diff --git a/.github/FUNDING.yml b/.github/FUNDING.yml new file mode 100644 index 000000000..f784c8faf --- /dev/null +++ b/.github/FUNDING.yml @@ -0,0 +1 @@ +custom: ['https://www.heidisql.com/donate.php'] diff --git a/.github/ISSUE_TEMPLATE/bug_report.md b/.github/ISSUE_TEMPLATE/bug_report.md deleted file mode 100644 index 6fe96ed2c..000000000 --- a/.github/ISSUE_TEMPLATE/bug_report.md +++ /dev/null @@ -1,29 +0,0 @@ ---- -name: Bug report -about: Create a report to help us improve -title: '' -labels: '' -assignees: '' - ---- - -**Describe the bug** -A clear and concise description of what the bug is. - -**To Reproduce** -Steps to reproduce the behavior: -1. Go to '...' -2. Click on '....' -3. Scroll down to '....' -4. See error - -**Expected behavior** -A clear and concise description of what you expected to happen. - -**Screenshots** -If applicable, add screenshots to help explain your problem. - -**Environment:** - - OS: [e.g. Windows 10, Ubuntu/Wine5.0] - - HeidiSQL version [e.g. 11.0.0.6050] - - Database type and version [e.g. MariaDB 10.3.12] diff --git a/.github/ISSUE_TEMPLATE/bug_report.yml b/.github/ISSUE_TEMPLATE/bug_report.yml new file mode 100644 index 000000000..386650a72 --- /dev/null +++ b/.github/ISSUE_TEMPLATE/bug_report.yml @@ -0,0 +1,36 @@ +name: Bug report +description: Create a report to help us improve +labels: ["bug"] +body: + - type: textarea + attributes: + label: Description + description: "A clear and concise description of what the bug is. Screenshots welcome!" + validations: + required: true + - type: input + id: heidisql_version + attributes: + label: HeidiSQL version and OS + placeholder: "Example: 12.15 Linux GTK2" + validations: + required: true + - type: input + id: database_software + attributes: + label: Database server version + placeholder: "Example: MariaDB 10.3.27, or just '-' if irrelevant" + validations: + required: true + - type: textarea + attributes: + label: Reproduction recipe + placeholder: "Instructions for reproducing the problem" + validations: + required: true + - type: textarea + id: error_log + attributes: + label: Error/Backtrace + placeholder: "Optional, attach or paste crash report here" + render: shell diff --git a/.github/ISSUE_TEMPLATE/feature_request.md b/.github/ISSUE_TEMPLATE/feature_request.md index bbcbbe7d6..181e2a1db 100644 --- a/.github/ISSUE_TEMPLATE/feature_request.md +++ b/.github/ISSUE_TEMPLATE/feature_request.md @@ -7,6 +7,11 @@ assignees: '' --- + + **Is your feature request related to a problem? Please describe.** A clear and concise description of what the problem is. Ex. I'm always frustrated when [...] diff --git a/.github/pull_request_template.md b/.github/pull_request_template.md new file mode 100644 index 000000000..b4193a36e --- /dev/null +++ b/.github/pull_request_template.md @@ -0,0 +1,5 @@ +* Pull requests will **only be accepted for bugfixes**. +* Pull requests introducing a new feature will be closed or ignored. +* Mention the ticket id in your pull request to which this is a bugfix. + +After reading the above requirements, just delete it. diff --git a/.gitignore b/.gitignore index f05a47d34..16c8d23ce 100644 --- a/.gitignore +++ b/.gitignore @@ -1,19 +1,20 @@ -*.exe -*.bpl -*.dcu -*.dcp -*.local -*.stat -*.skincfg -*.map -*.identcache -*.dsk -*.rsm -*.~* -*.drc -*.tvsconfig -__history -__recovery -*.mo -*.po -*.res \ No newline at end of file +*.exe +*.bpl +*.dcu +*.dcp +*.local +*.stat +*.skincfg +*.map +*.identcache +*.dsk +*.rsm +*.~* +*.drc +*.tvsconfig +__history +__recovery +*.mo +*.po +*.res +out/Backups/* \ No newline at end of file diff --git a/.tx/config b/.tx/config index 8cb4e5341..6e2802e7a 100644 --- a/.tx/config +++ b/.tx/config @@ -1,9 +1,10 @@ [main] -host = https://www.transifex.com +host = https://app.transifex.com -[heidisql.ui] -file_filter = out/locale//LC_MESSAGES/default.po -source_file = out/locale/en/LC_MESSAGES/default.po -source_lang = en -type = PO +[o:heidisql:p:heidisql:r:ui] +file_filter = out/locale//LC_MESSAGES/default.po +source_file = out/locale/en/LC_MESSAGES/default.po +source_lang = en +type = PO minimum_perc = 20 + diff --git a/SECURITY.md b/SECURITY.md new file mode 100644 index 000000000..2f52e4bc7 --- /dev/null +++ b/SECURITY.md @@ -0,0 +1,19 @@ +# Security Policy + +## Supported Versions + +Currently supported releases with security updates: + +| Version | Supported | +| ------- | ------------------ | +| 12.x | :white_check_mark: | +| < 12.x | :x: | + +## Reporting a Vulnerability + +When reporting a vulnerability, please file a ticket here. You may also send an +email to security@heidisql.com . + +It is important that the report is _valid_, and I am able to _understand_ the vulnerability impact. +If so, you may expect an update within weeks, probably quicker. I'll do my best to keep the +software and the user systems intact. diff --git a/build-res.bat b/build-res.bat index 1e69faa2e..200d9fa34 100644 --- a/build-res.bat +++ b/build-res.bat @@ -1,7 +1,11 @@ -brcc32 res\version.rc -cgrc res\icon.rc -brcc32 res\icon-question.rc -brcc32 res\manifest.rc -brcc32 -fores\updater.res res\updater32.rc -cgrc.exe res\styles.rc -pause +brcc32 res\version.rc +cgrc res\icon.rc +brcc32 res\icon-question.rc +brcc32 res\manifest.rc +brcc32 res\updater.rc +cgrc.exe res\styles.rc +brcc32.exe source\vcl-styles-utils\AwesomeFont.rc +brcc32.exe source\vcl-styles-utils\AwesomeFont_zip.rc +brcc32.exe res\updater\manifest.rc + +pause diff --git a/build.php b/build.php new file mode 100644 index 000000000..6d85508a3 --- /dev/null +++ b/build.php @@ -0,0 +1,243 @@ +> '.$command); + exec($command.' 2>&1', $output, $resultCode); + if(!$returnOutput) { + foreach ($output as $oline) { + dumpMessage('# ' . ($resultCode ? 'Error: ' : '') . $oline); + } + } + $success = $resultCode == 0; + if(!$success) { + dumpMessage('Last command failed, terminating.'); + exit(1); + } + return $returnOutput ? $output : $success; +} + + +/** + * Return file names from given directory, recursively + * @param string $path file path + * @param string $filepattern file pattern, e.g. "*.xml" + * @return array files + */ +function globRecursive(string $path, string $filepattern): array +{ + static $filecount=0; + $path = rtrim($path, '/\\'); + + // Find files in path + $files = glob($path . DS . $filepattern, GLOB_BRACE); + $filecount += count($files); + + // Find subdirectories in path, and do recursion + $dirs = glob($path . DS . '*', GLOB_ONLYDIR); + foreach($dirs as $d) + { + $files = array_merge($files, globRecursive($d, $filepattern)); + } + + return $files; +} + + +chdir(BASE_DIR); +dumpMessage('Detect Git revision...'); +$gitCommits = execCommand('git log --pretty=oneline', true); +if(empty($gitCommits)) { + die('No commits found.'); +} +$lastCommitRevision = count($gitCommits) + 671; // The number of earlier Subversion commits which I could not migrate to Git +$lastCommitHash = substr($gitCommits[0], 0, strpos($gitCommits[0], ' ')); + +// start the build process +dumpMessage('Compile commit '.$lastCommitHash.' (revision '.$lastCommitRevision.')', true); +chdir(BASE_DIR); + +dumpMessage('Remove unversioned files...'); +execCommand('git clean -dfx'); + +dumpMessage('Download fresh translation files ...', true); +execCommand('extra\\internationalization\\tx.exe pull -a'); + +dumpMessage('Compile .po translation files...'); +$po_files = globRecursive('out\\locale\\', '*.po'); +foreach($po_files as $po_file) +{ + $mo_file = preg_replace('#\.po$#', '.mo', $po_file); + execCommand('"extra\\internationalization\\msgfmt.exe" -o '.$mo_file.' '.$po_file); +} + +$compileBits = ['64']; + +foreach($compileBits as $bit) +{ + dumpMessage('********* Compile '.$bit.' bit executable', true); + chdir(BASE_DIR); + + compileComponent('synedit', 'SynEdit_R.dpk', $bit); + + compileComponent('virtualtreeview', 'VirtualTreesR.dpk', $bit); + + + chdir(BASE_DIR); + $versionFile = realpath('res\\version.rc'); + dumpMessage('Revert version resource file...', true); + execCommand('git checkout '.$versionFile); + dumpMessage('Modify version resource file...'); + $versionOriginal = file_get_contents($versionFile); + $versionRevision = preg_replace('#(FILEVERSION\s+\d+,\d+,\d+,)(\d+)(\b)#i', '${1}'.$lastCommitRevision.'$3', $versionOriginal); + $versionRevision = str_replace('%APPNAME%', APPNAME, $versionRevision); + preg_match('#FILEVERSION\s+(\d+),(\d+),(\d+),(\d+)\b#i', $versionRevision, $matches); + $shortVersion = $matches[1].'.'.$matches[2].'.'.$matches[3].'.'.$matches[4]; + $fullVersion = $shortVersion.' '.$bit.' Bit'; + $versionRevision = str_replace('%APPVER%', $fullVersion, $versionRevision); + file_put_contents($versionFile, $versionRevision); + + dumpMessage('Compile resource files...', true); + execCommand('"'.COMPILER_DIR . 'brcc32.exe" '.$versionFile); + execCommand('"'.COMPILER_DIR . 'cgrc.exe" res\\icon.rc'); + execCommand('"'.COMPILER_DIR . 'brcc32.exe" res\\icon-question.rc'); + execCommand('"'.COMPILER_DIR . 'brcc32.exe" res\\manifest.rc'); + execCommand('"'.COMPILER_DIR . 'brcc32.exe" res\\updater.rc'); + execCommand('"'.COMPILER_DIR . 'cgrc.exe" res\\styles.rc'); + execCommand('"'.COMPILER_DIR . 'brcc32.exe" source\\vcl-styles-utils\\AwesomeFont.rc'); + execCommand('"'.COMPILER_DIR . 'brcc32.exe" source\\vcl-styles-utils\\AwesomeFont_zip.rc'); + + dumpMessage('Compile main project...', true); + chdir(BASE_DIR.'packages\\'.PACKAGE_DIR); + execCommand(compilerCommand($bit, 'exe').' -E"'.BASE_DIR.'out" heidisql.dpr'); + + dumpMessage('Patch executable with .mo files...', true); + // Must be done before madExcept writes a new crc header, otherwise it will complain about a corrupt .exe + // See http://tech.dir.groups.yahoo.com/group/dxgettext/message/3623 + chdir(BASE_DIR); + execCommand('extra\\internationalization\\assemble.exe out\\'.BIN_NAME.'.exe --dxgettext'); + + dumpMessage('Patch executable with exception handler...', true); + chdir(BASE_DIR.'packages\\'.PACKAGE_DIR); + execCommand('"'.MAD_DIR.'madExcept\\Tools\\madExceptPatch.exe" "'.BASE_DIR.'out\\'.BIN_NAME.'.exe" heidisql.mes'); + + chdir(BASE_DIR); + $renameTo = sprintf('out\\%s%d.exe', BIN_NAME, $bit); + dumpMessage('Rename to '.$renameTo.'...', true); + rename('out\\'.BIN_NAME.'.exe', $renameTo); + +} + + +chdir($start_dir); + diff --git a/components/synedit/Packages/Delphi10.4/SynEdit_R.dproj b/components/synedit/Packages/Delphi10.4/SynEdit_R.dproj deleted file mode 100644 index 712edc356..000000000 --- a/components/synedit/Packages/Delphi10.4/SynEdit_R.dproj +++ /dev/null @@ -1,268 +0,0 @@ - - - {AC917C2B-5870-48AD-981D-668AD3E4A533} - SynEdit_R.dpk - True - Debug - 3 - Package - VCL - 19.0 - Win64 - - - true - - - true - Base - true - - - true - Base - true - - - true - Base - true - - - true - Base - true - - - true - Cfg_2 - true - true - - - SynEdit_R - ..\..\build\$(Platform) - true - true - CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= - 00400000 - true - Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;Winapi;System.Win;Bde;$(DCC_Namespace) - SynEdit component suite runtime - true - false - false - true - false - 1031 - false - false - - - Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;$(DCC_Namespace) - true - 1033 - - - Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;$(DCC_Namespace) - 1033 - true - - - false - 0 - 0 - RELEASE;$(DCC_Define) - - - DEBUG;$(DCC_Define) - false - true - - - true - 1033 - - - - MainSource - - - - - - - - -
frmAutoCorrectEditor
- - - - - - - - - - - -
SynEditKeystrokeEditorForm
- - - -
SynEditKeystrokesEditorForm
- - - - - -
fmEditorOptionsDialog
- - - - - - - - -
SynEditPrintMarginsDlg
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
$ENDIF
- - - - - - Cfg_2 - Base - - - Base - - - Cfg_1 - Base - - - - Delphi.Personality.12 - Package - - - - SynEdit_R.dpk - - - True - False - 1 - 0 - 0 - 0 - False - False - False - False - False - 1031 - 1252 - - - - - 1.0.0.0 - - - - - - 1.0.0.0 - - - - - True - True - - - 12 - - - - diff --git a/components/synedit/Packages/Delphi10.4/SynEdit.groupproj b/components/synedit/Packages/Delphi12.3/SynEdit.groupproj similarity index 100% rename from components/synedit/Packages/Delphi10.4/SynEdit.groupproj rename to components/synedit/Packages/Delphi12.3/SynEdit.groupproj diff --git a/components/synedit/Packages/Delphi10.4/SynEdit_D.dpk b/components/synedit/Packages/Delphi12.3/SynEdit_D.dpk similarity index 100% rename from components/synedit/Packages/Delphi10.4/SynEdit_D.dpk rename to components/synedit/Packages/Delphi12.3/SynEdit_D.dpk diff --git a/components/synedit/Packages/Delphi10.4/SynEdit_D.dproj b/components/synedit/Packages/Delphi12.3/SynEdit_D.dproj similarity index 78% rename from components/synedit/Packages/Delphi10.4/SynEdit_D.dproj rename to components/synedit/Packages/Delphi12.3/SynEdit_D.dproj index d407c7465..055e92a4b 100644 --- a/components/synedit/Packages/Delphi10.4/SynEdit_D.dproj +++ b/components/synedit/Packages/Delphi12.3/SynEdit_D.dproj @@ -7,8 +7,9 @@ 1 Package None - 19.0 + 20.3 Win32 + SynEdit_D true @@ -18,6 +19,16 @@ Base true + + true + Base + true + + + true + Base + true + true Base @@ -58,6 +69,20 @@ true 1033 + + System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;$(DCC_Namespace) + Debug + true + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProgramID=com.embarcadero.$(MSBuildProjectName);ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments= + 1033 + + + System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;$(DCC_Namespace) + Debug + true + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProgramID=com.embarcadero.$(MSBuildProjectName);ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments= + 1033 + false 0 @@ -83,10 +108,6 @@ - - Cfg_2 - Base - Base @@ -94,6 +115,10 @@ Cfg_1 Base + + Cfg_2 + Base + Delphi.Personality.12 @@ -134,6 +159,7 @@ True False + False 12 diff --git a/components/synedit/Packages/Delphi10.4/SynEdit_R.dpk b/components/synedit/Packages/Delphi12.3/SynEdit_R.dpk similarity index 94% rename from components/synedit/Packages/Delphi10.4/SynEdit_R.dpk rename to components/synedit/Packages/Delphi12.3/SynEdit_R.dpk index 8be3c4f06..70a1407d8 100644 --- a/components/synedit/Packages/Delphi10.4/SynEdit_R.dpk +++ b/components/synedit/Packages/Delphi12.3/SynEdit_R.dpk @@ -46,6 +46,7 @@ contains SynEditDocumentManager in '..\..\Source\SynEditDocumentManager.pas', SynEditExport in '..\..\Source\SynEditExport.pas', SynEditHighlighter in '..\..\Source\SynEditHighlighter.pas', + SynEditHighlighterOptions in '..\..\Source\SynEditHighlighterOptions.pas', SynEditKbdHandler in '..\..\Source\SynEditKbdHandler.pas', SynEditKeyCmdEditor in '..\..\Source\SynEditKeyCmdEditor.pas' {SynEditKeystrokeEditorForm}, SynEditKeyCmds in '..\..\Source\SynEditKeyCmds.pas', @@ -55,7 +56,6 @@ contains SynEditMiscProcs in '..\..\Source\SynEditMiscProcs.pas', SynEditOptionsDialog in '..\..\Source\SynEditOptionsDialog.pas' {fmEditorOptionsDialog}, SynEditPlugins in '..\..\Source\SynEditPlugins.pas', - SynEditWordWrap in '..\..\Source\SynEditWordWrap.pas', SynEditPrint in '..\..\Source\SynEditPrint.pas', SynEditPrinterInfo in '..\..\Source\SynEditPrinterInfo.pas', SynEditPrintHeaderFooter in '..\..\Source\SynEditPrintHeaderFooter.pas', @@ -69,11 +69,13 @@ contains SynEditStrConst in '..\..\Source\SynEditStrConst.pas', SynEditTextBuffer in '..\..\Source\SynEditTextBuffer.pas', SynEditTypes in '..\..\Source\SynEditTypes.pas', + SynEditWordWrap in '..\..\Source\SynEditWordWrap.pas', SynExportHTML in '..\..\Source\SynExportHTML.pas', SynExportRTF in '..\..\Source\SynExportRTF.pas', SynExportTeX in '..\..\Source\SynExportTeX.pas', SynHighlighterADSP21xx in '..\..\Source\SynHighlighterADSP21xx.pas', SynHighlighterAsm in '..\..\Source\SynHighlighterAsm.pas', + SynHighlighterAsmMASM in '..\..\Source\SynHighlighterAsmMASM.pas', SynHighlighterAWK in '..\..\Source\SynHighlighterAWK.pas', SynHighlighterBaan in '..\..\Source\SynHighlighterBaan.pas', SynHighlighterBat in '..\..\Source\SynHighlighterBat.pas', @@ -83,13 +85,19 @@ contains SynHighlighterCPM in '..\..\Source\SynHighlighterCPM.pas', SynHighlighterCpp in '..\..\Source\SynHighlighterCpp.pas', SynHighlighterCS in '..\..\Source\SynHighlighterCS.pas', + SynHighlighterCss in '..\..\Source\SynHighlighterCss.pas', SynHighlighterDfm in '..\..\Source\SynHighlighterDfm.pas', SynHighlighterDml in '..\..\Source\SynHighlighterDml.pas', + SynHighlighterDOT in '..\..\Source\SynHighlighterDOT.pas', + SynHighlighterDWS in '..\..\Source\SynHighlighterDWS.pas', + SynHighlighterECMAScript in '..\..\Source\SynHighlighterECMAScript.pas', + SynHighlighterEiffel in '..\..\Source\SynHighlighterEiffel.pas', SynHighlighterFortran in '..\..\Source\SynHighlighterFortran.pas', SynHighlighterFoxpro in '..\..\Source\SynHighlighterFoxpro.pas', SynHighlighterGalaxy in '..\..\Source\SynHighlighterGalaxy.pas', SynHighlighterGeneral in '..\..\Source\SynHighlighterGeneral.pas', SynHighlighterGLSL in '..\..\Source\SynHighlighterGLSL.pas', + SynHighlighterGo in '..\..\Source\SynHighlighterGo.pas', SynHighlighterGWS in '..\..\Source\SynHighlighterGWS.pas', SynHighlighterHashEntries in '..\..\Source\SynHighlighterHashEntries.pas', SynHighlighterHaskell in '..\..\Source\SynHighlighterHaskell.pas', @@ -103,6 +111,8 @@ contains SynHighlighterJScript in '..\..\Source\SynHighlighterJScript.pas', SynHighlighterJSON in '..\..\Source\SynHighlighterJSON.pas', SynHighlighterKix in '..\..\Source\SynHighlighterKix.pas', + SynHighlighterLDraw in '..\..\Source\SynHighlighterLDraw.pas', + SynHighlighterLLVM in '..\..\Source\SynHighlighterLLVM.pas', SynHighlighterM3 in '..\..\Source\SynHighlighterM3.pas', SynHighlighterModelica in '..\..\Source\SynHighlighterModelica.pas', SynHighlighterMsg in '..\..\Source\SynHighlighterMsg.pas', @@ -113,6 +123,7 @@ contains SynHighlighterProgress in '..\..\Source\SynHighlighterProgress.pas', SynHighlighterPython in '..\..\Source\SynHighlighterPython.pas', SynHighlighterRC in '..\..\Source\SynHighlighterRC.pas', + SynHighlighterRexx in '..\..\Source\SynHighlighterRexx.pas', SynHighlighterRuby in '..\..\Source\SynHighlighterRuby.pas', SynHighlighterSDD in '..\..\Source\SynHighlighterSDD.pas', SynHighlighterSml in '..\..\Source\SynHighlighterSml.pas', @@ -122,24 +133,18 @@ contains SynHighlighterTeX in '..\..\Source\SynHighlighterTeX.pas', SynHighlighterUNIXShellScript in '..\..\Source\SynHighlighterUNIXShellScript.pas', SynHighlighterUnreal in '..\..\Source\SynHighlighterUnreal.pas', + SynHighlighterURI in '..\..\Source\SynHighlighterURI.pas', SynHighlighterVB in '..\..\Source\SynHighlighterVB.pas', SynHighlighterVBScript in '..\..\Source\SynHighlighterVBScript.pas', + SynHighlighterVrml97 in '..\..\Source\SynHighlighterVrml97.pas', + SynHighlighterWebIDL in '..\..\Source\SynHighlighterWebIDL.pas', SynHighlighterXML in '..\..\Source\SynHighlighterXML.pas', + SynHighlighterZPL in '..\..\Source\SynHighlighterZPL.pas', SynMacroRecorder in '..\..\Source\SynMacroRecorder.pas', SynMemo in '..\..\Source\SynMemo.pas', SynRegExpr in '..\..\Source\SynRegExpr.pas', - SynHighlighterCss in '..\..\Source\SynHighlighterCss.pas', - SynHighlighterLDraw in '..\..\Source\SynHighlighterLDraw.pas', - SynHighlighterURI in '..\..\Source\SynHighlighterURI.pas', SynURIOpener in '..\..\Source\SynURIOpener.pas', - SynHighlighterDOT in '..\..\Source\SynHighlighterDOT.pas', - SynHighlighterDWS in '..\..\Source\SynHighlighterDWS.pas', - SynHighlighterVrml97 in '..\..\Source\SynHighlighterVrml97.pas', - SynHighlighterEiffel in '..\..\Source\SynHighlighterEiffel.pas', SynUnicode in '..\..\Source\SynUnicode.pas' {$IFNDEF CPUX64}, - SynUsp10 in '..\..\Source\SynUsp10.pas' {$ENDIF}, - SynEditHighlighterOptions in '..\..\Source\SynEditHighlighterOptions.pas', - SynHighlighterAsmMASM in '..\..\Source\SynHighlighterAsmMASM.pas', - SynHighlighterGo in '..\..\Source\SynHighlighterGo.pas'; + SynUsp10 in '..\..\Source\SynUsp10.pas' {$ENDIF}; end. diff --git a/components/synedit/Packages/Delphi12.3/SynEdit_R.dproj b/components/synedit/Packages/Delphi12.3/SynEdit_R.dproj new file mode 100644 index 000000000..fb7620b38 --- /dev/null +++ b/components/synedit/Packages/Delphi12.3/SynEdit_R.dproj @@ -0,0 +1,1152 @@ + + + {AC917C2B-5870-48AD-981D-668AD3E4A533} + SynEdit_R.dpk + True + Debug + 3 + Package + VCL + 20.1 + Win32 + SynEdit_R + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_2 + true + true + + + SynEdit_R + ..\..\build\$(Platform) + true + true + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= + 00400000 + true + Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;Winapi;System.Win;Bde;$(DCC_Namespace) + SynEdit component suite runtime + true + false + false + true + false + 1031 + false + false + + + Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;$(DCC_Namespace) + true + 1033 + + + Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;$(DCC_Namespace) + 1033 + true + + + Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;$(DCC_Namespace) + Debug + true + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProgramID=com.embarcadero.$(MSBuildProjectName);ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments= + 1033 + + + false + 0 + 0 + RELEASE;$(DCC_Define) + + + DEBUG;$(DCC_Define) + false + true + + + true + 1033 + false + + + + MainSource + + + + + + + + +
frmAutoCorrectEditor
+ + + + + + + + + + + + +
SynEditKeystrokeEditorForm
+ + + +
SynEditKeystrokesEditorForm
+ + + + + +
fmEditorOptionsDialog
+ + + + + + + +
SynEditPrintMarginsDlg
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
$IFNDEF CPUX64
+ + +
$ENDIF
+ + + Base + + + Cfg_1 + Base + + + Cfg_2 + Base + + + + Delphi.Personality.12 + Package + + + + SynEdit_R.dpk + + + True + False + 1 + 0 + 0 + 0 + False + False + False + False + False + 1031 + 1252 + + + + + 1.0.0.0 + + + + + + 1.0.0.0 + + + + Microsoft Office 2000 Sample Automation Server Wrapper Components + Microsoft Office XP Sample Automation Server Wrapper Components + + + + True + True + False + + + + + + + 1 + + + 0 + + + + + res\xml + 1 + + + res\xml + 1 + + + + + library\lib\armeabi + 1 + + + library\lib\armeabi + 1 + + + + + library\lib\armeabi-v7a + 1 + + + + + library\lib\mips + 1 + + + library\lib\mips + 1 + + + + + library\lib\armeabi-v7a + 1 + + + library\lib\arm64-v8a + 1 + + + + + library\lib\armeabi-v7a + 1 + + + + + res\drawable + 1 + + + res\drawable + 1 + + + + + res\drawable-anydpi-v21 + 1 + + + res\drawable-anydpi-v21 + 1 + + + + + res\values + 1 + + + res\values + 1 + + + + + res\values-v21 + 1 + + + res\values-v21 + 1 + + + + + res\values-v31 + 1 + + + res\values-v31 + 1 + + + + + res\values-v35 + 1 + + + res\values-v35 + 1 + + + + + res\drawable-anydpi-v26 + 1 + + + res\drawable-anydpi-v26 + 1 + + + + + res\drawable + 1 + + + res\drawable + 1 + + + + + res\drawable + 1 + + + res\drawable + 1 + + + + + res\drawable + 1 + + + res\drawable + 1 + + + + + res\drawable-anydpi-v33 + 1 + + + res\drawable-anydpi-v33 + 1 + + + + + res\values + 1 + + + res\values + 1 + + + + + res\values-night-v21 + 1 + + + res\values-night-v21 + 1 + + + + + res\drawable + 1 + + + res\drawable + 1 + + + + + res\drawable-xxhdpi + 1 + + + res\drawable-xxhdpi + 1 + + + + + res\drawable-xxxhdpi + 1 + + + res\drawable-xxxhdpi + 1 + + + + + res\drawable-ldpi + 1 + + + res\drawable-ldpi + 1 + + + + + res\drawable-mdpi + 1 + + + res\drawable-mdpi + 1 + + + + + res\drawable-hdpi + 1 + + + res\drawable-hdpi + 1 + + + + + res\drawable-xhdpi + 1 + + + res\drawable-xhdpi + 1 + + + + + res\drawable-mdpi + 1 + + + res\drawable-mdpi + 1 + + + + + res\drawable-hdpi + 1 + + + res\drawable-hdpi + 1 + + + + + res\drawable-xhdpi + 1 + + + res\drawable-xhdpi + 1 + + + + + res\drawable-xxhdpi + 1 + + + res\drawable-xxhdpi + 1 + + + + + res\drawable-xxxhdpi + 1 + + + res\drawable-xxxhdpi + 1 + + + + + res\drawable-small + 1 + + + res\drawable-small + 1 + + + + + res\drawable-normal + 1 + + + res\drawable-normal + 1 + + + + + res\drawable-large + 1 + + + res\drawable-large + 1 + + + + + res\drawable-xlarge + 1 + + + res\drawable-xlarge + 1 + + + + + res\values + 1 + + + res\values + 1 + + + + + res\drawable-anydpi-v24 + 1 + + + res\drawable-anydpi-v24 + 1 + + + + + res\drawable + 1 + + + res\drawable + 1 + + + + + res\drawable-night-anydpi-v21 + 1 + + + res\drawable-night-anydpi-v21 + 1 + + + + + res\drawable-anydpi-v31 + 1 + + + res\drawable-anydpi-v31 + 1 + + + + + res\drawable-night-anydpi-v31 + 1 + + + res\drawable-night-anydpi-v31 + 1 + + + + + 1 + + + 1 + + + 0 + + + + + 1 + .framework + + + 1 + .framework + + + 1 + .framework + + + 0 + + + + + 1 + .dylib + + + 1 + .dylib + + + 1 + .dylib + + + 0 + .dll;.bpl + + + + + 1 + .dylib + + + 1 + .dylib + + + 1 + .dylib + + + 1 + .dylib + + + 1 + .dylib + + + 1 + .dylib + + + 0 + .bpl + + + + + 0 + + + 0 + + + 0 + + + 0 + + + 0 + + + 0 + + + 0 + + + 0 + + + 0 + + + + + 1 + + + 1 + + + + + + + + Contents\Resources + 1 + + + Contents\Resources + 1 + + + Contents\Resources + 1 + + + + + library\lib\armeabi-v7a + 1 + + + library\lib\arm64-v8a + 1 + + + 1 + + + 1 + + + 1 + + + 1 + + + 1 + + + 1 + + + 1 + + + 0 + + + + + library\lib\armeabi-v7a + 1 + + + + + 1 + + + 1 + + + 1 + + + + + ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF + 1 + + + ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF + 1 + + + ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF + 1 + + + + + + + + 1 + + + 1 + + + 1 + + + + + Assets + 1 + + + Assets + 1 + + + + + Assets + 1 + + + Assets + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + + + + + + + + + + + + + + 12 + + + + + diff --git a/components/synedit/Source/SynCompletionProposal.pas b/components/synedit/Source/SynCompletionProposal.pas index 8d6bdf2c8..9c5b7da39 100644 --- a/components/synedit/Source/SynCompletionProposal.pas +++ b/components/synedit/Source/SynCompletionProposal.pas @@ -45,7 +45,7 @@ unit SynCompletionProposal; {$ENDIF} -{$I SynEdit.Inc} +{$I SynEdit.inc} interface @@ -2722,9 +2722,14 @@ function TSynBaseCompletionProposal.GetDefaultKind: SynCompletionType; procedure TSynBaseCompletionProposal.SetDefaultKind(const Value: SynCompletionType); begin - Form.DefaultType := Value; - Form.DisplayType := Value; - Form.RecreateWnd; + if Form.DefaultType <> Value then begin + Form.DefaultType := Value; + Form.DisplayType := Value; + if Form.HandleAllocated then + Form.RecreateWnd; + end + else + Form.DisplayType := Value; end; procedure TSynBaseCompletionProposal.SetEndOfTokenChar( diff --git a/components/synedit/Source/SynEdit.inc b/components/synedit/Source/SynEdit.inc index 61ddab613..bd2ba75a9 100644 --- a/components/synedit/Source/SynEdit.inc +++ b/components/synedit/Source/SynEdit.inc @@ -120,6 +120,10 @@ (* SYN_DELPHI_10_2_UP : Delphi RX 10.2 or higher is being used. *) (* SYN_DELPHI_10_3 : Delphi RX 10.3 (Rio) is being used. *) (* SYN_DELPHI_10_3_UP : Delphi RX 10.3 or higher is being used. *) +(* SYN_DELPHI_10_4 : Delphi RX 10.4 (Sydney) is being used. *) +(* SYN_DELPHI_10_4_UP : Delphi RX 10.4 or higher is being used. *) +(* SYN_DELPHI_11 : Delphi RX 11 (Alexandrai) is being used. *) +(* SYN_DELPHI_11_UP : Delphi RX 11 or higher is being used. *) (* SYN_KYLIX : Kylix 1.0 is being using. *) (******************************************************************************) @@ -161,6 +165,18 @@ { VERXXX to SYN_COMPILERX, SYN_DELPHIX and SYN_CPPBX mappings } {------------------------------------------------------------------------------} +{$IFDEF VER360} + {$DEFINE SYN_COMPILER_29} + {$DEFINE SYN_DELPHI} + {$DEFINE SYN_DELPHI_12} +{$ENDIF} + +{$IFDEF VER350} + {$DEFINE SYN_COMPILER_28} + {$DEFINE SYN_DELPHI} + {$DEFINE SYN_DELPHI_11} +{$ENDIF} + {$IFDEF VER340} {$DEFINE SYN_COMPILER_27} {$DEFINE SYN_DELPHI} @@ -769,6 +785,67 @@ {$DEFINE SYN_COMPILER_27_UP} {$ENDIF} +{$IFDEF SYN_COMPILER_28} + {$DEFINE SYN_COMPILER_1_UP} + {$DEFINE SYN_COMPILER_2_UP} + {$DEFINE SYN_COMPILER_3_UP} + {$DEFINE SYN_COMPILER_4_UP} + {$DEFINE SYN_COMPILER_5_UP} + {$DEFINE SYN_COMPILER_6_UP} + {$DEFINE SYN_COMPILER_7_UP} + {$DEFINE SYN_COMPILER_8_UP} + {$DEFINE SYN_COMPILER_9_UP} + {$DEFINE SYN_COMPILER_10_UP} + {$DEFINE SYN_COMPILER_11_UP} + {$DEFINE SYN_COMPILER_12_UP} + {$DEFINE SYN_COMPILER_14_UP} + {$DEFINE SYN_COMPILER_15_UP} + {$DEFINE SYN_COMPILER_16_UP} + {$DEFINE SYN_COMPILER_17_UP} + {$DEFINE SYN_COMPILER_18_UP} + {$DEFINE SYN_COMPILER_19_UP} + {$DEFINE SYN_COMPILER_20_UP} + {$DEFINE SYN_COMPILER_21_UP} + {$DEFINE SYN_COMPILER_22_UP} + {$DEFINE SYN_COMPILER_23_UP} + {$DEFINE SYN_COMPILER_24_UP} + {$DEFINE SYN_COMPILER_25_UP} + {$DEFINE SYN_COMPILER_26_UP} + {$DEFINE SYN_COMPILER_27_UP} + {$DEFINE SYN_COMPILER_28_UP} +{$ENDIF} + +{$IFDEF SYN_COMPILER_29} + {$DEFINE SYN_COMPILER_1_UP} + {$DEFINE SYN_COMPILER_2_UP} + {$DEFINE SYN_COMPILER_3_UP} + {$DEFINE SYN_COMPILER_4_UP} + {$DEFINE SYN_COMPILER_5_UP} + {$DEFINE SYN_COMPILER_6_UP} + {$DEFINE SYN_COMPILER_7_UP} + {$DEFINE SYN_COMPILER_8_UP} + {$DEFINE SYN_COMPILER_9_UP} + {$DEFINE SYN_COMPILER_10_UP} + {$DEFINE SYN_COMPILER_11_UP} + {$DEFINE SYN_COMPILER_12_UP} + {$DEFINE SYN_COMPILER_14_UP} + {$DEFINE SYN_COMPILER_15_UP} + {$DEFINE SYN_COMPILER_16_UP} + {$DEFINE SYN_COMPILER_17_UP} + {$DEFINE SYN_COMPILER_18_UP} + {$DEFINE SYN_COMPILER_19_UP} + {$DEFINE SYN_COMPILER_20_UP} + {$DEFINE SYN_COMPILER_21_UP} + {$DEFINE SYN_COMPILER_22_UP} + {$DEFINE SYN_COMPILER_23_UP} + {$DEFINE SYN_COMPILER_24_UP} + {$DEFINE SYN_COMPILER_25_UP} + {$DEFINE SYN_COMPILER_26_UP} + {$DEFINE SYN_COMPILER_27_UP} + {$DEFINE SYN_COMPILER_28_UP} + {$DEFINE SYN_COMPILER_29_UP} +{$ENDIF} + {$IFDEF SYN_DELPHI_2} {$DEFINE SYN_DELPHI_2_UP} @@ -1166,6 +1243,63 @@ {$DEFINE SYN_DELPHI_10_4_UP} {$ENDIF} +{$IFDEF SYN_DELPHI_11} + {$DEFINE SYN_DELPHI_2_UP} + {$DEFINE SYN_DELPHI_3_UP} + {$DEFINE SYN_DELPHI_4_UP} + {$DEFINE SYN_DELPHI_5_UP} + {$DEFINE SYN_DELPHI_6_UP} + {$DEFINE SYN_DELPHI_7_UP} + {$DEFINE SYN_DELPHI_8_UP} + {$DEFINE SYN_DELPHI_2005_UP} + {$DEFINE SYN_DELPHI_2006_UP} + {$DEFINE SYN_DELPHI_2007_UP} + {$DEFINE SYN_DELPHI_2009_UP} + {$DEFINE SYN_DELPHI_2010_UP} + {$DEFINE SYN_DELPHI_XE_UP} + {$DEFINE SYN_DELPHI_XE2_UP} + {$DEFINE SYN_DELPHI_XE3_UP} + {$DEFINE SYN_DELPHI_XE4_UP} + {$DEFINE SYN_DELPHI_XE5_UP} + {$DEFINE SYN_DELPHI_XE6_UP} + {$DEFINE SYN_DELPHI_XE7_UP} + {$DEFINE SYN_DELPHI_XE8_UP} + {$DEFINE SYN_DELPHI_10_1_UP} + {$DEFINE SYN_DELPHI_10_2_UP} + {$DEFINE SYN_DELPHI_10_3_UP} + {$DEFINE SYN_DELPHI_10_4_UP} + {$DEFINE SYN_DELPHI_11_UP} +{$ENDIF} + +{$IFDEF SYN_DELPHI_12} + {$DEFINE SYN_DELPHI_2_UP} + {$DEFINE SYN_DELPHI_3_UP} + {$DEFINE SYN_DELPHI_4_UP} + {$DEFINE SYN_DELPHI_5_UP} + {$DEFINE SYN_DELPHI_6_UP} + {$DEFINE SYN_DELPHI_7_UP} + {$DEFINE SYN_DELPHI_8_UP} + {$DEFINE SYN_DELPHI_2005_UP} + {$DEFINE SYN_DELPHI_2006_UP} + {$DEFINE SYN_DELPHI_2007_UP} + {$DEFINE SYN_DELPHI_2009_UP} + {$DEFINE SYN_DELPHI_2010_UP} + {$DEFINE SYN_DELPHI_XE_UP} + {$DEFINE SYN_DELPHI_XE2_UP} + {$DEFINE SYN_DELPHI_XE3_UP} + {$DEFINE SYN_DELPHI_XE4_UP} + {$DEFINE SYN_DELPHI_XE5_UP} + {$DEFINE SYN_DELPHI_XE6_UP} + {$DEFINE SYN_DELPHI_XE7_UP} + {$DEFINE SYN_DELPHI_XE8_UP} + {$DEFINE SYN_DELPHI_10_1_UP} + {$DEFINE SYN_DELPHI_10_2_UP} + {$DEFINE SYN_DELPHI_10_3_UP} + {$DEFINE SYN_DELPHI_10_4_UP} + {$DEFINE SYN_DELPHI_11_UP} + {$DEFINE SYN_DELPHI_12_UP} +{$ENDIF} + {$IFDEF SYN_CPPB_6} {$DEFINE SYN_CPPB_3_UP} {$DEFINE SYN_CPPB_4_UP} diff --git a/components/synedit/Source/SynEdit.pas b/components/synedit/Source/SynEdit.pas index 82ea79ea2..385933818 100644 --- a/components/synedit/Source/SynEdit.pas +++ b/components/synedit/Source/SynEdit.pas @@ -110,6 +110,21 @@ interface SYNEDIT_CLIPBOARD_FORMAT = 'SynEdit Control Block Type'; + // Reconversion string. + IMR_COMPOSITIONWINDOW = $0001; + IMR_CANDIDATEWINDOW = $0002; + IMR_COMPOSITIONFONT = $0003; + IMR_RECONVERTSTRING = $0004; + IMR_CONFIRMRECONVERTSTRING = $0005; + IMR_QUERYCHARPOSITION = $0006; + IMR_DOCUMENTFEED = $0007; + + SCS_SETSTR = GCS_COMPREADSTR or GCS_COMPSTR; + SCS_CHANGEATTR = GCS_COMPREADATTR or GCS_COMPATTR; + SCS_CHANGECLAUSE = GCS_COMPREADCLAUSE or GCS_COMPCLAUSE; + SCS_SETRECONVERTSTRING = $00010000; + SCS_QUERYRECONVERTSTRING = $00020000; + var SynEditClipboardFormat: UINT; @@ -342,6 +357,20 @@ TSynEditPlugin = class(TObject) FindText: UnicodeString) of object; {$ENDIF} + // Reconversion string. + PReconvertString = ^TReconvertString; + TReconvertString = record + dwSize: DWord; + dwVersion: DWord; + dwStrLen: DWord; + dwStrOffset: DWord; + dwCompStrLen: DWord; + dwCompStrOffset: DWord; + dwTargetStrLen: DWord; + dwTargetStrOffset: DWord; + end; + + TCustomSynEdit = class(TCustomControl) private procedure CMHintShow(var Msg: TMessage); message CM_HINTSHOW; @@ -363,6 +392,7 @@ TCustomSynEdit = class(TCustomControl) procedure WMImeChar(var Msg: TMessage); message WM_IME_CHAR; procedure WMImeComposition(var Msg: TMessage); message WM_IME_COMPOSITION; procedure WMImeNotify(var Msg: TMessage); message WM_IME_NOTIFY; + procedure WMImeRequest(var Message: TMessage); message WM_IME_REQUEST; procedure WMKillFocus(var Msg: TWMKillFocus); message WM_KILLFOCUS; procedure WMSetCursor(var Msg: TWMSetCursor); message WM_SETCURSOR; procedure WMSetFocus(var Msg: TWMSetFocus); message WM_SETFOCUS; @@ -4925,6 +4955,7 @@ procedure TCustomSynEdit.UpdateCaret; vCaretDisplay: TDisplayCoord; vCaretPix: TPoint; cf: TCompositionForm; + vSelStartPix: TPoint; begin if (PaintLock <> 0) or not (Focused or FAlwaysShowCaret) then Include(FStateFlags, sfCaretChanged) @@ -4950,9 +4981,17 @@ procedure TCustomSynEdit.UpdateCaret; SetCaretPos(CX, CY); HideCaret; end; - cf.dwStyle := CFS_POINT; - cf.ptCurrentPos := Point(CX, CY); - ImmSetCompositionWindow(ImmGetContext(Handle), @cf); + if (Self.SelAvail = False) then + begin + cf.dwStyle := CFS_POINT; + cf.ptCurrentPos := Point(CX, CY); + ImmSetCompositionWindow(ImmGetContext(Handle), @cf); + end + else + begin + vSelStartPix := Self.RowColumnToPixels(BufferToDisplayPos(Self.BlockBegin)); + Self.SetImeCompositionWindow(Self.Font, vSelStartPix.X, vSelStartPix.Y); + end; end; end; @@ -5434,6 +5473,113 @@ procedure TCustomSynEdit.WMImeNotify(var Msg: TMessage); inherited; end; +procedure TCustomSynEdit.WMImeRequest(var Message: TMessage); +var + pReconvert: PReconvertString; + TargetText: string; + TargetByteLength: Integer; + pTarget: PChar; + H: HIMC; +begin + case Message.WParam of + IMR_RECONVERTSTRING: + begin + // Reconversion string + if (Self.SelLength <> 0) then + begin + TargetText := Self.SelText; + end + else + begin + if (Self.Lines.Count >= Self.CaretY - 1) then + TargetText := Self.Lines[Self.CaretY - 1] + else + TargetText := ''; + end; + TargetByteLength := Length(TargetText) * sizeof(Char); + + if (Message.LParam = 0) then + begin + // 1st time (get buffer size (bytes)) + // Select only one row + if (Self.BlockBegin.Line = Self.BlockEnd.Line) then + Message.Result := Sizeof(TReconvertString) + TargetByteLength + else + Message.Result := 0; + end + else + begin + // 2nd time + pReconvert := Pointer(Message.LParam); + pReconvert.dwSize := Sizeof(TReconvertString); + pReconvert.dwVersion := 0; + pReconvert.dwStrLen := Length(TargetText); + pReconvert.dwStrOffset := Sizeof(TReconvertString); + + pTarget := Pointer(Message.LParam + Sizeof(TReconvertString)); + move(TargetText[1], pTarget^, TargetByteLength); + + if (Self.SelLength <> 0) then + begin + pReconvert.dwTargetStrLen := 0; + pReconvert.dwTargetStrOffset := 0; + pReconvert.dwCompStrLen := Length(TargetText); + pReconvert.dwCompStrOffset := 0; + end + else + begin + pReconvert.dwTargetStrLen := 0; + pReconvert.dwTargetStrOffset := (Self.CaretX - 1) * sizeof(Char); + H := Imm32GetContext(Handle); + try + ImmSetCompositionString(H, SCS_QUERYRECONVERTSTRING, pReconvert, Sizeof(TReconvertString) + TargetByteLength, nil, 0); + if (pReconvert.dwCompStrLen <> 0) then + begin + Self.CaretX := pReconvert.dwCompStrOffset div sizeof(Char) + 1; + Self.SelStart := RowColToCharIndex(Self.CaretXY); + Self.SelLength := pReconvert.dwCompStrLen; + end; + finally + Imm32ReleaseContext(Handle, H); + end; + end; + Message.Result := Sizeof(TReconvertString) + TargetByteLength; + end; + end; + IMR_DOCUMENTFEED: + begin + // Notifies an application when the selected IME needs the converted string from the application. + if (Self.Lines.Count >= Self.CaretY) then + TargetText := Self.Lines[Self.CaretY] + else + TargetText := ''; + if (Message.LParam = 0) then + begin + // 1st time (get line size (bytes)) + Message.Result := Sizeof(TReconvertString) + Length(TargetText) * sizeof(Char); + end + else + begin + // 2nd time + pReconvert := Pointer(Message.LParam); + pReconvert.dwSize := Sizeof(TReconvertString); + pReconvert.dwVersion := 0; + pReconvert.dwStrLen := Length(TargetText); + pReconvert.dwStrOffset := Sizeof(TReconvertString); + pReconvert.dwCompStrLen := 0; + pReconvert.dwCompStrOffset := 0; + pReconvert.dwTargetStrLen := 0; + pReconvert.dwTargetStrOffset := (Self.CaretX - 1) * sizeof(Char); + + pTarget := Pointer(Message.LParam + Sizeof(TReconvertString)); + move(TargetText[1], pTarget^, Length(TargetText) * sizeof(Char)); + + Message.Result := Sizeof(TReconvertString) + Length(TargetText) * sizeof(Char); + end; + end; + end; +end; + procedure TCustomSynEdit.WMKillFocus(var Msg: TWMKillFocus); begin inherited; @@ -8172,11 +8318,13 @@ procedure TCustomSynEdit.ExecuteCommand(Command: TSynEditorCommand; AChar: WideC begin BeginUndoBlock; try - FUndoList.AddChange(crDelete, FBlockBegin, FBlockEnd, Helper, + FUndoList.AddChange(crDelete, FBlockBegin, FBlockEnd, SelText, smNormal); - StartOfBlock := FBlockBegin; + StartOfBlock := BlockBegin; + EndOfBlock.Line := BlockBegin.Line; + EndOfBlock.Char := BlockBegin.Char + Length(s); SetSelTextPrimitive(s); - FUndoList.AddChange(crInsert, FBlockBegin, FBlockEnd, Helper, + FUndoList.AddChange(crInsert, StartOfBlock, EndOfBlock, '', smNormal); finally EndUndoBlock; diff --git a/components/synedit/Source/SynEditCodeFolding.pas b/components/synedit/Source/SynEditCodeFolding.pas index f19038d95..e9228bedd 100644 --- a/components/synedit/Source/SynEditCodeFolding.pas +++ b/components/synedit/Source/SynEditCodeFolding.pas @@ -106,7 +106,7 @@ } interface -{$I SynEdit.Inc} +{$I SynEdit.inc} uses Graphics, diff --git a/components/synedit/Source/SynEditHighlighter.pas b/components/synedit/Source/SynEditHighlighter.pas index 112b9db80..b74ebcf41 100644 --- a/components/synedit/Source/SynEditHighlighter.pas +++ b/components/synedit/Source/SynEditHighlighter.pas @@ -29,7 +29,7 @@ unit SynEditHighlighter; -{$I SynEdit.Inc} +{$I SynEdit.inc} interface diff --git a/components/synedit/Source/SynEditKbdHandler.pas b/components/synedit/Source/SynEditKbdHandler.pas index c78c0e517..ed8711e8f 100644 --- a/components/synedit/Source/SynEditKbdHandler.pas +++ b/components/synedit/Source/SynEditKbdHandler.pas @@ -161,6 +161,8 @@ procedure TSynEditKbdHandler.AddMouseCursorHandler(aHandler: TMouseCursorEvent); constructor TSynEditKbdHandler.Create; begin + inherited; + { Elements to handle KeyDown-Events } FKeyDownChain := TMethodList.Create; @@ -355,12 +357,16 @@ procedure TMethodList.Add(aHandler: TMethod); constructor TMethodList.Create; begin + inherited; + FData := TList.Create; end; destructor TMethodList.Destroy; begin FData.Free; + + inherited; end; function TMethodList.GetCount: Integer; diff --git a/components/synedit/Source/SynEditOptionsDialog.pas b/components/synedit/Source/SynEditOptionsDialog.pas index 1648314cc..680c0335b 100644 --- a/components/synedit/Source/SynEditOptionsDialog.pas +++ b/components/synedit/Source/SynEditOptionsDialog.pas @@ -40,7 +40,7 @@ unit SynEditOptionsDialog; {$ENDIF} -{$I SynEdit.Inc} +{$I SynEdit.inc} interface diff --git a/components/synedit/Source/SynEditPrint.pas b/components/synedit/Source/SynEditPrint.pas index 485729d7c..4f69680c3 100644 --- a/components/synedit/Source/SynEditPrint.pas +++ b/components/synedit/Source/SynEditPrint.pas @@ -87,7 +87,7 @@ {$ENDIF} {$M+} -{$I SynEdit.Inc} +{$I SynEdit.inc} interface diff --git a/components/synedit/Source/SynEditReg.dcr b/components/synedit/Source/SynEditReg.dcr index 71104456d..b5f15015f 100644 Binary files a/components/synedit/Source/SynEditReg.dcr and b/components/synedit/Source/SynEditReg.dcr differ diff --git a/components/synedit/Source/SynEditReg.pas b/components/synedit/Source/SynEditReg.pas index 3466c10e9..6b054cfee 100644 --- a/components/synedit/Source/SynEditReg.pas +++ b/components/synedit/Source/SynEditReg.pas @@ -87,6 +87,7 @@ interface {$ifdef SYN_DELPHI_2009_UP} SynHighlighterDWS, {$endif} + SynHighlighterECMAScript, SynHighlighterEiffel, SynHighlighterFortran, SynHighlighterFoxpro, @@ -182,7 +183,7 @@ procedure Register; TSynM3Syn, TSynPasSyn, TSynVBSyn, TSynCobolSyn, TSynCSSyn, TSynGoSyn, // internet TSynCssSyn, TSynHTMLSyn, TSynJScriptSyn, TSynPHPSyn, TSynVBScriptSyn, - TSynXMLSyn, TSynJSONSyn, TSynVrml97Syn, + TSynXMLSyn, TSynJSONSyn, TSynVrml97Syn, TSynECMAScriptSyn, //interpreted TSynAWKSyn, TSynBATSyn, {$ifdef SYN_DELPHI_2009_UP} diff --git a/components/synedit/Source/SynEditSearch.pas b/components/synedit/Source/SynEditSearch.pas index b27bd807c..4d2613b6e 100644 --- a/components/synedit/Source/SynEditSearch.pas +++ b/components/synedit/Source/SynEditSearch.pas @@ -40,7 +40,7 @@ unit SynEditSearch; {$ENDIF} -{$I SynEdit.Inc} +{$I SynEdit.inc} interface diff --git a/components/synedit/Source/SynEditStrConst.pas b/components/synedit/Source/SynEditStrConst.pas index 8e342d0c2..441e6e9bd 100644 --- a/components/synedit/Source/SynEditStrConst.pas +++ b/components/synedit/Source/SynEditStrConst.pas @@ -219,6 +219,7 @@ interface SYNS_LangCSS = 'CascadingStyleSheet'; SYNS_LangDfm = 'BorlandForms'; SYNS_LangDOT = 'DOT_Graph_Drawing_Description_language'; + SYNS_LangECMAScript = 'ECMAScript'; SYNS_LangEiffel = 'Eiffel'; SYNS_LangFortran = 'Fortran'; SYNS_LangFoxpro = 'Foxpro'; @@ -459,6 +460,7 @@ interface SYNS_FilterDFM = 'Borland Form Files (*.dfm;*.xfm)|*.dfm;*.xfm'; SYNS_FilterDOT = 'DOT Graph Drawing Description (*.dot)|*.dot'; SYNS_FilterDWS = 'DWScript Files (*.dws;*.pas;*.inc)|*.dws;*.pas;*.inc'; + SYNS_FilterEcmaScript = 'Javascript Files (*.js)|*.js'; SYNS_FilterEiffel = 'Eiffel (*.e;*.ace)|*.e;*.ace'; SYNS_FilterFortran = 'Fortran Files (*.for)|*.for'; SYNS_FilterFoxpro = 'Foxpro Files (*.prg)|*.prg'; @@ -519,6 +521,7 @@ interface SYNS_FriendlyLangCSS = 'Cascading Style Sheet'; SYNS_FriendlyLangDfm = 'Borland Forms'; SYNS_FriendlyLangDOT = 'DOT Graph Drawing Description language'; + SYNS_FriendlyLangEcmaScript = 'ECMA Script'; SYNS_FriendlyLangEiffel = 'Eiffel'; SYNS_FriendlyLangFortran = 'Fortran'; SYNS_FriendlyLangFoxpro = 'Foxpro'; @@ -535,6 +538,7 @@ interface SYNS_FriendlyLangINI = 'INI'; SYNS_FriendlyLangInno = 'Inno Setup Script'; SYNS_FriendlyLangJava = 'Java'; + SYNS_FriendlyLangJavaScript = 'JavaScript'; SYNS_FriendlyLangJScript = 'JavaScript'; SYNS_FriendlyLangJSON = 'JSON'; SYNS_FriendlyLangKIX = 'KiXtart'; diff --git a/components/synedit/Source/SynHighlighterADSP21xx.pas b/components/synedit/Source/SynHighlighterADSP21xx.pas index c5596a399..8d0ea5153 100644 --- a/components/synedit/Source/SynHighlighterADSP21xx.pas +++ b/components/synedit/Source/SynHighlighterADSP21xx.pas @@ -45,7 +45,7 @@ unit SynHighlighterADSP21xx; -{$I SynEdit.Inc} +{$I SynEdit.inc} interface diff --git a/components/synedit/Source/SynHighlighterAWK.pas b/components/synedit/Source/SynHighlighterAWK.pas index 9e02104cb..6cfe3c31b 100644 --- a/components/synedit/Source/SynHighlighterAWK.pas +++ b/components/synedit/Source/SynHighlighterAWK.pas @@ -47,7 +47,7 @@ interface -{$I SynEdit.Inc} +{$I SynEdit.inc} uses Graphics, diff --git a/components/synedit/Source/SynHighlighterAsm.pas b/components/synedit/Source/SynHighlighterAsm.pas index 085ca6d9c..c2d54e3a8 100644 --- a/components/synedit/Source/SynHighlighterAsm.pas +++ b/components/synedit/Source/SynHighlighterAsm.pas @@ -47,7 +47,7 @@ unit SynHighlighterAsm; -{$I SynEdit.Inc} +{$I SynEdit.inc} interface diff --git a/components/synedit/Source/SynHighlighterAsmMASM.pas b/components/synedit/Source/SynHighlighterAsmMASM.pas index 250bba32b..80cdf42a4 100644 --- a/components/synedit/Source/SynHighlighterAsmMASM.pas +++ b/components/synedit/Source/SynHighlighterAsmMASM.pas @@ -49,7 +49,7 @@ unit SynHighlighterAsmMASM; -{$I SynEdit.Inc} +{$I SynEdit.inc} interface diff --git a/components/synedit/Source/SynHighlighterBaan.pas b/components/synedit/Source/SynHighlighterBaan.pas index 241e8cfb6..ca20bf31a 100644 --- a/components/synedit/Source/SynHighlighterBaan.pas +++ b/components/synedit/Source/SynHighlighterBaan.pas @@ -46,7 +46,7 @@ unit SynHighlighterBaan; -{$I SynEdit.Inc} +{$I SynEdit.inc} interface diff --git a/components/synedit/Source/SynHighlighterBat.pas b/components/synedit/Source/SynHighlighterBat.pas index 2a00ed8de..83dc21b97 100644 --- a/components/synedit/Source/SynHighlighterBat.pas +++ b/components/synedit/Source/SynHighlighterBat.pas @@ -46,7 +46,7 @@ unit SynHighlighterBat; -{$I SynEdit.Inc} +{$I SynEdit.inc} interface diff --git a/components/synedit/Source/SynHighlighterCAC.pas b/components/synedit/Source/SynHighlighterCAC.pas index 914cb8683..d111af344 100644 --- a/components/synedit/Source/SynHighlighterCAC.pas +++ b/components/synedit/Source/SynHighlighterCAC.pas @@ -46,7 +46,7 @@ unit SynHighlighterCAC; -{$I SynEdit.Inc} +{$I SynEdit.inc} interface diff --git a/components/synedit/Source/SynHighlighterCPM.pas b/components/synedit/Source/SynHighlighterCPM.pas index 2ae66898b..079ede1dd 100644 --- a/components/synedit/Source/SynHighlighterCPM.pas +++ b/components/synedit/Source/SynHighlighterCPM.pas @@ -35,7 +35,7 @@ unit SynHighlighterCPM; -{$I SynEdit.Inc} +{$I SynEdit.inc} interface diff --git a/components/synedit/Source/SynHighlighterCS.pas b/components/synedit/Source/SynHighlighterCS.pas index 8ae9c64b9..1a9a7adbd 100644 --- a/components/synedit/Source/SynHighlighterCS.pas +++ b/components/synedit/Source/SynHighlighterCS.pas @@ -51,7 +51,7 @@ unit SynHighlighterCS; -{$I SynEdit.Inc} +{$I SynEdit.inc} interface diff --git a/components/synedit/Source/SynHighlighterCache.pas b/components/synedit/Source/SynHighlighterCache.pas index 3db98c28d..003e5af21 100644 --- a/components/synedit/Source/SynHighlighterCache.pas +++ b/components/synedit/Source/SynHighlighterCache.pas @@ -46,7 +46,7 @@ unit SynHighlighterCache; -{$I SynEdit.Inc} +{$I SynEdit.inc} interface diff --git a/components/synedit/Source/SynHighlighterCobol.pas b/components/synedit/Source/SynHighlighterCobol.pas index ae3723a5e..7156a7f2e 100644 --- a/components/synedit/Source/SynHighlighterCobol.pas +++ b/components/synedit/Source/SynHighlighterCobol.pas @@ -38,7 +38,7 @@ unit SynHighlighterCobol; -{$I SynEdit.Inc} +{$I SynEdit.inc} interface diff --git a/components/synedit/Source/SynHighlighterCpp.pas b/components/synedit/Source/SynHighlighterCpp.pas index 1503103cc..3ff4f3e26 100644 --- a/components/synedit/Source/SynHighlighterCpp.pas +++ b/components/synedit/Source/SynHighlighterCpp.pas @@ -46,7 +46,7 @@ unit SynHighlighterCpp; -{$I SynEdit.Inc} +{$I SynEdit.inc} interface diff --git a/components/synedit/Source/SynHighlighterCss.pas b/components/synedit/Source/SynHighlighterCss.pas index 444a1280c..d0a41711a 100644 --- a/components/synedit/Source/SynHighlighterCss.pas +++ b/components/synedit/Source/SynHighlighterCss.pas @@ -53,7 +53,7 @@ unit SynHighlighterCSS; -{$I SynEdit.Inc} +{$I SynEdit.inc} interface diff --git a/components/synedit/Source/SynHighlighterDOT.pas b/components/synedit/Source/SynHighlighterDOT.pas index 1cba7ab22..72d8b59e1 100644 --- a/components/synedit/Source/SynHighlighterDOT.pas +++ b/components/synedit/Source/SynHighlighterDOT.pas @@ -45,7 +45,7 @@ unit SynHighlighterDOT; -{$I SynEdit.Inc} +{$I SynEdit.inc} interface diff --git a/components/synedit/Source/SynHighlighterDfm.pas b/components/synedit/Source/SynHighlighterDfm.pas index c75b6ee8d..2e2d14092 100644 --- a/components/synedit/Source/SynHighlighterDfm.pas +++ b/components/synedit/Source/SynHighlighterDfm.pas @@ -46,7 +46,7 @@ unit SynHighlighterDfm; -{$I SynEdit.Inc} +{$I SynEdit.inc} interface diff --git a/components/synedit/Source/SynHighlighterDml.pas b/components/synedit/Source/SynHighlighterDml.pas index 3601f9d61..505ae200c 100644 --- a/components/synedit/Source/SynHighlighterDml.pas +++ b/components/synedit/Source/SynHighlighterDml.pas @@ -46,7 +46,7 @@ unit SynHighlighterDml; -{$I SynEdit.Inc} +{$I SynEdit.inc} interface diff --git a/components/synedit/Source/SynHighlighterECMAScript.pas b/components/synedit/Source/SynHighlighterECMAScript.pas new file mode 100644 index 000000000..574e6470b --- /dev/null +++ b/components/synedit/Source/SynHighlighterECMAScript.pas @@ -0,0 +1,889 @@ +{------------------------------------------------------------------------------- +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. + +Code template generated with SynGen. +The original code is: C:\Users\Public\Code\SynEdit\SynGen\Test ECMAScript\SynHighlighterECMAScript.pas, released 2020-06-21. +Description: ECMA Script Syntax Highlighter +The initial author of this file is Christian-W. Budde. +Copyright (c) 2020, all rights reserved. + +Contributors to the SynEdit and mwEdit projects are listed in the +Contributors.txt file. + +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. + +$Id: $ + +You may retrieve the latest version of this file at the SynEdit home page, +located at http://SynEdit.SourceForge.net + +-------------------------------------------------------------------------------} + +unit SynHighlighterECMAScript; + +{$I SynEdit.inc} + +interface + +uses + Graphics, + SynEditTypes, + SynEditHighlighter, + SynUnicode, + SysUtils, + Classes; + +type + TtkTokenKind = ( + tkComment, + tkIdentifier, + tkKey, + tkReserved, + tkStrict, + tkNull, + tkNumber, + tkSpace, + tkString, + tkSymbol, + tkUnknown); + + TRangeState = (rsUnknown, rsMultiLineComment, rsSingleLineComment, + rsDoubleQuotedString, rsSingleQuotedString); + + TProcTableProc = procedure of object; + + PIdentFuncTableFunc = ^TIdentFuncTableFunc; + TIdentFuncTableFunc = function (Index: Integer): TtkTokenKind of object; + +type + TSynECMAScriptSyn = class(TSynCustomHighlighter) + private + FRange: TRangeState; + FTokenId: TtkTokenKind; + FIdentFuncTable: array[0..108] of TIdentFuncTableFunc; + FCommentAttri: TSynHighlighterAttributes; + FIdentifierAttri: TSynHighlighterAttributes; + FKeyAttri: TSynHighlighterAttributes; + FNumberAttri: TSynHighlighterAttributes; + FSpaceAttri: TSynHighlighterAttributes; + FStringAttri: TSynHighlighterAttributes; + FSymbolAttri: TSynHighlighterAttributes; + function AltFunc(Index: Integer): TtkTokenKind; + function FuncKeyWord(Index: Integer): TtkTokenKind; + function FuncReservedWord(Index: Integer): TtkTokenKind; + function FuncStrictMode(Index: Integer): TtkTokenKind; + function HashKey(Str: PWideChar): Cardinal; + function IdentKind(MayBe: PWideChar): TtkTokenKind; + procedure AndSymbolProc; + procedure BackslashProc; + procedure CRProc; + procedure CoalesceProc; + procedure EqualsProc; + procedure GreaterProc; + procedure Hex4DigitProc; + procedure InitIdent; + procedure IdentProc; + procedure LessProc; + procedure LFProc; + procedure MinusProc; + procedure ModSymbolProc; + procedure MultiLineCommentProc; + procedure NotProc; + procedure NullProc; + procedure NumberProc; + procedure OrSymbolProc; + procedure PlusProc; + procedure DotProc; + procedure SlashProc; + procedure SpaceProc; + procedure StarProc; + procedure StringProc; + procedure SymbolProc; + procedure UnknownProc; + procedure XorSymbolProc; + protected + function GetSampleSource: UnicodeString; override; + function IsFilterStored: Boolean; override; + public + constructor Create(AOwner: TComponent); override; + class function GetFriendlyLanguageName: UnicodeString; override; + class function GetLanguageName: string; override; + function GetRange: Pointer; override; + procedure ResetRange; override; + procedure SetRange(Value: Pointer); override; + function GetDefaultAttribute(Index: Integer): TSynHighlighterAttributes; override; + function GetEol: Boolean; override; + function GetKeyWords(TokenKind: Integer): UnicodeString; override; + function GetTokenID: TtkTokenKind; + function GetTokenAttribute: TSynHighlighterAttributes; override; + function GetTokenKind: Integer; override; + function IsIdentChar(AChar: WideChar): Boolean; override; + procedure Next; override; + published + property CommentAttri: TSynHighlighterAttributes read FCommentAttri write FCommentAttri; + property IdentifierAttri: TSynHighlighterAttributes read FIdentifierAttri write FIdentifierAttri; + property KeyAttri: TSynHighlighterAttributes read FKeyAttri write FKeyAttri; + property NumberAttri: TSynHighlighterAttributes read FNumberAttri write FNumberAttri; + property SpaceAttri: TSynHighlighterAttributes read FSpaceAttri write FSpaceAttri; + property StringAttri: TSynHighlighterAttributes read FStringAttri write FStringAttri; + property SymbolAttri: TSynHighlighterAttributes read FSymbolAttri write FSymbolAttri; + end; + +implementation + +uses + SynEditStrConst; + +resourcestring + SYNS_FilterECMAScript = 'JavaScript files (*.js)|*.js'; + SYNS_LangECMAScript = 'ECMA Script'; + SYNS_FriendlyLangECMAScript = 'ECMA Script'; + +const + // as this language is case-insensitive keywords *must* be in lowercase + KeyWords: array[0..52] of UnicodeString = ( + 'as', 'async', 'await', 'break', 'case', 'catch', 'class', 'const', + 'continue', 'debugger', 'default', 'delete', 'do', 'else', 'enum', 'export', + 'extends', 'false', 'finally', 'for', 'from', 'function', 'get', 'if', + 'implements', 'import', 'in', 'instance', 'interface', 'let', 'new', 'null', + 'of', 'package', 'private', 'protected', 'public', 'return', 'set', + 'static', 'super', 'switch', 'target', 'this', 'throw', 'true', 'try', + 'typeof', 'var', 'void', 'while', 'with', 'yield' + ); + + KeyIndices: array[0..108] of Integer = ( + -1, 25, -1, 42, -1, 52, 48, 10, -1, -1, -1, -1, 2, -1, -1, -1, -1, -1, -1, + 4, 46, -1, 5, 30, -1, -1, 27, 20, -1, -1, 32, 51, -1, 38, 13, -1, 28, 12, + -1, -1, 19, 41, -1, 3, -1, -1, -1, 9, 6, -1, 24, 34, -1, -1, 36, 16, 49, -1, + 22, 17, -1, -1, 35, -1, 21, 0, -1, -1, -1, -1, 50, 11, -1, 40, 18, -1, 7, + -1, -1, 39, 44, -1, -1, 47, 31, 43, 26, -1, -1, -1, -1, 33, 23, 29, 14, -1, + 45, 37, -1, 8, -1, -1, -1, -1, -1, -1, 1, -1, 15 + ); + +constructor TSynECMAScriptSyn.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + FCaseSensitive := False; + + FCommentAttri := TSynHighLighterAttributes.Create(SYNS_AttrComment, SYNS_FriendlyAttrComment); + FCommentAttri.Style := [fsItalic]; + FCommentAttri.Foreground := clNavy; + AddAttribute(FCommentAttri); + + FIdentifierAttri := TSynHighLighterAttributes.Create(SYNS_AttrIdentifier, SYNS_FriendlyAttrIdentifier); + AddAttribute(FIdentifierAttri); + + FKeyAttri := TSynHighLighterAttributes.Create(SYNS_AttrReservedWord, SYNS_FriendlyAttrReservedWord); + FKeyAttri.Style := [fsBold]; + AddAttribute(FKeyAttri); + + FNumberAttri := TSynHighlighterAttributes.Create(SYNS_AttrNumber, SYNS_FriendlyAttrNumber); + AddAttribute(FNumberAttri); + + FSpaceAttri := TSynHighLighterAttributes.Create(SYNS_AttrSpace, SYNS_FriendlyAttrSpace); + AddAttribute(FSpaceAttri); + + FStringAttri := TSynHighLighterAttributes.Create(SYNS_AttrString, SYNS_FriendlyAttrString); + AddAttribute(FStringAttri); + + FSymbolAttri := TSynHighlighterAttributes.Create(SYNS_AttrSymbol, SYNS_FriendlyAttrSymbol); + AddAttribute(FSymbolAttri); + + SetAttributesOnChange(DefHighlightChange); + InitIdent; + FDefaultFilter := SYNS_FilterECMAScript; + FRange := rsUnknown; +end; + +procedure TSynECMAScriptSyn.InitIdent; +var + i: Integer; +begin + for i := Low(FIdentFuncTable) to High(FIdentFuncTable) do + if KeyIndices[i] = -1 then + FIdentFuncTable[i] := AltFunc; + + FIdentFuncTable[12] := FuncReservedWord; + FIdentFuncTable[65] := FuncKeyWord; + FIdentFuncTable[106] := FuncKeyWord; + FIdentFuncTable[43] := FuncReservedWord; + FIdentFuncTable[19] := FuncReservedWord; + FIdentFuncTable[22] := FuncReservedWord; + FIdentFuncTable[48] := FuncReservedWord; + FIdentFuncTable[76] := FuncReservedWord; + FIdentFuncTable[99] := FuncReservedWord; + FIdentFuncTable[47] := FuncReservedWord; + FIdentFuncTable[7] := FuncReservedWord; + FIdentFuncTable[71] := FuncReservedWord; + FIdentFuncTable[37] := FuncReservedWord; + FIdentFuncTable[34] := FuncReservedWord; + FIdentFuncTable[94] := FuncReservedWord; + FIdentFuncTable[108] := FuncReservedWord; + FIdentFuncTable[55] := FuncReservedWord; + FIdentFuncTable[59] := FuncReservedWord; + FIdentFuncTable[74] := FuncReservedWord; + FIdentFuncTable[40] := FuncReservedWord; + FIdentFuncTable[27] := FuncKeyWord; + FIdentFuncTable[64] := FuncReservedWord; + FIdentFuncTable[58] := FuncKeyWord; + FIdentFuncTable[92] := FuncReservedWord; + FIdentFuncTable[50] := FuncStrictMode; + FIdentFuncTable[1] := FuncReservedWord; + FIdentFuncTable[86] := FuncReservedWord; + FIdentFuncTable[26] := FuncReservedWord; + FIdentFuncTable[36] := FuncStrictMode; + FIdentFuncTable[93] := FuncStrictMode; + FIdentFuncTable[23] := FuncReservedWord; + FIdentFuncTable[84] := FuncReservedWord; + FIdentFuncTable[30] := FuncKeyWord; + FIdentFuncTable[91] := FuncStrictMode; + FIdentFuncTable[51] := FuncStrictMode; + FIdentFuncTable[62] := FuncStrictMode; + FIdentFuncTable[54] := FuncStrictMode; + FIdentFuncTable[97] := FuncReservedWord; + FIdentFuncTable[33] := FuncKeyWord; + FIdentFuncTable[79] := FuncStrictMode; + FIdentFuncTable[73] := FuncReservedWord; + FIdentFuncTable[41] := FuncReservedWord; + FIdentFuncTable[3] := FuncKeyWord; + FIdentFuncTable[85] := FuncReservedWord; + FIdentFuncTable[80] := FuncReservedWord; + FIdentFuncTable[96] := FuncReservedWord; + FIdentFuncTable[20] := FuncReservedWord; + FIdentFuncTable[83] := FuncReservedWord; + FIdentFuncTable[6] := FuncReservedWord; + FIdentFuncTable[56] := FuncReservedWord; + FIdentFuncTable[70] := FuncReservedWord; + FIdentFuncTable[31] := FuncReservedWord; + FIdentFuncTable[5] := FuncReservedWord; +end; + +{$Q-} +function TSynECMAScriptSyn.HashKey(Str: PWideChar): Cardinal; +begin + Result := 0; + while IsIdentChar(Str^) do + begin + Result := Result * 474 + Ord(Str^) * 408; + Inc(Str); + end; + Result := Result mod 109; + FStringLen := Str - FToIdent; +end; +{$Q+} + +function TSynECMAScriptSyn.FuncReservedWord(Index: Integer): TtkTokenKind; +begin + if IsCurrentToken(KeyWords[Index]) then + Result := tkReserved + else + Result := tkIdentifier; +end; + +function TSynECMAScriptSyn.FuncStrictMode(Index: Integer): TtkTokenKind; +begin + if IsCurrentToken(KeyWords[Index]) then + Result := tkStrict + else + Result := tkIdentifier; +end; + +function TSynECMAScriptSyn.FuncKeyWord(Index: Integer): TtkTokenKind; +begin + if IsCurrentToken(KeyWords[Index]) then + Result := tkKey + else + Result := tkIdentifier; +end; + +function TSynECMAScriptSyn.AltFunc(Index: Integer): TtkTokenKind; +begin + Result := tkIdentifier; +end; + +procedure TSynECMAScriptSyn.AndSymbolProc; +begin + FTokenID := tkSymbol; + Inc(Run); + if CharInSet(FLine[Run], ['=', '&']) then + Inc(Run); +end; + +function TSynECMAScriptSyn.IdentKind(MayBe: PWideChar): TtkTokenKind; +var + Key: Cardinal; +begin + FToIdent := MayBe; + Key := HashKey(MayBe); + if Key <= High(FIdentFuncTable) then + Result := FIdentFuncTable[Key](KeyIndices[Key]) + else + Result := tkIdentifier; +end; + +procedure TSynECMAScriptSyn.SpaceProc; +begin + Inc(Run); + FTokenId := tkSpace; + while (FLine[Run] <= #32) and not IsLineEnd(Run) do + Inc(Run); +end; + +procedure TSynECMAScriptSyn.CoalesceProc; +begin + FTokenID := tkSymbol; + Inc(Run); + if FLine[Run] = '?' then + Inc(Run); +end; + +procedure TSynECMAScriptSyn.NotProc; +begin + FTokenID := tkSymbol; + Inc(Run); + if FLine[Run] = '=' then + begin + Inc(Run); + if FLine[Run] = '=' then + Inc(Run); + end; +end; + +procedure TSynECMAScriptSyn.NullProc; +begin + FTokenId := tkNull; + Inc(Run); +end; + +procedure TSynECMAScriptSyn.CRProc; +begin + FTokenId := tkSpace; + Inc(Run); + if FLine[Run] = #10 then + Inc(Run); +end; + +procedure TSynECMAScriptSyn.LFProc; +begin + FTokenId := tkSpace; + Inc(Run); +end; + +procedure TSynECMAScriptSyn.NumberProc; + + function IsNumberChar: Boolean; + begin + case FLine[Run] of + '0'..'9', '.', 'a'..'f', 'A'..'F', 'x', 'X': + Result := True; + else + Result := False; + end; + end; + + function IsHexChar(Run: Integer): Boolean; + begin + case FLine[Run] of + '0'..'9', 'a'..'f', 'A'..'F': + Result := True; + else + Result := False; + end; + end; + +var + idx1: Integer; // token[1] + isHex: Boolean; +begin + FTokenID := tkNumber; + isHex := False; + idx1 := Run; + Inc(Run); + while IsNumberChar do + begin + case FLine[Run] of + '.': + if FLine[Succ(Run)] = '.' then + Break; + 'a'..'f', 'A'..'F': + if not isHex then + Break; + 'x', 'X': + begin + if (FLine[idx1] <> '0') or (Run > Succ(idx1)) then + Break; + if not IsHexChar(Succ(Run)) then + Break; + isHex := True; + end; + end; + Inc(Run); + end; +end; + +procedure TSynECMAScriptSyn.OrSymbolProc; +begin + FTokenID := tkSymbol; + Inc(Run); + if CharInSet(FLine[Run], ['=', '|']) then Inc(Run); +end; + +procedure TSynECMAScriptSyn.EqualsProc; +begin + FTokenID := tkSymbol; + Inc(Run); + case FLine[Run] of + '=': + begin + Inc(Run); + if FLine[Run] = '=' then + Inc(Run); + end; + '>': + Inc(Run); + end; +end; + +procedure TSynECMAScriptSyn.GreaterProc; +begin + FTokenID := tkSymbol; + Inc(Run); + case FLine[Run] of + '=': + Inc(Run); + '>': + begin + Inc(Run); + case FLine[Run] of + '=': + Inc(Run); + '>': + begin + Inc(Run); + if FLine[Run] = '=' then + Inc(Run); + end; + end; + end; + end; +end; + +procedure TSynECMAScriptSyn.LessProc; +begin + FTokenID := tkSymbol; + Inc(Run); + case FLine[Run] of + '=': + Inc(Run); + '<': + begin + Inc(Run); + if FLine[Run] = '=' then + Inc(Run); + end; + end; +end; + +procedure TSynECMAScriptSyn.PlusProc; +begin + FTokenID := tkSymbol; + Inc(Run); + if CharInSet(FLine[Run], ['=', '+']) then + Inc(Run); +end; + +procedure TSynECMAScriptSyn.DotProc; +begin + FTokenID := tkSymbol; + Inc(Run); + if (FLine[Run] = '.') and (FLine[Run + 1] = '.') then Inc(Run, 2); +end; + +procedure TSynECMAScriptSyn.SlashProc; +begin + Inc(Run); + case FLine[Run] of + '/': + begin + FTokenId := tkComment; + FRange := rsSingleLineComment; + repeat + Inc(Run); + until IsLineEnd(Run); + FTokenId := tkComment; + end; + '*': + begin + Inc(Run, 1); + FRange := rsMultiLineComment; + FTokenId := tkComment; + repeat + Inc(Run); + if (FLine[Run] = '*') and (FLine[Run + 1] = '/') then + begin + FRange := rsUnknown; + Inc(Run, 2); + Break; + end; + until IsLineEnd(Run); + end; + '=': + begin + Inc(Run); + FTokenID := tkSymbol; + end; + end; +end; + +procedure TSynECMAScriptSyn.MultiLineCommentProc; +begin + case FLine[Run] of + #0: NullProc; + #10: LFProc; + #13: CRProc; + else + begin + FTokenId := tkComment; + repeat + if (FLine[Run] = '*') and + (FLine[Run + 1] = '/') then + begin + Inc(Run, 2); + FRange := rsUnknown; + Break; + end; + if not IsLineEnd(Run) then + Inc(Run); + until IsLineEnd(Run); + end; + end; +end; + +procedure TSynECMAScriptSyn.StarProc; +begin + FTokenID := tkSymbol; + Inc(Run); + case FLine[Run] of + '=': + Inc(Run); + '*': + begin + Inc(Run); + if FLine[Run] = '=' then + Inc(Run); + end; + end; +end; + +procedure TSynECMAScriptSyn.StringProc; +var + QuoteChar: UnicodeString; +begin + FTokenID := tkString; + QuoteChar := FLine[Run]; // We could have '"' or #39 + if (FLine[Run + 1] = QuoteChar) and (FLine[Run + 2] = QuoteChar) then Inc(Run, 2); + repeat + if IsLineEnd(Run) then + Break; + Inc(Run); + until (FLine[Run] = QuoteChar) and (FLine[Pred(Run)] <> '\'); + if not IsLineEnd(Run) then + Inc(Run); +end; + +procedure TSynECMAScriptSyn.IdentProc; +begin + FTokenID := IdentKind((FLine + Run)); + Inc(Run, FStringLen); + while IsIdentChar(FLine[Run]) do + Inc(Run); +end; + +procedure TSynECMAScriptSyn.Hex4DigitProc; +var + i: Integer; + + function IsHexDigit(AChar: WideChar): Boolean; + begin + case FLine[Run] of + '0'..'9', 'a'..'f', 'A'..'F': + Result := True; + else + Result := False; + end; + end; + +begin + for i := 0 to 3 do + begin + if not IsHexDigit(FLine[Run]) then + begin + FTokenId := tkUnknown; + Exit; + end; + Inc(Run); + end; +end; + +procedure TSynECMAScriptSyn.BackslashProc; +begin + Inc(Run); + if FLine[Run] = 'u' then + begin + Inc(Run); + Hex4DigitProc; + end + else + FTokenId := tkUnknown; +end; + +procedure TSynECMAScriptSyn.MinusProc; +begin + FTokenID := tkSymbol; + Inc(Run); + if CharInSet(FLine[Run], ['=', '-', '>']) then Inc(Run); +end; + +procedure TSynECMAScriptSyn.ModSymbolProc; +begin + FTokenID := tkSymbol; + Inc(Run); + if FLine[Run] = '=' then Inc(Run); +end; + +procedure TSynECMAScriptSyn.SymbolProc; +begin + Inc(Run); + FTokenID := tkSymbol; +end; + +procedure TSynECMAScriptSyn.UnknownProc; +begin + Inc(Run); + FTokenId := tkUnknown; +end; + +procedure TSynECMAScriptSyn.XorSymbolProc; +begin + FTokenID := tkSymbol; + Inc(Run); + if FLine[Run] = '=' then + Inc(Run); +end; + +procedure TSynECMAScriptSyn.Next; +begin + FTokenPos := Run; + case FRange of + rsMultiLineComment: MultiLineCommentProc; + else + case FLine[Run] of + #0: + NullProc; + #10: + LFProc; + #13: + CRProc; + #1..#9, #11, #12, #14..#32: + SpaceProc; + '"', #39: + StringProc; + '%': + ModSymbolProc; + '&': + AndSymbolProc; + '.': + DotProc; + '/': + SlashProc; + '-': + MinusProc; + '\': + BackslashProc; + '|': + OrSymbolProc; + '(', ')': + SymbolProc; + '*': + StarProc; + '+': + PlusProc; + '=': + EqualsProc; + '>': + GreaterProc; + '<': + LessProc; + '!': + NotProc; + '?': + CoalesceProc; + '^': + XorSymbolProc; + '~', ',', '[', ']', ':', ';', '{', '}': + SymbolProc; + '0'..'9': + NumberProc; + 'A'..'Z', 'a'..'z', '_', '$', #$AA, #$B5, #$BA, #$C0..#$D6, #$D8..#$F6, + #$0F8..#$2C1: + IdentProc; + else + UnknownProc; + end; + end; + inherited; +end; + +function TSynECMAScriptSyn.GetDefaultAttribute(Index: Integer): TSynHighLighterAttributes; +begin + case Index of + SYN_ATTR_COMMENT: + Result := FCommentAttri; + SYN_ATTR_IDENTIFIER: + Result := FIdentifierAttri; + SYN_ATTR_KEYWORD: + Result := FKeyAttri; + SYN_ATTR_STRING: + Result := FStringAttri; + SYN_ATTR_WHITESPACE: + Result := FSpaceAttri; + SYN_ATTR_SYMBOL: + Result := FSymbolAttri; + else + Result := nil; + end; +end; + +function TSynECMAScriptSyn.GetEol: Boolean; +begin + Result := Run = FLineLen + 1; +end; + +function TSynECMAScriptSyn.GetKeyWords(TokenKind: Integer): UnicodeString; +begin + Result := + 'as,async,await,break,case,catch,class,const,continue,debugger,default,' + + 'delete,do,else,enum,export,extends,false,finally,for,from,function,' + + 'get,if,implements,import,in,instance,interface,let,new,null,of,package,' + + 'private,protected,public,return,set,static,super,switch,target,this,' + + 'throw,true,try,typeof,var,void,while,with,yield'; +end; + +function TSynECMAScriptSyn.GetTokenID: TtkTokenKind; +begin + Result := FTokenId; +end; + +function TSynECMAScriptSyn.GetTokenAttribute: TSynHighLighterAttributes; +begin + case GetTokenID of + tkComment: + Result := FCommentAttri; + tkIdentifier: + Result := FIdentifierAttri; + tkKey: + Result := FKeyAttri; + tkReserved: + Result := FKeyAttri; + tkNumber: + Result := FNumberAttri; + tkStrict: + Result := FKeyAttri; + tkSpace: + Result := FSpaceAttri; + tkString: + Result := FStringAttri; + tkSymbol: + Result := FSymbolAttri; + tkUnknown: + Result := FIdentifierAttri; + else + Result := nil; + end; +end; + +function TSynECMAScriptSyn.GetTokenKind: Integer; +begin + Result := Ord(FTokenId); +end; + +function TSynECMAScriptSyn.IsIdentChar(AChar: WideChar): Boolean; +begin + case AChar of + 'A'..'Z', 'a'..'z', '_', '$', #$AA, #$B5, #$BA, #$C0..#$D6, #$D8..#$F6, + #$0F8..#$2C1: + Result := True; + else + Result := False; + end; +end; + +function TSynECMAScriptSyn.GetSampleSource: UnicodeString; +begin + Result := + '// Syntax highlighting'#13#10 + + 'function printNumber()'#13#10 + + '{'#13#10 + + ' var number = 1234;'#13#10 + + ' var x;'#13#10 + + ' document.write("The number is " + number);'#13#10 + + ' for (var i = 0; i <= number; i++)'#13#10 + + ' {'#13#10 + + ' x++;'#13#10 + + ' x--;'#13#10 + + ' x += 1.0;'#13#10 + + ' }'#13#10 + + ' i += @; // illegal character'#13#10 + + '}'#13#10 + + 'body.onLoad = printNumber;'; +end; + +function TSynECMAScriptSyn.IsFilterStored: Boolean; +begin + Result := FDefaultFilter <> SYNS_FilterECMAScript; +end; + +class function TSynECMAScriptSyn.GetFriendlyLanguageName: UnicodeString; +begin + Result := SYNS_FriendlyLangECMAScript; +end; + +class function TSynECMAScriptSyn.GetLanguageName: string; +begin + Result := SYNS_LangECMAScript; +end; + +procedure TSynECMAScriptSyn.ResetRange; +begin + FRange := rsUnknown; +end; + +procedure TSynECMAScriptSyn.SetRange(Value: Pointer); +begin + FRange := TRangeState(Value); +end; + +function TSynECMAScriptSyn.GetRange: Pointer; +begin + Result := Pointer(FRange); +end; + +initialization + RegisterPlaceableHighlighter(TSynECMAScriptSyn); + +end. diff --git a/components/synedit/Source/SynHighlighterEiffel.pas b/components/synedit/Source/SynHighlighterEiffel.pas index a40202a96..46ba345be 100644 --- a/components/synedit/Source/SynHighlighterEiffel.pas +++ b/components/synedit/Source/SynHighlighterEiffel.pas @@ -44,7 +44,7 @@ unit SynHighlighterEiffel; -{$I SynEdit.Inc} +{$I SynEdit.inc} interface diff --git a/components/synedit/Source/SynHighlighterFortran.pas b/components/synedit/Source/SynHighlighterFortran.pas index 2cc4e7cdb..e27f727ac 100644 --- a/components/synedit/Source/SynHighlighterFortran.pas +++ b/components/synedit/Source/SynHighlighterFortran.pas @@ -46,7 +46,7 @@ unit SynHighlighterFortran; -{$I SynEdit.Inc} +{$I SynEdit.inc} interface diff --git a/components/synedit/Source/SynHighlighterFoxpro.pas b/components/synedit/Source/SynHighlighterFoxpro.pas index 7fd76f7c3..fc5dc0abf 100644 --- a/components/synedit/Source/SynHighlighterFoxpro.pas +++ b/components/synedit/Source/SynHighlighterFoxpro.pas @@ -46,7 +46,7 @@ unit SynHighlighterFoxpro; -{$I SynEdit.Inc} +{$I SynEdit.inc} interface diff --git a/components/synedit/Source/SynHighlighterGLSL.pas b/components/synedit/Source/SynHighlighterGLSL.pas index b62f7f66f..183122587 100644 --- a/components/synedit/Source/SynHighlighterGLSL.pas +++ b/components/synedit/Source/SynHighlighterGLSL.pas @@ -46,7 +46,7 @@ unit SynHighlighterGLSL; -{$I SynEdit.Inc} +{$I SynEdit.inc} interface diff --git a/components/synedit/Source/SynHighlighterGWS.pas b/components/synedit/Source/SynHighlighterGWS.pas index e54341f23..94335ca5a 100644 --- a/components/synedit/Source/SynHighlighterGWS.pas +++ b/components/synedit/Source/SynHighlighterGWS.pas @@ -39,7 +39,7 @@ { This unit provides a syntax highlighter for GW-TEL Scripts } -{$I SynEdit.Inc} +{$I SynEdit.inc} interface diff --git a/components/synedit/Source/SynHighlighterGalaxy.pas b/components/synedit/Source/SynHighlighterGalaxy.pas index dae1cd883..5ea4ecf6c 100644 --- a/components/synedit/Source/SynHighlighterGalaxy.pas +++ b/components/synedit/Source/SynHighlighterGalaxy.pas @@ -47,7 +47,7 @@ unit SynHighlighterGalaxy; -{$I SynEdit.Inc} +{$I SynEdit.inc} interface diff --git a/components/synedit/Source/SynHighlighterGeneral.pas b/components/synedit/Source/SynHighlighterGeneral.pas index 2e5d2b853..4eb6666f4 100644 --- a/components/synedit/Source/SynHighlighterGeneral.pas +++ b/components/synedit/Source/SynHighlighterGeneral.pas @@ -46,7 +46,7 @@ unit SynHighlighterGeneral; -{$I SynEdit.Inc} +{$I SynEdit.inc} interface diff --git a/components/synedit/Source/SynHighlighterHC11.pas b/components/synedit/Source/SynHighlighterHC11.pas index c9904fedb..1aae4ab60 100644 --- a/components/synedit/Source/SynHighlighterHC11.pas +++ b/components/synedit/Source/SynHighlighterHC11.pas @@ -47,7 +47,7 @@ unit SynHighlighterHC11; -{$I SynEdit.Inc} +{$I SynEdit.inc} interface diff --git a/components/synedit/Source/SynHighlighterHP48.pas b/components/synedit/Source/SynHighlighterHP48.pas index 5f756eb71..688eb1ed9 100644 --- a/components/synedit/Source/SynHighlighterHP48.pas +++ b/components/synedit/Source/SynHighlighterHP48.pas @@ -45,7 +45,7 @@ unit SynHighlighterHP48; -{$I SynEdit.Inc} +{$I SynEdit.inc} interface diff --git a/components/synedit/Source/SynHighlighterHaskell.pas b/components/synedit/Source/SynHighlighterHaskell.pas index d1ddeda5d..ce1732697 100644 --- a/components/synedit/Source/SynHighlighterHaskell.pas +++ b/components/synedit/Source/SynHighlighterHaskell.pas @@ -51,7 +51,7 @@ unit SynHighlighterHaskell; -{$I SynEdit.Inc} +{$I SynEdit.inc} interface diff --git a/components/synedit/Source/SynHighlighterHtml.pas b/components/synedit/Source/SynHighlighterHtml.pas index 4a4b99054..76dc679b2 100644 --- a/components/synedit/Source/SynHighlighterHtml.pas +++ b/components/synedit/Source/SynHighlighterHtml.pas @@ -48,7 +48,7 @@ interface -{$I SynEdit.Inc} +{$I SynEdit.inc} uses {$IFDEF UNICODE} diff --git a/components/synedit/Source/SynHighlighterIDL.pas b/components/synedit/Source/SynHighlighterIDL.pas index 21c7c0bb5..d311048b3 100644 --- a/components/synedit/Source/SynHighlighterIDL.pas +++ b/components/synedit/Source/SynHighlighterIDL.pas @@ -37,7 +37,7 @@ unit SynHighlighterIDL; -{$I SynEdit.Inc} +{$I SynEdit.inc} interface diff --git a/components/synedit/Source/SynHighlighterIni.pas b/components/synedit/Source/SynHighlighterIni.pas index f747bce86..d4fbbe0ce 100644 --- a/components/synedit/Source/SynHighlighterIni.pas +++ b/components/synedit/Source/SynHighlighterIni.pas @@ -46,7 +46,7 @@ unit SynHighlighterIni; -{$I SynEdit.Inc} +{$I SynEdit.inc} interface diff --git a/components/synedit/Source/SynHighlighterInno.pas b/components/synedit/Source/SynHighlighterInno.pas index 87fbea224..985d96de9 100644 --- a/components/synedit/Source/SynHighlighterInno.pas +++ b/components/synedit/Source/SynHighlighterInno.pas @@ -45,7 +45,7 @@ unit SynHighlighterInno; -{$I SynEdit.Inc} +{$I SynEdit.inc} interface diff --git a/components/synedit/Source/SynHighlighterJSON.pas b/components/synedit/Source/SynHighlighterJSON.pas index 197e2e7b9..7cee7f56b 100644 --- a/components/synedit/Source/SynHighlighterJSON.pas +++ b/components/synedit/Source/SynHighlighterJSON.pas @@ -31,7 +31,7 @@ unit SynHighlighterJSON; -{$I SynEdit.Inc} +{$I SynEdit.inc} interface diff --git a/components/synedit/Source/SynHighlighterJScript.pas b/components/synedit/Source/SynHighlighterJScript.pas index 9497dec04..077186033 100644 --- a/components/synedit/Source/SynHighlighterJScript.pas +++ b/components/synedit/Source/SynHighlighterJScript.pas @@ -46,7 +46,7 @@ unit SynHighlighterJScript; -{$I SynEdit.Inc} +{$I SynEdit.inc} interface diff --git a/components/synedit/Source/SynHighlighterJava.pas b/components/synedit/Source/SynHighlighterJava.pas index 6da2098e2..98a6e3574 100644 --- a/components/synedit/Source/SynHighlighterJava.pas +++ b/components/synedit/Source/SynHighlighterJava.pas @@ -45,7 +45,7 @@ unit SynHighlighterJava; -{$I SynEdit.Inc} +{$I SynEdit.inc} interface diff --git a/components/synedit/Source/SynHighlighterKix.pas b/components/synedit/Source/SynHighlighterKix.pas index 0634984ff..941e7e6e9 100644 --- a/components/synedit/Source/SynHighlighterKix.pas +++ b/components/synedit/Source/SynHighlighterKix.pas @@ -45,7 +45,7 @@ unit SynHighlighterKix; -{$I SynEdit.Inc} +{$I SynEdit.inc} interface diff --git a/components/synedit/Source/SynHighlighterLDraw.pas b/components/synedit/Source/SynHighlighterLDraw.pas index 09b311f72..f5ccdc160 100644 --- a/components/synedit/Source/SynHighlighterLDraw.pas +++ b/components/synedit/Source/SynHighlighterLDraw.pas @@ -44,7 +44,7 @@ unit SynHighlighterLDraw; -{$I SynEdit.Inc} +{$I SynEdit.inc} interface diff --git a/components/synedit/Source/SynHighlighterM3.pas b/components/synedit/Source/SynHighlighterM3.pas index 4d7f7d6ef..70cd27276 100644 --- a/components/synedit/Source/SynHighlighterM3.pas +++ b/components/synedit/Source/SynHighlighterM3.pas @@ -41,7 +41,7 @@ unit SynHighlighterM3; -{$I SynEdit.Inc} +{$I SynEdit.inc} interface diff --git a/components/synedit/Source/SynHighlighterModelica.pas b/components/synedit/Source/SynHighlighterModelica.pas index 22bbf0dc5..1579478a3 100644 --- a/components/synedit/Source/SynHighlighterModelica.pas +++ b/components/synedit/Source/SynHighlighterModelica.pas @@ -36,7 +36,7 @@ unit SynHighlighterModelica; -{$I SynEdit.Inc} +{$I SynEdit.inc} interface diff --git a/components/synedit/Source/SynHighlighterMsg.pas b/components/synedit/Source/SynHighlighterMsg.pas index 762e7a4ea..948e0399a 100644 --- a/components/synedit/Source/SynHighlighterMsg.pas +++ b/components/synedit/Source/SynHighlighterMsg.pas @@ -37,7 +37,7 @@ unit SynHighlighterMsg; -{$I SynEdit.Inc} +{$I SynEdit.inc} interface diff --git a/components/synedit/Source/SynHighlighterPHP.pas b/components/synedit/Source/SynHighlighterPHP.pas index 57a5a68cf..013724af3 100644 --- a/components/synedit/Source/SynHighlighterPHP.pas +++ b/components/synedit/Source/SynHighlighterPHP.pas @@ -48,7 +48,7 @@ unit SynHighlighterPHP; -{$I SynEdit.Inc} +{$I SynEdit.inc} interface diff --git a/components/synedit/Source/SynHighlighterPerl.pas b/components/synedit/Source/SynHighlighterPerl.pas index 7933c402c..d9dc77e65 100644 --- a/components/synedit/Source/SynHighlighterPerl.pas +++ b/components/synedit/Source/SynHighlighterPerl.pas @@ -48,7 +48,7 @@ unit SynHighlighterPerl; -{$I SynEdit.Inc} +{$I SynEdit.inc} interface diff --git a/components/synedit/Source/SynHighlighterProgress.pas b/components/synedit/Source/SynHighlighterProgress.pas index 98c4f50b3..907c26f09 100644 --- a/components/synedit/Source/SynHighlighterProgress.pas +++ b/components/synedit/Source/SynHighlighterProgress.pas @@ -47,7 +47,7 @@ unit SynHighlighterProgress; -{$I SynEdit.Inc} +{$I SynEdit.inc} interface diff --git a/components/synedit/Source/SynHighlighterPython.pas b/components/synedit/Source/SynHighlighterPython.pas index 711b0cbc2..e008075fe 100644 --- a/components/synedit/Source/SynHighlighterPython.pas +++ b/components/synedit/Source/SynHighlighterPython.pas @@ -46,7 +46,7 @@ unit SynHighlighterPython; -{$I SynEdit.Inc} +{$I SynEdit.inc} interface diff --git a/components/synedit/Source/SynHighlighterRC.pas b/components/synedit/Source/SynHighlighterRC.pas index d949a3e3d..41400a66b 100644 --- a/components/synedit/Source/SynHighlighterRC.pas +++ b/components/synedit/Source/SynHighlighterRC.pas @@ -34,7 +34,7 @@ unit SynHighlighterRC; -{$I SynEdit.Inc} +{$I SynEdit.inc} interface diff --git a/components/synedit/Source/SynHighlighterRuby.pas b/components/synedit/Source/SynHighlighterRuby.pas index 526a1abfb..cf5a19157 100644 --- a/components/synedit/Source/SynHighlighterRuby.pas +++ b/components/synedit/Source/SynHighlighterRuby.pas @@ -45,7 +45,7 @@ unit SynHighlighterRuby; -{$I SynEdit.Inc} +{$I SynEdit.inc} interface diff --git a/components/synedit/Source/SynHighlighterSDD.pas b/components/synedit/Source/SynHighlighterSDD.pas index 1422c88e0..398940221 100644 --- a/components/synedit/Source/SynHighlighterSDD.pas +++ b/components/synedit/Source/SynHighlighterSDD.pas @@ -35,7 +35,7 @@ unit SynHighlighterSDD; -{$I SynEdit.Inc} +{$I SynEdit.inc} interface diff --git a/components/synedit/Source/SynHighlighterSQL.pas b/components/synedit/Source/SynHighlighterSQL.pas index 90efd5768..77502d12c 100644 --- a/components/synedit/Source/SynHighlighterSQL.pas +++ b/components/synedit/Source/SynHighlighterSQL.pas @@ -49,7 +49,7 @@ unit SynHighlighterSQL; -{$I SynEdit.Inc} +{$I SynEdit.inc} interface @@ -930,67 +930,97 @@ implementation //---MySQL---------------------------------------------------------------------- // keywords MySqlKW: UnicodeString = - 'ACCOUNT,ACTION,ADD,AFTER,AGAINST,ALGORITHM,ALL,ALTER,ANY,ALWAYS,ANALYZE,' + - 'AND,AS,ASC,AT,AUTO_INCREMENT,AVG_ROW_LENGTH,BEFORE,BEGIN,BETWEEN,BINLOG,' + - 'BLOCK,BOTH,BY,CACHE,CALL,CASCADE,CASCADED,CATALOG_NAME,CHANGE,CHANGED,' + - 'CHANNEL,CHAIN,CHARACTER,CHARSET,CHECK,CHECKSUM,CLASS_ORIGIN,CLIENT,CODE,' + - 'COLLATE,COLLATION,COLUMN,COLUMN_FORMAT,COLUMN_NAME,COLUMNS,COMMENT,' + - 'COMMIT,COMMITTED,COMPLETION,CONCURRENT,CONDITION,CONNECTION,CONSISTENT,' + - 'CONSTRAINT,CONSTRAINT_CATALOG,CONSTRAINT_NAME,CONSTRAINT_SCHEMA,' + - 'CONTAINS,CONTEXT,CONTINUE,CONVERT,COPY,CPU,CREATE,CROSS,CURRENT,CURSOR,' + - 'CURSOR_NAME,CYCLE,DATA,DATABASE,DATABASES,DATAFILE,DAY_HOUR,' + - 'DAY_MICROSECOND,DAY_MINUTE,DAY_SECOND,DEALLOCATE,DECLARE,DEFAULT,' + - 'DEFINER,DELAY_KEY_WRITE,DELAYED,DELETE,DESC,DESCRIBE,DETERMINISTIC,' + - 'DIAGNOSTICS,DIRECTORY,DISABLE,DISCARD,DISTINCT,DISTINCTROW,DIV,DO,DROP,' + - 'DUAL,DUMPFILE,DUPLICATE,EACH,ELSE,ELSEIF,ENABLE,ENCLOSED,END,ENDS,' + - 'ENGINE,ENGINES,ERROR,ERRORS,ESCAPE,ESCAPED,EVENT,EVENTS,EVERY,EXCHANGE,' + - 'EXCLUSIVE,EXECUTE,EXISTS,EXPANSION,EXPIRE,EXPLAIN,EXTENDED,FALSE,FAST,' + - 'FAULTS,FILE_BLOCK_SIZE,FLUSH,FIELDS,FILE,FIRST,FOLLOWS,FOR,FORCE,' + - 'FOREIGN,FOUND,FROM,FULL,FULLTEXT,FUNCTION,GENERAL,GENERATED,GET,GLOBAL,' + - 'GRANT,GRANTS,GROUP,HAVING,HELP,HIGH_PRIORITY,HOST,HOSTS,' + - 'HOUR_MICROSECOND,HOUR_MINUTE,HOUR_SECOND,IDENTIFIED,IGNORE,' + - 'IGNORE_SERVER_IDS,IMPORT,IN,INCREMENT,INDEX,INDEXES,INFILE,INITIAL_SIZE,' + - 'INNER,INOUT,INPLACE,INSTANCE,INSERT,INSERT_METHOD,INSTALL,INTO,INVOKER,' + - 'IO,IPC,IS,ISOLATION,JOIN,JSON,KEY,KEY_BLOCK_SIZE,KEYS,KILL,LANGUAGE,' + - 'LAST,LEADING,LESS,LEVEL,LIKE,LIMIT,LINEAR,LINES,LIST,LOAD,LOCAL,LOCK,' + - 'LOGS,LOW_PRIORITY,MASTER,MASTER_AUTO_POSITION,MASTER_BIND,' + - 'MASTER_CONNECT_RETRY,MASTER_DELAY,MASTER_HEARTBEAT_PERIOD,MASTER_HOST,' + - 'MASTER_LOG_FILE,MASTER_LOG_POS,MASTER_PASSWORD,MASTER_PORT,' + - 'MASTER_RETRY_COUNT,MASTER_SSL,MASTER_SSL_CA,MASTER_SSL_CAPATH,' + - 'MASTER_SSL_CERT,MASTER_SSL_CIPHER,MASTER_SSL_CRL,MASTER_SSL_CRLPATH,' + - 'MASTER_SSL_KEY,MASTER_SSL_VERIFY_SERVER_CERT,MASTER_TLS_VERSION,' + - 'MASTER_USER,MATCH,MAX_QUERIES_PER_HOUR,MAX_ROWS,' + - 'MAX_CONNECTIONS_PER_HOUR,MAX_STATEMENT_TIME,MAX_UPDATES_PER_HOUR,' + - 'MAX_USER_CONNECTIONS,MAXVALUE,MEDIUM,MESSAGE_TEXT,MIGRATE,MIN_ROWS,' + - 'MINUTE_MICROSECOND,MINUTE_SECOND,MINVALUE,MOD,MODE,MODIFIES,MODIFY,' + - 'MUTEX,MYSQL_ERRNO,NAME,NAMES,NATURAL,NEVER,NEW,NEXT,NO,NOCACHE,NOCYCLE,' + - 'NOMAXVALUE,NOMINVALUE,NONE,NOT,NULL,NO_WRITE_TO_BINLOG,NUMBER,OFFSET,' + - 'OJ,OLD,ON,ONE,ONLINE,ONLY,OPEN,OPTIMIZE,OPTION,OPTIONALLY,OPTIONS,OR,' + - 'ORDER,OUT,OUTER,OUTFILE,OWNER,PACK_KEYS,PAGE,PAGE_CHECKSUM,PARSER,' + - 'PARTIAL,PARTITION,PARTITIONING,PARTITIONS,PERSIST,PERSISTENT,PHASE,' + - 'PLUGINS,PLUGIN,PORT,PRECEDES,PREPARE,PRESERVE,PRIMARY,PRIVILEGES,' + - 'PROCEDURE,PROCESS,PROCESSLIST,PROFILE,PROFILES,PROXY,PURGE,QUERY,QUICK,' + - 'RANGE,READ,READS,REBUILD,RECOVER,REFERENCES,REGEXP,RELAY,RELAYLOG,' + - 'RELEASE,RELAY_LOG_FILE,RELAY_LOG_POS,RELOAD,REMOVE,RENAME,REORGANIZE,' + - 'REPAIR,REPEATABLE,REPLACE,REPLICATION,REQUIRE,RESET,RESIGNAL,' + - 'RESTRICT,RESUME,RETURN,RETURNED_SQLSTATE,RETURNS,REVOKE,RLIKE,ROLLBACK,' + - 'ROLLUP,ROTATE,ROUTINE,ROW,ROW_FORMAT,ROWS,SAVEPOINT,SCHEDULE,SCHEMA,' + - 'SCHEMA_NAME,SECOND_MICROSECOND,SECURITY,SELECT,SEPARATOR,SEQUENCE,' + - 'SERIALIZABLE,SERVER,SESSION,SET,SHARE,SHARED,SHOW,SHUTDOWN,SIGNAL,' + - 'SIMPLE,SLAVE,SLOW,SNAPSHOT,SOCKET,SOME,SONAME,SOUNDS,SOURCE,SPATIAL,' + - 'SQL,SQL_BIG_RESULT,SQL_BUFFER_RESULT,SQL_CACHE,SQL_CALC_FOUND_ROWS,' + - 'SQL_NO_CACHE,SQL_SMALL_RESULT,SQL_TSI_DAY,SQL_TSI_HOUR,' + - 'SQL_TSI_MICROSECOND,SQL_TSI_MINUTE,SQL_TSI_MONTH,SQL_TSI_QUARTER,' + - 'SQL_TSI_SECOND,SQL_TSI_WEEK,SQL_TSI_YEAR,SQLEXCEPTION,SQLSTATE,' + - 'SQLWARNING,STACKED,STARTING,START,STARTS,STATS_AUTO_RECALC,' + - 'STATS_PERSISTENT,STATS_SAMPLE_PAGES,STATUS,STOP,STORAGE,STORED,' + - 'STRAIGHT_JOIN,SUBCLASS_ORIGIN,SUBPARTITION,SUBPARTITIONS,SUPER,SUSPEND,' + - 'SWAPS,SWITCHES,TABLE,TABLE_CHECKSUM,TABLE_NAME,TABLES,TABLESPACE,' + - 'TEMPORARY,TERMINATED,THAN,TO,TRADITIONAL,TRAILING,TRANSACTION,' + - 'TRANSACTIONAL,TRIGGER,TRIGGERS,TRUE,TYPE,UNCOMMITTED,UNDO,UNINSTALL,' + - 'UNION,UNIQUE,UNKNOWN,UNLOCK,UPDATE,UPGRADE,USAGE,USE,USE_FRM,' + - 'USING,VALIDATION,VALUE,VALUES,VARIABLES,VIEW,VIRTUAL,WAIT,WARNINGS,' + - 'WHERE,WRAPPER,WRITE,WITH,WITHOUT,WORK,XA,XID,XML,XOR,YEAR_MONTH'; + 'ACCESSIBLE,ACCOUNT,ACTION,ACTIVE,ADD,ADMIN,AFTER,AGAINST,AGGREGATE,' + + 'ALGORITHM,ALL,ALTER,ALWAYS,ANALYSE,ANALYZE,AND,ANY,ARRAY,AS,ASC,' + + 'ASENSITIVE,AT,ATTRIBUTE,AUTHENTICATION,AUTOEXTEND_SIZE,AUTO_INCREMENT,' + + 'AVG_ROW_LENGTH,BACKUP,BEFORE,BEGIN,BETWEEN,BINLOG,BIT,BLOCK,BOTH,BUCKETS,' + + 'BULK,BY,CACHE,CALL,CASCADE,CASCADED,CATALOG_NAME,CHAIN,CHALLENGE_RESPONSE,' + + 'CHANGE,CHANGED,CHANNEL,CHARACTER,CHARSET,CHECK,CHECKSUM,CIPHER,' + + 'CLASS_ORIGIN,CLIENT,CLONE,CODE,COLLATE,COLLATION,COLUMN,COLUMNS,' + + 'COLUMN_FORMAT,COLUMN_NAME,COMMENT,COMMIT,COMMITTED,COMPLETION,COMPONENT,' + + 'COMPRESSION,CONCURRENT,CONDITION,CONNECTION,CONSISTENT,CONSTRAINT,' + + 'CONSTRAINT_CATALOG,CONSTRAINT_NAME,CONSTRAINT_SCHEMA,CONTAINS,CONTEXT,' + + 'CONTINUE,CONVERT,CPU,CREATE,CROSS,CUBE,CUME_DIST,CURRENT,CURSOR,' + + 'CURSOR_NAME,DATA,DATABASE,DATABASES,DATAFILE,DAY_HOUR,DAY_MICROSECOND,' + + 'DAY_MINUTE,DAY_SECOND,DEALLOCATE,DEC,DECLARE,DEFAULT,DEFAULT_AUTH,DEFINER,' + + 'DEFINITION,DELAYED,DELAY_KEY_WRITE,DELETE,DENSE_RANK,DESC,DESCRIBE,' + + 'DESCRIPTION,DES_KEY_FILE,DETERMINISTIC,DIAGNOSTICS,DIRECTORY,DISABLE,' + + 'DISCARD,DISTINCT,DISTINCTROW,DIV,DO,DROP,DUAL,DUMPFILE,DUPLICATE,EACH,' + + 'ELSE,ELSEIF,EMPTY,ENABLE,ENCLOSED,ENCRYPTION,END,ENDS,ENFORCED,ENGINE,' + + 'ENGINES,ENGINE_ATTRIBUTE,ERROR,ERRORS,ESCAPE,ESCAPED,EVENT,EVENTS,EVERY,' + + 'EXCEPT,EXCHANGE,EXCLUDE,EXECUTE,EXISTS,EXPANSION,EXPIRE,EXPLAIN,EXPORT,' + + 'EXTENDED,EXTENT_SIZE,FACTOR,FAILED_LOGIN_ATTEMPTS,FALSE,FAST,FAULTS,' + + 'FIELDS,FILE,FILE_BLOCK_SIZE,FILTER,FINISH,FIRST,FIRST_VALUE,FLOAT4,FLOAT8,' + + 'FLUSH,FOLLOWING,FOLLOWS,FOR,FORCE,FOREIGN,FOUND,FROM,FULL,FULLTEXT,' + + 'FUNCTION,GENERAL,GENERATE,GENERATED,GEOMCOLLECTION,GET,' + + 'GET_MASTER_PUBLIC_KEY,GET_SOURCE_PUBLIC_KEY,GLOBAL,GRANT,GRANTS,GROUP,' + + 'GROUPING,GROUPS,GROUP_REPLICATION,GTID_ONLY,HAVING,HELP,HIGH_PRIORITY,' + + 'HISTOGRAM,HISTORY,HOST,HOSTS,HOUR_MICROSECOND,HOUR_MINUTE,HOUR_SECOND,' + + 'IDENTIFIED,IGNORE,IGNORE_SERVER_IDS,IMPORT,IN,INACTIVE,INDEX,INDEXES,' + + 'INFILE,INITIAL,INITIAL_SIZE,INITIATE,INNER,INOUT,INSENSITIVE,INSERT,' + + 'INSERT_METHOD,INSTALL,INSTANCE,INT1,INT2,INT3,INT4,INT8,INTERSECT,INTO,' + + 'INVISIBLE,INVOKER,IO,IO_AFTER_GTIDS,IO_BEFORE_GTIDS,IO_THREAD,IPC,IS,' + + 'ISOLATION,ISSUER,JOIN,JSON,JSON_TABLE,JSON_VALUE,KEY,KEYRING,KEYS,' + + 'KEY_BLOCK_SIZE,KILL,LAG,LANGUAGE,LAST,LAST_VALUE,LATERAL,LEAD,LEADING,' + + 'LEAVES,LESS,LEVEL,LIKE,LIMIT,LINEAR,LINES,LIST,LOAD,LOCAL,LOCK,LOCKED,' + + 'LOCKS,LOGFILE,LOGS,LONG,LOW_PRIORITY,MASTER,MASTER_AUTO_POSITION,' + + 'MASTER_BIND,MASTER_COMPRESSION_ALGORITHMS,MASTER_CONNECT_RETRY,' + + 'MASTER_DELAY,MASTER_HEARTBEAT_PERIOD,MASTER_HOST,MASTER_LOG_FILE,' + + 'MASTER_LOG_POS,MASTER_PASSWORD,MASTER_PORT,MASTER_PUBLIC_KEY_PATH,' + + 'MASTER_RETRY_COUNT,MASTER_SERVER_ID,MASTER_SSL,MASTER_SSL_CA,' + + 'MASTER_SSL_CAPATH,MASTER_SSL_CERT,MASTER_SSL_CIPHER,MASTER_SSL_CRL,' + + 'MASTER_SSL_CRLPATH,MASTER_SSL_KEY,MASTER_SSL_VERIFY_SERVER_CERT,' + + 'MASTER_TLS_CIPHERSUITES,MASTER_TLS_VERSION,MASTER_USER,' + + 'MASTER_ZSTD_COMPRESSION_LEVEL,MATCH,MAXVALUE,MAX_CONNECTIONS_PER_HOUR,' + + 'MAX_QUERIES_PER_HOUR,MAX_ROWS,MAX_SIZE,MAX_UPDATES_PER_HOUR,' + + 'MAX_USER_CONNECTIONS,MEDIUM,MEMBER,MESSAGE_TEXT,MIDDLEINT,MIGRATE,' + + 'MINUTE_MICROSECOND,MINUTE_SECOND,MIN_ROWS,MOD,MODE,MODIFIES,MODIFY,MUTEX,' + + 'MYSQL_ERRNO,NAME,NAMES,NATURAL,NCHAR,NESTED,NETWORK_NAMESPACE,NEVER,NEW,' + + 'NEXT,NO,NODEGROUP,NONE,NOT,NOWAIT,NO_WAIT,NO_WRITE_TO_BINLOG,NTH_VALUE,' + + 'NTILE,NULL,NULLS,NUMBER,NVARCHAR,OF,OFF,OFFSET,OJ,OLD,ON,ONE,ONLY,OPEN,' + + 'OPTIMIZE,OPTIMIZER_COSTS,OPTION,OPTIONAL,OPTIONALLY,OPTIONS,OR,ORDER,' + + 'ORDINALITY,ORGANIZATION,OTHERS,OUT,OUTER,OUTFILE,OVER,OWNER,PACK_KEYS,' + + 'PAGE,PARSER,PARSE_GCOL_EXPR,PARTIAL,PARTITION,PARTITIONING,PARTITIONS,' + + 'PASSWORD_LOCK_TIME,PATH,PERCENT_RANK,PERSIST,PERSIST_ONLY,PHASE,PLUGIN,' + + 'PLUGINS,PLUGIN_DIR,PORT,PRECEDES,PRECEDING,PREPARE,PRESERVE,PREV,PRIMARY,' + + 'PRIVILEGES,PRIVILEGE_CHECKS_USER,PROCEDURE,PROCESS,PROCESSLIST,PROFILE,' + + 'PROFILES,PROXY,PURGE,QUERY,QUICK,RANDOM,RANGE,RANK,READ,READS,READ_ONLY,' + + 'READ_WRITE,REBUILD,RECOVER,RECURSIVE,REDOFILE,REDO_BUFFER_SIZE,REFERENCE,' + + 'REFERENCES,REGEXP,REGISTRATION,RELAY,RELAYLOG,RELAY_LOG_FILE,' + + 'RELAY_LOG_POS,RELAY_THREAD,RELEASE,RELOAD,REMOTE,REMOVE,RENAME,REORGANIZE,' + + 'REPAIR,REPEATABLE,REPLACE,REPLICA,REPLICAS,REPLICATE_DO_DB,' + + 'REPLICATE_DO_TABLE,REPLICATE_IGNORE_DB,REPLICATE_IGNORE_TABLE,' + + 'REPLICATE_REWRITE_DB,REPLICATE_WILD_DO_TABLE,REPLICATE_WILD_IGNORE_TABLE,' + + 'REPLICATION,REQUIRE,REQUIRE_ROW_FORMAT,RESET,RESIGNAL,RESOURCE,RESPECT,' + + 'RESTART,RESTORE,RESTRICT,RESUME,RETAIN,RETURN,RETURNED_SQLSTATE,RETURNING,' + + 'RETURNS,REUSE,REVOKE,RLIKE,ROLE,ROLLBACK,ROLLUP,ROTATE,ROUTINE,ROW,ROWS,' + + 'ROW_FORMAT,ROW_NUMBER,RTREE,SAVEPOINT,SCHEDULE,SCHEMA,SCHEMAS,SCHEMA_NAME,' + + 'SECONDARY,SECONDARY_ENGINE,SECONDARY_ENGINE_ATTRIBUTE,SECONDARY_LOAD,' + + 'SECONDARY_UNLOAD,SECOND_MICROSECOND,SECURITY,SELECT,SENSITIVE,SEPARATOR,' + + 'SERIALIZABLE,SERVER,SESSION,SET,SHARE,SHOW,SHUTDOWN,SIGNAL,SIMPLE,SKIP,' + + 'SLAVE,SLOW,SNAPSHOT,SOCKET,SOME,SONAME,SOUNDS,SOURCE,SOURCE_AUTO_POSITION,' + + 'SOURCE_BIND,SOURCE_COMPRESSION_ALGORITHMS,SOURCE_CONNECT_RETRY,' + + 'SOURCE_DELAY,SOURCE_HEARTBEAT_PERIOD,SOURCE_HOST,SOURCE_LOG_FILE,' + + 'SOURCE_LOG_POS,SOURCE_PASSWORD,SOURCE_PORT,SOURCE_PUBLIC_KEY_PATH,' + + 'SOURCE_RETRY_COUNT,SOURCE_SSL,SOURCE_SSL_CA,SOURCE_SSL_CAPATH,' + + 'SOURCE_SSL_CERT,SOURCE_SSL_CIPHER,SOURCE_SSL_CRL,SOURCE_SSL_CRLPATH,' + + 'SOURCE_SSL_KEY,SOURCE_SSL_VERIFY_SERVER_CERT,SOURCE_TLS_CIPHERSUITES,' + + 'SOURCE_TLS_VERSION,SOURCE_USER,SOURCE_ZSTD_COMPRESSION_LEVEL,SPATIAL,' + + 'SPECIFIC,SQL,SQLEXCEPTION,SQLSTATE,SQLWARNING,SQL_AFTER_GTIDS,' + + 'SQL_AFTER_MTS_GAPS,SQL_BEFORE_GTIDS,SQL_BIG_RESULT,SQL_BUFFER_RESULT,' + + 'SQL_CACHE,SQL_CALC_FOUND_ROWS,SQL_NO_CACHE,SQL_SMALL_RESULT,SQL_THREAD,' + + 'SQL_TSI_DAY,SQL_TSI_HOUR,SQL_TSI_MINUTE,SQL_TSI_MONTH,SQL_TSI_QUARTER,' + + 'SQL_TSI_SECOND,SQL_TSI_WEEK,SQL_TSI_YEAR,SSL,STACKED,START,STARTING,' + + 'STARTS,STATS_AUTO_RECALC,STATS_PERSISTENT,STATS_SAMPLE_PAGES,STATUS,STOP,' + + 'STORAGE,STORED,STRAIGHT_JOIN,STREAM,SUBCLASS_ORIGIN,SUBJECT,SUBPARTITION,' + + 'SUBPARTITIONS,SUPER,SUSPEND,SWAPS,SWITCHES,SYSTEM,TABLE,TABLES,TABLESPACE,' + + 'TABLE_CHECKSUM,TABLE_NAME,TEMPORARY,TERMINATED,THAN,THREAD_PRIORITY,TIES,' + + 'TLS,TO,TRAILING,TRANSACTION,TRIGGER,TRIGGERS,TRUE,TYPE,TYPES,UNBOUNDED,' + + 'UNCOMMITTED,UNDO,UNDOFILE,UNDO_BUFFER_SIZE,UNINSTALL,UNION,UNIQUE,UNKNOWN,' + + 'UNLOCK,UNREGISTER,UPDATE,UPGRADE,URL,USAGE,USE,USER_RESOURCES,USE_FRM,' + + 'USING,VALIDATION,VALUE,VALUES,VARCHARACTER,VARIABLES,VARYING,VCPU,VIEW,' + + 'VIRTUAL,VISIBLE,WAIT,WARNINGS,WHERE,WINDOW,WITH,WITHOUT,WORK,WRAPPER,' + + 'WRITE,X509,XA,XID,XML,XOR,YEAR_MONTH,ZONE'; // PLSQL keywords MySQLPLSQLKW: UnicodeString = @@ -1012,7 +1042,7 @@ implementation 'longtext,mediumblob,mediumint,mediumtext,multilinestring,multipoint,' + 'multipolygon,national,numeric,point,polygon,precision,real,serial,' + 'signed,smallint,string,text,time,timestamp,tinyblob,tinyint,tinytext,' + - 'unicode,unsigned,varbinary,varchar,year,zerofill,' + + 'unicode,unsigned,varbinary,varchar,vector,year,zerofill,' + // Row Formats 'COMPACT,COMPRESSED,DISK,DYNAMIC,FIXED,REDUNDANT,' + @@ -1095,74 +1125,76 @@ implementation 'utf8_vietnamese_ci'; // functions - // Taken from MariaDB 10.5.5 help tables MySQLFunctions: UnicodeString = - 'ABS,ACOS,ADDDATE,ADDTIME,AES_DECRYPT,AES_ENCRYPT,AREA,ASBINARY,ASCII' + - 'ASIN,ASTEXT,ASWKB,ASWKT,ATAN,ATAN2,AVG,BENCHMARK,BIN,BINLOG_GTID_POS' + - 'BIT_AND,BIT_COUNT,BIT_LENGTH,BIT_OR,BIT_XOR,BOUNDARY,BUFFER,CAST,CEIL' + - 'CEILING,CENTROID,CHARACTER_LENGTH,CHAR_LENGTH,CHR,COERCIBILITY' + - 'COLUMN_ADD,COLUMN_CHECK,COLUMN_CREATE,COLUMN_DELETE,COLUMN_EXISTS' + - 'COLUMN_GET,COLUMN_JSON,COLUMN_LIST,COMPRESS,CONCAT,CONCAT_WS' + - 'CONNECTION_ID,CONV,CONVERT_TZ,CONVEXHULL,COS,COT,COUNT,CRC32,CROSSES' + - 'CUME_DIST,CURDATE,CURRENT_DATE,CURRENT_ROLE,CURRENT_TIME' + - 'CURRENT_TIMESTAMP,CURRENT_USER,CURTIME,DATEDIFF,DATE_ADD,DATE_FORMAT' + - 'DATE_SUB,DAY,DAYNAME,DAYOFMONTH,DAYOFWEEK,DAYOFYEAR,DECODE' + - 'DECODE_HISTOGRAM,DEGREES,DENSE_RANK,DES_DECRYPT,DES_ENCRYPT,DIMENSION' + - 'DISJOINT,ELT,ENCODE,ENCRYPT,ENDPOINT,ENVELOPE,EQUALS,EXP,EXPORT_SET' + - 'EXTERIORRING,EXTRACT,EXTRACTVALUE,FIELD,FIND_IN_SET,FIRST_VALUE,FLOOR' + - 'FORMAT,FOUND_ROWS,FROM_BASE64,FROM_DAYS,FROM_UNIXTIME,GEOMCOLLFROMTEXT' + - 'GEOMCOLLFROMWKB,GEOMETRYCOLLECTIONFROMTEXT,GEOMETRYCOLLECTIONFROMWKB' + - 'GEOMETRYFROMTEXT,GEOMETRYFROMWKB,GEOMETRYN,GEOMETRYTYPE,GEOMFROMTEXT' + - 'GEOMFROMWKB,GET_FORMAT,GET_LOCK,GLENGTH,GROUP_CONCAT,HELP_DATE,HEX' + - 'HOUR,IFNULL,INET6_ATON,INET6_NTOA,INET_ATON,INET_NTOA,INSTR' + - 'INTERIORRINGN,INTERSECTS,ISCLOSED,ISEMPTY,ISRING,ISSIMPLE,IS_FREE_LOCK' + - 'IS_IPV4,IS_IPV4_COMPAT,IS_IPV4_MAPPED,IS_IPV6,IS_USED_LOCK,JSON_ARRAY' + - 'JSON_ARRAY_APPEND,JSON_ARRAY_INSERT,JSON_COMPACT,JSON_CONTAINS' + - 'JSON_CONTAINS_PATH,JSON_DEPTH,JSON_DETAILED,JSON_EXISTS,JSON_EXTRACT' + - 'JSON_INSERT,JSON_KEYS,JSON_LENGTH,JSON_LOOSE,JSON_MERGE,JSON_OBJECT' + - 'JSON_QUERY,JSON_QUOTE,JSON_REMOVE,JSON_REPLACE,JSON_SEARCH,JSON_SET' + - 'JSON_TYPE,JSON_UNQUOTE,JSON_VALID,JSON_VALUE,LABELS,LAG,LASTVAL' + - 'LAST_DAY,LAST_INSERT_ID,LAST_VALUE,LCASE,LEFT,LENGTH,LENGTHB' + - 'LINEFROMTEXT,LINEFROMWKB,LINESTRINGFROMTEXT,LINESTRINGFROMWKB,LN' + - 'LOAD_FILE,LOCALTIME,LOCALTIMESTAMP,LOCATE,LOG,LOG10,LOG2,LOWER,LPAD' + - 'LTRIM,MAKEDATE,MAKETIME,MAKE_SET,MASTER_GTID_WAIT,MASTER_POS_WAIT,MAX' + - 'MBRCONTAINS,MBRDISJOINT,MBREQUAL,MBRINTERSECTS,MBROVERLAPS,MBRTOUCHES' + - 'MBRWITHIN,MD5,MEDIAN,MICROSECOND,MID,MIN,MINUTE,MLINEFROMTEXT' + - 'MLINEFROMWKB,MONTH,MONTHNAME,MPOINTFROMTEXT,MPOINTFROMWKB' + - 'MPOLYFROMTEXT,MPOLYFROMWKB,MULTILINESTRINGFROMTEXT' + - 'MULTILINESTRINGFROMWKB,MULTIPOINTFROMTEXT,MULTIPOINTFROMWKB' + - 'MULTIPOLYGONFROMTEXT,MULTIPOLYGONFROMWKB,NAME_CONST,NEXTVAL,NOW' + - 'NTH_VALUE,NTILE,NULLIF,NUMGEOMETRIES,NUMINTERIORRINGS,NUMPOINTS,OCT' + - 'OCTET_LENGTH,OLD_PASSWORD,ORD,OVERLAPS,PARENTHESES,PASSWORD' + - 'PERCENTILE_CONT,PERCENTILE_DISC,PERCENT_RANK,PERIOD_ADD,PERIOD_DIFF,PI' + - 'POINTFROMTEXT,POINTFROMWKB,POINTN,POINTONSURFACE,POLYFROMTEXT' + - 'POLYFROMWKB,POLYGONFROMTEXT,POLYGONFROMWKB,POSITION,POW,POWER,QUARTER' + - 'QUOTE,RADIANS,RAND,RANK,REGEXP_INSTR,REGEXP_REPLACE,REGEXP_SUBSTR' + - 'RELEASE_LOCK,REVERSE,RIGHT,ROUND,ROW_COUNT,ROW_NUMBER,RPAD,RTRIM' + - 'SECOND,SEC_TO_TIME,SESSION_USER,SETVAL(),SHA1,SHA2,SIGN,SIN,SLEEP' + - 'SOUNDEX,SPACE,SPIDER_BG_DIRECT_SQL,SPIDER_COPY_TABLES' + - 'SPIDER_DIRECT_SQL,SPIDER_FLUSH_TABLE_MON_CACHE,SQRT,SRID,STARTPOINT' + - 'STD,STDDEV,STDDEV_POP,STDDEV_SAMP,STRCMP,STR_TO_DATE,ST_AREA' + - 'ST_ASBINARY,ST_ASTEXT,ST_ASWKB,ST_ASWKT,ST_BOUNDARY,ST_BUFFER' + - 'ST_CENTROID,ST_CONTAINS,ST_CONVEXHULL,ST_CROSSES,ST_DIFFERENCE' + - 'ST_DIMENSION,ST_DISJOINT,ST_DISTANCE,ST_ENDPOINT,ST_ENVELOPE,ST_EQUALS' + - 'ST_EXTERIORRING,ST_GEOMCOLLFROMTEXT,ST_GEOMCOLLFROMWKB' + - 'ST_GEOMETRYCOLLECTIONFROMTEXT,ST_GEOMETRYCOLLECTIONFROMWKB' + - 'ST_GEOMETRYFROMTEXT,ST_GEOMETRYFROMWKB,ST_GEOMETRYN,ST_GEOMETRYTYPE' + - 'ST_GEOMFROMTEXT,ST_GEOMFROMWKB,ST_INTERIORRINGN,ST_INTERSECTION' + - 'ST_INTERSECTS,ST_ISCLOSED,ST_ISEMPTY,ST_ISRING,ST_ISSIMPLE,ST_LENGTH' + - 'ST_LINEFROMTEXT,ST_LINEFROMWKB,ST_LINESTRINGFROMTEXT' + - 'ST_LINESTRINGFROMWKB,ST_NUMGEOMETRIES,ST_NUMINTERIORRINGS,ST_NUMPOINTS' + - 'ST_OVERLAPS,ST_POINTFROMTEXT,ST_POINTFROMWKB,ST_POINTN' + - 'ST_POINTONSURFACE,ST_POLYFROMTEXT,ST_POLYFROMWKB,ST_POLYGONFROMTEXT' + - 'ST_POLYGONFROMWKB,ST_RELATE,ST_SRID,ST_SYMDIFFERENCE,ST_TOUCHES' + - 'ST_UNION,ST_WITHIN,ST_X,ST_Y,SUBDATE,SUBSTR,SUBSTRING,SUBSTRING_INDEX' + - 'SUBTIME,SUM,SYSDATE,SYSTEM_USER,TAN,TIMEDIFF,TIMESTAMPADD' + - 'TIMESTAMPDIFF,TIME_FORMAT,TIME_TO_SEC,TOUCHES,TO_BASE64,TO_DAYS' + - 'TO_SECONDS,TRIM,TRUNCATE,UCASE,UNCOMPRESS,UNCOMPRESSED_LENGTH,UNHEX' + - 'UNIX_TIMESTAMP,UPDATEXML,UPPER,USER,UTC_DATE,UTC_TIME,UTC_TIMESTAMP' + - 'UUID,UUID_SHORT,VARIANCE,VAR_POP,VAR_SAMP,VERSION,WEEK,WEEKDAY' + - 'WEEKOFYEAR,WEIGHT_STRING,WITHIN,X,Y,YEARWEEK'; + 'ABS,ACOS,ADDDATE,ADDTIME,AES_DECRYPT,AES_ENCRYPT,ANY_VALUE,AREA,' + + 'ASBINARY,ASCII,ASIN,ASTEXT,ASWKBASWKT,ASYMMETRIC_DECRYPT,' + + 'ASYMMETRIC_DERIVE,ASYMMETRIC_ENCRYPT,ASYMMETRIC_SIGN,ASYMMETRIC_VERIFY,' + + 'ATAN,ATAN2,AVG,BIN,BIT_AND,BIT_COUNT,BIT_LENGTH,BIT_OR,BIT_XOR,BUFFER,' + + 'CAST,CEIL,CEILING,CENTROID,CHAR_LENGTH,CHARACTER_LENGTH,COALESCE,' + + 'COERCIBILITY,COMPRESS,CONCAT,CONCAT_WS,CONNECTION_ID,CONV,CONVERT_TZ,' + + 'CONVEXHULL,COS,COT,COUNT,CRC32,CREATE_ASYMMETRIC_PRIV_KEY,' + + 'CREATE_ASYMMETRIC_PUB_KEY,CREATE_DH_PARAMETERS,CREATE_DIGEST,CROSSES,' + + 'CURDATE,CURRENT_DATE,CURRENT_TIME,CURRENT_TIMESTAMP,CURRENT_USER,' + + 'CURTIME,DATE_ADD,DATE_FORMAT,DATE_SUB,DATEDIFF,DAY,DAYNAME,DAYOFMONTH,' + + 'DAYOFWEEK,DAYOFYEAR,DECODE,DEGREES,DES_DECRYPT,DES_ENCRYPT,DIMENSION,' + + 'DISJOINT,DISTANCE,ELT,ENCODE,ENCRYPT,ENDPOINT,ENVELOPE,EQUALS,EXP,' + + 'EXPORT_SET,EXTERIORRING,EXTRACT,EXTRACTVALUE,FIELD,FIND_IN_SET,FLOOR,' + + 'FORMAT,FOUND_ROWS,FROM_BASE64,FROM_DAYS,FROM_UNIXTIME,GEOMCOLLFROMTEXT,' + + 'GEOMCOLLFROMWKB,GEOMETRYCOLLECTIONFROMTEXT,GEOMETRYCOLLECTIONFROMWKB,' + + 'GEOMETRYFROMTEXT,GEOMETRYFROMWKB,GEOMETRYN,GEOMETRYTYPE,GEOMFROMTEXT,' + + 'GEOMFROMWKB,GET_FORMAT,GET_LOCK,GLENGTH,GREATEST,GROUP_CONCAT,' + + 'GTID_SUBSET,GTID_SUBTRACT,HEX,HOUR,IFNULL,INET_ATON,INET_NTOA,' + + 'INET6_ATON,INET6_NTOA,INSTR,INTERIORRINGN,INTERSECTS,INTERVAL,' + + 'IS_FREE_LOCK,IS_IPV4,IS_IPV4_COMPAT,IS_IPV4_MAPPED,IS_IPV6,IS_USED_LOCK,' + + 'ISCLOSED,ISEMPTY,ISNULL,ISSIMPLE,JSON_APPEND,JSON_ARRAY,' + + 'JSON_ARRAY_APPEND,JSON_ARRAY_INSERT,JSON_CONTAINS,JSON_CONTAINS_PATH,' + + 'JSON_DEPTH,JSON_EXTRACT,JSON_INSERT,JSON_KEYS,JSON_LENGTH,JSON_MERGE,' + + 'JSON_OBJECT,JSON_QUOTE,JSON_REMOVE,JSON_REPLACE,JSON_SEARCH,JSON_SET,' + + 'JSON_TYPE,JSON_UNQUOTE,JSON_VALID,LAST_DAY,LAST_INSERT_ID,LCASE,LEAST,' + + 'LEFT,LENGTH,LINEFROMTEXT,LINEFROMWKB,LINESTRINGFROMTEXT,' + + 'LINESTRINGFROMWKB,LN,LOAD_FILE,LOCALTI,LOCALTIME,LOCALTIMESTAMP,LOCATE,' + + 'LOG,LOG10,LOG2,LOWER,LPAD,LTRIM,MAKE_SET,MAKEDATE,MAKETIME,' + + 'MASTER_POS_WAIT,MAX,MBRCONTAINS,MBRCOVEREDBY,MBRCOVERS,MBRDISJOINT,' + + 'MBREQUAL,MBREQUALS,MBRINTERSECTS,MBROVERLAPS,MBRTOUCHES,MBRWITHIN,MD5,' + + 'MICROSECOND,MID,MIN,MINUTE,MLINEFROMTEXT,MLINEFROMWKB,MONTH,' + + 'MONTHNAME,MPOINTFROMTEXT,MPOINTFROMWKB,MPOLYFROMTEXT,MPOLYFROMWKB,' + + 'MULTILINESTRINGFROMTEXT,MULTILINESTRINGFROMWKB,MULTIPOINTFROMTEXT,' + + 'MULTIPOINTFROMWKB,MULTIPOLYGONFROMTEXT,MULTIPOLYGONFROMWKB,NAME_CONST,' + + 'NOW,NULLIF,NUMGEOMETRIES,NUMINTERIORRINGS,NUMPOINTS,OCT,OCTET_LENGTH,' + + 'OLD_PASSWORD,ORD,OVERLAPS,PASSWORD,PERIOD_ADD,PERIOD_DIFF,PI,' + + 'POINTFROMTEXT,POINTFROMWKB,POINTN,POLYFROMTEXT,POLYFROMWKB,' + + 'POLYGONFROMTEXT,POLYGONFROMWKB,POSITION,POW,POWER,QUARTER,QUOTE,RADIANS,' + + 'RAND,RANDOM_BYTES,RELEASE_ALL_LOCKS,RELEASE_LOCK,REVERSE,RIGHT,ROUND,' + + 'ROW_COUNT,RPAD,RTRIM,SEC_TO_TIME,SECOND,SESSION_USER,SHA,SHA1,SHA2,SIGN,' + + 'SIN,SLEEP,SOUNDEX,SPACE,SQRT,SRID,ST_AREA,ST_ASBINARY,ST_ASGEOJSON,' + + 'ST_ASTEXT,ST_ASWKB,ST_ASWKT,ST_BUFFER,ST_BUFFER_STRATEGY,ST_CENTROID,' + + 'ST_CONTAINS,ST_CONVEXHULL,ST_CROSSES,ST_DIFFERENCE,ST_DIMENSION,' + + 'ST_DISJOINT,ST_DISTANCE,ST_DISTANCE_SPHERE,ST_ENDPOINT,ST_ENVELOPE,' + + 'ST_EQUALS,ST_EXTERIORRING,ST_GEOHASH,ST_GEOMCOLLFROMTEXT,' + + 'ST_GEOMCOLLFROMTXT,ST_GEOMCOLLFROMWKB,ST_GEOMETRYCOLLECTIONFROMTEXT,' + + 'ST_GEOMETRYCOLLECTIONFROMWKB,ST_GEOMETRYFROMTEXT,ST_GEOMETRYFROMWKB,' + + 'ST_GEOMETRYN,ST_GEOMETRYTYPE,ST_GEOMFROMGEOJSON,ST_GEOMFROMTEXT,' + + 'ST_GEOMFROMWKB,ST_INTERIORRINGN,ST_INTERSECTION,ST_INTERSECTS,' + + 'ST_ISCLOSED,ST_ISEMPTY,ST_ISSIMPLE,ST_ISVALID,ST_LATFROMGEOHASH,' + + 'ST_LENGTH,ST_LINEFROMTEXT,ST_LINEFROMWKB,ST_LINESTRINGFROMTEXT,' + + 'ST_LINESTRINGFROMWKB,ST_LONGFROMGEOHASH,ST_MAKEENVELOPE,' + + 'ST_MLINEFROMTEXT,ST_MLINEFROMWKB,ST_MPOINTFROMTEXT,ST_MPOINTFROMWKB,' + + 'ST_MPOLYFROMTEXT,ST_MPOLYFROMWKB,ST_MULTILINESTRINGFROMTEXT,' + + 'ST_MULTILINESTRINGFROMWKB,ST_MULTIPOINTFROMTEXT,ST_MULTIPOINTFROMWKB,' + + 'ST_MULTIPOLYGONFROMTEXT,ST_MULTIPOLYGONFROMWKB,ST_NUMGEOMETRIES,' + + 'ST_NUMINTERIORRING,ST_NUMINTERIORRINGS,ST_NUMPOINTS,ST_OVERLAPS,' + + 'ST_POINTFROMGEOHASH,ST_POINTFROMTEXT,ST_POINTFROMWKB,ST_POINTN,' + + 'ST_POLYFROMTEXT,ST_POLYFROMWKB,ST_POLYGONFROMTEXT,ST_POLYGONFROMWKB,' + + 'ST_SIMPLIFY,ST_SRID,ST_STARTPOINT,ST_SYMDIFFERENCE,ST_TOUCHES,ST_UNION,' + + 'ST_VALIDATE,ST_WITHIN,ST_X,ST_Y,STARTPOINT,STD,STDDEV,STDDEV_POP,' + + 'STDDEV_SAMP,STR_TO_DATE,STRCMP,SUBDATE,SUBSTR,SUBSTRING,SUBSTRING_INDEX,' + + 'SUBTIME,SUM,SYSDATE,SYSTEM_USER,TAN,TIME_FORMAT,TIME_TO_SEC,TIMEDIFF,' + + 'TIMESTAMPADD,TIMESTAMPDIFF,TO_BASE64,TO_DAYS,TO_SECONDS,TOUCHES,TRIM,' + + 'TRUNCATE,UCASE,UNCOMPRESS,UNCOMPRESSED_LENGTH,UNHEX,UNIX_TIMESTAMP,' + + 'UPDATEXML,UPPER,USER,UTC_DATE,UTC_TIME,UTC_TIMESTAMP,UUID,UUID_SHORT,' + + 'VALIDATE_PASSWORD_STRENGTH,VAR_POP,VAR_SAMP,VARIANCE,VERSION,' + + 'WAIT_FOR_EXECUTED_GTID_SET,WAIT_UNTIL_SQL_THREAD_AFTER_GTIDS,WEEK,' + + 'WEEKDAY,WEEKOFYEAR,WEIGHT_STRING,WITHIN,X,Y,YEARWEEK'; //---Ingres--------------------------------------------------------------------- // keywords @@ -1641,7 +1673,7 @@ procedure TSynSQLSyn.LowerProc; procedure TSynSQLSyn.MinusProc; begin Inc(Run); - if (FLine[Run] = '-') and ((FDialect <> sqlMySQL) or (FLine[Run+1] = ' ')) then + if (FLine[Run] = '-') and ((FDialect <> sqlMySQL) or IsWhiteChar(FLine[Run+1])) then begin FTokenID := tkComment; repeat diff --git a/components/synedit/Source/SynHighlighterST.pas b/components/synedit/Source/SynHighlighterST.pas index 1f034952b..8bda85fec 100644 --- a/components/synedit/Source/SynHighlighterST.pas +++ b/components/synedit/Source/SynHighlighterST.pas @@ -39,7 +39,7 @@ unit SynHighlighterST; -{$I SynEdit.Inc} +{$I SynEdit.inc} interface diff --git a/components/synedit/Source/SynHighlighterSml.pas b/components/synedit/Source/SynHighlighterSml.pas index 33746e9b3..8bd6082c8 100644 --- a/components/synedit/Source/SynHighlighterSml.pas +++ b/components/synedit/Source/SynHighlighterSml.pas @@ -47,7 +47,7 @@ unit SynHighlighterSml; -{$I SynEdit.Inc} +{$I SynEdit.inc} interface diff --git a/components/synedit/Source/SynHighlighterTclTk.pas b/components/synedit/Source/SynHighlighterTclTk.pas index 43bb074a3..c577ca7c4 100644 --- a/components/synedit/Source/SynHighlighterTclTk.pas +++ b/components/synedit/Source/SynHighlighterTclTk.pas @@ -45,7 +45,7 @@ unit SynHighlighterTclTk; -{$I SynEdit.Inc} +{$I SynEdit.inc} interface diff --git a/components/synedit/Source/SynHighlighterTeX.pas b/components/synedit/Source/SynHighlighterTeX.pas index eeeb0a17f..fddc2309b 100644 --- a/components/synedit/Source/SynHighlighterTeX.pas +++ b/components/synedit/Source/SynHighlighterTeX.pas @@ -37,7 +37,7 @@ unit SynHighlighterTeX; -{$I SynEdit.Inc} +{$I SynEdit.inc} interface diff --git a/components/synedit/Source/SynHighlighterUNIXShellScript.pas b/components/synedit/Source/SynHighlighterUNIXShellScript.pas index 05f4ba0d0..557adee16 100644 --- a/components/synedit/Source/SynHighlighterUNIXShellScript.pas +++ b/components/synedit/Source/SynHighlighterUNIXShellScript.pas @@ -45,7 +45,7 @@ unit SynHighlighterUNIXShellScript; -{$I SynEdit.Inc} +{$I SynEdit.inc} interface diff --git a/components/synedit/Source/SynHighlighterURI.pas b/components/synedit/Source/SynHighlighterURI.pas index 7f5506b86..afd076ad1 100644 --- a/components/synedit/Source/SynHighlighterURI.pas +++ b/components/synedit/Source/SynHighlighterURI.pas @@ -68,7 +68,7 @@ unit SynHighlighterURI; -{$I SynEdit.Inc} +{$I SynEdit.inc} interface diff --git a/components/synedit/Source/SynHighlighterUnreal.pas b/components/synedit/Source/SynHighlighterUnreal.pas index ba851c27c..2d2227950 100644 --- a/components/synedit/Source/SynHighlighterUnreal.pas +++ b/components/synedit/Source/SynHighlighterUnreal.pas @@ -43,7 +43,7 @@ unit SynHighlighterUnreal; -{$I SynEdit.Inc} +{$I SynEdit.inc} interface diff --git a/components/synedit/Source/SynHighlighterVB.pas b/components/synedit/Source/SynHighlighterVB.pas index 45254c02c..45e263148 100644 --- a/components/synedit/Source/SynHighlighterVB.pas +++ b/components/synedit/Source/SynHighlighterVB.pas @@ -45,7 +45,7 @@ unit SynHighlighterVB; -{$I SynEdit.Inc} +{$I SynEdit.inc} interface diff --git a/components/synedit/Source/SynHighlighterVBScript.pas b/components/synedit/Source/SynHighlighterVBScript.pas index e653269a3..f1c79677a 100644 --- a/components/synedit/Source/SynHighlighterVBScript.pas +++ b/components/synedit/Source/SynHighlighterVBScript.pas @@ -46,7 +46,7 @@ unit SynHighlighterVBScript; -{$I SynEdit.Inc} +{$I SynEdit.inc} interface diff --git a/components/synedit/Source/SynHighlighterVrml97.pas b/components/synedit/Source/SynHighlighterVrml97.pas index 767824029..ad815a118 100644 --- a/components/synedit/Source/SynHighlighterVrml97.pas +++ b/components/synedit/Source/SynHighlighterVrml97.pas @@ -68,7 +68,7 @@ unit SynHighlighterVrml97; -{$I SynEdit.Inc} +{$I SynEdit.inc} interface diff --git a/components/synedit/Source/SynHighlighterXML.pas b/components/synedit/Source/SynHighlighterXML.pas index 55820ac63..818cff490 100644 --- a/components/synedit/Source/SynHighlighterXML.pas +++ b/components/synedit/Source/SynHighlighterXML.pas @@ -53,7 +53,7 @@ interface -{$I SynEdit.Inc} +{$I SynEdit.inc} uses Windows, Messages, Controls, Graphics, Registry, @@ -830,7 +830,6 @@ procedure TSynXMLSyn.ScanForFoldRanges(FoldRanges: TSynFoldRanges; LinesToScan: TStrings; FromLine, ToLine: Integer); var Line: Integer; - TagStartPos: Integer; CurLine: string; RunPos: Integer; IsClosing: Boolean; diff --git a/components/synedit/Source/SynMemo.pas b/components/synedit/Source/SynMemo.pas index d5263c9e3..47cf022b5 100644 --- a/components/synedit/Source/SynMemo.pas +++ b/components/synedit/Source/SynMemo.pas @@ -40,7 +40,7 @@ unit SynMemo; -{$I SynEdit.Inc} +{$I SynEdit.inc} interface diff --git a/components/synedit/Source/SynRegExpr.pas b/components/synedit/Source/SynRegExpr.pas index b17c23570..6f0b43641 100644 --- a/components/synedit/Source/SynRegExpr.pas +++ b/components/synedit/Source/SynRegExpr.pas @@ -44,48 +44,66 @@ The same modified LGPL with static linking exception as the Free Pascal RTL } +{ +program 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 connects 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.) +} + interface { off $DEFINE DebugSynRegExpr } // ======== Determine compiler -{$INCLUDE SynEdit.inc} +{$I SynEdit.inc} // ======== Define base compiler options {$BOOLEVAL OFF} {$EXTENDEDSYNTAX ON} {$LONGSTRINGS ON} -{$OPTIMIZATION ON} -{$IFDEF SYN_COMPILER_6_UP} - {$WARN SYMBOL_PLATFORM OFF} // Suppress .Net warnings -{$ENDIF} -{$IFDEF SYN_COMPILER_7_UP} - {$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 {$INLINE ON} {$ENDIF} // ======== Define options for TRegExpr engine -{$DEFINE UniCode} // Use WideChar for characters and UnicodeString/WideString for strings -{ off $DEFINE UseWordChars} // Use WordChars property, otherwise fixed list 'a'..'z','A'..'Z','0'..'9','_' +{$DEFINE UnicodeRE} // Use WideChar for characters and UnicodeString/WideString for strings +{ off $DEFINE UnicodeEx} // Support Unicode >0xFFFF, e.g. emoji, e.g. "." must find 2 WideChars of 1 emoji +{ off $DEFINE UseWordChars} // Use WordChars property, otherwise fixed list 'a'..'z','A'..'Z','0'..'9','_' { off $DEFINE UseSpaceChars} // Use SpaceChars property, otherwise fixed list -{ off $DEFINE UnicodeWordDetection} // Additionally to ASCII word chars, detect word chars >=128 by Unicode table +{ off $DEFINE UseLineSep} // Use LineSeparators property, otherwise fixed line-break chars +{$IFDEF UNICODE} + {$IFNDEF UnicodeRE} + {$MESSAGE ERROR 'You cannot undefine UnicodeRE for Unicode Delphi versions'} + {$ENDIF} +{$ENDIF} +{$IFDEF FPC} + {$DEFINE FastUnicodeData} // Use arrays for UpperCase/LowerCase/IsWordChar, they take 320K more memory +{$ENDIF} +{ off $DEFINE RegExpWithStackOverflowCheck} // Check the recursion depth and abort matching before stack overflows (available only for some OS/CPU) {$DEFINE UseFirstCharSet} // Enable optimization, which finds possible first chars of input string {$DEFINE RegExpPCodeDump} // Enable method Dump() to show opcode as string {$IFNDEF FPC} // 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} - {$UNDEF UnicodeWordDetection} +{$IFNDEF UnicodeRE} + {$UNDEF UnicodeEx} + {$UNDEF FastUnicodeData} {$ENDIF} +{.$DEFINE Compat} // Enable compatability methods/properties for forked version in Free Pascal 3.0 // ======== 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 SYN_COMPILER_3_UP} {$DEFINE UseAsserts} {$ENDIF} -{$IFDEF FPC} {$DEFINE UseAsserts} {$ENDIF} +{$IFDEF SYN_COMPILER_3_UP} { $DEFINE WITH_REGEX_ASSERT} {$ENDIF} +{$IFDEF FPC}{$IFOPT C+} {$DEFINE WITH_REGEX_ASSERT} {$ENDIF}{$ENDIF} // Only if compile with -Sa // Define 'use subroutine parameters default values' option (do not edit this definition). {$IFDEF SYN_COMPILER_4_UP} {$DEFINE DefParam} {$ENDIF} {$IFDEF FPC} {$DEFINE DefParam} {$ENDIF} @@ -93,20 +111,40 @@ interface {$IFDEF SYN_COMPILER_5_UP} {$DEFINE OverMeth} {$ENDIF} {$IFDEF FPC} {$DEFINE OverMeth} {$ENDIF} // Define 'InlineFuncs' options, to use inline keyword (do not edit this definitions). -{$IFDEF SYN_COMPILER_8_UP} {$DEFINE InlineFuncs} {$ENDIF} +// Disabled for HeidiSQL due to compiler errors +{$IFDEF SYN_COMPILER_8_UP} {.$DEFINE InlineFuncs} {$ENDIF} {$IFDEF FPC} {$DEFINE InlineFuncs} {$ENDIF} +{$IFDEF RegExpWithStackOverflowCheck} // Define the stack checking algorithm for the current platform/CPU + {$IF defined(Linux) or defined(Windows)}{$IF defined(CPU386) or defined(CPUX86_64)} + {$DEFINE RegExpWithStackOverflowCheck_DecStack_Frame} // Stack-pointer decrements // use getframe over Sptr() + {$ENDIF}{$ENDIF} +{$ENDIF} uses - Classes, // TStrings in Split method SysUtils, // Exception - Math; + {$IFDEF SYN_DELPHI_2009_UP} + {$IFDEF SYN_COMPILER_16_UP} + System.Character, + {$ELSE} + Character, + {$ENDIF} + {$ENDIF} + Classes; // TStrings in Split method type {$IFNDEF FPC} - PtrInt = integer; - PtrUInt = cardinal; + // Delphi doesn't have PtrInt but has NativeInt + // but unfortunately NativeInt is declared wrongly in several versions + {$IF SizeOf(Pointer)=4} + PtrInt = Integer; + PtrUInt = Cardinal; + {$ELSE} + PtrInt = Int64; + PtrUInt = UInt64; + {$IFEND} {$ENDIF} - {$IFDEF UniCode} + + {$IFDEF UnicodeRE} PRegExprChar = PWideChar; {$IFDEF FPC} RegExprString = UnicodeString; @@ -119,27 +157,29 @@ interface {$ENDIF} REChar = WideChar; {$ELSE} - PRegExprChar = PChar; - RegExprString = AnsiString; // ###0.952 was string - REChar = Char; + PRegExprChar = PAnsiChar; + RegExprString = AnsiString; + REChar = AnsiChar; {$ENDIF} - TREOp = REChar; // internal p-code type //###0.933 + TREOp = REChar; // internal opcode type PREOp = ^TREOp; type - TRegExprInvertCaseFunction = function(const Ch: REChar): REChar of object; - TRegExprCharset = set of byte; + TRegExprCharset = set of Byte; const // Escape char ('\' in common r.e.) used for escaping metachars (\w, \d etc) EscChar = '\'; - 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 + // Substitute method: prefix of group reference: $1 .. $9 and $ + SubstituteGroupChar = '$'; + + 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 {$IFDEF UseSpaceChars} // default value for SpaceChars @@ -153,153 +193,213 @@ interface + 'ABCDEFGHIJKLMNOPQRSTUVWXYZ_'; {$ENDIF} + {$IFDEF UseLineSep} // default value for LineSeparators RegExprLineSeparators: RegExprString = #$d#$a#$b#$c - {$IFDEF UniCode} + {$IFDEF UnicodeRE} + #$2028#$2029#$85 {$ENDIF}; - - // default value for LinePairedSeparator - RegExprLinePairedSeparator: RegExprString = #$d#$a; - { if You need Unix-styled line separators (only \n), then use: - RegExprLineSeparators = #$a; - RegExprLinePairedSeparator = ''; - } + {$ENDIF} // Tab and Unicode category "Space Separator": // https://www.compart.com/en/unicode/category/Zs RegExprHorzSeparators: RegExprString = #9#$20#$A0 - {$IFDEF UniCode} + {$IFDEF UnicodeRE} + #$1680#$2000#$2001#$2002#$2003#$2004#$2005#$2006#$2007#$2008#$2009#$200A#$202F#$205F#$3000 {$ENDIF}; -const - NSUBEXP = 90; // 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 error). - // 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. + RegExprUsePairedBreak: Boolean = True; + RegExprReplaceLineBreak: RegExprString = sLineBreak; -{$IFDEF ComplexBraces} const - LoopStackMax = 10; // max depth of loops stack //###0.925 + // Increment/keep-capacity for the size of arrays holding 'Group' related data + // e.g., GrpBounds, GrpIndexes, GrpOpCodes and GrpNames + RegexGroupCountIncrement = 50; -type - TRegExprLoopStack = array [1 .. LoopStackMax] of integer; -{$ENDIF} + // Max possible amount of groups. + // Don't change it! It's defined by internal TRegExpr design. + RegexMaxMaxGroups = MaxInt div 16; + + // Max depth of recursion for (?R) and (?1)..(?9) + RegexMaxRecursion = 20; type TRegExprModifiers = record - I: boolean; + I: Boolean; // Case-insensitive. - R: boolean; + R: Boolean; // Extended syntax for Russian ranges in []. // If True, then а-я additionally includes letter 'ё', // А-Я additionally includes 'Ё', and а-Я includes all Russian letters. // Turn it off if it interferes with your national alphabet. - S: boolean; + S: Boolean; // Dot '.' matches any char, otherwise only [^\n]. - G: boolean; + G: Boolean; // Greedy. Switching it off switches all operators to non-greedy style, // so if G=False, then '*' works like '*?', '+' works like '+?' and so on. - M: boolean; + M: Boolean; // Treat string as multiple lines. It changes `^' and `$' from // matching at only the very start/end of the string to the start/end // of any line anywhere within the string. - X: boolean; + X: Boolean; // Allow comments in regex using # char. end; -function IsModifiersEqual(const A, B: TRegExprModifiers): boolean; +function IsModifiersEqual(const A, B: TRegExprModifiers): Boolean; type TRegExpr = class; TRegExprReplaceFunction = function(ARegExpr: TRegExpr): RegExprString of object; - TRegExprCharChecker = function(ch: REChar): boolean of object; + TRegExprCharChecker = function(ch: REChar): Boolean of object; TRegExprCharCheckerArray = array[0 .. 30] of TRegExprCharChecker; TRegExprCharCheckerInfo = record CharBegin, CharEnd: REChar; - CheckerIndex: integer; + CheckerIndex: Integer; end; TRegExprCharCheckerInfos = array of TRegExprCharCheckerInfo; + TRegExprAnchor = ( + raNone, // Not anchored + raBOL, // Must start at BOL + raEOL, // Must start at EOL (maybe look behind) + raContinue, // Must start at continue pos \G + raOnlyOnce // Starts with .* must match from the start pos only. Must not be tried from a later pos + ); + + TRegExprFindFixedLengthFlag = ( + flfForceToStopAt, + flfReturnAtNextNil, + flfSkipLookAround + ); + TRegExprFindFixedLengthFlags = set of TRegExprFindFixedLengthFlag; + + {$IFDEF Compat} + TRegExprInvertCaseFunction = function(const Ch: REChar): REChar of object; + {$ENDIF} + + {$IFDEF ComplexBraces} + POpLoopInfo = ^TOpLoopInfo; + TOpLoopInfo = record + Count: Integer; + CurrentRegInput: PRegExprChar; + BackTrackingAsAtom: Boolean; + OuterLoop: POpLoopInfo; // for nested loops + end; + {$ENDIF} + + + TRegExprBounds = record + GrpStart: array of PRegExprChar; // pointer to group start in InputString + GrpEnd: array of PRegExprChar; // pointer to group end in InputString + end; + TRegExprBoundsArray = array[0 .. RegexMaxRecursion] of TRegExprBounds; + + PRegExprLookAroundInfo = ^TRegExprLookAroundInfo; + TRegExprLookAroundInfo = record + InputPos: PRegExprChar; // pointer to start of look-around in the input string + savedInputCurrentEnd: PRegExprChar; // pointer to start of look-around in the input string + IsNegative, HasMatchedToEnd: Boolean; + IsBackTracking: Boolean; + OuterInfo: PRegExprLookAroundInfo; // for nested lookaround + end; + + TRegExprGroupName = record + Name: RegExprString; + Index: Integer; + end; + + { TRegExprGroupNameList } + + TRegExprGroupNameList = object + Names: array of TRegExprGroupName; + NameCount: Integer; + // get index of group (subexpression) by name, to support named groups + // like in Python: (?Pregex) + function MatchIndexFromName(const AName: RegExprString): Integer; + procedure Clear; + procedure Add(const AName: RegExprString; AnIndex: Integer); + end; + { TRegExpr } TRegExpr = class private - startp: array [0 .. NSUBEXP - 1] of PRegExprChar; // found expr start points - endp: array [0 .. NSUBEXP - 1] of PRegExprChar; // found expr end points - - GrpIndexes: array [0 .. NSUBEXP - 1] of integer; - GrpCount: integer; + FAllowBraceWithoutMin: Boolean; + FAllowUnsafeLookBehind: Boolean; + FAllowLiteralBraceWithoutRange: Boolean; + FMatchesCleared: Boolean; + fRaiseForRuntimeError: Boolean; + GrpBounds: TRegExprBoundsArray; + GrpIndexes: array of Integer; // map global group index to _capturing_ group index + GrpNames: TRegExprGroupNameList; // names of groups, if non-empty + GrpBacktrackingAsAtom: array of Boolean; // close of group[i] has set IsBacktrackingGroupAsAtom + IsBacktrackingGroupAsAtom: Boolean; // Backtracking an entire atomic group that had matched. + // Once the group matched it should not try any alternative matches within the group + // If the pattern after the group fails, then the group fails (regardless of any alternative match in the group) + + GrpOpCodes: array of PRegExprChar; // pointer to opcode of group[i] (used by OP_SUBCALL*) + GrpCount, ParsedGrpCount: Integer; {$IFDEF ComplexBraces} - LoopStack: TRegExprLoopStack; // state before entering loop - LoopStackIdx: integer; // 0 - out of all loops + CurrentLoopInfoListPtr: POpLoopInfo; {$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. - reganchored: REChar; // is the match anchored (at beginning-of-line only)? - regmust: PRegExprChar; // string (pointer into program) that match must include, or nil - regmustlen: integer; // length of regmust string - regmustString: RegExprString; - // reganchored permits 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 + + regAnchored: TRegExprAnchor; // is the match anchored (at beginning-of-line only)? + // regAnchored permits 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). regmustlen is + // at the start of the r.e., which can involve a lot of backup). regMustLen is // supplied because the test in regexec() needs it and regcomp() is computing // it anyway. + regMust: PRegExprChar; // string (pointer into program) that match must include, or nil + regMustLen: Integer; // length of regMust string + regMustString: RegExprString; // string which must occur in match (got from regMust/regMustLen) + LookAroundInfoList: PRegExprLookAroundInfo; + //regNestedCalls: integer; // some attempt to prevent 'catastrophic backtracking' but not used + CurrentSubCalled: Integer; + + FMinMatchLen: integer; {$IFDEF UseFirstCharSet} FirstCharSet: TRegExprCharset; - FirstCharArray: array[byte] of boolean; + FirstCharArray: array[Byte] of Boolean; {$ENDIF} // work variables for Exec routines - 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 - fRegexStart: PRegExprChar; - fRegexEnd: PRegExprChar; + regInput: PRegExprChar; // pointer to currently handling char of input string + fInputStart: PRegExprChar; // pointer to first char of input string + fInputContinue: PRegExprChar; // pointer to char specified with Exec(AOffset), or start pos of ExecNext + fInputEnd: PRegExprChar; // pointer after last char of input string + fInputCurrentEnd: PRegExprChar; // pointer after last char of the current visible part of input string (can be limited by look-behind) + fRegexStart: PRegExprChar; // pointer to first char of regex + fRegexEnd: PRegExprChar; // pointer after last char of regex + regRecursion: Integer; // current level of recursion (?R) (?1); always 0 if no recursion is used // work variables for compiler's routines - regparse: PRegExprChar; // Input-scan pointer. - regnpar: integer; // Count of () brackets. - regdummy: REChar; - regcode: PRegExprChar; // Code-emit pointer; @regdummy = don't. - regsize: integer; // Total programm size in REChars. - regExactlyLen: PLongInt; - regexpBegin: PRegExprChar; // only for error handling. Contains pointer to beginning of r.e. while compiling - regexpIsCompiled: boolean; // true if r.e. successfully compiled - fSecondPass: boolean; - - // 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 connects 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: RegExprString; // source of compiled r.e. + regParse: PRegExprChar; // pointer to currently handling char of regex + regNumBrackets: Integer; // count of () brackets + regDummy: array [0..8 div SizeOf(REChar)] of REChar; // dummy pointer, used to detect 1st/2nd pass of Compile + // if p=@regDummy, it is pass-1: opcode memory is not yet allocated + programm: PRegExprChar; // pointer to opcode, =nil in pass-1 + regCode: PRegExprChar; // pointer to last emitted opcode; changing in pass-2, but =@regDummy in pass-1 + regCodeSize: Integer; // total opcode size in REChars + regCodeWork: PRegExprChar; // pointer to opcode, to first code after MAGIC + regExactlyLen: PLongInt; // pointer to length of substring of OP_EXACTLY* inside opcode + fSecondPass: Boolean; // true inside pass-2 of Compile + + fExpression: RegExprString; // regex string fInputString: RegExprString; // input string - fLastError: integer; // see Error, LastError + fLastError: Integer; // Error call sets code of LastError fLastErrorOpcode: TREOp; + fLastErrorSymbol: REChar; - fModifiers: TRegExprModifiers; // modifiers + fModifiers: TRegExprModifiers; // regex modifiers fCompModifiers: TRegExprModifiers; // compiler's copy of modifiers fProgModifiers: TRegExprModifiers; // modifiers values from last programm compilation @@ -309,99 +409,112 @@ TRegExpr = class {$IFDEF UseWordChars} fWordChars: RegExprString; {$ENDIF} - fInvertCase: TRegExprInvertCaseFunction; + {$IFDEF UseLineSep} fLineSeparators: RegExprString; - fLinePairedSeparatorAssigned: boolean; - fLinePairedSeparatorHead, fLinePairedSeparatorTail: REChar; + {$ENDIF} - FReplaceLineEnd: RegExprString; // string to use for "\n" in Substitute method - FUseOsLineEndOnReplace: boolean; // use OS LineBreak chars (LF or CRLF) for FReplaceLineEnd + fUsePairedBreak: Boolean; + fReplaceLineEnd: RegExprString; // string to use for "\n" in Substitute method - fSlowChecksSizeMax: integer; - // use ASlowChecks=True in Exec() only when Length(InputString)regex) + function MatchIndexFromName(const AName: RegExprString): Integer; + + function MatchFromName(const AName: RegExprString): RegExprString; // Returns position in r.e. where compiler stopped. // Useful for error diagnostics @@ -642,51 +811,48 @@ TRegExpr = class // Contains chars, treated as /s (initially filled with RegExprSpaceChars // global constant) property SpaceChars: RegExprString read fSpaceChars write fSpaceChars; - // ###0.927 {$ENDIF} {$IFDEF UseWordChars} // Contains chars, treated as /w (initially filled with RegExprWordChars // global constant) property WordChars: RegExprString read fWordChars write fWordChars; - // ###0.929 {$ENDIF} - {$IFDEF UnicodeWordDetection} - // If set to true, in addition to using WordChars, a heuristic to detect unicode word letters is used for \w - property UseUnicodeWordDetection: boolean read FUseUnicodeWordDetection write FUseUnicodeWordDetection; - {$ENDIF} + {$IFDEF UseLineSep} // line separators (like \n in Unix) - property LineSeparators: RegExprString read fLineSeparators write SetLineSeparators; // ###0.941 + property LineSeparators: RegExprString read fLineSeparators write SetLineSeparators; + {$ENDIF} + + // support paired line-break CR LF + property UseLinePairedBreak: Boolean read fUsePairedBreak write SetUsePairedBreak; + + property ReplaceLineEnd: RegExprString read fReplaceLineEnd write fReplaceLineEnd; - // paired line separator (like \r\n in DOS and Windows). - // must contain exactly two chars or no chars at all - property LinePairedSeparator: RegExprString read GetLinePairedSeparator write SetLinePairedSeparator; // ###0.941 + property SlowChecksSizeMax: Integer read fSlowChecksSizeMax write fSlowChecksSizeMax; - // Set this property if you want to override case-insensitive functionality. - // Create set it to RegExprInvertCaseFunction (InvertCaseFunction by default) - property InvertCase: TRegExprInvertCaseFunction read fInvertCase write fInvertCase; // ##0.935 + // Errors during Exec() return false and set LastError. This option allows + // them to raise an Exception + property RaiseForRuntimeError: Boolean read fRaiseForRuntimeError write fRaiseForRuntimeError; - // Use OS line end on replace or not. Default is True for backwards compatibility. - // Set to false to use #10. - property UseOsLineEndOnReplace: boolean read FUseOsLineEndOnReplace write SetUseOsLineEndOnReplace; + property AllowUnsafeLookBehind: Boolean read FAllowUnsafeLookBehind write FAllowUnsafeLookBehind; - property SlowChecksSizeMax: integer read fSlowChecksSizeMax write fSlowChecksSizeMax; + // Make sure a { always is a range / don't allow unescaped literal usage + property AllowLiteralBraceWithoutRange: Boolean read FAllowLiteralBraceWithoutRange write FAllowLiteralBraceWithoutRange; + // support {,123} defaulting the min-matches to 0 + property AllowBraceWithoutMin: Boolean read FAllowBraceWithoutMin write FAllowBraceWithoutMin; end; type ERegExpr = class(Exception) public - ErrorCode: integer; + ErrorCode: Integer; CompilerErrorPos: PtrInt; end; -const - RegExprInvertCaseFunction: TRegExprInvertCaseFunction = nil; - // true if string AInputString match regular expression ARegExpr // ! will raise exeption if syntax errors in ARegExpr -function ExecRegExpr(const ARegExpr, AInputStr: RegExprString): boolean; +function ExecRegExpr(const ARegExpr, AInputStr: RegExprString): Boolean; // Split AInputStr into APieces by r.e. ARegExpr occurencies procedure SplitRegExpr(const ARegExpr, AInputStr: RegExprString; @@ -703,8 +869,8 @@ procedure SplitRegExpr(const ARegExpr, AInputStr: RegExprString; // 'BLOCK( test1)', 'def "$1" value "$2"') // will return: def "$1" value "$2" function ReplaceRegExpr(const ARegExpr, AInputStr, AReplaceStr: RegExprString; - AUseSubstitution: boolean{$IFDEF DefParam} = False{$ENDIF}): RegExprString; -{$IFDEF OverMeth}overload; // ###0.947 + AUseSubstitution: Boolean{$IFDEF DefParam} = False{$ENDIF}): RegExprString; +{$IFDEF OverMeth}overload; // Alternate form allowing to set more parameters. @@ -744,42 +910,32 @@ function QuoteRegExprMetaChars(const AStr: RegExprString): RegExprString; // 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 +// -(n+1) At position n was found opening '[' without // 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 -function RegExprSubExpressions(const ARegExpr: string; ASubExprs: TStrings; - AExtendedSyntax: boolean{$IFDEF DefParam} = False{$ENDIF}): integer; +function RegExprSubExpressions(const ARegExpr: RegExprString; ASubExprs: TStrings; + AExtendedSyntax: Boolean{$IFDEF DefParam} = False{$ENDIF}): Integer; implementation -{$IFDEF FPC} -{$IFDEF UnicodeWordDetection} -uses - UnicodeData; -{$ENDIF} -{$ELSE} -{$IFDEF SYN_DELPHI_2009_UP} +{$IFDEF FastUnicodeData} uses - // unit exists since Delphi 2009 - {$IFDEF SYN_DELPHI_XE2_UP} - System.Character; - {$ELSE} - Character; - {$ENDIF} -{$ENDIF} + regexpr_unicodedata; {$ENDIF} const // TRegExpr.VersionMajor/Minor return values of these constants: - REVersionMajor = 0; - REVersionMinor = 989; + REVersionMajor = 1; + REVersionMinor = 181; OpKind_End = REChar(1); OpKind_MetaClass = REChar(2); OpKind_Range = REChar(3); OpKind_Char = REChar(4); + OpKind_CategoryYes = REChar(5); + OpKind_CategoryNo = REChar(6); RegExprAllSet = [0 .. 255]; RegExprWordSet = [Ord('a') .. Ord('z'), Ord('A') .. Ord('Z'), Ord('0') .. Ord('9'), Ord('_')]; @@ -788,19 +944,51 @@ implementation RegExprUpperAzSet = [Ord('A') .. Ord('Z')]; RegExprAllAzSet = RegExprLowerAzSet + RegExprUpperAzSet; RegExprSpaceSet = [Ord(' '), $9, $A, $D, $C]; - RegExprLineSeparatorsSet = [$d, $a, $b, $c] {$IFDEF UniCode} + [$85] {$ENDIF}; + RegExprLineSeparatorsSet = [$d, $a, $b, $c] {$IFDEF UnicodeRE} + [$85] {$ENDIF}; RegExprHorzSeparatorsSet = [9, $20, $A0]; - MaxBracesArg = $7FFFFFFF - 1; // max value for {n,m} arguments //###0.933 + MaxBracesArg = $7FFFFFFF - 1; // max value for {n,m} arguments type TRENextOff = PtrInt; - // internal Next "pointer" (offset to current p-code) //###0.933 + // internal Next "pointer" (offset to current p-code) PRENextOff = ^TRENextOff; - // used for extracting Next "pointers" from compiled r.e. //###0.933 - TREBracesArg = integer; // type of {m,n} arguments + // used for extracting Next "pointers" from compiled r.e. + TREBracesArg = Integer; // type of {m,n} arguments PREBracesArg = ^TREBracesArg; + TREGroupKind = ( + gkNormalGroup, + gkNonCapturingGroup, + gkAtomicGroup, + gkNamedGroupReference, + gkComment, + gkModifierString, + gkLookahead, + gkLookaheadNeg, + gkLookbehind, + gkLookbehindNeg, + gkRecursion, + gkSubCall + ); + + TReOpLookBehindOptions = packed record + MatchLenMin, MatchLenMax: TREBracesArg; + IsGreedy: REChar; + end; + PReOpLookBehindOptions = ^TReOpLookBehindOptions; + +const + ReOpLookBehindOptionsSz = SizeOf(TReOpLookBehindOptions) div SizeOf(REChar); + OPT_LOOKBEHIND_NON_GREEDY = REChar(0); + OPT_LOOKBEHIND_GREEDY = REChar(1); + OPT_LOOKBEHIND_FIXED = REChar(2); + +// Alexey T.: handling of that define FPC_REQUIRES_PROPER_ALIGNMENT was present even 15 years ago, +// but with it, we have failing of some RegEx tests, on ARM64 CPU. +// If I undefine FPC_REQUIRES_PROPER_ALIGNMENT, all tests run OK on ARM64 again. +{$undef FPC_REQUIRES_PROPER_ALIGNMENT} + const REOpSz = SizeOf(TREOp) div SizeOf(REChar); // size of OP_ command in REChars @@ -818,6 +1006,53 @@ implementation {$ENDIF} RENumberSz = SizeOf(LongInt) div SizeOf(REChar); + REBranchArgSz = 2; // 2 * (REChar div REChar) + +type + TReGroupIndex = LongInt; + PReGroupIndex = ^TReGroupIndex; +const + ReGroupIndexSz = SizeOf(TReGroupIndex) div SizeOf(REChar); + +type + PtrPair = {$IFDEF UnicodeRE} ^LongInt; {$ELSE} ^Word; {$ENDIF} + +function GroupDataArraySize(ARequired, ACurrent: Integer): Integer; +begin + Result := ARequired; + if Result > ACurrent then + Exit; + + // Keep some extra + if Result > ACurrent - RegexGroupCountIncrement then + Result := ACurrent; +end; + +function IsPairedBreak(p: PRegExprChar): Boolean; {$IFDEF InlineFuncs}inline;{$ENDIF} +const + cBreak = {$IFDEF UnicodeRE} $000D000A; {$ELSE} $0D0A; {$ENDIF} +begin + Result := PtrPair(p)^ = cBreak; +end; + +function IsAnyLineBreak(C: REChar): Boolean; {$IFDEF InlineFuncs}inline;{$ENDIF} +begin + case C of + #10, + #13, + #$0B, + #$0C + {$ifdef UnicodeRE} + , #$85 + , #$2028 + , #$2029 + {$endif}: + Result := True; + else + Result := False; + end; +end; + function _FindCharInBuffer(SBegin, SEnd: PRegExprChar; Ch: REChar): PRegExprChar; {$IFDEF InlineFuncs}inline;{$ENDIF} begin while SBegin < SEnd do @@ -832,27 +1067,28 @@ function _FindCharInBuffer(SBegin, SEnd: PRegExprChar; Ch: REChar): PRegExprChar Result := nil; end; -function IsIgnoredChar(AChar: REChar): boolean; {$IFDEF InlineFuncs}inline;{$ENDIF} +function IsIgnoredChar(AChar: REChar): Boolean; {$IFDEF InlineFuncs}inline;{$ENDIF} begin case AChar of ' ', #9, #$d, #$a: Result := True - else - Result := False; + else + Result := False; end; end; -function _IsMetaChar(AChar: REChar): boolean; {$IFDEF InlineFuncs}inline;{$ENDIF} +function _IsMetaChar(AChar: REChar): Boolean; {$IFDEF InlineFuncs}inline;{$ENDIF} begin case AChar of 'd', 'D', 's', 'S', 'w', 'W', 'v', 'V', - 'h', 'H': + 'h', 'H', + 'R': Result := True - else - Result := False; + else + Result := False; end; end; @@ -868,12 +1104,83 @@ function AlignToPtr(const p: Pointer): Pointer; {$IFDEF InlineFuncs}inline;{$END function AlignToInt(const p: Pointer): Pointer; {$IFDEF InlineFuncs}inline;{$ENDIF} begin {$IFDEF FPC_REQUIRES_PROPER_ALIGNMENT} - Result := Align(p, SizeOf(integer)); + Result := Align(p, SizeOf(Integer)); {$ELSE} Result := p; {$ENDIF} end; +function StrLScan(P: PRegExprChar; C: REChar; len: PtrInt): PRegExprChar; +Var + count: PtrInt; +Begin + count := 0; + { Find first matching character of Ch in Str } + while (count < len) do + begin + if C = P[count] then + begin + StrLScan := @(P[count]); + exit; + end; + Inc(count); + end; + { nothing found. } + StrLScan := nil; +end; + +function StrLComp(str1,str2 : PRegExprChar; len : PtrInt) : PtrInt; +var + counter: PtrInt; + c1, c2: REChar; +begin + if len = 0 then + begin + StrLComp := 0; + exit; + end; + counter:=0; + repeat + c1:=str1[counter]; + c2:=str2[counter]; + inc(counter); + until (c1<>c2) or (counter>=len) or (c1=#0) or (c2=#0); + StrLComp:=ord(c1)-ord(c2); +end; + +function StrLPos(str1,str2 : PRegExprChar; len1, len2: PtrInt) : PRegExprChar; +var + p : PRegExprChar; +begin + StrLPos := nil; + if (str1 = nil) or (str2 = nil) then + exit; + len1 := len1 - len2 + 1; + p := StrLScan(str1,str2^, len1); + while p <> nil do + begin + if StrLComp(p, str2, len2)=0 then + begin + StrLPos := p; + exit; + end; + inc(p); + p := StrLScan(p, str2^, len1 - (p-str1)); + end; +end; + +{$IFDEF FastUnicodeData} +function _UpperCase(Ch: REChar): REChar; {$IFDEF InlineFuncs}inline;{$ENDIF} +begin + Result := CharUpperArray[Ord(Ch)]; +end; + +function _LowerCase(Ch: REChar): REChar; {$IFDEF InlineFuncs}inline;{$ENDIF} +begin + Result := CharLowerArray[Ord(Ch)]; +end; + +{$ELSE} function _UpperCase(Ch: REChar): REChar; begin Result := Ch; @@ -886,15 +1193,19 @@ function _UpperCase(Ch: REChar): REChar; Exit; {$IFDEF FPC} - {$IFDEF UniCode} + {$IFDEF UnicodeRE} Result := UnicodeUpperCase(Ch)[1]; {$ELSE} Result := AnsiUpperCase(Ch)[1]; {$ENDIF} {$ELSE} - {$IFDEF UniCode} - {$IFDEF SYN_DELPHI_2009_UP} + {$IFDEF UnicodeRE} + {$IFDEF SYN_COMPILER_18_UP} + Result := Ch.ToUpper; + {$ELSE} + {$IFDEF SYN_DELPHI_2009_UP} Result := TCharacter.ToUpper(Ch); + {$ENDIF} {$ENDIF} {$ELSE} Result := AnsiUpperCase(Ch)[1]; @@ -914,27 +1225,96 @@ function _LowerCase(Ch: REChar): REChar; Exit; {$IFDEF FPC} - {$IFDEF UniCode} + {$IFDEF UnicodeRE} Result := UnicodeLowerCase(Ch)[1]; {$ELSE} Result := AnsiLowerCase(Ch)[1]; {$ENDIF} {$ELSE} - {$IFDEF UniCode} - {$IFDEF SYN_DELPHI_2009_UP} + {$IFDEF UnicodeRE} + {$IFDEF SYN_COMPILER_18_UP} + Result := Ch.ToLower; + {$ELSE} + {$IFDEF SYN_DELPHI_2009_UP} Result := TCharacter.ToLower(Ch); + {$ENDIF} {$ENDIF} {$ELSE} Result := AnsiLowerCase(Ch)[1]; {$ENDIF} {$ENDIF} end; +{$ENDIF} + +function InvertCase(const Ch: REChar): REChar; {$IFDEF InlineFuncs}inline;{$ENDIF} +begin + Result := _UpperCase(Ch); + if Result = Ch then + Result := _LowerCase(Ch); +end; + +function _FindClosingBracket(P, PEnd: PRegExprChar): PRegExprChar; +var + Level: Integer; +begin + Result := nil; + Level := 1; + repeat + if P >= PEnd then Exit; + case P^ of + EscChar: + Inc(P); + '(': + begin + Inc(Level); + end; + ')': + begin + Dec(Level); + if Level = 0 then + begin + Result := P; + Exit; + end; + end; + end; + Inc(P); + until False; +end; + +{$IFDEF UNICODEEX} +procedure IncUnicode(var p: PRegExprChar); {$IFDEF InlineFuncs}inline;{$ENDIF} +// make additional increment if we are on low-surrogate char +// no need to check p= $DC00) and (Ord(ch) <= $DFFF) then + Inc(p); +end; + +procedure IncUnicode2(var p: PRegExprChar; var N: Integer); {$IFDEF InlineFuncs}inline;{$ENDIF} +var + ch: REChar; +begin + Inc(p); + Inc(N); + ch := p^; + if (Ord(ch) >= $DC00) and (Ord(ch) <= $DFFF) then + begin + Inc(p); + Inc(N); + end; +end; +{$ENDIF} { ============================================================= } { ===================== Global functions ====================== } { ============================================================= } -function IsModifiersEqual(const A, B: TRegExprModifiers): boolean; +function IsModifiersEqual(const A, B: TRegExprModifiers): Boolean; begin Result := (A.I = B.I) and @@ -946,19 +1326,27 @@ function IsModifiersEqual(const A, B: TRegExprModifiers): boolean; end; function ParseModifiers(const APtr: PRegExprChar; - ALen: integer; - var AValue: TRegExprModifiers): boolean; + ALen: Integer; + var AValue: TRegExprModifiers): Boolean; // Parse string and set AValue if it's in format 'ismxrg-ismxrg' var - IsOn: boolean; - i: integer; + IsOn: Boolean; + i: Integer; begin Result := True; IsOn := True; for i := 0 to ALen-1 do case APtr[i] of '-': - IsOn := False; + if IsOn then + begin + IsOn := False; + end + else + begin + Result := False; + Exit; + end; 'I', 'i': AValue.I := IsOn; 'R', 'r': @@ -972,14 +1360,12 @@ function ParseModifiers(const APtr: PRegExprChar; 'X', 'x': AValue.X := IsOn; else - begin - Result := False; - Exit; - end; + Result := False; + Exit; end; end; -function ExecRegExpr(const ARegExpr, AInputStr: RegExprString): boolean; +function ExecRegExpr(const ARegExpr, AInputStr: RegExprString): Boolean; var r: TRegExpr; begin @@ -1010,7 +1396,7 @@ procedure SplitRegExpr(const ARegExpr, AInputStr: RegExprString; -------------------------------------------------------------- } function ReplaceRegExpr(const ARegExpr, AInputStr, AReplaceStr: RegExprString; - AUseSubstitution: boolean{$IFDEF DefParam} = False{$ENDIF}): RegExprString; + AUseSubstitution: Boolean{$IFDEF DefParam} = False{$ENDIF}): RegExprString; begin with TRegExpr.Create do try @@ -1037,7 +1423,10 @@ function ReplaceRegExpr(const ARegExpr, AInputStr, AReplaceStr: RegExprString; ModifierX := (rroModifierX in Options); // Set this after the above, if the regex contains modifiers, they will be applied. Expression := ARegExpr; - UseOsLineEndOnReplace := (rroUseOsLineEnd in Options); + if rroUseOsLineEnd in Options then + ReplaceLineEnd := sLineBreak + else + ReplaceLineEnd := #10; Result := Replace(AInputStr, AReplaceStr, rroUseSubstitution in Options); finally Free; @@ -1052,30 +1441,30 @@ function ReplaceRegExpr(const ARegExpr, AInputStr, AReplaceStr: RegExprString; MetaAll = MetaChars_Init + ']}'; // Very similar to MetaChars, but slighly changed. *) -function _IsMetaSymbol1(ch: REChar): boolean; {$IFDEF InlineFuncs}inline;{$ENDIF} +function _IsMetaSymbol1(ch: REChar): Boolean; {$IFDEF InlineFuncs}inline;{$ENDIF} begin case ch of '^', '$', '.', '[', '(', ')', '|', '?', '+', '*', EscChar, '{': Result := True - else - Result := False + else + Result := False end; end; -function _IsMetaSymbol2(ch: REChar): boolean; {$IFDEF InlineFuncs}inline;{$ENDIF} +function _IsMetaSymbol2(ch: REChar): Boolean; {$IFDEF InlineFuncs}inline;{$ENDIF} begin case ch of '^', '$', '.', '[', '(', ')', '|', '?', '+', '*', EscChar, '{', ']', '}': Result := True - else - Result := False + else + Result := False end; end; function QuoteRegExprMetaChars(const AStr: RegExprString): RegExprString; var - i, i0, Len: integer; + i, i0, Len: Integer; ch: REChar; begin Result := ''; @@ -1096,21 +1485,21 @@ function QuoteRegExprMetaChars(const AStr: RegExprString): RegExprString; end; { of function QuoteRegExprMetaChars -------------------------------------------------------------- } -function RegExprSubExpressions(const ARegExpr: string; ASubExprs: TStrings; - AExtendedSyntax: boolean{$IFDEF DefParam} = False{$ENDIF}): integer; +function RegExprSubExpressions(const ARegExpr: RegExprString; ASubExprs: TStrings; + AExtendedSyntax: Boolean{$IFDEF DefParam} = False{$ENDIF}): Integer; type - TStackItemRec = record // ###0.945 - SubExprIdx: integer; + TStackItemRec = record + SubExprIdx: Integer; StartPos: PtrInt; end; - TStackArray = packed array [0 .. NSUBEXPMAX - 1] of TStackItemRec; + TStackArray = packed array [0 .. RegexMaxMaxGroups - 1] of TStackItemRec; var - Len, SubExprLen: integer; - i, i0: integer; + Len, SubExprLen: Integer; + i, i0: Integer; Modif: TRegExprModifiers; - Stack: ^TStackArray; // ###0.945 - StackIdx, StackSz: integer; + Stack: ^TStackArray; + StackIdx, StackSz: Integer; begin Result := 0; // no unbalanced brackets found at this very moment FillChar(Modif, SizeOf(Modif), 0); @@ -1126,7 +1515,7 @@ TStackItemRec = record // ###0.945 for i := 1 to Len do if ARegExpr[i] = '(' then Inc(StackSz); - // SetLength (Stack, StackSz); //###0.945 + // SetLength (Stack, StackSz); GetMem(Stack, SizeOf(TStackItemRec) * StackSz); try @@ -1194,21 +1583,21 @@ TStackItemRec = record // ###0.945 then Inc(i); while (i <= Len) and (ARegExpr[i] <> ']') do - if ARegExpr[i] = EscChar // ###0.942 + if ARegExpr[i] = EscChar then Inc(i, 2) // skip 'escaped' char to prevent stopping at '\]' else Inc(i); - if (i > Len) or (ARegExpr[i] <> ']') // ###0.942 + if (i > Len) or (ARegExpr[i] <> ']') then - Result := -(i0 + 1); // unbalansed '[' //###0.942 + Result := -(i0 + 1); // unbalanced '[' 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 not use [#$d, #$a] due to Unicode compatibility do Inc(i); while (i + 1 <= Len) and @@ -1243,71 +1632,95 @@ TStackItemRec = record // ###0.945 const OP_MAGIC = TREOp(216); // programm signature - // name opcode opnd? meaning - OP_EEND = TREOp(0); // - End of program - OP_BOL = TREOp(1); // - Match "" at beginning of line - OP_EOL = TREOp(2); // - Match "" at end of line - OP_ANY = TREOp(3); // - Match any one character - OP_ANYOF = TREOp(4); // Str Match any character in string Str - OP_ANYBUT = TREOp(5); // Str Match any char. not in string Str - OP_BRANCH = TREOp(6); // Node Match this alternative, or the next - OP_BACK = TREOp(7); // - Jump backward (Next < 0) - OP_EXACTLY = TREOp(8); // Str Match string Str - OP_NOTHING = TREOp(9); // - Match empty string - OP_STAR = TREOp(10); // Node Match this (simple) thing 0 or more times - OP_PLUS = TREOp(11); // Node Match this (simple) thing 1 or more times - OP_ANYDIGIT = TREOp(12); // - Match any digit (equiv [0-9]) - OP_NOTDIGIT = TREOp(13); // - Match not digit (equiv [0-9]) - OP_ANYLETTER = TREOp(14); // - Match any letter from property WordChars - OP_NOTLETTER = TREOp(15); // - Match not letter from property WordChars - OP_ANYSPACE = TREOp(16); // - Match any space char (see property SpaceChars) - OP_NOTSPACE = TREOp(17); // - Match not space char (see property SpaceChars) + OP_EEND = TREOp(0); // End of program + OP_BOL = TREOp(1); // Empty match at beginning of line + OP_EOL = TREOp(2); // Empty match at end of line + OP_ANY = TREOp(3); // Match any one character + OP_ANYOF = TREOp(4); // Match any character in string + OP_ANYBUT = TREOp(5); // Match any character not in string + OP_BRANCH = TREOp(6); // Match this alternative, or the next + OP_BACK = TREOp(7); // Jump backward (Next < 0) + OP_EXACTLY = TREOp(8); // Match string exactly + OP_NOTHING = TREOp(9); // Match empty string + OP_STAR = TREOp(10); // Match this (simple) thing 0 or more times + OP_PLUS = TREOp(11); // Match this (simple) thing 1 or more times + OP_ANYDIGIT = TREOp(12); // Match any digit (equiv [0-9]) + OP_NOTDIGIT = TREOp(13); // Match not digit (equiv [0-9]) + OP_ANYLETTER = TREOp(14); // Match any 'word' char + OP_NOTLETTER = TREOp(15); // Match any 'non-word' char + OP_ANYSPACE = TREOp(16); // Match any 'space' char + OP_NOTSPACE = TREOp(17); // Match 'not space' char OP_BRACES = TREOp(18); // Node,Min,Max Match this (simple) thing from Min to Max times. // Min and Max are TREBracesArg - OP_COMMENT = TREOp(19); // - Comment ;) - OP_EXACTLYCI = TREOp(20); // Str Match string Str case insensitive - OP_ANYOFCI = TREOp(21); - // Str Match any character in string Str, case insensitive - OP_ANYBUTCI = TREOp(22); - // Str Match any char. not in string Str, case insensitive - OP_LOOPENTRY = TREOp(23); // Node Start of loop (Node - LOOP for this loop) - OP_LOOP = TREOp(24); // Node,Min,Max,LoopEntryJmp - back jump for LOOPENTRY. + OP_COMMENT = TREOp(19); // Comment + OP_EXACTLY_CI = TREOp(20); // Match string, case insensitive + OP_ANYOF_CI = TREOp(21); // Match any character in string, case insensitive + OP_ANYBUT_CI = TREOp(22); // Match any char not in string, case insensitive + OP_LOOPENTRY = TREOp(23); // Start of loop (Node - LOOP for this loop) + OP_LOOP = TREOp(24); // Back jump for LOOPENTRY // Min and Max are TREBracesArg // Node - next node in sequence, // LoopEntryJmp - associated LOOPENTRY node addr - OP_BSUBEXP = TREOp(28); - // Idx Match previously matched subexpression #Idx (stored as REChar) //###0.936 - OP_BSUBEXPCI = TREOp(29); // Idx -"- in case-insensitive mode - - // Non-Greedy Style Ops //###0.940 - OP_STARNG = TREOp(30); // Same as OP_START but in non-greedy mode - OP_PLUSNG = TREOp(31); // Same as OP_PLUS but in non-greedy mode - OP_BRACESNG = TREOp(32); // Same as OP_BRACES but in non-greedy mode - OP_LOOPNG = TREOp(33); // Same as OP_LOOP but in non-greedy mode + OP_EOL2 = TReOp(25); // like OP_EOL, but also matches before final line-break + OP_CONTINUE_POS = TReOp(26); // \G, where offset is from last match end or from Exec(AOffset) + OP_ANYLINEBREAK = TReOp(27); // \R + OP_BSUBEXP = TREOp(28); // Match previously matched subexpression #Idx (stored as REChar) + OP_BSUBEXP_CI = TREOp(29); // -"- in case-insensitive mode + + // Non-greedy ops + OP_STAR_NG = TREOp(30); // Same as OP_START but in non-greedy mode + OP_PLUS_NG = TREOp(31); // Same as OP_PLUS but in non-greedy mode + OP_BRACES_NG = TREOp(32); // Same as OP_BRACES but in non-greedy mode + OP_LOOP_NG = TREOp(33); // Same as OP_LOOP but in non-greedy mode // Multiline mode \m - OP_BOLML = TREOp(34); // - Match "" at beginning of line - OP_EOLML = TREOp(35); // - Match "" at end of line - OP_ANYML = TREOp(36); // - Match any one character + OP_BOL_ML = TREOp(34); // Match "" at beginning of line + OP_EOL_ML = TREOp(35); // Match "" at end of line + OP_ANY_ML = TREOp(36); // Match any one character // Word boundary - OP_BOUND = TREOp(37); // Match "" between words //###0.943 - OP_NOTBOUND = TREOp(38); // Match "" not between words //###0.943 + OP_BOUND = TREOp(37); // Match "" between word char and non-word char + OP_NOTBOUND = TREOp(38); // Opposite to OP_BOUND OP_ANYHORZSEP = TREOp(39); // Any horizontal whitespace \h OP_NOTHORZSEP = TREOp(40); // Not horizontal whitespace \H OP_ANYVERTSEP = TREOp(41); // Any vertical whitespace \v OP_NOTVERTSEP = TREOp(42); // Not vertical whitespace \V - // !!! Change OP_OPEN value if you add new opcodes !!! + OP_ANYCATEGORY = TREOp(43); // \p{L} + OP_NOTCATEGORY = TREOp(44); // \P{L} - OP_OPEN = TREOp(43); // - Mark this point in input as start of \n - // OP_OPEN + 1 is \1, etc. - OP_CLOSE = TREOp(Ord(OP_OPEN) + NSUBEXP); - // - Analogous to OP_OPEN. + // Possessive quantifiers + OP_STAR_POSS = TReOp(45); + OP_PLUS_POSS = TReOp(46); + OP_BRACES_POSS = TReOp(47); - // !!! Don't add new OpCodes after CLOSE !!! + OP_RECUR = TReOp(48); + + OP_OPEN = TREOp(50); // Opening of group + OP_CLOSE = TREOp(51); // Closing of group + OP_OPEN_ATOMIC = TREOp(52); // Opening of group + OP_CLOSE_ATOMIC = TREOp(53); // Closing of group + + OP_LOOKAHEAD = TREOp(55); + OP_LOOKAHEAD_NEG = TREOp(56); + OP_LOOKAHEAD_END = TREOp(57); + OP_LOOKBEHIND = TREOp(58); + OP_LOOKBEHIND_NEG = TREOp(59); + OP_LOOKBEHIND_END = TREOp(60); + OP_LOOKAROUND_OPTIONAL = TREOp(61); + + OP_SUBCALL = TREOp(65); // Call of subroutine; OP_SUBCALL+i is for group i + OP_LOOP_POSS = TREOp(66); // Same as OP_LOOP but in non-greedy mode + + OP_GBRANCH = TREOp(67); // Guarded branch + OP_GBRANCH_EX = TREOp(68); + OP_GBRANCH_EX_CI = TREOp(69); + + OP_RESET_MATCHPOS = TReOp(70); + + OP_NONE = High(TREOp); // We work with p-code through pointers, compatible with PRegExprChar. // Note: all code components (TRENextOff, TREOp, TREBracesArg, etc) @@ -1346,12 +1759,13 @@ TStackItemRec = record // ###0.945 const reeOk = 0; reeCompNullArgument = 100; + reeUnknownMetaSymbol = 101; reeCompParseRegTooManyBrackets = 102; reeCompParseRegUnmatchedBrackets = 103; reeCompParseRegUnmatchedBrackets2 = 104; reeCompParseRegJunkOnEnd = 105; - reePlusStarOperandCouldBeEmpty = 106; - reeNestedSQP = 107; + reeNotQuantifiable = 106; + reeNestedQuantif = 107; reeBadHexDigit = 108; reeInvalidRange = 109; reeParseAtomTrailingBackSlash = 110; @@ -1359,11 +1773,12 @@ TStackItemRec = record // ###0.945 reeHexCodeAfterBSlashXTooBig = 112; reeUnmatchedSqBrackets = 113; reeInternalUrp = 114; - reeQPSBFollowsNothing = 115; + reeQuantifFollowsNothing = 115; reeTrailingBackSlash = 116; reeNoLetterAfterBSlashC = 117; reeMetaCharAfterMinusInRange = 118; reeRarseAtomInternalDisaster = 119; + reeIncorrectSpecialBrackets = 120; reeIncorrectBraces = 121; reeBRACESArgTooBig = 122; reeUnknownOpcodeInFillFirst = 123; @@ -1372,28 +1787,41 @@ TStackItemRec = record // ###0.945 reeComplexBracesNotImplemented = 126; reeUnrecognizedModifier = 127; reeBadLinePairedSeparator = 128; - // Runtime errors must be >= 1000 + reeBadUnicodeCategory = 129; + reeTooSmallCheckersArray = 130; + reeBadRecursion = 132; + reeBadSubCall = 133; + reeNamedGroupBad = 140; + reeNamedGroupBadName = 141; + reeNamedGroupBadRef = 142; + reeNamedGroupDupName = 143; + reeLookaheadBad = 150; + reeLookbehindBad = 152; + reeLookaroundNotSafe = 153; + reeBadReference = 154; + // Runtime errors must be >= reeFirstRuntimeCode + reeFirstRuntimeCode = 1000; reeRegRepeatCalledInappropriately = 1000; reeMatchPrimMemoryCorruption = 1001; - reeMatchPrimCorruptedPointers = 1002; reeNoExpression = 1003; reeCorruptedProgram = 1004; - //reeNoInputStringSpecified = 1005; reeOffsetMustBePositive = 1006; reeExecNextWithoutExec = 1007; reeBadOpcodeInCharClass = 1008; reeDumpCorruptedOpcode = 1011; - reeModifierUnsupported = 1013; reeLoopStackExceeded = 1014; reeLoopWithoutEntry = 1015; + reeUnknown = 1016; -function TRegExpr.ErrorMsg(AErrorID: integer): RegExprString; +function TRegExpr.ErrorMsg(AErrorID: Integer): RegExprString; begin case AErrorID of reeOk: Result := 'No errors'; reeCompNullArgument: Result := 'TRegExpr compile: null argument'; + reeUnknownMetaSymbol: + Result := 'TRegExpr compile: unknown meta-character: \' + fLastErrorSymbol; reeCompParseRegTooManyBrackets: Result := 'TRegExpr compile: ParseReg: too many ()'; reeCompParseRegUnmatchedBrackets: @@ -1402,10 +1830,10 @@ function TRegExpr.ErrorMsg(AErrorID: integer): RegExprString; Result := 'TRegExpr compile: ParseReg: unmatched ()'; reeCompParseRegJunkOnEnd: Result := 'TRegExpr compile: ParseReg: junk at end'; - reePlusStarOperandCouldBeEmpty: - Result := 'TRegExpr compile: *+ operand could be empty'; - reeNestedSQP: - Result := 'TRegExpr compile: nested *?+'; + reeNotQuantifiable: + Result := 'TRegExpr compile: Token before *+ operand is not quantifiable'; + reeNestedQuantif: + Result := 'TRegExpr compile: nested quantifier *?+'; reeBadHexDigit: Result := 'TRegExpr compile: bad hex digit'; reeInvalidRange: @@ -1424,12 +1852,14 @@ function TRegExpr.ErrorMsg(AErrorID: integer): RegExprString; Result := 'TRegExpr compile: unmatched []'; reeInternalUrp: Result := 'TRegExpr compile: internal fail on char "|", ")"'; - reeQPSBFollowsNothing: - Result := 'TRegExpr compile: ?+*{ follows nothing'; + reeQuantifFollowsNothing: + Result := 'TRegExpr compile: quantifier ?+*{ follows nothing'; reeTrailingBackSlash: Result := 'TRegExpr compile: trailing \'; reeRarseAtomInternalDisaster: Result := 'TRegExpr compile: RarseAtom internal disaster'; + reeIncorrectSpecialBrackets: + Result := 'TRegExpr compile: incorrect expression in (?...) brackets'; reeIncorrectBraces: Result := 'TRegExpr compile: incorrect {} braces'; reeBRACESArgTooBig: @@ -1443,22 +1873,42 @@ function TRegExpr.ErrorMsg(AErrorID: integer): RegExprString; reeComplexBracesNotImplemented: Result := 'TRegExpr compile: if you use braces {} and non-greedy ops *?, +?, ?? for complex cases, enable {$DEFINE ComplexBraces}'; reeUnrecognizedModifier: - Result := 'TRegExpr compile: unrecognized modifier'; + Result := 'TRegExpr compile: incorrect modifier'; reeBadLinePairedSeparator: Result := 'TRegExpr compile: LinePairedSeparator must countain two different chars or be empty'; + reeBadUnicodeCategory: + Result := 'TRegExpr compile: invalid category after \p or \P'; + reeTooSmallCheckersArray: + Result := 'TRegExpr compile: too small CharCheckers array'; + reeBadRecursion: + Result := 'TRegExpr compile: bad recursion (?R)'; + reeBadSubCall: + Result := 'TRegExpr compile: bad subroutine call'; + reeNamedGroupBad: + Result := 'TRegExpr compile: bad named group'; + reeNamedGroupBadName: + Result := 'TRegExpr compile: bad identifier in named group'; + reeNamedGroupBadRef: + Result := 'TRegExpr compile: bad back-reference to named group'; + reeNamedGroupDupName: + Result := 'TRegExpr compile: named group defined more than once'; + reeLookaheadBad: + Result := 'TRegExpr compile: bad lookahead'; + reeLookbehindBad: + Result := 'TRegExpr compile: bad lookbehind'; + reeLookaroundNotSafe: + Result := 'TRegExpr compile: lookbehind brackets with variable length do not support captures'; + reeBadReference: + Result := 'TRegExpr compile: invalid syntax for reference to capture group'; 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: empty expression'; reeCorruptedProgram: Result := 'TRegExpr exec: corrupted opcode (no magic byte)'; - //reeNoInputStringSpecified: - // Result := 'TRegExpr exec: empty input string'; reeOffsetMustBePositive: Result := 'TRegExpr exec: offset must be >0'; reeExecNextWithoutExec: @@ -1471,13 +1921,15 @@ function TRegExpr.ErrorMsg(AErrorID: integer): RegExprString; Result := 'TRegExpr exec: loop stack exceeded'; reeLoopWithoutEntry: Result := 'TRegExpr exec: loop without loop entry'; + reeUnknown: + Result := 'TRegExpr exec: unknow error'; else Result := 'Unknown error'; end; end; { of procedure TRegExpr.Error -------------------------------------------------------------- } -function TRegExpr.LastError: integer; +function TRegExpr.LastError: Integer; begin Result := fLastError; fLastError := reeOk; @@ -1488,12 +1940,12 @@ function TRegExpr.LastError: integer; { ===================== Common section ======================== } { ============================================================= } -class function TRegExpr.VersionMajor: integer; +class function TRegExpr.VersionMajor: Integer; begin Result := REVersionMajor; end; -class function TRegExpr.VersionMinor: integer; +class function TRegExpr.VersionMinor: Integer; begin Result := REVersionMinor; end; @@ -1505,42 +1957,77 @@ constructor TRegExpr.Create; fExpression := ''; fInputString := ''; - regexpBegin := nil; - regexpIsCompiled := False; - - FillChar(fModifiers, SIzeOf(fModifiers), 0); - ModifierI := RegExprModifierI; - ModifierR := RegExprModifierR; - ModifierS := RegExprModifierS; - ModifierG := RegExprModifierG; - ModifierM := RegExprModifierM; - ModifierX := RegExprModifierX; + FillChar(fModifiers, SizeOf(fModifiers), 0); + fModifiers.I := RegExprModifierI; + fModifiers.R := RegExprModifierR; + fModifiers.S := RegExprModifierS; + fModifiers.G := RegExprModifierG; + fModifiers.M := RegExprModifierM; + fModifiers.X := RegExprModifierX; {$IFDEF UseSpaceChars} - SpaceChars := RegExprSpaceChars; // ###0.927 + SpaceChars := RegExprSpaceChars; {$ENDIF} {$IFDEF UseWordChars} - WordChars := RegExprWordChars; // ###0.929 + WordChars := RegExprWordChars; {$ENDIF} - fInvertCase := RegExprInvertCaseFunction; // ###0.927 - - fLineSeparators := RegExprLineSeparators; // ###0.941 - LinePairedSeparator := RegExprLinePairedSeparator; // ###0.941 - FUseOsLineEndOnReplace := True; - FReplaceLineEnd := sLineBreak; - - {$IFDEF UnicodeWordDetection} - FUseUnicodeWordDetection := True; + {$IFDEF UseLineSep} + fLineSeparators := RegExprLineSeparators; {$ENDIF} + fUsePairedBreak := RegExprUsePairedBreak; + fReplaceLineEnd := RegExprReplaceLineBreak; + fSlowChecksSizeMax := 2000; + FAllowUnsafeLookBehind := False; + fRaiseForRuntimeError := True; + {$IFDEF UseLineSep} InitLineSepArray; + {$ENDIF} + InitCharCheckers; + + {$IFDEF Compat} + fInvertCase := OldInvertCase; + {$ENDIF} end; { of constructor TRegExpr.Create -------------------------------------------------------------- } +{ TRegExprGroupNameList } + +function TRegExprGroupNameList.MatchIndexFromName(const AName: RegExprString + ): Integer; +var + i: Integer; +begin + for i := 0 to NameCount - 1 do + if Names[i].Name = AName then + begin + Result := Names[i].Index; + Exit; + end; + Result := -1; +end; + +procedure TRegExprGroupNameList.Clear; +begin + NameCount := 0; + if Length(Names) > RegexGroupCountIncrement then + SetLength(Names, RegexGroupCountIncrement); +end; + +procedure TRegExprGroupNameList.Add(const AName: RegExprString; AnIndex: Integer + ); +begin + if NameCount >= Length(Names) then + SetLength(Names, Length(Names) + 1 + RegexGroupCountIncrement); + Names[NameCount].Name := AName; + Names[NameCount].Index := AnIndex; + inc(NameCount); +end; + {$IFDEF OverMeth} constructor TRegExpr.Create(const AExpression: RegExprString); begin @@ -1556,105 +2043,86 @@ destructor TRegExpr.Destroy; FreeMem(programm); programm := nil; end; -end; { of destructor TRegExpr.Destroy - -------------------------------------------------------------- } +end; -class function TRegExpr.InvertCaseFunction(const Ch: REChar): REChar; +procedure TRegExpr.SetExpression(const AStr: RegExprString); begin - Result := Ch; - if (Ch >= 'a') and (Ch <= 'z') then - begin - Dec(Result, 32); - Exit; - end; - if (Ch >= 'A') and (Ch <= 'Z') then - begin - Inc(Result, 32); - Exit; - end; - if Ord(Ch) < 128 then - Exit; - - {$IFDEF FPC} - Result := _UpperCase(Ch); - if Result = Ch then - Result := _LowerCase(Ch); - {$ELSE} - {$IFDEF UniCode} - {$IFDEF SYN_DELPHI_2009_UP} - if TCharacter.IsUpper(Ch) then - Result := TCharacter.ToLower(Ch) - else - Result := TCharacter.ToUpper(Ch); - {$ENDIF} - {$ELSE} - Result := _UpperCase(Ch); - if Result = Ch then - Result := _LowerCase(Ch); - {$ENDIF} - {$ENDIF} -end; { of function TRegExpr.InvertCaseFunction - -------------------------------------------------------------- } - -procedure TRegExpr.SetExpression(const AStr: RegExprString); -begin - if (AStr <> fExpression) or not regexpIsCompiled then + if (AStr <> fExpression) or not IsCompiled then begin - regexpIsCompiled := False; fExpression := AStr; - UniqueString(fExpression); + //UniqueString(fExpression); fRegexStart := PRegExprChar(fExpression); fRegexEnd := fRegexStart + Length(fExpression); - InvalidateProgramm; // ###0.941 + InvalidateProgramm; end; -end; { of procedure TRegExpr.SetExpression - -------------------------------------------------------------- } +end; -function TRegExpr.GetSubExprCount: integer; +function TRegExpr.GetSubExprCount: Integer; begin + Result := -1; + if Length(GrpIndexes) = 0 then + Exit; // if nothing found, we must return -1 per TRegExpr docs - if startp[0] = nil then - Result := -1 - else + if (GrpBounds[0].GrpStart[0] <> nil) then Result := GrpCount; end; -function TRegExpr.GetMatchPos(Idx: integer): PtrInt; +function TRegExpr.GetMatchPos(Idx: Integer): PtrInt; begin + Result := -1; + if Length(GrpIndexes) = 0 then + Exit; + if (Idx < 0) or (Idx >= Length(GrpIndexes)) then + Exit; Idx := GrpIndexes[Idx]; - if (Idx >= 0) and (startp[Idx] <> nil) then - Result := startp[Idx] - fInputStart + 1 - else - Result := -1; -end; { of function TRegExpr.GetMatchPos - -------------------------------------------------------------- } + if (Idx >= 0) and (GrpBounds[0].GrpStart[Idx] <> nil) then + Result := GrpBounds[0].GrpStart[Idx] - fInputStart + 1; +end; -function TRegExpr.GetMatchLen(Idx: integer): PtrInt; +function TRegExpr.GetMatchLen(Idx: Integer): PtrInt; begin + Result := -1; + if Length(GrpIndexes) = 0 then + Exit; + if (Idx < 0) or (Idx >= Length(GrpIndexes)) then + Exit; Idx := GrpIndexes[Idx]; - if (Idx >= 0) and (startp[Idx] <> nil) then - Result := endp[Idx] - startp[Idx] - else - Result := -1; -end; { of function TRegExpr.GetMatchLen - -------------------------------------------------------------- } + if (Idx >= 0) and (GrpBounds[0].GrpStart[Idx] <> nil) then + Result := GrpBounds[0].GrpEnd[Idx] - GrpBounds[0].GrpStart[Idx]; +end; -function TRegExpr.GetMatch(Idx: integer): RegExprString; +function TRegExpr.GetMatch(Idx: Integer): RegExprString; begin Result := ''; + if Length(GrpIndexes) = 0 then + Exit; + if (Idx < 0) or (Idx >= Length(GrpIndexes)) then + Exit; Idx := GrpIndexes[Idx]; - if (Idx >= 0) and (endp[Idx] > startp[Idx]) then - SetString(Result, startp[Idx], endp[Idx] - startp[Idx]); - { - // then Result := copy (fInputString, MatchPos [Idx], MatchLen [Idx]) //###0.929 + if (Idx >= 0) and (GrpBounds[0].GrpStart[Idx] <> nil) and + (GrpBounds[0].GrpEnd[Idx] > GrpBounds[0].GrpStart[Idx]) then - begin - SetLength(Result, endp[Idx] - startp[Idx]); - System.Move(startp[Idx]^, Result[1], Length(Result) * SizeOf(REChar)); - end; - } -end; { of function TRegExpr.GetMatch - -------------------------------------------------------------- } + SetString(Result, GrpBounds[0].GrpStart[Idx], GrpBounds[0].GrpEnd[Idx] - GrpBounds[0].GrpStart[Idx]); +end; + +function TRegExpr.MatchIndexFromName(const AName: RegExprString): Integer; +begin + Result := GrpNames.MatchIndexFromName(AName); +end; + +function TRegExpr.MatchFromName(const AName: RegExprString): RegExprString; +var + Idx: Integer; +begin + Result := ''; + if Length(GrpIndexes) = 0 then + Exit; + Idx := GrpNames.MatchIndexFromName(AName); + if Idx >= 0 then + Result := GetMatch(Idx) + else + Result := ''; +end; function TRegExpr.GetModifierStr: RegExprString; begin @@ -1691,67 +2159,207 @@ function TRegExpr.GetModifierStr: RegExprString; end; { of function TRegExpr.GetModifierStr -------------------------------------------------------------- } -procedure TRegExpr.SetModifierG(AValue: boolean); +procedure TRegExpr.SetModifierG(AValue: Boolean); begin - fModifiers.G := AValue; + if fModifiers.G <> AValue then + begin + fModifiers.G := AValue; + InvalidateProgramm; + end; end; -procedure TRegExpr.SetModifierI(AValue: boolean); +procedure TRegExpr.SetModifierI(AValue: Boolean); begin - fModifiers.I := AValue; + if fModifiers.I <> AValue then + begin + fModifiers.I := AValue; + InvalidateProgramm; + end; end; -procedure TRegExpr.SetModifierM(AValue: boolean); +procedure TRegExpr.SetModifierM(AValue: Boolean); begin - fModifiers.M := AValue; + if fModifiers.M <> AValue then + begin + fModifiers.M := AValue; + InvalidateProgramm; + end; end; -procedure TRegExpr.SetModifierR(AValue: boolean); +procedure TRegExpr.SetModifierR(AValue: Boolean); begin - fModifiers.R := AValue; + if fModifiers.R <> AValue then + begin + fModifiers.R := AValue; + InvalidateProgramm; + end; end; -procedure TRegExpr.SetModifierS(AValue: boolean); +procedure TRegExpr.SetModifierS(AValue: Boolean); begin - fModifiers.S := AValue; + if fModifiers.S <> AValue then + begin + fModifiers.S := AValue; + InvalidateProgramm; + end; end; -procedure TRegExpr.SetModifierX(AValue: boolean); +procedure TRegExpr.SetModifierX(AValue: Boolean); begin - fModifiers.X := AValue; + if fModifiers.X <> AValue then + begin + fModifiers.X := AValue; + InvalidateProgramm; + end; end; procedure TRegExpr.SetModifierStr(const AStr: RegExprString); begin - if not ParseModifiers(PRegExprChar(AStr), Length(AStr), fModifiers) then - Error(reeModifierUnsupported); -end; { of procedure TRegExpr.SetModifierStr - -------------------------------------------------------------- } + if ParseModifiers(PRegExprChar(AStr), Length(AStr), fModifiers) then + InvalidateProgramm + else + Error(reeUnrecognizedModifier); +end; { ============================================================= } { ==================== Compiler section ======================= } { ============================================================= } -{$IFDEF UnicodeWordDetection} - {$IFDEF FPC} - function IsUnicodeWordChar(AChar: WideChar): boolean; inline; - var - NType: byte; - begin - if Ord(AChar) >= LOW_SURROGATE_BEGIN then - Exit(False); - NType := GetProps(Ord(AChar))^.Category; - Result := (NType <= UGC_OtherNumber); +{$IFDEF FastUnicodeData} +function TRegExpr.IsWordChar(AChar: REChar): Boolean; +begin + // bit 7 in value: is word char + Result := CharCategoryArray[Ord(AChar)] and 128 <> 0; +end; + +(* + // Unicode General Category + UGC_UppercaseLetter = 0; Lu + UGC_LowercaseLetter = 1; Ll + UGC_TitlecaseLetter = 2; Lt + UGC_ModifierLetter = 3; Lm + UGC_OtherLetter = 4; Lo + + UGC_NonSpacingMark = 5; Mn + UGC_CombiningMark = 6; Mc + UGC_EnclosingMark = 7; Me + + UGC_DecimalNumber = 8; Nd + UGC_LetterNumber = 9; Nl + UGC_OtherNumber = 10; No + + UGC_ConnectPunctuation = 11; Pc + UGC_DashPunctuation = 12; Pd + UGC_OpenPunctuation = 13; Ps + UGC_ClosePunctuation = 14; Pe + UGC_InitialPunctuation = 15; Pi + UGC_FinalPunctuation = 16; Pf + UGC_OtherPunctuation = 17; Po + + UGC_MathSymbol = 18; Sm + UGC_CurrencySymbol = 19; Sc + UGC_ModifierSymbol = 20; Sk + UGC_OtherSymbol = 21; So + + UGC_SpaceSeparator = 22; Zs + UGC_LineSeparator = 23; Zl + UGC_ParagraphSeparator = 24; Zp + + UGC_Control = 25; Cc + UGC_Format = 26; Cf + UGC_Surrogate = 27; Cs + UGC_PrivateUse = 28; Co + UGC_Unassigned = 29; Cn +*) + +const + CategoryNames: array[0..29] of array[0..1] of REChar = ( + ('L', 'u'), + ('L', 'l'), + ('L', 't'), + ('L', 'm'), + ('L', 'o'), + ('M', 'n'), + ('M', 'c'), + ('M', 'e'), + ('N', 'd'), + ('N', 'l'), + ('N', 'o'), + ('P', 'c'), + ('P', 'd'), + ('P', 's'), + ('P', 'e'), + ('P', 'i'), + ('P', 'f'), + ('P', 'o'), + ('S', 'm'), + ('S', 'c'), + ('S', 'k'), + ('S', 'o'), + ('Z', 's'), + ('Z', 'l'), + ('Z', 'p'), + ('C', 'c'), + ('C', 'f'), + ('C', 's'), + ('C', 'o'), + ('C', 'n') + ); + +function IsCategoryFirstChar(AChar: REChar): Boolean; {$IFDEF InlineFuncs}inline;{$ENDIF} +begin + case AChar of + 'L', 'M', 'N', 'P', 'S', 'C', 'Z': + Result := True; + else + Result := False; end; - {$ELSE} - function IsUnicodeWordChar(AChar: WideChar): boolean; inline; +end; + +function IsCategoryChars(AChar, AChar2: REChar): Boolean; +var + i: Integer; +begin + for i := Low(CategoryNames) to High(CategoryNames) do + if (AChar = CategoryNames[i][0]) then + if (AChar2 = CategoryNames[i][1]) then + begin + Result := True; + Exit + end; + Result := False; +end; + +function CheckCharCategory(AChar: REChar; Ch0, Ch1: REChar): Boolean; +// AChar: check this char against opcode +// Ch0, Ch1: opcode operands after OP_*CATEGORY +var + N: Byte; + Name0, Name1: REChar; +begin + Result := False; + // bits 0..6 are category + N := CharCategoryArray[Ord(AChar)] and 127; + if N <= High(CategoryNames) then begin - Result := System.Character.IsLetterOrDigit(AChar); + Name0 := CategoryNames[N][0]; + Name1 := CategoryNames[N][1]; + if Ch0 <> Name0 then Exit; + if Ch1 <> #0 then + if Ch1 <> Name1 then Exit; + Result := True; end; - {$ENDIF} -{$ENDIF} +end; + +function MatchOneCharCategory(opnd, scan: PRegExprChar): Boolean; {$IFDEF InlineFuncs}inline;{$ENDIF} +// opnd: points to opcode operands after OP_*CATEGORY +// scan: points into InputString +begin + Result := CheckCharCategory(scan^, opnd^, (opnd + 1)^); +end; -function TRegExpr.IsWordChar(AChar: REChar): boolean; +{$ELSE} +function TRegExpr.IsWordChar(AChar: REChar): Boolean; begin {$IFDEF UseWordChars} Result := Pos(AChar, fWordChars) > 0; @@ -1761,17 +2369,14 @@ function TRegExpr.IsWordChar(AChar: REChar): boolean; 'A' .. 'Z', '0' .. '9', '_': Result := True - else - Result := False; + else + Result := False; end; {$ENDIF} - {$IFDEF UnicodeWordDetection} - if not Result and (Ord(AChar) >= 128) and UseUnicodeWordDetection then - Result := IsUnicodeWordChar(AChar); - {$ENDIF} end; +{$ENDIF} -function TRegExpr.IsSpaceChar(AChar: REChar): boolean; +function TRegExpr.IsSpaceChar(AChar: REChar): Boolean; begin {$IFDEF UseSpaceChars} Result := Pos(AChar, fSpaceChars) > 0; @@ -1779,22 +2384,35 @@ function TRegExpr.IsSpaceChar(AChar: REChar): boolean; case AChar of ' ', #$9, #$A, #$D, #$C: Result := True - else - Result := False; + else + Result := False; end; {$ENDIF} end; -function TRegExpr.IsCustomLineSeparator(AChar: REChar): boolean; +function TRegExpr.IsCustomLineSeparator(AChar: REChar): Boolean; begin - {$IFDEF UniCode} - Result := Pos(AChar, fLineSeparators) > 0; + {$IFDEF UseLineSep} + {$IFDEF UnicodeRE} + Result := Pos(AChar, fLineSeparators) > 0; + {$ELSE} + Result := fLineSepArray[Byte(AChar)]; + {$ENDIF} {$ELSE} - Result := fLineSepArray[byte(AChar)]; + case AChar of + #$d, #$a, + {$IFDEF UnicodeRE} + #$85, #$2028, #$2029, + {$ENDIF} + #$b, #$c: + Result := True; + else + Result := False; + end; {$ENDIF} end; -function IsDigitChar(AChar: REChar): boolean; {$IFDEF InlineFuncs}inline;{$ENDIF} +function IsDigitChar(AChar: REChar): Boolean; {$IFDEF InlineFuncs}inline;{$ENDIF} begin case AChar of '0' .. '9': @@ -1804,13 +2422,13 @@ function IsDigitChar(AChar: REChar): boolean; {$IFDEF InlineFuncs}inline;{$ENDIF end; end; -function IsHorzSeparator(AChar: REChar): boolean; {$IFDEF InlineFuncs}inline;{$ENDIF} +function IsHorzSeparator(AChar: REChar): Boolean; {$IFDEF InlineFuncs}inline;{$ENDIF} begin // Tab and Unicode categoty "Space Separator": https://www.compart.com/en/unicode/category/Zs case AChar of #9, #$20, #$A0: Result := True; - {$IFDEF UniCode} + {$IFDEF UnicodeRE} #$1680, #$2000 .. #$200A, #$202F, #$205F, #$3000: Result := True; {$ENDIF} @@ -1819,12 +2437,12 @@ function IsHorzSeparator(AChar: REChar): boolean; {$IFDEF InlineFuncs}inline;{$E end; end; -function IsLineSeparator(AChar: REChar): boolean; {$IFDEF InlineFuncs}inline;{$ENDIF} +function IsVertLineSeparator(AChar: REChar): Boolean; {$IFDEF InlineFuncs}inline;{$ENDIF} begin case AChar of #$d, #$a, #$b, #$c: Result := True; - {$IFDEF UniCode} + {$IFDEF UnicodeRE} #$2028, #$2029, #$85: Result := True; {$ENDIF} @@ -1851,43 +2469,43 @@ procedure TRegExpr.Compile; Exit; end; - CompileRegExpr(PRegExprChar(fExpression)); + CompileRegExpr(fRegexStart); end; { of procedure TRegExpr.Compile -------------------------------------------------------------- } +{$IFDEF UseLineSep} procedure TRegExpr.InitLineSepArray; -{$IFNDEF UniCode} +{$IFNDEF UnicodeRE} var - i: integer; + i: Integer; {$ENDIF} begin - {$IFNDEF UniCode} + {$IFNDEF UnicodeRE} FillChar(fLineSepArray, SizeOf(fLineSepArray), 0); for i := 1 to Length(fLineSeparators) do - fLineSepArray[byte(fLineSeparators[i])] := True; + fLineSepArray[Byte(fLineSeparators[i])] := True; {$ENDIF} end; +{$ENDIF} -function TRegExpr.IsProgrammOk: boolean; +function TRegExpr.IsProgrammOk: Boolean; begin Result := False; // check modifiers - if not IsModifiersEqual(fModifiers, fProgModifiers) // ###0.941 - then + if not IsModifiersEqual(fModifiers, fProgModifiers) then InvalidateProgramm; - // [Re]compile if needed + // compile if needed if programm = nil then begin - Compile; // ###0.941 - // Check [re]compiled programm + Compile; + // Check compiled programm if programm = nil then - Exit; // error was set/raised by Compile (was reeExecAfterCompErr) + Exit; end; - if programm[0] <> OP_MAGIC // Program corrupted. - then + if programm[0] <> OP_MAGIC then Error(reeCorruptedProgram) else Result := True; @@ -1898,30 +2516,23 @@ procedure TRegExpr.Tail(p: PRegExprChar; val: PRegExprChar); // set the next-pointer at the end of a node chain var scan: PRegExprChar; - temp: PRegExprChar; begin - if p = @regdummy then + if p = @regDummy then Exit; // Find last node. - scan := p; - repeat - temp := regnext(scan); - if temp = nil then - Break; - scan := temp; - until False; + scan := regLast(p); // Set Next 'pointer' if val < scan then - PRENextOff(AlignToPtr(scan + REOpSz))^ := -(scan - val) // ###0.948 + PRENextOff(AlignToPtr(scan + REOpSz))^ := -(scan - val) // 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 + // I could wrap it in $IFDEF UnicodeRE, 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(AlignToPtr(scan + REOpSz))^ := val - scan; // ###0.933 + PRENextOff(AlignToPtr(scan + REOpSz))^ := val - scan; end; { of procedure TRegExpr.Tail -------------------------------------------------------------- } @@ -1929,92 +2540,191 @@ procedure TRegExpr.OpTail(p: PRegExprChar; val: PRegExprChar); // regtail on operand of first argument; nop if operandless begin // "Operandless" and "op != OP_BRANCH" are synonymous in practice. - if (p = nil) or (p = @regdummy) or (PREOp(p)^ <> OP_BRANCH) then + if (p = nil) or (p = @regDummy) or + (PREOp(p)^ <> OP_BRANCH) and (PREOp(p)^ <> OP_GBRANCH) and + (PREOp(p)^ <> OP_GBRANCH_EX) and (PREOp(p)^ <> OP_GBRANCH_EX_CI) + then Exit; - Tail(p + REOpSz + RENextOffSz, val); // ###0.933 + Tail(p + REOpSz + RENextOffSz + REBranchArgSz, val); end; { of procedure TRegExpr.OpTail -------------------------------------------------------------- } -function TRegExpr.EmitNode(op: TREOp): PRegExprChar; // ###0.933 +function TRegExpr.EmitNode(op: TREOp): PRegExprChar; // emit a node, return location begin - Result := regcode; - if Result <> @regdummy then + Result := regCode; + if Result <> @regDummy then begin - PREOp(regcode)^ := op; - Inc(regcode, REOpSz); - PRENextOff(AlignToPtr(regcode))^ := 0; // Next "pointer" := nil - Inc(regcode, RENextOffSz); + PREOp(regCode)^ := op; + Inc(regCode, REOpSz); + PRENextOff(AlignToPtr(regCode))^ := 0; // Next "pointer" := nil + Inc(regCode, RENextOffSz); - if (op = OP_EXACTLY) or (op = OP_EXACTLYCI) then - regExactlyLen := PLongInt(regcode) + if (op = OP_EXACTLY) or (op = OP_EXACTLY_CI) then + regExactlyLen := PLongInt(regCode) else regExactlyLen := nil; {$IFDEF DebugSynRegExpr} - if regcode - programm > regsize then + if regcode - programm > regCodeSize then raise Exception.Create('TRegExpr.EmitNode buffer overrun'); {$ENDIF} end else - Inc(regsize, REOpSz + RENextOffSz); + Inc(regCodeSize, REOpSz + RENextOffSz); // compute code size without code generation end; { of function TRegExpr.EmitNode -------------------------------------------------------------- } +function TRegExpr.EmitBranch: PRegExprChar; +begin + Result := EmitNode(OP_BRANCH); + EmitC(#0); + EmitC(#0); +end; + procedure TRegExpr.EmitC(ch: REChar); begin - if regcode <> @regdummy then + if regCode <> @regDummy then begin - regcode^ := ch; - Inc(regcode); + regCode^ := ch; + Inc(regCode); {$IFDEF DebugSynRegExpr} - if regcode - programm > regsize then + if regcode - programm > regCodeSize then raise Exception.Create('TRegExpr.EmitC buffer overrun'); {$ENDIF} end else - Inc(regsize, REOpSz); // Type of p-code pointer always is ^REChar + Inc(regCodeSize, REOpSz); // Type of p-code pointer always is ^REChar end; { of procedure TRegExpr.EmitC -------------------------------------------------------------- } procedure TRegExpr.EmitInt(AValue: LongInt); begin - if regcode <> @regdummy then + if regCode <> @regDummy then begin - PLongInt(regcode)^ := AValue; - Inc(regcode, RENumberSz); + PLongInt(regCode)^ := AValue; + Inc(regCode, RENumberSz); {$IFDEF DebugSynRegExpr} - if regcode - programm > regsize then + if regcode - programm > regCodeSize then raise Exception.Create('TRegExpr.EmitInt buffer overrun'); {$ENDIF} end else - Inc(regsize, RENumberSz); + Inc(regCodeSize, RENumberSz); +end; + +function TRegExpr.EmitNodeWithGroupIndex(op: TREOp; AIndex: Integer): PRegExprChar; +begin + Result := EmitNode(op); + EmitInt(AIndex); // TReGroupIndex = LongInt; +end; + +function TRegExpr.EmitGroupRef(AIndex: Integer; AIgnoreCase: Boolean): PRegExprChar; +begin + if AIgnoreCase then + Result := EmitNode(OP_BSUBEXP_CI) + else + Result := EmitNode(OP_BSUBEXP); + EmitInt(AIndex); // TReGroupIndex = LongInt; +end; + +{$IFDEF FastUnicodeData} +procedure TRegExpr.FindCategoryName(var scan: PRegExprChar; var ch1, ch2: REChar); +// scan: points into regex string after '\p', to find category name +// ch1, ch2: 2-char name of category; ch2 can be #0 +var + ch: REChar; + pos1, pos2, namePtr: PRegExprChar; + nameLen: Integer; +begin + ch1 := #0; + ch2 := #0; + ch := scan^; + if IsCategoryFirstChar(ch) then + begin + ch1 := ch; + Exit; + end; + if ch = '{' then + begin + pos1 := scan; + pos2 := pos1; + while (pos2 < fRegexEnd) and (pos2^ <> '}') do + Inc(pos2); + if pos2 >= fRegexEnd then + Error(reeIncorrectBraces); + + namePtr := pos1+1; + nameLen := pos2-pos1-1; + Inc(scan, nameLen+1); + + if nameLen<1 then + Error(reeBadUnicodeCategory); + if nameLen>2 then + Error(reeBadUnicodeCategory); + + if nameLen = 1 then + begin + ch1 := namePtr^; + ch2 := #0; + if not IsCategoryFirstChar(ch1) then + Error(reeBadUnicodeCategory); + Exit; + end; + + if nameLen = 2 then + begin + ch1 := namePtr^; + ch2 := (namePtr+1)^; + if not IsCategoryChars(ch1, ch2) then + Error(reeBadUnicodeCategory); + Exit; + end; + end + else + Error(reeBadUnicodeCategory); end; -procedure TRegExpr.InsertOperator(op: TREOp; opnd: PRegExprChar; sz: integer); +function TRegExpr.EmitCategoryMain(APositive: Boolean): PRegExprChar; +var + ch, ch2: REChar; +begin + Inc(regParse); + if regParse >= fRegexEnd then + Error(reeBadUnicodeCategory); + FindCategoryName(regParse, ch, ch2); + if APositive then + Result := EmitNode(OP_ANYCATEGORY) + else + Result := EmitNode(OP_NOTCATEGORY); + EmitC(ch); + EmitC(ch2); +end; +{$ENDIF} + +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; + i: Integer; begin - if regcode = @regdummy then + if regCode = @regDummy then begin - Inc(regsize, sz); + Inc(regCodeSize, sz); Exit; end; // move code behind insert position - src := regcode; - Inc(regcode, sz); + src := regCode; + Inc(regCode, sz); {$IFDEF DebugSynRegExpr} - if regcode - programm > regsize then + if regCode - programm > regCodeSize then raise Exception.Create('TRegExpr.InsertOperator buffer overrun'); - // if (opndregsize) then - // raise Exception.Create('TRegExpr.InsertOperator invalid opnd'); + if fSecondPass and ( (opndregCodeSize) ) then + raise Exception.Create('TRegExpr.InsertOperator invalid opnd'); {$ENDIF} - dst := regcode; + dst := regCode; while src > opnd do begin Dec(dst); @@ -2029,10 +2739,46 @@ procedure TRegExpr.InsertOperator(op: TREOp; opnd: PRegExprChar; sz: integer); place^ := #0; Inc(place); end; + for i := 0 to regNumBrackets - 1 do + if (GrpOpCodes[i] <> nil) and (GrpOpCodes[i] >= opnd) then + GrpOpCodes[i] := GrpOpCodes[i] + sz; end; { of procedure TRegExpr.InsertOperator -------------------------------------------------------------- } -function FindSkippedMetaLen(PStart, PEnd: PRegExprChar): integer; {$IFDEF InlineFuncs}inline;{$ENDIF} +procedure TRegExpr.RemoveOperator(opnd: PRegExprChar; sz: Integer); +// remove an operator in front of already-emitted operand +// Means relocating the operand. +var + src, dst: PRegExprChar; + i: Integer; +begin + if regCode = @regDummy then + begin + // Do not decrement regCodeSize => the fSecondPass may temporary fill the extra memory; + Exit; + end; + // move code behind insert position + {$IFDEF DebugSynRegExpr} + if fSecondPass and ( (opnd=regCodeWork+regCodeSize) ) then + raise Exception.Create('TRegExpr.RemoveOperator() invalid opnd'); + if (sz > regCodeSize-(opnd-regCodeWork)) then + raise Exception.Create('TRegExpr.RemoveOperator buffer underrun'); + {$ENDIF} + src := opnd + sz; + dst := opnd; + while src < regCode do + begin + dst^ := src^; + Inc(dst); + Inc(src); + end; + Dec(regCode, sz); + for i := 0 to regNumBrackets - 1 do + if (GrpOpCodes[i] <> nil) and (GrpOpCodes[i] > opnd) then + GrpOpCodes[i] := GrpOpCodes[i] - sz; +end; + +function FindSkippedMetaLen(PStart, PEnd: PRegExprChar): Integer; {$IFDEF InlineFuncs}inline;{$ENDIF} // find length of initial segment of PStart string consisting // entirely of characters not from IsMetaSymbol1. begin @@ -2048,12 +2794,16 @@ function FindSkippedMetaLen(PStart, PEnd: PRegExprChar): integer; {$IFDEF Inline const // Flags to be passed up and down. - flag_HasWidth = 01; // Known never to match nil string. - flag_Simple = 02; // Simple enough to be OP_STAR/OP_PLUS/OP_BRACES operand. - flag_SpecStart = 04; // Starts with * or +. - flag_Worst = 0; // Worst case. - - {$IFDEF UniCode} + FLAG_WORST = 0; // Worst case + FLAG_HASWIDTH = 1; // Cannot match empty string + FLAG_SIMPLE = 2; // Simple enough to be OP_STAR/OP_PLUS/OP_BRACES operand + FLAG_SPECSTART = 4; // Starts with * or + + FLAG_LOOP = 8; // Has eithe *, + or {,n} with n>=2 + FLAG_GREEDY = 16; // Has any greedy code + FLAG_LOOKAROUND = 32; // "Piece" (ParsePiece) is look-around + FLAG_NOT_QUANTIFIABLE = 64; // "Piece" (ParsePiece) is look-around + + {$IFDEF UnicodeRE} RusRangeLoLow = #$430; // 'а' RusRangeLoHigh = #$44F; // 'я' RusRangeHiLow = #$410; // 'А' @@ -2065,17 +2815,19 @@ function FindSkippedMetaLen(PStart, PEnd: PRegExprChar): integer; {$IFDEF Inline RusRangeHiHigh = #$DF; // 'Я' in cp1251 {$ENDIF} -function TRegExpr.FindInCharClass(ABuffer: PRegExprChar; AChar: REChar; AIgnoreCase: boolean): boolean; +function TRegExpr.FindInCharClass(ABuffer: PRegExprChar; AChar: REChar; AIgnoreCase: Boolean): Boolean; // Buffer contains char pairs: (Kind, Data), where Kind is one of OpKind_ values, // and Data depends on Kind var + OpKind: REChar; ch, ch2: REChar; - N, i: integer; + N, i: Integer; begin if AIgnoreCase then AChar := _UpperCase(AChar); repeat - case ABuffer^ of + OpKind := ABuffer^; + case OpKind of OpKind_End: begin Result := False; @@ -2086,34 +2838,39 @@ function TRegExpr.FindInCharClass(ABuffer: PRegExprChar; AChar: REChar; AIgnoreC begin Inc(ABuffer); ch := ABuffer^; - Inc(ABuffer); - ch2 := ABuffer^; - Inc(ABuffer); - { - // if AIgnoreCase, ch, ch2 are upcased in opcode - if AIgnoreCase then - begin - ch := _UpperCase(ch); - ch2 := _UpperCase(ch2); - end; - } - if (AChar >= ch) and (AChar <= ch2) then + if (AChar >= ch) then begin - Result := True; - Exit; - end; + Inc(ABuffer); + ch2 := ABuffer^; + { + // if AIgnoreCase, ch, ch2 are upcased in opcode + if AIgnoreCase then + begin + ch := _UpperCase(ch); + ch2 := _UpperCase(ch2); + end; + } + if (AChar <= ch2) then + begin + Result := True; + Exit; + end; + Inc(ABuffer); + end + else + Inc(ABuffer, 2); end; OpKind_MetaClass: begin Inc(ABuffer); N := Ord(ABuffer^); - Inc(ABuffer); if CharCheckers[N](AChar) then begin Result := True; Exit end; + Inc(ABuffer); end; OpKind_Char: @@ -2121,10 +2878,8 @@ function TRegExpr.FindInCharClass(ABuffer: PRegExprChar; AChar: REChar; AIgnoreC Inc(ABuffer); N := PLongInt(ABuffer)^; Inc(ABuffer, RENumberSz); - for i := 1 to N do - begin + repeat ch := ABuffer^; - Inc(ABuffer); { // already upcased in opcode if AIgnoreCase then @@ -2135,20 +2890,41 @@ function TRegExpr.FindInCharClass(ABuffer: PRegExprChar; AChar: REChar; AIgnoreC Result := True; Exit; end; - end; + Inc(ABuffer); + dec(n); + until n = 0; end; - else - Error(reeBadOpcodeInCharClass); + {$IFDEF FastUnicodeData} + OpKind_CategoryYes, + OpKind_CategoryNo: + begin + Inc(ABuffer); + ch := ABuffer^; + Inc(ABuffer); + ch2 := ABuffer^; + Inc(ABuffer); + Result := CheckCharCategory(AChar, ch, ch2); + if OpKind = OpKind_CategoryNo then + Result := not Result; + if Result then + Exit; + end; + {$ENDIF} + + {$IFDEF WITH_REGEX_ASSERT} + else + Error(reeBadOpcodeInCharClass); + {$ENDIF} end; until False; // assume that Buffer is ended correctly end; -procedure TRegExpr.GetCharSetFromWordChars(var ARes: TRegExprCharset); +procedure TRegExpr.GetCharSetFromWordChars(var ARes: TRegExprCharSet); {$IFDEF UseWordChars} var - i: integer; + i: Integer; ch: REChar; {$ENDIF} begin @@ -2157,10 +2933,10 @@ procedure TRegExpr.GetCharSetFromWordChars(var ARes: TRegExprCharset); for i := 1 to Length(fWordChars) do begin ch := fWordChars[i]; - {$IFDEF UniCode} + {$IFDEF UnicodeRE} if Ord(ch) <= $FF then {$ENDIF} - Include(ARes, byte(ch)); + Include(ARes, Byte(ch)); end; {$ELSE} ARes := RegExprWordSet; @@ -2170,7 +2946,7 @@ procedure TRegExpr.GetCharSetFromWordChars(var ARes: TRegExprCharset); procedure TRegExpr.GetCharSetFromSpaceChars(var ARes: TRegExprCharset); {$IFDEF UseSpaceChars} var - i: integer; + i: Integer; ch: REChar; {$ENDIF} begin @@ -2179,21 +2955,21 @@ procedure TRegExpr.GetCharSetFromSpaceChars(var ARes: TRegExprCharset); for i := 1 to Length(fSpaceChars) do begin ch := fSpaceChars[i]; - {$IFDEF UniCode} + {$IFDEF UnicodeRE} if Ord(ch) <= $FF then {$ENDIF} - Include(ARes, byte(ch)); + Include(ARes, Byte(ch)); end; {$ELSE} ARes := RegExprSpaceSet; {$ENDIF} end; -procedure TRegExpr.GetCharSetFromCharClass(ABuffer: PRegExprChar; AIgnoreCase: boolean; var ARes: TRegExprCharset); +procedure TRegExpr.GetCharSetFromCharClass(ABuffer: PRegExprChar; AIgnoreCase: Boolean; var ARes: TRegExprCharset); var ch, ch2: REChar; TempSet: TRegExprCharSet; - N, i: integer; + N, i: Integer; begin ARes := []; TempSet := []; @@ -2208,13 +2984,16 @@ procedure TRegExpr.GetCharSetFromCharClass(ABuffer: PRegExprChar; AIgnoreCase: b ch := ABuffer^; Inc(ABuffer); ch2 := ABuffer^; + {$IFDEF UnicodeRE} + if Ord(ch2) > $FF then + ch2 := REChar($FF); + {$ENDIF} Inc(ABuffer); - for i := Ord(ch) to - {$IFDEF UniCode} Min(Ord(ch2), $FF) {$ELSE} Ord(ch2) {$ENDIF} do + for i := Ord(ch) to Ord(ch2) do begin - Include(ARes, byte(i)); + Include(ARes, Byte(i)); if AIgnoreCase then - Include(ARes, byte(InvertCase(REChar(i)))); + Include(ARes, Byte(InvertCase(REChar(i)))); end; end; @@ -2281,6 +3060,12 @@ procedure TRegExpr.GetCharSetFromCharClass(ABuffer: PRegExprChar; AIgnoreCase: b else ARes := ARes + RegExprUpperAzSet; end + else + if N = CheckerIndex_AnyLineBreak then + begin + ARes := ARes + RegExprLineSeparatorsSet; + //we miss U+2028 and U+2029 here + end else Error(reeBadOpcodeInCharClass); end; @@ -2294,55 +3079,67 @@ procedure TRegExpr.GetCharSetFromCharClass(ABuffer: PRegExprChar; AIgnoreCase: b begin ch := ABuffer^; Inc(ABuffer); - {$IFDEF UniCode} + {$IFDEF UnicodeRE} if Ord(ch) <= $FF then {$ENDIF} begin - Include(ARes, byte(ch)); + Include(ARes, Byte(ch)); if AIgnoreCase then - Include(ARes, byte(InvertCase(ch))); + Include(ARes, Byte(InvertCase(ch))); end; end; end; - else - Error(reeBadOpcodeInCharClass); + {$IFDEF FastUnicodeData} + OpKind_CategoryYes, + OpKind_CategoryNo: + begin + // usage of FirstCharSet makes no sense for regex with \p \P + ARes := RegExprAllSet; + Exit; + end; + {$ENDIF} + + {$IFDEF WITH_REGEX_ASSERT} + else + Error(reeBadOpcodeInCharClass); + {$ENDIF} end; until False; // assume that Buffer is ended correctly end; -function TRegExpr.GetModifierG: boolean; +function TRegExpr.GetModifierG: Boolean; begin Result := fModifiers.G; end; -function TRegExpr.GetModifierI: boolean; +function TRegExpr.GetModifierI: Boolean; begin Result := fModifiers.I; end; -function TRegExpr.GetModifierM: boolean; +function TRegExpr.GetModifierM: Boolean; begin Result := fModifiers.M; end; -function TRegExpr.GetModifierR: boolean; +function TRegExpr.GetModifierR: Boolean; begin Result := fModifiers.R; end; -function TRegExpr.GetModifierS: boolean; +function TRegExpr.GetModifierS: Boolean; begin Result := fModifiers.S; end; -function TRegExpr.GetModifierX: boolean; +function TRegExpr.GetModifierX: Boolean; begin Result := fModifiers.X; end; -function TRegExpr.CompileRegExpr(ARegExp: PRegExprChar): boolean; +function TRegExpr.CompileRegExpr(ARegExp: 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 @@ -2355,17 +3152,19 @@ function TRegExpr.CompileRegExpr(ARegExp: PRegExprChar): boolean; // Beware that the optimization-preparation code in here knows about some // of the structure of the compiled regexp. var - scan, longest, longestTemp: PRegExprChar; - Len, LenTemp: integer; - flags: integer; -begin - Result := False; // life too dark - flags := 0; - regparse := nil; // for correct error handling - regexpBegin := ARegExp; + scan, scanTemp, longest, longestTemp: PRegExprChar; + Len, LenTemp: Integer; + FlagTemp, MaxMatchLen: integer; + op: TREOp; +begin + Result := False; + FlagTemp := 0; + regParse := nil; // for correct error handling regExactlyLen := nil; - ClearInternalIndexes; + GrpCount := 0; + ParsedGrpCount := 0; + GrpNames.Clear; fLastError := reeOk; fLastErrorOpcode := TREOp(0); @@ -2383,83 +3182,117 @@ function TRegExpr.CompileRegExpr(ARegExp: PRegExprChar): boolean; end; fProgModifiers := fModifiers; - // well, may it's paranoia. I'll check it later... !!!!!!!! + // well, may it's paranoia. I'll check it later. - // First pass: determine size, legality. + // First pass: calculate opcode size, validate regex fSecondPass := False; fCompModifiers := fModifiers; - regparse := ARegExp; - regnpar := 1; - regsize := 0; - regcode := @regdummy; + regParse := ARegExp; + regNumBrackets := 1; + regCodeSize := 0; + regCode := @regDummy; + regCodeWork := nil; + EmitC(OP_MAGIC); - if ParseReg(0, flags) = nil then + if ParseReg(False, FlagTemp) = nil then begin + regNumBrackets := 0; // Not calling InitInternalGroupData => array sizes not adjusted for FillChar Exit; + end; - // Allocate space. - GetMem(programm, regsize * SizeOf(REChar)); + // Allocate memory + GetMem(programm, regCodeSize * SizeOf(REChar)); + InitInternalGroupData; - // Second pass: emit code. + // Second pass: emit opcode fSecondPass := True; fCompModifiers := fModifiers; - regparse := ARegExp; - regnpar := 1; - regcode := programm; + regParse := ARegExp; + regNumBrackets := 1; + GrpCount := ParsedGrpCount; + ParsedGrpCount := 0; + regCode := programm; + regCodeWork := programm + REOpSz; + EmitC(OP_MAGIC); - if ParseReg(0, flags) = nil then + if ParseReg(False, FlagTemp) = nil then Exit; // Dig out information for optimizations. - {$IFDEF UseFirstCharSet} // ###0.929 + IsFixedLengthEx(op, FMinMatchLen, MaxMatchLen); + {$IFDEF UseFirstCharSet} FirstCharSet := []; - FillFirstCharSet(programm + REOpSz); + FillFirstCharSet(regCodeWork); for Len := 0 to 255 do - FirstCharArray[Len] := byte(Len) in FirstCharSet; + FirstCharArray[Len] := Byte(Len) in FirstCharSet; {$ENDIF} - reganchored := #0; - regmust := nil; - regmustlen := 0; - regmustString := ''; - - scan := programm + REOpSz; // First OP_BRANCH. - if PREOp(regnext(scan))^ = OP_EEND then - begin // Only one top-level choice. - scan := scan + REOpSz + RENextOffSz; - - // Starting-point info. - if PREOp(scan)^ = OP_BOL then - Inc(reganchored); - - // 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 flag_SpecStart) <> 0 then + regAnchored := raNone; + regMust := nil; + regMustLen := 0; + regMustString := ''; + + scan := regCodeWork; // First OP_BRANCH. + // Starting-point info. + if PREOp(scan)^ = OP_BOL then + regAnchored := raBOL + else + if PREOp(scan)^ = OP_EOL then + regAnchored := raEOL + else + if PREOp(scan)^ = OP_CONTINUE_POS then + regAnchored := raContinue + else + // ".*", ".*?", ".*+" at the very start of the pattern, only need to be + // tested from the start-pos of the InputString. + // If a pattern matches, then the ".*" will always go forward to where the + // rest of the pattern starts matching + // OP_ANY is "ModifierS=True" + if (PREOp(scan)^ = OP_STAR) or (PREOp(scan)^ = OP_STAR_NG) or (PREOp(scan)^ = OP_STAR_POSS) then begin + scanTemp := AlignToInt(scan + REOpSz + RENextOffSz); + if PREOp(scanTemp)^ = OP_ANY then + regAnchored := raOnlyOnce; + end + else + // "{0,} is the same as ".*". So the same optimization applies + if (PREOp(scan)^ = OP_BRACES) or (PREOp(scan)^ = OP_BRACES_NG) or (PREOp(scan)^ = OP_BRACES_POSS) then begin + scanTemp := AlignToInt(scan + REOpSz + RENextOffSz); + if (PREBracesArg(scanTemp)^ = 0) // BracesMinCount + and (PREBracesArg(scanTemp + REBracesArgSz)^ = MaxBracesArg) // BracesMaxCount + then begin + scanTemp := AlignToPtr(scanTemp + REBracesArgSz + REBracesArgSz); + if PREOp(scanTemp)^ = OP_ANY then + regAnchored := raOnlyOnce; + end; + end; + + // 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 (FlagTemp and FLAG_SPECSTART) <> 0 then + begin + longest := nil; + Len := 0; + while scan <> nil do begin - longest := nil; - Len := 0; - while scan <> nil do + if PREOp(scan)^ = OP_EXACTLY then begin - if PREOp(scan)^ = OP_EXACTLY then + longestTemp := scan + REOpSz + RENextOffSz + RENumberSz; + LenTemp := PLongInt(scan + REOpSz + RENextOffSz)^; + if LenTemp >= Len then begin - longestTemp := scan + REOpSz + RENextOffSz + RENumberSz; - LenTemp := PLongInt(scan + REOpSz + RENextOffSz)^; - if LenTemp >= Len then - begin - longest := longestTemp; - Len := LenTemp; - end; + longest := longestTemp; + Len := LenTemp; end; - scan := regnext(scan); end; - regmust := longest; - regmustlen := Len; - if regmustlen > 1 then // don't use regmust if too short - SetString(regmustString, regmust, regmustlen); + scan := regNext(scan); end; + regMust := longest; + regMustLen := Len; + if regMustLen > 1 then // don't use regMust if too short + SetString(regMustString, regMust, regMustLen); end; Result := True; @@ -2468,60 +3301,62 @@ function TRegExpr.CompileRegExpr(ARegExp: PRegExprChar): boolean; begin if not Result then InvalidateProgramm; - regexpBegin := nil; - regexpIsCompiled := Result; // ###0.944 end; end; end; { of function TRegExpr.CompileRegExpr -------------------------------------------------------------- } -procedure TRegExpr.SetUseOsLineEndOnReplace(AValue: boolean); +function TRegExpr.ParseReg(InBrackets: Boolean; var FlagParse: Integer): PRegExprChar; begin - if FUseOsLineEndOnReplace = AValue then - Exit; - FUseOsLineEndOnReplace := AValue; - if FUseOsLineEndOnReplace then - FReplaceLineEnd := sLineBreak - else - FReplaceLineEnd := #10; + Result := DoParseReg(InBrackets, True, FlagParse, OP_OPEN, OP_CLOSE); end; -function TRegExpr.ParseReg(paren: integer; var flagp: integer): PRegExprChar; +function TRegExpr.DoParseReg(InBrackets, IndexBrackets: Boolean; + var FlagParse: Integer; BeginGroupOp, EndGroupOP: TReOp): 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; + ret, br, ender, brStart: PRegExprChar; + NBrackets: Integer; + FlagTemp: Integer; SavedModifiers: TRegExprModifiers; + HasGBranch, HasChoice: Boolean; begin - flags := 0; Result := nil; - flagp := flag_HasWidth; // Tentatively. - parno := 0; // eliminate compiler stupid warning + FlagTemp := 0; + FlagParse := FLAG_HASWIDTH; // Tentatively. + NBrackets := 0; SavedModifiers := fCompModifiers; // Make an OP_OPEN node, if parenthesized. - if paren <> 0 then + ret := nil; + if InBrackets then begin - if regnpar >= NSUBEXP then - begin - Error(reeCompParseRegTooManyBrackets); - Exit; - end; - parno := regnpar; - Inc(regnpar); - ret := EmitNode(TREOp(Ord(OP_OPEN) + parno)); - end - else - ret := nil; + if IndexBrackets then begin + if regNumBrackets >= RegexMaxMaxGroups then + begin + Error(reeCompParseRegTooManyBrackets); + Exit; + end; + NBrackets := regNumBrackets; + Inc(regNumBrackets); + if BeginGroupOp <> OP_NONE then + ret := EmitNodeWithGroupIndex(BeginGroupOp, NBrackets); + if fSecondPass then + GrpOpCodes[NBrackets] := ret; + end + else + if BeginGroupOp <> OP_NONE then + ret := EmitNode(BeginGroupOp); + end; // Pick up the branches, linking them together. - br := ParseBranch(flags); + br := ParseBranch(FlagTemp); + brStart := br; if br = nil then begin Result := nil; @@ -2531,51 +3366,78 @@ function TRegExpr.ParseReg(paren: integer; var flagp: integer): PRegExprChar; Tail(ret, br) // OP_OPEN -> first. else ret := br; - if (flags and flag_HasWidth) = 0 then - flagp := flagp and not flag_HasWidth; - flagp := flagp or flags and flag_SpecStart; - while (regparse^ = '|') do + if (FlagTemp and FLAG_HASWIDTH) = 0 then + FlagParse := FlagParse and not FLAG_HASWIDTH; + FlagParse := FlagParse or FlagTemp and (FLAG_SPECSTART or FLAG_LOOP or FLAG_GREEDY); + HasGBranch := False; + HasChoice := regParse^ = '|'; + while (regParse^ = '|') do begin - Inc(regparse); - br := ParseBranch(flags); + Inc(regParse); + br := ParseBranch(FlagTemp); if br = nil then begin Result := nil; Exit; end; + if br^ <> OP_BRANCH then + HasGBranch := True; Tail(ret, br); // OP_BRANCH -> OP_BRANCH. - if (flags and flag_HasWidth) = 0 then - flagp := flagp and not flag_HasWidth; - flagp := flagp or flags and flag_SpecStart; + if (FlagTemp and FLAG_HASWIDTH) = 0 then + FlagParse := FlagParse and not FLAG_HASWIDTH; + FlagParse := FlagParse or FlagTemp and (FLAG_SPECSTART or FLAG_LOOP or FLAG_GREEDY); + end; + if fSecondPass then begin + if HasGBranch then begin + if brStart^ = OP_BRANCH then + brStart^ := OP_GBRANCH; + end + else + if not HasChoice then + RemoveOperator(brStart, REOpSz + RENextOffSz + REBranchArgSz); end; // Make a closing node, and hook it on the end. - if paren <> 0 then - ender := EmitNode(TREOp(Ord(OP_CLOSE) + parno)) + if InBrackets and (EndGroupOP <> OP_NONE) then begin + if IndexBrackets then + ender := EmitNodeWithGroupIndex(EndGroupOP, NBrackets) + else + ender := EmitNode(EndGroupOP); + end + else + if (EndGroupOP = OP_NONE) then begin + if HasChoice then + ender := EmitNode(OP_COMMENT) // need something to hook the branches' tails too + else + ender := nil; + end else ender := EmitNode(OP_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); + if ender <> nil then begin + 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; end; // Check for proper termination. - if paren <> 0 then - if regparse^ <> ')' then + if InBrackets then + if regParse^ <> ')' then begin Error(reeCompParseRegUnmatchedBrackets); Exit; end else - Inc(regparse); // skip trailing ')' - if (paren = 0) and (regparse < fRegexEnd) then + Inc(regParse); // skip trailing ')' + if (not InBrackets) and (regParse < fRegexEnd) then begin - if regparse^ = ')' then + if regParse^ = ')' then Error(reeCompParseRegUnmatchedBrackets2) else Error(reeCompParseRegJunkOnEnd); @@ -2586,30 +3448,59 @@ function TRegExpr.ParseReg(paren: integer; var flagp: integer): PRegExprChar; end; { of function TRegExpr.ParseReg -------------------------------------------------------------- } -function TRegExpr.ParseBranch(var flagp: integer): PRegExprChar; +function TRegExpr.ParseBranch(var FlagParse: Integer): PRegExprChar; // one alternative of an | operator // Implements the concatenation operator. var ret, chain, latest: PRegExprChar; - flags: integer; + ch: REChar; + FlagTemp: Integer; begin - flags := 0; - flagp := flag_Worst; // Tentatively. + FlagTemp := 0; + FlagParse := FLAG_WORST; // Tentatively. - ret := EmitNode(OP_BRANCH); + ret := EmitBranch; chain := nil; - while (regparse < fRegexEnd) and (regparse^ <> '|') and (regparse^ <> ')') do + while (regParse < fRegexEnd) and (regParse^ <> '|') and (regParse^ <> ')') do begin - latest := ParsePiece(flags); + latest := ParsePiece(FlagTemp); if latest = nil then begin Result := nil; Exit; end; - flagp := flagp or flags and flag_HasWidth; + if fSecondPass and + (latest <> nil) and (latest^ = OP_COMMENT) and + ( ((regParse < fRegexEnd) and (regParse^ <> '|') and (regParse^ <> ')')) or + (chain <> nil) + ) + then begin + regCode := latest; + continue; + end; + + FlagParse := FlagParse or FlagTemp and (FLAG_HASWIDTH or FLAG_LOOP or FLAG_GREEDY); if chain = nil // First piece. - then - flagp := flagp or flags and flag_SpecStart + then begin + FlagParse := FlagParse or FlagTemp and FLAG_SPECSTART; + if fSecondPass then begin + case latest^ of + OP_EXACTLY: begin + ret^ := OP_GBRANCH_EX; + ch := (latest + REOpSz + RENextOffSz + RENumberSz)^; + (ret + REOpSz + RENextOffSz)^ := ch; + end; + OP_EXACTLY_CI: begin + ret^ := OP_GBRANCH_EX_CI; + ch := (latest + REOpSz + RENextOffSz + RENumberSz)^; + (ret + REOpSz + RENextOffSz)^ := _UpperCase(ch); + (ret + REOpSz + RENextOffSz + 1)^ := _LowerCase(ch); + end; + end; + end + else begin + end; + end else Tail(chain, latest); chain := latest; @@ -2621,7 +3512,7 @@ function TRegExpr.ParseBranch(var flagp: integer): PRegExprChar; end; { of function TRegExpr.ParseBranch -------------------------------------------------------------- } -function TRegExpr.ParsePiece(var flagp: integer): PRegExprChar; +function TRegExpr.ParsePiece(var FlagParse: 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 OP_NOTHING node as @@ -2653,7 +3544,7 @@ function TRegExpr.ParsePiece(var flagp: integer): PRegExprChar; TheOp: TREOp; NextNode: PRegExprChar; - procedure EmitComplexBraces(ABracesMin, ABracesMax: TREBracesArg; ANonGreedyOp: boolean); // ###0.940 + procedure EmitComplexBraces(ABracesMin, ABracesMax: TREBracesArg; ANonGreedyOp, APossesive: boolean); {$IFDEF ComplexBraces} var off: TRENextOff; @@ -2662,229 +3553,365 @@ function TRegExpr.ParsePiece(var flagp: integer): PRegExprChar; {$IFNDEF ComplexBraces} Error(reeComplexBracesNotImplemented); {$ELSE} + if APossesive then + TheOp := OP_LOOP_POSS + else if ANonGreedyOp then - TheOp := OP_LOOPNG + TheOp := OP_LOOP_NG else TheOp := OP_LOOP; InsertOperator(OP_LOOPENTRY, Result, REOpSz + RENextOffSz); NextNode := EmitNode(TheOp); - if regcode <> @regdummy then + if regCode <> @regDummy then begin - off := (Result + REOpSz + RENextOffSz) - (regcode - REOpSz - RENextOffSz); + off := (Result + REOpSz + RENextOffSz) - (regCode - REOpSz - RENextOffSz); // back to Atom after OP_LOOPENTRY - PREBracesArg(AlignToInt(regcode))^ := ABracesMin; - Inc(regcode, REBracesArgSz); - PREBracesArg(AlignToInt(regcode))^ := ABracesMax; - Inc(regcode, REBracesArgSz); - PRENextOff(AlignToPtr(regcode))^ := off; - Inc(regcode, RENextOffSz); + PREBracesArg(AlignToInt(regCode))^ := ABracesMin; + Inc(regCode, REBracesArgSz); + PREBracesArg(AlignToInt(regCode))^ := ABracesMax; + Inc(regCode, REBracesArgSz); + PRENextOff(AlignToPtr(regCode))^ := off; + Inc(regCode, RENextOffSz); {$IFDEF DebugSynRegExpr} - if regcode - programm > regsize then + if regcode - programm > regCodeSize then raise Exception.Create ('TRegExpr.ParsePiece.EmitComplexBraces buffer overrun'); {$ENDIF} end else - Inc(regsize, REBracesArgSz * 2 + RENextOffSz); + Inc(regCodeSize, REBracesArgSz * 2 + RENextOffSz); Tail(Result, NextNode); // OP_LOOPENTRY -> OP_LOOP - if regcode <> @regdummy then + if regCode <> @regDummy then Tail(Result + REOpSz + RENextOffSz, NextNode); // Atom -> OP_LOOP {$ENDIF} end; - procedure EmitSimpleBraces(ABracesMin, ABracesMax: TREBracesArg; ANonGreedyOp: boolean); // ###0.940 + procedure EmitSimpleBraces(ABracesMin, ABracesMax: TREBracesArg; ANonGreedyOp, APossessive: Boolean); begin - if ANonGreedyOp // ###0.940 - then - TheOp := OP_BRACESNG + if APossessive then + TheOp := OP_BRACES_POSS + else + if ANonGreedyOp then + TheOp := OP_BRACES_NG else TheOp := OP_BRACES; InsertOperator(TheOp, Result, REOpSz + RENextOffSz + REBracesArgSz * 2); - if regcode <> @regdummy then + if regCode <> @regDummy then begin PREBracesArg(AlignToInt(Result + REOpSz + RENextOffSz))^ := ABracesMin; PREBracesArg(AlignToInt(Result + REOpSz + RENextOffSz + REBracesArgSz))^ := ABracesMax; end; end; + function DoParseBraceMinMax(var BMin, BMax: TREBracesArg): Boolean; + var + p: PRegExprChar; + begin + Result := False; + p := regParse; + while IsDigitChar(regParse^) do // MUST appear + Inc(regParse); + if FAllowBraceWithoutMin and (regParse^ = ',') and (p = regParse) then + begin + if not (((regParse+1)^ >= '0') and ((regParse+1)^ <= '9')) then + Exit; + BMin := 0 + end + else + if (regParse^ <> '}') and (regParse^ <> ',') or (p = regParse) then + begin + if not FAllowLiteralBraceWithoutRange then + Error(reeIncorrectBraces); + Exit; + end + else + BMin := ParseNumber(p, regParse - 1); + if regParse^ = ',' then + begin + Inc(regParse); + p := regParse; + while IsDigitChar(regParse^) do + Inc(regParse); + if regParse^ <> '}' then + begin + if not FAllowLiteralBraceWithoutRange then + Error(reeIncorrectBraces); + Exit; + end; + if p = regParse then + BMax := MaxBracesArg + else + BMax := ParseNumber(p, regParse - 1); + end + else + BMax := BMin; // {n} == {n,n} + Result := True; + end; + + function ParseBraceMinMax(var BMin, BMax: TREBracesArg): Boolean; + begin + Result := DoParseBraceMinMax(BMin, BMax); + if Result and (BMin > BMax) then + begin + Error(reeBracesMinParamGreaterMax); + Exit; + end; + end; + + function CheckBraceIsLiteral: Boolean; + var + dummyBracesMin, dummyBracesMax: TREBracesArg; + savedRegParse: PRegExprChar; + begin + Result := False; + if not FAllowLiteralBraceWithoutRange then + exit; + savedRegParse := regParse; + Inc(regParse); + Result := not DoParseBraceMinMax(dummyBracesMin, dummyBracesMax); + regParse := savedRegParse; + end; + var - op: REChar; - NonGreedyOp, NonGreedyCh: boolean; // ###0.940 - flags: integer; - BracesMin, Bracesmax: TREBracesArg; - p: PRegExprChar; -begin - flags := 0; - Result := ParseAtom(flags); + op, nextch: REChar; + NonGreedyOp, NonGreedyCh, PossessiveCh: Boolean; + FlagTemp: Integer; + BracesMin, BracesMax: TREBracesArg; + savedRegParse: PRegExprChar; +begin + FlagTemp := 0; + Result := ParseAtom(FlagTemp); if Result = nil then Exit; - op := regparse^; + op := regParse^; if not ((op = '*') or (op = '+') or (op = '?') or (op = '{')) then begin - flagp := flags; + FlagParse := FlagTemp and not FLAG_LOOKAROUND; Exit; end; - if ((flags and flag_HasWidth) = 0) and (op <> '?') then - begin - Error(reePlusStarOperandCouldBeEmpty); + + if (FlagTemp and FLAG_LOOKAROUND) <> 0 then begin + FlagTemp:= FlagTemp and not FLAG_LOOKAROUND; + FlagParse := FlagParse or FlagTemp and (FLAG_LOOP or FLAG_GREEDY); + BracesMin := 0; + if op = '{' then begin + savedRegParse := regParse; + Inc(regParse); + if not ParseBraceMinMax(BracesMin, BracesMax) then + begin + regParse := savedRegParse; + Exit; + end; + end; + if op = '+' then + BracesMin := 1; + if BracesMin = 0 then + EmitNode(OP_LOOKAROUND_OPTIONAL); + + nextch := (regParse + 1)^; + if (nextch = '+') or (nextch = '?') then + Inc(regParse); + Inc(regParse); + op := regParse^; + if (op = '*') or (op = '+') or (op = '?') or + ( (op = '{') and not CheckBraceIsLiteral) + then + Error(reeNestedQuantif); Exit; end; case op of '*': begin - flagp := flag_Worst or flag_SpecStart; - NonGreedyCh := (regparse + 1)^ = '?'; // ###0.940 - NonGreedyOp := NonGreedyCh or not fCompModifiers.G; - // ###0.940 - if (flags and flag_Simple) = 0 then + if (FlagTemp and FLAG_NOT_QUANTIFIABLE) <> 0 then begin + Error(reeNotQuantifiable); + exit; + end; + FlagParse := FLAG_WORST or FLAG_SPECSTART or FLAG_LOOP; + nextch := (regParse + 1)^; + PossessiveCh := nextch = '+'; + if PossessiveCh then begin - if NonGreedyOp // ###0.940 - then - EmitComplexBraces(0, MaxBracesArg, NonGreedyOp) + NonGreedyCh := False; + NonGreedyOp := False; + end + else + begin + NonGreedyCh := nextch = '?'; + NonGreedyOp := NonGreedyCh or not fCompModifiers.G; + end; + if not NonGreedyCh then + FlagParse := FlagParse or FLAG_GREEDY; + if (FlagTemp and (FLAG_SIMPLE or FLAG_HASWIDTH)) <> (FLAG_SIMPLE or FLAG_HASWIDTH) then + begin + if NonGreedyOp or PossessiveCh or ((FlagTemp and FLAG_HASWIDTH) = 0) then + EmitComplexBraces(0, MaxBracesArg, NonGreedyOp, PossessiveCh) else begin // Emit x* as (x&|), where & means "self". - InsertOperator(OP_BRANCH, Result, REOpSz + RENextOffSz); // Either x + InsertOperator(OP_BRANCH, Result, REOpSz + RENextOffSz + REBranchArgSz); // Either x OpTail(Result, EmitNode(OP_BACK)); // and loop OpTail(Result, Result); // back - Tail(Result, EmitNode(OP_BRANCH)); // or + Tail(Result, EmitBranch); // or Tail(Result, EmitNode(OP_NOTHING)); // nil. end end else - begin // Simple - if NonGreedyOp // ###0.940 - then - TheOp := OP_STARNG + begin // Simple AND has Width + if PossessiveCh then + TheOp := OP_STAR_POSS + else + if NonGreedyOp then + TheOp := OP_STAR_NG else TheOp := OP_STAR; InsertOperator(TheOp, Result, REOpSz + RENextOffSz); end; - if NonGreedyCh // ###0.940 - then - Inc(regparse); // Skip extra char ('?') + if NonGreedyCh or PossessiveCh then + Inc(regParse); // Skip extra char ('?') end; { of case '*' } '+': begin - flagp := flag_Worst or flag_SpecStart or flag_HasWidth; - NonGreedyCh := (regparse + 1)^ = '?'; // ###0.940 - NonGreedyOp := NonGreedyCh or not fCompModifiers.G; - // ###0.940 - if (flags and flag_Simple) = 0 then + if (FlagTemp and FLAG_NOT_QUANTIFIABLE) <> 0 then begin + Error(reeNotQuantifiable); + exit; + end; + FlagParse := FLAG_WORST or FLAG_SPECSTART or (FlagTemp and FLAG_HASWIDTH) or FLAG_LOOP; + nextch := (regParse + 1)^; + PossessiveCh := nextch = '+'; + if PossessiveCh then begin - if NonGreedyOp // ###0.940 - then - EmitComplexBraces(1, MaxBracesArg, NonGreedyOp) + NonGreedyCh := False; + NonGreedyOp := False; + end + else + begin + NonGreedyCh := nextch = '?'; + NonGreedyOp := NonGreedyCh or not fCompModifiers.G; + end; + if not NonGreedyCh then + FlagParse := FlagParse or FLAG_GREEDY; + if (FlagTemp and (FLAG_SIMPLE or FLAG_HASWIDTH)) <> (FLAG_SIMPLE or FLAG_HASWIDTH) then + begin + if NonGreedyOp or PossessiveCh or ((FlagTemp and FLAG_HASWIDTH) = 0) then + EmitComplexBraces(1, MaxBracesArg, NonGreedyOp, PossessiveCh) else begin // Emit x+ as x(&|), where & means "self". - NextNode := EmitNode(OP_BRANCH); // Either + NextNode := EmitBranch; // Either Tail(Result, NextNode); Tail(EmitNode(OP_BACK), Result); // loop back - Tail(NextNode, EmitNode(OP_BRANCH)); // or + Tail(NextNode, EmitBranch); // or Tail(Result, EmitNode(OP_NOTHING)); // nil. end end else begin // Simple - if NonGreedyOp // ###0.940 - then - TheOp := OP_PLUSNG + if PossessiveCh then + TheOp := OP_PLUS_POSS + else + if NonGreedyOp then + TheOp := OP_PLUS_NG else TheOp := OP_PLUS; InsertOperator(TheOp, Result, REOpSz + RENextOffSz); end; - if NonGreedyCh // ###0.940 - then - Inc(regparse); // Skip extra char ('?') + if NonGreedyCh or PossessiveCh then + Inc(regParse); // Skip extra char ('?') end; { of case '+' } '?': begin - flagp := flag_Worst; - NonGreedyCh := (regparse + 1)^ = '?'; // ###0.940 - NonGreedyOp := NonGreedyCh or not fCompModifiers.G; - // ###0.940 - if NonGreedyOp then - begin // ###0.940 // We emit x?? as x{0,1}? - if (flags and flag_Simple) = 0 then - EmitComplexBraces(0, 1, NonGreedyOp) + FlagParse := FLAG_WORST; + nextch := (regParse + 1)^; + PossessiveCh := nextch = '+'; + if PossessiveCh then + begin + NonGreedyCh := False; + NonGreedyOp := False; + end + else + begin + NonGreedyCh := nextch = '?'; + NonGreedyOp := NonGreedyCh or not fCompModifiers.G; + end; + if not NonGreedyCh then + FlagParse := FlagParse or FLAG_GREEDY; + if NonGreedyOp or PossessiveCh then + begin // We emit x?? as x{0,1}? + if (FlagTemp and FLAG_SIMPLE) = 0 then + begin + EmitComplexBraces(0, 1, NonGreedyOp, PossessiveCh); + end else - EmitSimpleBraces(0, 1, NonGreedyOp); + EmitSimpleBraces(0, 1, NonGreedyOp, PossessiveCh); end else begin // greedy '?' - InsertOperator(OP_BRANCH, Result, REOpSz + RENextOffSz); // Either x - Tail(Result, EmitNode(OP_BRANCH)); // or + InsertOperator(OP_BRANCH, Result, REOpSz + RENextOffSz + REBranchArgSz); // Either x + Tail(Result, EmitBranch); // or NextNode := EmitNode(OP_NOTHING); // nil. Tail(Result, NextNode); OpTail(Result, NextNode); end; - if NonGreedyCh // ###0.940 - then - Inc(regparse); // Skip extra char ('?') + if NonGreedyCh or PossessiveCh then + Inc(regParse); // Skip extra char ('?') end; { of case '?' } '{': begin - Inc(regparse); - p := regparse; - while IsDigitChar(regparse^) do // MUST appear - Inc(regparse); - if (regparse^ <> '}') and (regparse^ <> ',') or (p = regparse) then + savedRegParse := regParse; + Inc(regParse); + if not ParseBraceMinMax(BracesMin, BracesMax) then begin - Error(reeIncorrectBraces); + regParse := savedRegParse; Exit; end; - BracesMin := ParseNumber(p, regparse - 1); - if regparse^ = ',' then + if (FlagTemp and FLAG_NOT_QUANTIFIABLE) <> 0 then begin + Error(reeNotQuantifiable); + exit; + end; + if BracesMin > 0 then + FlagParse := FLAG_WORST or (FlagTemp and FLAG_HASWIDTH); + if BracesMax > 0 then + FlagParse := FlagParse or FLAG_SPECSTART; + + nextch := (regParse + 1)^; + PossessiveCh := nextch = '+'; + if PossessiveCh then begin - Inc(regparse); - p := regparse; - while IsDigitChar(regparse^) do - Inc(regparse); - if regparse^ <> '}' then - begin - Error(reeIncorrectBraces); - Exit; - end; - if p = regparse then - Bracesmax := MaxBracesArg - else - Bracesmax := ParseNumber(p, regparse - 1); + NonGreedyCh := False; + NonGreedyOp := False; end else - Bracesmax := BracesMin; // {n} == {n,n} - if BracesMin > Bracesmax then begin - Error(reeBracesMinParamGreaterMax); - Exit; + NonGreedyCh := nextch = '?'; + NonGreedyOp := NonGreedyCh or not fCompModifiers.G; end; - if BracesMin > 0 then - flagp := flag_Worst; - if Bracesmax > 0 then - flagp := flagp or flag_HasWidth or flag_SpecStart; - - NonGreedyCh := (regparse + 1)^ = '?'; // ###0.940 - NonGreedyOp := NonGreedyCh or not fCompModifiers.G; - // ###0.940 - if (flags and flag_Simple) <> 0 then - EmitSimpleBraces(BracesMin, Bracesmax, NonGreedyOp) + if not NonGreedyCh then + FlagParse := FlagParse or FLAG_GREEDY; + if BracesMax >= 2 then + FlagParse := FlagParse or FLAG_LOOP; + if (FlagTemp and (FLAG_SIMPLE or FLAG_HASWIDTH)) = (FLAG_SIMPLE or FLAG_HASWIDTH) then + EmitSimpleBraces(BracesMin, BracesMax, NonGreedyOp, PossessiveCh) else - EmitComplexBraces(BracesMin, Bracesmax, NonGreedyOp); - if NonGreedyCh // ###0.940 - then - Inc(regparse); // Skip extra char '?' + begin + EmitComplexBraces(BracesMin, BracesMax, NonGreedyOp, PossessiveCh); + end; + if NonGreedyCh or PossessiveCh then + Inc(regParse); // Skip extra char '?' end; // of case '{' // else // here we can't be end; { of case op } - Inc(regparse); - op := regparse^; - if (op = '*') or (op = '+') or (op = '?') or (op = '{') then - Error(reeNestedSQP); + FlagParse := FlagParse or FlagTemp and (FLAG_LOOP or FLAG_GREEDY); + Inc(regParse); + op := regParse^; + if (op = '*') or (op = '+') or (op = '?') or + ( (op = '{') and not CheckBraceIsLiteral) + then + Error(reeNestedQuantif); end; { of function TRegExpr.ParsePiece -------------------------------------------------------------- } -function TRegExpr.HexDig(Ch: REChar): integer; +function TRegExpr.HexDig(Ch: REChar): Integer; begin case Ch of '0' .. '9': @@ -2893,15 +3920,13 @@ function TRegExpr.HexDig(Ch: REChar): integer; Result := Ord(Ch) - Ord('a') + 10; 'A' .. 'F': Result := Ord(Ch) - Ord('A') + 10; - else - begin - Result := 0; - Error(reeBadHexDigit); - end; + else + Result := 0; + Error(reeBadHexDigit); end; end; -function TRegExpr.UnQuoteChar(var APtr: PRegExprChar): REChar; +function TRegExpr.UnQuoteChar(var APtr, AEnd: PRegExprChar): REChar; var Ch: REChar; begin @@ -2920,8 +3945,9 @@ function TRegExpr.UnQuoteChar(var APtr: PRegExprChar): REChar; Result := #$1b; // \e => escape (ESC) 'c': begin // \cK => code for Ctrl+K + Result := #0; Inc(APtr); - if APtr >= fRegexEnd then + if APtr >= AEnd then Error(reeNoLetterAfterBSlashC); Ch := APtr^; case Ch of @@ -2937,16 +3963,16 @@ function TRegExpr.UnQuoteChar(var APtr: PRegExprChar): REChar; begin // \x: hex char Result := #0; Inc(APtr); - if APtr >= fRegexEnd then + if APtr >= AEnd then begin Error(reeNoHexCodeAfterBSlashX); Exit; end; if APtr^ = '{' then - begin // \x{nnnn} //###0.936 + begin // \x{nnnn} repeat Inc(APtr); - if APtr >= fRegexEnd then + if APtr >= AEnd then begin Error(reeNoHexCodeAfterBSlashX); Exit; @@ -2970,7 +3996,7 @@ function TRegExpr.UnQuoteChar(var APtr: PRegExprChar): REChar; Result := REChar(HexDig(APtr^)); // HexDig will cause Error if bad hex digit found Inc(APtr); - if APtr >= fRegexEnd then + if APtr >= AEnd then begin Error(reeNoHexCodeAfterBSlashX); Exit; @@ -2981,37 +4007,72 @@ function TRegExpr.UnQuoteChar(var APtr: PRegExprChar): REChar; end; else Result := APtr^; + if (Result <> '_') and IsWordChar(Result) then + begin + fLastErrorSymbol := Result; + Error(reeUnknownMetaSymbol); + end; end; end; -function TRegExpr.ParseAtom(var flagp: integer): PRegExprChar; +function TRegExpr.ParseAtom(var FlagParse: 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; + ret, ret2, regLookBehindOption: PRegExprChar; RangeBeg, RangeEnd: REChar; - CanBeRange: boolean; + CanBeRange: Boolean; AddrOfLen: PLongInt; + HasCaseSenseChars: boolean; + + function ParseNumber(var AParsePos: PRegExprChar; out ANumber: Integer): Boolean; + begin + Result := False; + ANumber := 0; + while (AParsePos^ >= '0') and (AParsePos^ <= '9') do + begin + if ANumber > (High(ANumber)-10) div 10 then + exit; + ANumber := ANumber * 10 + (Ord(AParsePos^) - Ord('0')); + inc(AParsePos); + end; + Result := True; + end; procedure EmitExactly(Ch: REChar); + var + cs: Boolean; begin if fCompModifiers.I then - ret := EmitNode(OP_EXACTLYCI) + ret := EmitNode(OP_EXACTLY_CI) else ret := EmitNode(OP_EXACTLY); EmitInt(1); - EmitC(Ch); - flagp := flagp or flag_HasWidth or flag_Simple; + cs := False; + if fCompModifiers.I then begin + Ch := _UpperCase(Ch); + EmitC(Ch); + if Ch <> _LowerCase(Ch) then + cs := True; + end + else + EmitC(Ch); + if not cs then + PREOp(ret)^ := OP_EXACTLY; + FlagParse := FlagParse or FLAG_HASWIDTH or FLAG_SIMPLE; end; - procedure EmitRangeChar(Ch: REChar; AStartOfRange: boolean); + procedure EmitRangeChar(Ch: REChar; AStartOfRange: Boolean); begin CanBeRange := AStartOfRange; - if fCompModifiers.I then + if fCompModifiers.I then begin Ch := _UpperCase(Ch); + if Ch <> _LowerCase(Ch) then + HasCaseSenseChars := True; + end; if AStartOfRange then begin AddrOfLen := nil; @@ -3022,7 +4083,7 @@ function TRegExpr.ParseAtom(var flagp: integer): PRegExprChar; if AddrOfLen = nil then begin EmitC(OpKind_Char); - Pointer(AddrOfLen) := regcode; + Pointer(AddrOfLen) := regCode; EmitInt(0); end; Inc(AddrOfLen^); @@ -3032,7 +4093,7 @@ function TRegExpr.ParseAtom(var flagp: integer): PRegExprChar; procedure EmitRangePacked(ch1, ch2: REChar); var - ChkIndex: integer; + ChkIndex: Integer; begin AddrOfLen := nil; CanBeRange := False; @@ -3041,6 +4102,8 @@ function TRegExpr.ParseAtom(var flagp: integer): PRegExprChar; begin ch1 := _UpperCase(ch1); ch2 := _UpperCase(ch2); + if (Ch1 <> _LowerCase(Ch1)) or (Ch2 <> _LowerCase(Ch2)) then + HasCaseSenseChars := True; end; for ChkIndex := Low(CharCheckerInfos) to High(CharCheckerInfos) do @@ -3057,82 +4120,130 @@ function TRegExpr.ParseAtom(var flagp: integer): PRegExprChar; EmitC(ch2); end; + {$IFDEF FastUnicodeData} + procedure EmitCategoryInCharClass(APositive: Boolean); + var + ch, ch2: REChar; + begin + AddrOfLen := nil; + CanBeRange := False; + Inc(regParse); + FindCategoryName(regParse, ch, ch2); + if APositive then + EmitC(OpKind_CategoryYes) + else + EmitC(OpKind_CategoryNo); + EmitC(ch); + EmitC(ch2); + end; + {$ENDIF} + var - flags: integer; - Len: integer; + FlagTemp: Integer; + Len: Integer; SavedPtr: PRegExprChar; EnderChar, TempChar: REChar; + DashForRange: Boolean; + GrpKind: TREGroupKind; + GrpName: RegExprString; + GrpIndex, ALen, RegGrpCountBefore, AMaxLen: integer; + NextCh: REChar; + op: TREOp; + SavedModifiers: TRegExprModifiers; begin Result := nil; - flags := 0; - flagp := flag_Worst; + FlagTemp := 0; + FlagParse := FLAG_WORST; AddrOfLen := nil; + GrpIndex := -1; - Inc(regparse); - case (regparse - 1)^ of + Inc(regParse); + case (regParse - 1)^ of '^': - if not fCompModifiers.M or - ((fLineSeparators = '') and not fLinePairedSeparatorAssigned) then + begin + FlagParse := FlagParse or FLAG_NOT_QUANTIFIABLE; + if not fCompModifiers.M + {$IFDEF UseLineSep} or (fLineSeparators = '') {$ENDIF} then ret := EmitNode(OP_BOL) else - ret := EmitNode(OP_BOLML); + ret := EmitNode(OP_BOL_ML); + end; + '$': - if not fCompModifiers.M or - ((fLineSeparators = '') and not fLinePairedSeparatorAssigned) then + begin + FlagParse := FlagParse or FLAG_NOT_QUANTIFIABLE; + if not fCompModifiers.M + {$IFDEF UseLineSep} or (fLineSeparators = '') {$ENDIF} then ret := EmitNode(OP_EOL) else - ret := EmitNode(OP_EOLML); + ret := EmitNode(OP_EOL_ML); + end; + '.': + begin if fCompModifiers.S then begin ret := EmitNode(OP_ANY); - flagp := flagp or flag_HasWidth or flag_Simple; + FlagParse := FlagParse or FLAG_HASWIDTH or FLAG_SIMPLE; end else begin // not /s, so emit [^:LineSeparators:] - ret := EmitNode(OP_ANYML); - flagp := flagp or flag_HasWidth; // not so simple ;) + ret := EmitNode(OP_ANY_ML); + FlagParse := FlagParse or FLAG_HASWIDTH; // not so simple ;) end; + end; + '[': begin - if regparse^ = '^' then + HasCaseSenseChars := False; + if regParse^ = '^' then begin // Complement of range. if fCompModifiers.I then - ret := EmitNode(OP_ANYBUTCI) + ret := EmitNode(OP_ANYBUT_CI) else ret := EmitNode(OP_ANYBUT); - Inc(regparse); + Inc(regParse); end else if fCompModifiers.I then - ret := EmitNode(OP_ANYOFCI) + ret := EmitNode(OP_ANYOF_CI) else ret := EmitNode(OP_ANYOF); CanBeRange := False; - if regparse^ = ']' then + if regParse^ = ']' then begin // first ']' inside [] treated as simple char, no need to check '[' - EmitRangeChar(regparse^, (regparse + 1)^ = '-'); - Inc(regparse); + EmitRangeChar(regParse^, (regParse + 1)^ = '-'); + Inc(regParse); end; - while (regparse < fRegexEnd) and (regparse^ <> ']') do + while (regParse < fRegexEnd) and (regParse^ <> ']') do begin - if (regparse^ = '-') and ((regparse + 1) < fRegexEnd) and - ((regparse + 1)^ <> ']') and CanBeRange then + // last '-' inside [] treated as simple dash + if (regParse^ = '-') and + ((regParse + 1) < fRegexEnd) and + ((regParse + 1)^ = ']') then + begin + EmitRangeChar('-', False); + Inc(regParse); + Break; + end; + + // char '-' which (maybe) makes a range + if (regParse^ = '-') and ((regParse + 1) < fRegexEnd) and CanBeRange then begin - Inc(regparse); - RangeEnd := regparse^; + Inc(regParse); + RangeEnd := regParse^; if RangeEnd = EscChar then begin - if _IsMetaChar((regparse + 1)^) then + if _IsMetaChar((regParse + 1)^) then begin Error(reeMetaCharAfterMinusInRange); Exit; end; - Inc(regparse); - RangeEnd := UnQuoteChar(regparse); + Inc(regParse); + RangeEnd := UnQuoteChar(regParse, fRegexEnd); end; // special handling for Russian range a-YA, add 2 ranges: a-ya and A-YA @@ -3151,24 +4262,24 @@ function TRegExpr.ParseAtom(var flagp: integer): PRegExprChar; end; EmitRangePacked(RangeBeg, RangeEnd); end; - Inc(regparse); + Inc(regParse); end else begin - if regparse^ = EscChar then + if regParse^ = EscChar then begin - Inc(regparse); - if regparse >= fRegexEnd then + Inc(regParse); + if regParse >= fRegexEnd then begin Error(reeParseAtomTrailingBackSlash); Exit; end; - if _IsMetaChar(regparse^) then + if _IsMetaChar(regParse^) then begin AddrOfLen := nil; CanBeRange := False; EmitC(OpKind_MetaClass); - case regparse^ of + case regParse^ of 'w': EmitC(REChar(CheckerIndex_Word)); 'W': @@ -3189,249 +4300,661 @@ function TRegExpr.ParseAtom(var flagp: integer): PRegExprChar; EmitC(REChar(CheckerIndex_HorzSep)); 'H': EmitC(REChar(CheckerIndex_NotHorzSep)); - else - Error(reeBadOpcodeInCharClass); + 'R': + EmitC(REChar(CheckerIndex_AnyLineBreak)); + else + Error(reeBadOpcodeInCharClass); end; end else + {$IFDEF FastUnicodeData} + if regParse^ = 'p' then + EmitCategoryInCharClass(True) + else + if regParse^ = 'P' then + EmitCategoryInCharClass(False) + else + {$ENDIF} begin - TempChar := UnQuoteChar(regparse); - EmitRangeChar(TempChar, (regparse + 1)^ = '-'); + TempChar := UnQuoteChar(regParse, fRegexEnd); + // False if '-' is last char in [] + DashForRange := + (regParse + 2 < fRegexEnd) and + ((regParse + 1)^ = '-') and + ((regParse + 2)^ <> ']'); + EmitRangeChar(TempChar, DashForRange); end; end else begin - EmitRangeChar(regparse^, (regparse + 1)^ = '-'); + // False if '-' is last char in [] + DashForRange := + (regParse + 2 < fRegexEnd) and + ((regParse + 1)^ = '-') and + ((regParse + 2)^ <> ']'); + EmitRangeChar(regParse^, DashForRange); end; - Inc(regparse); + Inc(regParse); end; end; { of while } AddrOfLen := nil; CanBeRange := False; EmitC(OpKind_End); - if regparse^ <> ']' then + if fCompModifiers.I and not HasCaseSenseChars then begin + if PREOp(ret)^ = OP_ANYBUT_CI then + PREOp(ret)^ := OP_ANYBUT; + if PREOp(ret)^ = OP_ANYOF_CI then + PREOp(ret)^ := OP_ANYOF; + end; + if regParse^ <> ']' then begin Error(reeUnmatchedSqBrackets); Exit; end; - Inc(regparse); - flagp := flagp or flag_HasWidth or flag_Simple; + Inc(regParse); + FlagParse := FlagParse or FLAG_HASWIDTH or FLAG_SIMPLE; end; + '(': begin - if regparse^ = '?' then + GrpKind := gkNormalGroup; + GrpName := ''; + + // A: detect kind of expression in brackets + if regParse^ = '?' then begin - // check for non-capturing group: (?:text) - if (regparse + 1)^ = ':' then - begin - Inc(regparse, 2); - ret := ParseReg(1, flags); - if ret = nil then + NextCh := (regParse + 1)^; + case NextCh of + ':': + begin + // non-capturing group: (?:regex) + GrpKind := gkNonCapturingGroup; + Inc(regParse, 2); + end; + '>': + begin + // atomic group: (?>regex) + GrpKind := gkAtomicGroup; + Inc(regParse, 2); + end; + 'P': + begin + if (regParse + 4 >= fRegexEnd) then + Error(reeNamedGroupBad); + case (regParse + 2)^ of + '<': + begin + // named group: (?Pregex) + GrpKind := gkNormalGroup; + FindGroupName(regParse + 3, fRegexEnd, '>', GrpName); + Inc(regParse, Length(GrpName) + 4); + end; + '=': + begin + // back-reference to named group: (?P=name) + GrpKind := gkNamedGroupReference; + FindGroupName(regParse + 3, fRegexEnd, ')', GrpName); + Inc(regParse, Length(GrpName) + 4); + end; + '>': + begin + // subroutine call to named group: (?P>name) + GrpKind := gkSubCall; + FindGroupName(regParse + 3, fRegexEnd, ')', GrpName); + Inc(regParse, Length(GrpName) + 4); + if fSecondPass then begin + GrpIndex := GrpNames.MatchIndexFromName(GrpName); + if GrpIndex < 1 then + Error(reeNamedGroupBadRef); + end; + end; + else + Error(reeNamedGroupBad); + end; + end; + '<': + begin + // lookbehind: (?<=foo)bar + case (regParse + 2)^ of + '=': + begin + if (regParse + 4 >= fRegexEnd) then + Error(reeLookbehindBad); + GrpKind := gkLookbehind; + Inc(regParse, 3); + end; + '!': + begin + if (regParse + 4 >= fRegexEnd) then + Error(reeLookbehindBad); + GrpKind := gkLookbehindNeg; + Inc(regParse, 3); + end; + 'A'..'Z', 'a'..'z': + begin + // named group: (?regex) + if (regParse + 4 >= fRegexEnd) then + Error(reeNamedGroupBad); + GrpKind := gkNormalGroup; + FindGroupName(regParse + 2, fRegexEnd, '>', GrpName); + Inc(regParse, Length(GrpName) + 3); + end; + else + Error(reeIncorrectSpecialBrackets); + end; + end; + '=', '!': + begin + // lookaheads: foo(?=bar) and foo(?!bar) + if (regParse + 3 >= fRegexEnd) then + Error(reeLookaheadBad); + if NextCh = '=' then + begin + GrpKind := gkLookahead; + end + else + begin + GrpKind := gkLookaheadNeg; + end; + Inc(regParse, 2); + end; + '#': + begin + // (?#comment) + FlagParse := FlagParse or FLAG_NOT_QUANTIFIABLE; + GrpKind := gkComment; + Inc(regParse, 2); + end; + 'a'..'z', '-': + begin + // modifiers string like (?mxr) + FlagParse := FlagParse or FLAG_NOT_QUANTIFIABLE; + GrpKind := gkModifierString; + Inc(regParse); + end; + 'R', '0': + begin + // recursion (?R), (?0) + GrpKind := gkRecursion; + Inc(regParse, 2); + if regParse^ <> ')' then + Error(reeBadRecursion); + Inc(regParse); + end; + '1'..'9': + begin + // subroutine call (?1)..(?99) + GrpKind := gkSubCall; + Inc(regParse, 1); + if not ParseNumber(regParse, GrpIndex) or (regParse^ <> ')') then + begin + Error(reeBadRecursion); + Exit; + end; + Inc(regParse, 1); + if fSecondPass and (GrpIndex > GrpCount) then + Error(reeBadSubCall); + end; + '''': + begin + // named group: (?'name'regex) + if (regParse + 4 >= fRegexEnd) then + Error(reeNamedGroupBad); + GrpKind := gkNormalGroup; + FindGroupName(regParse + 2, fRegexEnd, '''', GrpName); + Inc(regParse, Length(GrpName) + 3); + end; + '&': + begin + // subroutine call to named group: (?&name) + if (regParse + 2 >= fRegexEnd) then + Error(reeBadSubCall); + GrpKind := gkSubCall; + FindGroupName(regParse + 2, fRegexEnd, ')', GrpName); + Inc(regParse, Length(GrpName) + 3); + if fSecondPass then begin + GrpIndex := GrpNames.MatchIndexFromName(GrpName); + if GrpIndex < 1 then + Error(reeNamedGroupBadRef); + end; + end; + else + Error(reeIncorrectSpecialBrackets); + end; + end; + + // B: process found kind of brackets + case GrpKind of + gkNonCapturingGroup: begin - Result := nil; - Exit; - end; - flagp := flagp or flags and (flag_HasWidth or flag_SpecStart); - end - else - // check for extended Perl syntax : (?..) - if (regparse + 1)^ = '#' then - begin // (?#comment) - Inc(regparse, 2); // find closing ')' - while (regparse < fRegexEnd) and (regparse^ <> ')') do - Inc(regparse); - if regparse^ <> ')' then + ret := DoParseReg(True, False, FlagTemp, OP_NONE, OP_NONE); + if ret = nil then begin - Error(reeUnclosedComment); + Result := nil; Exit; end; - Inc(regparse); // skip ')' - ret := EmitNode(OP_COMMENT); // comment - end - else - begin // modifiers ? - Inc(regparse); // skip '?' - SavedPtr := regparse; - while (regparse < fRegexEnd) and (regparse^ <> ')') do - Inc(regparse); - if (regparse^ <> ')') or - not ParseModifiers(SavedPtr, regparse - SavedPtr, fCompModifiers) then + FlagParse := FlagParse or FlagTemp and (FLAG_HASWIDTH or FLAG_SPECSTART or FLAG_LOOP or FLAG_GREEDY); + end; + + gkNormalGroup, + gkAtomicGroup: + begin + // skip this block for one of passes, to not double groups count; + // must take first pass (we need GrpNames filled) + if (GrpKind = gkNormalGroup) then begin + Inc(ParsedGrpCount); + if fSecondPass then begin + GrpIndexes[ParsedGrpCount] := regNumBrackets; + end + else + if (GrpName <> '') then + begin + // first pass + if GrpNames.MatchIndexFromName(GrpName) >= 0 then + Error(reeNamedGroupDupName); + GrpNames.Add(GrpName, ParsedGrpCount); + end; + end; + + if GrpKind = gkAtomicGroup then + ret := DoParseReg(True, True, FlagTemp, OP_OPEN_ATOMIC, OP_CLOSE_ATOMIC) + else + ret := ParseReg(True, FlagTemp); + if ret = nil then begin - Error(reeUnrecognizedModifier); + Result := nil; Exit; end; - Inc(regparse); // skip ')' - ret := EmitNode(OP_COMMENT); // comment - // Error (reeQPSBFollowsNothing); - // Exit; + FlagParse := FlagParse or FlagTemp and (FLAG_HASWIDTH or FLAG_SPECSTART or FLAG_LOOP or FLAG_GREEDY); end; - end - else - begin - // normal (capturing) group - if fSecondPass then - // must skip this block for one of passes, to not double groups count - if GrpCount < NSUBEXP - 1 then + + gkLookahead, + gkLookaheadNeg: begin - Inc(GrpCount); - GrpIndexes[GrpCount] := regnpar; + case GrpKind of + gkLookahead: ret := EmitNode(OP_LOOKAHEAD); + gkLookaheadNeg: ret := EmitNode(OP_LOOKAHEAD_NEG); + end; + + Result := DoParseReg(True, False, FlagTemp, OP_NONE, OP_LOOKAHEAD_END); + if Result = nil then + Exit; + + Tail(ret, regLast(Result)); + FlagParse := FlagParse and not FLAG_HASWIDTH or FLAG_LOOKAROUND; end; - ret := ParseReg(1, flags); - if ret = nil then - begin - Result := nil; - Exit; - end; - flagp := flagp or flags and (flag_HasWidth or flag_SpecStart); - end; + + gkLookbehind, + gkLookbehindNeg: + begin + case GrpKind of + gkLookbehind: ret := EmitNode(OP_LOOKBEHIND); + gkLookbehindNeg: ret := EmitNode(OP_LOOKBEHIND_NEG); + end; + regLookBehindOption := regCode; + if (regCode <> @regDummy) then + Inc(regCode, ReOpLookBehindOptionsSz) + else + Inc(regCodeSize, ReOpLookBehindOptionsSz); + + RegGrpCountBefore := ParsedGrpCount; + Result := DoParseReg(True, False, FlagTemp, OP_NONE, OP_LOOKBEHIND_END); + if Result = nil then + Exit; + + Tail(ret, regLast(Result)); + + ret2 := Result; + if (regCode <> @regDummy) then begin + ALen := 0; + if IsPartFixedLength(ret2, op, ALen, AMaxLen, OP_LOOKBEHIND_END, nil, [flfSkipLookAround]) then + PReOpLookBehindOptions(regLookBehindOption)^.IsGreedy := OPT_LOOKBEHIND_FIXED + else + if (ParsedGrpCount > RegGrpCountBefore) and (not FAllowUnsafeLookBehind) then + Error(reeLookaroundNotSafe) + else + if (FlagTemp and (FLAG_GREEDY)) = (FLAG_GREEDY) then + PReOpLookBehindOptions(regLookBehindOption)^.IsGreedy := OPT_LOOKBEHIND_GREEDY + else + PReOpLookBehindOptions(regLookBehindOption)^.IsGreedy := OPT_LOOKBEHIND_NON_GREEDY; + PReOpLookBehindOptions(regLookBehindOption)^.MatchLenMin := ALen; + PReOpLookBehindOptions(regLookBehindOption)^.MatchLenMax := AMaxLen; + end; + + FlagParse := FlagParse and not FLAG_HASWIDTH or FLAG_LOOKAROUND; + end; + + gkNamedGroupReference: + begin + Len := GrpNames.MatchIndexFromName(GrpName); + if fSecondPass and (Len < 0) then + Error(reeNamedGroupBadRef); + ret := EmitGroupRef(Len, fCompModifiers.I); + FlagParse := FlagParse or FLAG_HASWIDTH or FLAG_SIMPLE; + end; + + gkModifierString: + begin + SavedPtr := regParse; + while (regParse < fRegexEnd) and (regParse^ <> ')') and (regParse^ <> ':') do + Inc(regParse); + SavedModifiers := fCompModifiers; + if (regParse^ = ':') and ParseModifiers(SavedPtr, regParse - SavedPtr, fCompModifiers) then + begin + Inc(regParse); // skip ')' + ret := ParseReg(True, FlagTemp); + fCompModifiers := SavedModifiers; + if ret = nil then + begin + Result := nil; + Exit; + end; + FlagParse := FlagParse or FlagTemp and (FLAG_HASWIDTH or FLAG_SPECSTART or FLAG_LOOP or FLAG_GREEDY); + end + else + if (regParse^ = ')') and ParseModifiers(SavedPtr, regParse - SavedPtr, fCompModifiers) then + begin + Inc(regParse); // skip ')' + ret := EmitNode(OP_COMMENT); // comment + end + else + begin + Error(reeUnrecognizedModifier); + Exit; + end; + end; + + gkComment: + begin + while (regParse < fRegexEnd) and (regParse^ <> ')') do + Inc(regParse); + if regParse^ <> ')' then + begin + Error(reeUnclosedComment); + Exit; + end; + Inc(regParse); // skip ')' + ret := EmitNode(OP_COMMENT); // comment + end; + + gkRecursion: + begin + // set FLAG_HASWIDTH to allow compiling of such regex: b(?:m|(?R))*e + FlagParse := FlagParse or FLAG_HASWIDTH; + ret := EmitNode(OP_RECUR); + end; + + gkSubCall: + begin + // set FLAG_HASWIDTH like for (?R) + FlagParse := FlagParse or FLAG_HASWIDTH; + ret := EmitNodeWithGroupIndex(OP_SUBCALL, GrpIndex); + end; + end; // case GrpKind of end; + '|', ')': begin // Supposed to be caught earlier. Error(reeInternalUrp); Exit; end; + '?', '+', '*': begin - Error(reeQPSBFollowsNothing); + Error(reeQuantifFollowsNothing); Exit; end; + EscChar: begin - if regparse >= fRegexEnd then + if regParse >= fRegexEnd then begin Error(reeTrailingBackSlash); Exit; end; - case regparse^ of // r.e.extensions + case regParse^ of 'b': - ret := EmitNode(OP_BOUND); // ###0.943 + begin + FlagParse := FlagParse or FLAG_NOT_QUANTIFIABLE; + ret := EmitNode(OP_BOUND); + end; 'B': - ret := EmitNode(OP_NOTBOUND); // ###0.943 + begin + FlagParse := FlagParse or FLAG_NOT_QUANTIFIABLE; + ret := EmitNode(OP_NOTBOUND); + end; 'A': - ret := EmitNode(OP_BOL); // ###0.941 + begin + FlagParse := FlagParse or FLAG_NOT_QUANTIFIABLE; + ret := EmitNode(OP_BOL); + end; + 'z': + begin + FlagParse := FlagParse or FLAG_NOT_QUANTIFIABLE; + ret := EmitNode(OP_EOL); + end; 'Z': - ret := EmitNode(OP_EOL); // ###0.941 + begin + FlagParse := FlagParse or FLAG_NOT_QUANTIFIABLE; + ret := EmitNode(OP_EOL2); + end; + 'G': + begin + FlagParse := FlagParse or FLAG_NOT_QUANTIFIABLE; + ret := EmitNode(OP_CONTINUE_POS); + end; 'd': begin // r.e.extension - any digit ('0' .. '9') ret := EmitNode(OP_ANYDIGIT); - flagp := flagp or flag_HasWidth or flag_Simple; + FlagParse := FlagParse or FLAG_HASWIDTH or FLAG_SIMPLE; end; 'D': begin // r.e.extension - not digit ('0' .. '9') ret := EmitNode(OP_NOTDIGIT); - flagp := flagp or flag_HasWidth or flag_Simple; + FlagParse := FlagParse or FLAG_HASWIDTH or FLAG_SIMPLE; end; 's': begin // r.e.extension - any space char ret := EmitNode(OP_ANYSPACE); - flagp := flagp or flag_HasWidth or flag_Simple; + FlagParse := FlagParse or FLAG_HASWIDTH or FLAG_SIMPLE; end; 'S': begin // r.e.extension - not space char ret := EmitNode(OP_NOTSPACE); - flagp := flagp or flag_HasWidth or flag_Simple; + FlagParse := FlagParse or FLAG_HASWIDTH or FLAG_SIMPLE; end; 'w': begin // r.e.extension - any english char / digit / '_' ret := EmitNode(OP_ANYLETTER); - flagp := flagp or flag_HasWidth or flag_Simple; + FlagParse := FlagParse or FLAG_HASWIDTH or FLAG_SIMPLE; end; 'W': begin // r.e.extension - not english char / digit / '_' ret := EmitNode(OP_NOTLETTER); - flagp := flagp or flag_HasWidth or flag_Simple; + FlagParse := FlagParse or FLAG_HASWIDTH or FLAG_SIMPLE; end; 'v': begin ret := EmitNode(OP_ANYVERTSEP); - flagp := flagp or flag_HasWidth or flag_Simple; + FlagParse := FlagParse or FLAG_HASWIDTH or FLAG_SIMPLE; end; 'V': begin ret := EmitNode(OP_NOTVERTSEP); - flagp := flagp or flag_HasWidth or flag_Simple; + FlagParse := FlagParse or FLAG_HASWIDTH or FLAG_SIMPLE; end; 'h': begin ret := EmitNode(OP_ANYHORZSEP); - flagp := flagp or flag_HasWidth or flag_Simple; + FlagParse := FlagParse or FLAG_HASWIDTH or FLAG_SIMPLE; end; 'H': begin ret := EmitNode(OP_NOTHORZSEP); - flagp := flagp or flag_HasWidth or flag_Simple; + FlagParse := FlagParse or FLAG_HASWIDTH or FLAG_SIMPLE; end; '1' .. '9': - begin // ###0.936 - if fCompModifiers.I then - ret := EmitNode(OP_BSUBEXPCI) + begin + if fSecondPass and (Ord(regParse^) - Ord('0') > GrpCount) then + Error(reeBadReference); + ret := EmitGroupRef(Ord(regParse^) - Ord('0'), fCompModifiers.I); + FlagParse := FlagParse or FLAG_HASWIDTH or FLAG_SIMPLE; + end; + 'g': + begin + case (regParse + 1)^ of + '<', '''': + begin + // subroutine call to named group + case (regParse + 1)^ of + '<': FindGroupName(regParse + 2, fRegexEnd, '>', GrpName); + '''': FindGroupName(regParse + 2, fRegexEnd, '''', GrpName); + end; + Inc(regParse, Length(GrpName) + 2); + GrpIndex := GrpNames.MatchIndexFromName(GrpName); + if fSecondPass and (GrpIndex < 1) then + Error(reeNamedGroupBadRef); + ret := EmitNodeWithGroupIndex(OP_SUBCALL, GrpIndex); + FlagParse := FlagParse or FLAG_HASWIDTH; + end; + '{': + begin + // back-reference to named group + FindGroupName(regParse + 2, fRegexEnd, '}', GrpName); + Inc(regParse, Length(GrpName) + 2); + GrpIndex := GrpNames.MatchIndexFromName(GrpName); + if fSecondPass and (GrpIndex < 1) then + Error(reeNamedGroupBadRef); + ret := EmitGroupRef(GrpIndex, fCompModifiers.I); + FlagParse := FlagParse or FLAG_HASWIDTH or FLAG_SIMPLE; + end; + '0'..'9': + begin + inc(regParse); + if not ParseNumber(regParse, GrpIndex) then begin + Error(reeBadReference); + Exit; + end; + dec(regParse); + if GrpIndex = 0 then + Error(reeBadReference); + if fSecondPass and (GrpIndex > GrpCount) then + Error(reeBadReference); + ret := EmitGroupRef(GrpIndex, fCompModifiers.I); + FlagParse := FlagParse or FLAG_HASWIDTH or FLAG_SIMPLE; + end; + else + Error(reeBadReference); + end; + end; + 'k': + begin + // back-reference to named group + case (regParse + 1)^ of + '<': + FindGroupName(regParse + 2, fRegexEnd, '>', GrpName); + '''': + FindGroupName(regParse + 2, fRegexEnd, '''', GrpName); + '{': + FindGroupName(regParse + 2, fRegexEnd, '}', GrpName); else - ret := EmitNode(OP_BSUBEXP); - EmitC(REChar(Ord(regparse^) - Ord('0'))); - flagp := flagp or flag_HasWidth or flag_Simple; + Error(reeBadReference); + end; + Inc(regParse, Length(GrpName) + 2); + GrpIndex := GrpNames.MatchIndexFromName(GrpName); + if fSecondPass and (GrpIndex < 1) then + Error(reeNamedGroupBadRef); + ret := EmitGroupRef(GrpIndex, fCompModifiers.I); + FlagParse := FlagParse or FLAG_HASWIDTH or FLAG_SIMPLE; + end; + 'K': + begin + ret := EmitNode(OP_RESET_MATCHPOS); + FlagParse := FlagParse or FLAG_NOT_QUANTIFIABLE; + end; + {$IFDEF FastUnicodeData} + 'p': + begin + ret := EmitCategoryMain(True); + FlagParse := FlagParse or FLAG_HASWIDTH or FLAG_SIMPLE; + end; + 'P': + begin + ret := EmitCategoryMain(False); + FlagParse := FlagParse or FLAG_HASWIDTH or FLAG_SIMPLE; + end; + {$ENDIF} + 'R': + begin + ret := EmitNode(OP_ANYLINEBREAK); + FlagParse := FlagParse or FLAG_HASWIDTH or FLAG_SIMPLE; end; else - EmitExactly(UnQuoteChar(regparse)); + EmitExactly(UnQuoteChar(regParse, fRegexEnd)); end; { of case } - Inc(regparse); + Inc(regParse); end; + else begin - Dec(regparse); + Dec(regParse); if fCompModifiers.X and // check for eXtended syntax - ((regparse^ = '#') or IsIgnoredChar(regparse^)) then - begin // ###0.941 \x - if regparse^ = '#' then + ((regParse^ = '#') or IsIgnoredChar(regParse^)) then + begin // \x + if regParse^ = '#' then begin // Skip eXtended comment // find comment terminator (group of \n and/or \r) - while (regparse < fRegexEnd) and (regparse^ <> #$d) and - (regparse^ <> #$a) do - Inc(regparse); - while (regparse^ = #$d) or (regparse^ = #$a) + while (regParse < fRegexEnd) and (regParse^ <> #$d) and + (regParse^ <> #$a) do + Inc(regParse); + while (regParse^ = #$d) or (regParse^ = #$a) // skip comment terminator do - Inc(regparse); + Inc(regParse); // attempt to support different type of line separators end else begin // Skip the blanks! - while IsIgnoredChar(regparse^) do - Inc(regparse); + while IsIgnoredChar(regParse^) do + Inc(regParse); end; ret := EmitNode(OP_COMMENT); // comment end else begin - Len := FindSkippedMetaLen(regparse, fRegexEnd); + Len := FindSkippedMetaLen(regParse, fRegexEnd); if Len <= 0 then - if regparse^ <> '{' then + if regParse^ <> '{' then begin Error(reeRarseAtomInternalDisaster); Exit; end else - Len := FindSkippedMetaLen(regparse + 1, fRegexEnd) + 1; + Len := FindSkippedMetaLen(regParse + 1, fRegexEnd) + 1; // bad {n,m} - compile as EXACTLY - EnderChar := (regparse + Len)^; + EnderChar := (regParse + Len)^; if (Len > 1) and ((EnderChar = '*') or (EnderChar = '+') or (EnderChar = '?') or (EnderChar = '{')) then Dec(Len); // back off clear of ?+*{ operand. - flagp := flagp or flag_HasWidth; + FlagParse := FlagParse or FLAG_HASWIDTH; if Len = 1 then - flagp := flagp or flag_Simple; + FlagParse := FlagParse or FLAG_SIMPLE; if fCompModifiers.I then - ret := EmitNode(OP_EXACTLYCI) + ret := EmitNode(OP_EXACTLY_CI) else ret := EmitNode(OP_EXACTLY); EmitInt(0); - while (Len > 0) and ((not fCompModifiers.X) or (regparse^ <> '#')) do + while (Len > 0) and ((not fCompModifiers.X) or (regParse^ <> '#')) do begin - if not fCompModifiers.X or not IsIgnoredChar(regparse^) then + if not fCompModifiers.X or not IsIgnoredChar(regParse^) then begin - EmitC(regparse^); - if regcode <> @regdummy then + if fCompModifiers.I then + EmitC(_UpperCase(regParse^)) + else + EmitC(regParse^); + if regCode <> @regDummy then Inc(regExactlyLen^); end; - Inc(regparse); + Inc(regParse); Dec(Len); end; end; { of if not comment } @@ -3445,9 +4968,9 @@ function TRegExpr.ParseAtom(var flagp: integer): PRegExprChar; function TRegExpr.GetCompilerErrorPos: PtrInt; begin Result := 0; - if (regexpBegin = nil) or (regparse = nil) then + if (fRegexStart = nil) or (regParse = nil) then Exit; // not in compiling mode ? - Result := regparse - regexpBegin; + Result := regParse - fRegexStart; end; { of function TRegExpr.GetCompilerErrorPos -------------------------------------------------------------- } @@ -3455,35 +4978,71 @@ function TRegExpr.GetCompilerErrorPos: PtrInt; { ===================== Matching section ====================== } { ============================================================= } -function TRegExpr.regrepeat(p: PRegExprChar; AMax: integer): integer; +procedure TRegExpr.FindGroupName(APtr, AEndPtr: PRegExprChar; AEndChar: REChar; var AName: RegExprString); +// check that group name is valid identifier, started from non-digit +// this is to be like in Python regex +var + P: PRegExprChar; +begin + P := APtr; + if IsDigitChar(P^) or not IsWordChar(P^) then + Error(reeNamedGroupBadName); + + repeat + if P >= AEndPtr then + Error(reeNamedGroupBad); + if P^ = AEndChar then + Break; + if not (IsWordChar(P^) or (P^ = '_')) then + Error(reeNamedGroupBadName); + Inc(P); + until False; + + SetString(AName, APtr, P-APtr); +end; + +function TRegExpr.FindRepeated(p: PRegExprChar; AMax: Integer): Integer; // repeatedly match something simple, report how many +// p: points to current opcode var scan: PRegExprChar; opnd: PRegExprChar; - TheMax, NLen: integer; - InvChar: REChar; // ###0.931 - GrpStart, GrpEnd: PRegExprChar; // ###0.936 - ArrayIndex: integer; + TheMax: PtrInt; // PtrInt, gets diff of 2 pointers + InvChar: REChar; + CurStart, CurEnd: PRegExprChar; + ArrayIndex: Integer; + {$IFDEF UnicodeEx} + i: Integer; + {$ENDIF} begin Result := 0; - scan := reginput; - opnd := p + REOpSz + RENextOffSz; // OPERAND + scan := regInput; // points into InputString + opnd := p + REOpSz + RENextOffSz; // points to operand of opcode (after OP_nnn code) TheMax := fInputEnd - scan; if TheMax > AMax then TheMax := AMax; case PREOp(p)^ of OP_ANY: begin - // note - OP_ANYML cannot be proceeded in regrepeat because can skip + // note - OP_ANY_ML cannot be proceeded in FindRepeated because can skip // more than one char at once + {$IFDEF UnicodeEx} + for i := 1 to TheMax do + IncUnicode2(scan, Result); + {$ELSE} Result := TheMax; Inc(scan, Result); + {$ENDIF} end; + OP_EXACTLY: begin // in opnd can be only ONE char !!! + { + // Alexey: commented because of https://github.com/andgineer/TRegExpr/issues/145 NLen := PLongInt(opnd)^; if TheMax > NLen then TheMax := NLen; + } Inc(opnd, RENumberSz); while (Result < TheMax) and (opnd^ = scan^) do begin @@ -3491,20 +5050,24 @@ function TRegExpr.regrepeat(p: PRegExprChar; AMax: integer): integer; Inc(scan); end; end; - OP_EXACTLYCI: + + OP_EXACTLY_CI: begin // in opnd can be only ONE char !!! + { + // Alexey: commented because of https://github.com/andgineer/TRegExpr/issues/145 NLen := PLongInt(opnd)^; if TheMax > NLen then TheMax := NLen; + } Inc(opnd, RENumberSz); while (Result < TheMax) and (opnd^ = scan^) do - begin // prevent unneeded InvertCase //###0.931 + begin // prevent unneeded InvertCase Inc(Result); Inc(scan); end; if Result < TheMax then - begin // ###0.931 - InvChar := InvertCase(opnd^); // store in register + begin + InvChar := _LowerCase(opnd^); // store in register while (Result < TheMax) and ((opnd^ = scan^) or (InvChar = scan^)) do begin Inc(Result); @@ -3512,20 +5075,21 @@ function TRegExpr.regrepeat(p: PRegExprChar; AMax: integer): integer; end; end; end; + OP_BSUBEXP: - begin // ###0.936 - ArrayIndex := GrpIndexes[Ord(opnd^)]; + begin + ArrayIndex := GrpIndexes[PReGroupIndex(opnd)^]; if ArrayIndex < 0 then Exit; - GrpStart := startp[ArrayIndex]; - if GrpStart = nil then + CurStart := GrpBounds[regRecursion].GrpStart[ArrayIndex]; + if CurStart = nil then Exit; - GrpEnd := endp[ArrayIndex]; - if GrpEnd = nil then + CurEnd := GrpBounds[regRecursion].GrpEnd[ArrayIndex]; + if CurEnd = nil then Exit; repeat - opnd := GrpStart; - while opnd < GrpEnd do + opnd := CurStart; + while opnd < CurEnd do begin if (scan >= fInputEnd) or (scan^ <> opnd^) then Exit; @@ -3533,23 +5097,24 @@ function TRegExpr.regrepeat(p: PRegExprChar; AMax: integer): integer; Inc(opnd); end; Inc(Result); - reginput := scan; + regInput := scan; until Result >= AMax; end; - OP_BSUBEXPCI: - begin // ###0.936 - ArrayIndex := GrpIndexes[Ord(opnd^)]; + + OP_BSUBEXP_CI: + begin + ArrayIndex := GrpIndexes[PReGroupIndex(opnd)^]; if ArrayIndex < 0 then Exit; - GrpStart := startp[ArrayIndex]; - if GrpStart = nil then + CurStart := GrpBounds[regRecursion].GrpStart[ArrayIndex]; + if CurStart = nil then Exit; - GrpEnd := endp[ArrayIndex]; - if GrpEnd = nil then + CurEnd := GrpBounds[regRecursion].GrpEnd[ArrayIndex]; + if CurEnd = nil then Exit; repeat - opnd := GrpStart; - while opnd < GrpEnd do + opnd := CurStart; + while opnd < CurEnd do begin if (scan >= fInputEnd) or ((scan^ <> opnd^) and (scan^ <> InvertCase(opnd^))) then @@ -3558,123 +5123,340 @@ function TRegExpr.regrepeat(p: PRegExprChar; AMax: integer): integer; Inc(opnd); end; Inc(Result); - reginput := scan; + regInput := scan; until Result >= AMax; end; + OP_ANYDIGIT: while (Result < TheMax) and IsDigitChar(scan^) do begin Inc(Result); Inc(scan); end; + OP_NOTDIGIT: + {$IFDEF UNICODEEX} + begin + i := 0; + while (i < TheMax) and not IsDigitChar(scan^) do + begin + Inc(i); + IncUnicode2(scan, Result); + end; + end; + {$ELSE} while (Result < TheMax) and not IsDigitChar(scan^) do begin Inc(Result); Inc(scan); end; + {$ENDIF} + OP_ANYLETTER: - while (Result < TheMax) and IsWordChar(scan^) do // ###0.940 + while (Result < TheMax) and IsWordChar(scan^) do begin Inc(Result); Inc(scan); end; + OP_NOTLETTER: - while (Result < TheMax) and not IsWordChar(scan^) do // ###0.940 + {$IFDEF UNICODEEX} + begin + i := 0; + while (i < TheMax) and not IsWordChar(scan^) do + begin + Inc(i); + IncUnicode2(scan, Result); + end; + end; + {$ELSE} + while (Result < TheMax) and not IsWordChar(scan^) do begin Inc(Result); Inc(scan); end; + {$ENDIF} + OP_ANYSPACE: while (Result < TheMax) and IsSpaceChar(scan^) do begin Inc(Result); Inc(scan); end; + OP_NOTSPACE: + {$IFDEF UNICODEEX} + begin + i := 0; + while (i < TheMax) and not IsSpaceChar(scan^) do + begin + Inc(i); + IncUnicode2(scan, Result); + end; + end; + {$ELSE} while (Result < TheMax) and not IsSpaceChar(scan^) do begin Inc(Result); Inc(scan); end; + {$ENDIF} + OP_ANYVERTSEP: - while (Result < TheMax) and IsLineSeparator(scan^) do + while (Result < TheMax) and IsVertLineSeparator(scan^) do begin Inc(Result); Inc(scan); end; + OP_NOTVERTSEP: - while (Result < TheMax) and not IsLineSeparator(scan^) do + {$IFDEF UNICODEEX} + begin + i := 0; + while (i < TheMax) and not IsVertLineSeparator(scan^) do + begin + Inc(i); + IncUnicode2(scan, Result); + end; + end; + {$ELSE} + while (Result < TheMax) and not IsVertLineSeparator(scan^) do begin Inc(Result); Inc(scan); end; + {$ENDIF} + OP_ANYHORZSEP: while (Result < TheMax) and IsHorzSeparator(scan^) do begin Inc(Result); Inc(scan); end; + OP_NOTHORZSEP: + {$IFDEF UNICODEEX} + begin + i := 0; + while (i < TheMax) and not IsHorzSeparator(scan^) do + begin + Inc(i); + IncUnicode2(scan, Result); + end; + end; + {$ELSE} while (Result < TheMax) and not IsHorzSeparator(scan^) do begin Inc(Result); Inc(scan); end; + {$ENDIF} + OP_ANYOF: + {$IFDEF UNICODEEX} + begin + i := 0; + while (i < TheMax) and FindInCharClass(opnd, scan^, False) do + begin + Inc(i); + IncUnicode2(scan, Result); + end; + end; + {$ELSE} while (Result < TheMax) and FindInCharClass(opnd, scan^, False) do begin Inc(Result); Inc(scan); end; + {$ENDIF} + OP_ANYBUT: + {$IFDEF UNICODEEX} + begin + i := 0; + while (i < TheMax) and not FindInCharClass(opnd, scan^, False) do + begin + Inc(i); + IncUnicode2(scan, Result); + end; + end; + {$ELSE} while (Result < TheMax) and not FindInCharClass(opnd, scan^, False) do begin Inc(Result); Inc(scan); end; - OP_ANYOFCI: + {$ENDIF} + + OP_ANYOF_CI: + {$IFDEF UNICODEEX} + begin + i := 0; + while (i < TheMax) and FindInCharClass(opnd, scan^, True) do + begin + Inc(i); + IncUnicode2(scan, Result); + end; + end; + {$ELSE} while (Result < TheMax) and FindInCharClass(opnd, scan^, True) do begin Inc(Result); Inc(scan); end; - OP_ANYBUTCI: + {$ENDIF} + + OP_ANYBUT_CI: + {$IFDEF UNICODEEX} + begin + i := 0; + while (i < TheMax) and not FindInCharClass(opnd, scan^, True) do + begin + Inc(i); + IncUnicode2(scan, Result); + end; + end; + {$ELSE} while (Result < TheMax) and not FindInCharClass(opnd, scan^, True) do begin Inc(Result); Inc(scan); end; + {$ENDIF} + + {$IFDEF FastUnicodeData} + OP_ANYCATEGORY: + {$IFDEF UNICODEEX} + begin + i := 0; + while (i < TheMax) and MatchOneCharCategory(opnd, scan) do + begin + Inc(i); + IncUnicode2(scan, Result); + end; + end; + {$ELSE} + while (Result < TheMax) and MatchOneCharCategory(opnd, scan) do + begin + Inc(Result); + Inc(scan); + end; + {$ENDIF} + + OP_NOTCATEGORY: + {$IFDEF UNICODEEX} + begin + i := 0; + while (i < TheMax) and not MatchOneCharCategory(opnd, scan) do + begin + Inc(i); + IncUnicode2(scan, Result); + end; + end; + {$ELSE} + while (Result < TheMax) and not MatchOneCharCategory(opnd, scan) do + begin + Inc(Result); + Inc(scan); + end; + {$ENDIF} + {$ENDIF} + + OP_ANYLINEBREAK: + while (Result < TheMax) and IsAnyLineBreak(scan^) do + begin + Inc(Result); + Inc(scan); + end; + else - begin // Oh dear. Called inappropriately. - Result := 0; // Best compromise. - Error(reeRegRepeatCalledInappropriately); - Exit; - end; + Result := 0; + Error(reeRegRepeatCalledInappropriately); + Exit; end; { of case } - reginput := scan; -end; { of function TRegExpr.regrepeat + regInput := scan; +end; { of function TRegExpr.FindRepeated -------------------------------------------------------------- } -function TRegExpr.regnext(p: PRegExprChar): PRegExprChar; +function TRegExpr.regNext(p: PRegExprChar): PRegExprChar; // dig the "next" pointer out of a node var offset: TRENextOff; begin - if p = @regdummy then + if p = @regDummy then begin Result := nil; Exit; end; - offset := PRENextOff(AlignToPtr(p + REOpSz))^; // ###0.933 inlined NEXT + offset := PRENextOff(AlignToPtr(p + REOpSz))^; if offset = 0 then Result := nil else Result := p + offset; -end; { of function TRegExpr.regnext - -------------------------------------------------------------- } +end; -function TRegExpr.MatchPrim(prog: PRegExprChar): boolean; +function TRegExpr.regNextQuick(p: PRegExprChar): PRegExprChar; {$IFDEF FPC}inline;{$ENDIF} +var + offset: TRENextOff; +begin + // The inlined version is never called in the first pass. + Assert(fSecondPass); // fSecondPass will also be true in MatchPrim. + offset := PRENextOff(AlignToPtr(p + REOpSz))^; + {$IFDEF WITH_REGEX_ASSERT} + if offset = 0 then + Result := nil + else + begin + {$ENDIF} + Result := p + offset; + {$IFDEF WITH_REGEX_ASSERT} + assert((Result >= programm) and (Result < programm + regCodeSize * SizeOf(REChar))); + end; + {$ENDIF} +end; + +function TRegExpr.regLast(p: PRegExprChar): PRegExprChar; +var + temp: PRegExprChar; +begin + Result := p; + if p = @regDummy then + Exit; + // Find last node. + repeat + temp := regNext(Result); + if temp = nil then + Break; + Result := temp; + until False; +end; + +type + TRegExprMatchPrimLocals = record + case TREOp of + {$IFDEF ComplexBraces} + OP_LOOPENTRY: ( + LoopInfo: TOpLoopInfo; + ); + OP_LOOP: ( // and OP_LOOP_NG + LoopInfoListPtr: POpLoopInfo; + ); + {$ENDIF} + OP_LOOKAHEAD, OP_LOOKBEHIND: ( + IsNegativeLook: Boolean; + IsGreedy: REChar; + LookAroundInfo: TRegExprLookAroundInfo; + InpStart: PRegExprChar; // only OP_LOOKBEHIND + ); + OP_LOOKAHEAD_END, OP_LOOKBEHIND_END: ( + LookAroundInfoPtr: PRegExprLookAroundInfo; + ); + OP_SUBCALL: ( + savedCurrentSubCalled: Integer; + ); + end; + +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, @@ -3682,193 +5464,280 @@ function TRegExpr.MatchPrim(prog: PRegExprChar): boolean; // 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. + scan: PRegExprChar; // current node + next: PRegExprChar; // next node Len: PtrInt; - opnd: PRegExprChar; - no: integer; + opnd, opGrpEnd: PRegExprChar; + no: Integer; save: PRegExprChar; nextch: REChar; - BracesMin, Bracesmax: integer; - // we use integer instead of TREBracesArg for better support */+ - {$IFDEF ComplexBraces} - SavedLoopStack: TRegExprLoopStack; // :(( very bad for recursion - SavedLoopStackIdx: integer; // ###0.925 - {$ENDIF} - bound1, bound2: boolean; + BracesMin, BracesMax: Integer; + // we use integer instead of TREBracesArg to better support */+ + bound1, bound2: Boolean; + Local: TRegExprMatchPrimLocals; begin Result := False; + {$IFDEF RegExpWithStackOverflowCheck_DecStack_Frame} + if get_frame < StackLimit then begin + error(reeLoopStackExceeded); + exit; + end; + {$ENDIF} + + + { + // Alexey: not sure it's ok for long searches in big texts, so disabled + if regNestedCalls > MaxRegexBackTracking then + Exit; + Inc(regNestedCalls); + } + scan := prog; - while scan <> nil do + while True do begin - Len := PRENextOff(AlignToPtr(scan + 1))^; // ###0.932 inlined regnext - if Len = 0 then - next := nil - else - next := scan + Len; + Assert(scan <> nil); + next := regNextQuick(scan); case scan^ of - OP_NOTBOUND, OP_BOUND: begin - bound1 := (reginput = fInputStart) or not IsWordChar((reginput - 1)^); - bound2 := (reginput = fInputEnd) or not IsWordChar(reginput^); - if (scan^ = OP_BOUND) xor (bound1 <> bound2) then + bound1 := (regInput = fInputStart) or not IsWordChar((regInput - 1)^); + bound2 := (regInput >= fInputEnd) or not IsWordChar(regInput^); + if bound1 = bound2 then Exit; end; + + OP_NOTBOUND: + begin + bound1 := (regInput = fInputStart) or not IsWordChar((regInput - 1)^); + bound2 := (regInput >= fInputEnd) or not IsWordChar(regInput^); + if bound1 <> bound2 then + Exit; + end; + OP_BOL: begin - if reginput <> fInputStart then + if regInput <> fInputStart then + Exit; + end; + + OP_CONTINUE_POS: + begin + if regInput <> fInputContinue then Exit; end; + + OP_RESET_MATCHPOS: + begin + save := GrpBounds[0].GrpStart[0]; + GrpBounds[0].GrpStart[0] := regInput; + Result := MatchPrim(next); + if not Result then + GrpBounds[0].GrpStart[0] := save; + exit; + end; + OP_EOL: begin - if reginput < fInputEnd then + // \z matches at the very end + if regInput < fInputEnd then Exit; end; - OP_BOLML: - if reginput > fInputStart then + + OP_EOL2: begin - nextch := (reginput - 1)^; - if (nextch <> fLinePairedSeparatorTail) or - ((reginput - 1) <= fInputStart) or - ((reginput - 2)^ <> fLinePairedSeparatorHead) then + // \Z matches at the very and + before the final line-break (LF and CR LF) + if regInput < fInputEnd then begin - if (nextch = fLinePairedSeparatorHead) and - (reginput^ = fLinePairedSeparatorTail) then - Exit; // don't stop between paired separator - if not IsCustomLineSeparator(nextch) then + if (regInput = fInputEnd - 1) and (regInput^ = #10) then + begin end + else + if (regInput = fInputEnd - 2) and (regInput^ = #13) and ((regInput + 1) ^ = #10) then + begin end + else Exit; end; end; - OP_EOLML: - if reginput < fInputEnd then + + OP_BOL_ML: + if regInput > fInputStart then begin - nextch := reginput^; - if (nextch <> fLinePairedSeparatorHead) or - ((reginput + 1)^ <> fLinePairedSeparatorTail) then + if ((regInput - 1) <= fInputStart) or + not IsPairedBreak(regInput - 2) then begin - if (nextch = fLinePairedSeparatorTail) and (reginput > fInputStart) - and ((reginput - 1)^ = fLinePairedSeparatorHead) then - Exit; // don't stop between paired separator - if not IsCustomLineSeparator(nextch) then + // don't stop between paired separator + if IsPairedBreak(regInput - 1) then + Exit; + if not IsCustomLineSeparator((regInput - 1)^) then + Exit; + end; + end; + + OP_EOL_ML: + if regInput < fInputEnd then + begin + if not IsPairedBreak(regInput) then + begin + // don't stop between paired separator + if (regInput > fInputStart) and IsPairedBreak(regInput - 1) then + Exit; + if not IsCustomLineSeparator(regInput^) then Exit; end; end; + OP_ANY: begin - if reginput = fInputEnd then + if regInput >= fInputCurrentEnd then Exit; - Inc(reginput); - end; - OP_ANYML: - begin // ###0.941 - if (reginput = fInputEnd) or - ((reginput^ = fLinePairedSeparatorHead) and - ((reginput + 1)^ = fLinePairedSeparatorTail)) or - IsCustomLineSeparator(reginput^) + {$IFDEF UNICODEEX} + IncUnicode(regInput); + {$ELSE} + Inc(regInput); + {$ENDIF} + end; + + OP_ANY_ML: + begin + if (regInput >= fInputCurrentEnd) or + IsPairedBreak(regInput) or + IsCustomLineSeparator(regInput^) then Exit; - Inc(reginput); + {$IFDEF UNICODEEX} + IncUnicode(regInput); + {$ELSE} + Inc(regInput); + {$ENDIF} end; + OP_ANYDIGIT: begin - if (reginput = fInputEnd) or not IsDigitChar(reginput^) then + if (regInput >= fInputCurrentEnd) or not IsDigitChar(regInput^) then Exit; - Inc(reginput); + Inc(regInput); end; + OP_NOTDIGIT: begin - if (reginput = fInputEnd) or IsDigitChar(reginput^) then + if (regInput >= fInputCurrentEnd) or IsDigitChar(regInput^) then Exit; - Inc(reginput); + {$IFDEF UNICODEEX} + IncUnicode(regInput); + {$ELSE} + Inc(regInput); + {$ENDIF} end; + OP_ANYLETTER: begin - if (reginput = fInputEnd) or not IsWordChar(reginput^) // ###0.943 - then + if (regInput >= fInputCurrentEnd) or not IsWordChar(regInput^) then Exit; - Inc(reginput); + Inc(regInput); end; + OP_NOTLETTER: begin - if (reginput = fInputEnd) or IsWordChar(reginput^) // ###0.943 - then + if (regInput >= fInputCurrentEnd) or IsWordChar(regInput^) then Exit; - Inc(reginput); + {$IFDEF UNICODEEX} + IncUnicode(regInput); + {$ELSE} + Inc(regInput); + {$ENDIF} end; + OP_ANYSPACE: begin - if (reginput = fInputEnd) or not IsSpaceChar(reginput^) // ###0.943 - then + if (regInput >= fInputCurrentEnd) or not IsSpaceChar(regInput^) then Exit; - Inc(reginput); + Inc(regInput); end; + OP_NOTSPACE: begin - if (reginput = fInputEnd) or IsSpaceChar(reginput^) // ###0.943 - then + if (regInput >= fInputCurrentEnd) or IsSpaceChar(regInput^) then Exit; - Inc(reginput); + {$IFDEF UNICODEEX} + IncUnicode(regInput); + {$ELSE} + Inc(regInput); + {$ENDIF} end; + OP_ANYVERTSEP: begin - if (reginput = fInputEnd) or not IsLineSeparator(reginput^) then + if (regInput >= fInputCurrentEnd) or not IsVertLineSeparator(regInput^) then Exit; - Inc(reginput); + Inc(regInput); end; + OP_NOTVERTSEP: begin - if (reginput = fInputEnd) or IsLineSeparator(reginput^) then + if (regInput >= fInputCurrentEnd) or IsVertLineSeparator(regInput^) then Exit; - Inc(reginput); + {$IFDEF UNICODEEX} + IncUnicode(regInput); + {$ELSE} + Inc(regInput); + {$ENDIF} end; + OP_ANYHORZSEP: begin - if (reginput = fInputEnd) or not IsHorzSeparator(reginput^) then + if (regInput >= fInputCurrentEnd) or not IsHorzSeparator(regInput^) then Exit; - Inc(reginput); + Inc(regInput); end; + OP_NOTHORZSEP: begin - if (reginput = fInputEnd) or IsHorzSeparator(reginput^) then + if (regInput >= fInputCurrentEnd) or IsHorzSeparator(regInput^) then Exit; - Inc(reginput); + {$IFDEF UNICODEEX} + IncUnicode(regInput); + {$ELSE} + Inc(regInput); + {$ENDIF} end; - OP_EXACTLYCI: + + OP_EXACTLY_CI: begin opnd := scan + REOpSz + RENextOffSz; // OPERAND Len := PLongInt(opnd)^; + if (regInput + Len > fInputCurrentEnd) then + Exit; Inc(opnd, RENumberSz); // Inline the first character, for speed. - if (opnd^ <> reginput^) and (InvertCase(opnd^) <> reginput^) then + if (opnd^ <> regInput^) and (_LowerCase(opnd^) <> regInput^) then Exit; - // ###0.929 begin no := Len; - save := reginput; + save := regInput; while no > 1 do begin Inc(save); Inc(opnd); - if (opnd^ <> save^) and (InvertCase(opnd^) <> save^) then + if (opnd^ <> save^) and (_LowerCase(opnd^) <> save^) then Exit; Dec(no); end; - // ###0.929 end - Inc(reginput, Len); + Inc(regInput, Len); end; + OP_EXACTLY: begin opnd := scan + REOpSz + RENextOffSz; // OPERAND Len := PLongInt(opnd)^; + if (regInput + Len > fInputCurrentEnd) then + Exit; Inc(opnd, RENumberSz); // Inline the first character, for speed. - if opnd^ <> reginput^ then + if opnd^ <> regInput^ then Exit; - // ###0.929 begin no := Len; - save := reginput; + save := regInput; while no > 1 do begin Inc(save); @@ -3877,275 +5746,579 @@ function TRegExpr.MatchPrim(prog: PRegExprChar): boolean; Exit; Dec(no); end; - // ###0.929 end - Inc(reginput, Len); + Inc(regInput, Len); end; + OP_BSUBEXP: - begin // ###0.936 - no := Ord((scan + REOpSz + RENextOffSz)^); + begin + no := PReGroupIndex((scan + REOpSz + RENextOffSz))^; no := GrpIndexes[no]; if no < 0 then Exit; - if startp[no] = nil then + opnd := GrpBounds[regRecursion].GrpStart[no]; + if opnd = nil then Exit; - if endp[no] = nil then + opGrpEnd := GrpBounds[regRecursion].GrpEnd[no]; + if opGrpEnd = nil then Exit; - save := reginput; - opnd := startp[no]; - while opnd < endp[no] do + save := regInput; + while opnd < opGrpEnd do begin - if (save >= fInputEnd) or (save^ <> opnd^) then + if (save >= fInputCurrentEnd) or (save^ <> opnd^) then Exit; Inc(save); Inc(opnd); end; - reginput := save; + regInput := save; end; - OP_BSUBEXPCI: - begin // ###0.936 - no := Ord((scan + REOpSz + RENextOffSz)^); + + OP_BSUBEXP_CI: + begin + no := PReGroupIndex((scan + REOpSz + RENextOffSz))^; no := GrpIndexes[no]; if no < 0 then Exit; - if startp[no] = nil then + opnd := GrpBounds[regRecursion].GrpStart[no]; + if opnd = nil then Exit; - if endp[no] = nil then + opGrpEnd := GrpBounds[regRecursion].GrpEnd[no]; + if opGrpEnd = nil then Exit; - save := reginput; - opnd := startp[no]; - while opnd < endp[no] do + save := regInput; + while opnd < opGrpEnd do begin - if (save >= fInputEnd) or + if (save >= fInputCurrentEnd) or ((save^ <> opnd^) and (save^ <> InvertCase(opnd^))) then Exit; Inc(save); Inc(opnd); end; - reginput := save; + regInput := save; end; + OP_ANYOF: begin - if (reginput = fInputEnd) or - not FindInCharClass(scan + REOpSz + RENextOffSz, reginput^, False) then + if (regInput >= fInputCurrentEnd) or + not FindInCharClass(scan + REOpSz + RENextOffSz, regInput^, False) then Exit; - Inc(reginput); + {$IFDEF UNICODEEX} + IncUnicode(regInput); + {$ELSE} + Inc(regInput); + {$ENDIF} end; + OP_ANYBUT: begin - if (reginput = fInputEnd) or - FindInCharClass(scan + REOpSz + RENextOffSz, reginput^, False) then + if (regInput >= fInputCurrentEnd) or + FindInCharClass(scan + REOpSz + RENextOffSz, regInput^, False) then Exit; - Inc(reginput); + {$IFDEF UNICODEEX} + IncUnicode(regInput); + {$ELSE} + Inc(regInput); + {$ENDIF} end; - OP_ANYOFCI: + + OP_ANYOF_CI: begin - if (reginput = fInputEnd) or - not FindInCharClass(scan + REOpSz + RENextOffSz, reginput^, True) then + if (regInput >= fInputCurrentEnd) or + not FindInCharClass(scan + REOpSz + RENextOffSz, regInput^, True) then Exit; - Inc(reginput); + {$IFDEF UNICODEEX} + IncUnicode(regInput); + {$ELSE} + Inc(regInput); + {$ENDIF} end; - OP_ANYBUTCI: + + OP_ANYBUT_CI: begin - if (reginput = fInputEnd) or - FindInCharClass(scan + REOpSz + RENextOffSz, reginput^, True) then + if (regInput >= fInputCurrentEnd) or + FindInCharClass(scan + REOpSz + RENextOffSz, regInput^, True) then Exit; - Inc(reginput); + {$IFDEF UNICODEEX} + IncUnicode(regInput); + {$ELSE} + Inc(regInput); + {$ENDIF} end; + OP_NOTHING: ; OP_COMMENT: ; OP_BACK: ; - Succ(OP_OPEN) .. TREOp(Ord(OP_OPEN) + NSUBEXP - 1): - begin // ###0.929 - no := Ord(scan^) - Ord(OP_OPEN); - // save := reginput; - save := startp[no]; // ###0.936 - startp[no] := reginput; // ###0.936 + + OP_OPEN, OP_OPEN_ATOMIC: + begin + no := PReGroupIndex((scan + REOpSz + RENextOffSz))^; + save := GrpBounds[regRecursion].GrpStart[no]; + opnd := GrpBounds[regRecursion].GrpEnd[no]; // save2 + GrpBounds[regRecursion].GrpStart[no] := regInput; 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. + if GrpBacktrackingAsAtom[no] then + IsBacktrackingGroupAsAtom := False; + GrpBacktrackingAsAtom[no] := False; + if not Result then begin + GrpBounds[regRecursion].GrpStart[no] := save; + GrpBounds[regRecursion].GrpEnd[no] := opnd; + end; Exit; end; - Succ(OP_CLOSE) .. TREOp(Ord(OP_CLOSE) + NSUBEXP - 1): - begin // ###0.929 - no := Ord(scan^) - Ord(OP_CLOSE); - // save := reginput; - save := endp[no]; // ###0.936 - endp[no] := reginput; // ###0.936 + + OP_CLOSE: + begin + no := PReGroupIndex((scan + REOpSz + RENextOffSz))^; + // handle atomic group, mark it as "done" + // (we are here because some OP_BRANCH is matched) + GrpBounds[regRecursion].GrpEnd[no] := regInput; + + // if we are in OP_SUBCALL* call, it called OP_OPEN*, so we must return + // in OP_CLOSE, without going to next opcode + if CurrentSubCalled = no then + begin + Result := True; + Exit; + end; + end; + + OP_CLOSE_ATOMIC: + begin + no := PReGroupIndex((scan + REOpSz + RENextOffSz))^; + // handle atomic group, mark it as "done" + // (we are here because some OP_BRANCH is matched) + GrpBounds[regRecursion].GrpEnd[no] := regInput; + 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. + if not Result then begin + if not IsBacktrackingGroupAsAtom then begin + GrpBacktrackingAsAtom[no] := True; + IsBacktrackingGroupAsAtom := True; + end; + end; Exit; end; - OP_BRANCH: + + OP_LOOKAHEAD, OP_LOOKAHEAD_NEG: begin - if (next^ <> OP_BRANCH) // No choice. - then - next := scan + REOpSz + RENextOffSz // Avoid recursion + Local.IsNegativeLook := (scan^ = OP_LOOKAHEAD_NEG); + + Local.LookAroundInfo.InputPos := regInput; + Local.LookAroundInfo.IsNegative := Local.IsNegativeLook; + Local.LookAroundInfo.HasMatchedToEnd := False; + Local.LookAroundInfo.IsBackTracking := False; + Local.LookAroundInfo.OuterInfo := LookAroundInfoList; + Local.LookAroundInfo.savedInputCurrentEnd := fInputCurrentEnd; + LookAroundInfoList := @Local.LookAroundInfo; + fInputCurrentEnd := fInputEnd; + + scan := PRegExprChar(AlignToPtr(scan + 1)) + RENextOffSz; + Result := MatchPrim(scan); + + if Local.LookAroundInfo.IsBackTracking then + IsBacktrackingGroupAsAtom := False; + LookAroundInfoList := Local.LookAroundInfo.OuterInfo; + fInputCurrentEnd := Local.LookAroundInfo.savedInputCurrentEnd; + + opnd := PRegExprChar(AlignToPtr(next + 1)) + RENextOffSz; // Successor of OP_LOOKAHEAD_END; + if Local.IsNegativeLook then begin + Result := (opnd^ = OP_LOOKAROUND_OPTIONAL); + if not Result then + Result := (not Local.LookAroundInfo.HasMatchedToEnd); + if Result then begin + next := regNextQuick(next); // Next-Pointer of OP_LOOKAHEAD_END + if (next^ = OP_LOOKAROUND_OPTIONAL) then + next := PRegExprChar(AlignToPtr(next + 1)) + RENextOffSz; + regInput := Local.LookAroundInfo.InputPos; + Result := False; + scan := next; + continue; + end; + end else - begin - repeat - save := reginput; - Result := MatchPrim(scan + REOpSz + RENextOffSz); - if Result then - Exit; - reginput := save; - scan := regnext(scan); - until (scan = nil) or (scan^ <> OP_BRANCH); - Exit; + if (opnd^ = OP_LOOKAROUND_OPTIONAL) then begin + if not Local.LookAroundInfo.HasMatchedToEnd then begin + next := regNextQuick(next); // Next-Pointer of OP_LOOKAHEAD_END + if (next^ = OP_LOOKAROUND_OPTIONAL) then + next := PRegExprChar(AlignToPtr(next + 1)) + RENextOffSz; + regInput := Local.LookAroundInfo.InputPos; + Result := False; + scan := next; + continue; + end; end; + + if not Result then + regInput := Local.LookAroundInfo.InputPos; + + Exit; end; - {$IFDEF ComplexBraces} - OP_LOOPENTRY: - begin // ###0.925 - no := LoopStackIdx; - Inc(LoopStackIdx); - if LoopStackIdx > LoopStackMax then - begin - Error(reeLoopStackExceeded); + + OP_LOOKBEHIND, OP_LOOKBEHIND_NEG: + begin + Local.IsNegativeLook := (scan^ = OP_LOOKBEHIND_NEG); + scan := PRegExprChar(AlignToPtr(scan + 1)) + RENextOffSz; + Local.IsGreedy := PReOpLookBehindOptions(scan)^.IsGreedy; + + Local.LookAroundInfo.InputPos := regInput; + Local.LookAroundInfo.IsNegative := Local.IsNegativeLook; + Local.LookAroundInfo.HasMatchedToEnd := False; + Local.LookAroundInfo.IsBackTracking := False; + Local.LookAroundInfo.OuterInfo := LookAroundInfoList; + Local.LookAroundInfo.savedInputCurrentEnd := fInputCurrentEnd; + LookAroundInfoList := @Local.LookAroundInfo; + fInputCurrentEnd := regInput; + + Result := regInput - fInputStart >= PReOpLookBehindOptions(scan)^.MatchLenMin; + if Result then begin + if Local.IsGreedy = OPT_LOOKBEHIND_FIXED then begin + regInput := regInput - PReOpLookBehindOptions(scan)^.MatchLenMin; + inc(scan, ReOpLookBehindOptionsSz); + Result := MatchPrim(scan) + end + else + if Local.IsGreedy = OPT_LOOKBEHIND_NON_GREEDY then begin + Local.InpStart := regInput - PReOpLookBehindOptions(scan)^.MatchLenMin; + if regInput - fInputStart >= PReOpLookBehindOptions(scan)^.MatchLenMax then + save := regInput - PReOpLookBehindOptions(scan)^.MatchLenMax + else + save := fInputStart; + inc(scan, ReOpLookBehindOptionsSz); + repeat + regInput := Local.InpStart; + dec(Local.InpStart); + Result := MatchPrim(scan); + until Local.LookAroundInfo.HasMatchedToEnd or (Local.InpStart < save); + end + else begin + if regInput - fInputStart >= PReOpLookBehindOptions(scan)^.MatchLenMax then + Local.InpStart := regInput - PReOpLookBehindOptions(scan)^.MatchLenMax + else + Local.InpStart := fInputStart; + save := Local.LookAroundInfo.InputPos - PReOpLookBehindOptions(scan)^.MatchLenMin; + inc(scan, ReOpLookBehindOptionsSz); + repeat + regInput := Local.InpStart; + inc(Local.InpStart); + Result := MatchPrim(scan); + until Local.LookAroundInfo.HasMatchedToEnd or (Local.InpStart > save); + end; + end; + + if Local.LookAroundInfo.IsBackTracking then + IsBacktrackingGroupAsAtom := False; + LookAroundInfoList := Local.LookAroundInfo.OuterInfo; + fInputCurrentEnd := Local.LookAroundInfo.savedInputCurrentEnd; + + opnd := PRegExprChar(AlignToPtr(next + 1)) + RENextOffSz; // Successor of OP_LOOKAHEAD_END; + if Local.IsNegativeLook then begin + Result := (opnd^ = OP_LOOKAROUND_OPTIONAL); + if not Result then + Result := not Local.LookAroundInfo.HasMatchedToEnd; + if Result then begin + next := regNextQuick(next); // Next-Pointer of OP_LOOKAHEAD_END + if (next^ = OP_LOOKAROUND_OPTIONAL) then + next := PRegExprChar(AlignToPtr(next + 1)) + RENextOffSz; + regInput := Local.LookAroundInfo.InputPos; + Result := False; + scan := next; + continue; + end; + end + else + if (opnd^ = OP_LOOKAROUND_OPTIONAL) then begin + if not Local.LookAroundInfo.HasMatchedToEnd then begin + next := regNextQuick(next); // Next-Pointer of OP_LOOKAHEAD_END + if (next^ = OP_LOOKAROUND_OPTIONAL) then + next := PRegExprChar(AlignToPtr(next + 1)) + RENextOffSz; + regInput := Local.LookAroundInfo.InputPos; + Result := False; + scan := next; + continue; + end; + end; + + if not Result then + regInput := Local.LookAroundInfo.InputPos; + Exit; + end; + + OP_LOOKAHEAD_END: + begin + if LookAroundInfoList = nil then Exit; + Local.LookAroundInfoPtr := LookAroundInfoList; + Local.LookAroundInfoPtr.HasMatchedToEnd := True; + + if not Local.LookAroundInfoPtr^.IsNegative then begin + fInputCurrentEnd := Local.LookAroundInfoPtr^.savedInputCurrentEnd; + regInput := Local.LookAroundInfoPtr^.InputPos; + LookAroundInfoList := Local.LookAroundInfoPtr^.OuterInfo; + + if (next^ = OP_LOOKAROUND_OPTIONAL) then + next := PRegExprChar(AlignToPtr(next + 1)) + RENextOffSz; + Result := MatchPrim(next); + LookAroundInfoList := Local.LookAroundInfoPtr; end; - save := reginput; - LoopStack[LoopStackIdx] := 0; // init loop counter - Result := MatchPrim(next); // execute loop - LoopStackIdx := no; // cleanup - if Result then + + if (not Result) and not IsBacktrackingGroupAsAtom then begin + IsBacktrackingGroupAsAtom := True; + Local.LookAroundInfoPtr.IsBackTracking := True; + end; + Exit; + end; + + OP_LOOKBEHIND_END: + begin + if LookAroundInfoList = nil then + Exit; + + Local.LookAroundInfoPtr := LookAroundInfoList; + if not (Local.LookAroundInfoPtr^.InputPos = regInput) then Exit; - reginput := save; + + Local.LookAroundInfoPtr.HasMatchedToEnd := True; + + if not Local.LookAroundInfoPtr^.IsNegative then begin + regInput := Local.LookAroundInfoPtr^.InputPos; + fInputCurrentEnd := Local.LookAroundInfoPtr^.savedInputCurrentEnd; + LookAroundInfoList := Local.LookAroundInfoPtr^.OuterInfo; + + if (next^ = OP_LOOKAROUND_OPTIONAL) then + next := PRegExprChar(AlignToPtr(next + 1)) + RENextOffSz; + Result := MatchPrim(next); + LookAroundInfoList := Local.LookAroundInfoPtr; + end; + + if (not Result) and not IsBacktrackingGroupAsAtom then begin + IsBacktrackingGroupAsAtom := True; + Local.LookAroundInfoPtr.IsBackTracking := True; + end; + Exit; + end; + + OP_BRANCH: + begin + repeat + save := regInput; + Result := MatchPrim(scan + REOpSz + RENextOffSz + REBranchArgSz); + if Result then + Exit; + // if branch worked until OP_CLOSE, and marked atomic group as "done", then exit + regInput := save; + if IsBacktrackingGroupAsAtom then + Exit; + scan := next; + Assert(scan <> nil); + next := regNextQuick(scan); + if (next^ <> OP_BRANCH) then + break; + until False; + next := scan + REOpSz + RENextOffSz + REBranchArgSz; // Avoid recursion + end; + + OP_GBRANCH, OP_GBRANCH_EX, OP_GBRANCH_EX_CI: + begin + Assert((next^ = OP_BRANCH) or (next^ = OP_GBRANCH) or (next^ = OP_GBRANCH_EX) or (next^ = OP_GBRANCH_EX_CI)); + repeat + save := regInput; + case scan^ of + OP_GBRANCH, OP_BRANCH: + Result := MatchPrim(scan + REOpSz + RENextOffSz + REBranchArgSz); + OP_GBRANCH_EX: + if (regInput^ = (scan + REOpSz + RENextOffSz)^) then + Result := MatchPrim(scan + REOpSz + RENextOffSz + REBranchArgSz); + OP_GBRANCH_EX_CI: + if (regInput^ = (scan + REOpSz + RENextOffSz)^) or + (regInput^ = (scan + REOpSz + RENextOffSz + 1)^) + then + Result := MatchPrim(scan + REOpSz + RENextOffSz + REBranchArgSz); + end; + if Result then + Exit; + // if branch worked until OP_CLOSE, and marked atomic group as "done", then exit + regInput := save; + if IsBacktrackingGroupAsAtom then + Exit; + scan := next; + Assert(scan <> nil); + next := regNextQuick(scan); + if (next^ <> OP_BRANCH) and (next^ <> OP_GBRANCH) and (next^ <> OP_GBRANCH_EX) and (next^ <> OP_GBRANCH_EX_CI) then + break; + until False; + case scan^ of + OP_GBRANCH_EX: + if (regInput^ <> (scan + REOpSz + RENextOffSz)^) then + exit; + OP_GBRANCH_EX_CI: + if (regInput^ <> (scan + REOpSz + RENextOffSz)^) and + (regInput^ <> (scan + REOpSz + RENextOffSz + 1)^) + then + exit; + end; + next := scan + REOpSz + RENextOffSz + REBranchArgSz; // Avoid recursion + end; + + {$IFDEF ComplexBraces} + OP_LOOPENTRY: + begin + Local.LoopInfo.Count := 0; + Local.LoopInfo.BackTrackingAsAtom := False; + Local.LoopInfo.CurrentRegInput := nil; + Local.LoopInfo.OuterLoop := CurrentLoopInfoListPtr; + CurrentLoopInfoListPtr := @Local.LoopInfo; + save := regInput; + Result := MatchPrim(next); // execute loop + CurrentLoopInfoListPtr := Local.LoopInfo.OuterLoop; + if Local.LoopInfo.BackTrackingAsAtom then + IsBacktrackingGroupAsAtom := False; + if not Result then + regInput := save; Exit; end; - OP_LOOP, OP_LOOPNG: - begin // ###0.940 - if LoopStackIdx <= 0 then - begin + + OP_LOOP, OP_LOOP_NG, OP_LOOP_POSS: + begin + if CurrentLoopInfoListPtr = nil then begin Error(reeLoopWithoutEntry); Exit; end; opnd := scan + PRENextOff(AlignToPtr(scan + REOpSz + RENextOffSz + 2 * REBracesArgSz))^; BracesMin := PREBracesArg(AlignToInt(scan + REOpSz + RENextOffSz))^; - Bracesmax := PREBracesArg(AlignToPtr(scan + REOpSz + RENextOffSz + REBracesArgSz))^; - save := reginput; - if LoopStack[LoopStackIdx] >= BracesMin then + BracesMax := PREBracesArg(AlignToPtr(scan + REOpSz + RENextOffSz + REBracesArgSz))^; + save := regInput; + Local.LoopInfoListPtr := CurrentLoopInfoListPtr; + if Local.LoopInfoListPtr^.Count >= BracesMin then begin // Min alredy matched - we can work - if scan^ = OP_LOOP then + Result := (BracesMax = MaxBracesArg) and // * or + + (Local.LoopInfoListPtr^.CurrentRegInput = regInput); + if Result then begin + CurrentLoopInfoListPtr := Local.LoopInfoListPtr^.OuterLoop; + Result := MatchPrim(next); + CurrentLoopInfoListPtr := Local.LoopInfoListPtr; + if not Result then + regInput := save; + exit; + end; + + Local.LoopInfoListPtr^.CurrentRegInput := regInput; + if not (scan^ = OP_LOOP_NG) then begin // greedy way - first try to max deep of greed ;) - if LoopStack[LoopStackIdx] < Bracesmax then + if Local.LoopInfoListPtr^.Count < BracesMax then begin - Inc(LoopStack[LoopStackIdx]); - no := LoopStackIdx; + Inc(Local.LoopInfoListPtr^.Count); Result := MatchPrim(opnd); - LoopStackIdx := no; if Result then Exit; - reginput := save; + if IsBacktrackingGroupAsAtom then + Exit; + Dec(Local.LoopInfoListPtr^.Count); + regInput := save; end; - Dec(LoopStackIdx); // Fail. May be we are too greedy? ;) + CurrentLoopInfoListPtr := Local.LoopInfoListPtr^.OuterLoop; Result := MatchPrim(next); + CurrentLoopInfoListPtr := Local.LoopInfoListPtr; + + if IsBacktrackingGroupAsAtom then + Exit; + if (scan^ = OP_LOOP_POSS) and (not Result) then begin + Local.LoopInfoListPtr^.BackTrackingAsAtom := True; + IsBacktrackingGroupAsAtom := True; + exit; + end; if not Result then - reginput := save; + regInput := save; Exit; end else begin // non-greedy - try just now + CurrentLoopInfoListPtr := Local.LoopInfoListPtr^.OuterLoop; Result := MatchPrim(next); + CurrentLoopInfoListPtr := Local.LoopInfoListPtr; if Result then - Exit - else - reginput := save; // failed - move next and try again - if LoopStack[LoopStackIdx] < Bracesmax then + Exit; + if IsBacktrackingGroupAsAtom then + Exit; + regInput := save; // failed - move next and try again + if Local.LoopInfoListPtr^.Count < BracesMax then begin - Inc(LoopStack[LoopStackIdx]); - no := LoopStackIdx; + Inc(Local.LoopInfoListPtr^.Count); Result := MatchPrim(opnd); - LoopStackIdx := no; if Result then Exit; - reginput := save; + if IsBacktrackingGroupAsAtom then + Exit; + Dec(Local.LoopInfoListPtr^.Count); + regInput := save; end; - Dec(LoopStackIdx); // Failed - back up Exit; end end else begin // first match a min_cnt times - Inc(LoopStack[LoopStackIdx]); - no := LoopStackIdx; + Inc(Local.LoopInfoListPtr^.Count); + Local.LoopInfoListPtr^.CurrentRegInput := regInput; Result := MatchPrim(opnd); - LoopStackIdx := no; if Result then Exit; - Dec(LoopStack[LoopStackIdx]); - reginput := save; + if IsBacktrackingGroupAsAtom then + Exit; + Dec(Local.LoopInfoListPtr^.Count); + regInput := save; Exit; end; end; {$ENDIF} - OP_STAR, OP_PLUS, OP_BRACES, OP_STARNG, OP_PLUSNG, OP_BRACESNG: + + OP_STAR, OP_PLUS, OP_BRACES, OP_STAR_NG, OP_PLUS_NG, OP_BRACES_NG: begin // Lookahead to avoid useless match attempts when we know // what character comes next. nextch := #0; if next^ = OP_EXACTLY then nextch := (next + REOpSz + RENextOffSz + RENumberSz)^; - Bracesmax := MaxInt; // infinite loop for * and + //###0.92 - if (scan^ = OP_STAR) or (scan^ = OP_STARNG) then + BracesMax := MaxInt; // infinite loop for * and + + if (scan^ = OP_STAR) or (scan^ = OP_STAR_NG) then BracesMin := 0 // star - else if (scan^ = OP_PLUS) or (scan^ = OP_PLUSNG) then + else if (scan^ = OP_PLUS) or (scan^ = OP_PLUS_NG) then BracesMin := 1 // plus else begin // braces BracesMin := PREBracesArg(AlignToPtr(scan + REOpSz + RENextOffSz))^; - Bracesmax := PREBracesArg(AlignToPtr(scan + REOpSz + RENextOffSz + REBracesArgSz))^; + BracesMax := PREBracesArg(AlignToPtr(scan + REOpSz + RENextOffSz + REBracesArgSz))^; end; - save := reginput; + save := regInput; opnd := scan + REOpSz + RENextOffSz; - if (scan^ = OP_BRACES) or (scan^ = OP_BRACESNG) then + if (scan^ = OP_BRACES) or (scan^ = OP_BRACES_NG) then Inc(opnd, 2 * REBracesArgSz); - if (scan^ = OP_PLUSNG) or (scan^ = OP_STARNG) or (scan^ = OP_BRACESNG) then + if (scan^ = OP_PLUS_NG) or (scan^ = OP_STAR_NG) or (scan^ = OP_BRACES_NG) then begin // non-greedy mode - Bracesmax := regrepeat(opnd, Bracesmax); + BracesMax := FindRepeated(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 + while no <= BracesMax do begin - reginput := save + no; + regInput := save + no; // If it could work, try it. - if (nextch = #0) or (reginput^ = nextch) then + 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} + if IsBacktrackingGroupAsAtom then + Exit; end; Inc(no); // Couldn't or didn't - move forward. end; { of while } @@ -4153,122 +6326,286 @@ function TRegExpr.MatchPrim(prog: PRegExprChar): boolean; end else begin // greedy mode - no := regrepeat(opnd, Bracesmax); // don't repeat more than max_cnt + no := FindRepeated(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 + 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} + if IsBacktrackingGroupAsAtom then + Exit; end; Dec(no); // Couldn't or didn't - back up. - reginput := save + no; + regInput := save + no; end; { of while } Exit; end; end; + + OP_STAR_POSS, OP_PLUS_POSS, OP_BRACES_POSS: + begin + // Lookahead to avoid useless match attempts when we know + // what character comes next. + nextch := #0; + if next^ = OP_EXACTLY then + nextch := (next + REOpSz + RENextOffSz + RENumberSz)^; + opnd := scan + REOpSz + RENextOffSz; + case scan^ of + OP_STAR_POSS: + begin + BracesMin := 0; + BracesMax := MaxInt; + end; + OP_PLUS_POSS: + begin + BracesMin := 1; + BracesMax := MaxInt; + end; + else + begin // braces + BracesMin := PREBracesArg(AlignToPtr(scan + REOpSz + RENextOffSz))^; + BracesMax := PREBracesArg(AlignToPtr(scan + REOpSz + RENextOffSz + REBracesArgSz))^; + Inc(opnd, 2 * REBracesArgSz); + end; + end; + no := FindRepeated(opnd, BracesMax); + if no >= BracesMin then + if (nextch = #0) or (regInput^ = nextch) then begin + scan := next; + continue; + end; + Exit; + end; + OP_EEND: begin Result := True; // Success! Exit; end; + + {$IFDEF FastUnicodeData} + OP_ANYCATEGORY: + begin + if (regInput >= fInputCurrentEnd) then Exit; + if not MatchOneCharCategory(scan + REOpSz + RENextOffSz, regInput) then Exit; + {$IFDEF UNICODEEX} + IncUnicode(regInput); + {$ELSE} + Inc(regInput); + {$ENDIF} + end; + + OP_NOTCATEGORY: + begin + if (regInput >= fInputCurrentEnd) then Exit; + if MatchOneCharCategory(scan + REOpSz + RENextOffSz, regInput) then Exit; + {$IFDEF UNICODEEX} + IncUnicode(regInput); + {$ELSE} + Inc(regInput); + {$ENDIF} + end; + {$ENDIF} + + OP_RECUR: + begin + // call opcode start + if regRecursion < RegexMaxRecursion then + begin + Inc(regRecursion); + FillChar(GrpBounds[regRecursion].GrpStart[0], SizeOf(GrpBounds[regRecursion].GrpStart[0])*regNumBrackets, 0); + bound1 := MatchPrim(regCodeWork); + Dec(regRecursion); + end + else + bound1 := False; + if not bound1 then Exit; + end; + + OP_SUBCALL: + begin + // call subroutine + no := PReGroupIndex((scan + REOpSz + RENextOffSz))^; + no := GrpIndexes[no]; + if no < 0 then Exit; + save := GrpOpCodes[no]; + if save = nil then Exit; + if regRecursion < RegexMaxRecursion then + begin + Local.savedCurrentSubCalled := CurrentSubCalled; + CurrentSubCalled := no; + Inc(regRecursion); + FillChar(GrpBounds[regRecursion].GrpStart[0], SizeOf(GrpBounds[regRecursion].GrpStart[0])*regNumBrackets, 0); + bound1 := MatchPrim(save); + Dec(regRecursion); + CurrentSubCalled := Local.savedCurrentSubCalled; + end + else + bound1 := False; + if not bound1 then Exit; + end; + + OP_ANYLINEBREAK: + begin + if (regInput >= fInputCurrentEnd) or not IsAnyLineBreak(regInput^) then + Exit; + nextch := regInput^; + Inc(regInput); + if (nextch = #13) and (regInput < fInputCurrentEnd) and (regInput^ = #10) then + Inc(regInput); + end; + + {$IFDEF WITH_REGEX_ASSERT} else - begin - Error(reeMatchPrimMemoryCorruption); - Exit; - end; + Error(reeMatchPrimMemoryCorruption); + Exit; + {$ENDIF} 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 -------------------------------------------------------------- } -function TRegExpr.Exec(const AInputString: RegExprString): boolean; +function TRegExpr.Exec(const AInputString: RegExprString): Boolean; begin InputString := AInputString; - Result := ExecPrim(1, False, False); + Result := ExecPrim(1, False, False, 0); end; { of function TRegExpr.Exec -------------------------------------------------------------- } {$IFDEF OverMeth} -function TRegExpr.Exec: boolean; +function TRegExpr.Exec: Boolean; var - SlowChecks: boolean; + SlowChecks: Boolean; begin - SlowChecks := Length(fInputString) < fSlowChecksSizeMax; - Result := ExecPrim(1, False, SlowChecks); + SlowChecks := fInputEnd - fInputStart < fSlowChecksSizeMax; + Result := ExecPrim(1, SlowChecks, False, 0); end; { of function TRegExpr.Exec -------------------------------------------------------------- } -function TRegExpr.Exec(AOffset: integer): boolean; +function TRegExpr.Exec(AOffset: Integer): Boolean; begin - Result := ExecPrim(AOffset, False, False); + Result := ExecPrim(AOffset, False, False, 0); end; { of function TRegExpr.Exec -------------------------------------------------------------- } {$ENDIF} -function TRegExpr.ExecPos(AOffset: integer {$IFDEF DefParam} = 1{$ENDIF}): boolean; +function TRegExpr.ExecPos(AOffset: Integer {$IFDEF DefParam} = 1{$ENDIF}): Boolean; begin - Result := ExecPrim(AOffset, False, False); + Result := ExecPrim(AOffset, False, False, 0); end; { of function TRegExpr.ExecPos -------------------------------------------------------------- } {$IFDEF OverMeth} -function TRegExpr.ExecPos(AOffset: integer; ATryOnce: boolean): boolean; +function TRegExpr.ExecPos(AOffset: Integer; ATryOnce, ABackward: Boolean): Boolean; begin - Result := ExecPrim(AOffset, ATryOnce, False); + if ATryOnce then + Result := ExecPrim(AOffset, False, ABackward, AOffset + 1) + else + Result := ExecPrim(AOffset, False, ABackward, 0); +end; + +function TRegExpr.ExecPos(AOffset, ATryMatchOnlyStartingBefore: Integer): Boolean; +begin + Result := ExecPrim(AOffset, False, False, ATryMatchOnlyStartingBefore); end; {$ENDIF} -function TRegExpr.MatchAtOnePos(APos: PRegExprChar): boolean; +function TRegExpr.MatchAtOnePos(APos: PRegExprChar): Boolean; begin - reginput := APos; - Result := MatchPrim(programm + REOpSz); + regInput := APos; + //regNestedCalls := 0; + fInputCurrentEnd := fInputEnd; + GrpBounds[0].GrpStart[0] := APos; + Result := MatchPrim(regCodeWork); if Result then - begin - startp[0] := APos; - endp[0] := reginput; - end; + Result := regInput >= GrpBounds[0].GrpStart[0]; + if Result then + GrpBounds[0].GrpEnd[0] := regInput + else + GrpBounds[0].GrpStart[0] := nil; end; procedure TRegExpr.ClearMatches; begin - FillChar(startp, SizeOf(startp), 0); - FillChar(endp, SizeOf(endp), 0); + if FMatchesCleared then + exit; + FMatchesCleared := True; + if Length(GrpBounds[0].GrpStart) > 0 then + FillChar(GrpBounds[0].GrpStart[0], SizeOf(GrpBounds[0].GrpStart[0])*regNumBrackets, 0); end; -procedure TRegExpr.ClearInternalIndexes; +procedure TRegExpr.ClearInternalExecData; +begin + fLastError := reeOk; + FillChar(GrpBacktrackingAsAtom[0], SizeOf(GrpBacktrackingAsAtom[0])*regNumBrackets, 0); + IsBacktrackingGroupAsAtom := False; + {$IFDEF ComplexBraces} + // no loops started + CurrentLoopInfoListPtr := nil; + {$ENDIF} + LookAroundInfoList := nil; + CurrentSubCalled := -1; + regRecursion := 0; +end; + +procedure TRegExpr.InitInternalGroupData; var - i: integer; + BndLen, i: Integer; begin - FillChar(startp, SizeOf(startp), 0); - FillChar(endp, SizeOf(endp), 0); - for i := 0 to NSUBEXP - 1 do + BndLen := GroupDataArraySize(regNumBrackets, Length(GrpBounds[0].GrpStart)); + for i := low(GrpBounds) to high(GrpBounds) do begin + SetLength(GrpBounds[i].GrpStart, BndLen); + SetLength(GrpBounds[i].GrpEnd, BndLen); + end; + + SetLength(GrpIndexes, GroupDataArraySize(regNumBrackets, Length(GrpIndexes))); + for i := 1 to regNumBrackets - 1 do GrpIndexes[i] := -1; GrpIndexes[0] := 0; - GrpCount := 0; + + SetLength(GrpOpCodes, GroupDataArraySize(regNumBrackets, Length(GrpOpCodes))); + SetLength(GrpBacktrackingAsAtom, GroupDataArraySize(regNumBrackets, Length(GrpBacktrackingAsAtom))); + + GrpOpCodes[0] := nil; +end; + +function TRegExpr.ExecPrim(AOffset: Integer; ASlowChecks, ABackward: Boolean; + ATryMatchOnlyStartingBefore: Integer): Boolean; +begin + if fRaiseForRuntimeError then begin + Result := ExecPrimProtected(AOffset, ASlowChecks, ABackward, ATryMatchOnlyStartingBefore); + end + else begin + try + Result := ExecPrimProtected(AOffset, ASlowChecks, ABackward, ATryMatchOnlyStartingBefore); + except + on E: EStackOverflow do begin + Result := False; + fLastError := reeLoopStackExceeded; + Error(reeLoopStackExceeded); + end; + on E: ERegExpr do begin + Result := False; + raise; + end; + else begin + fLastError := reeUnknown; + Error(reeUnknown); + end; + end; + end; end; -function TRegExpr.ExecPrim(AOffset: integer; ATryOnce, ASlowChecks: boolean): boolean; +function TRegExpr.ExecPrimProtected(AOffset: Integer; ASlowChecks, + ABackward: Boolean; ATryMatchOnlyStartingBefore: Integer): Boolean; var - Ptr: PRegExprChar; + Ptr, SearchEnd: PRegExprChar; begin Result := False; @@ -4285,11 +6622,11 @@ function TRegExpr.ExecPrim(AOffset: integer; ATryOnce, ASlowChecks: boolean): bo Exit; end; - // Check InputString presence - if fInputString = '' then + if fInputEnd = fInputStart then begin - //Error(reeNoInputStringSpecified); // better don't raise error, breaks some apps - Exit; + // Empty string can match e.g. '^$' + if regMustLen > 0 then + Exit; end; // Check that the start position is not negative @@ -4298,33 +6635,43 @@ function TRegExpr.ExecPrim(AOffset: integer; ATryOnce, ASlowChecks: boolean): bo Error(reeOffsetMustBePositive); Exit; end; + if (ATryMatchOnlyStartingBefore > 0) and (AOffset >= ATryMatchOnlyStartingBefore) then + Exit; // Check that the start position is not longer than the line - // If so then exit with nothing found - if AOffset > (Length(fInputString) + 1) // for matching empty string after last char. - then + if (AOffset - 1) > (fInputEnd - fInputStart) then Exit; + ClearInternalExecData; + Ptr := fInputStart + AOffset - 1; + fInputContinue := Ptr; // If there is a "must appear" string, look for it. if ASlowChecks then - if regmustString <> '' then - if Pos(regmustString, fInputString) = 0 then Exit; - - {$IFDEF ComplexBraces} - // no loops started - LoopStackIdx := 0; // ###0.925 + if regMustString <> '' then + if StrLPos(fInputStart, PRegExprChar(regMustString), fInputEnd - fInputStart, length(regMustString)) = nil then + exit; + + {$IFDEF RegExpWithStackOverflowCheck_DecStack_Frame} + StackLimit := StackBottom; + if StackLimit <> nil then + StackLimit := StackLimit + 36000; // Add for any calls within the current MatchPrim // FPC has "STACK_MARGIN = 16384;", but we need to call Error, ..., raise {$ENDIF} + FMatchesCleared := False; // ATryOnce or anchored match (it needs to be tried only once). - if ATryOnce or (reganchored <> #0) then + if (ATryMatchOnlyStartingBefore = AOffset + 1) or (regAnchored in [raBOL, raOnlyOnce, raContinue]) then begin + case regAnchored of + raBOL: if AOffset > 1 then Exit; // can't match the BOL + raEOL: Ptr := fInputEnd; + end; {$IFDEF UseFirstCharSet} - {$IFDEF UniCode} - if Ord(Ptr^) <= $FF then - {$ENDIF} - if not FirstCharArray[byte(Ptr^)] then + if (Ptr < fInputEnd) + {$IFDEF UnicodeRE} and (Ord(Ptr^) <= $FF) {$ENDIF} + then + if not FirstCharArray[Byte(Ptr^)] then Exit; {$ENDIF} @@ -4333,35 +6680,61 @@ function TRegExpr.ExecPrim(AOffset: integer; ATryOnce, ASlowChecks: boolean): bo end; // Messy cases: unanchored match. - Dec(Ptr); - repeat - Inc(Ptr); - if Ptr > fInputEnd then - Exit; + if ABackward then begin + Inc(Ptr, 2); + repeat + Dec(Ptr); + if Ptr < fInputStart then + Exit; - {$IFDEF UseFirstCharSet} - {$IFDEF UniCode} - if Ord(Ptr^) <= $FF then - {$ENDIF} - if not FirstCharArray[byte(Ptr^)] then - Continue; - {$ENDIF} + {$IFDEF UseFirstCharSet} + {$IFDEF UnicodeRE} + if Ord(Ptr^) <= $FF then + {$ENDIF} + if not FirstCharArray[byte(Ptr^)] then + Continue; + {$ENDIF} - Result := MatchAtOnePos(Ptr); - // Exit on a match or after testing the end-of-string - if Result then - Exit; - until False; + Result := MatchAtOnePos(Ptr); + // Exit on a match or after testing the end-of-string + if Result then + Exit; + until False; + end + else begin + Dec(Ptr); + SearchEnd := fInputEnd - FMinMatchLen; + if (ATryMatchOnlyStartingBefore > 0) and (fInputStart + ATryMatchOnlyStartingBefore < SearchEnd) then + SearchEnd := fInputStart + ATryMatchOnlyStartingBefore - 2; + repeat + Inc(Ptr); + if Ptr > SearchEnd then + Exit; + + {$IFDEF UseFirstCharSet} + {$IFDEF UnicodeRE} + if Ord(Ptr^) <= $FF then + {$ENDIF} + if not FirstCharArray[byte(Ptr^)] then + Continue; + {$ENDIF} + + Result := MatchAtOnePos(Ptr); + // Exit on a match or after testing the end-of-string + if Result then + Exit; + until False; + end; end; { of function TRegExpr.ExecPrim -------------------------------------------------------------- } -function TRegExpr.ExecNext: boolean; +function TRegExpr.ExecNext(ABackward: Boolean {$IFDEF DefParam} = False{$ENDIF}): Boolean; var PtrBegin, PtrEnd: PRegExprChar; Offset: PtrInt; begin - PtrBegin := startp[0]; - PtrEnd := endp[0]; + PtrBegin := GrpBounds[0].GrpStart[0]; + PtrEnd := GrpBounds[0].GrpEnd[0]; if (PtrBegin = nil) or (PtrEnd = nil) then begin Error(reeExecNextWithoutExec); @@ -4374,7 +6747,7 @@ function TRegExpr.ExecNext: boolean; if PtrBegin = PtrEnd then Inc(Offset); - Result := ExecPrim(Offset, False, False); + Result := ExecPrim(Offset, False, ABackward, 0); end; { of function TRegExpr.ExecNext -------------------------------------------------------------- } @@ -4383,13 +6756,23 @@ procedure TRegExpr.SetInputString(const AInputString: RegExprString); ClearMatches; fInputString := AInputString; - UniqueString(fInputString); + //UniqueString(fInputString); fInputStart := PRegExprChar(fInputString); fInputEnd := fInputStart + Length(fInputString); -end; { of procedure TRegExpr.SetInputString - -------------------------------------------------------------- } + fInputContinue := fInputStart; +end; + +procedure TRegExpr.SetInputRange(AStart, AEnd, AContinueAnchor: PRegExprChar); +begin + ClearMatches; + fInputString := ''; + fInputStart := AStart; + fInputEnd := AEnd; + fInputContinue := AContinueAnchor; +end; +{$IFDEF UseLineSep} procedure TRegExpr.SetLineSeparators(const AStr: RegExprString); begin if AStr <> fLineSeparators then @@ -4400,72 +6783,32 @@ procedure TRegExpr.SetLineSeparators(const AStr: RegExprString); end; end; { of procedure TRegExpr.SetLineSeparators -------------------------------------------------------------- } +{$ENDIF} -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; +procedure TRegExpr.SetUsePairedBreak(AValue: Boolean); begin - if fLinePairedSeparatorAssigned then + if AValue <> fUsePairedBreak 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 - -------------------------------------------------------------- } + fUsePairedBreak := AValue; + InvalidateProgramm; + end; +end; function TRegExpr.Substitute(const ATemplate: RegExprString): RegExprString; // perform substitutions after a regexp match var TemplateBeg, TemplateEnd: PRegExprChar; - function ParseVarName(var APtr: PRegExprChar): integer; - // extract name of variable (digits, may be enclosed with - // curly braces) from APtr^, uses TemplateEnd !!! + function ParseVarName(var APtr: PRegExprChar): Integer; + // extract name of variable: $1 or ${1} or ${name} + // from APtr^, uses TemplateEnd var p: PRegExprChar; - Delimited: boolean; + Delimited: Boolean; + GrpName: RegExprString; begin Result := 0; + GrpName := ''; p := APtr; Delimited := (p < TemplateEnd) and (p^ = '{'); if Delimited then @@ -4473,11 +6816,23 @@ function TRegExpr.Substitute(const ATemplate: RegExprString): RegExprString; if (p < TemplateEnd) and (p^ = '&') then Inc(p) // this is '$&' or '${&}' else - while (p < TemplateEnd) and IsDigitChar(p^) do + begin + if IsDigitChar(p^) then begin - Result := Result * 10 + (Ord(p^) - Ord('0')); // ###0.939 - Inc(p); + while (p < TemplateEnd) and IsDigitChar(p^) do + begin + Result := Result * 10 + (Ord(p^) - Ord('0')); + Inc(p); + end + end + else + if Delimited then + begin + FindGroupName(p, TemplateEnd, '}', GrpName); + Result := GrpNames.MatchIndexFromName(GrpName); + Inc(p, Length(GrpName)); end; + end; if Delimited then if (p < TemplateEnd) and (p^ = '}') then Inc(p) // skip right curly brace @@ -4488,28 +6843,32 @@ function TRegExpr.Substitute(const ATemplate: RegExprString): RegExprString; APtr := p; end; + procedure FindSubstGroupIndex(var p: PRegExprChar; var Idx: Integer; var NumberFound: Boolean); + begin + Idx := ParseVarName(p); + NumberFound := Idx >= 0; + if NumberFound and (Idx <= High(GrpIndexes)) then + Idx := GrpIndexes[Idx] + else + Idx := -1; + end; + type TSubstMode = (smodeNormal, smodeOneUpper, smodeOneLower, smodeAllUpper, smodeAllLower); var Mode: TSubstMode; p, p0, p1, ResultPtr: PRegExprChar; - ResultLen, n: integer; + ResultLen, n: Integer; Ch, QuotedChar: REChar; + GroupFound: Boolean; begin // Check programm and input string if not IsProgrammOk then Exit; - { - // don't check for empty, user needs to replace regex "\b", zero length - if fInputString = '' then - begin - Error(reeNoInputStringSpecified); - Exit; - end; - } - // Prepare for working + // Note: don't check for empty fInputString, it's valid case, + // e.g. user needs to replace regex "\b" to "_", it's zero match length if ATemplate = '' then - begin // prevent nil pointers + begin Result := ''; Exit; end; @@ -4522,13 +6881,14 @@ function TRegExpr.Substitute(const ATemplate: RegExprString): RegExprString; begin Ch := p^; Inc(p); - if Ch = '$' then - n := GrpIndexes[ParseVarName(p)] - else - n := -1; - if n >= 0 then + n := -1; + GroupFound := False; + if Ch = SubstituteGroupChar then + FindSubstGroupIndex(p, n, GroupFound); + if GroupFound then begin - Inc(ResultLen, endp[n] - startp[n]); + if (n >= 0) and (GrpBounds[0].GrpStart[n] <> nil) then + Inc(ResultLen, GrpBounds[0].GrpEnd[n] - GrpBounds[0].GrpStart[n]); end else begin @@ -4538,7 +6898,7 @@ function TRegExpr.Substitute(const ATemplate: RegExprString): RegExprString; Inc(p); case Ch of 'n': - Inc(ResultLen, Length(FReplaceLineEnd)); + Inc(ResultLen, Length(fReplaceLineEnd)); 'u', 'l', 'U', 'L': { nothing } ; 'x': @@ -4569,7 +6929,7 @@ function TRegExpr.Substitute(const ATemplate: RegExprString): RegExprString; end; SetLength(Result, ResultLen); // Fill Result - ResultPtr := Pointer(Result); + ResultPtr := PRegExprChar(Result); p := TemplateBeg; Mode := smodeNormal; while p < TemplateEnd do @@ -4578,14 +6938,22 @@ function TRegExpr.Substitute(const ATemplate: RegExprString): RegExprString; p0 := p; Inc(p); p1 := p; - if Ch = '$' then - n := GrpIndexes[ParseVarName(p)] - else - n := -1; - if (n >= 0) then + n := -1; + GroupFound := False; + if Ch = SubstituteGroupChar then + FindSubstGroupIndex(p, n, GroupFound); + if GroupFound then begin - p0 := startp[n]; - p1 := endp[n]; + if n >= 0 then + begin + p0 := GrpBounds[0].GrpStart[n]; + if p0 = nil then + p1 := nil + else + p1 := GrpBounds[0].GrpEnd[n]; + end + else + p1 := p0; end else begin @@ -4596,14 +6964,14 @@ function TRegExpr.Substitute(const ATemplate: RegExprString): RegExprString; case Ch of 'n': begin - p0 := PRegExprChar(FReplaceLineEnd); - p1 := p0 + Length(FReplaceLineEnd); + p0 := PRegExprChar(fReplaceLineEnd); + p1 := p0 + Length(fReplaceLineEnd); end; 'x', 't', 'r', 'f', 'a', 'e': begin p := p - 1; // UnquoteChar expects the escaped char under the pointer - QuotedChar := UnQuoteChar(p); + QuotedChar := UnQuoteChar(p, TemplateEnd); p := p + 1; // Skip after last part of the escaped sequence - UnquoteChar stops on the last symbol of it p0 := @QuotedChar; @@ -4630,10 +6998,8 @@ function TRegExpr.Substitute(const ATemplate: RegExprString): RegExprString; p1 := p0; end; else - begin - Inc(p0); - Inc(p1); - end; + Inc(p0); + Inc(p1); end; end end; @@ -4688,7 +7054,7 @@ procedure TRegExpr.Split(const AInputStr: RegExprString; APieces: TStrings); function TRegExpr.Replace(const AInputStr: RegExprString; const AReplaceStr: RegExprString; - AUseSubstitution: boolean{$IFDEF DefParam} = False{$ENDIF}): RegExprString; + AUseSubstitution: Boolean{$IFDEF DefParam} = False{$ENDIF}): RegExprString; var PrevPos: PtrInt; begin @@ -4697,7 +7063,7 @@ function TRegExpr.Replace(const AInputStr: RegExprString; if Exec(AInputStr) then repeat Result := Result + System.Copy(AInputStr, PrevPos, MatchPos[0] - PrevPos); - if AUseSubstitution // ###0.946 + if AUseSubstitution then Result := Result + Substitute(AReplaceStr) else @@ -4745,220 +7111,331 @@ procedure TRegExpr.FillFirstCharSet(prog: PRegExprChar); opnd: PRegExprChar; Oper: TREOp; ch: REChar; - min_cnt, i: integer; - TempSet: TRegExprCharset; + min_cnt: Integer; + {$IFDEF UseLineSep} + i: Integer; + {$ENDIF} + TempSet, TmpFirstCharSet: TRegExprCharset; begin TempSet := []; scan := prog; while scan <> nil do begin - Next := regnext(scan); + Next := regNextQuick(scan); Oper := PREOp(scan)^; case Oper of OP_BSUBEXP, - OP_BSUBEXPCI: + OP_BSUBEXP_CI: begin // we cannot optimize r.e. if it starts with back reference - FirstCharSet := RegExprAllSet; //###0.930 + FirstCharSet := RegExprAllSet; Exit; end; + OP_BOL, - OP_BOLML: - ; // Exit; //###0.937 + OP_BOL_ML, + OP_CONTINUE_POS, + OP_RESET_MATCHPOS: + ; // Exit; + OP_EOL, - OP_EOLML: - begin //###0.948 was empty in 0.947, was EXIT in 0.937 + OP_EOL2, + OP_EOL_ML: + begin Include(FirstCharSet, 0); if ModifierM then + begin + {$IFDEF UseLineSep} for i := 1 to Length(LineSeparators) do - Include(FirstCharSet, byte(LineSeparators[i])); + Include(FirstCharSet, Byte(LineSeparators[i])); + {$ELSE} + FirstCharSet := FirstCharSet + RegExprLineSeparatorsSet; + {$ENDIF} + end; Exit; end; + OP_BOUND, OP_NOTBOUND: - ; //###0.943 ?!! + ; + OP_ANY, - OP_ANYML: - begin // we can better define ANYML !!! - FirstCharSet := RegExprAllSet; //###0.930 + OP_ANY_ML: + begin // we can better define ANYML + FirstCharSet := RegExprAllSet; Exit; end; + OP_ANYDIGIT: begin FirstCharSet := FirstCharSet + RegExprDigitSet; Exit; end; + OP_NOTDIGIT: begin FirstCharSet := FirstCharSet + (RegExprAllSet - RegExprDigitSet); Exit; end; + OP_ANYLETTER: begin GetCharSetFromWordChars(TempSet); FirstCharSet := FirstCharSet + TempSet; Exit; end; + OP_NOTLETTER: begin GetCharSetFromWordChars(TempSet); FirstCharSet := FirstCharSet + (RegExprAllSet - TempSet); Exit; end; + OP_ANYSPACE: begin GetCharSetFromSpaceChars(TempSet); FirstCharSet := FirstCharSet + TempSet; Exit; end; + OP_NOTSPACE: begin GetCharSetFromSpaceChars(TempSet); FirstCharSet := FirstCharSet + (RegExprAllSet - TempSet); Exit; end; + OP_ANYVERTSEP: begin FirstCharSet := FirstCharSet + RegExprLineSeparatorsSet; Exit; end; + OP_NOTVERTSEP: begin FirstCharSet := FirstCharSet + (RegExprAllSet - RegExprLineSeparatorsSet); Exit; end; + OP_ANYHORZSEP: begin FirstCharSet := FirstCharSet + RegExprHorzSeparatorsSet; Exit; end; + OP_NOTHORZSEP: begin FirstCharSet := FirstCharSet + (RegExprAllSet - RegExprHorzSeparatorsSet); Exit; end; - OP_EXACTLYCI: + + OP_EXACTLY_CI: begin ch := (scan + REOpSz + RENextOffSz + RENumberSz)^; - {$IFDEF UniCode} + {$IFDEF UnicodeRE} if Ord(ch) <= $FF then {$ENDIF} begin - Include(FirstCharSet, byte(ch)); - Include(FirstCharSet, byte(InvertCase(ch))); + Include(FirstCharSet, Byte(ch)); + Include(FirstCharSet, Byte(InvertCase(ch))); end; Exit; end; + OP_EXACTLY: begin ch := (scan + REOpSz + RENextOffSz + RENumberSz)^; - {$IFDEF UniCode} + {$IFDEF UnicodeRE} if Ord(ch) <= $FF then {$ENDIF} - Include(FirstCharSet, byte(ch)); + Include(FirstCharSet, Byte(ch)); Exit; end; + OP_ANYOF: begin GetCharSetFromCharClass(scan + REOpSz + RENextOffSz, False, TempSet); FirstCharSet := FirstCharSet + TempSet; Exit; end; + OP_ANYBUT: begin GetCharSetFromCharClass(scan + REOpSz + RENextOffSz, False, TempSet); FirstCharSet := FirstCharSet + (RegExprAllSet - TempSet); Exit; end; - OP_ANYOFCI: + + OP_ANYOF_CI: begin GetCharSetFromCharClass(scan + REOpSz + RENextOffSz, True, TempSet); FirstCharSet := FirstCharSet + TempSet; Exit; end; - OP_ANYBUTCI: + + OP_ANYBUT_CI: begin GetCharSetFromCharClass(scan + REOpSz + RENextOffSz, True, TempSet); FirstCharSet := FirstCharSet + (RegExprAllSet - TempSet); Exit; end; + OP_NOTHING: ; OP_COMMENT: ; OP_BACK: - ; - Succ(OP_OPEN) .. TREOp(Ord(OP_OPEN) + NSUBEXP - 1): - begin //###0.929 + begin + // No point to rescan the code again + Next := PRegExprChar(AlignToPtr(scan + 1)) + RENextOffSz;; + end; + + OP_OPEN, OP_OPEN_ATOMIC: + begin FillFirstCharSet(Next); Exit; end; - Succ(OP_CLOSE) .. TREOp(Ord(OP_CLOSE) + NSUBEXP - 1): - begin //###0.929 + + OP_CLOSE, OP_CLOSE_ATOMIC: + begin FillFirstCharSet(Next); Exit; end; - OP_BRANCH: + + OP_LOOKAHEAD: begin - if (PREOp(Next)^ <> OP_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)^ <> OP_BRANCH); + opnd := PRegExprChar(AlignToPtr(Next + 1)) + RENextOffSz; + Next := regNextQuick(Next); + FillFirstCharSet(Next); + if opnd^ = OP_LOOKAROUND_OPTIONAL then Exit; - end; + + Next := PRegExprChar(AlignToPtr(scan + 1)) + RENextOffSz; + TmpFirstCharSet := FirstCharSet; + FirstCharSet := []; + FillFirstCharSet(Next); + + if TmpFirstCharSet = [] then + exit; + if FirstCharSet = [] then + FirstCharSet := TmpFirstCharSet + else + FirstCharSet := FirstCharSet * TmpFirstCharSet; + exit; + end; + + OP_LOOKAHEAD_NEG, + OP_LOOKBEHIND, OP_LOOKBEHIND_NEG: + begin + Next := PRegExprChar(AlignToPtr(Next + 1)) + RENextOffSz; + end; + + OP_LOOKAHEAD_END, OP_LOOKBEHIND_END: + begin + Exit; + end; + + OP_LOOKAROUND_OPTIONAL: + begin + Next := PRegExprChar(AlignToPtr(scan + 1)) + RENextOffSz; + end; + + OP_BRANCH, OP_GBRANCH, OP_GBRANCH_EX, OP_GBRANCH_EX_CI: + begin + repeat + TmpFirstCharSet := FirstCharSet; + FirstCharSet := []; + FillFirstCharSet(scan + REOpSz + RENextOffSz + REBranchArgSz); + FirstCharSet := FirstCharSet + TmpFirstCharSet; + scan := regNextQuick(scan); + until (scan = nil) or + ( (PREOp(scan)^ <> OP_BRANCH) and (PREOp(Next)^ <> OP_GBRANCH) and + (PREOp(scan)^ <> OP_GBRANCH_EX) and (PREOp(scan)^ <> OP_GBRANCH_EX_CI) ); + Exit; end; + {$IFDEF ComplexBraces} OP_LOOPENTRY: - begin //###0.925 - //LoopStack [LoopStackIdx] := 0; //###0.940 line removed - FillFirstCharSet(Next); // execute LOOP - Exit; + begin + min_cnt := PREBracesArg(AlignToPtr(Next + REOpSz + RENextOffSz))^; + if min_cnt = 0 then begin + opnd := AlignToPtr(Next + REOpSz + 2 * RENextOffSz + 2 * REBracesArgSz); + FillFirstCharSet(opnd); // FirstChar may be after loop + end; + Next := PRegExprChar(AlignToPtr(scan + 1)) + RENextOffSz; end; + OP_LOOP, - OP_LOOPNG: - begin //###0.940 - opnd := scan + PRENextOff(AlignToPtr(scan + REOpSz + RENextOffSz + REBracesArgSz * 2))^; + OP_LOOP_NG, + OP_LOOP_POSS: + begin min_cnt := PREBracesArg(AlignToPtr(scan + REOpSz + RENextOffSz))^; - FillFirstCharSet(opnd); if min_cnt = 0 then - FillFirstCharSet(Next); - Exit; + Exit; + // zero width loop + Next := AlignToPtr(scan + REOpSz + 2 * RENextOffSz + 2 * REBracesArgSz); end; {$ENDIF} + OP_STAR, - OP_STARNG: //###0.940 + OP_STAR_NG, + OP_STAR_POSS: FillFirstCharSet(scan + REOpSz + RENextOffSz); + OP_PLUS, - OP_PLUSNG: - begin //###0.940 + OP_PLUS_NG, + OP_PLUS_POSS: + begin FillFirstCharSet(scan + REOpSz + RENextOffSz); Exit; end; + OP_BRACES, - OP_BRACESNG: - begin //###0.940 + OP_BRACES_NG, + OP_BRACES_POSS: + begin opnd := scan + REOpSz + RENextOffSz + REBracesArgSz * 2; min_cnt := PREBracesArg(AlignToPtr(scan + REOpSz + RENextOffSz))^; // BRACES FillFirstCharSet(opnd); if min_cnt > 0 then Exit; end; + OP_EEND: begin - FirstCharSet := RegExprAllSet; //###0.948 + FirstCharSet := RegExprAllSet; Exit; end; - else + + OP_ANYCATEGORY, + OP_NOTCATEGORY: + begin + FirstCharSet := RegExprAllSet; + Exit; + end; + + OP_RECUR, + OP_SUBCALL: begin - fLastErrorOpcode := Oper; - Error(reeUnknownOpcodeInFillFirst); + // we cannot optimize // TODO: lookup the called group + FirstCharSet := RegExprAllSet; Exit; end; + + OP_ANYLINEBREAK: + begin + Include(FirstCharSet, Byte(10)); + Include(FirstCharSet, Byte(13)); + Include(FirstCharSet, Byte($0B)); + Include(FirstCharSet, Byte($0C)); + Include(FirstCharSet, Byte($85)); + end; + + else + fLastErrorOpcode := Oper; + Error(reeUnknownOpcodeInFillFirst); + Exit; end; { of case scan^} scan := Next; end; { of while scan <> nil} @@ -4968,13 +7445,13 @@ procedure TRegExpr.FillFirstCharSet(prog: PRegExprChar); procedure TRegExpr.InitCharCheckers; var - Cnt: integer; + Cnt: Integer; // - function Add(AChecker: TRegExprCharChecker): byte; + function Add(AChecker: TRegExprCharChecker): Byte; begin Inc(Cnt); if Cnt > High(CharCheckers) then - raise Exception.Create('Too small CharCheckers array'); + Error(reeTooSmallCheckersArray); CharCheckers[Cnt - 1] := AChecker; Result := Cnt - 1; end; @@ -4996,6 +7473,7 @@ procedure TRegExpr.InitCharCheckers; //CheckerIndex_AllAZ := Add(CharChecker_AllAZ); CheckerIndex_LowerAZ := Add(CharChecker_LowerAZ); CheckerIndex_UpperAZ := Add(CharChecker_UpperAZ); + CheckerIndex_AnyLineBreak := Add(CharChecker_AnyLineBreak); SetLength(CharCheckerInfos, 3); with CharCheckerInfos[0] do @@ -5018,73 +7496,78 @@ procedure TRegExpr.InitCharCheckers; end; end; -function TRegExpr.CharChecker_Word(ch: REChar): boolean; +function TRegExpr.CharChecker_Word(ch: REChar): Boolean; begin Result := IsWordChar(ch); end; -function TRegExpr.CharChecker_NotWord(ch: REChar): boolean; +function TRegExpr.CharChecker_NotWord(ch: REChar): Boolean; begin Result := not IsWordChar(ch); end; -function TRegExpr.CharChecker_Space(ch: REChar): boolean; +function TRegExpr.CharChecker_Space(ch: REChar): Boolean; begin Result := IsSpaceChar(ch); end; -function TRegExpr.CharChecker_NotSpace(ch: REChar): boolean; +function TRegExpr.CharChecker_NotSpace(ch: REChar): Boolean; begin Result := not IsSpaceChar(ch); end; -function TRegExpr.CharChecker_Digit(ch: REChar): boolean; +function TRegExpr.CharChecker_Digit(ch: REChar): Boolean; begin Result := IsDigitChar(ch); end; -function TRegExpr.CharChecker_NotDigit(ch: REChar): boolean; +function TRegExpr.CharChecker_NotDigit(ch: REChar): Boolean; begin Result := not IsDigitChar(ch); end; -function TRegExpr.CharChecker_VertSep(ch: REChar): boolean; +function TRegExpr.CharChecker_VertSep(ch: REChar): Boolean; begin - Result := IsLineSeparator(ch); + Result := IsVertLineSeparator(ch); end; -function TRegExpr.CharChecker_NotVertSep(ch: REChar): boolean; +function TRegExpr.CharChecker_NotVertSep(ch: REChar): Boolean; begin - Result := not IsLineSeparator(ch); + Result := not IsVertLineSeparator(ch); end; -function TRegExpr.CharChecker_HorzSep(ch: REChar): boolean; +function TRegExpr.CharChecker_AnyLineBreak(ch: REChar): Boolean; +begin + Result := IsAnyLineBreak(ch); +end; + +function TRegExpr.CharChecker_HorzSep(ch: REChar): Boolean; begin Result := IsHorzSeparator(ch); end; -function TRegExpr.CharChecker_NotHorzSep(ch: REChar): boolean; +function TRegExpr.CharChecker_NotHorzSep(ch: REChar): Boolean; begin Result := not IsHorzSeparator(ch); end; -function TRegExpr.CharChecker_LowerAZ(ch: REChar): boolean; +function TRegExpr.CharChecker_LowerAZ(ch: REChar): Boolean; begin case ch of 'a' .. 'z': Result := True; - else - Result := False; + else + Result := False; end; end; -function TRegExpr.CharChecker_UpperAZ(ch: REChar): boolean; +function TRegExpr.CharChecker_UpperAZ(ch: REChar): Boolean; begin case ch of 'A' .. 'Z': Result := True; - else - Result := False; + else + Result := False; end; end; @@ -5099,18 +7582,22 @@ function TRegExpr.DumpOp(op: TREOp): RegExprString; Result := 'BOL'; OP_EOL: Result := 'EOL'; - OP_BOLML: - Result := 'BOLML'; - OP_EOLML: - Result := 'EOLML'; + OP_EOL2: + Result := 'EOL2'; + OP_BOL_ML: + Result := 'BOL_ML'; + OP_CONTINUE_POS: + Result := 'CONTINUE_POS'; + OP_EOL_ML: + Result := 'EOL_ML'; OP_BOUND: - Result := 'BOUND'; // ###0.943 + Result := 'BOUND'; OP_NOTBOUND: - Result := 'NOTBOUND'; // ###0.943 + Result := 'NOTBOUND'; OP_ANY: Result := 'ANY'; - OP_ANYML: - Result := 'ANYML'; // ###0.941 + OP_ANY_ML: + Result := 'ANY_ML'; OP_ANYLETTER: Result := 'ANYLETTER'; OP_NOTLETTER: @@ -5135,16 +7622,22 @@ function TRegExpr.DumpOp(op: TREOp): RegExprString; Result := 'ANYOF'; OP_ANYBUT: Result := 'ANYBUT'; - OP_ANYOFCI: - Result := 'ANYOF/CI'; - OP_ANYBUTCI: - Result := 'ANYBUT/CI'; + OP_ANYOF_CI: + Result := 'ANYOF_CI'; + OP_ANYBUT_CI: + Result := 'ANYBUT_CI'; OP_BRANCH: Result := 'BRANCH'; + OP_GBRANCH: + Result := 'G_BRANCH'; + OP_GBRANCH_EX: + Result := 'G_BRANCH_EX'; + OP_GBRANCH_EX_CI: + Result := 'G_BRANCH_EX_CI'; OP_EXACTLY: Result := 'EXACTLY'; - OP_EXACTLYCI: - Result := 'EXACTLY/CI'; + OP_EXACTLY_CI: + Result := 'EXACTLY_CI'; OP_NOTHING: Result := 'NOTHING'; OP_COMMENT: @@ -5155,12 +7648,30 @@ function TRegExpr.DumpOp(op: TREOp): RegExprString; Result := 'END'; OP_BSUBEXP: Result := 'BSUBEXP'; - OP_BSUBEXPCI: - Result := 'BSUBEXP/CI'; - Succ(OP_OPEN) .. TREOp(Ord(OP_OPEN) + NSUBEXP - 1): // ###0.929 - Result := Format('OPEN[%d]', [Ord(op) - Ord(OP_OPEN)]); - Succ(OP_CLOSE) .. TREOp(Ord(OP_CLOSE) + NSUBEXP - 1): // ###0.929 - Result := Format('CLOSE[%d]', [Ord(op) - Ord(OP_CLOSE)]); + OP_BSUBEXP_CI: + Result := 'BSUBEXP_CI'; + OP_OPEN: + Result := 'OPEN'; + OP_CLOSE: + Result := 'CLOSE'; + OP_OPEN_ATOMIC: + Result := 'OPEN_ATOMIC'; + OP_CLOSE_ATOMIC: + Result := 'CLOSE_ATOMIC'; + OP_LOOKAHEAD: + Result := 'LOOKAHEAD'; + OP_LOOKAHEAD_NEG: + Result := 'LOOKAHEAD_NEG'; + OP_LOOKBEHIND: + Result := 'LOOKBEHIND'; + OP_LOOKBEHIND_NEG: + Result := 'LOOKBEHIND_NEG'; + OP_LOOKAHEAD_END: + Result := 'LOOKAHEAD_END'; + OP_LOOKBEHIND_END: + Result := 'LOOKBEHIND_END'; + OP_LOOKAROUND_OPTIONAL: + Result := 'OP_LOOKAROUND_OPTIONAL'; OP_STAR: Result := 'STAR'; OP_PLUS: @@ -5169,25 +7680,49 @@ function TRegExpr.DumpOp(op: TREOp): RegExprString; Result := 'BRACES'; {$IFDEF ComplexBraces} OP_LOOPENTRY: - Result := 'LOOPENTRY'; // ###0.925 + Result := 'LOOPENTRY'; OP_LOOP: - Result := 'LOOP'; // ###0.925 - OP_LOOPNG: - Result := 'LOOPNG'; // ###0.940 + Result := 'LOOP'; + OP_LOOP_NG: + Result := 'LOOP_NG'; + OP_LOOP_POSS: + Result := 'LOOP_POSS'; {$ENDIF} - OP_STARNG: - Result := 'STARNG'; // ###0.940 - OP_PLUSNG: - Result := 'PLUSNG'; // ###0.940 - OP_BRACESNG: - Result := 'BRACESNG'; // ###0.940 + OP_STAR_NG: + Result := 'STAR_NG'; + OP_PLUS_NG: + Result := 'PLUS_NG'; + OP_BRACES_NG: + Result := 'BRACES_NG'; + OP_STAR_POSS: + Result := 'STAR_POSS'; + OP_PLUS_POSS: + Result := 'PLUS_POSS'; + OP_BRACES_POSS: + Result := 'BRACES_POSS'; + OP_ANYCATEGORY: + Result := 'ANYCATEGORY'; + OP_NOTCATEGORY: + Result := 'NOTCATEGORY'; + OP_RECUR: + Result := 'RECURSION'; + OP_SUBCALL: + Result := 'SUBCALL'; + OP_ANYLINEBREAK: + Result := 'ANYLINEBREAK'; + OP_RESET_MATCHPOS: + Result := 'RESET_MATCHPOS'; else Error(reeDumpCorruptedOpcode); - end; { of case op } - Result := ':' + Result; + end; end; { of function TRegExpr.DumpOp -------------------------------------------------------------- } +function TRegExpr.IsCompiled: Boolean; +begin + Result := programm <> nil; +end; + function PrintableChar(AChar: REChar): RegExprString; {$IFDEF InlineFuncs}inline;{$ENDIF} begin if AChar < ' ' then @@ -5196,35 +7731,70 @@ function PrintableChar(AChar: REChar): RegExprString; {$IFDEF InlineFuncs}inline Result := AChar; end; -function TRegExpr.Dump: RegExprString; +function TRegExpr.DumpCheckerIndex(N: Byte): RegExprString; +begin + Result := '?'; + if N = CheckerIndex_Word then Result := '\w' else + if N = CheckerIndex_NotWord then Result := '\W' else + if N = CheckerIndex_Digit then Result := '\d' else + if N = CheckerIndex_NotDigit then Result := '\D' else + if N = CheckerIndex_Space then Result := '\s' else + if N = CheckerIndex_NotSpace then Result := '\S' else + if N = CheckerIndex_HorzSep then Result := '\h' else + if N = CheckerIndex_NotHorzSep then Result := '\H' else + if N = CheckerIndex_VertSep then Result := '\v' else + if N = CheckerIndex_NotVertSep then Result := '\V' else + if N = CheckerIndex_LowerAZ then Result := 'az' else + if N = CheckerIndex_UpperAZ then Result := 'AZ' else + if N = CheckerIndex_AnyLineBreak then Result := '\R' + ; +end; + +function TRegExpr.DumpCategoryChars(ch, ch2: REChar; Positive: Boolean): RegExprString; +const + S: array[Boolean] of RegExprString = ('P', 'p'); +begin + Result := '\' + S[Positive] + '{' + ch; + if ch2 <> #0 then + Result := Result + ch2; + Result := Result + '} '; +end; + +function TRegExpr.Dump(Indent: Integer): RegExprString; // dump a regexp in vaguely comprehensible form var s: PRegExprChar; op: TREOp; // Arbitrary non-END op. next: PRegExprChar; - i, NLen: integer; + i, NLen, CurIndent: Integer; Diff: PtrInt; - iByte: byte; + iByte: Byte; + ch, ch2: REChar; begin + Result := ''; if not IsProgrammOk then Exit; + CurIndent := 0; op := OP_EXACTLY; - Result := ''; - s := programm + REOpSz; + s := regCodeWork; while op <> OP_EEND do begin // While that wasn't END last time... op := s^; - Result := Result + Format('%2d%s', [s - programm, DumpOp(s^)]); + if ((op =OP_CLOSE) or (op = OP_CLOSE_ATOMIC) or (op = OP_LOOP) or (op = OP_LOOP_NG) or (op = OP_LOOP_POSS)) and (CurIndent > 0) then + dec(CurIndent, Indent); + Result := Result + Format('%2d:%s %s', [s - programm, StringOfChar(' ', CurIndent), DumpOp(s^)]); + if ((op = OP_OPEN) or (op = OP_OPEN_ATOMIC) or (op = OP_LOOPENTRY)) then + inc(CurIndent, Indent); // Where, what. - next := regnext(s); + 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) + // PWideChar subtraction workaround (see comments in Tail method for details) then Diff := next - s else @@ -5232,7 +7802,7 @@ function TRegExpr.Dump: RegExprString; Result := Result + Format(' (%d) ', [(s - programm) + Diff]); end; Inc(s, REOpSz + RENextOffSz); - if (op = OP_ANYOF) or (op = OP_ANYOFCI) or (op = OP_ANYBUT) or (op = OP_ANYBUTCI) then + if (op = OP_ANYOF) or (op = OP_ANYOF_CI) or (op = OP_ANYBUT) or (op = OP_ANYBUT_CI) then begin repeat case s^ of @@ -5254,7 +7824,7 @@ function TRegExpr.Dump: RegExprString; OpKind_MetaClass: begin Inc(s); - Result := Result + '\' + PrintableChar(s^) + ' '; + Result := Result + DumpCheckerIndex(Byte(s^)) + ' '; Inc(s); end; OpKind_Char: @@ -5270,12 +7840,30 @@ function TRegExpr.Dump: RegExprString; end; Result := Result + ') '; end; - else - Error(reeDumpCorruptedOpcode); + OpKind_CategoryYes: + begin + Inc(s); + ch := s^; + Inc(s); + ch2 := s^; + Result := Result + DumpCategoryChars(ch, ch2, True); + Inc(s); + end; + OpKind_CategoryNo: + begin + Inc(s); + ch := s^; + Inc(s); + ch2 := s^; + Result := Result + DumpCategoryChars(ch, ch2, False); + Inc(s); + end; + else + Error(reeDumpCorruptedOpcode); end; until false; end; - if (op = OP_EXACTLY) or (op = OP_EXACTLYCI) then + if (op = OP_EXACTLY) or (op = OP_EXACTLY_CI) then begin // Literal string, where present. NLen := PLongInt(s)^; @@ -5286,21 +7874,31 @@ function TRegExpr.Dump: RegExprString; Inc(s); end; end; - if (op = OP_BSUBEXP) or (op = OP_BSUBEXPCI) then + if (op = OP_BSUBEXP) or (op = OP_BSUBEXP_CI) then begin - Result := Result + ' \' + IntToStr(Ord(s^)); - Inc(s); + Result := Result + ' \' + IntToStr(PReGroupIndex(s)^); + Inc(s, ReGroupIndexSz); + end; + if (op = OP_SUBCALL) then + begin + Result := Result + ' (?' + IntToStr(PReGroupIndex(s)^) + ') @' + IntToStr(GrpOpCodes[PReGroupIndex(s)^]-programm); + Inc(s, ReGroupIndexSz); + end; + if (op = OP_OPEN) or (op = OP_OPEN_ATOMIC) or (op = OP_CLOSE) or (op = OP_CLOSE_ATOMIC) then + begin + Result := Result + ' [' + IntToStr(PReGroupIndex(s)^) + ']'; + Inc(s, ReGroupIndexSz); end; - if (op = OP_BRACES) or (op = OP_BRACESNG) then - begin // ###0.941 + if (op = OP_BRACES) or (op = OP_BRACES_NG) or (op = OP_BRACES_POSS) then + begin // show min/max argument of braces operator Result := Result + Format('{%d,%d}', [PREBracesArg(AlignToInt(s))^, PREBracesArg(AlignToInt(s + REBracesArgSz))^]); Inc(s, REBracesArgSz * 2); end; {$IFDEF ComplexBraces} - if (op = OP_LOOP) or (op = OP_LOOPNG) then - begin // ###0.940 + if (op = OP_LOOP) or (op = OP_LOOP_NG) or (op = OP_LOOP_POSS) then + begin Result := Result + Format(' -> (%d) {%d,%d}', [(s - programm - (REOpSz + RENextOffSz)) + PRENextOff(AlignToPtr(s + 2 * REBracesArgSz))^, @@ -5309,16 +7907,53 @@ function TRegExpr.Dump: RegExprString; Inc(s, 2 * REBracesArgSz + RENextOffSz); end; {$ENDIF} + if (op = OP_ANYCATEGORY) or (op = OP_NOTCATEGORY) then + begin + ch := s^; + Inc(s); + ch2 := s^; + Inc(s); + if ch2<>#0 then + Result := Result + '{' + ch + ch2 + '}' + else + Result := Result + '{' + ch + '}'; + end; + if (op = OP_LOOKBEHIND) or (op = OP_LOOKBEHIND_NEG) then + begin + if PReOpLookBehindOptions(s)^.IsGreedy = OPT_LOOKBEHIND_FIXED then + Result := Result + ' (fixed)' + else + if PReOpLookBehindOptions(s)^.IsGreedy = OPT_LOOKBEHIND_NON_GREEDY then + Result := Result + ' (not greedy)' + else + Result := Result + ' (greedy)'; + Result := Result + + ' Len: ' + IntToStr(PReOpLookBehindOptions(s)^.MatchLenMin) + + '..' + IntToStr(PReOpLookBehindOptions(s)^.MatchLenMax); + Inc(s, ReOpLookBehindOptionsSz); + end + else + if (op = OP_BRANCH) or (op = OP_GBRANCH) or + (op = OP_GBRANCH_EX) or (op = OP_GBRANCH_EX_CI) + then + begin + Inc(s, REBranchArgSz); + end; Result := Result + #$d#$a; end; { of while } // Header fields of interest. - if reganchored <> #0 then - Result := Result + 'Anchored; '; - if regmustString <> '' then - Result := Result + 'Must have: "' + regmustString + '"; '; + case regAnchored of + raBOL: Result := Result + 'Anchored(BOL); '; + raEOL: Result := Result + 'Anchored(EOL); '; + raContinue: Result := Result + 'Anchored(\G); '; + raOnlyOnce: Result := Result + 'Anchored(start); '; + end; + + if regMustString <> '' then + Result := Result + 'Must have: "' + regMustString + '"; '; - {$IFDEF UseFirstCharSet} // ###0.929 + {$IFDEF UseFirstCharSet} Result := Result + #$d#$a'First charset: '; if FirstCharSet = [] then Result := Result + '' @@ -5335,6 +7970,366 @@ function TRegExpr.Dump: RegExprString; -------------------------------------------------------------- } {$ENDIF} + +function TRegExpr.IsFixedLength(var op: TREOp; var ALen: Integer): Boolean; +var + s: PRegExprChar; + ADummyMaxLen: integer; +begin + Result := False; + if not IsCompiled then Exit; + s := regCodeWork; + Result := IsPartFixedLength(s, op, ALen, ADummyMaxLen, OP_EEND, nil, []); +end; + +function TRegExpr.IsFixedLengthEx(var op: TREOp; var AMinLen, AMaxLen: integer + ): boolean; +var + s: PRegExprChar; +begin + Result := False; + if not IsCompiled then Exit; + s := regCodeWork; + Result := IsPartFixedLength(s, op, AMinLen, AMaxLen, OP_EEND, nil, []); +end; + +function TRegExpr.IsPartFixedLength(var prog: PRegExprChar; var op: TREOp; + var AMinLen, AMaxLen: integer; StopAt: TREOp; StopMaxProg: PRegExprChar; + Flags: TRegExprFindFixedLengthFlags): boolean; + + function MultiplyLen(AVal, AFactor: Integer): Integer; + begin + if AFactor > High(AVal) div AVal then + Result := high(AVal) + else + Result := AVal * AFactor; + end; + + procedure IncMaxLen(var AVal: Integer; AInc: Integer); + begin + if AInc > High(AVal) - AVal then + AVal := high(AVal) + else + AVal := AVal + AInc; + end; + + +var + s, next: PRegExprChar; + N, N2, FndMaxLen, ASubLen, ABranchLen, ABranchMaxLen, ASubMaxLen: integer; + NotFixedLen, r, NextIsNil: Boolean; + FirstVarLenOp: TREOp; +begin + Result := False; + NotFixedLen := False; + AMinLen := 0; + AMaxLen := High(AMaxLen); + FndMaxLen := 0; + next := prog; + s := prog; + + repeat + NextIsNil := next = nil; + next := regNext(s); + prog := s; + op := s^; + if not NotFixedLen then + FirstVarLenOp := op; + + if (op = StopAt) or + ((StopMaxProg <> nil) and (s >= StopMaxProg)) or + (NextIsNil and (flfReturnAtNextNil in Flags)) + then begin + AMaxLen := FndMaxLen; + op := FirstVarLenOp; + if not NotFixedLen then + Result := True; + Exit; + end; + + Inc(s, REOpSz + RENextOffSz); + + case op of + OP_EEND: + begin + AMaxLen := FndMaxLen; + op := FirstVarLenOp; + if not NotFixedLen then + Result := True; + Exit; + end; + + OP_BRANCH, OP_GBRANCH, OP_GBRANCH_EX, OP_GBRANCH_EX_CI: + begin + s := s + REBranchArgSz; + if not IsPartFixedLength(s, op, ABranchLen, ABranchMaxLen, OP_EEND, next, []) then + begin + if not NotFixedLen then + FirstVarLenOp := op; + NotFixedLen := True; + if (ABranchMaxLen = high(ABranchMaxLen)) and not(flfForceToStopAt in Flags) then + exit; + end; + s := next; + repeat + next := regNext(s); + s := s + REBranchArgSz; + Inc(s, REOpSz + RENextOffSz); + if not IsPartFixedLength(s, op, ASubLen, ASubMaxLen, OP_EEND, next, []) then + begin + if not NotFixedLen then + FirstVarLenOp := op; + NotFixedLen := True; + if (ABranchMaxLen = high(ABranchMaxLen)) and not(flfForceToStopAt in Flags) then + exit; + end; + s := next; + if (ASubLen <> ABranchLen) then + NotFixedLen := True; + if ASubLen < ABranchLen then + ABranchLen := ASubLen; + if ASubMaxLen > ABranchMaxLen then + ABranchMaxLen := ASubMaxLen; + until (next^ <> OP_BRANCH) and (next^ <> OP_GBRANCH) and + (next^ <> OP_GBRANCH_EX) and (next^ <> OP_GBRANCH_EX_CI); + AMinLen := AMinLen + ABranchLen; + IncMaxLen(FndMaxLen, ABranchMaxLen); + end; + + OP_OPEN: + begin + Inc(s, ReGroupIndexSz); + if not IsPartFixedLength(s, op, ASubLen, ASubMaxLen, OP_CLOSE, nil, [flfForceToStopAt]) then + begin + if not NotFixedLen then + FirstVarLenOp := op; + NotFixedLen := True; + if (ABranchMaxLen = high(ABranchMaxLen)) and not(flfForceToStopAt in Flags) then + exit; + end; + assert(s^=OP_CLOSE); + AMinLen := AMinLen + ASubLen; + IncMaxLen(FndMaxLen, ASubMaxLen); + Inc(s, REOpSz + RENextOffSz + ReGroupIndexSz); // consume the OP_CLOSE + continue; + end; + + OP_OPEN_ATOMIC: + begin + Inc(s, ReGroupIndexSz); + if not IsPartFixedLength(s, op, ASubLen, ASubMaxLen, OP_CLOSE_ATOMIC, nil, [flfForceToStopAt]) then + begin + if not NotFixedLen then + FirstVarLenOp := op; + NotFixedLen := True; + if (ABranchMaxLen = high(ABranchMaxLen)) and not(flfForceToStopAt in Flags) then + exit; + end; + assert(s^=OP_CLOSE_ATOMIC); + AMinLen := AMinLen + ASubLen; + IncMaxLen(FndMaxLen, ASubMaxLen); + Inc(s, REOpSz + RENextOffSz + ReGroupIndexSz); // consume the OP_CLOSE_ATOMIC; + continue; + end; + + OP_CLOSE, OP_CLOSE_ATOMIC: + begin + Inc(s, ReGroupIndexSz); + continue; + end; + + OP_LOOKAHEAD, OP_LOOKAHEAD_NEG: + begin + r := IsPartFixedLength(s, op, ASubLen, ASubMaxLen, OP_LOOKAHEAD_END, next, [flfSkipLookAround, flfForceToStopAt]); + s := next; + Inc(s, REOpSz + RENextOffSz); // skip the OP_LOOKAHEAD_END + if not (flfSkipLookAround in Flags) then + begin + //if not r then + NotFixedLen := True; + end; + end; + + OP_LOOKBEHIND, OP_LOOKBEHIND_NEG: + begin + Inc(s, ReOpLookBehindOptionsSz); + r := IsPartFixedLength(s, op, ASubLen, ASubMaxLen, OP_LOOKBEHIND_END, next, [flfSkipLookAround, flfForceToStopAt]); + s := next; + Inc(s, REOpSz + RENextOffSz); // skip the OP_LOOKBEHIND_END + if not (flfSkipLookAround in Flags) then + //if flfForceToStopAt in Flags then + NotFixedLen := True + //else + // Exit; + end; + + OP_LOOKAHEAD_END, OP_LOOKBEHIND_END: + if flfSkipLookAround in Flags then + begin + continue; + end; + + OP_LOOKAROUND_OPTIONAL: + continue; + + OP_NOTHING, + OP_COMMENT, + OP_BOUND, + OP_NOTBOUND, + OP_BOL, + OP_BOL_ML, + OP_EOL, + OP_EOL2, + OP_EOL_ML, + OP_CONTINUE_POS: + Continue; + + OP_ANY, + OP_ANY_ML, + OP_ANYDIGIT, + OP_NOTDIGIT, + OP_ANYLETTER, + OP_NOTLETTER, + OP_ANYSPACE, + OP_NOTSPACE, + OP_ANYHORZSEP, + OP_NOTHORZSEP, + OP_ANYVERTSEP, + OP_NOTVERTSEP: + begin + Inc(AMinLen); + IncMaxLen(FndMaxLen, 1); + Continue; + end; + + OP_ANYOF, + OP_ANYOF_CI, + OP_ANYBUT, + OP_ANYBUT_CI: + begin + Inc(AMinLen); + IncMaxLen(FndMaxLen, 1); + repeat + case s^ of + OpKind_End: + begin + Inc(s); + Break; + end; + OpKind_Range: + begin + Inc(s); + Inc(s); + Inc(s); + end; + OpKind_MetaClass: + begin + Inc(s); + Inc(s); + end; + OpKind_Char: + begin + Inc(s); + Inc(s, RENumberSz + PLongInt(s)^); + end; + OpKind_CategoryYes, + OpKind_CategoryNo: + begin + Inc(s); + Inc(s); + Inc(s); + end; + end; + until False; + end; + + OP_EXACTLY, + OP_EXACTLY_CI: + begin + N := PLongInt(s)^; + Inc(AMinLen, N); + IncMaxLen(FndMaxLen, N); + Inc(s, RENumberSz + N); + Continue; + end; + + OP_ANYCATEGORY, + OP_NOTCATEGORY: + begin + Inc(AMinLen); + IncMaxLen(FndMaxLen, 1); + Inc(s, 2); + Continue; + end; + + OP_BRACES, + OP_BRACES_NG, + OP_BRACES_POSS: + begin + // allow only d{n,n} + N := PREBracesArg(AlignToInt(s))^; + N2 := PREBracesArg(AlignToInt(s + REBracesArgSz))^; + Inc(s, REBracesArgSz * 2); + r := IsPartFixedLength(s, op, ASubLen, ASubMaxLen, OP_EEND, next, [flfSkipLookAround, flfReturnAtNextNil, flfForceToStopAt]); + if not r then + begin + if not NotFixedLen then + FirstVarLenOp := op; + if (ABranchMaxLen = high(ABranchMaxLen)) and not(flfForceToStopAt in Flags) then + exit; + end; + + Inc(AMinLen, MultiplyLen(ASubLen, N)); + IncMaxLen(FndMaxLen, MultiplyLen(ASubMaxLen, N2)); + if (not r) or (N <> N2) then + NotFixedLen := True; + s := next; + end; + + OP_BSUBEXP, OP_BSUBEXP_CI, OP_SUBCALL: + begin + s := next; + NotFixedLen := True; // group may be in look-around. Could be anything + FndMaxLen := high(FndMaxLen); + end; + + else + begin + s := next; + FndMaxLen := high(FndMaxLen); + if flfForceToStopAt in Flags then + NotFixedLen := True + else + Exit; + end; + end; + until False; +end; + +procedure TRegExpr.SetInputSubString(const AInputString: RegExprString; + AInputStartPos, AInputLen: Integer); +begin + ClearMatches; + + if AInputStartPos < 1 then + AInputStartPos := 1 + else + if AInputStartPos > Length(AInputString) then + AInputStartPos := Length(AInputString) + 1; + if AInputLen < 0 then + AInputLen := 0 + else + if AInputLen > Length(AInputString) + 1 - AInputStartPos then + AInputLen := Length(AInputString) + 1 - AInputStartPos; + + fInputString := AInputString; + //UniqueString(fInputString); + + fInputStart := PRegExprChar(fInputString) + AInputStartPos - 1; + fInputEnd := fInputStart + AInputLen; + fInputContinue := fInputStart; +end; + {$IFDEF reRealExceptionAddr} {$OPTIMIZATION ON} // ReturnAddr works correctly only if compiler optimization is ON @@ -5342,46 +8337,80 @@ function TRegExpr.Dump: RegExprString; // way to restore compiler optimization flag ... {$ENDIF} -procedure TRegExpr.Error(AErrorID: integer); +procedure TRegExpr.Error(AErrorID: Integer); + {$IFDEF windows} {$IFDEF reRealExceptionAddr} - function ReturnAddr: Pointer; // ###0.938 + function ReturnAddr: Pointer; asm mov eax,[ebp+4] end; {$ENDIF} + {$ENDIF} var e: ERegExpr; + Msg: string; 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)); + Msg := ErrorMsg(AErrorID); + // compilation error ? + if AErrorID < reeFirstRuntimeCode then + Msg := Msg + ' (pos ' + IntToStr(CompilerErrorPos) + ')'; + e := ERegExpr.Create(Msg); e.ErrorCode := AErrorID; e.CompilerErrorPos := CompilerErrorPos; raise e + {$IFDEF windows} {$IFDEF reRealExceptionAddr} - at ReturnAddr; // ###0.938 + at ReturnAddr {$ENDIF} + {$ENDIF}; end; { of procedure TRegExpr.Error -------------------------------------------------------------- } -(* - PCode persistence: - FirstCharSet - programm, regsize - reganchored // -> programm - regmust, regmustlen // -> programm - fExprIsCompiled -*) +{$IFDEF Compat} // APIs needed only for users of old FPC 3.0 +function TRegExpr.ExecPos(AOffset: Integer; ATryOnce: Boolean): Boolean; overload; +begin + if ATryOnce then + Result := ExecPrim(AOffset, False, False, AOffset + 1) + else + Result := ExecPrim(AOffset, False, False, 0); +end; + +function TRegExpr.OldInvertCase(const Ch: REChar): REChar; +begin + Result := _UpperCase(Ch); + if Result = Ch then + Result := _LowerCase(Ch); +end; + +class function TRegExpr.InvertCaseFunction(const Ch: REChar): REChar; +begin + Result := _UpperCase(Ch); + if Result = Ch then + Result := _LowerCase(Ch); +end; -// be carefull - placed here code will be always compiled with -// compiler optimization flag +function TRegExpr.GetLinePairedSeparator: RegExprString; +begin + // not supported anymore + Result := ''; +end; -initialization +procedure TRegExpr.SetLinePairedSeparator(const AValue: RegExprString); +begin + // not supported anymore +end; - RegExprInvertCaseFunction := TRegExpr.InvertCaseFunction; +procedure TRegExpr.SetUseOsLineEndOnReplace(AValue: Boolean); +begin + if fUseOsLineEndOnReplace = AValue then + Exit; + fUseOsLineEndOnReplace := AValue; + if fUseOsLineEndOnReplace then + fReplaceLineEnd := sLineBreak + else + fReplaceLineEnd := #10; +end; +{$ENDIF} end. diff --git a/components/synedit/SynGen/SynGen.dpr b/components/synedit/SynGen/SynGen.dpr index 77c7792b1..b5558e896 100644 --- a/components/synedit/SynGen/SynGen.dpr +++ b/components/synedit/SynGen/SynGen.dpr @@ -41,7 +41,7 @@ program SynGen; uses Forms, - SynGenUnit in 'SynGenUnit.pas' {FrmMain}, + SynGenUnit in 'SynGenUnit.pas' {FormMain}, GenLex in 'GenLex.pas', HashTableGen in 'HashTableGen.pas' {FrmHashTableGen}; @@ -50,7 +50,7 @@ uses begin Application.Initialize; Application.Title := 'SynGen'; - Application.CreateForm(TFrmMain, FrmMain); + Application.CreateForm(TFormMain, FormMain); Application.CreateForm(TFrmHashTableGen, FrmHashTableGen); Application.Run; end. diff --git a/components/synedit/SynGen/SynGen.dproj b/components/synedit/SynGen/SynGen.dproj index b8fed1387..5b2cb8d42 100644 --- a/components/synedit/SynGen/SynGen.dproj +++ b/components/synedit/SynGen/SynGen.dproj @@ -8,7 +8,7 @@ 1 Application VCL - 16.1 + 18.4 Win32 @@ -34,6 +34,12 @@ Base true + + true + Cfg_2 + true + true + 1031 Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;Winapi;System.Win;$(DCC_Namespace) @@ -52,10 +58,16 @@ $(BDS)\bin\default_app.manifest 1033 true - Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + true + $(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_44.png + $(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_150.png $(BDS)\bin\default_app.manifest + true + $(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_44.png + $(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_150.png false @@ -66,12 +78,15 @@ DEBUG;$(DCC_Define) + + Debug + MainSource -
FrmMain
+
FormMain
 diff --git a/components/synedit/SynGen/SynGenUnit.dfm b/components/synedit/SynGen/SynGenUnit.dfm index 676e75e73..5be357cdb 100644 --- a/components/synedit/SynGen/SynGenUnit.dfm +++ b/components/synedit/SynGen/SynGenUnit.dfm @@ -1,343 +1,338 @@ -object FrmMain: TFrmMain - Left = 379 - Top = 238 - ActiveControl = BtnStart - BorderIcons = [biSystemMenu, biMinimize] - BorderStyle = bsSingle - Caption = 'SynGen' - ClientHeight = 288 - ClientWidth = 368 - Color = clBtnFace - Font.Charset = DEFAULT_CHARSET - Font.Color = clWindowText - Font.Height = -11 - Font.Name = 'MS Sans Serif' - Font.Style = [] - Menu = MainMenu - OldCreateOrder = False - OnClose = FormClose - OnCreate = FormCreate - OnDestroy = FormDestroy - PixelsPerInch = 96 - TextHeight = 13 - object PageControl: TPageControl - Left = 8 - Top = 8 - Width = 353 - Height = 241 - ActivePage = TabHighlighter - TabOrder = 1 - TabWidth = 80 - object TabHighlighter: TTabSheet - Caption = 'Highlighter' - object LblAuthor: TLabel - Left = 8 - Top = 20 - Width = 34 - Height = 13 - Caption = 'Author:' - end - object LblDescription: TLabel - Left = 8 - Top = 52 - Width = 56 - Height = 13 - Caption = 'Description:' - end - object LblVersion: TLabel - Left = 8 - Top = 84 - Width = 38 - Height = 13 - Caption = 'Version:' - end - object EditAuthor: TEdit - Left = 80 - Top = 16 - Width = 257 - Height = 21 - TabOrder = 0 - end - object EditDescription: TEdit - Left = 80 - Top = 48 - Width = 257 - Height = 21 - TabOrder = 1 - end - object EditVersion: TEdit - Left = 80 - Top = 80 - Width = 257 - Height = 21 - TabOrder = 2 - end - object ChkGetKeyWords: TCheckBox - Left = 8 - Top = 188 - Width = 249 - Height = 17 - Caption = 'Include optional GetKeyWords public method' - Checked = True - State = cbChecked - TabOrder = 4 - end - object ChkGPLHeader: TCheckBox - Left = 8 - Top = 168 - Width = 249 - Height = 17 - Caption = 'Use SynEdit standard GPL comment header' - Checked = True - State = cbChecked - TabOrder = 3 - end - end - object TabLanguage: TTabSheet - Caption = 'Language' - object LblFilter: TLabel - Left = 8 - Top = 20 - Width = 59 - Height = 13 - Caption = 'Default filter:' - end - object LblLangName: TLabel - Left = 8 - Top = 52 - Width = 80 - Height = 13 - Caption = 'Language name:' - end - object CboFilter: TComboBox - Left = 96 - Top = 16 - Width = 241 - Height = 21 - ItemHeight = 13 - TabOrder = 0 - Text = 'All files (*.*)|*.*' - OnChange = CboLangNameChange - Items.Strings = ( - 'Pascal files (*.pas,*.dpr,*.dpk,*.inc)|*.pas;*.dpr;*.dpk;*.inc' - 'HP48 files (*.s,*.sou,*.a,*.hp)|*.s;*.sou;*.a;*.hp' - 'CA-Clipper files (*.prg, *.ch, *.inc)|*.prg;*.ch;*.inc' - 'C++ files (*.cpp,*.h,*.hpp)|*.cpp;*.h;*.hpp' - 'Java files (*.java)|*.java' - 'Perl files (*.pl,*.pm,*.cgi)|*.pl;*.pm;*.cgi' - 'AWK Script (*.awk)|*.awk' - 'HTML Document (*.htm,*.html)|*.htm;*.html' - 'VBScript files (*.vbs)|*.vbs' - 'Galaxy files (*.gtv,*.galrep,*.txt)|*.gtv;*.galrep;*.txt' - 'Python files (*.py)|*.py' - 'SQL files (*.sql)|*.sql' - 'HP48 files (*.s,*.sou,*.a,*.hp)|*.s;*.sou;*.a;*.hp' - 'Tcl/Tk files (*.tcl)|*.tcl' - 'Rich Text Format (*.rtf)|*.rtf' - 'MS-DOS Batch Files (*.bat)|*.bat' - 'Delphi/C++ Builder Form Files (*.dfm)|*.dfm' - 'x86 Assembly Files (*.asm)|*.asm' - 'GEMBASE files (*.dml,*.gem)|*.dml;*.gem' - 'INI Files (*.ini)|*.ini' - 'Standard ML Files (*.sml)|*.sml' - 'Visual Basic files (*.bas)|*.bas' - 'DSP files (*.dsp,*.inc)|*.dsp;*.inc' - - 'PHP files (*.php,*.php3,*.phtml,*.inc)|*.php;*.php3;*.phtml;*.in' + - 'c' - 'Cache files (*.mac,*.inc,*.int)|*.mac;*.inc;*.int' - 'Cascading Stylesheets (*.css)|*.css' - 'Javascript files (*.js)|*.js' - 'Kix Scripts (*.kix)|*.kix' - 'Baan 4GL files (*.cln)|*.cln' - 'Foxpro Files (*.prg)|*.prg' - 'Fortran Files (*.for)|*.for' - '68HC11 Assembler files (*.hc11,*.asm,*.asc)|*.hc11;*.asm;*.asc') - end - object CboLangName: TComboBox - Left = 96 - Top = 48 - Width = 241 - Height = 21 - ItemHeight = 13 - TabOrder = 1 - OnChange = CboLangNameChange - Items.Strings = ( - 'HP48' - 'CA-Clipper' - 'C++' - 'Java' - 'Perl' - 'MS-DOS Batch Language' - 'Delphi/C++ Builder Form Definitions' - 'AWK Script' - 'HTML Document' - 'MS VBScript' - 'Galaxy' - 'General' - 'ObjectPascal' - 'x86 Assembly Language' - 'Python' - 'Tcl/Tk' - 'SQL' - 'Gembase' - 'INI files' - 'Standard ML' - 'Visual Basic' - 'ADSP21xx' - 'PHP' - 'Sybase SQL' - 'General Multi-Highlighter' - 'Cache object script' - 'Cascading Stylesheets' - 'Javascript' - 'KIX32' - 'Baan 4GL' - 'Foxpro' - 'Fortran' - '68HC11 Assembler') - end - end - object TabAttributes: TTabSheet - Caption = 'Attributes' - object LblUnknownTokenAttr: TLabel - Left = 8 - Top = 120 - Width = 164 - Height = 13 - Caption = 'Assign unknown token to attribute:' - end - object GrpAttrNames: TGroupBox - Left = 8 - Top = 8 - Width = 329 - Height = 96 - Caption = 'Attribute names' - TabOrder = 0 - object LblIdentifier: TLabel - Left = 16 - Top = 32 - Width = 43 - Height = 13 - Caption = 'Identifier:' - end - object LblReservedWord: TLabel - Left = 16 - Top = 64 - Width = 75 - Height = 13 - Caption = 'Reserved word:' - end - object CboAttrIdentifier: TComboBox - Left = 104 - Top = 28 - Width = 209 - Height = 21 - Style = csDropDownList - ItemHeight = 13 - TabOrder = 0 - end - object CboAttrReservedWord: TComboBox - Left = 104 - Top = 60 - Width = 209 - Height = 21 - Style = csDropDownList - ItemHeight = 13 - TabOrder = 1 - end - end - object CboUnknownTokenAttr: TComboBox - Left = 184 - Top = 116 - Width = 153 - Height = 21 - Style = csDropDownList - ItemHeight = 13 - TabOrder = 1 - Items.Strings = ( - 'Identifier' - 'Symbol' - 'Miscellaneous') - end - end - object TabFields: TTabSheet - Caption = 'Private Fields' - object ListBoxFields: TListBox - Left = 8 - Top = 40 - Width = 249 - Height = 161 - ItemHeight = 13 - Sorted = True - TabOrder = 3 - OnClick = ListBoxFieldsClick - end - object BtnAdd: TButton - Left = 264 - Top = 8 - Width = 73 - Height = 23 - Caption = 'Add' - Enabled = False - TabOrder = 0 - OnClick = BtnAddClick - end - object BtnDelete: TButton - Left = 264 - Top = 40 - Width = 73 - Height = 23 - Caption = 'Delete' - Enabled = False - TabOrder = 1 - OnClick = BtnDeleteClick - end - object EditAddField: TEdit - Left = 8 - Top = 8 - Width = 249 - Height = 21 - TabOrder = 2 - OnChange = EditAddFieldChange - OnKeyPress = EditAddFieldKeyPress - end - end - end - object BtnStart: TButton - Left = 288 - Top = 257 - Width = 75 - Height = 23 - Caption = 'Start!' - Default = True - TabOrder = 0 - OnClick = BtnStartClick - end - object OpenDialog: TOpenDialog - Filter = 'Grammar file (*.msg)|*.msg' - Left = 320 - Top = 184 - end - object MainMenu: TMainMenu - Left = 288 - Top = 184 - object MnuFile: TMenuItem - Caption = '&File' - object MnuOpen: TMenuItem - Caption = '&Open...' - ShortCut = 16463 - OnClick = MnuOpenClick - end - object MnuExit: TMenuItem - Caption = 'E&xit' - ShortCut = 32883 - OnClick = MnuExitClick - end - end - object MnuStart: TMenuItem - Caption = '&Start!' - OnClick = BtnStartClick - end - end -end +object FormMain: TFormMain + Left = 379 + Top = 238 + ActiveControl = ButtonStart + BorderIcons = [biSystemMenu, biMinimize] + BorderStyle = bsSingle + Caption = 'SynGen' + ClientHeight = 288 + ClientWidth = 368 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + Menu = MainMenu + OldCreateOrder = False + OnClose = FormClose + OnCreate = FormCreate + OnDestroy = FormDestroy + PixelsPerInch = 96 + TextHeight = 13 + object PageControl: TPageControl + Left = 8 + Top = 8 + Width = 353 + Height = 241 + ActivePage = TabHighlighter + TabOrder = 1 + TabWidth = 80 + object TabHighlighter: TTabSheet + Caption = 'Highlighter' + object LabelAuthor: TLabel + Left = 8 + Top = 20 + Width = 34 + Height = 13 + Caption = 'Author:' + end + object LabelDescription: TLabel + Left = 8 + Top = 52 + Width = 56 + Height = 13 + Caption = 'Description:' + end + object LabelVersion: TLabel + Left = 8 + Top = 84 + Width = 38 + Height = 13 + Caption = 'Version:' + end + object EditAuthor: TEdit + Left = 80 + Top = 16 + Width = 257 + Height = 21 + TabOrder = 0 + end + object EditDescription: TEdit + Left = 80 + Top = 48 + Width = 257 + Height = 21 + TabOrder = 1 + end + object EditVersion: TEdit + Left = 80 + Top = 80 + Width = 257 + Height = 21 + TabOrder = 2 + end + object CheckBoxGetKeyWords: TCheckBox + Left = 8 + Top = 188 + Width = 249 + Height = 17 + Caption = 'Include optional GetKeyWords public method' + Checked = True + State = cbChecked + TabOrder = 4 + end + object CheckBoxGPLHeader: TCheckBox + Left = 8 + Top = 168 + Width = 249 + Height = 17 + Caption = 'Use SynEdit standard GPL comment header' + Checked = True + State = cbChecked + TabOrder = 3 + end + end + object TabLanguage: TTabSheet + Caption = 'Language' + object LabelFilter: TLabel + Left = 8 + Top = 20 + Width = 59 + Height = 13 + Caption = 'Default filter:' + end + object LabelLangName: TLabel + Left = 8 + Top = 52 + Width = 80 + Height = 13 + Caption = 'Language name:' + end + object ComboBoxFilter: TComboBox + Left = 96 + Top = 16 + Width = 241 + Height = 21 + TabOrder = 0 + Text = 'All files (*.*)|*.*' + OnChange = ComboBoxLangNameChange + Items.Strings = ( + 'Pascal files (*.pas,*.dpr,*.dpk,*.inc)|*.pas;*.dpr;*.dpk;*.inc' + 'HP48 files (*.s,*.sou,*.a,*.hp)|*.s;*.sou;*.a;*.hp' + 'CA-Clipper files (*.prg, *.ch, *.inc)|*.prg;*.ch;*.inc' + 'C++ files (*.cpp,*.h,*.hpp)|*.cpp;*.h;*.hpp' + 'Java files (*.java)|*.java' + 'Perl files (*.pl,*.pm,*.cgi)|*.pl;*.pm;*.cgi' + 'AWK Script (*.awk)|*.awk' + 'HTML Document (*.htm,*.html)|*.htm;*.html' + 'VBScript files (*.vbs)|*.vbs' + 'Galaxy files (*.gtv,*.galrep,*.txt)|*.gtv;*.galrep;*.txt' + 'Python files (*.py)|*.py' + 'SQL files (*.sql)|*.sql' + 'HP48 files (*.s,*.sou,*.a,*.hp)|*.s;*.sou;*.a;*.hp' + 'Tcl/Tk files (*.tcl)|*.tcl' + 'Rich Text Format (*.rtf)|*.rtf' + 'MS-DOS Batch Files (*.bat)|*.bat' + 'Delphi/C++ Builder Form Files (*.dfm)|*.dfm' + 'x86 Assembly Files (*.asm)|*.asm' + 'GEMBASE files (*.dml,*.gem)|*.dml;*.gem' + 'INI Files (*.ini)|*.ini' + 'Standard ML Files (*.sml)|*.sml' + 'Visual Basic files (*.bas)|*.bas' + 'DSP files (*.dsp,*.inc)|*.dsp;*.inc' + + 'PHP files (*.php,*.php3,*.phtml,*.inc)|*.php;*.php3;*.phtml;*.in' + + 'c' + 'Cache files (*.mac,*.inc,*.int)|*.mac;*.inc;*.int' + 'Cascading Stylesheets (*.css)|*.css' + 'Javascript files (*.js)|*.js' + 'Kix Scripts (*.kix)|*.kix' + 'Baan 4GL files (*.cln)|*.cln' + 'Foxpro Files (*.prg)|*.prg' + 'Fortran Files (*.for)|*.for' + '68HC11 Assembler files (*.hc11,*.asm,*.asc)|*.hc11;*.asm;*.asc') + end + object ComboBoxLangName: TComboBox + Left = 96 + Top = 48 + Width = 241 + Height = 21 + TabOrder = 1 + OnChange = ComboBoxLangNameChange + Items.Strings = ( + 'HP48' + 'CA-Clipper' + 'C++' + 'Java' + 'Perl' + 'MS-DOS Batch Language' + 'Delphi/C++ Builder Form Definitions' + 'AWK Script' + 'HTML Document' + 'MS VBScript' + 'Galaxy' + 'General' + 'ObjectPascal' + 'x86 Assembly Language' + 'Python' + 'Tcl/Tk' + 'SQL' + 'Gembase' + 'INI files' + 'Standard ML' + 'Visual Basic' + 'ADSP21xx' + 'PHP' + 'Sybase SQL' + 'General Multi-Highlighter' + 'Cache object script' + 'Cascading Stylesheets' + 'Javascript' + 'KIX32' + 'Baan 4GL' + 'Foxpro' + 'Fortran' + '68HC11 Assembler') + end + end + object TabAttributes: TTabSheet + Caption = 'Attributes' + object LabelUnknownTokenAttr: TLabel + Left = 8 + Top = 120 + Width = 164 + Height = 13 + Caption = 'Assign unknown token to attribute:' + end + object GrpAttrNames: TGroupBox + Left = 8 + Top = 8 + Width = 329 + Height = 96 + Caption = 'Attribute names' + TabOrder = 0 + object LabelIdentifier: TLabel + Left = 16 + Top = 32 + Width = 43 + Height = 13 + Caption = 'Identifier:' + end + object LabelReservedWord: TLabel + Left = 16 + Top = 64 + Width = 75 + Height = 13 + Caption = 'Reserved word:' + end + object ComboBoxAttrIdentifier: TComboBox + Left = 104 + Top = 28 + Width = 209 + Height = 21 + Style = csDropDownList + TabOrder = 0 + end + object ComboBoxAttrReservedWord: TComboBox + Left = 104 + Top = 60 + Width = 209 + Height = 21 + Style = csDropDownList + TabOrder = 1 + end + end + object ComboBoxUnknownTokenAttr: TComboBox + Left = 184 + Top = 116 + Width = 153 + Height = 21 + Style = csDropDownList + TabOrder = 1 + Items.Strings = ( + 'Identifier' + 'Symbol' + 'Miscellaneous') + end + end + object TabFields: TTabSheet + Caption = 'Private Fields' + object ListBoxFields: TListBox + Left = 8 + Top = 40 + Width = 249 + Height = 161 + ItemHeight = 13 + Sorted = True + TabOrder = 3 + OnClick = ListBoxFieldsClick + end + object ButtonAdd: TButton + Left = 264 + Top = 8 + Width = 73 + Height = 23 + Caption = 'Add' + Enabled = False + TabOrder = 0 + OnClick = ButtonAddClick + end + object ButtonDelete: TButton + Left = 264 + Top = 40 + Width = 73 + Height = 23 + Caption = 'Delete' + Enabled = False + TabOrder = 1 + OnClick = ButtonDeleteClick + end + object EditAddField: TEdit + Left = 8 + Top = 8 + Width = 249 + Height = 21 + TabOrder = 2 + OnChange = EditAddFieldChange + OnKeyPress = EditAddFieldKeyPress + end + end + end + object ButtonStart: TButton + Left = 288 + Top = 257 + Width = 75 + Height = 23 + Caption = 'Start!' + Default = True + TabOrder = 0 + OnClick = ButtonStartClick + end + object OpenDialog: TOpenDialog + Filter = 'Grammar file (*.msg)|*.msg' + Left = 320 + Top = 184 + end + object MainMenu: TMainMenu + Left = 288 + Top = 184 + object MenuItemFile: TMenuItem + Caption = '&File' + object MenuItemOpen: TMenuItem + Caption = '&Open...' + ShortCut = 16463 + OnClick = MenuItemOpenClick + end + object MenuItemExit: TMenuItem + Caption = 'E&xit' + ShortCut = 32883 + OnClick = MenuItemExitClick + end + end + object MenuItemStart: TMenuItem + Caption = '&Start!' + OnClick = ButtonStartClick + end + end +end diff --git a/components/synedit/SynGen/SynGenUnit.pas b/components/synedit/SynGen/SynGenUnit.pas index 71f88c03f..ced7069d5 100644 --- a/components/synedit/SynGen/SynGenUnit.pas +++ b/components/synedit/SynGen/SynGenUnit.pas @@ -1,1938 +1,1926 @@ -{------------------------------------------------------------------------------- -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. - -The Original Code is: SynGenUnit.pas, released 2000-04-19. -Description: Generator for skeletons of HighLighters to use in SynEdit, -drived by a simple grammar. - -The Original Code is based on SynGenU.pas by Martin Waldenburg, part of -the mwEdit component suite. -Portions created by Martin Waldenburg are Copyright (C) 1998 Martin Waldenburg. -Portions created by Pieter Polak are Copyright (C) 2001 Pieter Polak. -Unicode translation by Mal Hrz. -All Rights Reserved. - -Contributors to the SynEdit and mwEdit projects are listed in the -Contributors.txt file. - -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. - -$Id: SynGenUnit.pas,v 1.18.2.11 2008/10/25 23:30:31 maelh Exp $ - -You may retrieve the latest version of this file at the SynEdit home page, -located at http://SynEdit.SourceForge.net - -Todo: - - Remember the last opened MSG file - - Double-click a MSG file opens SynGen - - Add user-defined default attributes to TSynXXXSyn.Create - - SynEdit to edit the MSG file (using the highlighter for MSG files) - - Store language names list and attribute names list in INI file - - SynEdit with Pascal highlighter to preview the created highlighter source - - Allow to define different type of keywords in MSG file - -Known Issues: --------------------------------------------------------------------------------} - -unit SynGenUnit; - -{$I SynEdit.inc} - -interface - -uses - Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, - StdCtrls, GenLex, ComCtrls, Menus, SynUnicode; - -var - mKeyHashTable: array[#0..#255] of Integer; - mSKeyHashTable: array[#0..#255] of Integer; - -type - TLexKeys = class - public - KeyName: string; - Key: Cardinal; - TokenType: string; - end; - - TLexCharsets = class - public - SetName: string; - Charset: string; - ProcData: string; - FuncData: string; - end; - - TLexEnclosedBy = class - public - TokenName: string; - ProcName: string; - StartsWith: string; - EndsWith: string; - MultiLine: Boolean; - constructor Create; - end; - - TLexDefaultAttri = class - public - Style: string; - Foreground: string; - Background: string; - constructor Create; - end; - - TFrmMain = class(TForm) - BtnStart: TButton; - OpenDialog: TOpenDialog; - PageControl: TPageControl; - TabLanguage: TTabSheet; - LblFilter: TLabel; - CboFilter: TComboBox; - LblLangName: TLabel; - CboLangName: TComboBox; - TabAttributes: TTabSheet; - GrpAttrNames: TGroupBox; - LblIdentifier: TLabel; - LblReservedWord: TLabel; - CboAttrIdentifier: TComboBox; - CboAttrReservedWord: TComboBox; - LblUnknownTokenAttr: TLabel; - CboUnknownTokenAttr: TComboBox; - TabFields: TTabSheet; - BtnAdd: TButton; - BtnDelete: TButton; - EditAddField: TEdit; - ListBoxFields: TListBox; - MainMenu: TMainMenu; - MnuFile: TMenuItem; - MnuOpen: TMenuItem; - MnuExit: TMenuItem; - TabHighlighter: TTabSheet; - LblAuthor: TLabel; - LblDescription: TLabel; - LblVersion: TLabel; - EditAuthor: TEdit; - EditDescription: TEdit; - EditVersion: TEdit; - MnuStart: TMenuItem; - ChkGetKeyWords: TCheckBox; - ChkGPLHeader: TCheckBox; - procedure BtnStartClick(Sender: TObject); - procedure FormCreate(Sender: TObject); - procedure FormDestroy(Sender: TObject); - procedure CboLangNameChange(Sender: TObject); - procedure ListBoxFieldsClick(Sender: TObject); - procedure BtnAddClick(Sender: TObject); - procedure BtnDeleteClick(Sender: TObject); - procedure EditAddFieldChange(Sender: TObject); - procedure EditAddFieldKeyPress(Sender: TObject; var Key: Char); - procedure MnuExitClick(Sender: TObject); - procedure MnuOpenClick(Sender: TObject); - procedure FormClose(Sender: TObject; var Action: TCloseAction); - private - LexName: string; - IdentPre: string; - IdentStart: string; - IdentContent: string; - FFileName: string; - IniFile: string; - OutFile: TextFile; - Sensitivity: Boolean; - LexFileContents: UnicodeString; - Lex: TGenLex; - KeyList: TList; - SetList: TList; - EnclosedList: TList; - SampleSourceList: TStringList; - IdentList: TStringList; - procedure ClearAll; - function GetFilterName: string; - function GetLangName: string; - function FilterInvalidChars(const Value: string): string; - procedure MakeHashTable; - procedure MakeSensitiveHashTable; - procedure FillKeyList; - procedure FillTokenTypeList; - procedure OutFileCreate(InName: string); - procedure ParseCharsets; - procedure ParseEnclosedBy; - procedure ParseSampleSource; - procedure RetrieveCharset; - procedure RetrieveEnclosedBy; - procedure RetrieveSampleSource; - procedure WriteSettings; - function PerformFileOpen: Boolean; - procedure WriteRest; - function KeywordsAreAllAlphaNumAndDifferent: Boolean; - function GetFriendlyLangName: string; - public - end; - -var - FrmMain: TFrmMain; - -implementation - -{$R *.DFM} - -uses -{$IFDEF SYN_COMPILER_6_UP} - StrUtils, -{$ENDIF} - Registry, HashTableGen; - -const - BoolStrs: array[Boolean] of string = ('False', 'True'); // Do not localize - -function CompareKeys(Item1, Item2: Pointer): Integer; -begin - Result := AnsiCompareStr(TLexKeys(Item1).KeyName, TLexKeys(Item2).KeyName); -end; - -function CompareSets(Item1, Item2: Pointer): Integer; -begin - Result := 0; - if TLexCharsets(Item1).SetName < TLexCharsets(Item2).SetName then - Result := -1 - else if TLexCharsets(Item1).SetName > TLexCharsets(Item2).SetName then - Result := 1; -end; - -function AddInt(const aValue: Integer): string; -begin - if (aValue < 0) then - Result := ' - ' + IntToStr(Abs(aValue)) - else if (aValue > 0) then - Result := ' + ' + IntToStr(aValue) - else - Result := ''; -end; - -function StuffString(const Value: UnicodeString): UnicodeString; -var - i: Integer; -begin - Result := ''; - for i := 1 to Length(Value) do - begin - if (Value[i] = '''') then - Result := Result + '''''' - else - Result := Result + Value[i]; - end; -end; - -function FirstLetterCap(S: UnicodeString): UnicodeString; -begin - Result := SynWideLowerCase(S); - if Length(Result) > 0 then - Result[1] := SynWideUpperCase(S[1])[1]; -end; - -{$IFNDEF SYN_COMPILER_6_UP} -function AnsiReplaceStr(const AText, AFromText, AToText: string): string; -begin - Result := StringReplace(AText, AFromText, AToText, [rfReplaceAll]); -end; -{$ENDIF} - -function ToAlphaNum(S: UnicodeString): UnicodeString; -var - c: Char; -begin - for c := #33 to #47 do - S := AnsiReplaceStr(S, c, IntToStr(Ord(c))); - - for c := #58 to #64 do - S := AnsiReplaceStr(S, c, IntToStr(Ord(c))); - - for c := #91 to #96 do - S := AnsiReplaceStr(S, c, IntToStr(Ord(c))); - - for c := #123 to #191 do - S := AnsiReplaceStr(S, c, IntToStr(Ord(c))); - - Result := S; -end; - -function IsASCIIAlphaNum(S: UnicodeString): Boolean; -var - i: Integer; -begin - Result := True; - - S := ToAlphaNum(S); - - for i := 1 to Length(S) do - case S[i] of - 'a'..'z', 'A'..'Z', '0'..'9', '_': ; - else - begin - Result := False; - Exit; - end; - end; -end; - -constructor TLexEnclosedBy.Create; -begin - inherited Create; - TokenName := ''; - ProcName := ''; - StartsWith := ''; - EndsWith := ''; - MultiLine := False; -end; - -constructor TLexDefaultAttri.Create; -begin - inherited Create; - Style := ''; - Foreground := ''; - Background := ''; -end; - -procedure TFrmMain.MakeSensitiveHashTable; -var - I: Char; -begin - for I := #0 to #255 do - begin - case CharInSet(I, ['_', 'A'..'Z', 'a'..'z']) of - True: - begin - if (I > #64) and (I < #91) then - mSKeyHashTable[I] := Ord(I) - 64 - else if (I > #96) then - mSKeyHashTable[I] := Ord(I) - 95; - end; - else - mSKeyHashTable[I] := 0; - end; - end; -end; - -procedure TFrmMain.MakeHashTable; -var - I, J: Char; -begin - for I := #0 to #255 do - begin - J := UpperCase(I)[1]; - case CharInSet(I, ['_', 'A'..'Z', 'a'..'z']) of - True: mKeyHashTable[I] := Ord(J) - 64; - else - mKeyHashTable[I] := 0; - end; - end; -end; - -procedure TFrmMain.WriteSettings; -begin - with TRegIniFile.Create(IniFile) do - try - WriteString('General', 'OpenDir', OpenDialog.InitialDir); - WriteBool(FFileName, 'GetKeyWords', ChkGetKeyWords.Checked); - WriteBool(FFileName, 'ChkGPLHeader', ChkGPLHeader.Checked); - WriteString(FFileName, 'Author', EditAuthor.Text); - WriteString(FFileName, 'Description', EditDescription.Text); - WriteString(FFileName, 'Version', EditVersion.Text); - WriteString(FFileName, 'Filter', CboFilter.Text); - WriteString(FFileName, 'Language', CboLangName.Text); - WriteString(FFileName, 'AttrIdentifier', CboAttrIdentifier.Text); - WriteString(FFileName, 'AttrReservedWord', CboAttrReservedWord.Text); - WriteString(FFileName, 'UnknownTokenAttr', CboUnknownTokenAttr.Text); - WriteString(FFileName, 'Fields', ListBoxFields.Items.CommaText); - finally - Free; - end; -end; - -function TFrmMain.PerformFileOpen: Boolean; -var - UserName: PChar; -{$IFDEF SYN_COMPILER_5_UP} - Count: Cardinal; -{$ELSE} - Count: Integer; -{$ENDIF} -begin - if OpenDialog.Execute then - begin - Count := 0; - Result := True; - FFileName := ExtractFileName(OpenDialog.FileName); - Caption := 'SynGen - ' + FFileName; - Application.Title := Caption; - OpenDialog.InitialDir := ExtractFilePath(OpenDialog.FileName); - GetUserName(nil, Count); - // retrieve the required size of the user name buffer - UserName := StrAlloc(Count); // allocate memory for the user name - GetUserName(UserName, Count); // retrieve the user name - with TRegIniFile.Create(IniFile) do - try - EditAuthor.Text := ReadString(FFileName, 'Author', StrPas(UserName)); - EditDescription.Text := ReadString(FFileName, 'Description', - 'Syntax Parser/Highlighter'); - EditVersion.Text := ReadString(FFileName, 'Version', '0.1'); - CboFilter.Text := ReadString(FFileName, 'Filter', 'All files (*.*)|*.*'); - CboLangName.Text := ReadString(FFileName, 'Language', ''); - ChkGetKeyWords.Checked := ReadBool(FFileName, 'GetKeyWords', True); - ChkGPLHeader.Checked := ReadBool(FFileName, 'ChkGPLHeader', True); - CboAttrIdentifier.ItemIndex := CboAttrIdentifier.Items.IndexOf - (ReadString(FFileName, 'AttrIdentifier', 'SYNS_AttrIdentifier')); - CboAttrReservedWord.ItemIndex := CboAttrReservedWord.Items.IndexOf - (ReadString(FFileName, 'AttrReservedWord', 'SYNS_AttrReservedWord')); - CboUnknownTokenAttr.ItemIndex := CboUnknownTokenAttr.Items.IndexOf - (ReadString(FFileName, 'UnknownTokenAttr', 'Identifier')); - ListBoxFields.Items.CommaText := ReadString(FFileName, 'Fields', ''); - finally - Free; - end; - StrDispose(UserName); - CboLangNameChange(Self); - end - else - Result := False; -end; - -procedure TFrmMain.FormCreate(Sender: TObject); -var - i: Integer; -begin - for i := FrmMain.ComponentCount - 1 downto 0 do - if FrmMain.Components[i] is TComboBox then - if TComboBox(FrmMain.Components[i]).Parent = GrpAttrNames then - begin - TComboBox(FrmMain.Components[i]).Items.Clear; - TComboBox(FrmMain.Components[i]).Items.Add('SYNS_AttrAsm'); - TComboBox(FrmMain.Components[i]).Items.Add('SYNS_AttrAsmComment'); - TComboBox(FrmMain.Components[i]).Items.Add('SYNS_AttrAsmKey'); - TComboBox(FrmMain.Components[i]).Items.Add('SYNS_AttrASP'); - TComboBox(FrmMain.Components[i]).Items.Add('SYNS_AttrAssembler'); - TComboBox(FrmMain.Components[i]).Items.Add('SYNS_AttrBlock'); - TComboBox(FrmMain.Components[i]).Items.Add('SYNS_AttrBrackets'); - TComboBox(FrmMain.Components[i]).Items.Add('SYNS_AttrCharacter'); - TComboBox(FrmMain.Components[i]).Items.Add('SYNS_AttrClass'); - TComboBox(FrmMain.Components[i]).Items.Add('SYNS_AttrComment'); - TComboBox(FrmMain.Components[i]).Items.Add('SYNS_AttrCondition'); - TComboBox(FrmMain.Components[i]).Items.Add('SYNS_AttrDir'); - TComboBox(FrmMain.Components[i]).Items.Add('SYNS_AttrDirective'); - TComboBox(FrmMain.Components[i]).Items.Add('SYNS_AttrDocumentation'); - TComboBox(FrmMain.Components[i]).Items.Add('SYNS_AttrEmbedSQL'); - TComboBox(FrmMain.Components[i]).Items.Add('SYNS_AttrEmbedText'); - TComboBox(FrmMain.Components[i]).Items.Add('SYNS_AttrEscapeAmpersand'); - TComboBox(FrmMain.Components[i]).Items.Add('SYNS_AttrForm'); - TComboBox(FrmMain.Components[i]).Items.Add('SYNS_AttrFunction'); - TComboBox(FrmMain.Components[i]).Items.Add('SYNS_AttrIcon'); - TComboBox(FrmMain.Components[i]).Items.Add('SYNS_AttrIdentifier'); - TComboBox(FrmMain.Components[i]).Items.Add('SYNS_AttrIllegalChar'); - TComboBox(FrmMain.Components[i]).Items.Add('SYNS_AttrIndirect'); - TComboBox(FrmMain.Components[i]).Items.Add('SYNS_AttrInvalidSymbol'); - TComboBox(FrmMain.Components[i]).Items.Add('SYNS_AttrInternalFunction'); - TComboBox(FrmMain.Components[i]).Items.Add('SYNS_AttrKey'); - TComboBox(FrmMain.Components[i]).Items.Add('SYNS_AttrLabel'); - TComboBox(FrmMain.Components[i]).Items.Add('SYNS_AttrMacro'); - TComboBox(FrmMain.Components[i]).Items.Add('SYNS_AttrMarker'); - TComboBox(FrmMain.Components[i]).Items.Add('SYNS_AttrMessage'); - TComboBox(FrmMain.Components[i]).Items.Add('SYNS_AttrMiscellaneous'); - TComboBox(FrmMain.Components[i]).Items.Add('SYNS_AttrNull'); - TComboBox(FrmMain.Components[i]).Items.Add('SYNS_AttrNumber'); - TComboBox(FrmMain.Components[i]).Items.Add('SYNS_AttrOperator'); - TComboBox(FrmMain.Components[i]).Items.Add('SYNS_AttrPragma'); - TComboBox(FrmMain.Components[i]).Items.Add('SYNS_AttrPreprocessor'); - TComboBox(FrmMain.Components[i]).Items.Add('SYNS_AttrQualifier'); - TComboBox(FrmMain.Components[i]).Items.Add('SYNS_AttrRegister'); - TComboBox(FrmMain.Components[i]).Items.Add('SYNS_AttrReservedWord'); - TComboBox(FrmMain.Components[i]).Items.Add('SYNS_AttrRpl'); - TComboBox(FrmMain.Components[i]).Items.Add('SYNS_AttrRplKey'); - TComboBox(FrmMain.Components[i]).Items.Add('SYNS_AttrRplComment'); - TComboBox(FrmMain.Components[i]).Items.Add('SYNS_AttrSASM'); - TComboBox(FrmMain.Components[i]).Items.Add('SYNS_AttrSASMComment'); - TComboBox(FrmMain.Components[i]).Items.Add('SYNS_AttrSASMKey'); - TComboBox(FrmMain.Components[i]).Items.Add('SYNS_AttrSecondReservedWord'); - TComboBox(FrmMain.Components[i]).Items.Add('SYNS_AttrSection'); - TComboBox(FrmMain.Components[i]).Items.Add('SYNS_AttrSpace'); - TComboBox(FrmMain.Components[i]).Items.Add('SYNS_AttrSpecialVariable'); - TComboBox(FrmMain.Components[i]).Items.Add('SYNS_AttrString'); - TComboBox(FrmMain.Components[i]).Items.Add('SYNS_AttrSymbol'); - TComboBox(FrmMain.Components[i]).Items.Add('SYNS_AttrSyntaxError'); - TComboBox(FrmMain.Components[i]).Items.Add('SYNS_AttrSystem'); - TComboBox(FrmMain.Components[i]).Items.Add('SYNS_AttrSystemValue'); - TComboBox(FrmMain.Components[i]).Items.Add('SYNS_AttrText'); - TComboBox(FrmMain.Components[i]).Items.Add('SYNS_AttrUnknownWord'); - TComboBox(FrmMain.Components[i]).Items.Add('SYNS_AttrUser'); - TComboBox(FrmMain.Components[i]).Items.Add('SYNS_AttrUserFunction'); - TComboBox(FrmMain.Components[i]).Items.Add('SYNS_AttrValue'); - TComboBox(FrmMain.Components[i]).Items.Add('SYNS_AttrVariable'); - end; - PageControl.ActivePage := PageControl.Pages[0]; - Lex := TGenLex.Create; - KeyList := TList.Create; - SetList := TList.Create; - EnclosedList := TList.Create; - SampleSourceList := TStringList.Create; - IdentList := TStringList.Create; - // read ini file - IniFile := Copy(ExtractFileName(Application.ExeName), 0, - Length(ExtractFileName(Application.ExeName)) - - Length(ExtractFileExt(Application.ExeName))) + '.ini'; - with TRegIniFile.Create(IniFile) do - try - OpenDialog.InitialDir := ReadString('General', 'OpenDir', - ExtractFilePath(Application.ExeName)); - finally - Free; - end; - - { Move form off the screen, but show already, to activate it correctly when - OpenFileDialog is closed with OK. } - Left := -10000; - Show; - if PerformFileOpen then - begin - MakeHashTable; - MakeSensitiveHashTable; - Position := poScreenCenter; // move form on the screen ("make visible") - end - else - Application.Terminate -end; - -procedure TFrmMain.ClearAll; -var - I: Integer; -begin - // Clear the contents of KeyList - for I := 0 to (KeyList.Count - 1) do - TObject(KeyList[I]).Free; - KeyList.Clear; - // Clear the contents of SetList - for I := 0 to (SetList.Count - 1) do - TObject(SetList[I]).Free; - SetList.Clear; - // Clear the contents of EnclosedList - for I := 0 to (EnclosedList.Count - 1) do - TObject(EnclosedList[I]).Free; - EnclosedList.Clear; - // Clear the contents of IdentList - for I := 0 to (IdentList.Count - 1) do - begin - if Assigned(IdentList.Objects[I]) then - TObject(IdentList.Objects[I]).Free; - end; - IdentList.Clear; - // Clear the contents of SampleSourceList - SampleSourceList.Clear; -end; - -procedure TFrmMain.FormDestroy(Sender: TObject); -begin - ClearAll; - Lex.Free; - IdentList.Free; - KeyList.Free; - SetList.Free; - EnclosedList.Free; -end; - -procedure TFrmMain.BtnStartClick(Sender: TObject); -var - LexFileLines: TUnicodeStringList; -begin - ClearAll; - - Screen.Cursor := crHourGlass; - - LexFileLines := TUnicodeStringList.Create; - try - LexFileLines.LoadFromFile(OpenDialog.FileName); - LexFileContents := LexFileLines.Text; - finally - LexFileLines.Free; - end; - Lex.Origin := PWideChar(LexFileContents); - Lex.Tokenize; - - while Lex.RunId <> IDIdentifier do - Lex.Next; - LexName := Lex.RunToken; - - Lex.Next; - while Lex.RunId <> IDIdentifier do - Lex.Next; - IdentPre := Lex.RunToken; - - OutFileCreate(OpenDialog.FileName); - try - while not (Lex.RunId in [IdSensitive, IdIdentStart]) do - Lex.Next; - - if Lex.RunId = IdSensitive then - Sensitivity := True - else - Sensitivity := False; - Lex.Next; - - while Lex.RunId <> IDCharSet do - Lex.Next; - IdentStart := Lex.RunToken; - Lex.Next; - - while Lex.RunId <> IDNull do - begin - case Lex.RunId of - IDCharSet: IdentContent := Lex.RunToken; - IDKeys: FillKeyList; - IDTokenTypes: FillTokenTypeList; - IDChars: ParseCharSets; - IDEnclosedBy: ParseEnclosedBy; - IDSampleSource: ParseSampleSource; - end; - Lex.Next; - end; - - if (KeyList.Count = 0) then - raise Exception.Create('You should specify at least 1 keyword!'); - if (IdentList.Count = 0) then - raise Exception.Create('You should specify at least 1 token type'); - if not KeywordsAreAllAlphaNumAndDifferent then - raise Exception.Create('One or more keywords contain unhandable characters'); - - FrmHashTableGen.AssignKeyWords(KeyList, Sensitivity); - FrmHashTableGen.ShowModal; - - WriteRest; - while (Lex.RunId <> IdNull) do - begin - Lex.Next; - end; - finally - Screen.Cursor := crDefault; - CloseFile(OutFile); - end; - MessageDlg(LexName + ' created on ' + DateTimeToStr(Now), mtInformation, - [mbOk], 0); -end; - -procedure TFrmMain.FillKeyList; -var - aLexKey: TLexKeys; - aString: string; - aTokenType: string; -begin - Lex.Next; - - aTokenType := ''; - while Lex.RunId <> IdCRLF do - begin - if not (Lex.RunId in [IdSpace, IdBraceOpen]) then - aTokenType := aTokenType + Lex.RunToken; - Lex.Next; - end; - - if (aTokenType = '') then - aTokenType := 'Key'; - - while Lex.RunId <> IdStop do - begin - while Lex.RunId in [IdSpace, IdBraceOpen, IdCRLF] do - Lex.Next; - if Lex.RunId <> IdStop then - begin - aString := ''; - while not (Lex.RunId in [IdSpace, IdBraceOpen, IdCRLF]) do - begin - aString := aString + Lex.RunToken; - Lex.Next; - end; - aLexKey := TLexKeys.Create; - aLexKey.TokenType := aTokenType; - aLexKey.KeyName := aString; - KeyList.Add(aLexKey); - end - else - Break; - Lex.Next; - end; - KeyList.Sort(CompareKeys); -end; - -procedure TFrmMain.FillTokenTypeList; -var - i: Integer; - List: TStringList; - sIdent: string; - sLine: string; - DefAttri: TLexDefaultAttri; -begin - Lex.Next; - IdentList.Add(IdentPre + 'Unknown'); - IdentList.Add(IdentPre + 'Null'); - while (Lex.RunId <> IdStop) do - begin - while Lex.RunId in [IdSpace, IdBraceOpen, IdCRLF, IDUnknown] do - Lex.Next; - if (Lex.RunId <> IdStop) then - begin - sIdent := IdentPre + Lex.RunToken; - if not IsValidIdent(sIdent) then - raise Exception.Create('Invalid identifier for token type: ' + sIdent); - - if (IdentList.IndexOf(sIdent) < 0) then - IdentList.Add(sIdent); - Lex.Next; - - sLine := ''; - while (Lex.RunId = IdSpace) do - Lex.Next; - while not (Lex.RunId in [IdStop, IdCRLF]) do - begin { is there more data on this line? } - sLine := sLine + Lex.RunToken; - Lex.Next; - end; - - if (sLine <> '') then { The Msg file specifies default attributes } - begin - List := TStringList.Create; - try - while (sLine <> '') do - begin - i := Pos('|', sLine); - if (i > 0) then - begin - List.Add(Copy(sLine, 1, i - 1)); - Delete(sLine, 1, i); - end - else - begin - List.Add(sLine); - sLine := ''; - end; - end; - - i := IdentList.IndexOf(sIdent); - if (i >= 0) then - begin - DefAttri := TLexDefaultAttri.Create; - DefAttri.Style := List.Values['Style']; - DefAttri.Foreground := List.Values['Foreground']; - DefAttri.Background := List.Values['Background']; - IdentList.Objects[i] := DefAttri; - end; - finally - List.Free; - end; - end; - end - else - Break; - end; -end; - -procedure TFrmMain.OutFileCreate(InName: string); -var - OutName, UName: string; - sysTime: TSystemTime; - ISODate: string; -begin - OutName := ChangeFileExt(InName, '.pas'); - Uname := ExtractFileName(ChangeFileExt(InName, '')); - AssignFile(OutFile, OutName); - rewrite(OutFile); - GetSystemTime(sysTime); - ISODate := Format('%.4d-%.2d-%.2d', [sysTime.wYear, sysTime.wMonth, - sysTime.wDay]); - if ChkGPLHeader.Checked then - begin - Writeln(OutFile, - '{-------------------------------------------------------------------------------'); - Writeln(OutFile, - 'The contents of this file are subject to the Mozilla Public License'); - Writeln(OutFile, - 'Version 1.1 (the "License"); you may not use this file except in compliance'); - Writeln(OutFile, - 'with the License. You may obtain a copy of the License at'); - Writeln(OutFile, 'http://www.mozilla.org/MPL/'); - Writeln(OutFile); - Writeln(OutFile, - 'Software distributed under the License is distributed on an "AS IS" basis,'); - Writeln(OutFile, - 'WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for'); - Writeln(OutFile, - 'the specific language governing rights and limitations under the License.'); - Writeln(OutFile); - Writeln(OutFile, 'Code template generated with SynGen.'); - Writeln(OutFile, 'The original code is: ' + OutName + ', released ' + ISODate - + '.'); - Writeln(OutFile, 'Description: ' + EditDescription.Text); - Writeln(OutFile, 'The initial author of this file is ' + EditAuthor.Text + - '.'); - Writeln(OutFile, 'Copyright (c) ' + Format('%d', [sysTime.wYear]) + - ', all rights reserved.'); - Writeln(OutFile); - Writeln(OutFile, - 'Contributors to the SynEdit and mwEdit projects are listed in the'); - Writeln(OutFile, 'Contributors.txt file.'); - Writeln(OutFile); - Writeln(OutFile, - 'Alternatively, the contents of this file may be used under the terms of the'); - Writeln(OutFile, - 'GNU General Public License Version 2 or later (the "GPL"), in which case'); - Writeln(OutFile, - 'the provisions of the GPL are applicable instead of those above.'); - Writeln(OutFile, - 'If you wish to allow use of your version of this file only under the terms'); - Writeln(OutFile, - 'of the GPL and not to allow others to use your version of this file'); - Writeln(OutFile, - 'under the MPL, indicate your decision by deleting the provisions above and'); - Writeln(OutFile, - 'replace them with the notice and other provisions required by the GPL.'); - Writeln(OutFile, - 'If you do not delete the provisions above, a recipient may use your version'); - Writeln(OutFile, 'of this file under either the MPL or the GPL.'); - Writeln(OutFile); - Writeln(OutFile, '$' + 'Id: ' + '$'); - Writeln(OutFile); - Writeln(OutFile, - 'You may retrieve the latest version of this file at the SynEdit home page,'); - Writeln(OutFile, 'located at http://SynEdit.SourceForge.net'); - Writeln(OutFile); - Writeln(OutFile, - '-------------------------------------------------------------------------------}'); - end - else - begin - Writeln(OutFile, - '{+-----------------------------------------------------------------------------+'); - Writeln(OutFile, ' | Class: ' + LexName); - Writeln(OutFile, ' | Created: ' + ISODate); - Writeln(OutFile, ' | Last change: ' + ISODate); - Writeln(OutFile, ' | Author: ' + EditAuthor.Text); - Writeln(OutFile, ' | Description: ' + EditDescription.Text); - Writeln(OutFile, ' | Version: ' + EditVersion.Text); - Writeln(OutFile, ' |'); - Writeln(OutFile, ' | Copyright (c) ' + Format('%d', [sysTime.wYear]) + #32 + - EditAuthor.Text + '. All rights reserved.'); - Writeln(OutFile, ' |'); - Writeln(OutFile, ' | Generated with SynGen.'); - Writeln(OutFile, - ' +----------------------------------------------------------------------------+}'); - end; - Writeln(OutFile); - Writeln(OutFile, '{$IFNDEF Q' + UpperCase(Uname) + '}'); - Writeln(OutFile, 'unit ' + Uname + ';'); - Writeln(OutFile, '{$ENDIF}'); - Writeln(OutFile); - Writeln(OutFile, '{$I SynEdit.inc}'); - Writeln(OutFile); - Writeln(OutFile, 'interface'); - Writeln(OutFile); - Writeln(OutFile, 'uses'); - Writeln(OutFile, '{$IFDEF SYN_CLX}'); - Writeln(OutFile, ' QGraphics,'); - Writeln(OutFile, ' QSynEditTypes,'); - Writeln(OutFile, ' QSynEditHighlighter,'); - Writeln(OutFile, ' QSynUnicode,'); - Writeln(OutFile, '{$ELSE}'); - Writeln(OutFile, ' Graphics,'); - Writeln(OutFile, ' SynEditTypes,'); - Writeln(OutFile, ' SynEditHighlighter,'); - Writeln(OutFile, ' SynUnicode,'); - Writeln(OutFile, '{$ENDIF}'); - Writeln(OutFile, ' SysUtils,'); - Writeln(OutFile, ' Classes;'); - Writeln(OutFile); - Writeln(OutFile, 'type'); - Writeln(OutFile, ' T' + IdentPre + 'TokenKind = ('); -end; - -procedure TFrmMain.ParseCharsets; -begin - Lex.Next; - while Lex.RunId <> IdStop do - begin - case Lex.RunId of - IdCharset: RetrieveCharset; - else - Lex.Next; - end; - end; -end; - -procedure TFrmMain.ParseEnclosedBy; -begin - Lex.Next; - while not (Lex.RunId in [IdStop, IdNull]) do - RetrieveEnclosedBy; -end; - -procedure TFrmMain.ParseSampleSource; -begin - Lex.Next; - if (Lex.RunId = IdCRLF) then - Lex.Next; - - while not (Lex.RunId in [IdStop, IdNull]) do - RetrieveSampleSource; -end; - -procedure TFrmMain.RetrieveCharset; -var - aSet: TLexCharsets; -begin - aSet := TLexCharsets.Create; - aSet.Charset := Lex.RunToken; - while Lex.RunId <> IDIdentifier do - Lex.Next; - aSet.SetName := Lex.RunToken; - while Lex.RunId <> IDBeginProc do - Lex.Next; - Lex.Next; - while Lex.RunId in [IdCRLF, IdSpace] do - Lex.Next; - while not (Lex.RunId = IdEndProc) do - begin - aSet.ProcData := aSet.ProcData + Lex.RunToken; - Lex.Next; - end; - SetList.Add(aSet); - Lex.Next; -end; - -procedure TFrmMain.RetrieveSampleSource; -var - sLine: string; -begin - sLine := ''; - while not (Lex.RunId in [IdCRLF, IdNull, IdStop]) do - begin - sLine := sLine + Lex.RunToken; - Lex.Next; - end; - if (Lex.RunId = IdCRLF) then - Lex.Next; - - SampleSourceList.Add(sLine); -end; - -procedure TFrmMain.RetrieveEnclosedBy; -var - aThing: TLexEnclosedBy; - sLine: string; - iPos: Integer; -begin - while Lex.RunId in [IdCRLF, IdSpace] do - Lex.Next; - - sLine := ''; - while not (Lex.RunId in [IdCRLF, IdNull, IdStop]) do - begin - sLine := sLine + Lex.RunToken; - Lex.Next; - end; - - if (sLine <> '') then - begin - aThing := TLexEnclosedBy.Create; - - iPos := Pos(',', sLine); - aThing.TokenName := Copy(sLine, 1, iPos - 1); - Delete(sLine, 1, iPos); - - iPos := Pos(',', sLine); - aThing.ProcName := Copy(sLine, 1, iPos - 1); - Delete(sLine, 1, iPos); - - iPos := Pos(',', sLine); - aThing.StartsWith := Copy(sLine, 1, iPos - 1); - Delete(sLine, 1, iPos); - - iPos := Pos(',', sLine); - if (iPos > 0) then - begin - aThing.EndsWith := Copy(sLine, 1, iPos - 1); - Delete(sLine, 1, iPos); - if (Pos('MULTILINE', UpperCase(sLine)) = 1) then - aThing.MultiLine := True; - end - else - aThing.EndsWith := sLine; - - EnclosedList.Add(aThing); - end - else if (Lex.RunId <> IdStop) then - Lex.Next; -end; { RetrieveEnclosedBy } - -function TFrmMain.FilterInvalidChars(const Value: string): string; -var - i: Integer; -begin - Result := ''; - for i := 1 to Length(Value) do - begin - if IsValidIdent(Result + Value[i]) then - Result := Result + Value[i]; - end; -end; { FilterInvalidChars } - -function TFrmMain.GetFilterName: string; -var - FilterName: string; -begin - FilterName := ''; - case CboFilter.ItemIndex of - -1: FilterName := 'SYNS_Filter' + FilterInvalidChars(CboLangName.Text); - 0: FilterName := 'SYNS_FilterPascal'; - 1: FilterName := 'SYNS_FilterHP48'; - 2: FilterName := 'SYNS_FilterCAClipper'; - 3: FilterName := 'SYNS_FilterCPP'; - 4: FilterName := 'SYNS_FilterJava'; - 5: FilterName := 'SYNS_FilterPerl'; - 6: FilterName := 'SYNS_FilterAWK'; - 7: FilterName := 'SYNS_FilterHTML'; - 8: FilterName := 'SYNS_FilterVBScript'; - 9: FilterName := 'SYNS_FilterGalaxy'; - 10: FilterName := 'SYNS_FilterPython'; - 11: FilterName := 'SYNS_FilterSQL'; - 12: FilterName := 'SYNS_FilterTclTk'; - 13: FilterName := 'SYNS_FilterRTF'; - 14: FilterName := 'SYNS_FilterBatch'; - 15: FilterName := 'SYNS_FilterDFM'; - 16: FilterName := 'SYNS_FilterX86Asm'; - 17: FilterName := 'SYNS_FilterGembase'; - 18: FilterName := 'SYNS_FilterINI'; - 19: FilterName := 'SYNS_FilterML'; - 20: FilterName := 'SYNS_FilterVisualBASIC'; - 21: FilterName := 'SYNS_FilterADSP21xx'; - 22: FilterName := 'SYNS_FilterPHP'; - 23: FilterName := 'SYNS_FilterCache'; - 24: FilterName := 'SYNS_FilterCSS'; - 25: FilterName := 'SYNS_FilterJScript'; - 26: FilterName := 'SYNS_FilterKIX'; - 27: FilterName := 'SYNS_FilterBaan'; - 28: FilterName := 'SYNS_FilterFoxpro'; - 29: FilterName := 'SYNS_FilterFortran'; - 30: FilterName := 'SYNS_FilterAsm68HC11'; - end; - Result := FilterName; -end; - -function TFrmMain.GetFriendlyLangName: string; -var - LangName: string; -begin - case CboLangName.ItemIndex of - -1: LangName := 'SYNS_FriendlyLang' + FilterInvalidChars(CboLangName.Text); - 0: LangName := 'SYNS_FriendlyLangHP48'; - 1: LangName := 'SYNS_FriendlyLangCAClipper'; - 2: LangName := 'SYNS_FriendlyLangCPP'; - 3: LangName := 'SYNS_FriendlyLangJava'; - 4: LangName := 'SYNS_FriendlyLangPerl'; - 5: LangName := 'SYNS_FriendlyLangBatch'; - 6: LangName := 'SYNS_FriendlyLangDfm'; - 7: LangName := 'SYNS_FriendlyLangAWK'; - 8: LangName := 'SYNS_FriendlyLangHTML'; - 9: LangName := 'SYNS_FriendlyLangVBSScript'; - 10: LangName := 'SYNS_FriendlyLangGalaxy'; - 11: LangName := 'SYNS_FriendlyLangGeneral'; - 12: LangName := 'SYNS_FriendlyLangPascal'; - 13: LangName := 'SYNS_FriendlyLangX86Asm'; - 14: LangName := 'SYNS_FriendlyLangPython'; - 15: LangName := 'SYNS_FriendlyLangTclTk'; - 16: LangName := 'SYNS_FriendlyLangSQL'; - 17: LangName := 'SYNS_FriendlyLangGembase'; - 18: LangName := 'SYNS_FriendlyLangINI'; - 19: LangName := 'SYNS_FriendlyLangML'; - 20: LangName := 'SYNS_FriendlyLangVisualBASIC'; - 21: LangName := 'SYNS_FriendlyLangADSP21xx'; - 22: LangName := 'SYNS_FriendlyLangPHP'; - 23: LangName := 'SYNS_FriendlyLangSybaseSQL'; - 24: LangName := 'SYNS_FriendlyLangGeneralMulti'; - 25: LangName := 'SYNS_FriendlyLangCache'; - 26: LangName := 'SYNS_FriendlyLangCSS'; - 27: LangName := 'SYNS_FriendlyLangJScript'; - 28: LangName := 'SYNS_FriendlyLangKIX'; - 29: LangName := 'SYNS_FriendlyLangBaan'; - 30: LangName := 'SYNS_FriendlyLangFoxpro'; - 31: LangName := 'SYNS_FriendlyLangFortran'; - 32: LangName := 'SYNS_FriendlyLang68HC11'; - end; - Result := LangName; -end; - -function TFrmMain.GetLangName: string; -var - LangName: string; -begin - case CboLangName.ItemIndex of - -1: LangName := 'SYNS_Lang' + FilterInvalidChars(CboLangName.Text); - 0: LangName := 'SYNS_LangHP48'; - 1: LangName := 'SYNS_LangCAClipper'; - 2: LangName := 'SYNS_LangCPP'; - 3: LangName := 'SYNS_LangJava'; - 4: LangName := 'SYNS_LangPerl'; - 5: LangName := 'SYNS_LangBatch'; - 6: LangName := 'SYNS_LangDfm'; - 7: LangName := 'SYNS_LangAWK'; - 8: LangName := 'SYNS_LangHTML'; - 9: LangName := 'SYNS_LangVBSScript'; - 10: LangName := 'SYNS_LangGalaxy'; - 11: LangName := 'SYNS_LangGeneral'; - 12: LangName := 'SYNS_LangPascal'; - 13: LangName := 'SYNS_LangX86Asm'; - 14: LangName := 'SYNS_LangPython'; - 15: LangName := 'SYNS_LangTclTk'; - 16: LangName := 'SYNS_LangSQL'; - 17: LangName := 'SYNS_LangGembase'; - 18: LangName := 'SYNS_LangINI'; - 19: LangName := 'SYNS_LangML'; - 20: LangName := 'SYNS_LangVisualBASIC'; - 21: LangName := 'SYNS_LangADSP21xx'; - 22: LangName := 'SYNS_LangPHP'; - 23: LangName := 'SYNS_LangSybaseSQL'; - 24: LangName := 'SYNS_LangGeneralMulti'; - 25: LangName := 'SYNS_LangCache'; - 26: LangName := 'SYNS_LangCSS'; - 27: LangName := 'SYNS_LangJScript'; - 28: LangName := 'SYNS_LangKIX'; - 29: LangName := 'SYNS_LangBaan'; - 30: LangName := 'SYNS_LangFoxpro'; - 31: LangName := 'SYNS_LangFortran'; - 32: LangName := 'SYNS_Lang68HC11'; - end; - Result := LangName; -end; - -procedure TFrmMain.WriteRest; -var - I, J: Integer; - LineLength: Integer; - KeyString: string; - AttrName: string; - FriendlyAttrName: string; - AttrTemp: string; - TempStringList: TStringList; - sPrefix: string; - DefAttri: TLexDefaultAttri; -begin - IdentList.Sort; - SetList.Sort(CompareSets); - I := 0; - while I < IdentList.Count - 1 do - begin - Writeln(OutFile, ' ' + IdentList[I] + ','); - inc(I); - end; - Writeln(OutFile, ' ' + IdentList[I] + ');'); - Writeln(OutFile); - Write(OutFile, ' TRangeState = (rsUnKnown'); - for I := 0 to (EnclosedList.Count - 1) do - Write(OutFile, ', rs' + TLexEnclosedBy(EnclosedList[I]).ProcName); - Writeln(OutFile, ');'); - Writeln(OutFile); - Writeln(OutFile, ' TProcTableProc = procedure of object;'); - Writeln(OutFile); - Writeln(OutFile, ' PIdentFuncTableFunc = ^TIdentFuncTableFunc;'); - Writeln(OutFile, ' TIdentFuncTableFunc = function (Index: Integer): T' + IdentPre + - 'TokenKind of object;'); - Writeln(OutFile); - - Writeln(OutFile, 'type'); - Writeln(OutFile, ' ' + LexName + ' = class(TSynCustomHighlighter)'); - Writeln(OutFile, ' private'); - Writeln(OutFile, ' fRange: TRangeState;'); - - if ListBoxFields.Items.Count > 0 then - for i := 0 to ListBoxFields.Items.Count - 1 do - Writeln(OutFile, ' ' + ListBoxFields.Items[i] + ';'); - - Writeln(OutFile, ' fTokenID: TtkTokenKind;'); - Writeln(OutFile, - ' fIdentFuncTable: array[0..' + - IntToStr(FrmHashTableGen.KeyIndicesCount - 1) + ']' + - ' of TIdentFuncTableFunc;'); - - I := 0; - while I < IdentList.Count do - begin - if (IdentList[I] <> IdentPre + 'Null') and (IdentList[I] <> IdentPre + - 'Unknown') then - Writeln(OutFile, ' f' + Copy(IdentList[I], Length(IdentPre) + 1, - Length(IdentList[I])) + 'Attri: TSynHighlighterAttributes;'); - inc(I); - end; - - Writeln(OutFile, ' function HashKey(Str: PWideChar): Cardinal;'); - - I := 0; - while I < KeyList.Count do - begin - Writeln(OutFile, AnsiString(' function Func' + - ToAlphaNum(FirstLetterCap(TLexKeys(KeyList[I]).KeyName)) + - '(Index: Integer): T' + IdentPre + 'TokenKind;')); - inc(I); - end; - - I := 0; - while I < SetList.Count do - begin - Writeln(OutFile, ' procedure ' + TLexCharsets(SetList[I]).SetName + - 'Proc;'); - inc(I); - end; - - Writeln(OutFile, ' procedure UnknownProc;'); - Writeln(OutFile, ' function AltFunc(Index: Integer): T' + IdentPre + 'TokenKind;'); - Writeln(OutFile, ' procedure InitIdent;'); - Writeln(OutFile, ' function IdentKind(MayBe: PWideChar): T' + IdentPre + - 'TokenKind;'); - Writeln(OutFile, ' procedure NullProc;'); - if (IdentList.IndexOf(IdentPre + 'Space') >= 0) then - Writeln(OutFile, ' procedure SpaceProc;'); - Writeln(OutFile, ' procedure CRProc;'); - Writeln(OutFile, ' procedure LFProc;'); - for I := 0 to (EnclosedList.Count - 1) do - begin - Writeln(OutFile, ' procedure ' + TLexEnclosedBy(EnclosedList[I]).ProcName - + 'OpenProc;'); - Writeln(OutFile, ' procedure ' + TLexEnclosedBy(EnclosedList[I]).ProcName - + 'Proc;'); - end; - Writeln(OutFile, ' protected'); - Writeln(OutFile, ' function GetSampleSource: UnicodeString; override;'); - Writeln(OutFile, ' function IsFilterStored: Boolean; override;'); - Writeln(OutFile, ' public'); - Writeln(OutFile, ' constructor Create(AOwner: TComponent); override;'); - Writeln(OutFile, ' class function GetFriendlyLanguageName: UnicodeString; override;'); - Writeln(OutFile, ' class function GetLanguageName: string; override;'); - Writeln(OutFile, ' function GetRange: Pointer; override;'); - Writeln(OutFile, ' procedure ResetRange; override;'); - Writeln(OutFile, ' procedure SetRange(Value: Pointer); override;'); - Writeln(OutFile, - ' function GetDefaultAttribute(Index: Integer): TSynHighlighterAttributes; override;'); - Writeln(OutFile, ' function GetEol: Boolean; override;'); - if ChkGetKeyWords.Checked then - Writeln(OutFile, ' function GetKeyWords(TokenKind: Integer): UnicodeString; override;'); - Writeln(OutFile, ' function GetTokenID: TtkTokenKind;'); - Writeln(OutFile, - ' function GetTokenAttribute: TSynHighlighterAttributes; override;'); - Writeln(OutFile, ' function GetTokenKind: Integer; override;'); - Writeln(OutFile, ' function IsIdentChar(AChar: WideChar): Boolean; override;'); - Writeln(OutFile, ' procedure Next; override;'); - Writeln(OutFile, ' published'); - - I := 0; - while I < IdentList.Count do - begin - if (IdentList[I] <> IdentPre + 'Null') and (IdentList[I] <> IdentPre + - 'Unknown') then - Writeln(OutFile, ' property ' + Copy(IdentList[I], Length(IdentPre) + - 1, Length(IdentList[I])) - + 'Attri: TSynHighlighterAttributes read f' + Copy(IdentList[I], - Length(IdentPre) + 1, Length(IdentList[I])) + - 'Attri write f' + Copy(IdentList[I], Length(IdentPre) + 1, - Length(IdentList[I])) + 'Attri;'); - inc(I); - end; - - Writeln(OutFile, ' end;'); - Writeln(OutFile); - Writeln(OutFile, 'implementation'); - Writeln(OutFile); - Writeln(OutFile, 'uses'); - Writeln(OutFile, '{$IFDEF SYN_CLX}'); - Writeln(OutFile, ' QSynEditStrConst;'); - Writeln(OutFile, '{$ELSE}'); - Writeln(OutFile, ' SynEditStrConst;'); - Writeln(OutFile, '{$ENDIF}'); - Writeln(OutFile); - if (CboFilter.ItemIndex = -1) or (CboLangName.ItemIndex = -1) then - begin - Writeln(OutFile, 'resourcestring'); - if (CboFilter.ItemIndex = -1) then - Writeln(OutFile, ' SYNS_Filter' + FilterInvalidChars(CboLangName.Text) + - ' = ''' + CboFilter.Text + ''';'); - if (CboLangName.ItemIndex = -1) then - begin - Writeln(OutFile, ' SYNS_Lang' + FilterInvalidChars(CboLangName.Text) + - ' = ''' + CboLangName.Text + ''';'); - - Writeln(OutFile, ' SYNS_FriendlyLang' + FilterInvalidChars(CboLangName.Text) + - ' = ''' + CboLangName.Text + ''';'); - end; - - I := 0; - while I < IdentList.Count do - begin - AttrTemp := Copy(IdentList[I], Length(IdentPre) + 1, - Length(IdentList[I])); - if (CboAttrIdentifier.Items.IndexOf('SYNS_Attr' + AttrTemp) < 0) and - (AttrTemp <> 'Unknown') then - begin - Writeln(OutFile, ' SYNS_Attr' + FilterInvalidChars(AttrTemp) + ' = ''' - + AttrTemp + ''';'); - Writeln(OutFile, ' SYNS_FriendlyAttr' + FilterInvalidChars(AttrTemp) + ' = ''' - + AttrTemp + ''';'); - end; - Inc(i); - end; - Writeln(OutFile); - end; - - Writeln(OutFile, 'const'); - Write(OutFile, FrmHashTableGen.GetKeyWordConstantsSource(Sensitivity)); - Writeln(OutFile); - - Writeln(OutFile, 'procedure ' + LexName + '.InitIdent;'); - Writeln(OutFile, 'var'); - Writeln(OutFile, ' i: Integer;'); - Writeln(OutFile, 'begin'); - Writeln(OutFile, ' for i := Low(fIdentFuncTable) to High(fIdentFuncTable) do'); - Writeln(OutFile, ' if KeyIndices[i] = -1 then'); - Writeln(OutFile, ' fIdentFuncTable[i] := AltFunc;'); - Writeln(OutFile, ''); - - I := 0; - while I < KeyList.Count do - begin - if I < KeyList.Count - 1 then - while TLexKeys(KeyList[I]).Key = TLexKeys(KeyList[I + 1]).Key do - begin - inc(I); - if I >= KeyList.Count - 1 then - break; - end; - KeyString := IntToStr(TLexKeys(KeyList[I]).Key); - Writeln(OutFile, ' fIdentFuncTable[' + KeyString + '] := Func' + - ToAlphaNum(FirstLetterCap(TLexKeys(KeyList[I]).KeyName)) + ';'); - inc(I); - end; - - Writeln(OutFile, 'end;'); - Writeln(OutFile); - - Write(OutFile, FrmHashTableGen.GetHashKeyFunctionSource(LexName)); - Writeln(OutFile); - - I := 0; - while I < KeyList.Count do - begin - KeyString := ToAlphaNum(FirstLetterCap(TLexKeys(KeyList[I]).KeyName)); - Writeln(OutFile, 'function ' + LexName + '.Func' + KeyString + '(Index: Integer): T' + - IdentPre + 'TokenKind;'); - Writeln(OutFile, 'begin'); - if I < KeyList.Count - 1 then - while TLexKeys(KeyList[I]).Key = TLexKeys(KeyList[I + 1]).Key do - begin - Writeln(OutFile, ' if IsCurrentToken(KeyWords[Index]) then'); - Writeln(OutFile, ' Result := ' + IdentPre + TLexKeys(KeyList[I]).TokenType); - Writeln(OutFile, ' else'); - inc(I); - if I >= KeyList.Count - 1 then - break; - end; - Writeln(OutFile, ' if IsCurrentToken(KeyWords[Index]) then'); - Writeln(OutFile, ' Result := ' + IdentPre + TLexKeys(KeyList[I]).TokenType); - Writeln(OutFile, ' else'); - Writeln(OutFile, ' Result := ' + IdentPre + 'Identifier;'); - Writeln(OutFile, 'end;'); - Writeln(OutFile); - inc(I); - end; - - Writeln(OutFile, 'function ' + LexName + '.AltFunc(Index: Integer): T' + IdentPre + - 'TokenKind;'); - Writeln(OutFile, 'begin'); - Writeln(OutFile, ' Result := ' + IdentPre + 'Identifier;'); - Writeln(OutFile, 'end;'); - Writeln(OutFile); - - Writeln(OutFile, 'function ' + LexName + '.IdentKind(MayBe: PWideChar): T' + - IdentPre + 'TokenKind;'); - Writeln(OutFile, 'var'); - Writeln(OutFile, ' Key: Cardinal;'); - Writeln(OutFile, 'begin'); - Writeln(OutFile, ' fToIdent := MayBe;'); - Writeln(OutFile, ' Key := HashKey(MayBe);'); - Writeln(OutFile, ' if Key <= High(fIdentFuncTable) then'); - Writeln(OutFile, ' Result := fIdentFuncTable[Key](KeyIndices[Key])'); - Writeln(OutFile, ' else'); - Writeln(OutFile, ' Result := ' + IdentPre + 'Identifier;'); - Writeln(OutFile, 'end;'); - Writeln(OutFile); - - if (IdentList.IndexOf(IdentPre + 'Space') >= 0) then - begin - Writeln(OutFile, 'procedure ' + LexName + '.SpaceProc;'); - Writeln(OutFile, 'begin'); - Writeln(OutFile, ' inc(Run);'); - Writeln(OutFile, ' fTokenID := ' + IdentPre + 'Space;'); - Writeln(OutFile, ' while (FLine[Run] <= #32) and not IsLineEnd(Run) do inc(Run);'); - Writeln(OutFile, 'end;'); - Writeln(OutFile); - end; - - Writeln(OutFile, 'procedure ' + LexName + '.NullProc;'); - Writeln(OutFile, 'begin'); - Writeln(OutFile, ' fTokenID := ' + IdentPre + 'Null;'); - Writeln(OutFile, ' inc(Run);'); - Writeln(OutFile, 'end;'); - Writeln(OutFile); - - Writeln(OutFile, 'procedure ' + LexName + '.CRProc;'); - Writeln(OutFile, 'begin'); - if (IdentList.IndexOf(IdentPre + 'Space') >= 0) then - Writeln(OutFile, ' fTokenID := ' + IdentPre + 'Space;') - else - Writeln(OutFile, ' fTokenID := ' + IdentPre + 'Unknown;'); - Writeln(OutFile, ' inc(Run);'); - Writeln(OutFile, ' if fLine[Run] = #10 then'); - Writeln(OutFile, ' inc(Run);'); - Writeln(OutFile, 'end;'); - Writeln(OutFile); - - Writeln(OutFile, 'procedure ' + LexName + '.LFProc;'); - Writeln(OutFile, 'begin'); - if (IdentList.IndexOf(IdentPre + 'Space') >= 0) then - Writeln(OutFile, ' fTokenID := ' + IdentPre + 'Space;') - else - Writeln(OutFile, ' fTokenID := ' + IdentPre + 'Unknown;'); - Writeln(OutFile, ' inc(Run);'); - Writeln(OutFile, 'end;'); - Writeln(OutFile); - - for I := 0 to (EnclosedList.Count - 1) do - begin - Writeln(OutFile, 'procedure ' + LexName + '.' + - TLexEnclosedBy(EnclosedList[I]).ProcName + 'OpenProc;'); - Writeln(OutFile, 'begin'); - Writeln(OutFile, ' Inc(Run);'); - if (Length(TLexEnclosedBy(EnclosedList[I]).StartsWith) > 1) then - begin - Write(OutFile, ' if '); - for J := 2 to Length(TLexEnclosedBy(EnclosedList[I]).StartsWith) do - begin - if (J > 2) then - begin - Writeln(OutFile, ' and'); - Write(OutFile, ' '); - end; - Write(OutFile, '(fLine[Run' + AddInt(J - 2) + '] = ''' + - StuffString(TLexEnclosedBy(EnclosedList[I]).StartsWith[J]) + ''')'); - end; - Writeln(OutFile, ' then'); - Writeln(OutFile, ' begin'); - Writeln(OutFile, ' Inc(Run, ' + - IntToStr(Length(TLexEnclosedBy(EnclosedList[I]).StartsWith)-1) + ');'); - Writeln(OutFile, ' fRange := rs' + - TLexEnclosedBy(EnclosedList[I]).ProcName + ';'); - if not TLexEnclosedBy(EnclosedList[I]).MultiLine then - begin - Writeln(OutFile, ' ' + TLexEnclosedBy(EnclosedList[I]).ProcName + - 'Proc;'); - end; - Writeln(OutFile, ' fTokenID := ' + IdentPre + - TLexEnclosedBy(EnclosedList[I]).TokenName + ';'); - Writeln(OutFile, ' end'); - Writeln(OutFile, ' else'); - if (IdentList.IndexOf(IdentPre + 'Symbol') >= 0) then - Writeln(OutFile, ' fTokenID := ' + IdentPre + 'Symbol;') - else - Writeln(OutFile, ' fTokenID := ' + IdentPre + 'Identifier;'); - end - else - begin - Writeln(OutFile, ' fRange := rs' + - TLexEnclosedBy(EnclosedList[I]).ProcName + ';'); - if not TLexEnclosedBy(EnclosedList[I]).MultiLine then - begin - Writeln(OutFile, ' ' + TLexEnclosedBy(EnclosedList[I]).ProcName + - 'Proc;'); - end; - Writeln(OutFile, ' fTokenID := ' + IdentPre + - TLexEnclosedBy(EnclosedList[I]).TokenName + ';'); - end; - Writeln(OutFile, 'end;'); - Writeln(OutFile); - Writeln(OutFile, 'procedure ' + LexName + '.' + - TLexEnclosedBy(EnclosedList[I]).ProcName + 'Proc;'); - Writeln(OutFile, 'begin'); - if TLexEnclosedBy(EnclosedList[I]).MultiLine then - begin - Writeln(OutFile, ' case fLine[Run] of'); - Writeln(OutFile, ' #0: NullProc;'); - Writeln(OutFile, ' #10: LFProc;'); - Writeln(OutFile, ' #13: CRProc;'); - Writeln(OutFile, ' else'); - Writeln(OutFile, ' begin'); - sPrefix := ' '; - end - else - sPrefix := ''; - Writeln(OutFile, sPrefix, ' fTokenID := ' + IdentPre + - TLexEnclosedBy(EnclosedList[I]).TokenName + ';'); - Writeln(OutFile, sPrefix, ' repeat'); - Write(OutFile, sPrefix, ' if '); - for J := 1 to Length(TLexEnclosedBy(EnclosedList[I]).EndsWith) do - begin - if (J > 1) then - begin - Writeln(OutFile, ' and'); - Write(OutFile, sPrefix, ' '); - end; - Write(OutFile, '(fLine[Run' + AddInt(J - 1) + '] = ''' + - StuffString(TLexEnclosedBy(EnclosedList[I]).EndsWith[J]) + ''')'); - end; - Writeln(OutFile, ' then'); - Writeln(OutFile, sPrefix, ' begin'); - Writeln(OutFile, sPrefix, ' Inc(Run, ' + - IntToStr(Length(TLexEnclosedBy(EnclosedList[I]).EndsWith)) + ');'); - Writeln(OutFile, sPrefix, ' fRange := rsUnKnown;'); - Writeln(OutFile, sPrefix, ' Break;'); - Writeln(OutFile, sPrefix, ' end;'); - Writeln(OutFile, sPrefix, ' if not IsLineEnd(Run) then'); - Writeln(OutFile, sPrefix, ' Inc(Run);'); - Writeln(OutFile, sPrefix, ' until IsLineEnd(Run);'); - Writeln(OutFile, sPrefix, 'end;'); - if TLexEnclosedBy(EnclosedList[I]).MultiLine then - begin - Writeln(OutFile, ' end;'); - Writeln(OutFile, 'end;'); - end; - Writeln(OutFile); - end; - - Writeln(OutFile, 'constructor ' + LexName + '.Create(AOwner: TComponent);'); - Writeln(OutFile, 'begin'); - Writeln(OutFile, ' inherited Create(AOwner);'); - Writeln(OutFile, ' fCaseSensitive := ' + BoolStrs[Sensitivity] + ';'); - Writeln(OutFile); - - I := 0; - while I < IdentList.Count do - begin - AttrTemp := Copy(IdentList[I], Length(IdentPre) + 1, Length(IdentList[I])); - if AttrTemp = 'Key' then - AttrName := CboAttrReservedWord.Text - else if AttrTemp = 'Identifier' then - AttrName := CboAttrIdentifier.Text - else - AttrName := 'SYNS_Attr' + FilterInvalidChars(AttrTemp); - - if Pos('SYNS_', AttrName) = 1 then - begin - FriendlyAttrName := AttrName; - Insert('Friendly', FriendlyAttrName, Length('SYNS_') + 1) - end - else - FriendlyAttrName := 'Friendly' + AttrName; - - if (IdentList[I] <> IdentPre + 'Null') and (IdentList[I] <> IdentPre + - 'Unknown') then - begin - AttrTemp := 'f' + AttrTemp + 'Attri'; - Writeln(OutFile, ' ' + AttrTemp + ' := TSynHighLighterAttributes.Create(' - + AttrName + ', ' + FriendlyAttrName + ');'); - if Assigned(IdentList.Objects[i]) then - begin - DefAttri := TLexDefaultAttri(IdentList.Objects[i]); - if (DefAttri.Style <> '') then - Writeln(OutFile, ' ' + AttrTemp + '.Style := ' + DefAttri.Style + - ';'); - if (DefAttri.Foreground <> '') then - Writeln(OutFile, ' ' + AttrTemp + '.Foreground := ' + - DefAttri.Foreground + ';'); - if (DefAttri.Background <> '') then - Writeln(OutFile, ' ' + AttrTemp + '.Background := ' + - DefAttri.Background + ';'); - end - else if (IdentList[I] = IdentPre + 'Key') then - Writeln(OutFile, ' ' + AttrTemp + '.Style := [fsBold];') - else if (IdentList[I] = IdentPre + 'Comment') then - begin - Writeln(OutFile, ' ' + AttrTemp + '.Style := [fsItalic];'); - Writeln(OutFile, ' ' + AttrTemp + '.Foreground := clNavy;'); - end; - Writeln(OutFile, ' AddAttribute(' + AttrTemp + ');'); - Writeln(OutFile); - end; - Inc(I); - end; - - Writeln(OutFile, ' SetAttributesOnChange(DefHighlightChange);'); - Writeln(OutFile, ' InitIdent;'); - - Writeln(OutFile, ' fDefaultFilter := ' + GetFilterName + ';'); - Writeln(OutFile, ' fRange := rsUnknown;'); - Writeln(OutFile, 'end;'); - Writeln(OutFile); - - I := 0; - while I < SetList.Count do - begin - Writeln(OutFile, 'procedure ' + LexName + '.' + - TLexCharsets(SetList[I]).SetName + 'Proc;'); - Writeln(OutFile, 'begin'); - Write(OutFile, ' ' + TLexCharsets(SetList[I]).ProcData); - Writeln(OutFile, 'end;'); - Writeln(OutFile); - inc(I); - end; - - Writeln(OutFile, 'procedure ' + LexName + '.UnknownProc;'); - Writeln(OutFile, 'begin'); - Writeln(OutFile, ' inc(Run);'); - Writeln(OutFile, ' fTokenID := ' + IdentPre + 'Unknown;'); - Writeln(OutFile, 'end;'); - Writeln(OutFile); - - Writeln(OutFile, 'procedure ' + LexName + '.Next;'); - Writeln(OutFile, 'begin'); - Writeln(OutFile, ' fTokenPos := Run;'); - if (EnclosedList.Count > 0) then - begin - Writeln(OutFile, ' case fRange of'); - for I := 0 to (EnclosedList.Count - 1) do - begin - if TLexEnclosedBy(EnclosedList[I]).MultiLine then - begin - Writeln(OutFile, ' rs' + TLexEnclosedBy(EnclosedList[I]).ProcName + - ': ' + TLexEnclosedBy(EnclosedList[I]).ProcName + 'Proc;'); - end; - end; - Writeln(OutFile, ' else'); - Writeln(OutFile, ' case fLine[Run] of'); - Writeln(OutFile, ' #0: NullProc;'); - Writeln(OutFile, ' #10: LFProc;'); - Writeln(OutFile, ' #13: CRProc;'); - - for I := 0 to (EnclosedList.Count - 1) do - begin - if (TLexEnclosedBy(EnclosedList[I]).StartsWith <> '') then - begin - Writeln(OutFile, ' ''' + - StuffString(TLexEnclosedBy(EnclosedList[I]).StartsWith[1]) + - ''': ' + TLexEnclosedBy(EnclosedList[I]).ProcName + 'OpenProc;'); - end; - end; - if (IdentList.IndexOf(IdentPre + 'Space') >= 0) then - Writeln(OutFile, ' #1..#9, #11, #12, #14..#32: SpaceProc;'); - I := 0; - while I < SetList.Count do - begin - Writeln(OutFile, ' ' + TLexCharsets(SetList[I]).Charset + - ': ' + TLexCharsets(SetList[I]).SetName + 'Proc;'); - Inc(I); - end; - - Writeln(OutFile, ' else'); - Writeln(OutFile, ' UnknownProc;'); - Writeln(OutFile, ' end;'); - Writeln(OutFile, ' end;'); - end - else - begin - Writeln(OutFile, ' case fLine[Run] of'); - Writeln(OutFile, ' #0: NullProc;'); - Writeln(OutFile, ' #10: LFProc;'); - Writeln(OutFile, ' #13: CRProc;'); - - if (IdentList.IndexOf(IdentPre + 'Space') >= 0) then - Writeln(OutFile, ' #1..#9, #11, #12, #14..#32: SpaceProc;'); - I := 0; - while I < SetList.Count do - begin - Writeln(OutFile, ' ' + TLexCharsets(SetList[I]).Charset + - ': ' + TLexCharsets(SetList[I]).SetName + 'Proc;'); - Inc(I); - end; - - Writeln(OutFile, ' else'); - Writeln(OutFile, ' UnknownProc;'); - Writeln(OutFile, ' end;'); - end; - Writeln(OutFile, ' inherited;'); - Writeln(OutFile, 'end;'); - Writeln(OutFile); - - Writeln(OutFile, 'function ' + LexName + - '.GetDefaultAttribute(Index: Integer): TSynHighLighterAttributes;'); - Writeln(OutFile, 'begin'); - Writeln(OutFile, ' case Index of'); - if (IdentList.IndexOf(IdentPre + 'Comment') >= 0) then - Writeln(OutFile, ' SYN_ATTR_COMMENT: Result := fCommentAttri;'); - if (IdentList.IndexOf(IdentPre + 'Identifier') >= 0) then - Writeln(OutFile, ' SYN_ATTR_IDENTIFIER: Result := fIdentifierAttri;'); - if (IdentList.IndexOf(IdentPre + 'Key') >= 0) then - Writeln(OutFile, ' SYN_ATTR_KEYWORD: Result := fKeyAttri;'); - if (IdentList.IndexOf(IdentPre + 'String') >= 0) then - Writeln(OutFile, ' SYN_ATTR_STRING: Result := fStringAttri;'); - if (IdentList.IndexOf(IdentPre + 'Space') >= 0) then - Writeln(OutFile, ' SYN_ATTR_WHITESPACE: Result := fSpaceAttri;'); - if (IdentList.IndexOf(IdentPre + 'Symbol') >= 0) then - Writeln(OutFile, ' SYN_ATTR_SYMBOL: Result := fSymbolAttri;'); - Writeln(OutFile, ' else'); - Writeln(OutFile, ' Result := nil;'); - Writeln(OutFile, ' end;'); - Writeln(OutFile, 'end;'); - Writeln(OutFile); - - Writeln(OutFile, 'function ' + LexName + '.GetEol: Boolean;'); - Writeln(OutFile, 'begin'); - Writeln(OutFile, ' Result := Run = fLineLen + 1;'); - Writeln(OutFile, 'end;'); - Writeln(OutFile); - - if ChkGetKeyWords.Checked then - begin - Writeln(OutFile, 'function ' + LexName + '.GetKeyWords(TokenKind: Integer): UnicodeString;'); - Writeln(OutFile, 'begin'); - TempStringList := TStringList.Create; - try - TempStringList.Sorted := True; - for I := 0 to KeyList.Count - 1 do - TempStringList.Add(TLexKeys(KeyList[I]).KeyName); - if TempStringList.Count > 0 then - begin - Writeln(OutFile, ' Result := '); - for I := 0 to Trunc(Int(Length(TempStringList.CommaText) div 70)) - 1 do - begin - if I = 0 then - LineLength := 69 - else - LineLength := 70; - Writeln(OutFile, ' ' + #39 + Copy(TempStringList.CommaText, - I * 70, LineLength) + #39 + #32 + #43); - end; - I := Trunc(Int(Length(TempStringList.CommaText) div 70)); - Writeln(OutFile, ' ' + #39 + Copy(TempStringList.CommaText, - I * 70, Length(TempStringList.CommaText)) + #39 + ';') - end - else - Writeln(OutFile, ' Result := ' + #39 + #39 + ';'); - finally - TempStringList.Free; - end; - Writeln(OutFile, 'end;'); - Writeln(OutFile); - end; - - Writeln(OutFile, 'function ' + LexName + '.GetTokenID: TtkTokenKind;'); - Writeln(OutFile, 'begin'); - Writeln(OutFile, ' Result := fTokenId;'); - Writeln(OutFile, 'end;'); - Writeln(OutFile); - - Writeln(OutFile, 'function ' + LexName + - '.GetTokenAttribute: TSynHighLighterAttributes;'); - Writeln(OutFile, 'begin'); - Writeln(OutFile, ' case GetTokenID of'); - - I := 0; - while I < IdentList.Count do - begin - if (IdentList[I] <> IdentPre + 'Null') and (IdentList[I] <> IdentPre + - 'Unknown') then - Writeln(OutFile, ' ' + IdentList[I] + ': Result := f' + - Copy(IdentList[I], Length(IdentPre) + 1, Length(IdentList[I])) + - 'Attri;'); - inc(I); - end; - Writeln(OutFile, ' ' + IdentPre + 'Unknown: Result := f' + - CboUnknownTokenAttr.Text + 'Attri;'); - - Writeln(OutFile, ' else'); - Writeln(OutFile, ' Result := nil;'); - Writeln(OutFile, ' end;'); - Writeln(OutFile, 'end;'); - Writeln(OutFile); - - Writeln(OutFile, 'function ' + LexName + '.GetTokenKind: Integer;'); - Writeln(OutFile, 'begin'); - Writeln(OutFile, ' Result := Ord(fTokenId);'); - Writeln(OutFile, 'end;'); - Writeln(OutFile); - - Writeln(OutFile, 'function ' + LexName + '.IsIdentChar(AChar: WideChar): Boolean;'); - Writeln(OutFile, 'begin'); - Writeln(OutFile, ' case AChar of'); - Writeln(OutFile, ' ' + IdentContent + ':'); - Writeln(OutFile, ' Result := True;'); - Writeln(OutFile, ' else'); - Writeln(OutFile, ' Result := False;'); - Writeln(OutFile, ' end;'); - Writeln(OutFile, 'end;'); - Writeln(OutFile); - - Writeln(OutFile, 'function ' + LexName + '.GetSampleSource: UnicodeString;'); - Writeln(OutFile, 'begin'); - if (SampleSourceList.Count = 0) then - begin - Writeln(OutFile, ' Result := '); - Writeln(OutFile, ' ''Sample source for: ''#13#10 +'); - Writeln(OutFile, ' ''' + EditDescription.Text + ''';'); - end - else - begin - Writeln(OutFile, ' Result := '); - for i := 0 to SampleSourceList.Count - 1 do - begin - if (i > 0) and (i < SampleSourceList.Count - 1) then - Writeln(OutFile, '#13#10 +'); - if (i < SampleSourceList.Count - 1) then - Write(OutFile, ' '); - if SampleSourceList[i] <> '' then - Write(OutFile, '''', StuffString(SampleSourceList[i]), ''''); - end; - Writeln(OutFile, ';'); - end; - Writeln(OutFile, 'end;'); - Writeln(OutFile); - - Writeln(OutFile, 'function ' + LexName + '.IsFilterStored: Boolean;'); - Writeln(OutFile, 'begin'); - Writeln(OutFile, ' Result := fDefaultFilter <> ' + GetFilterName + ';'); - Writeln(OutFile, 'end;'); - Writeln(OutFile); - - Writeln(OutFile, 'class function ' + LexName + '.GetFriendlyLanguageName: UnicodeString;'); - Writeln(OutFile, 'begin'); - Writeln(OutFile, ' Result := ' + GetFriendlyLangName + ';'); - Writeln(OutFile, 'end;'); - Writeln(OutFile); - - Writeln(OutFile, 'class function ' + LexName + '.GetLanguageName: string;'); - Writeln(OutFile, 'begin'); - Writeln(OutFile, ' Result := ' + GetLangName + ';'); - Writeln(OutFile, 'end;'); - Writeln(OutFile); - - Writeln(OutFile, 'procedure ' + LexName + '.ResetRange;'); - Writeln(OutFile, 'begin'); - Writeln(OutFile, ' fRange := rsUnknown;'); - Writeln(OutFile, 'end;'); - Writeln(OutFile); - - Writeln(OutFile, 'procedure ' + LexName + '.SetRange(Value: Pointer);'); - Writeln(OutFile, 'begin'); - Writeln(OutFile, ' fRange := TRangeState(Value);'); - Writeln(OutFile, 'end;'); - Writeln(OutFile); - - Writeln(OutFile, 'function ' + LexName + '.GetRange: Pointer;'); - Writeln(OutFile, 'begin'); - Writeln(OutFile, ' Result := Pointer(fRange);'); - Writeln(OutFile, 'end;'); - Writeln(OutFile); - - Writeln(OutFile, 'initialization'); - Writeln(OutFile, '{$IFNDEF SYN_CPPB_1}'); - Writeln(OutFile, ' RegisterPlaceableHighlighter(' + LexName + ');'); - Writeln(OutFile, '{$ENDIF}'); - Writeln(OutFile, 'end.'); -end; - -procedure TFrmMain.CboLangNameChange(Sender: TObject); -begin - if (CboLangName.Text <> '') and (CboFilter.Text <> '') then - BtnStart.Enabled := True - else - BtnStart.Enabled := False; -end; - -procedure TFrmMain.ListBoxFieldsClick(Sender: TObject); -begin - BtnDelete.Enabled := True; -end; - -procedure TFrmMain.BtnAddClick(Sender: TObject); -begin - ListBoxFields.Items.Add(EditAddField.Text); - EditAddField.Clear; -end; - -procedure TFrmMain.BtnDeleteClick(Sender: TObject); -begin - BtnDelete.Enabled := False; - ListBoxFields.Items.Delete(ListBoxFields.ItemIndex); -end; - -procedure TFrmMain.EditAddFieldChange(Sender: TObject); -begin - BtnAdd.Enabled := EditAddField.Text <> ''; -end; - -procedure TFrmMain.EditAddFieldKeyPress(Sender: TObject; var Key: Char); -begin - if (Key = ';') or (Key = #32) then - Key := #0; -end; - -procedure TFrmMain.MnuExitClick(Sender: TObject); -begin - Close; -end; - -procedure TFrmMain.MnuOpenClick(Sender: TObject); -begin - WriteSettings; - PerformFileOpen; -end; - -procedure TFrmMain.FormClose(Sender: TObject; var Action: TCloseAction); -begin - WriteSettings; -end; - -function TFrmMain.KeywordsAreAllAlphaNumAndDifferent: Boolean; -var - i: Integer; - KeyWordList: TStringList; -begin - Result := True; - - KeyWordList := TStringList.Create; - try - KeyWordList.Sorted := True; - KeyWordList.Duplicates := dupError; - - try - for i := 0 to KeyList.Count - 1 do - KeyWordList.Add(TLexKeys(KeyList[i]).KeyName); - except - Result := False; - Exit; - end; - finally - KeyWordList.Free; - end; - - for i := 0 to KeyList.Count - 1 do - if not IsASCIIAlphaNum(TLexKeys(KeyList[i]).KeyName) then - begin - Result := False; - Exit; - end; -end; - -end. - +{------------------------------------------------------------------------------- +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. + +The Original Code is: SynGenUnit.pas, released 2000-04-19. +Description: Generator for skeletons of HighLighters to use in SynEdit, +drived by a simple grammar. + +The Original Code is based on SynGenU.pas by Martin Waldenburg, part of +the mwEdit component suite. +Portions created by Martin Waldenburg are Copyright (C) 1998 Martin Waldenburg. +Portions created by Pieter Polak are Copyright (C) 2001 Pieter Polak. +Unicode translation by Mal Hrz. +All Rights Reserved. + +Contributors to the SynEdit and mwEdit projects are listed in the +Contributors.txt file. + +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. + +$Id: SynGenUnit.pas,v 1.18.2.11 2008/10/25 23:30:31 maelh Exp $ + +You may retrieve the latest version of this file at the SynEdit home page, +located at http://SynEdit.SourceForge.net + +Todo: + - Remember the last opened MSG file + - Double-click a MSG file opens SynGen + - Add user-defined default attributes to TSynXXXSyn.Create + - SynEdit to edit the MSG file (using the highlighter for MSG files) + - Store language names list and attribute names list in INI file + - SynEdit with Pascal highlighter to preview the created highlighter source + - Allow to define different type of keywords in MSG file + +Known Issues: +-------------------------------------------------------------------------------} + +unit SynGenUnit; + +{$I SynEdit.inc} + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + StdCtrls, GenLex, ComCtrls, Menus, SynUnicode; + +var + mKeyHashTable: array[#0..#255] of Integer; + mSKeyHashTable: array[#0..#255] of Integer; + +type + TLexKeys = class + public + KeyName: string; + Key: Cardinal; + TokenType: string; + end; + + TLexCharsets = class + public + SetName: string; + Charset: string; + ProcData: string; + FuncData: string; + end; + + TLexEnclosedBy = class + public + TokenName: string; + ProcName: string; + StartsWith: string; + EndsWith: string; + MultiLine: Boolean; + constructor Create; + end; + + TLexDefaultAttri = class + public + Style: string; + Foreground: string; + Background: string; + constructor Create; + end; + + TFormMain = class(TForm) + ButtonAdd: TButton; + ButtonDelete: TButton; + ButtonStart: TButton; + ComboBoxAttrIdentifier: TComboBox; + ComboBoxAttrReservedWord: TComboBox; + ComboBoxFilter: TComboBox; + ComboBoxLangName: TComboBox; + ComboBoxUnknownTokenAttr: TComboBox; + CheckBoxGetKeyWords: TCheckBox; + CheckBoxGPLHeader: TCheckBox; + EditAddField: TEdit; + EditAuthor: TEdit; + EditDescription: TEdit; + EditVersion: TEdit; + GrpAttrNames: TGroupBox; + LabelAuthor: TLabel; + LabelDescription: TLabel; + LabelFilter: TLabel; + LabelIdentifier: TLabel; + LabelLangName: TLabel; + LabelReservedWord: TLabel; + LabelUnknownTokenAttr: TLabel; + LabelVersion: TLabel; + ListBoxFields: TListBox; + MainMenu: TMainMenu; + MenuItemExit: TMenuItem; + MenuItemFile: TMenuItem; + MenuItemOpen: TMenuItem; + MenuItemStart: TMenuItem; + OpenDialog: TOpenDialog; + PageControl: TPageControl; + TabAttributes: TTabSheet; + TabFields: TTabSheet; + TabHighlighter: TTabSheet; + TabLanguage: TTabSheet; + procedure ButtonStartClick(Sender: TObject); + procedure FormCreate(Sender: TObject); + procedure FormDestroy(Sender: TObject); + procedure ComboBoxLangNameChange(Sender: TObject); + procedure ListBoxFieldsClick(Sender: TObject); + procedure ButtonAddClick(Sender: TObject); + procedure ButtonDeleteClick(Sender: TObject); + procedure EditAddFieldChange(Sender: TObject); + procedure EditAddFieldKeyPress(Sender: TObject; var Key: Char); + procedure MenuItemExitClick(Sender: TObject); + procedure MenuItemOpenClick(Sender: TObject); + procedure FormClose(Sender: TObject; var Action: TCloseAction); + private + FLexName: string; + FIdentPre: string; + FIdentStart: string; + FIdentContent: string; + FFileName: string; + FIniFile: string; + FOutFile: TextFile; + FSensitivity: Boolean; + FLexFileContents: UnicodeString; + FLex: TGenLex; + FKeyList: TList; + FSetList: TList; + FEnclosedList: TList; + FSampleSourceList: TStringList; + FIdentList: TStringList; + procedure ClearAll; + function GetFilterName: string; + function GetLangName: string; + function FilterInvalidChars(const Value: string): string; + procedure MakeHashTable; + procedure MakeSensitiveHashTable; + procedure FillKeyList; + procedure FillTokenTypeList; + procedure OutFileCreate(InName: string); + procedure ParseCharsets; + procedure ParseEnclosedBy; + procedure ParseSampleSource; + procedure RetrieveCharset; + procedure RetrieveEnclosedBy; + procedure RetrieveSampleSource; + procedure WriteSettings; + function PerformFileOpen: Boolean; + procedure WriteRest; + function KeywordsAreAllAlphaNumAndDifferent: Boolean; + function GetFriendlyLangName: string; + public + end; + +var + FormMain: TFormMain; + +implementation + +{$R *.DFM} + +uses +{$IFDEF SYN_COMPILER_6_UP} + StrUtils, +{$ENDIF} + Registry, HashTableGen; + +const + BoolStrs: array[Boolean] of string = ('False', 'True'); // Do not localize + +function CompareKeys(Item1, Item2: Pointer): Integer; +begin + Result := AnsiCompareStr(TLexKeys(Item1).KeyName, TLexKeys(Item2).KeyName); +end; + +function CompareSets(Item1, Item2: Pointer): Integer; +begin + Result := 0; + if TLexCharsets(Item1).SetName < TLexCharsets(Item2).SetName then + Result := -1 + else if TLexCharsets(Item1).SetName > TLexCharsets(Item2).SetName then + Result := 1; +end; + +function AddInt(const aValue: Integer): string; +begin + if (aValue < 0) then + Result := ' - ' + IntToStr(Abs(aValue)) + else if (aValue > 0) then + Result := ' + ' + IntToStr(aValue) + else + Result := ''; +end; + +function StuffString(const Value: UnicodeString): UnicodeString; +var + i: Integer; +begin + Result := ''; + for i := 1 to Length(Value) do + begin + if (Value[i] = '''') then + Result := Result + '''''' + else + Result := Result + Value[i]; + end; +end; + +function FirstLetterCap(S: UnicodeString): UnicodeString; +begin + Result := SynWideLowerCase(S); + if Length(Result) > 0 then + Result[1] := SynWideUpperCase(S[1])[1]; +end; + +{$IFNDEF SYN_COMPILER_6_UP} +function AnsiReplaceStr(const AText, AFromText, AToText: string): string; +begin + Result := StringReplace(AText, AFromText, AToText, [rfReplaceAll]); +end; +{$ENDIF} + +function ToAlphaNum(S: UnicodeString): UnicodeString; +var + c: Char; +begin + for c := #33 to #47 do + S := AnsiReplaceStr(S, c, IntToStr(Ord(c))); + + for c := #58 to #64 do + S := AnsiReplaceStr(S, c, IntToStr(Ord(c))); + + for c := #91 to #96 do + S := AnsiReplaceStr(S, c, IntToStr(Ord(c))); + + for c := #123 to #191 do + S := AnsiReplaceStr(S, c, IntToStr(Ord(c))); + + Result := S; +end; + +function IsASCIIAlphaNum(S: UnicodeString): Boolean; +var + i: Integer; +begin + Result := True; + + S := ToAlphaNum(S); + + for i := 1 to Length(S) do + case S[i] of + 'a'..'z', 'A'..'Z', '0'..'9', '_': ; + else + begin + Result := False; + Exit; + end; + end; +end; + +constructor TLexEnclosedBy.Create; +begin + inherited Create; + TokenName := ''; + ProcName := ''; + StartsWith := ''; + EndsWith := ''; + MultiLine := False; +end; + +constructor TLexDefaultAttri.Create; +begin + inherited Create; + Style := ''; + Foreground := ''; + Background := ''; +end; + +procedure TFormMain.MakeSensitiveHashTable; +var + I: Char; +begin + for I := #0 to #255 do + begin + case CharInSet(I, ['_', 'A'..'Z', 'a'..'z']) of + True: + begin + if (I > #64) and (I < #91) then + mSKeyHashTable[I] := Ord(I) - 64 + else if (I > #96) then + mSKeyHashTable[I] := Ord(I) - 95; + end; + else + mSKeyHashTable[I] := 0; + end; + end; +end; + +procedure TFormMain.MakeHashTable; +var + I, J: Char; +begin + for I := #0 to #255 do + begin + J := UpperCase(I)[1]; + case CharInSet(I, ['_', 'A'..'Z', 'a'..'z']) of + True: mKeyHashTable[I] := Ord(J) - 64; + else + mKeyHashTable[I] := 0; + end; + end; +end; + +procedure TFormMain.WriteSettings; +begin + with TRegIniFile.Create(FIniFile) do + try + WriteString('General', 'OpenDir', OpenDialog.InitialDir); + WriteBool(FFileName, 'GetKeyWords', CheckBoxGetKeyWords.Checked); + WriteBool(FFileName, 'CheckBoxGPLHeader', CheckBoxGPLHeader.Checked); + WriteString(FFileName, 'Author', EditAuthor.Text); + WriteString(FFileName, 'Description', EditDescription.Text); + WriteString(FFileName, 'Version', EditVersion.Text); + WriteString(FFileName, 'Filter', ComboBoxFilter.Text); + WriteString(FFileName, 'Language', ComboBoxLangName.Text); + WriteString(FFileName, 'AttrIdentifier', ComboBoxAttrIdentifier.Text); + WriteString(FFileName, 'AttrReservedWord', ComboBoxAttrReservedWord.Text); + WriteString(FFileName, 'UnknownTokenAttr', ComboBoxUnknownTokenAttr.Text); + WriteString(FFileName, 'Fields', ListBoxFields.Items.CommaText); + finally + Free; + end; +end; + +function TFormMain.PerformFileOpen: Boolean; +var + UserName: PChar; +{$IFDEF SYN_COMPILER_5_UP} + Count: Cardinal; +{$ELSE} + Count: Integer; +{$ENDIF} +begin + if OpenDialog.Execute then + begin + Count := 0; + Result := True; + FFileName := ExtractFileName(OpenDialog.FileName); + Caption := 'SynGen - ' + FFileName; + Application.Title := Caption; + OpenDialog.InitialDir := ExtractFilePath(OpenDialog.FileName); + GetUserName(nil, Count); + // retrieve the required size of the user name buffer + UserName := StrAlloc(Count); // allocate memory for the user name + GetUserName(UserName, Count); // retrieve the user name + with TRegIniFile.Create(FIniFile) do + try + EditAuthor.Text := ReadString(FFileName, 'Author', StrPas(UserName)); + EditDescription.Text := ReadString(FFileName, 'Description', + 'Syntax Parser/Highlighter'); + EditVersion.Text := ReadString(FFileName, 'Version', '0.1'); + ComboBoxFilter.Text := ReadString(FFileName, 'Filter', 'All files (*.*)|*.*'); + ComboBoxLangName.Text := ReadString(FFileName, 'Language', ''); + CheckBoxGetKeyWords.Checked := ReadBool(FFileName, 'GetKeyWords', True); + CheckBoxGPLHeader.Checked := ReadBool(FFileName, 'CheckBoxGPLHeader', True); + ComboBoxAttrIdentifier.ItemIndex := ComboBoxAttrIdentifier.Items.IndexOf + (ReadString(FFileName, 'AttrIdentifier', 'SYNS_AttrIdentifier')); + ComboBoxAttrReservedWord.ItemIndex := ComboBoxAttrReservedWord.Items.IndexOf + (ReadString(FFileName, 'AttrReservedWord', 'SYNS_AttrReservedWord')); + ComboBoxUnknownTokenAttr.ItemIndex := ComboBoxUnknownTokenAttr.Items.IndexOf + (ReadString(FFileName, 'UnknownTokenAttr', 'Identifier')); + ListBoxFields.Items.CommaText := ReadString(FFileName, 'Fields', ''); + finally + Free; + end; + StrDispose(UserName); + ComboBoxLangNameChange(Self); + end + else + Result := False; +end; + +procedure TFormMain.FormCreate(Sender: TObject); +var + i: Integer; + items: TStrings; +begin + for i := FormMain.ComponentCount - 1 downto 0 do + if FormMain.Components[i] is TComboBox then + if TComboBox(FormMain.Components[i]).Parent = GrpAttrNames then + begin + items := TComboBox(FormMain.Components[i]).Items; + items.Clear; + items.Add('SYNS_AttrAsm'); + items.Add('SYNS_AttrAsmComment'); + items.Add('SYNS_AttrAsmKey'); + items.Add('SYNS_AttrASP'); + items.Add('SYNS_AttrAssembler'); + items.Add('SYNS_AttrBlock'); + items.Add('SYNS_AttrBrackets'); + items.Add('SYNS_AttrCharacter'); + items.Add('SYNS_AttrClass'); + items.Add('SYNS_AttrComment'); + items.Add('SYNS_AttrCondition'); + items.Add('SYNS_AttrDir'); + items.Add('SYNS_AttrDirective'); + items.Add('SYNS_AttrDocumentation'); + items.Add('SYNS_AttrEmbedSQL'); + items.Add('SYNS_AttrEmbedText'); + items.Add('SYNS_AttrEscapeAmpersand'); + items.Add('SYNS_AttrForm'); + items.Add('SYNS_AttrFunction'); + items.Add('SYNS_AttrIcon'); + items.Add('SYNS_AttrIdentifier'); + items.Add('SYNS_AttrIllegalChar'); + items.Add('SYNS_AttrIndirect'); + items.Add('SYNS_AttrInvalidSymbol'); + items.Add('SYNS_AttrInternalFunction'); + items.Add('SYNS_AttrKey'); + items.Add('SYNS_AttrLabel'); + items.Add('SYNS_AttrMacro'); + items.Add('SYNS_AttrMarker'); + items.Add('SYNS_AttrMessage'); + items.Add('SYNS_AttrMiscellaneous'); + items.Add('SYNS_AttrNull'); + items.Add('SYNS_AttrNumber'); + items.Add('SYNS_AttrOperator'); + items.Add('SYNS_AttrPragma'); + items.Add('SYNS_AttrPreprocessor'); + items.Add('SYNS_AttrQualifier'); + items.Add('SYNS_AttrRegister'); + items.Add('SYNS_AttrReservedWord'); + items.Add('SYNS_AttrRpl'); + items.Add('SYNS_AttrRplKey'); + items.Add('SYNS_AttrRplComment'); + items.Add('SYNS_AttrSASM'); + items.Add('SYNS_AttrSASMComment'); + items.Add('SYNS_AttrSASMKey'); + items.Add('SYNS_AttrSecondReservedWord'); + items.Add('SYNS_AttrSection'); + items.Add('SYNS_AttrSpace'); + items.Add('SYNS_AttrSpecialVariable'); + items.Add('SYNS_AttrString'); + items.Add('SYNS_AttrSymbol'); + items.Add('SYNS_AttrSyntaxError'); + items.Add('SYNS_AttrSystem'); + items.Add('SYNS_AttrSystemValue'); + items.Add('SYNS_AttrText'); + items.Add('SYNS_AttrUnknownWord'); + items.Add('SYNS_AttrUser'); + items.Add('SYNS_AttrUserFunction'); + items.Add('SYNS_AttrValue'); + items.Add('SYNS_AttrVariable'); + end; + PageControl.ActivePage := PageControl.Pages[0]; + FLex := TGenLex.Create; + FKeyList := TList.Create; + FSetList := TList.Create; + FEnclosedList := TList.Create; + FSampleSourceList := TStringList.Create; + FIdentList := TStringList.Create; + // read ini file + FIniFile := Copy(ExtractFileName(Application.ExeName), 0, + Length(ExtractFileName(Application.ExeName)) - + Length(ExtractFileExt(Application.ExeName))) + '.ini'; + with TRegIniFile.Create(FIniFile) do + try + OpenDialog.InitialDir := ReadString('General', 'OpenDir', + ExtractFilePath(Application.ExeName)); + finally + Free; + end; + + { Move form off the screen, but show already, to activate it correctly when + OpenFileDialog is closed with OK. } + Left := -10000; + Show; + if PerformFileOpen then + begin + MakeHashTable; + MakeSensitiveHashTable; + Position := poScreenCenter; // move form on the screen ("make visible") + end + else + Application.Terminate +end; + +procedure TFormMain.ClearAll; +var + I: Integer; +begin + // Clear the contents of FKeyList + for I := 0 to (FKeyList.Count - 1) do + TObject(FKeyList[I]).Free; + FKeyList.Clear; + // Clear the contents of FSetList + for I := 0 to (FSetList.Count - 1) do + TObject(FSetList[I]).Free; + FSetList.Clear; + // Clear the contents of FEnclosedList + for I := 0 to (FEnclosedList.Count - 1) do + TObject(FEnclosedList[I]).Free; + FEnclosedList.Clear; + // Clear the contents of FIdentList + for I := 0 to (FIdentList.Count - 1) do + begin + if Assigned(FIdentList.Objects[I]) then + TObject(FIdentList.Objects[I]).Free; + end; + FIdentList.Clear; + // Clear the contents of FSampleSourceList + FSampleSourceList.Clear; +end; + +procedure TFormMain.FormDestroy(Sender: TObject); +begin + ClearAll; + FLex.Free; + FIdentList.Free; + FKeyList.Free; + FSetList.Free; + FEnclosedList.Free; +end; + +procedure TFormMain.ButtonStartClick(Sender: TObject); +var + LexFileLines: TUnicodeStringList; +begin + ClearAll; + + Screen.Cursor := crHourGlass; + + LexFileLines := TUnicodeStringList.Create; + try + LexFileLines.LoadFromFile(OpenDialog.FileName); + FLexFileContents := LexFileLines.Text; + finally + LexFileLines.Free; + end; + FLex.Origin := PWideChar(FLexFileContents); + FLex.Tokenize; + + while FLex.RunId <> IDIdentifier do + FLex.Next; + FLexName := FLex.RunToken; + + FLex.Next; + while FLex.RunId <> IDIdentifier do + FLex.Next; + FIdentPre := FLex.RunToken; + + OutFileCreate(OpenDialog.FileName); + try + while not (FLex.RunId in [IdSensitive, IdIdentStart]) do + FLex.Next; + + if FLex.RunId = IdSensitive then + FSensitivity := True + else + FSensitivity := False; + FLex.Next; + + while FLex.RunId <> IDCharSet do + FLex.Next; + FIdentStart := FLex.RunToken; + FLex.Next; + + while FLex.RunId <> IDNull do + begin + case FLex.RunId of + IDCharSet: FIdentContent := FLex.RunToken; + IDKeys: FillKeyList; + IDTokenTypes: FillTokenTypeList; + IDChars: ParseCharSets; + IDEnclosedBy: ParseEnclosedBy; + IDSampleSource: ParseSampleSource; + end; + FLex.Next; + end; + + if (FKeyList.Count = 0) then + raise Exception.Create('You should specify at least 1 keyword!'); + if (FIdentList.Count = 0) then + raise Exception.Create('You should specify at least 1 token type'); + if not KeywordsAreAllAlphaNumAndDifferent then + raise Exception.Create('One or more keywords contain unhandable characters'); + + FrmHashTableGen.AssignKeyWords(FKeyList, FSensitivity); + FrmHashTableGen.ShowModal; + + WriteRest; + while (FLex.RunId <> IdNull) do + begin + FLex.Next; + end; + finally + Screen.Cursor := crDefault; + CloseFile(FOutFile); + end; + MessageDlg(FLexName + ' created on ' + DateTimeToStr(Now), mtInformation, + [mbOk], 0); +end; + +procedure TFormMain.FillKeyList; +var + aLexKey: TLexKeys; + aString: string; + aTokenType: string; +begin + FLex.Next; + + aTokenType := ''; + while FLex.RunId <> IdCRLF do + begin + if not (FLex.RunId in [IdSpace, IdBraceOpen]) then + aTokenType := aTokenType + FLex.RunToken; + FLex.Next; + end; + + if (aTokenType = '') then + aTokenType := 'Key'; + + while FLex.RunId <> IdStop do + begin + while FLex.RunId in [IdSpace, IdBraceOpen, IdCRLF] do + FLex.Next; + if FLex.RunId <> IdStop then + begin + aString := ''; + while not (FLex.RunId in [IdSpace, IdBraceOpen, IdCRLF]) do + begin + aString := aString + FLex.RunToken; + FLex.Next; + end; + aLexKey := TLexKeys.Create; + aLexKey.TokenType := aTokenType; + aLexKey.KeyName := aString; + FKeyList.Add(aLexKey); + end + else + Break; + FLex.Next; + end; + FKeyList.Sort(CompareKeys); +end; + +procedure TFormMain.FillTokenTypeList; +var + i: Integer; + List: TStringList; + sIdent: string; + sLine: string; + DefAttri: TLexDefaultAttri; +begin + FLex.Next; + FIdentList.Add(FIdentPre + 'Unknown'); + FIdentList.Add(FIdentPre + 'Null'); + while (FLex.RunId <> IdStop) do + begin + while FLex.RunId in [IdSpace, IdBraceOpen, IdCRLF, IDUnknown] do + FLex.Next; + if (FLex.RunId <> IdStop) then + begin + sIdent := FIdentPre + FLex.RunToken; + if not IsValidIdent(sIdent) then + raise Exception.Create('Invalid identifier for token type: ' + sIdent); + + if (FIdentList.IndexOf(sIdent) < 0) then + FIdentList.Add(sIdent); + FLex.Next; + + sLine := ''; + while (FLex.RunId = IdSpace) do + FLex.Next; + while not (FLex.RunId in [IdStop, IdCRLF]) do + begin { is there more data on this line? } + sLine := sLine + FLex.RunToken; + FLex.Next; + end; + + if (sLine <> '') then { The Msg file specifies default attributes } + begin + List := TStringList.Create; + try + while (sLine <> '') do + begin + i := Pos('|', sLine); + if (i > 0) then + begin + List.Add(Copy(sLine, 1, i - 1)); + Delete(sLine, 1, i); + end + else + begin + List.Add(sLine); + sLine := ''; + end; + end; + + i := FIdentList.IndexOf(sIdent); + if (i >= 0) then + begin + DefAttri := TLexDefaultAttri.Create; + DefAttri.Style := List.Values['Style']; + DefAttri.Foreground := List.Values['Foreground']; + DefAttri.Background := List.Values['Background']; + FIdentList.Objects[i] := DefAttri; + end; + finally + List.Free; + end; + end; + end + else + Break; + end; +end; + +procedure TFormMain.OutFileCreate(InName: string); +var + OutName, UName: string; + sysTime: TSystemTime; + ISODate: string; +begin + OutName := ChangeFileExt(InName, '.pas'); + Uname := ExtractFileName(ChangeFileExt(InName, '')); + AssignFile(FOutFile, OutName); + rewrite(FOutFile); + GetSystemTime(sysTime); + ISODate := Format('%.4d-%.2d-%.2d', [sysTime.wYear, sysTime.wMonth, + sysTime.wDay]); + if CheckBoxGPLHeader.Checked then + begin + Writeln(FOutFile, + '{-------------------------------------------------------------------------------'); + Writeln(FOutFile, + 'The contents of this file are subject to the Mozilla Public License'); + Writeln(FOutFile, + 'Version 1.1 (the "License"); you may not use this file except in compliance'); + Writeln(FOutFile, + 'with the License. You may obtain a copy of the License at'); + Writeln(FOutFile, 'http://www.mozilla.org/MPL/'); + Writeln(FOutFile); + Writeln(FOutFile, + 'Software distributed under the License is distributed on an "AS IS" basis,'); + Writeln(FOutFile, + 'WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for'); + Writeln(FOutFile, + 'the specific language governing rights and limitations under the License.'); + Writeln(FOutFile); + Writeln(FOutFile, 'Code template generated with SynGen.'); + Writeln(FOutFile, 'The original code is: ' + OutName + ', released ' + ISODate + + '.'); + Writeln(FOutFile, 'Description: ' + EditDescription.Text); + Writeln(FOutFile, 'The initial author of this file is ' + EditAuthor.Text + + '.'); + Writeln(FOutFile, 'Copyright (c) ' + Format('%d', [sysTime.wYear]) + + ', all rights reserved.'); + Writeln(FOutFile); + Writeln(FOutFile, + 'Contributors to the SynEdit and mwEdit projects are listed in the'); + Writeln(FOutFile, 'Contributors.txt file.'); + Writeln(FOutFile); + Writeln(FOutFile, + 'Alternatively, the contents of this file may be used under the terms of the'); + Writeln(FOutFile, + 'GNU General Public License Version 2 or later (the "GPL"), in which case'); + Writeln(FOutFile, + 'the provisions of the GPL are applicable instead of those above.'); + Writeln(FOutFile, + 'If you wish to allow use of your version of this file only under the terms'); + Writeln(FOutFile, + 'of the GPL and not to allow others to use your version of this file'); + Writeln(FOutFile, + 'under the MPL, indicate your decision by deleting the provisions above and'); + Writeln(FOutFile, + 'replace them with the notice and other provisions required by the GPL.'); + Writeln(FOutFile, + 'If you do not delete the provisions above, a recipient may use your version'); + Writeln(FOutFile, 'of this file under either the MPL or the GPL.'); + Writeln(FOutFile); + Writeln(FOutFile, '$' + 'Id: ' + '$'); + Writeln(FOutFile); + Writeln(FOutFile, + 'You may retrieve the latest version of this file at the SynEdit home page,'); + Writeln(FOutFile, 'located at http://SynEdit.SourceForge.net'); + Writeln(FOutFile); + Writeln(FOutFile, + '-------------------------------------------------------------------------------}'); + end + else + begin + Writeln(FOutFile, + '{+-----------------------------------------------------------------------------+'); + Writeln(FOutFile, ' | Class: ' + FLexName); + Writeln(FOutFile, ' | Created: ' + ISODate); + Writeln(FOutFile, ' | Last change: ' + ISODate); + Writeln(FOutFile, ' | Author: ' + EditAuthor.Text); + Writeln(FOutFile, ' | Description: ' + EditDescription.Text); + Writeln(FOutFile, ' | Version: ' + EditVersion.Text); + Writeln(FOutFile, ' |'); + Writeln(FOutFile, ' | Copyright (c) ' + Format('%d', [sysTime.wYear]) + #32 + + EditAuthor.Text + '. All rights reserved.'); + Writeln(FOutFile, ' |'); + Writeln(FOutFile, ' | Generated with SynGen.'); + Writeln(FOutFile, + ' +----------------------------------------------------------------------------+}'); + end; + Writeln(FOutFile); + Writeln(FOutFile, 'unit ' + Uname + ';'); + Writeln(FOutFile); + Writeln(FOutFile, '{$I SynEdit.inc}'); + Writeln(FOutFile); + Writeln(FOutFile, 'interface'); + Writeln(FOutFile); + Writeln(FOutFile, 'uses'); + Writeln(FOutFile, ' Graphics,'); + Writeln(FOutFile, ' SynEditTypes,'); + Writeln(FOutFile, ' SynEditHighlighter,'); + Writeln(FOutFile, ' SynUnicode,'); + Writeln(FOutFile, ' SysUtils,'); + Writeln(FOutFile, ' Classes;'); + Writeln(FOutFile); + Writeln(FOutFile, 'type'); + Writeln(FOutFile, ' T' + FIdentPre + 'TokenKind = ('); +end; + +procedure TFormMain.ParseCharsets; +begin + FLex.Next; + while FLex.RunId <> IdStop do + begin + case FLex.RunId of + IdCharset: RetrieveCharset; + else + FLex.Next; + end; + end; +end; + +procedure TFormMain.ParseEnclosedBy; +begin + FLex.Next; + while not (FLex.RunId in [IdStop, IdNull]) do + RetrieveEnclosedBy; +end; + +procedure TFormMain.ParseSampleSource; +begin + FLex.Next; + if (FLex.RunId = IdCRLF) then + FLex.Next; + + while not (FLex.RunId in [IdStop, IdNull]) do + RetrieveSampleSource; +end; + +procedure TFormMain.RetrieveCharset; +var + aSet: TLexCharsets; +begin + aSet := TLexCharsets.Create; + aSet.Charset := FLex.RunToken; + while FLex.RunId <> IDIdentifier do + FLex.Next; + aSet.SetName := FLex.RunToken; + while FLex.RunId <> IDBeginProc do + FLex.Next; + FLex.Next; + while FLex.RunId in [IdCRLF, IdSpace] do + FLex.Next; + while not (FLex.RunId = IdEndProc) do + begin + aSet.ProcData := aSet.ProcData + FLex.RunToken; + FLex.Next; + end; + FSetList.Add(aSet); + FLex.Next; +end; + +procedure TFormMain.RetrieveSampleSource; +var + sLine: string; +begin + sLine := ''; + while not (FLex.RunId in [IdCRLF, IdNull, IdStop]) do + begin + sLine := sLine + FLex.RunToken; + FLex.Next; + end; + if (FLex.RunId = IdCRLF) then + FLex.Next; + + FSampleSourceList.Add(sLine); +end; + +procedure TFormMain.RetrieveEnclosedBy; +var + aThing: TLexEnclosedBy; + sLine: string; + iPos: Integer; +begin + while FLex.RunId in [IdCRLF, IdSpace] do + FLex.Next; + + sLine := ''; + while not (FLex.RunId in [IdCRLF, IdNull, IdStop]) do + begin + sLine := sLine + FLex.RunToken; + FLex.Next; + end; + + if (sLine <> '') then + begin + aThing := TLexEnclosedBy.Create; + + iPos := Pos(',', sLine); + aThing.TokenName := Copy(sLine, 1, iPos - 1); + Delete(sLine, 1, iPos); + + iPos := Pos(',', sLine); + aThing.ProcName := Copy(sLine, 1, iPos - 1); + Delete(sLine, 1, iPos); + + iPos := Pos(',', sLine); + aThing.StartsWith := Copy(sLine, 1, iPos - 1); + Delete(sLine, 1, iPos); + + iPos := Pos(',', sLine); + if (iPos > 0) then + begin + aThing.EndsWith := Copy(sLine, 1, iPos - 1); + Delete(sLine, 1, iPos); + if (Pos('MULTILINE', UpperCase(sLine)) = 1) then + aThing.MultiLine := True; + end + else + aThing.EndsWith := sLine; + + FEnclosedList.Add(aThing); + end + else if (FLex.RunId <> IdStop) then + FLex.Next; +end; { RetrieveEnclosedBy } + +function TFormMain.FilterInvalidChars(const Value: string): string; +var + i: Integer; +begin + Result := ''; + for i := 1 to Length(Value) do + begin + if IsValidIdent(Result + Value[i]) then + Result := Result + Value[i]; + end; +end; { FilterInvalidChars } + +function TFormMain.GetFilterName: string; +var + FilterName: string; +begin + FilterName := ''; + case ComboBoxFilter.ItemIndex of + -1: FilterName := 'SYNS_Filter' + FilterInvalidChars(ComboBoxLangName.Text); + 0: FilterName := 'SYNS_FilterPascal'; + 1: FilterName := 'SYNS_FilterHP48'; + 2: FilterName := 'SYNS_FilterCAClipper'; + 3: FilterName := 'SYNS_FilterCPP'; + 4: FilterName := 'SYNS_FilterJava'; + 5: FilterName := 'SYNS_FilterPerl'; + 6: FilterName := 'SYNS_FilterAWK'; + 7: FilterName := 'SYNS_FilterHTML'; + 8: FilterName := 'SYNS_FilterVBScript'; + 9: FilterName := 'SYNS_FilterGalaxy'; + 10: FilterName := 'SYNS_FilterPython'; + 11: FilterName := 'SYNS_FilterSQL'; + 12: FilterName := 'SYNS_FilterTclTk'; + 13: FilterName := 'SYNS_FilterRTF'; + 14: FilterName := 'SYNS_FilterBatch'; + 15: FilterName := 'SYNS_FilterDFM'; + 16: FilterName := 'SYNS_FilterX86Asm'; + 17: FilterName := 'SYNS_FilterGembase'; + 18: FilterName := 'SYNS_FilterINI'; + 19: FilterName := 'SYNS_FilterML'; + 20: FilterName := 'SYNS_FilterVisualBASIC'; + 21: FilterName := 'SYNS_FilterADSP21xx'; + 22: FilterName := 'SYNS_FilterPHP'; + 23: FilterName := 'SYNS_FilterCache'; + 24: FilterName := 'SYNS_FilterCSS'; + 25: FilterName := 'SYNS_FilterJScript'; + 26: FilterName := 'SYNS_FilterKIX'; + 27: FilterName := 'SYNS_FilterBaan'; + 28: FilterName := 'SYNS_FilterFoxpro'; + 29: FilterName := 'SYNS_FilterFortran'; + 30: FilterName := 'SYNS_FilterAsm68HC11'; + end; + Result := FilterName; +end; + +function TFormMain.GetFriendlyLangName: string; +var + LangName: string; +begin + case ComboBoxLangName.ItemIndex of + -1: LangName := 'SYNS_FriendlyLang' + FilterInvalidChars(ComboBoxLangName.Text); + 0: LangName := 'SYNS_FriendlyLangHP48'; + 1: LangName := 'SYNS_FriendlyLangCAClipper'; + 2: LangName := 'SYNS_FriendlyLangCPP'; + 3: LangName := 'SYNS_FriendlyLangJava'; + 4: LangName := 'SYNS_FriendlyLangPerl'; + 5: LangName := 'SYNS_FriendlyLangBatch'; + 6: LangName := 'SYNS_FriendlyLangDfm'; + 7: LangName := 'SYNS_FriendlyLangAWK'; + 8: LangName := 'SYNS_FriendlyLangHTML'; + 9: LangName := 'SYNS_FriendlyLangVBSScript'; + 10: LangName := 'SYNS_FriendlyLangGalaxy'; + 11: LangName := 'SYNS_FriendlyLangGeneral'; + 12: LangName := 'SYNS_FriendlyLangPascal'; + 13: LangName := 'SYNS_FriendlyLangX86Asm'; + 14: LangName := 'SYNS_FriendlyLangPython'; + 15: LangName := 'SYNS_FriendlyLangTclTk'; + 16: LangName := 'SYNS_FriendlyLangSQL'; + 17: LangName := 'SYNS_FriendlyLangGembase'; + 18: LangName := 'SYNS_FriendlyLangINI'; + 19: LangName := 'SYNS_FriendlyLangML'; + 20: LangName := 'SYNS_FriendlyLangVisualBASIC'; + 21: LangName := 'SYNS_FriendlyLangADSP21xx'; + 22: LangName := 'SYNS_FriendlyLangPHP'; + 23: LangName := 'SYNS_FriendlyLangSybaseSQL'; + 24: LangName := 'SYNS_FriendlyLangGeneralMulti'; + 25: LangName := 'SYNS_FriendlyLangCache'; + 26: LangName := 'SYNS_FriendlyLangCSS'; + 27: LangName := 'SYNS_FriendlyLangJScript'; + 28: LangName := 'SYNS_FriendlyLangKIX'; + 29: LangName := 'SYNS_FriendlyLangBaan'; + 30: LangName := 'SYNS_FriendlyLangFoxpro'; + 31: LangName := 'SYNS_FriendlyLangFortran'; + 32: LangName := 'SYNS_FriendlyLang68HC11'; + end; + Result := LangName; +end; + +function TFormMain.GetLangName: string; +var + LangName: string; +begin + case ComboBoxLangName.ItemIndex of + -1: LangName := 'SYNS_Lang' + FilterInvalidChars(ComboBoxLangName.Text); + 0: LangName := 'SYNS_LangHP48'; + 1: LangName := 'SYNS_LangCAClipper'; + 2: LangName := 'SYNS_LangCPP'; + 3: LangName := 'SYNS_LangJava'; + 4: LangName := 'SYNS_LangPerl'; + 5: LangName := 'SYNS_LangBatch'; + 6: LangName := 'SYNS_LangDfm'; + 7: LangName := 'SYNS_LangAWK'; + 8: LangName := 'SYNS_LangHTML'; + 9: LangName := 'SYNS_LangVBSScript'; + 10: LangName := 'SYNS_LangGalaxy'; + 11: LangName := 'SYNS_LangGeneral'; + 12: LangName := 'SYNS_LangPascal'; + 13: LangName := 'SYNS_LangX86Asm'; + 14: LangName := 'SYNS_LangPython'; + 15: LangName := 'SYNS_LangTclTk'; + 16: LangName := 'SYNS_LangSQL'; + 17: LangName := 'SYNS_LangGembase'; + 18: LangName := 'SYNS_LangINI'; + 19: LangName := 'SYNS_LangML'; + 20: LangName := 'SYNS_LangVisualBASIC'; + 21: LangName := 'SYNS_LangADSP21xx'; + 22: LangName := 'SYNS_LangPHP'; + 23: LangName := 'SYNS_LangSybaseSQL'; + 24: LangName := 'SYNS_LangGeneralMulti'; + 25: LangName := 'SYNS_LangCache'; + 26: LangName := 'SYNS_LangCSS'; + 27: LangName := 'SYNS_LangJScript'; + 28: LangName := 'SYNS_LangKIX'; + 29: LangName := 'SYNS_LangBaan'; + 30: LangName := 'SYNS_LangFoxpro'; + 31: LangName := 'SYNS_LangFortran'; + 32: LangName := 'SYNS_Lang68HC11'; + end; + Result := LangName; +end; + +procedure TFormMain.WriteRest; +var + I, J: Integer; + LineLength: Integer; + KeyString: string; + AttrName: string; + FriendlyAttrName: string; + AttrTemp: string; + TempStringList: TStringList; + sPrefix: string; + DefAttri: TLexDefaultAttri; +begin + FIdentList.Sort; + FSetList.Sort(CompareSets); + I := 0; + while I < FIdentList.Count - 1 do + begin + Writeln(FOutFile, ' ' + FIdentList[I] + ','); + inc(I); + end; + Writeln(FOutFile, ' ' + FIdentList[I] + ');'); + Writeln(FOutFile); + Write(FOutFile, ' TRangeState = (rsUnknown'); + for I := 0 to (FEnclosedList.Count - 1) do + Write(FOutFile, ', rs' + TLexEnclosedBy(FEnclosedList[I]).ProcName); + Writeln(FOutFile, ');'); + Writeln(FOutFile); + Writeln(FOutFile, ' TProcTableProc = procedure of object;'); + Writeln(FOutFile); + Writeln(FOutFile, ' PIdentFuncTableFunc = ^TIdentFuncTableFunc;'); + Writeln(FOutFile, ' TIdentFuncTableFunc = function (Index: Integer): T' + FIdentPre + + 'TokenKind of object;'); + Writeln(FOutFile); + + Writeln(FOutFile, 'type'); + Writeln(FOutFile, ' ' + FLexName + ' = class(TSynCustomHighlighter)'); + Writeln(FOutFile, ' private'); + Writeln(FOutFile, ' FRange: TRangeState;'); + + if ListBoxFields.Items.Count > 0 then + for i := 0 to ListBoxFields.Items.Count - 1 do + Writeln(FOutFile, ' ' + ListBoxFields.Items[i] + ';'); + + Writeln(FOutFile, ' FTokenId: TtkTokenKind;'); + Writeln(FOutFile, + ' fIdentFuncTable: array[0..' + + IntToStr(FrmHashTableGen.KeyIndicesCount - 1) + ']' + + ' of TIdentFuncTableFunc;'); + + I := 0; + while I < FIdentList.Count do + begin + if (FIdentList[I] <> FIdentPre + 'Null') and (FIdentList[I] <> FIdentPre + + 'Unknown') then + Writeln(FOutFile, ' f' + Copy(FIdentList[I], Length(FIdentPre) + 1, + Length(FIdentList[I])) + 'Attri: TSynHighlighterAttributes;'); + inc(I); + end; + + Writeln(FOutFile, ' function HashKey(Str: PWideChar): Cardinal;'); + + I := 0; + while I < FKeyList.Count do + begin + Writeln(FOutFile, AnsiString(' function Func' + + ToAlphaNum(FirstLetterCap(TLexKeys(FKeyList[I]).KeyName)) + + '(Index: Integer): T' + FIdentPre + 'TokenKind;')); + inc(I); + end; + + I := 0; + while I < FSetList.Count do + begin + Writeln(FOutFile, ' procedure ' + TLexCharsets(FSetList[I]).SetName + + 'Proc;'); + inc(I); + end; + + Writeln(FOutFile, ' procedure UnknownProc;'); + Writeln(FOutFile, ' function AltFunc(Index: Integer): T' + FIdentPre + 'TokenKind;'); + Writeln(FOutFile, ' procedure InitIdent;'); + Writeln(FOutFile, ' function IdentKind(MayBe: PWideChar): T' + FIdentPre + + 'TokenKind;'); + Writeln(FOutFile, ' procedure NullProc;'); + if (FIdentList.IndexOf(FIdentPre + 'Space') >= 0) then + Writeln(FOutFile, ' procedure SpaceProc;'); + Writeln(FOutFile, ' procedure CRProc;'); + Writeln(FOutFile, ' procedure LFProc;'); + for I := 0 to (FEnclosedList.Count - 1) do + begin + Writeln(FOutFile, ' procedure ' + TLexEnclosedBy(FEnclosedList[I]).ProcName + + 'OpenProc;'); + Writeln(FOutFile, ' procedure ' + TLexEnclosedBy(FEnclosedList[I]).ProcName + + 'Proc;'); + end; + Writeln(FOutFile, ' protected'); + Writeln(FOutFile, ' function GetSampleSource: UnicodeString; override;'); + Writeln(FOutFile, ' function IsFilterStored: Boolean; override;'); + Writeln(FOutFile, ' public'); + Writeln(FOutFile, ' constructor Create(AOwner: TComponent); override;'); + Writeln(FOutFile, ' class function GetFriendlyLanguageName: UnicodeString; override;'); + Writeln(FOutFile, ' class function GetLanguageName: string; override;'); + Writeln(FOutFile, ' function GetRange: Pointer; override;'); + Writeln(FOutFile, ' procedure ResetRange; override;'); + Writeln(FOutFile, ' procedure SetRange(Value: Pointer); override;'); + Writeln(FOutFile, + ' function GetDefaultAttribute(Index: Integer): TSynHighlighterAttributes; override;'); + Writeln(FOutFile, ' function GetEol: Boolean; override;'); + if CheckBoxGetKeyWords.Checked then + Writeln(FOutFile, ' function GetKeyWords(TokenKind: Integer): UnicodeString; override;'); + Writeln(FOutFile, ' function GetTokenID: TtkTokenKind;'); + Writeln(FOutFile, + ' function GetTokenAttribute: TSynHighlighterAttributes; override;'); + Writeln(FOutFile, ' function GetTokenKind: Integer; override;'); + Writeln(FOutFile, ' function IsIdentChar(AChar: WideChar): Boolean; override;'); + Writeln(FOutFile, ' procedure Next; override;'); + Writeln(FOutFile, ' published'); + + I := 0; + while I < FIdentList.Count do + begin + if (FIdentList[I] <> FIdentPre + 'Null') and (FIdentList[I] <> FIdentPre + + 'Unknown') then + Writeln(FOutFile, ' property ' + Copy(FIdentList[I], Length(FIdentPre) + + 1, Length(FIdentList[I])) + + 'Attri: TSynHighlighterAttributes read f' + Copy(FIdentList[I], + Length(FIdentPre) + 1, Length(FIdentList[I])) + + 'Attri write f' + Copy(FIdentList[I], Length(FIdentPre) + 1, + Length(FIdentList[I])) + 'Attri;'); + inc(I); + end; + + Writeln(FOutFile, ' end;'); + Writeln(FOutFile); + Writeln(FOutFile, 'implementation'); + Writeln(FOutFile); + Writeln(FOutFile, 'uses'); + Writeln(FOutFile, ' SynEditStrConst;'); + Writeln(FOutFile); + if (ComboBoxFilter.ItemIndex = -1) or (ComboBoxLangName.ItemIndex = -1) then + begin + Writeln(FOutFile, 'resourcestring'); + if (ComboBoxFilter.ItemIndex = -1) then + Writeln(FOutFile, ' SYNS_Filter' + FilterInvalidChars(ComboBoxLangName.Text) + + ' = ''' + ComboBoxFilter.Text + ''';'); + if (ComboBoxLangName.ItemIndex = -1) then + begin + Writeln(FOutFile, ' SYNS_Lang' + FilterInvalidChars(ComboBoxLangName.Text) + + ' = ''' + ComboBoxLangName.Text + ''';'); + + Writeln(FOutFile, ' SYNS_FriendlyLang' + FilterInvalidChars(ComboBoxLangName.Text) + + ' = ''' + ComboBoxLangName.Text + ''';'); + end; + + I := 0; + while I < FIdentList.Count do + begin + AttrTemp := Copy(FIdentList[I], Length(FIdentPre) + 1, + Length(FIdentList[I])); + if (ComboBoxAttrIdentifier.Items.IndexOf('SYNS_Attr' + AttrTemp) < 0) and + (AttrTemp <> 'Unknown') then + begin + Writeln(FOutFile, ' SYNS_Attr' + FilterInvalidChars(AttrTemp) + ' = ''' + + AttrTemp + ''';'); + Writeln(FOutFile, ' SYNS_FriendlyAttr' + FilterInvalidChars(AttrTemp) + ' = ''' + + AttrTemp + ''';'); + end; + Inc(i); + end; + Writeln(FOutFile); + end; + + Writeln(FOutFile, 'const'); + Write(FOutFile, FrmHashTableGen.GetKeyWordConstantsSource(FSensitivity)); + Writeln(FOutFile); + + Writeln(FOutFile, 'procedure ' + FLexName + '.InitIdent;'); + Writeln(FOutFile, 'var'); + Writeln(FOutFile, ' i: Integer;'); + Writeln(FOutFile, 'begin'); + Writeln(FOutFile, ' for i := Low(fIdentFuncTable) to High(fIdentFuncTable) do'); + Writeln(FOutFile, ' if KeyIndices[i] = -1 then'); + Writeln(FOutFile, ' fIdentFuncTable[i] := AltFunc;'); + Writeln(FOutFile, ''); + + I := 0; + while I < FKeyList.Count do + begin + if I < FKeyList.Count - 1 then + while TLexKeys(FKeyList[I]).Key = TLexKeys(FKeyList[I + 1]).Key do + begin + inc(I); + if I >= FKeyList.Count - 1 then + break; + end; + KeyString := IntToStr(TLexKeys(FKeyList[I]).Key); + Writeln(FOutFile, ' fIdentFuncTable[' + KeyString + '] := Func' + + ToAlphaNum(FirstLetterCap(TLexKeys(FKeyList[I]).KeyName)) + ';'); + inc(I); + end; + + Writeln(FOutFile, 'end;'); + Writeln(FOutFile); + + Write(FOutFile, FrmHashTableGen.GetHashKeyFunctionSource(FLexName)); + Writeln(FOutFile); + + I := 0; + while I < FKeyList.Count do + begin + KeyString := ToAlphaNum(FirstLetterCap(TLexKeys(FKeyList[I]).KeyName)); + Writeln(FOutFile, 'function ' + FLexName + '.Func' + KeyString + '(Index: Integer): T' + + FIdentPre + 'TokenKind;'); + Writeln(FOutFile, 'begin'); + if I < FKeyList.Count - 1 then + while TLexKeys(FKeyList[I]).Key = TLexKeys(FKeyList[I + 1]).Key do + begin + Writeln(FOutFile, ' if IsCurrentToken(KeyWords[Index]) then'); + Writeln(FOutFile, ' Result := ' + FIdentPre + TLexKeys(FKeyList[I]).TokenType); + Writeln(FOutFile, ' else'); + inc(I); + if I >= FKeyList.Count - 1 then + break; + end; + Writeln(FOutFile, ' if IsCurrentToken(KeyWords[Index]) then'); + Writeln(FOutFile, ' Result := ' + FIdentPre + TLexKeys(FKeyList[I]).TokenType); + Writeln(FOutFile, ' else'); + Writeln(FOutFile, ' Result := ' + FIdentPre + 'Identifier;'); + Writeln(FOutFile, 'end;'); + Writeln(FOutFile); + inc(I); + end; + + Writeln(FOutFile, 'function ' + FLexName + '.AltFunc(Index: Integer): T' + FIdentPre + + 'TokenKind;'); + Writeln(FOutFile, 'begin'); + Writeln(FOutFile, ' Result := ' + FIdentPre + 'Identifier;'); + Writeln(FOutFile, 'end;'); + Writeln(FOutFile); + + Writeln(FOutFile, 'function ' + FLexName + '.IdentKind(MayBe: PWideChar): T' + + FIdentPre + 'TokenKind;'); + Writeln(FOutFile, 'var'); + Writeln(FOutFile, ' Key: Cardinal;'); + Writeln(FOutFile, 'begin'); + Writeln(FOutFile, ' fToIdent := MayBe;'); + Writeln(FOutFile, ' Key := HashKey(MayBe);'); + Writeln(FOutFile, ' if Key <= High(fIdentFuncTable) then'); + Writeln(FOutFile, ' Result := FIdentFuncTable[Key](KeyIndices[Key])'); + Writeln(FOutFile, ' else'); + Writeln(FOutFile, ' Result := ' + FIdentPre + 'Identifier;'); + Writeln(FOutFile, 'end;'); + Writeln(FOutFile); + + if (FIdentList.IndexOf(FIdentPre + 'Space') >= 0) then + begin + Writeln(FOutFile, 'procedure ' + FLexName + '.SpaceProc;'); + Writeln(FOutFile, 'begin'); + Writeln(FOutFile, ' inc(Run);'); + Writeln(FOutFile, ' FTokenId := ' + FIdentPre + 'Space;'); + Writeln(FOutFile, ' while (FLine[Run] <= #32) and not IsLineEnd(Run) do inc(Run);'); + Writeln(FOutFile, 'end;'); + Writeln(FOutFile); + end; + + Writeln(FOutFile, 'procedure ' + FLexName + '.NullProc;'); + Writeln(FOutFile, 'begin'); + Writeln(FOutFile, ' FTokenId := ' + FIdentPre + 'Null;'); + Writeln(FOutFile, ' inc(Run);'); + Writeln(FOutFile, 'end;'); + Writeln(FOutFile); + + Writeln(FOutFile, 'procedure ' + FLexName + '.CRProc;'); + Writeln(FOutFile, 'begin'); + if (FIdentList.IndexOf(FIdentPre + 'Space') >= 0) then + Writeln(FOutFile, ' FTokenId := ' + FIdentPre + 'Space;') + else + Writeln(FOutFile, ' FTokenId := ' + FIdentPre + 'Unknown;'); + Writeln(FOutFile, ' inc(Run);'); + Writeln(FOutFile, ' if FLine[Run] = #10 then'); + Writeln(FOutFile, ' inc(Run);'); + Writeln(FOutFile, 'end;'); + Writeln(FOutFile); + + Writeln(FOutFile, 'procedure ' + FLexName + '.LFProc;'); + Writeln(FOutFile, 'begin'); + if (FIdentList.IndexOf(FIdentPre + 'Space') >= 0) then + Writeln(FOutFile, ' FTokenId := ' + FIdentPre + 'Space;') + else + Writeln(FOutFile, ' FTokenId := ' + FIdentPre + 'Unknown;'); + Writeln(FOutFile, ' inc(Run);'); + Writeln(FOutFile, 'end;'); + Writeln(FOutFile); + + for I := 0 to (FEnclosedList.Count - 1) do + begin + Writeln(FOutFile, 'procedure ' + FLexName + '.' + + TLexEnclosedBy(FEnclosedList[I]).ProcName + 'OpenProc;'); + Writeln(FOutFile, 'begin'); + Writeln(FOutFile, ' Inc(Run);'); + if (Length(TLexEnclosedBy(FEnclosedList[I]).StartsWith) > 1) then + begin + Write(FOutFile, ' if '); + for J := 2 to Length(TLexEnclosedBy(FEnclosedList[I]).StartsWith) do + begin + if (J > 2) then + begin + Writeln(FOutFile, ' and'); + Write(FOutFile, ' '); + end; + Write(FOutFile, '(FLine[Run' + AddInt(J - 2) + '] = ''' + + StuffString(TLexEnclosedBy(FEnclosedList[I]).StartsWith[J]) + ''')'); + end; + Writeln(FOutFile, ' then'); + Writeln(FOutFile, ' begin'); + Writeln(FOutFile, ' Inc(Run, ' + + IntToStr(Length(TLexEnclosedBy(FEnclosedList[I]).StartsWith)-1) + ');'); + Writeln(FOutFile, ' FRange := rs' + + TLexEnclosedBy(FEnclosedList[I]).ProcName + ';'); + if not TLexEnclosedBy(FEnclosedList[I]).MultiLine then + begin + Writeln(FOutFile, ' ' + TLexEnclosedBy(FEnclosedList[I]).ProcName + + 'Proc;'); + end; + Writeln(FOutFile, ' FTokenId := ' + FIdentPre + + TLexEnclosedBy(FEnclosedList[I]).TokenName + ';'); + Writeln(FOutFile, ' end'); + Writeln(FOutFile, ' else'); + if (FIdentList.IndexOf(FIdentPre + 'Symbol') >= 0) then + Writeln(FOutFile, ' FTokenId := ' + FIdentPre + 'Symbol;') + else + Writeln(FOutFile, ' FTokenId := ' + FIdentPre + 'Identifier;'); + end + else + begin + Writeln(FOutFile, ' FRange := rs' + + TLexEnclosedBy(FEnclosedList[I]).ProcName + ';'); + if not TLexEnclosedBy(FEnclosedList[I]).MultiLine then + begin + Writeln(FOutFile, ' ' + TLexEnclosedBy(FEnclosedList[I]).ProcName + + 'Proc;'); + end; + Writeln(FOutFile, ' FTokenId := ' + FIdentPre + + TLexEnclosedBy(FEnclosedList[I]).TokenName + ';'); + end; + Writeln(FOutFile, 'end;'); + Writeln(FOutFile); + Writeln(FOutFile, 'procedure ' + FLexName + '.' + + TLexEnclosedBy(FEnclosedList[I]).ProcName + 'Proc;'); + Writeln(FOutFile, 'begin'); + if TLexEnclosedBy(FEnclosedList[I]).MultiLine then + begin + Writeln(FOutFile, ' case FLine[Run] of'); + Writeln(FOutFile, ' #0: NullProc;'); + Writeln(FOutFile, ' #10: LFProc;'); + Writeln(FOutFile, ' #13: CRProc;'); + Writeln(FOutFile, ' else'); + Writeln(FOutFile, ' begin'); + sPrefix := ' '; + end + else + sPrefix := ''; + Writeln(FOutFile, sPrefix, ' FTokenId := ' + FIdentPre + + TLexEnclosedBy(FEnclosedList[I]).TokenName + ';'); + Writeln(FOutFile, sPrefix, ' repeat'); + Write(FOutFile, sPrefix, ' if '); + for J := 1 to Length(TLexEnclosedBy(FEnclosedList[I]).EndsWith) do + begin + if (J > 1) then + begin + Writeln(FOutFile, ' and'); + Write(FOutFile, sPrefix, ' '); + end; + Write(FOutFile, '(FLine[Run' + AddInt(J - 1) + '] = ''' + + StuffString(TLexEnclosedBy(FEnclosedList[I]).EndsWith[J]) + ''')'); + end; + Writeln(FOutFile, ' then'); + Writeln(FOutFile, sPrefix, ' begin'); + Writeln(FOutFile, sPrefix, ' Inc(Run, ' + + IntToStr(Length(TLexEnclosedBy(FEnclosedList[I]).EndsWith)) + ');'); + Writeln(FOutFile, sPrefix, ' FRange := rsUnknown;'); + Writeln(FOutFile, sPrefix, ' Break;'); + Writeln(FOutFile, sPrefix, ' end;'); + Writeln(FOutFile, sPrefix, ' if not IsLineEnd(Run) then'); + Writeln(FOutFile, sPrefix, ' Inc(Run);'); + Writeln(FOutFile, sPrefix, ' until IsLineEnd(Run);'); + Writeln(FOutFile, sPrefix, 'end;'); + if TLexEnclosedBy(FEnclosedList[I]).MultiLine then + begin + Writeln(FOutFile, ' end;'); + Writeln(FOutFile, 'end;'); + end; + Writeln(FOutFile); + end; + + Writeln(FOutFile, 'constructor ' + FLexName + '.Create(AOwner: TComponent);'); + Writeln(FOutFile, 'begin'); + Writeln(FOutFile, ' inherited Create(AOwner);'); + Writeln(FOutFile, ' fCaseSensitive := ' + BoolStrs[FSensitivity] + ';'); + Writeln(FOutFile); + + I := 0; + while I < FIdentList.Count do + begin + AttrTemp := Copy(FIdentList[I], Length(FIdentPre) + 1, Length(FIdentList[I])); + if AttrTemp = 'Key' then + AttrName := ComboBoxAttrReservedWord.Text + else if AttrTemp = 'Identifier' then + AttrName := ComboBoxAttrIdentifier.Text + else + AttrName := 'SYNS_Attr' + FilterInvalidChars(AttrTemp); + + if Pos('SYNS_', AttrName) = 1 then + begin + FriendlyAttrName := AttrName; + Insert('Friendly', FriendlyAttrName, Length('SYNS_') + 1) + end + else + FriendlyAttrName := 'Friendly' + AttrName; + + if (FIdentList[I] <> FIdentPre + 'Null') and (FIdentList[I] <> FIdentPre + + 'Unknown') then + begin + AttrTemp := 'f' + AttrTemp + 'Attri'; + Writeln(FOutFile, ' ' + AttrTemp + ' := TSynHighLighterAttributes.Create(' + + AttrName + ', ' + FriendlyAttrName + ');'); + if Assigned(FIdentList.Objects[i]) then + begin + DefAttri := TLexDefaultAttri(FIdentList.Objects[i]); + if (DefAttri.Style <> '') then + Writeln(FOutFile, ' ' + AttrTemp + '.Style := ' + DefAttri.Style + + ';'); + if (DefAttri.Foreground <> '') then + Writeln(FOutFile, ' ' + AttrTemp + '.Foreground := ' + + DefAttri.Foreground + ';'); + if (DefAttri.Background <> '') then + Writeln(FOutFile, ' ' + AttrTemp + '.Background := ' + + DefAttri.Background + ';'); + end + else if (FIdentList[I] = FIdentPre + 'Key') then + Writeln(FOutFile, ' ' + AttrTemp + '.Style := [fsBold];') + else if (FIdentList[I] = FIdentPre + 'Comment') then + begin + Writeln(FOutFile, ' ' + AttrTemp + '.Style := [fsItalic];'); + Writeln(FOutFile, ' ' + AttrTemp + '.Foreground := clNavy;'); + end; + Writeln(FOutFile, ' AddAttribute(' + AttrTemp + ');'); + Writeln(FOutFile); + end; + Inc(I); + end; + + Writeln(FOutFile, ' SetAttributesOnChange(DefHighlightChange);'); + Writeln(FOutFile, ' InitIdent;'); + + Writeln(FOutFile, ' fDefaultFilter := ' + GetFilterName + ';'); + Writeln(FOutFile, ' FRange := rsUnknown;'); + Writeln(FOutFile, 'end;'); + Writeln(FOutFile); + + I := 0; + while I < FSetList.Count do + begin + Writeln(FOutFile, 'procedure ' + FLexName + '.' + + TLexCharsets(FSetList[I]).SetName + 'Proc;'); + Writeln(FOutFile, 'begin'); + Write(FOutFile, ' ' + TLexCharsets(FSetList[I]).ProcData); + Writeln(FOutFile, 'end;'); + Writeln(FOutFile); + inc(I); + end; + + Writeln(FOutFile, 'procedure ' + FLexName + '.UnknownProc;'); + Writeln(FOutFile, 'begin'); + Writeln(FOutFile, ' inc(Run);'); + Writeln(FOutFile, ' FTokenId := ' + FIdentPre + 'Unknown;'); + Writeln(FOutFile, 'end;'); + Writeln(FOutFile); + + Writeln(FOutFile, 'procedure ' + FLexName + '.Next;'); + Writeln(FOutFile, 'begin'); + Writeln(FOutFile, ' fTokenPos := Run;'); + if (FEnclosedList.Count > 0) then + begin + Writeln(FOutFile, ' case FRange of'); + for I := 0 to (FEnclosedList.Count - 1) do + begin + if TLexEnclosedBy(FEnclosedList[I]).MultiLine then + begin + Writeln(FOutFile, ' rs' + TLexEnclosedBy(FEnclosedList[I]).ProcName + + ': ' + TLexEnclosedBy(FEnclosedList[I]).ProcName + 'Proc;'); + end; + end; + Writeln(FOutFile, ' else'); + Writeln(FOutFile, ' case FLine[Run] of'); + Writeln(FOutFile, ' #0: NullProc;'); + Writeln(FOutFile, ' #10: LFProc;'); + Writeln(FOutFile, ' #13: CRProc;'); + + for I := 0 to (FEnclosedList.Count - 1) do + begin + if (TLexEnclosedBy(FEnclosedList[I]).StartsWith <> '') then + begin + Writeln(FOutFile, ' ''' + + StuffString(TLexEnclosedBy(FEnclosedList[I]).StartsWith[1]) + + ''': ' + TLexEnclosedBy(FEnclosedList[I]).ProcName + 'OpenProc;'); + end; + end; + if (FIdentList.IndexOf(FIdentPre + 'Space') >= 0) then + Writeln(FOutFile, ' #1..#9, #11, #12, #14..#32: SpaceProc;'); + I := 0; + while I < FSetList.Count do + begin + Writeln(FOutFile, ' ' + TLexCharsets(FSetList[I]).Charset + + ': ' + TLexCharsets(FSetList[I]).SetName + 'Proc;'); + Inc(I); + end; + + Writeln(FOutFile, ' else'); + Writeln(FOutFile, ' UnknownProc;'); + Writeln(FOutFile, ' end;'); + Writeln(FOutFile, ' end;'); + end + else + begin + Writeln(FOutFile, ' case FLine[Run] of'); + Writeln(FOutFile, ' #0: NullProc;'); + Writeln(FOutFile, ' #10: LFProc;'); + Writeln(FOutFile, ' #13: CRProc;'); + + if (FIdentList.IndexOf(FIdentPre + 'Space') >= 0) then + Writeln(FOutFile, ' #1..#9, #11, #12, #14..#32: SpaceProc;'); + I := 0; + while I < FSetList.Count do + begin + Writeln(FOutFile, ' ' + TLexCharsets(FSetList[I]).Charset + + ': ' + TLexCharsets(FSetList[I]).SetName + 'Proc;'); + Inc(I); + end; + + Writeln(FOutFile, ' else'); + Writeln(FOutFile, ' UnknownProc;'); + Writeln(FOutFile, ' end;'); + end; + Writeln(FOutFile, ' inherited;'); + Writeln(FOutFile, 'end;'); + Writeln(FOutFile); + + Writeln(FOutFile, 'function ' + FLexName + + '.GetDefaultAttribute(Index: Integer): TSynHighLighterAttributes;'); + Writeln(FOutFile, 'begin'); + Writeln(FOutFile, ' case Index of'); + if (FIdentList.IndexOf(FIdentPre + 'Comment') >= 0) then + Writeln(FOutFile, ' SYN_ATTR_COMMENT: Result := FCommentAttri;'); + if (FIdentList.IndexOf(FIdentPre + 'Identifier') >= 0) then + Writeln(FOutFile, ' SYN_ATTR_IDENTIFIER: Result := FIdentifierAttri;'); + if (FIdentList.IndexOf(FIdentPre + 'Key') >= 0) then + Writeln(FOutFile, ' SYN_ATTR_KEYWORD: Result := FKeyAttri;'); + if (FIdentList.IndexOf(FIdentPre + 'String') >= 0) then + Writeln(FOutFile, ' SYN_ATTR_STRING: Result := FStringAttri;'); + if (FIdentList.IndexOf(FIdentPre + 'Space') >= 0) then + Writeln(FOutFile, ' SYN_ATTR_WHITESPACE: Result := FSpaceAttri;'); + if (FIdentList.IndexOf(FIdentPre + 'Symbol') >= 0) then + Writeln(FOutFile, ' SYN_ATTR_SYMBOL: Result := FSymbolAttri;'); + Writeln(FOutFile, ' else'); + Writeln(FOutFile, ' Result := nil;'); + Writeln(FOutFile, ' end;'); + Writeln(FOutFile, 'end;'); + Writeln(FOutFile); + + Writeln(FOutFile, 'function ' + FLexName + '.GetEol: Boolean;'); + Writeln(FOutFile, 'begin'); + Writeln(FOutFile, ' Result := Run = FLineLen + 1;'); + Writeln(FOutFile, 'end;'); + Writeln(FOutFile); + + if CheckBoxGetKeyWords.Checked then + begin + Writeln(FOutFile, 'function ' + FLexName + '.GetKeyWords(TokenKind: Integer): UnicodeString;'); + Writeln(FOutFile, 'begin'); + TempStringList := TStringList.Create; + try + TempStringList.Sorted := True; + for I := 0 to FKeyList.Count - 1 do + TempStringList.Add(TLexKeys(FKeyList[I]).KeyName); + if TempStringList.Count > 0 then + begin + Writeln(FOutFile, ' Result := '); + for I := 0 to Trunc(Int(Length(TempStringList.CommaText) div 70)) - 1 do + begin + if I = 0 then + LineLength := 69 + else + LineLength := 70; + Writeln(FOutFile, ' ' + #39 + Copy(TempStringList.CommaText, + I * 70, LineLength) + #39 + #32 + #43); + end; + I := Trunc(Int(Length(TempStringList.CommaText) div 70)); + Writeln(FOutFile, ' ' + #39 + Copy(TempStringList.CommaText, + I * 70, Length(TempStringList.CommaText)) + #39 + ';') + end + else + Writeln(FOutFile, ' Result := ' + #39 + #39 + ';'); + finally + TempStringList.Free; + end; + Writeln(FOutFile, 'end;'); + Writeln(FOutFile); + end; + + Writeln(FOutFile, 'function ' + FLexName + '.GetTokenID: TtkTokenKind;'); + Writeln(FOutFile, 'begin'); + Writeln(FOutFile, ' Result := FTokenId;'); + Writeln(FOutFile, 'end;'); + Writeln(FOutFile); + + Writeln(FOutFile, 'function ' + FLexName + + '.GetTokenAttribute: TSynHighLighterAttributes;'); + Writeln(FOutFile, 'begin'); + Writeln(FOutFile, ' case GetTokenID of'); + + I := 0; + while I < FIdentList.Count do + begin + if (FIdentList[I] <> FIdentPre + 'Null') and (FIdentList[I] <> FIdentPre + + 'Unknown') then + Writeln(FOutFile, ' ' + FIdentList[I] + ': Result := F' + + Copy(FIdentList[I], Length(FIdentPre) + 1, Length(FIdentList[I])) + + 'Attri;'); + inc(I); + end; + Writeln(FOutFile, ' ' + FIdentPre + 'Unknown: Result := F' + + ComboBoxUnknownTokenAttr.Text + 'Attri;'); + + Writeln(FOutFile, ' else'); + Writeln(FOutFile, ' Result := nil;'); + Writeln(FOutFile, ' end;'); + Writeln(FOutFile, 'end;'); + Writeln(FOutFile); + + Writeln(FOutFile, 'function ' + FLexName + '.GetTokenKind: Integer;'); + Writeln(FOutFile, 'begin'); + Writeln(FOutFile, ' Result := Ord(FTokenId);'); + Writeln(FOutFile, 'end;'); + Writeln(FOutFile); + + Writeln(FOutFile, 'function ' + FLexName + '.IsIdentChar(AChar: WideChar): Boolean;'); + Writeln(FOutFile, 'begin'); + Writeln(FOutFile, ' case AChar of'); + Writeln(FOutFile, ' ' + FIdentContent + ':'); + Writeln(FOutFile, ' Result := True;'); + Writeln(FOutFile, ' else'); + Writeln(FOutFile, ' Result := False;'); + Writeln(FOutFile, ' end;'); + Writeln(FOutFile, 'end;'); + Writeln(FOutFile); + + Writeln(FOutFile, 'function ' + FLexName + '.GetSampleSource: UnicodeString;'); + Writeln(FOutFile, 'begin'); + if (FSampleSourceList.Count = 0) then + begin + Writeln(FOutFile, ' Result := '); + Writeln(FOutFile, ' ''Sample source for: ''#13#10 +'); + Writeln(FOutFile, ' ''' + EditDescription.Text + ''';'); + end + else + begin + Writeln(FOutFile, ' Result := '); + for i := 0 to FSampleSourceList.Count - 1 do + begin + if (i > 0) and (i < FSampleSourceList.Count - 1) then + Writeln(FOutFile, '#13#10 +'); + if (i < FSampleSourceList.Count - 1) then + Write(FOutFile, ' '); + if FSampleSourceList[i] <> '' then + Write(FOutFile, '''', StuffString(FSampleSourceList[i]), ''''); + end; + Writeln(FOutFile, ';'); + end; + Writeln(FOutFile, 'end;'); + Writeln(FOutFile); + + Writeln(FOutFile, 'function ' + FLexName + '.IsFilterStored: Boolean;'); + Writeln(FOutFile, 'begin'); + Writeln(FOutFile, ' Result := FDefaultFilter <> ' + GetFilterName + ';'); + Writeln(FOutFile, 'end;'); + Writeln(FOutFile); + + Writeln(FOutFile, 'class function ' + FLexName + '.GetFriendlyLanguageName: UnicodeString;'); + Writeln(FOutFile, 'begin'); + Writeln(FOutFile, ' Result := ' + GetFriendlyLangName + ';'); + Writeln(FOutFile, 'end;'); + Writeln(FOutFile); + + Writeln(FOutFile, 'class function ' + FLexName + '.GetLanguageName: string;'); + Writeln(FOutFile, 'begin'); + Writeln(FOutFile, ' Result := ' + GetLangName + ';'); + Writeln(FOutFile, 'end;'); + Writeln(FOutFile); + + Writeln(FOutFile, 'procedure ' + FLexName + '.ResetRange;'); + Writeln(FOutFile, 'begin'); + Writeln(FOutFile, ' FRange := rsUnknown;'); + Writeln(FOutFile, 'end;'); + Writeln(FOutFile); + + Writeln(FOutFile, 'procedure ' + FLexName + '.SetRange(Value: Pointer);'); + Writeln(FOutFile, 'begin'); + Writeln(FOutFile, ' FRange := TRangeState(Value);'); + Writeln(FOutFile, 'end;'); + Writeln(FOutFile); + + Writeln(FOutFile, 'function ' + FLexName + '.GetRange: Pointer;'); + Writeln(FOutFile, 'begin'); + Writeln(FOutFile, ' Result := Pointer(FRange);'); + Writeln(FOutFile, 'end;'); + Writeln(FOutFile); + + Writeln(FOutFile, 'initialization'); + Writeln(FOutFile, '{$IFNDEF SYN_CPPB_1}'); + Writeln(FOutFile, ' RegisterPlaceableHighlighter(' + FLexName + ');'); + Writeln(FOutFile, '{$ENDIF}'); + Writeln(FOutFile, 'end.'); +end; + +procedure TFormMain.ComboBoxLangNameChange(Sender: TObject); +begin + if (ComboBoxLangName.Text <> '') and (ComboBoxFilter.Text <> '') then + ButtonStart.Enabled := True + else + ButtonStart.Enabled := False; +end; + +procedure TFormMain.ListBoxFieldsClick(Sender: TObject); +begin + ButtonDelete.Enabled := True; +end; + +procedure TFormMain.ButtonAddClick(Sender: TObject); +begin + ListBoxFields.Items.Add(EditAddField.Text); + EditAddField.Clear; +end; + +procedure TFormMain.ButtonDeleteClick(Sender: TObject); +begin + ButtonDelete.Enabled := False; + ListBoxFields.Items.Delete(ListBoxFields.ItemIndex); +end; + +procedure TFormMain.EditAddFieldChange(Sender: TObject); +begin + ButtonAdd.Enabled := EditAddField.Text <> ''; +end; + +procedure TFormMain.EditAddFieldKeyPress(Sender: TObject; var Key: Char); +begin + if (Key = ';') or (Key = #32) then + Key := #0; +end; + +procedure TFormMain.MenuItemExitClick(Sender: TObject); +begin + Close; +end; + +procedure TFormMain.MenuItemOpenClick(Sender: TObject); +begin + WriteSettings; + PerformFileOpen; +end; + +procedure TFormMain.FormClose(Sender: TObject; var Action: TCloseAction); +begin + WriteSettings; +end; + +function TFormMain.KeywordsAreAllAlphaNumAndDifferent: Boolean; +var + i: Integer; + KeyWordList: TStringList; +begin + Result := True; + + KeyWordList := TStringList.Create; + try + KeyWordList.Sorted := True; + KeyWordList.Duplicates := dupError; + + try + for i := 0 to FKeyList.Count - 1 do + KeyWordList.Add(TLexKeys(FKeyList[i]).KeyName); + except + Result := False; + Exit; + end; + finally + KeyWordList.Free; + end; + + for i := 0 to FKeyList.Count - 1 do + if not IsASCIIAlphaNum(TLexKeys(FKeyList[i]).KeyName) then + begin + Result := False; + Exit; + end; +end; + +end. diff --git a/components/virtualtreeview/.gitignore b/components/virtualtreeview/.gitignore new file mode 100644 index 000000000..b38a0e1d6 --- /dev/null +++ b/components/virtualtreeview/.gitignore @@ -0,0 +1,56 @@ +# Compiled source # +################### +*.dcu +*.obj +*.exe +*.bpl +*.bpi +*.dcp +*.rsm +*.stat +*.map +*.d +*.o + +# Generated source # +################### +*.hpp + +# Backup files # +################### +*.~* +__recovery + +# IDE Files # +################### +*.dproj.local +*.groupproj.local +*.identcache +*.dsk +*.tvsconfig +*.otares +*.drc +*.rc +*.res +*.local +*.dsv + +# Output Folders # +################### +/Win32 +/Win64 +/OSX32 +/__history +*.bak +*.Patch +VirtualTreeView.zip +*.#00 +*.pch +*.skincfg +*.a +Packages/RAD Studio XE3/VirtualTreesR.lib +*.lib + +# Folder with repro projects # +############################## +/#* \ No newline at end of file diff --git a/components/virtualtreeview/Delphinus.Info.json b/components/virtualtreeview/Delphinus.Info.json new file mode 100644 index 000000000..5e7439c21 --- /dev/null +++ b/components/virtualtreeview/Delphinus.Info.json @@ -0,0 +1,10 @@ +{ + "id": "{A34BA07B-19B6-4C21-9DEE-65FCA52D00AB}", + "name": "Virtual Treeview", + "picture": "Resources\\VirtualTreeview-Icon.png", + "license_type": "MPL-1.1", + "platforms": "Win32;Win64", + "first_version": "6.2.0", + "package_compiler_min": 24, + "compiler_min": 24 +} \ No newline at end of file diff --git a/components/virtualtreeview/Delphinus.Install.json b/components/virtualtreeview/Delphinus.Install.json new file mode 100644 index 000000000..a193c6c82 --- /dev/null +++ b/components/virtualtreeview/Delphinus.Install.json @@ -0,0 +1,56 @@ +{ + "search_pathes": [ + { + "pathes": "Source", + "platforms": "Win32;Win64" + } + ], + "browsing_pathes": [ + { + "pathes": "Source", + "platforms": "Win32;Win64" + } + ], + "source_folders": [ + { + "folder": "source", + "base": "", + "recursive": true, + "filter": "*;*.*" + }, + { + "folder": "Packages", + "base": "", + "recursive": true, + "filter": "*;*.*" + }, + { + "folder": "Design", + "base": "", + "recursive": true, + "filter": "*;*.*" + } + ], + "projects": [ + { + "project": "Packages\\RAD Studio XE3\\VirtualTreeView.groupproj", + "compiler_max": 26 + }, + { + "project": "Packages\\RAD Studio XE6\\VirtualTreeView.groupproj", + "compiler": 27 + }, + { + "project": "Packages\\RAD Studio XE7\\VirtualTreeView.groupproj", + "compiler": 28 + }, + { + "project": "Packages\\RAD Studio XE8\\VirtualTreeView.groupproj", + "compiler": 29 + }, + { + "project": "Packages\\RAD Studio 10\\VirtualTreeView.groupproj", + "compiler_min": 30 + } + ] +} diff --git a/components/virtualtreeview/Design/VirtualTreesReg.pas b/components/virtualtreeview/Design/VirtualTreesReg.pas index d5b67a665..9e241fcc7 100644 --- a/components/virtualtreeview/Design/VirtualTreesReg.pas +++ b/components/virtualtreeview/Design/VirtualTreesReg.pas @@ -11,8 +11,7 @@ interface {$warn UNSAFE_CODE off} uses - Windows, Classes, DesignIntf, DesignEditors, VCLEditors, PropertyCategories, - ColnEdit, VirtualTrees, VirtualTrees.HeaderPopup; + DesignEditors; type TVirtualTreeEditor = class (TDefaultEditor) @@ -27,8 +26,12 @@ procedure Register; implementation uses - StrEdit, Dialogs, TypInfo, SysUtils, Graphics, CommCtrl, ImgList, Controls, - VirtualTrees.ClipBoard, VirtualTrees.Actions; + WinApi.Windows, WinApi.CommCtrl, + System.TypInfo, System.SysUtils, System.Classes, + StrEdit,DesignIntf, VCLEditors, PropertyCategories, ColnEdit, + Vcl.Dialogs, Vcl.Graphics, Vcl.ImgList, Vcl.Controls, + VirtualTrees.ClipBoard, VirtualTrees.Actions, VirtualTrees, VirtualTrees.DrawTree, + VirtualTrees.HeaderPopup, VirtualTrees.BaseTree; type // The usual trick to make a protected property accessible in the ShowCollectionEditor call below. diff --git a/components/virtualtreeview/INSTALL.txt b/components/virtualtreeview/INSTALL.txt new file mode 100644 index 000000000..162fac3d9 --- /dev/null +++ b/components/virtualtreeview/INSTALL.txt @@ -0,0 +1,71 @@ +Supported Delphi version: RAD Studio 10.0 and higher +Supported Windows Versions: Windows 8 and higher + +Extract the entire(!) ZIP file and follow the instructions below. + +Delphi / RAD Studio 10.4 and higher Installation +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +1. Open the project group "Packages\RAD Studio 10.4+\VirtualTreeView.groupproj" +2. Right click on root element "VirtualTreeView" and click "Build All" +3. Right click on "VirtualTreesD*.bpl" and click "Install" +4. Go to "Tools > Options > Language > Delphi Options > Library +5. Choose platform "Win32", click on "Library Path > [...]" + Browse to the "Packages\RAD Studio 10.4+\Win32\Release" folder of VirtualTreeView, + press "Choose Folder", "Add", "OK" +6. Choose platform "Win64", click on "Library Path > [...]" + Browse to the "Packages\RAD Studio 10.4+\Win64\Release" folder of VirtualTreeView, + press "Choose Folder", "Add", "OK" +7. C++ Builder users only: + In the Options dialog go to "Environment Options > C++ Options > Paths and Directories" + a) Click "Library Path > [...]" + Browse to the "Source" folder of VirtualTreeView, press "OK", "Add", "OK" + b) Click "System Include path > [...]" + Browse to the "Source" folder of VirtualTreeView, press "OK", "Add", "OK" +8. Close the RAD Studio Options dialog by clicking "Save". + + +Delphi / RAD Studio 10.3 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +1. Open the project group "Packages\RAD Studio 10.3\VirtualTreeView.groupproj" +2. Right click on "VirtualTreesD270.bpl" and click "Install" +3. Go to "Tools > Options > Language > Delphi Options > Library > Library Path > [...]" + Browse to the "Source" folder of VirtualTreeView, press "OK", "Add", "OK" + Do this for both Win32 and Win64 platforms, which you can choose in the dropdown box. +4. C++ Builder users only: + In the Options dialog go to "Environment Options > C++ Options > Paths and Directories" + a) Click "Library Path > [...]" + Browse to the "Source" folder of VirtualTreeView, press "OK", "Add", "OK" + b) Click "System Include path > [...]" + Browse to the "Source" folder of VirtualTreeView, press "OK", "Add", "OK" +5. Close the RAD Studio Options dialog by clicking "Save". + + +Delphi / RAD Studio 10.0 - 10.2 Installation +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +1. Open the project group "Packages\RAD Studio *\VirtualTreeView.groupproj" +2. Right click on "VirtualTreesD*.bpl" and click "Install" +3. Go to "Tools > Options > Environment Options > Delphi Options > Library > Library Path > [...]" + Browse to the "Source" folder of VirtualTreeView, press "OK", "Add", "OK" + Do this for both Win32 and Win64 platforms, which you can choose in the dropdown box. +4. C++ Builder users only: + In the Options dialog go to "Environment Options > C++ Options > Paths and Directories" + a) Click "Library Path > [...]" + Browse to the "Source" folder of VirtualTreeView, press "OK", "Add", "OK" + b) Click "System Include path > [...]" + Browse to the "Source" folder of VirtualTreeView, press "OK", "Add", "OK" +5. Close the RAD Studio Options dialog by clicking "OK". + + +Troubleshooting +~~~~~~~~~~~~~~~ +In case you experience any problems, try to delete all these files from your disk and then start over: + - Virtualtrees.* + - VTAccessibility.* + - VTHeaderPopup.* + - VirtualTreesD.* + - VirtualTreesR.* +I recommend using UltraSearch for this task: http://www.jam-software.de/ultrasearch/ + + +For comments and suggestions regarding the packages and the install +instructions open an Issue at: https://github.com/JAM-Software/Virtual-TreeView/issues diff --git a/components/virtualtreeview/MAKEFILE b/components/virtualtreeview/MAKEFILE new file mode 100644 index 000000000..4c89b54b1 --- /dev/null +++ b/components/virtualtreeview/MAKEFILE @@ -0,0 +1,83 @@ +# Program files folder +PROGRAMFILESX64 = $(PROGRAMFILES) +!IF EXIST("C:\Program Files (x86)") +PROGRAMFILES = C:\Program Files (x86) +PROGRAMFILESX64 = C:\Program Files +!ENDIF + +# Default MS Build version +!IF EXIST("$(PROGRAMFILESX64)\Microsoft Visual Studio\2022\Enterprise\MSBuild\Current\Bin\msbuild.exe") +BUILDEXE = "$(PROGRAMFILESX64)\Microsoft Visual Studio\2022\Enterprise\MSBuild\Current\Bin\msbuild.exe" +!ELSE IF EXIST("$(PROGRAMFILESX64)\Microsoft Visual Studio\2022\Professional\MSBuild\Current\Bin\msbuild.exe") +BUILDEXE = "$(PROGRAMFILESX64)\Microsoft Visual Studio\2022\Professional\MSBuild\Current\Bin\msbuild.exe" +!ELSE IF EXIST("$(PROGRAMFILESX64)\Microsoft Visual Studio\2019\Enterprise\MSBuild\Current\Bin\msbuild.exe") +BUILDEXE = "$(PROGRAMFILESX64)\Microsoft Visual Studio\2019\Enterprise\MSBuild\Current\Bin\msbuild.exe" +!ELSE IF EXIST("$(PROGRAMFILESX64)\Microsoft Visual Studio\2019\Professional\MSBuild\Current\Bin\msbuild.exe") +BUILDEXE = "$(PROGRAMFILESX64)\Microsoft Visual Studio\2019\Professional\MSBuild\Current\Bin\msbuild.exe" +!ELSE IF EXIST("$(PROGRAMFILESX64)\Microsoft Visual Studio\2017\BuildTools\MSBuild\15.0\Bin\msbuild.exe") +BUILDEXE = "$(PROGRAMFILESX64)\Microsoft Visual Studio\2017\BuildTools\MSBuild\15.0\Bin\msbuild.exe" +!ELSE +BUILDEXE = "msbuild.exe" +!ENDIF + +PROJECT = VirtualTrees +EMBARCADERO = $(PROGRAMFILES)\Embarcadero\RAD Studio +STUDIO = $(PROGRAMFILES)\Embarcadero\Studio +BDSCOMMONDIRMAIN = %PUBLIC%\Documents\Embarcadero\Studio + +BUILD = $(BUILDEXE) /t:Rebuild + +clean: + ECHO Project: $(PROJECT) $(EMBARCADERO) + DEL /S /Q .\*.HPP + DEL /S /Q .\*.DCU +#TODO: Add demos and package folders + +12.3: Source\*.pas "Packages\RAD Studio 10.4+\$(PROJECT)R.dpk" "Packages\RAD Studio 10.4+\$(PROJECT)R.dproj" "Packages\RAD Studio 10.4+\$(PROJECT)D.dpk" "Packages\RAD Studio 10.4+\$(PROJECT)D.dproj" + SET BDS=$(STUDIO)\23.0 + $(BUILD) /property:Platform=Win32 "Packages\RAD Studio 10.4+\$(PROJECT)R.dproj" + $(BUILD) /property:Platform=Win32 "Packages\RAD Studio 10.4+\$(PROJECT)D.dproj" + $(BUILD) /property:Platform=Win64 "Packages\RAD Studio 10.4+\$(PROJECT)R.dproj" + $(BUILD) /property:Platform=Win64 "Packages\RAD Studio 10.4+\$(PROJECT)D.dproj" + $(MAKE) _samples + +12.0: Source\*.pas "Packages\RAD Studio 10.4+\$(PROJECT)R.dpk" "Packages\RAD Studio 10.4+\$(PROJECT)R.dproj" "Packages\RAD Studio 10.4+\$(PROJECT)D.dpk" "Packages\RAD Studio 10.4+\$(PROJECT)D.dproj" + SET BDS=$(STUDIO)\23.0 + $(BUILD) "Packages\RAD Studio 10.4+\$(PROJECT)R.dproj" + $(BUILD) "Packages\RAD Studio 10.4+\$(PROJECT)D.dproj" + $(BUILD) /property:Platform=Win64 "Packages\RAD Studio 10.4+\$(PROJECT)R.dproj" + $(MAKE) _samples + +# build all packages for Delphi 10.4. Note: The variable $@ is expanded to the build target name +10.1 10.2 10.3 10.4+: Source\*.pas "Packages\RAD Studio $@\$(PROJECT)R.dpk" "Packages\RAD Studio $@\$(PROJECT)R.dproj" "Packages\RAD Studio $@\$(PROJECT)D.dpk" "Packages\RAD Studio $@\$(PROJECT)D.dproj" + SET BDS=$(STUDIO)\21.0 + $(BUILD) "Packages\RAD Studio $@\$(PROJECT)R.dproj" + $(BUILD) "Packages\RAD Studio $@\$(PROJECT)D.dproj" + $(BUILD) /property:Platform=Win64 "Packages\RAD Studio $@\$(PROJECT)R.dproj" + $(MAKE) _samples + +"Demos\Advanced\Advanced.exe": "Demos\Advanced\*.dproj" "Demos\Advanced\*.dpr" "Demos\Advanced\*.pas" + $(BUILD) "Demos\Advanced\Advanced.dproj" + +"Demos\Minimal\Minimal.exe": "Demos\Minimal\*.dproj" "Demos\Minimal\*.dpr" "Demos\Minimal\*.pas" + $(BUILD) "Demos\Minimal\Minimal.dproj" + +"Demos\Objects\Objects.exe": "Demos\Objects\*.dproj" "Demos\Objects\*.dpr" "Demos\Objects\*.pas" + $(BUILD) "Demos\Objects\MVCDemo.dproj" + +"Demos\OLE\OLE.exe": "Demos\OLE\*.dproj" "Demos\OLE\*.dpr" "Demos\OLE\*.pas" + $(BUILD) "Demos\OLE\OLE.dproj" + +_samples: "Demos\Advanced\Advanced.exe" "Demos\Minimal\Minimal.exe" "Demos\Objects\Objects.exe" "Demos\OLE\OLE.exe" + +_continuousbuilds: clean 12.3 + +_release: +#This small batch file is intended to create a source code release file of the VirtualTreeView as ZIP archive +#It expects the ZIP.EXE from the InfoZip project V3.0 or higher to be in the system's search path +#Download e.g. from: ftp://ftp.info-zip.org/pub/infozip/win32/ + ZIP -9 -r .\VirtualTreeView.zip INSTALL.txt Changes.txt Source Design Packages Demos Contributions Help\VirtualTreeview.chm -i *.pas -i *.dpk -i *.groupproj -i *.dproj -i *.cbproj -i *.hlp -i *.rc -i *.res -i *.cfg -i *.dpr -i *.dof -i *.bpr -i *.dfm -i *.cpp -i *.inc -i *.dcr -i *.chm -i *.png -i *.js -i *.txt -i *.bmp -i *.uni + ECHO Source code zip archive "VirtualTreeView.zip" created. + ECHO !!! Please add version number to ZIP file name!!! + ECHO !!! Please create release at: https://github.com/Virtual-TreeView/Virtual-TreeView/releases + ECHO !!! Let JAM web-team upload the file to our server at https://www.jam-software.com/virtual-treeview \ No newline at end of file diff --git a/components/virtualtreeview/README.md b/components/virtualtreeview/README.md new file mode 100644 index 000000000..a882caa8f --- /dev/null +++ b/components/virtualtreeview/README.md @@ -0,0 +1,42 @@ +# Virtual-TreeView +Virtual Treeview is a Delphi treeview control built from ground up. Many years of development made it one of the most flexible and advanced tree controls available today. Virtual Treeview starts off with the claim to improve many aspects of existing solutions and introduces some new technologies and principles which were not available before. + +### Help Needed: Any volunteer that takes care about **C++ Builder** bugs and packages? +I don't use C++ Builder and my experience with it is very limited. This makes it difficult to take care about bugs that are reported in C++ Builder and to maintain the C++ Builder packages. I would be great if someone would volunteer to do this. + +### Downloads +[**V8** official release](https://github.com/JAM-Software/Virtual-TreeView/releases/latest) for **RAD Studio 10 to 12** which includes some **[breaking changes](https://github.com/JAM-Software/Virtual-TreeView/wiki/Breaking-Changes-in-V8)**. + +[**V7.6.x**](https://github.com/JAM-Software/Virtual-TreeView/releases/tag/V7.6.6) for **Delphi XE3 to XE8**. + +An experimental **FireMonkey** port can be found here: [livius2/Virtual-TreeView](https://github.com/livius2/Virtual-TreeView) + +A port to **Lazarus / FPC** can be found here: [blikblum/VirtualTreeView-Lazarus](https://github.com/blikblum/VirtualTreeView-Lazarus) + +For a **Delphi XE2** compatible fork see: [Fr0sT-Brutal/VirtualTreeView_mod/tree/fr0st_xe2](https://github.com/Fr0sT-Brutal/VirtualTreeView_mod/tree/fr0st_xe2) + +**V5.5.3** for **Delphi 7 to XE2**: [Download](https://github.com/JAM-Software/Virtual-TreeView/releases/download/V5.5.3/VirtualTreeViewV5.5.3.zip) + +**V6 latest stable version** tested on Windows XP/2003 support: [GitHub](https://github.com/Virtual-TreeView/Virtual-TreeView/archive/V6_stable.zip) + +For installation instruction see the "INSTALL.TXT" file in the ZIP. [Delphinus](http://memnarch.bplaced.net/blog/2015/08/delphinus-packagemanager-for-delphi-xe-and-newer/)-Support was added. + +### Technical Support +Please do not contact developers or JAM Software for technical support. Please try to get support from the community e.g. at [Stack Overflow](http://stackoverflow.com/search?q=%22virtual+treeview%22), [Delphi Pages](http://www.delphipages.com/), [Delphi Praxis](http://www.delphipraxis.net/141465-virtual-treeview-tutorials-mit-beispielen.html) or [Embarcadero forums](https://forums.embarcadero.com/). Please do not use the issue tracker for getting support, only for reporting true bugs (see below). + +### Reporting Bugs +First of all, please make sure you are using the **latest official version**. When **[reporting a bug](https://github.com/Virtual-TreeView/Virtual-TreeView/issues)** please attach a **sample** project as ZIP-file that allows us to quickly reproduce the bug. This can also be one of the demo projects that come with Virtual Treeview, modified to show the bug. If only small changes are required, a description is sufficient how a demo projects needs to be changed in order to replicate the bug. Please follow [best practices for good bug reports](https://www.softwaretestinghelp.com/how-to-write-good-bug-report/). + +If you already have a solution, please supply a patch file or make a pull request. If you used a previous version that did not have the bug, please include this version number in your report. + +### Feature Requests +We currently focus on reducing the number of reported bugs and getting Virtual Treeview stable. Feature Requests will most likely not processed at the moment. We are only going to process enhancement requests if the new feature is of general interest and a source code patch based on the latest SVN revision is attached to the report. Please mark feature requests with the flag "Enhancement". + +### Contributors +If you want to contribute, you are welcome. We always look for help, not only for the development of the Virtual Treeview control itself, but also for maintaining the sample projects, the help or the wiki. Please send an email to: joachim(dot)marder(a)gmail.com + +### License +Virtual Treeview is published under a double license: MPL 1.1 and LGPL 2.1 with static linking exception as described here: http://wiki.freepascal.org/modified_LGPL + +### New project owner +JAM Software took Virtual Treeview under its wing in 2014, but not much will change besides the homepage and download location. diff --git a/components/virtualtreeview/Source/VirtualTrees.Accessibility.pas b/components/virtualtreeview/Source/VirtualTrees.Accessibility.pas index 81a86ab1b..cb1e46896 100644 --- a/components/virtualtreeview/Source/VirtualTrees.Accessibility.pas +++ b/components/virtualtreeview/Source/VirtualTrees.Accessibility.pas @@ -1,4 +1,4 @@ -unit VirtualTrees.Accessibility; +unit VirtualTrees.Accessibility; // This unit implements iAccessible interfaces for the VirtualTree visual components // and the currently focused node. @@ -8,8 +8,10 @@ interface uses - Winapi.Windows, System.Classes, Winapi.ActiveX, System.Types, Winapi.oleacc, - VirtualTrees, VirtualTrees.AccessibilityFactory, Vcl.Controls; + Winapi.Windows, Winapi.ActiveX, Winapi.oleacc, + System.Classes, System.Types, + Vcl.Controls, + VirtualTrees, VirtualTrees.AccessibilityFactory, VirtualTrees.BaseTree; type TVirtualTreeAccessibility = class(TInterfacedObject, IDispatch, IAccessible) @@ -99,7 +101,9 @@ TVTMultiColumnAccessibleItemProvider = class(TInterfacedObject, IVTAccessibleP implementation uses - System.SysUtils, Vcl.Forms, System.Variants, System.Math; + System.SysUtils, System.Variants, System.Math, + Vcl.Forms, + VirtualTrees.Types; type @@ -792,6 +796,3 @@ initialization TVirtualTreeAccessibility.RegisterDefaultAccessibleProviders(); end. - - - diff --git a/components/virtualtreeview/Source/VirtualTrees.AccessibilityFactory.pas b/components/virtualtreeview/Source/VirtualTrees.AccessibilityFactory.pas index d62703132..e26dacaf8 100644 --- a/components/virtualtreeview/Source/VirtualTrees.AccessibilityFactory.pas +++ b/components/virtualtreeview/Source/VirtualTrees.AccessibilityFactory.pas @@ -1,178 +1,181 @@ -unit VirtualTrees.AccessibilityFactory; - -// 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/ -// -// Alternatively, you may redistribute this library, use and/or modify it under the terms of the -// GNU Lesser General Public License as published by the Free Software Foundation; -// either version 2.1 of the License, or (at your option) any later version. -// You may obtain a copy of the LGPL at http://www.gnu.org/copyleft/. -// -// 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. -// -// The original code is VirtualTrees.pas, released September 30, 2000. -// -// The initial developer of the original code is digital publishing AG (Munich, Germany, www.digitalpublishing.de), -// written by Mike Lischke (public@soft-gems.net, www.soft-gems.net). -// -// Portions created by digital publishing AG are Copyright -// (C) 1999-2001 digital publishing AG. All Rights Reserved. -//---------------------------------------------------------------------------------------------------------------------- - - -// class to create IAccessibles for the tree passed into it. -// If not already assigned, creates IAccessibles for the tree itself -// and the focused item -// the tree accessible is returned when the tree receives an WM_GETOBJECT message -// the AccessibleItem is returned when the Accessible is being asked for the first child -// To create your own IAccessibles, use the VTStandardAccessible unit as a reference, -// and assign your Accessibles to the variables in the unit's initialization. -// You only need to add the unit to your project, and voil, you have an accessible string tree! -// -// Written by Marco Zehe. (c) 2007 - -interface - -uses - System.Classes, Winapi.oleacc, VirtualTrees; - -type - IVTAccessibleProvider = interface - function CreateIAccessible(ATree: TBaseVirtualTree): IAccessible; - end; - - TVTAccessibilityFactory = class(TObject) - strict private class var - FAccessibilityAvailable: Boolean; - FVTAccessibleFactory: TVTAccessibilityFactory; - strict private - FAccessibleProviders: TInterfaceList; - private - class procedure FreeFactory; - public - constructor Create; - destructor Destroy; override; - function CreateIAccessible(ATree: TBaseVirtualTree): IAccessible; - class function GetAccessibilityFactory: TVTAccessibilityFactory; static; - procedure RegisterAccessibleProvider(const AProvider: IVTAccessibleProvider); - procedure UnRegisterAccessibleProvider(const AProvider: IVTAccessibleProvider); - end; - - -implementation - -{ TVTAccessibilityFactory } - -constructor TVTAccessibilityFactory.Create; -begin - inherited Create; - FAccessibleProviders := TInterfaceList.Create; - FAccessibleProviders.Clear; -end; - -function TVTAccessibilityFactory.CreateIAccessible( - ATree: TBaseVirtualTree): IAccessible; -var - I: Integer; - TmpIAccessible: IAccessible; -// returns an IAccessible. -// 1. If the Accessible property of the passed-in tree is nil, -// the first registered element will be returned. -// Usually, this is the IAccessible that provides information about the tree itself. -// If it is not nil, we'll check whether the AccessibleItem is nil. -// If it is, we'll look in the registered IAccessibles for the appropriate one. -// Each IAccessibleProvider will check the tree for properties to determine whether it is responsible. -// We'll work top to bottom, from the most complicated to the most simple. -// The index for these should all be greater than 0, e g the IAccessible for the tree itself should always be registered first, then any IAccessible items. -begin - Result := nil; - if ATree <> nil then - begin - if ATree.Accessible = nil then - begin - if FAccessibleProviders.Count > 0 then - begin - Result := IVTAccessibleProvider(FAccessibleProviders.Items[0]).CreateIAccessible(ATree); - Exit; - end; - end; - if ATree.AccessibleItem = nil then - begin - if FAccessibleProviders.Count > 0 then - begin - for I := FAccessibleProviders.Count - 1 downto 1 do - begin - TmpIAccessible := IVTAccessibleProvider(FAccessibleProviders.Items[I]).CreateIAccessible(ATree); - if TmpIAccessible <> nil then - begin - Result := TmpIAccessible; - Break; - end; - end; - if TmpIAccessible = nil then - begin - Result := IVTAccessibleProvider(FAccessibleProviders.Items[0]).CreateIAccessible(ATree); - end; - end; - end - else - Result := ATree.AccessibleItem; - end; -end; - -destructor TVTAccessibilityFactory.Destroy; -begin - FAccessibleProviders.Free; - FAccessibleProviders := nil; - inherited Destroy; -end; - -class procedure TVTAccessibilityFactory.FreeFactory; -begin - FVTAccessibleFactory.Free; -end; - -procedure TVTAccessibilityFactory.RegisterAccessibleProvider(const AProvider: IVTAccessibleProvider); -// Ads a provider if it is not already registered -begin - if FAccessibleProviders.IndexOf(AProvider) < 0 then - FAccessibleProviders.Add(AProvider) -end; - -procedure TVTAccessibilityFactory.UnRegisterAccessibleProvider(const AProvider: IVTAccessibleProvider); -// Unregisters/removes an IAccessible provider if it is present -begin - if FAccessibleProviders.IndexOf(AProvider) >= 0 then - FAccessibleProviders.Remove(AProvider); -end; - -class function TVTAccessibilityFactory.GetAccessibilityFactory: TVTAccessibilityFactory; -// Accessibility helper function to create a singleton class that will create or return -// the IAccessible interface for the tree and the focused node. - -begin - // first, check if we've loaded the library already - if not FAccessibilityAvailable then - FAccessibilityAvailable := True; - if FAccessibilityAvailable then - begin - // Check to see if the class has already been created. - if FVTAccessibleFactory = nil then - FVTAccessibleFactory := TVTAccessibilityFactory.Create; - Result := FVTAccessibleFactory; - end - else - Result := nil; -end; - -initialization - -finalization - TVTAccessibilityFactory.FreeFactory; - -end. - - +unit VirtualTrees.AccessibilityFactory; + +// 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/ +// +// Alternatively, you may redistribute this library, use and/or modify it under the terms of the +// GNU Lesser General Public License as published by the Free Software Foundation; +// either version 2.1 of the License, or (at your option) any later version. +// You may obtain a copy of the LGPL at http://www.gnu.org/copyleft/. +// +// 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. +// +// The original code is VirtualTrees.pas, released September 30, 2000. +// +// The initial developer of the original code is digital publishing AG (Munich, Germany, www.digitalpublishing.de), +// written by Mike Lischke (public@soft-gems.net, www.soft-gems.net). +// +// Portions created by digital publishing AG are Copyright +// (C) 1999-2001 digital publishing AG. All Rights Reserved. +//---------------------------------------------------------------------------------------------------------------------- + + +// class to create IAccessibles for the tree passed into it. +// If not already assigned, creates IAccessibles for the tree itself +// and the focused item +// the tree accessible is returned when the tree receives an WM_GETOBJECT message +// the AccessibleItem is returned when the Accessible is being asked for the first child +// To create your own IAccessibles, use the VTStandardAccessible unit as a reference, +// and assign your Accessibles to the variables in the unit's initialization. +// You only need to add the unit to your project, and voilá, you have an accessible string tree! +// +// Written by Marco Zehe. (c) 2007 + +interface + +uses + Winapi.oleacc, + System.Classes, + Vcl.Controls, + VirtualTrees.BaseTree; + +type + IVTAccessibleProvider = interface + ['{8B76176B-C1F2-4C5C-99B4-2444FABE495C}'] + function CreateIAccessible(ATree: TBaseVirtualTree): IAccessible; + end; + + TVTAccessibilityFactory = class(TObject) + strict private class var + FAccessibilityAvailable: Boolean; + FVTAccessibleFactory: TVTAccessibilityFactory; + strict private + FAccessibleProviders: TInterfaceList; + private + class procedure FreeFactory; + public + constructor Create; + destructor Destroy; override; + function CreateIAccessible(ATree: TCustomControl): IAccessible; + class function GetAccessibilityFactory: TVTAccessibilityFactory; static; + procedure RegisterAccessibleProvider(const AProvider: IVTAccessibleProvider); + procedure UnRegisterAccessibleProvider(const AProvider: IVTAccessibleProvider); + end; + + +implementation + +{ TVTAccessibilityFactory } + +constructor TVTAccessibilityFactory.Create; +begin + inherited Create; + FAccessibleProviders := TInterfaceList.Create; + FAccessibleProviders.Clear; +end; + +function TVTAccessibilityFactory.CreateIAccessible(ATree: TCustomControl): IAccessible; +var + I: Integer; + TmpIAccessible: IAccessible; + lTree: TBaseVirtualTree; +// returns an IAccessible. +// 1. If the Accessible property of the passed-in tree is nil, +// the first registered element will be returned. +// Usually, this is the IAccessible that provides information about the tree itself. +// If it is not nil, we'll check whether the AccessibleItem is nil. +// If it is, we'll look in the registered IAccessibles for the appropriate one. +// Each IAccessibleProvider will check the tree for properties to determine whether it is responsible. +// We'll work top to bottom, from the most complicated to the most simple. +// The index for these should all be greater than 0, e g the IAccessible for the tree itself should always be registered first, then any IAccessible items. +begin + Result := nil; + lTree := (ATree as TBaseVirtualTree); + if lTree <> nil then + begin + if lTree.Accessible = nil then + begin + if FAccessibleProviders.Count > 0 then + begin + Result := IVTAccessibleProvider(FAccessibleProviders.Items[0]).CreateIAccessible(lTree); + Exit; + end; + end; + if lTree.AccessibleItem = nil then + begin + if FAccessibleProviders.Count > 0 then + begin + for I := FAccessibleProviders.Count - 1 downto 1 do + begin + TmpIAccessible := IVTAccessibleProvider(FAccessibleProviders.Items[I]).CreateIAccessible(lTree); + if TmpIAccessible <> nil then + begin + Result := TmpIAccessible; + Break; + end; + end; + if TmpIAccessible = nil then + begin + Result := IVTAccessibleProvider(FAccessibleProviders.Items[0]).CreateIAccessible(lTree); + end; + end; + end + else + Result := lTree.AccessibleItem; + end; +end; + +destructor TVTAccessibilityFactory.Destroy; +begin + FAccessibleProviders.Free; + FAccessibleProviders := nil; + inherited Destroy; +end; + +class procedure TVTAccessibilityFactory.FreeFactory; +begin + FVTAccessibleFactory.Free; +end; + +procedure TVTAccessibilityFactory.RegisterAccessibleProvider(const AProvider: IVTAccessibleProvider); +// Ads a provider if it is not already registered +begin + if FAccessibleProviders.IndexOf(AProvider) < 0 then + FAccessibleProviders.Add(AProvider) +end; + +procedure TVTAccessibilityFactory.UnRegisterAccessibleProvider(const AProvider: IVTAccessibleProvider); +// Unregisters/removes an IAccessible provider if it is present +begin + if FAccessibleProviders.IndexOf(AProvider) >= 0 then + FAccessibleProviders.Remove(AProvider); +end; + +class function TVTAccessibilityFactory.GetAccessibilityFactory: TVTAccessibilityFactory; +// Accessibility helper function to create a singleton class that will create or return +// the IAccessible interface for the tree and the focused node. + +begin + // first, check if we've loaded the library already + if not FAccessibilityAvailable then + FAccessibilityAvailable := True; + if FAccessibilityAvailable then + begin + // Check to see if the class has already been created. + if FVTAccessibleFactory = nil then + FVTAccessibleFactory := TVTAccessibilityFactory.Create; + Result := FVTAccessibleFactory; + end + else + Result := nil; +end; + +initialization + +finalization + TVTAccessibilityFactory.FreeFactory; + +end. diff --git a/components/virtualtreeview/Source/VirtualTrees.Actions.pas b/components/virtualtreeview/Source/VirtualTrees.Actions.pas index 0a74ac618..9f91a9087 100644 --- a/components/virtualtreeview/Source/VirtualTrees.Actions.pas +++ b/components/virtualtreeview/Source/VirtualTrees.Actions.pas @@ -1,163 +1,164 @@ -unit VirtualTrees.Actions; - -interface - -uses - System.Classes, - System.Actions, - Vcl.Controls, - Vcl.ActnList, - VirtualTrees; - -type - TVirtualTreeAction = class(TCustomAction) - strict private - fTree: TBaseVirtualTree; // Member variable for the property "Control" - fTreeAutoDetect: Boolean; // True if a potential Virtual TreeView should be detected automatically, false if a specific Tree was assigned to the property "Tree" - fOnAfterExecute: TNotifyEvent; // Member variable for the OnAfterExecute event - function GetSelectedOnly: Boolean; // Setter for the property "SelectedOnly" - procedure SetSelectedOnly(const Value: Boolean); // Getter for the property "SelectedOnly" - strict protected - fFilter: TVirtualNodeStates; // Apply only of nodes which match these states - procedure SetControl(Value: TBaseVirtualTree); // Setter for the property "Control" - procedure Notification(AComponent: TComponent; Operation: TOperation); override; - procedure DoAfterExecute; virtual;// Fires the event "OnAfterExecute" - property SelectedOnly: Boolean read GetSelectedOnly write SetSelectedOnly default False; - public - function HandlesTarget(Target: TObject): Boolean; override; - procedure UpdateTarget(Target: TObject); override; - procedure ExecuteTarget(Target: TObject); override; - published - constructor Create(AOwner: TComponent); override; - function Update: Boolean; override; - property Control: TBaseVirtualTree read fTree write SetControl; - property OnAfterExecute: TNotifyEvent read fOnAfterExecute write fOnAfterExecute; // Executed after the action was performed - property Caption; - property Enabled; - property HelpContext; - property HelpType; - property Hint; - property ImageIndex; - property ShortCut; - property SecondaryShortCuts; - property Visible; - property OnHint; - end; - - TVirtualTreePerItemAction = class(TVirtualTreeAction) - strict private - fOnBeforeExecute: TNotifyEvent; - fOldCursor: TCursor; - strict protected - fToExecute: TVTGetNodeProc; // method which is executed per item to perform this action - procedure DoBeforeExecute(); - procedure DoAfterExecute(); override;// Fires the event "OnAfterExecute" - public - constructor Create(AOwner: TComponent); override; - procedure ExecuteTarget(Target: TObject); override; - published - property OnBeforeExecute: TNotifyEvent read fOnBeforeExecute write fOnBeforeExecute; - end; - - // A standard action which checkmarks nodes in a virtual treeview - TVirtualTreeCheckAll = class(TVirtualTreePerItemAction) - protected - fDesiredCheckState: TCheckState; - public - constructor Create(AOwner: TComponent); override; - published - property SelectedOnly; - property OnUpdate; - end; - - // A standard action which unchecks nodes in a virtual treeview - TVirtualTreeUncheckAll = class(TVirtualTreeCheckAll) - public - constructor Create(AOwner: TComponent); override; - end; - - TVirtualTreeSelectAll = class(TVirtualTreeAction) - public - procedure UpdateTarget(Target: TObject); override; - procedure ExecuteTarget(Target: TObject); override; - end; - - // Base class for actions that are applied to selected nodes only - TVirtualTreeForSelectedAction = class(TVirtualTreeAction) - public - constructor Create(AOwner: TComponent); override; - end; - - TVirtualTreeCopy = class(TVirtualTreeForSelectedAction) - public - procedure ExecuteTarget(Target: TObject); override; - end; - - TVirtualTreeCut = class(TVirtualTreeForSelectedAction) - public - procedure ExecuteTarget(Target: TObject); override; - end; - - TVirtualTreePaste = class(TVirtualTreeForSelectedAction) - public - procedure ExecuteTarget(Target: TObject); override; - end; - - TVirtualTreeDelete = class(TVirtualTreeForSelectedAction) - public - procedure ExecuteTarget(Target: TObject); override; - end; - -procedure Register; - - -implementation - -uses - WinApi.Windows, - Vcl.Forms; - -procedure Register; -begin - RegisterActions('VirtualTree', [TVirtualTreeCheckAll, TVirtualTreeUncheckAll, TVirtualTreeSelectAll, TVirtualTreeCopy, TVirtualTreeCut, TVirtualTreePaste, TVirtualTreeDelete], nil); -end; - -{ TVirtualTreeAction } - -constructor TVirtualTreeAction.Create(AOwner: TComponent); -begin - inherited Create(AOwner); - fTree := nil; - fFilter := []; - fOnAfterExecute := nil; - fTreeAutoDetect := True; -end; - -function TVirtualTreeAction.GetSelectedOnly: Boolean; -begin - exit(TVirtualNodeState.vsSelected in fFilter); -end; - -procedure TVirtualTreeAction.SetSelectedOnly(const Value: Boolean); -begin - if Value then - Include(fFilter, TVirtualNodeState.vsSelected) - else - Exclude(fFilter, TVirtualNodeState.vsSelected); -end; - -procedure TVirtualTreeAction.DoAfterExecute; -begin - if Assigned(fOnAfterExecute) then - fOnAfterExecute(Self); -end; - -function TVirtualTreeAction.HandlesTarget(Target: TObject): Boolean; -begin - Result := (Target is TBaseVirtualTree); -end; - -function TVirtualTreeAction.Update(): Boolean; +unit VirtualTrees.Actions; + +interface + +uses + System.Classes, + System.Actions, + Vcl.Controls, + Vcl.ActnList, + VirtualTrees.Types, + VirtualTrees.BaseTree; + +type + TVirtualTreeAction = class(TCustomAction) + strict private + fTree: TBaseVirtualTree; // Member variable for the property "Control" + fTreeAutoDetect: Boolean; // True if a potential Virtual TreeView should be detected automatically, false if a specific Tree was assigned to the property "Tree" + fOnAfterExecute: TNotifyEvent; // Member variable for the OnAfterExecute event + function GetSelectedOnly: Boolean; // Setter for the property "SelectedOnly" + procedure SetSelectedOnly(const Value: Boolean); // Getter for the property "SelectedOnly" + strict protected + fFilter: TVirtualNodeStates; // Apply only of nodes which match these states + procedure SetControl(Value: TBaseVirtualTree); // Setter for the property "Control" + procedure Notification(AComponent: TComponent; Operation: TOperation); override; + procedure DoAfterExecute; virtual;// Fires the event "OnAfterExecute" + property SelectedOnly: Boolean read GetSelectedOnly write SetSelectedOnly default False; + public + function HandlesTarget(Target: TObject): Boolean; override; + procedure UpdateTarget(Target: TObject); override; + procedure ExecuteTarget(Target: TObject); override; + published + constructor Create(AOwner: TComponent); override; + function Update: Boolean; override; + property Control: TBaseVirtualTree read fTree write SetControl; + property OnAfterExecute: TNotifyEvent read fOnAfterExecute write fOnAfterExecute; // Executed after the action was performed + property Caption; + property Enabled; + property HelpContext; + property HelpType; + property Hint; + property ImageIndex; + property ShortCut; + property SecondaryShortCuts; + property Visible; + property OnHint; + end; + + TVirtualTreePerItemAction = class(TVirtualTreeAction) + strict private + fOnBeforeExecute: TNotifyEvent; + fOldCursor: TCursor; + strict protected + fToExecute: TVTGetNodeProc; // method which is executed per item to perform this action + procedure DoBeforeExecute(); + procedure DoAfterExecute(); override;// Fires the event "OnAfterExecute" + public + constructor Create(AOwner: TComponent); override; + procedure ExecuteTarget(Target: TObject); override; + published + property OnBeforeExecute: TNotifyEvent read fOnBeforeExecute write fOnBeforeExecute; + end; + + // A standard action which checkmarks nodes in a virtual treeview + TVirtualTreeCheckAll = class(TVirtualTreePerItemAction) + protected + fDesiredCheckState: TCheckState; + public + constructor Create(AOwner: TComponent); override; + published + property SelectedOnly; + property OnUpdate; + end; + + // A standard action which unchecks nodes in a virtual treeview + TVirtualTreeUncheckAll = class(TVirtualTreeCheckAll) + public + constructor Create(AOwner: TComponent); override; + end; + + TVirtualTreeSelectAll = class(TVirtualTreeAction) + public + procedure UpdateTarget(Target: TObject); override; + procedure ExecuteTarget(Target: TObject); override; + end; + + // Base class for actions that are applied to selected nodes only + TVirtualTreeForSelectedAction = class(TVirtualTreeAction) + public + constructor Create(AOwner: TComponent); override; + end; + + TVirtualTreeCopy = class(TVirtualTreeForSelectedAction) + public + procedure ExecuteTarget(Target: TObject); override; + end; + + TVirtualTreeCut = class(TVirtualTreeForSelectedAction) + public + procedure ExecuteTarget(Target: TObject); override; + end; + + TVirtualTreePaste = class(TVirtualTreeForSelectedAction) + public + procedure ExecuteTarget(Target: TObject); override; + end; + + TVirtualTreeDelete = class(TVirtualTreeForSelectedAction) + public + procedure ExecuteTarget(Target: TObject); override; + end; + +procedure Register; + + +implementation + +uses + WinApi.Windows, + Vcl.Forms; + +procedure Register; +begin + RegisterActions('VirtualTree', [TVirtualTreeCheckAll, TVirtualTreeUncheckAll, TVirtualTreeSelectAll, TVirtualTreeCopy, TVirtualTreeCut, TVirtualTreePaste, TVirtualTreeDelete], nil); +end; + +{ TVirtualTreeAction } + +constructor TVirtualTreeAction.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + fTree := nil; + fFilter := []; + fOnAfterExecute := nil; + fTreeAutoDetect := True; +end; + +function TVirtualTreeAction.GetSelectedOnly: Boolean; +begin + exit(TVirtualNodeState.vsSelected in fFilter); +end; + +procedure TVirtualTreeAction.SetSelectedOnly(const Value: Boolean); +begin + if Value then + Include(fFilter, TVirtualNodeState.vsSelected) + else + Exclude(fFilter, TVirtualNodeState.vsSelected); +end; + +procedure TVirtualTreeAction.DoAfterExecute; +begin + if Assigned(fOnAfterExecute) then + fOnAfterExecute(Self); +end; + +function TVirtualTreeAction.HandlesTarget(Target: TObject): Boolean; +begin + Result := (Target is TBaseVirtualTree); +end; + +function TVirtualTreeAction.Update(): Boolean; begin Result := inherited; // If an OnUpdate event handler is assigned, TBasicAction.Update() will return True and so TBasicAction.UpdateTarget() will not be called. @@ -166,162 +167,162 @@ function TVirtualTreeAction.Update(): Boolean; SendAppMessage(CM_ACTIONUPDATE, 0, LPARAM(Self)) end; -procedure TVirtualTreeAction.UpdateTarget(Target: TObject); -begin - if fTreeAutoDetect and (Target is TBaseVirtualTree) then - fTree := (Target as TBaseVirtualTree); - Enabled := Assigned(Control) and not Control.IsEmpty and (not SelectedOnly or (Control.SelectedCount > 0)) -end; - -procedure TVirtualTreeAction.ExecuteTarget(Target: TObject); -begin - DoAfterExecute(); -end; - -procedure TVirtualTreeAction.Notification(AComponent: TComponent; Operation: TOperation); -begin - inherited Notification(AComponent, Operation); - if (Operation = opRemove) and (AComponent = FTree) then - FTree := nil; -end; - -procedure TVirtualTreeAction.SetControl(Value: TBaseVirtualTree); -begin - if Value <> fTree then begin - fTree := Value; - if Assigned(fTree) then begin - fTree.FreeNotification(Self);// register Self as a component that should be notified when fTree is about to be destroyed. - end;//if - // Do not update the target of this action if it wa set explicitely by the developer - fTreeAutoDetect := not Assigned(fTree); - end;//if -end; - - -{ TVirtualTreePerItemAction } - -constructor TVirtualTreePerItemAction.Create(AOwner: TComponent); -begin - inherited; - fToExecute := nil; - fOnBeforeExecute := nil; - fOldCursor := crNone; -end; - -procedure TVirtualTreePerItemAction.DoAfterExecute; -begin - inherited; - if fOldCursor <> crNone then - Screen.Cursor := fOldCursor; -end; - -procedure TVirtualTreePerItemAction.DoBeforeExecute; -begin - if Screen.Cursor <> crHourGlass then begin - fOldCursor := Screen.Cursor; - Screen.Cursor := crHourGlass; - end;//if - if Assigned(fOnBeforeExecute) then - fOnBeforeExecute(Self); -end; - -procedure TVirtualTreePerItemAction.ExecuteTarget(Target: TObject); -begin - DoBeforeExecute(); - Control.BeginUpdate(); - try - Control.IterateSubtree(nil, Self.fToExecute, nil, fFilter, true); - finally - Control.EndUpdate(); - DoAfterExecute(); - end; -end; - -{ TVirtualTreeCheckAll } - -constructor TVirtualTreeCheckAll.Create(AOwner: TComponent); -begin - inherited Create(AOwner); - Hint := 'Check all items in the list'; - Caption := 'Check &All'; - fDesiredCheckState := csCheckedNormal; - fToExecute := procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Data: Pointer; var Abort: Boolean) - begin - if not Control.CheckState[Node].IsDisabled then - Control.CheckState[Node] := fDesiredCheckState; - end; -end; - - -{ TVirtualTreeUncheckAll } - -constructor TVirtualTreeUncheckAll.Create(AOwner: TComponent); -begin - inherited Create(AOwner); - Hint := 'Uncheck all items in the list'; - Caption := '&Uncheck All'; - fDesiredCheckState := csUncheckedNormal; -end; - - -{ TVirtualStringSelectAll } - -procedure TVirtualTreeSelectAll.UpdateTarget(Target: TObject); -begin - Inherited; - //Enabled := Enabled and (toMultiSelect in Control.TreeOptions.SelectionOptions) // TreeOptions is protected :-( -end; - -procedure TVirtualTreeSelectAll.ExecuteTarget(Target: TObject); -begin - Control.SelectAll(False); - inherited; -end; - - -{ TVirtualTreeForSelectedAction } - -constructor TVirtualTreeForSelectedAction.Create(AOwner: TComponent); -begin - inherited; - SelectedOnly := True; -end; - - -{ TVirtualTreeCopy } - -procedure TVirtualTreeCopy.ExecuteTarget(Target: TObject); -begin - Control.CopyToClipboard(); - Inherited; -end; - - -{ TVirtualTreeCut } - -procedure TVirtualTreeCut.ExecuteTarget(Target: TObject); -begin - Control.CutToClipboard(); - Inherited; -end; - - -{ TVirtualTreePaste } - -procedure TVirtualTreePaste.ExecuteTarget(Target: TObject); -begin - Control.PasteFromClipboard(); - Inherited; -end; - - -{ TVirtualTreeDelete } - -procedure TVirtualTreeDelete.ExecuteTarget(Target: TObject); -begin - Control.DeleteSelectedNodes(); - Inherited; -end; - - -end. +procedure TVirtualTreeAction.UpdateTarget(Target: TObject); +begin + if fTreeAutoDetect and (Target is TBaseVirtualTree) then + fTree := (Target as TBaseVirtualTree); + Enabled := Assigned(Control) and not Control.IsEmpty and (not SelectedOnly or (Control.SelectedCount > 0)) +end; + +procedure TVirtualTreeAction.ExecuteTarget(Target: TObject); +begin + DoAfterExecute(); +end; + +procedure TVirtualTreeAction.Notification(AComponent: TComponent; Operation: TOperation); +begin + inherited Notification(AComponent, Operation); + if (Operation = opRemove) and (AComponent = FTree) then + FTree := nil; +end; + +procedure TVirtualTreeAction.SetControl(Value: TBaseVirtualTree); +begin + if Value <> fTree then begin + fTree := Value; + if Assigned(fTree) then begin + fTree.FreeNotification(Self);// register Self as a component that should be notified when fTree is about to be destroyed. + end;//if + // Do not update the target of this action if it wa set explicitely by the developer + fTreeAutoDetect := not Assigned(fTree); + end;//if +end; + + +{ TVirtualTreePerItemAction } + +constructor TVirtualTreePerItemAction.Create(AOwner: TComponent); +begin + inherited; + fToExecute := nil; + fOnBeforeExecute := nil; + fOldCursor := crNone; +end; + +procedure TVirtualTreePerItemAction.DoAfterExecute; +begin + inherited; + if fOldCursor <> crNone then + Screen.Cursor := fOldCursor; +end; + +procedure TVirtualTreePerItemAction.DoBeforeExecute; +begin + if Screen.Cursor <> crHourGlass then begin + fOldCursor := Screen.Cursor; + Screen.Cursor := crHourGlass; + end;//if + if Assigned(fOnBeforeExecute) then + fOnBeforeExecute(Self); +end; + +procedure TVirtualTreePerItemAction.ExecuteTarget(Target: TObject); +begin + DoBeforeExecute(); + Control.BeginUpdate(); + try + Control.IterateSubtree(nil, Self.fToExecute, nil, fFilter, true); + finally + Control.EndUpdate(); + DoAfterExecute(); + end; +end; + +{ TVirtualTreeCheckAll } + +constructor TVirtualTreeCheckAll.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + Hint := 'Check all items in the list'; + Caption := 'Check &All'; + fDesiredCheckState := csCheckedNormal; + fToExecute := procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Data: Pointer; var Abort: Boolean) + begin + if not Control.CheckState[Node].IsDisabled then + Control.CheckState[Node] := fDesiredCheckState; + end; +end; + + +{ TVirtualTreeUncheckAll } + +constructor TVirtualTreeUncheckAll.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + Hint := 'Uncheck all items in the list'; + Caption := '&Uncheck All'; + fDesiredCheckState := csUncheckedNormal; +end; + + +{ TVirtualStringSelectAll } + +procedure TVirtualTreeSelectAll.UpdateTarget(Target: TObject); +begin + Inherited; + //Enabled := Enabled and (toMultiSelect in Control.TreeOptions.SelectionOptions) // TreeOptions is protected :-( +end; + +procedure TVirtualTreeSelectAll.ExecuteTarget(Target: TObject); +begin + Control.SelectAll(False); + inherited; +end; + + +{ TVirtualTreeForSelectedAction } + +constructor TVirtualTreeForSelectedAction.Create(AOwner: TComponent); +begin + inherited; + SelectedOnly := True; +end; + + +{ TVirtualTreeCopy } + +procedure TVirtualTreeCopy.ExecuteTarget(Target: TObject); +begin + Control.CopyToClipboard(); + Inherited; +end; + + +{ TVirtualTreeCut } + +procedure TVirtualTreeCut.ExecuteTarget(Target: TObject); +begin + Control.CutToClipboard(); + Inherited; +end; + + +{ TVirtualTreePaste } + +procedure TVirtualTreePaste.ExecuteTarget(Target: TObject); +begin + Control.PasteFromClipboard(); + Inherited; +end; + + +{ TVirtualTreeDelete } + +procedure TVirtualTreeDelete.ExecuteTarget(Target: TObject); +begin + Control.DeleteSelectedNodes(); + Inherited; +end; + + +end. diff --git a/components/virtualtreeview/Source/VirtualTrees.AncestorFMX.pas b/components/virtualtreeview/Source/VirtualTrees.AncestorFMX.pas new file mode 100644 index 000000000..ca82b78e4 --- /dev/null +++ b/components/virtualtreeview/Source/VirtualTrees.AncestorFMX.pas @@ -0,0 +1,309 @@ +unit VirtualTrees.AncestorFMX; + +{$SCOPEDENUMS ON} + +{****************************************************************************************************************} +{ Project : VirtualTrees } +{ } +{ author : Karol Bieniaszewski } +{ year : 2022 } +{ contibutors : } +{****************************************************************************************************************} + +interface + +uses + System.Classes, System.UITypes, + FMX.Graphics, + VirtualTrees.FMX, VirtualTrees.BaseTree; + +const + EVENT_OBJECT_STATECHANGE = $800A; + +type + TVTAncestorFMX = class abstract(TBaseVirtualTree) + protected + procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X: Single; Y: Single); override; + procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X: Single; Y: Single); override; + procedure MouseWheel(Shift: TShiftState; WheelDelta: Integer; var Handled: Boolean); override; + + function PrepareDottedBrush(CurrentDottedBrush: TBrush; Bits: Pointer; const BitsLinesCount: Word): TBrush; override; + + function GetClientHeight: Single; override; + function GetClientWidth: Single; override; + function GetClientRect: TRect; override; + + procedure NotifyAccessibleEvent(pEvent: Uint32 = EVENT_OBJECT_STATECHANGE); virtual; + procedure HScrollChangeProc(Sender: TObject); override; + procedure VScrollChangeProc(Sender: TObject); override; + + procedure Resize; override; + //TODO: CopyCutPaste - need to be implemented + { + function PasteFromClipboard(): Boolean; override; + procedure CopyToClipboard(); override; + procedure CutToClipboard(); override; + } + public + constructor Create(AOwner: TComponent); override; + end; + +implementation +uses + System.SysUtils, + FMX.Forms, + VirtualTrees.Header, + VirtualTrees.Types; + +type + TVTHeaderCracker = class(TVTHeader); + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTAncestorFMX.MouseDown(Button: TMouseButton; Shift: TShiftState; X: Single; Y: Single); //wymaga BaseTree +Var MM: TWMMouse; + hInfo: THitInfo; + P: TPoint; + isNC: Boolean; +begin + P.X:= X; + P.Y:= Y; + if ClientRect.Contains(P) then + begin + isNc:= false; + end else + begin + isNC:= true; + P:= ClientToScreen(P); + end; + FillTWMMouse(MM, Button, Shift, P.X, P.Y, isNC, false); + if TVTHeaderCracker(Header).HandleMessage(TMessage(MM)) then + exit;//!!! + + FillTWMMouse(MM, Button, Shift, X, Y, isNC, false); + // get information about the hit + GetHitTestInfoAt(X, Y, True, hInfo); + + HandleMouseDown(MM, hInfo); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTAncestorFMX.MouseUp(Button: TMouseButton; Shift: TShiftState; X: Single; Y: Single); //wymaga BaseTree +Var MM: TWMMouse; + hInfo: THitInfo; + P: TPoint; + isNC: Boolean; +begin + P.X:= X; + P.Y:= Y; + if ClientRect.Contains(P) then + begin + isNc:= false; + end else + begin + isNC:= true; + P:= ClientToScreen(P); + end; + FillTWMMouse(MM, Button, Shift, P.X, P.Y, isNC, true); + if TVTHeaderCracker(Header).HandleMessage(TMessage(MM)) then + exit;//!!! + + FillTWMMouse(MM, Button, Shift, X, Y, isNC, true); + // get information about the hit + GetHitTestInfoAt(X, Y, True, hInfo); + HandleMouseUp(MM, hInfo); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTAncestorFMX.MouseWheel(Shift: TShiftState; WheelDelta: Integer; var Handled: Boolean); //wymaga BaseTree +Var M: TCMMouseWheel; + P: TPoint; +begin + P:= Screen.MousePos; + if not ClientRect.Contains(P) then + P:= ClientToScreen(P); + + M.Msg:= CM_MOUSEWHEEL; + M.ShiftState:= Shift; + M.WheelDelta:= WheelDelta; + M.XPos:= P.X; + M.YPos:= P.Y; + M.Result:= 0; + CMMouseWheel(M); + Handled:= M.Result<>0; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTAncestorFMX.NotifyAccessibleEvent(pEvent: Uint32); +begin + // Currently empty by intention as highly platfrom depedant +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTAncestorFMX.PrepareDottedBrush(CurrentDottedBrush: TBrush; Bits: Pointer; const BitsLinesCount: Word): TBrush; +Var PatternBitmap: TBitmap; + i_bmp, line, bit: Integer; +begin + //FMX pattern brush is different then VCL. Where color is derived from current one... + //We should have 2 brushes 1 for Tree lines 1 for grid lines + //and recreate it every time when color is changing + + CurrentDottedBrush.Free; + FDottedBrushGridLines.Free; + + Result := nil; + for i_bmp:= 1 to 2 do + begin + PatternBitmap := TBitmap.Create(8, BitsLinesCount); + PatternBitmap.Clear(TAlphaColorRec.Null); //fully transparent + PatternBitmap.Canvas.BeginScene; + + PatternBitmap.Map(TMapAccess.Write, BitmapData); + try + { + DestPitch := PixelFormatBytes[PatternBitmap.PixelFormat]; + System.Move(PAlphaColorArray(BitmapData.Data)[0], PAlphaColorArray(Bits)[0], 8 * 4); + } + for line:= 0 to BitsLinesCount-1 do + begin + for bit:= 0 to 7 do + begin + if PWordArray(Bits)^[line] and (1 shl bit)=0 then + BitmapData.SetPixel(bit, line, clWhite) else + begin + if i_bmp=1 then + BitmapData.SetPixel(bit, line, TreeColors.TreeLineColor) else + BitmapData.SetPixel(bit, line, TreeColors.GridLineColor); + end; + end; + end; + finally + PatternBitmap.UnMap(BitmapData); + end; + + PatternBitmap.Canvas.EndScene; + + if i_bmp=1 then + begin + Result := TStrokeBrush.Create(TBrushKind.Bitmap, clWhite); + Result.Bitmap.Bitmap.Assign(PatternBitmap); + end else + begin + FDottedBrushGridLines := TStrokeBrush.Create(TBrushKind.Bitmap, clWhite); + FDottedBrushGridLines.Bitmap.Bitmap.Assign(PatternBitmap); + end; + FreeAndNil(PatternBitmap); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTAncestorFMX.Resize; +Var M: TWMSize; +begin + inherited; + + if FInCreate then + exit; //!! + + M.Msg:= WM_SIZE; + M.SizeType:= SIZE_RESTORED; + M.Width:= Width; + M.Height:= Height; + M.Result:= 0; + WMSize(M); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTAncestorFMX.VScrollChangeProc(Sender: TObject); +Var M: TWMHScroll; +begin + M.Msg:= WM_VSCROLL; + M.ScrollCode:= SB_THUMBPOSITION; + M.Pos:= GetScrollPos(SB_VERT); + M.ScrollBar:= SB_VERT; + M.Result:= 0; + + WMVScroll(M); + Repaint; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTAncestorFMX.HScrollChangeProc(Sender: TObject); +Var M: TWMHScroll; +begin + M.Msg:= WM_HSCROLL; + M.ScrollCode:= SB_THUMBPOSITION; + M.Pos:= GetScrollPos(SB_HORZ); + M.ScrollBar:= SB_HORZ; + M.Result:= 0; + + WMHScroll(M); + Repaint; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +constructor TVTAncestorFMX.Create(AOwner: TComponent); +begin + FInCreate:= true; + + inherited; + + BackgroundOffsetX:= 0; + BackgroundOffsetY:= 0; + Margin:= 4; + TextMargin:= 4; + DefaultNodeHeight:= 18; //??? + Indent:= 18; //??? + + FInCreate:= false; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTAncestorFMX.GetClientHeight: Single; +begin + Result:= ClientRect.Height; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTAncestorFMX.GetClientWidth: Single; +begin + Result:= ClientRect.Width; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTAncestorFMX.GetClientRect: TRect; +begin + Result:= ClipRect; + if Assigned(Header) then + begin + if TVTHeaderOption.hoVisible in Header.Options then + Inc(Result.Top, Header.Height); + end; + if FVScrollBar.Visible then + Dec(Result.Right, VScrollBar.Width); + if HScrollBar.Visible then + Dec(Result.Bottom, HScrollBar.Height); + + if Result.Left>Result.Right then + Result.Left:= Result.Right; + + if Result.Top>Result.Bottom then + Result.Top:= Result.Bottom; + + //OffsetRect(Result, OffsetX, OffsetY); + //Dec(Result.Left, -OffsetX); //increase width + //Dec(Result.Top, -OffsetY); //increase height +end; + +end. diff --git a/components/virtualtreeview/Source/VirtualTrees.AncestorVcl.pas b/components/virtualtreeview/Source/VirtualTrees.AncestorVcl.pas new file mode 100644 index 000000000..d0739a9e7 --- /dev/null +++ b/components/virtualtreeview/Source/VirtualTrees.AncestorVcl.pas @@ -0,0 +1,494 @@ +unit VirtualTrees.AncestorVCL; + +{$SCOPEDENUMS ON} + +{****************************************************************************************************************} +{ Project : VirtualTrees } +{ } +{ author : Karol Bieniaszewski, look at VirtualTrees.pas as some code moved from there } +{ year : 2022 } +{ contibutors : } +{****************************************************************************************************************} + +interface + +uses + Vcl.Controls, + Vcl.Themes, + Winapi.Messages, + Winapi.Windows, + Winapi.oleacc, + Winapi.ActiveX, + VirtualTrees.Types, + VirtualTrees.BaseTree; + +type + TVTRenderOLEDataEvent = procedure(Sender: TBaseVirtualTree; const FormatEtcIn: TFormatEtc; out Medium: TStgMedium; + ForClipboard: Boolean; var Result: HRESULT) of object; + + TVTAncestorVcl = class abstract(TBaseVirtualTree) + private + FOnRenderOLEData: TVTRenderOLEDataEvent; // application/descendant defined clipboard formats + + protected + function GetHintWindowClass: THintWindowClass; override; + class function GetTreeFromDataObject(const DataObject: TVTDragDataObject): TBaseVirtualTree; deprecated 'Use class TVTDragManager.GetTreeFromDataObject() instead'; + function DoRenderOLEData(const FormatEtcIn: TFormatEtc; out Medium: TStgMedium; ForClipboard: Boolean): HRESULT; override; + property OnRenderOLEData: TVTRenderOLEDataEvent read FOnRenderOLEData write FOnRenderOLEData; + public //methods + function PasteFromClipboard(): Boolean; override; + end; + + // The trees need an own hint window class because of Unicode output and adjusted font. + TVirtualTreeHintWindow = class(THintWindow) + strict private + FHintData: TVTHintData; + FTextHeight: TDimension; + procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED; + procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND; + strict protected + procedure CreateParams(var Params: TCreateParams); override; + procedure Paint; override; + // Mitigator function to use the correct style service for this context (either the style assigned to the control for Delphi > 10.4 or the application style) + function StyleServices(AControl: TControl = nil): TCustomStyleServices; + public + function CalcHintRect(MaxWidth: TDimension; const AHint: string; AData: Pointer): TRect; override; + function IsHintMsg(var Msg: TMsg): Boolean; override; + end; + +implementation +uses + System.Classes, + Vcl.Graphics, + System.UITypes, + Vcl.AxCtrls, + Vcl.Forms, + Vcl.GraphUtil, + VirtualTrees.ClipBoard, + VirtualTrees.DataObject, + VirtualTrees.DragnDrop, + VirtualTrees.StyleHooks; + +resourcestring + SClipboardFailed = 'Clipboard operation failed.'; + +type + TBVTCracker = class(TBaseVirtualTree); + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTAncestorVcl.DoRenderOLEData(const FormatEtcIn: TFormatEtc; out Medium: TStgMedium; ForClipboard: Boolean): HRESULT; +begin + Result := E_FAIL; + if Assigned(FOnRenderOLEData) then + FOnRenderOLEData(Self, FormatEtcIn, Medium, ForClipboard, Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTAncestorVcl.GetHintWindowClass: THintWindowClass; + +// Returns the default hint window class used for the tree. Descendants can override it to use their own classes. + +begin + Result := TVirtualTreeHintWindow; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +class function TVTAncestorVcl.GetTreeFromDataObject(const DataObject: TVTDragDataObject): TBaseVirtualTree; + +// Returns the owner/sender of the given data object by means of a special clipboard format +// or nil if the sender is in another process or no virtual tree at all. + +var + Medium: TStgMedium; + Data: PVTReference; + +begin + Result := nil; + if Assigned(DataObject) then + begin + StandardOLEFormat.cfFormat := CF_VTREFERENCE; + if DataObject.GetData(StandardOLEFormat, Medium) = S_OK then + begin + Data := GlobalLock(Medium.hGlobal); + if Assigned(Data) then + begin + if Data.Process = GetCurrentProcessID then + Result := Data.Tree; + GlobalUnlock(Medium.hGlobal); + end; + ReleaseStgMedium(Medium); + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTAncestorVcl.PasteFromClipboard(): Boolean; + +// Reads what is currently on the clipboard into the tree (if the format is supported). +// Note: If the application wants to have text or special formats to be inserted then it must implement +// its own code (OLE). Here only the native tree format is accepted. + +var + Data: IDataObject; + Source: TBaseVirtualTree; + +begin + Result := False; + if not (toReadOnly in TreeOptions.MiscOptions) then + begin + if OleGetClipboard(Data) <> S_OK then + RaiseVTError(SClipboardFailed, hcTFClipboardFailed) + else + begin + // Try to get the source tree of the operation to optimize the operation. + Source := TVTDragManager.GetTreeFromDataObject(Data); + Result := ProcessOLEData(Source, Data, FocusedNode, DefaultPasteMode, Assigned(Source) and + (tsCutPending in Source.TreeStates)); + if Assigned(Source) then + begin + if Source <> Self then + Source.FinishCutOrCopy + else + DoStateChange([], [tsCutPending]); + end; + end; + end; +end; + +//----------------- TVirtualTreeHintWindow ----------------------------------------------------------------------------- + +procedure TVirtualTreeHintWindow.CMTextChanged(var Message: TMessage); + +begin + // swallow this message to prevent the ancestor from resizing the window (we don't use the caption anyway) +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeHintWindow.WMEraseBkgnd(var Message: TWMEraseBkgnd); + +// The control is fully painted by own code so don't erase its background as this causes flickering. + +begin + Message.Result := 1; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeHintWindow.CreateParams(var Params: TCreateParams); + +begin + inherited CreateParams(Params); + + with Params do + begin + Style := WS_POPUP; + ExStyle := ExStyle and not WS_EX_CLIENTEDGE; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeHintWindow.Paint(); +var + R: TRect; + Y: Integer; + S: string; + DrawFormat: Cardinal; + HintKind: TVTHintKind; + LClipRect: TRect; + + LColor: TColor; + LDetails: TThemedElementDetails; + LGradientStart: TColor; + LGradientEnd: TColor; + +begin + with FHintData do + begin + // Do actual painting only in the very first run. + // If the given node is nil then we have to display a header hint. + if (Node = nil) or (TBVTCracker(Tree).HintMode <> hmToolTip) then + begin + Canvas.Font := Screen.HintFont; + Canvas.Font.Height := MulDiv(Canvas.Font.Height, Tree.ScaledPixels(96), Screen.PixelsPerInch); // See issue #992 + Y := 2; + end + else + begin + Tree.GetTextInfo(Node, Column, Canvas.Font, R, S); + if LineBreakStyle = hlbForceMultiLine then + Y := 1 + else + Y := (R.Top - R.Bottom + Self.Height) div 2; + end; + + R := Rect(0, 0, Width, Height); + + HintKind := vhkText; + if Assigned(Node) then + TBVTCracker(Tree).DoGetHintKind(Node, Column, HintKind); + + if HintKind = vhkOwnerDraw then + begin + TBVTCracker(Tree).DoDrawHint(Canvas, Node, R, Column); + end + else + with Canvas do + begin + if TBVTCracker(Tree).VclStyleEnabled then + begin + InflateRect(R, -1, -1); // Fixes missing border when VCL styles are used + LDetails := StyleServices(Tree).GetElementDetails(thHintNormal); + if StyleServices(Tree).GetElementColor(LDetails, ecGradientColor1, LColor) and (LColor <> clNone) then + LGradientStart := LColor + else + LGradientStart := clInfoBk; + if StyleServices(Tree).GetElementColor(LDetails, ecGradientColor2, LColor) and (LColor <> clNone) then + LGradientEnd := LColor + else + LGradientEnd := clInfoBk; + if StyleServices(Tree).GetElementColor(LDetails, ecTextColor, LColor) and (LColor <> clNone) then + Font.Color := LColor + else + Font.Color := Screen.HintFont.Color; + GradientFillCanvas(Canvas, LGradientStart, LGradientEnd, R, gdVertical); + end + else + begin + // Still force tooltip back and text color. + Font.Color := clInfoText; + Pen.Color := clBlack; + Brush.Color := clInfoBk; + if StyleServices(Tree).Enabled and ((toThemeAware in TBVTCracker(Tree).TreeOptions.PaintOptions) or + (toUseExplorerTheme in TBVTCracker(Tree).TreeOptions.PaintOptions)) then + begin + if toUseExplorerTheme in TBVTCracker(Tree).TreeOptions.PaintOptions then // ToolTip style + StyleServices(Tree).DrawElement(Canvas.Handle, StyleServices(Tree).GetElementDetails(tttStandardNormal), R {$IF CompilerVersion >= 34}, nil, FCurrentPPI{$IFEND}) + else + begin // Hint style + LClipRect := R; + InflateRect(R, 4, 4); + StyleServices(Tree).DrawElement(Handle, StyleServices(Tree).GetElementDetails(tttStandardNormal), R, @LClipRect{$IF CompilerVersion >= 34}, FCurrentPPI{$IFEND}); + R := LClipRect; + StyleServices(Tree).DrawEdge(Handle, StyleServices(Tree).GetElementDetails(twWindowRoot), R, [eeRaisedOuter], [efRect]); + end; + end + else + if TBVTCracker(Tree).VclStyleEnabled then + StyleServices(Tree).DrawElement(Canvas.Handle, StyleServices(Tree).GetElementDetails(tttStandardNormal), R {$IF CompilerVersion >= 34}, nil, FCurrentPPI{$IFEND}) + else + Rectangle(R); + end; + // Determine text position and don't forget the border. + InflateRect(R, -1, -1); + DrawFormat := DT_TOP or DT_NOPREFIX; + SetBkMode(Handle, Winapi.Windows.TRANSPARENT); + R.Top := Y; + R.Left := R.Left + 3; // Make the text more centered + if Assigned(Node) and (LineBreakStyle = hlbForceMultiLine) then + DrawFormat := DrawFormat or DT_WORDBREAK; + Winapi.Windows.DrawTextW(Handle, PWideChar(HintText), Length(HintText), R, DrawFormat); + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeHintWindow.StyleServices(AControl: TControl): TCustomStyleServices; +begin + Result := VTStyleServices(AControl); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeHintWindow.CalcHintRect(MaxWidth: Integer; const AHint: string; AData: Pointer): TRect; + +var + TM: TTextMetric; + R: TRect; + +begin + try + if AData = nil then + // Defensive approach, it *can* happen that AData is nil. Maybe when several user defined hint classes are used. + Result := Rect(0, 0, 0, 0) + else + begin + // The hint window does not need any bidi mode setting but the caller of this method (TApplication.ActivateHint) + // does some unneccessary actions if the hint window is not left-to-right. + // The text alignment is based on the bidi mode passed in the hint data, hence we can + // simply set the window's mode to left-to-right (it might have been modified by the caller, if the + // tree window is right-to-left aligned). + BidiMode := bdLeftToRight; + + FHintData := PVTHintData(AData)^; + + with FHintData do + begin + // The draw tree gets its hint size by the application (but only if not a header hint is about to show). + // If the user will be drawing the hint, it gets its hint size by the application + // (but only if not a header hint is about to show). + // This size has already been determined in CMHintShow. + if Assigned(Node) and (not IsRectEmpty(HintRect)) then + Result := HintRect + else + begin + if Column <= NoColumn then + begin + BidiMode := Tree.BidiMode; + Alignment := TBVTCracker(Tree).Alignment; + end + else + begin + BidiMode := Tree.Header.Columns[Column].BidiMode; + Alignment := Tree.Header.Columns[Column].Alignment; + end; + + if BidiMode <> bdLeftToRight then + ChangeBidiModeAlignment(Alignment); + + if (Node = nil) or (TBVTCracker(Tree).HintMode <> hmToolTip) then + begin + Canvas.Font := Screen.HintFont; + Canvas.Font.Height := MulDiv(Canvas.Font.Height, Tree.ScaledPixels(96), Screen.PixelsPerInch); // See issue #992 + end + else + begin + Canvas.Font := Tree.Font; + with TBVTCracker(Tree) do + DoPaintText(Node, Self.Canvas, Column, ttNormal); + end; + + GetTextMetrics(Canvas.Handle, TM); + FTextHeight := TM.tmHeight; + + if Length(HintText) = 0 then + Result := Rect(0, 0, 0, 0) + else + begin + if Assigned(Node) and (TBVTCracker(Tree).HintMode = hmToolTip) then + begin + // Determine actual line break style depending on what was returned by the methods and what's in the node. + if LineBreakStyle = hlbDefault then + if (vsMultiline in Node.States) or HintText.Contains(#13) then + LineBreakStyle := hlbForceMultiLine + else + LineBreakStyle := hlbForceSingleLine; + + // Hint for a node. + if LineBreakStyle = hlbForceMultiLine then + begin + // Multiline tooltips use the columns width but extend the bottom border to fit the whole caption. + Result := Tree.GetDisplayRect(Node, Column, True, False); + R := Result; + + // On Windows NT/2K/XP the behavior of the tooltip is slightly different to that on Windows 9x/Me. + // We don't have Unicode word wrap on the latter so the tooltip gets as wide as the largest line + // in the caption (limited by carriage return), which results in unoptimal overlay of the tooltip. + Winapi.Windows.DrawTextW(Canvas.Handle, PWideChar(HintText), Length(HintText), R, DT_CALCRECT or DT_WORDBREAK); + if BidiMode = bdLeftToRight then + Result.Right := R.Right + TBVTCracker(Tree).TextMargin + else + Result.Left := R.Left - TBVTCracker(Tree).TextMargin + 1; + Result.Bottom := R.Bottom; + + Inc(Result.Right); + + // If the node height and the column width are both already large enough to cover the entire text, + // then we don't need the hint, though. + // However if the text is partially scrolled out of the client area then a hint is useful as well. + if (Tree.Header.Columns.Count > 0) and ((Tree.NodeHeight[Node] + 2) >= (Result.Bottom - Result.Top)) and + ((Tree.Header.Columns[Column].Width + 2) >= (Result.Right - Result.Left)) and not + ((Result.Left < 0) or (Result.Right > Tree.ClientWidth + 3) or + (Result.Top < 0) or (Result.Bottom > Tree.ClientHeight + 3)) then + begin + Result := Rect(0, 0, 0, 0); + Exit; + end; + end + else + begin + Result := TBVTCracker(Tree).LastHintRect; // = Tree.GetDisplayRect(Node, Column, True, True, True); see TBaseVirtualTree.CMHintShow + + { Fixes issue #623 + + Measure the rectangle to draw the text. The width of the result + is always adjusted according to the hint text because it may + be a custom hint coming in which can be larger or smaller than + the node text. + Earlier logic was using the current width of the node that was + either cutting off the hint text or producing undesired space + on the right. + } + R := Rect(0, 0, MaxWidth, FTextHeight); + Winapi.Windows.DrawTextW(Canvas.Handle, PWideChar(HintText), Length(HintText), R, DT_CALCRECT or DT_TOP or DT_NOPREFIX or DT_WORDBREAK); + if R.Right <> result.right - result.left then + begin + result.Right := result.Left + r.Right; + + //Space on right--taken from the code in the hmHint branch below. + if Assigned(Tree) then + Inc(Result.Right, TBVTCracker(Tree).TextMargin + TBVTCracker(Tree).Margin + Tree.ScaledPixels(4)); + end; + // Fix ends. + + if toShowHorzGridLines in TBVTCracker(Tree).TreeOptions.PaintOptions then + Dec(Result.Bottom); + end; + + // Include a one pixel border. + InflateRect(Result, 1, 1); + + // Make the coordinates relative. They will again be offset by the caller code. + OffsetRect(Result, -Result.Left - 1, -Result.Top - 1); + end + else + begin + // Hint for a header or non-tooltip hint. + + // Start with the base size of the hint in client coordinates. + Result := Rect(0, 0, MaxWidth, FTextHeight); + // Calculate the true size of the text rectangle. + Winapi.Windows.DrawTextW(Canvas.Handle, PWideChar(HintText), Length(HintText), Result, DT_CALCRECT or DT_TOP or DT_NOPREFIX or DT_WORDBREAK); + // The height of the text plus 2 pixels vertical margin plus the border determine the hint window height. + // Minus 4 because THintWindow.ActivateHint adds 4 to Rect.Bottom anyway. Note that it is not scaled because the RTL itself does not do any scaling either. + Inc(Result.Bottom, Tree.ScaledPixels(6) - 4); + // The text is centered horizontally with usual text margin for left and right borders (plus border). + if not Assigned(Tree) then + Exit; // Workaround, because we have seen several exceptions here caught by Eurekalog. Submitted as issue #114 to http://code.google.com/p/virtual-treeview/ + { Issue #623 Fix for strange space on the right. + Original logic was adding FTextHeight. Changed it to add FMargin instead and + it looks OK even if the hint font is larger. + } + Inc(Result.Right, TBVTCracker(Tree).TextMargin + + TBVTCracker(Tree).Margin + Tree.ScaledPixels(4)); //Issue #623 space on right + //+ FTextHeight); // Old code: We are extending the width here, but the text height scales with the text width and has a similar value as AveCharWdith * 2. + end; + end; + end; + end; + end; + except + Application.HandleException(Self); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeHintWindow.IsHintMsg(var Msg: TMsg): Boolean; + +// The VCL is a bit too generous when telling that an existing hint can be cancelled. Need to specify further here. + +begin + Result := inherited IsHintMsg(Msg) and HandleAllocated and IsWindowVisible(Handle); + // Avoid that mouse moves over the non-client area or cursor key presses cancel the current hint. + if Result and ((Msg.Message = WM_NCMOUSEMOVE) or ((Msg.Message >= WM_KEYFIRST) and (Msg.Message <= WM_KEYLAST) and (Msg.wparam in [VK_UP, VK_DOWN, VK_LEFT, VK_RIGHT]))) then + Result := False; +end; + +end. diff --git a/components/virtualtreeview/Source/VirtualTrees.BaseAncestorFMX.pas b/components/virtualtreeview/Source/VirtualTrees.BaseAncestorFMX.pas new file mode 100644 index 000000000..9d7ba60cf --- /dev/null +++ b/components/virtualtreeview/Source/VirtualTrees.BaseAncestorFMX.pas @@ -0,0 +1,553 @@ +unit VirtualTrees.BaseAncestorFMX; + +{$SCOPEDENUMS ON} + +{****************************************************************************************************************} +{ Project : VirtualTrees } +{ } +{ author : Karol Bieniaszewski } +{ year : 2022 } +{ contibutors : } +{****************************************************************************************************************} + +interface +uses + {$IFDEF MSWINDOWS} + WinApi.Windows, + {$ENDIF} + System.Classes, System.UITypes, + FMX.Objects, FMX.Graphics, FMX.Controls, FMX.StdCtrls, FMX.Forms, FMX.ImgList, + VirtualTrees.Types, VirtualTrees.FMX; + + +type + TVTBaseAncestorFMX = class abstract(TRectangle) + strict private + FFont: TFont; + procedure SetFont(const Value: TFont); + private + FDottedBrushTreeLines: TStrokeBrush; // used to paint dotted lines without special pens + FDottedBrushGridLines: TStrokeBrush; // used to paint dotted lines without special pens + FInCreate: Boolean; + + function GetFillColor: TAlphaColor; + procedure SetFillColor(const Value: TAlphaColor); + protected + FBevelEdges: TBevelEdges; + FBevelInner: TBevelCut; + FBevelOuter: TBevelCut; + FBevelKind: TBevelKind; + FBevelWidth: TBevelWidth; + FBorderWidth: TBorderWidth; + FHandleAllocated: Boolean; + FBiDiMode: TBiDiMode; + FHScrollBar: TScrollBar; + FVScrollBar: TScrollBar; + + FUseRightToLeftAlignment: Boolean; + + procedure SetBevelCut(Index: Integer; const Value: TBevelCut); + procedure SetBevelEdges(const Value: TBevelEdges); + procedure SetBevelKind(const Value: TBevelKind); + procedure SetBevelWidth(const Value: TBevelWidth); + procedure SetBorderWidth(Value: TBorderWidth); + procedure SetBiDiMode(Value: TBiDiMode); + + function GetClientHeight: Single; virtual; abstract; + function GetClientWidth: Single; virtual; abstract; + function GetClientRect: TRect; virtual; abstract; + procedure UpdateStyleElements; virtual; abstract; + + procedure DoStartDrag(var DragObject: TVTDragDataObject); virtual; abstract; + procedure DoEndDrag(Target: TObject; X, Y: TDimension); virtual; abstract; + procedure DragCanceled; virtual; abstract; + + procedure Resize; override; + function CreateSystemImageSet(): TImageList; + procedure SetWindowTheme(const Theme: string); virtual; + + procedure ChangeScale(M, D: Integer{$if CompilerVersion >= 31}; isDpiChange: Boolean{$ifend}); virtual; abstract; + function GetControlsAlignment: TAlignment; virtual; abstract; + function PrepareDottedBrush(CurrentDottedBrush: TBrush; Bits: Pointer; const BitsLinesCount: Word): TBrush; virtual; abstract; + function GetSelectedCount(): Integer; virtual; abstract; + procedure MarkCutCopyNodes; virtual; abstract; + function GetSortedCutCopySet(Resolve: Boolean): TNodeArray; virtual; abstract; + function GetSortedSelection(Resolve: Boolean): TNodeArray; virtual; abstract; + procedure WriteNode(Stream: TStream; Node: PVirtualNode); virtual; abstract; + procedure DoMouseEnter(); reintroduce; overload; virtual; abstract; + procedure DoMouseLeave(); reintroduce; overload; virtual; abstract; + protected //properties + property DottedBrushTreeLines: TStrokeBrush read FDottedBrushTreeLines write FDottedBrushTreeLines; + property DottedBrushGridLines: TStrokeBrush read FDottedBrushGridLines write FDottedBrushGridLines; + public //methods + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + + function ClientToScreen(P: TPoint): TPoint; + function ScreenToClient(P: TPoint): TPoint; + procedure RecreateWnd; + procedure ShowScrollBar(Bar: Integer; AShow: Boolean); + function SetScrollInfo(Bar: Integer; const ScrollInfo: TScrollInfo; Redraw: Boolean): TDimension; + function GetScrollInfo(Bar: Integer; var ScrollInfo: TScrollInfo): Boolean; + function GetScrollPos(Bar: Integer): TDimension; + function GetScrollBarForBar(Bar: Integer): TScrollBar; + procedure HScrollChangeProc(Sender: TObject); virtual; abstract; + procedure VScrollChangeProc(Sender: TObject); virtual; abstract; + + procedure CopyToClipboard; virtual; abstract; + procedure CutToClipboard; virtual; abstract; + function PasteFromClipboard: Boolean; virtual; abstract; + + /// + /// Alias for IsFocused to make same as Vcl Focused + /// + function Focused(): Boolean; inline; + + /// + /// Convert mouse message to TMouseButton + /// Created as method, to be available in whole hierarchy without specifing Unit file name (prevent circular unit ref). + /// + class function KeysToShiftState(Keys: LongInt): TShiftState; static; + + function GetParentForm(Control: TControl; TopForm: Boolean = True): TCustomForm; + + /// + /// Alias for Repaint on FMX to be compatible with VCL + /// + procedure Invalidate(); inline; + /// + /// Alias for Repaint on FMX to be compatible with VCL + /// + function InvalidateRect(lpRect: PRect; bErase: Boolean): Boolean; inline; + /// + /// Alias for Repaint on FMX to be compatible with VCL + /// + function UpdateWindow(): Boolean; inline; + /// + /// Alias for Repaint on FMX to be compatible with VCL + /// + function RedrawWindow(lprcUpdate: PRect; hrgnUpdate: NativeUInt; flags: UINT): Boolean; overload; inline; + /// + /// Alias for Repaint on FMX to be compatible with VCL + /// + function RedrawWindow(const lprcUpdate: TRect; hrgnUpdate: NativeUInt; flags: UINT): Boolean; overload; inline; + + /// + /// Alias for Repaint on FMX to be compatible with VCL + /// + function SendWM_SETREDRAW(Updating: Boolean): NativeUInt; inline; + + /// + /// Simulate Windows GetSystemMetrics + /// + function GetSystemMetrics(nIndex: Integer): Integer; + procedure Sort(Node: PVirtualNode; Column: TColumnIndex; Direction: TSortDirection; DoInit: Boolean = True); reintroduce; overload; virtual; abstract; + public //properties + property Font: TFont read FFont write SetFont; + property ClientRect: TRect read GetClientRect; + property ClientWidth: Single read GetClientWidth; + property ClientHeight: Single read GetClientHeight; + property UseRightToLeftAlignment: Boolean read FUseRightToLeftAlignment write FUseRightToLeftAlignment default false; + property BevelEdges: TBevelEdges read FBevelEdges write SetBevelEdges default [TBevelEdge.beLeft, TBevelEdge.beTop, TBevelEdge.beRight, TBevelEdge.beBottom]; + property BevelInner: TBevelCut index 0 read FBevelInner write SetBevelCut default TBevelCut.bvRaised; + property BevelOuter: TBevelCut index 1 read FBevelOuter write SetBevelCut default TBevelCut.bvLowered; + property BevelKind: TBevelKind read FBevelKind write SetBevelKind default TBevelKind.bkNone; + property BevelWidth: TBevelWidth read FBevelWidth write SetBevelWidth default 1; + property BorderWidth: TBorderWidth read FBorderWidth write SetBorderWidth; + property BiDiMode: TBiDiMode read FBiDiMode write SetBiDiMode; + property HScrollBar: TScrollBar read FHScrollBar; + property VScrollBar: TScrollBar read FVScrollBar; + property HandleAllocated: Boolean read FHandleAllocated; + + /// + /// Alias for Fill.Color to make same use as Vcl Color property + /// + property Color: TAlphaColor read GetFillColor write SetFillColor; + end; + +{$IFNDEF MSWINDOWS} +const + { GetSystemMetrics() codes } + SM_CXVSCROLL = 2; + SM_CYHSCROLL = 3; +{$ENDIF} + +implementation +uses FMX.TextLayout, FMX.Utils + {$IFNDEF MSWINDOWS} + , WinApi.Windows + {$ENDIF} + ; + +//-------- TVTBaseAncestorFMX ------------------------------------------------------------------------------------------ + +class function TVTBaseAncestorFMX.KeysToShiftState(Keys: LongInt): TShiftState; +begin + Result := TShiftState(Word(Keys)); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTBaseAncestorFMX.GetFillColor: TAlphaColor; +begin + Result:= Fill.Color; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +constructor TVTBaseAncestorFMX.Create(AOwner: TComponent); +begin + FInCreate:= true; + inherited; + + FHandleAllocated:= true; + FUseRightToLeftAlignment:= false; + FBevelEdges:= [TBevelEdge.beLeft, TBevelEdge.beTop, TBevelEdge.beRight, TBevelEdge.beBottom]; + FBevelInner:= TBevelCut.bvRaised; + FBevelOuter:= TBevelCut.bvLowered; + FBevelKind:= TBevelKind.bkNone; + FBevelWidth:= 1; + FBorderWidth:= 0; + FFont:= TFont.Create; + DisableFocusEffect := True; + CanFocus := True; + AutoCapture := True; + + FHScrollBar:= TScrollBar.Create(Self); + FHScrollBar.Parent:= Self; + FHScrollBar.Orientation:= TOrientation.Horizontal; + FHScrollBar.Align:= TAlignLayout.MostBottom; + FHScrollBar.Visible:= true; + FHScrollBar.OnChange:= HScrollChangeProc; + FHScrollBar.Margins.Right:= FHScrollBar.Height; + + FVScrollBar:= TScrollBar.Create(Self); + FVScrollBar.Parent:= Self; + FVScrollBar.Orientation:= TOrientation.Vertical; + FVScrollBar.Align:= TAlignLayout.MostRight; + FVScrollBar.Visible:= true; + FVScrollBar.OnChange:= VScrollChangeProc; + //FVScrollBar.Margins.Bottom:= FVScrollBar.Width; + + SetAcceptsControls(false); + + FInCreate:= false; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +destructor TVTBaseAncestorFMX.Destroy(); +begin + inherited; + + if FDottedBrushTreeLines <> nil then + FreeAndNil(FDottedBrushTreeLines); + if FDottedBrushGridLines <> nil then + FreeAndNil(FDottedBrushGridLines); + FreeAndNil(FFont); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTBaseAncestorFMX.SetBevelCut(Index: Integer; const Value: TBevelCut); +begin + case Index of + 0: { BevelInner } + if Value <> FBevelInner then + begin + FBevelInner := Value; + Repaint; + end; + 1: { BevelOuter } + if Value <> FBevelOuter then + begin + FBevelOuter := Value; + Repaint; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTBaseAncestorFMX.SetBevelEdges(const Value: TBevelEdges); +begin + if Value <> FBevelEdges then + begin + FBevelEdges := Value; + Repaint; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTBaseAncestorFMX.SetBevelKind(const Value: TBevelKind); +begin + if Value <> FBevelKind then + begin + FBevelKind := Value; + Repaint; + end; +end; +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTBaseAncestorFMX.SetBevelWidth(const Value: TBevelWidth); +begin + if Value <> FBevelWidth then + begin + FBevelWidth := Value; + Repaint; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTBaseAncestorFMX.ScreenToClient(P: TPoint): TPoint; + +begin + Result:= AbsoluteToLocal(P); +end; +//---------------------------------------------------------------------------------------------------------------------- + +function TVTBaseAncestorFMX.ClientToScreen(P: TPoint): TPoint; +begin + Result:= LocalToAbsolute(P); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTBaseAncestorFMX.Invalidate(); +begin + Repaint; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTBaseAncestorFMX.InvalidateRect(lpRect: PRect; bErase: Boolean): Boolean; +begin + Repaint; + Result:= true; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTBaseAncestorFMX.UpdateWindow(): Boolean; +begin + Repaint; + Result:= true; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTBaseAncestorFMX.RedrawWindow(lprcUpdate: PRect; hrgnUpdate: NativeUInt; flags: UINT): Boolean; +begin + Repaint; + Result:= true; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTBaseAncestorFMX.RedrawWindow(const lprcUpdate: TRect; hrgnUpdate: NativeUInt; flags: UINT): Boolean; +begin + Repaint; + Result:= true; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTBaseAncestorFMX.RecreateWnd(); +begin + Repaint; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTBaseAncestorFMX.ShowScrollBar(Bar: Integer; AShow: Boolean); +begin + if (Bar=SB_HORZ) or (Bar=SB_BOTH) then + FHScrollBar.Visible:= AShow; + + if (Bar=SB_VERT) or (Bar=SB_BOTH) then + FVScrollBar.Visible:= AShow; + + if FHScrollBar.Visible and FVScrollBar.Visible then + FHScrollBar.Margins.Right:= FHScrollBar.Height else + FHScrollBar.Margins.Right:= 0; + + Repaint; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTBaseAncestorFMX.SetScrollInfo(Bar: Integer; const ScrollInfo: TScrollInfo; Redraw: Boolean): TDimension; +Var ScrollBar: TScrollBar; +begin + ScrollBar:= GetScrollBarForBar(Bar); + if ScrollBar=nil then + Exit(0); //!!! + + if ScrollInfo.fMask and SIF_PAGE<>0 then + begin + ScrollBar.SmallChange:= ScrollInfo.nPage; + end; + + if ScrollInfo.fMask and SIF_RANGE<>0 then + begin + ScrollBar.Min:= ScrollInfo.nMin; + ScrollBar.Max:= ScrollInfo.nMax; + end; + + if ScrollInfo.fMask and SIF_POS<>0 then + begin + ScrollBar.Value:= ScrollInfo.nPos; + end; + + Result:= ScrollBar.Value; + + Repaint; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTBaseAncestorFMX.GetScrollInfo(Bar: Integer; var ScrollInfo: TScrollInfo): Boolean; +Var ScrollBar: TScrollBar; +begin + ScrollBar:= GetScrollBarForBar(Bar); + if ScrollBar=nil then + Exit(False); //!!! + + Result:= true; + + ScrollInfo.cbSize:= SizeOf(TScrollInfo); + ScrollInfo.fMask:= SIF_ALL; + + ScrollInfo.nMin:= ScrollBar.Min; + ScrollInfo.nMax:= ScrollBar.Max; + ScrollInfo.nPage:= ScrollBar.SmallChange; + ScrollInfo.nPos:= ScrollBar.Value; + ScrollInfo.nTrackPos:= ScrollBar.Value; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTBaseAncestorFMX.GetScrollPos(Bar: Integer): TDimension; +Var ScrollInfo: TScrollInfo; +begin + GetScrollInfo(Bar, ScrollInfo); //ignore result + Result:= ScrollInfo.nPos; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTBaseAncestorFMX.GetScrollBarForBar(Bar: Integer): TScrollBar; +begin + if (Bar=SB_HORZ) then + Result:= FHScrollBar else + if (Bar=SB_VERT) then + Result:= FVScrollBar else + Result:= nil; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTBaseAncestorFMX.SetBiDiMode(Value: TBiDiMode); +begin + if FBiDiMode <> Value then + begin + FBiDiMode := Value; + Repaint; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTBaseAncestorFMX.SetBorderWidth(Value: TBorderWidth); +begin + if FBorderWidth <> Value then + begin + FBorderWidth := Value; + Repaint; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTBaseAncestorFMX.SetFillColor(const Value: TAlphaColor); +begin + Fill.Color:= Value; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTBaseAncestorFMX.SetFont(const Value: TFont); +begin + FFont.Assign(Value); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTBaseAncestorFMX.Focused(): Boolean; +begin + Result:= IsFocused; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTBaseAncestorFMX.GetParentForm(Control: TControl; TopForm: Boolean = True): TCustomForm; +begin + Result:= Control.Root.GetObject as TCustomForm; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTBaseAncestorFMX.SendWM_SETREDRAW(Updating: Boolean): NativeUInt; +begin + Repaint; + Result:= 0; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTBaseAncestorFMX.GetSystemMetrics(nIndex: Integer): Integer; +begin + {$IFDEF MSWINDOWS} + Result:= GetSystemMetrics(nIndex); + {$ELSE} + case nIndex of + SM_CXVSCROLL: Result:= 16; + SM_CYHSCROLL: Result:= 3; + else + raise Exception.Create('Unknown code for GetSystemMetrics: ' + IntToStr(nIndex)); + end; + {$ENDIF} +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTBaseAncestorFMX.CreateSystemImageSet(): TImageList; +begin + Result:= TImageList.Create(Self); + FillSystemCheckImages(Self, Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTBaseAncestorFMX.SetWindowTheme(const Theme: string); +begin + //nothing +end; +//---------------------------------------------------------------------------------------------------------------------- + +function TVTBaseAncestorFMX.CreateSystemImageSet(): TImageList; +begin + Result:= TImageList.Create(Self); + FillSystemCheckImages(Self, Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTBaseAncestorFMX.SetWindowTheme(const Theme: string); +begin + //nothing +end; + +end. diff --git a/components/virtualtreeview/Source/VirtualTrees.BaseAncestorVcl.pas b/components/virtualtreeview/Source/VirtualTrees.BaseAncestorVcl.pas new file mode 100644 index 000000000..ce624b59e --- /dev/null +++ b/components/virtualtreeview/Source/VirtualTrees.BaseAncestorVcl.pas @@ -0,0 +1,581 @@ +unit VirtualTrees.BaseAncestorVCL; + +{$SCOPEDENUMS ON} + +{****************************************************************************************************************} +{ Project : VirtualTrees } +{ } +{ author : Karol Bieniaszewski, look at VirtualTrees.pas as some code moved from there } +{ year : 2022 } +{ contibutors : } +{****************************************************************************************************************} + +interface +uses + Winapi.Windows, + Winapi.oleacc, + Winapi.ActiveX, + Winapi.Messages, + System.Classes, + Vcl.Controls, + Vcl.Graphics, + Vcl.StdCtrls, + VirtualTrees.Types; + +type + TVTBaseAncestorVcl = class abstract(TCustomControl) + private + // MSAA support + FAccessible: IAccessible; // The IAccessible interface to the window itself. + FAccessibleItem: IAccessible; // The IAccessible to the item that currently has focus. + FAccessibleName: string; // The name the window is given for screen readers. + FDottedBrushTreeLines: TBrush; // used to paint dotted lines without special pens + + procedure WMGetObject(var Message: TMessage); message WM_GETOBJECT; + protected // methods + function DoRenderOLEData(const FormatEtcIn: TFormatEtc; out Medium: TStgMedium; ForClipboard: Boolean): HRESULT; virtual; abstract; + function RenderOLEData(const FormatEtcIn: TFormatEtc; out Medium: TStgMedium; ForClipboard: Boolean): HResult; virtual; + procedure NotifyAccessibleEvent(pEvent: DWord = EVENT_OBJECT_STATECHANGE); + function PrepareDottedBrush(CurrentDottedBrush: TBrush; Bits: Pointer; const BitsLinesCount: Word): TBrush; virtual; + function CreateSystemImageSet(): TImageList; + procedure SetWindowTheme(const Theme: string); virtual; + //// Abtract method that are implemented in TBaseVirtualTree, keep in sync with TVTBaseAncestorFMX + function GetSelectedCount(): Integer; virtual; abstract; + procedure MarkCutCopyNodes; virtual; abstract; + procedure DoStateChange(Enter: TVirtualTreeStates; Leave: TVirtualTreeStates = []); virtual; abstract; + function GetSortedCutCopySet(Resolve: Boolean): TNodeArray; virtual; abstract; + function GetSortedSelection(Resolve: Boolean): TNodeArray; virtual; abstract; + procedure WriteNode(Stream: TStream; Node: PVirtualNode); virtual; abstract; + procedure Sort(Node: PVirtualNode; Column: TColumnIndex; Direction: TSortDirection; DoInit: Boolean = True); virtual; abstract; + procedure DoMouseEnter(); virtual; abstract; + procedure DoMouseLeave(); virtual; abstract; + protected //properties + property DottedBrushTreeLines: TBrush read FDottedBrushTreeLines write FDottedBrushTreeLines; + public // methods + destructor Destroy; override; + procedure CopyToClipboard(); virtual; + procedure CutToClipboard(); virtual; + function PasteFromClipboard: Boolean; virtual; abstract; + + /// + /// Handle less alias for WinApi.Windows.InvalidateRect + /// + function InvalidateRect(lpRect: PRect; bErase: BOOL): BOOL; inline; + /// + /// Handle less alias for WinApi.Windows.UpdateWindow + /// + function UpdateWindow(): BOOL; inline; + /// + /// Handle less alias for WinApi.Windows.RedrawWindow + /// + function RedrawWindow(lprcUpdate: PRect; hrgnUpdate: HRGN; flags: UINT): BOOL; overload; inline; + /// + /// Handle less alias for WinApi.Windows.RedrawWindow + /// + function RedrawWindow(const lprcUpdate: TRect; hrgnUpdate: HRGN; flags: UINT): BOOL; overload; inline; + + /// + /// Handle less and with limited parameters version + /// + function SendWM_SETREDRAW(Updating: Boolean): LRESULT; inline; + + /// + /// Handle less alias for WinApi.Windows.ShowScrollBar + /// + procedure ShowScrollBar(Bar: Integer; AShow: Boolean); + /// + /// Handle less alias for WinApi.Windows.SetScrollInfo + /// + function SetScrollInfo(Bar: Integer; const ScrollInfo: TScrollInfo; Redraw: Boolean): TDimension; + /// + /// Handle less alias for WinApi.Windows.GetScrollInfo + /// + function GetScrollInfo(Bar: Integer; var ScrollInfo: TScrollInfo): Boolean; + /// + /// Handle less alias for WinApi.Windows.GetScrollPos + /// + function GetScrollPos(Bar: Integer): TDimension; + /// + /// Canvas based without HDC alias for WinApi.Windows.GetTextMetrics + /// + function GetTextMetrics(Canvas: TCanvas; var TM: TTextMetric): BOOL; overload; inline; + public //properties + property Accessible: IAccessible read FAccessible write FAccessible; + property AccessibleItem: IAccessible read FAccessibleItem write FAccessibleItem; + property AccessibleName: string read FAccessibleName write FAccessibleName; + end; + +implementation + +uses + System.SyncObjs, + System.SysUtils, + Vcl.AxCtrls, + Vcl.Forms, + Vcl.Themes, + Winapi.CommCtrl, + Winapi.ShlObj, + Winapi.UxTheme, + VirtualTrees.DataObject, + VirtualTrees.Clipboard, + VirtualTrees.AccessibilityFactory, + VirtualTrees.StyleHooks; + +//---------------------------------------------------------------------------------------------------------------------- + +const + Grays: array[0..3] of TColor = (clWhite, clSilver, clGray, clBlack); + SysGrays: array[0..3] of TColor = (clWindow, clBtnFace, clBtnShadow, clBtnText); + +//not used curently anywhere, moved to VCL, to remove ifdef (gWatcher is declared in VirtualTrees.BaseTree) +procedure ConvertImageList(gWatcher: TCriticalSection; BaseVirtualTreeClass: TClass; IL: TImageList; const ImageName: string; ColorRemapping: Boolean = True); + +// Loads a bunch of images given by ImageName into IL. If ColorRemapping = True then a mapping of gray values to +// system colors is performed. + +var + lImages, + lOneImage: TBitmap; + I: Integer; + MaskColor: TColor; + Source, + Dest: TRect; + +begin + gWatcher.Enter(); + try + // Since we want the image list appearing in the correct system colors, we have to remap its colors. + lImages := TBitmap.Create; + lOneImage := TBitmap.Create; + if ColorRemapping then + lImages.Handle := CreateMappedRes(FindClassHInstance(BaseVirtualTreeClass), PChar(ImageName), Grays, SysGrays) + else + lImages.Handle := LoadBitmap(FindClassHInstance(BaseVirtualTreeClass), PChar(ImageName)); + + try + Assert(lImages.Height > 0, 'Internal image "' + ImageName + '" is missing or corrupt.'); + if lImages.Height = 0 then + Exit;// This should never happen, it prevents a division by zero exception below in the for loop, which we have seen in a few cases + // It is assumed that the image height determines also the width of one entry in the image list. + IL.Clear; + IL.Height := lImages.Height; + IL.Width := lImages.Height; + lOneImage.Width := IL.Width; + lOneImage.Height := IL.Height; + MaskColor := lImages.Canvas.Pixels[0, 0]; // this is usually clFuchsia + Dest := Rect(0, 0, IL.Width, IL.Height); + for I := 0 to (lImages.Width div lImages.Height) - 1 do + begin + Source := Rect(I * IL.Width, 0, (I + 1) * IL.Width, IL.Height); + lOneImage.Canvas.CopyRect(Dest, lImages.Canvas, Source); + IL.AddMasked(lOneImage, MaskColor); + end; + finally + lImages.Free; + lOneImage.Free; + end; + finally + gWatcher.Leave(); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTBaseAncestorVcl.RenderOLEData(const FormatEtcIn: TFormatEtc; out Medium: TStgMedium; ForClipboard: Boolean): HResult; + +// Returns a memory expression of all currently selected nodes in the Medium structure. +// Note: The memory requirement of this method might be very high. This depends however on the requested storage format. +// For HGlobal (a global memory block) we need to render first all nodes to local memory and copy this then to +// the global memory in Medium. This is necessary because we have first to determine how much +// memory is needed before we can allocate it. Hence for a short moment we need twice the space as used by the +// nodes alone (plus the amount the nodes need in the tree anyway)! +// With IStream this does not happen. We directly stream out the nodes and pass the constructed stream along. + + //--------------- local function -------------------------------------------- + + procedure WriteNodes(Stream: TStream); + + var + Selection: TNodeArray; + I: Integer; + + begin + if ForClipboard then + Selection := GetSortedCutCopySet(True) + else + Selection := GetSortedSelection(True); + for I := 0 to High(Selection) do + WriteNode(Stream, Selection[I]); + end; + + //--------------- end local function ---------------------------------------- + +var + Data: PCardinal; + ResPointer: Pointer; + ResSize: Integer; + OLEStream: IStream; + VCLStream: TStream; + +begin + ZeroMemory (@Medium, SizeOf(Medium)); + + // We can render the native clipboard format in two different storage media. + if (FormatEtcIn.cfFormat = CF_VIRTUALTREE) and (FormatEtcIn.tymed and (TYMED_HGLOBAL or TYMED_ISTREAM) <> 0) then + begin + VCLStream := nil; + try + Medium.unkForRelease := nil; + // Return data in one of the supported storage formats, prefer IStream. + if FormatEtcIn.tymed and TYMED_ISTREAM <> 0 then + begin + // Create an IStream on a memory handle (here it is 0 which indicates to implicitely allocated a handle). + // Do not use TStreamAdapter as it is not compatible with OLE (when flushing the clipboard OLE wants the HGlobal + // back which is not supported by TStreamAdapater). + CreateStreamOnHGlobal(0, True, OLEStream); + VCLStream := TOLEStream.Create(OLEStream); + WriteNodes(VCLStream); + // Rewind stream. + VCLStream.Position := 0; + Medium.tymed := TYMED_ISTREAM; + IUnknown(Medium.stm) := OLEStream; + Result := S_OK; + end + else + begin + VCLStream := TMemoryStream.Create; + WriteNodes(VCLStream); + ResPointer := TMemoryStream(VCLStream).Memory; + ResSize := VCLStream.Position; + + // Allocate memory to hold the string. + if ResSize > 0 then + begin + Medium.hGlobal := GlobalAlloc(GHND or GMEM_SHARE, ResSize + SizeOf(Cardinal)); + Data := GlobalLock(Medium.hGlobal); + // Store the size of the data too, for easy retrival. + Data^ := ResSize; + Inc(Data); + Move(ResPointer^, Data^, ResSize); + GlobalUnlock(Medium.hGlobal); + Medium.tymed := TYMED_HGLOBAL; + + Result := S_OK; + end + else + Result := E_FAIL; + end; + finally + // We can free the VCL stream here since it was either a pure memory stream or only a wrapper around + // the OLEStream which exists independently. + VCLStream.Free; + end; + end + else // Ask application descendants to render self defined formats. + Result := DoRenderOLEData(FormatEtcIn, Medium, ForClipboard); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTBaseAncestorVcl.CopyToClipboard; + +var + lDataObject: IDataObject; + +begin + if GetSelectedCount > 0 then + begin + lDataObject := TVTDataObject.Create(Self, True); + if OleSetClipboard(lDataObject) = S_OK then + begin + MarkCutCopyNodes; + DoStateChange([tsCopyPending]); + Invalidate; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTBaseAncestorVcl.CreateSystemImageSet: TImageList; + +// Creates a system check image set. +// Note: the DarkCheckImages and FlatImages image lists must already be filled, as some images from them are copied here. + +const + MaskColor: TColor = clRed; + cFlags = ILC_COLOR32 or ILC_MASK; + +var + BM: TBitmap; + Theme: HTHEME; + Details: TThemedElementDetails; + + //--------------------------------------------------------------------------- + + // Mitigator function to use the correct style service for this context (either the style assigned to the control for Delphi > 10.4 or the application style) + function StyleServices: TCustomStyleServices; + begin + Result := VTStyleServices(Self); + end; + + procedure AddSystemImage(IL: TImageList; Index: Integer); + const + States: array [0..19] of Integer = ( + RBS_UNCHECKEDNORMAL, RBS_UNCHECKEDHOT, RBS_UNCHECKEDPRESSED, RBS_UNCHECKEDDISABLED, + RBS_CHECKEDNORMAL, RBS_CHECKEDHOT, RBS_CHECKEDPRESSED, RBS_CHECKEDDISABLED, + CBS_UNCHECKEDNORMAL, CBS_UNCHECKEDHOT, CBS_UNCHECKEDPRESSED, CBS_UNCHECKEDDISABLED, + CBS_CHECKEDNORMAL, CBS_CHECKEDHOT, CBS_CHECKEDPRESSED, CBS_CHECKEDDISABLED, + CBS_MIXEDNORMAL, CBS_MIXEDHOT, CBS_MIXEDPRESSED, CBS_MIXEDDISABLED); + var + ButtonState: Cardinal; + ButtonType: Cardinal; + + begin + BM.Canvas.FillRect(Rect(0, 0, BM.Width, BM.Height)); + if StyleServices.Enabled and StyleServices.IsSystemStyle then + begin + if Index < 8 then + Details.Part := BP_RADIOBUTTON + else + Details.Part := BP_CHECKBOX; + Details.State := States[Index]; + DrawThemeBackground(Theme, BM.Canvas.Handle, Details.Part, Details.State, Rect(0, 0, BM.Width, BM.Height), nil); + end + else + begin + if Index < 8 then + ButtonType := DFCS_BUTTONRADIO + else + ButtonType := DFCS_BUTTONCHECK; + if Index >= 16 then + ButtonType := ButtonType or DFCS_BUTTON3STATE; + + case Index mod 4 of + 0: + ButtonState := 0; + 1: + ButtonState := DFCS_HOT; + 2: + ButtonState := DFCS_PUSHED; + else + ButtonState := DFCS_INACTIVE; + end; + if Index in [4..7, 12..19] then + ButtonState := ButtonState or DFCS_CHECKED; +// if Flat then +// ButtonState := ButtonState or DFCS_FLAT; + DrawFrameControl(BM.Canvas.Handle, Rect(0, 0, BM.Width, BM.Height), DFC_BUTTON, ButtonType or ButtonState); + end; + IL.AddMasked(BM, MaskColor); + end; + + //--------------- end local functions --------------------------------------- + +const + cDefaultCheckboxSize = 13;// Used when no other value is available +var + I: Integer; + lSize: TSize; + Res: Boolean; +begin + BM := TBitmap.Create; // Create a temporary bitmap, which holds the intermediate images. + try + Res := False; + // Retrieve the checkbox image size, prefer theme if available, fall back to GetSystemMetrics() otherwise, but this returns odd results on Windows 8 and higher in high-dpi scenarios. + if StyleServices.Enabled then + if StyleServices.IsSystemStyle then + begin + {$if CompilerVersion >= 33} + if TOSVersion.Check(10) and (TOSVersion.Build >= 15063) then + Theme := OpenThemeDataForDPI(Handle, 'BUTTON', CurrentPPI) + else + {$ifend} + Theme := OpenThemeData(Self.Handle, 'BUTTON'); + Details := StyleServices.GetElementDetails(tbCheckBoxUncheckedNormal); + Res := GetThemePartSize(Theme, BM.Canvas.Handle, Details.Part, Details.State, nil, TS_TRUE, lSize) = S_OK; + end + else + Res := StyleServices.GetElementSize(BM.Canvas.Handle, StyleServices.GetElementDetails(tbCheckBoxUncheckedNormal), TElementSize.esActual, lSize {$IF CompilerVersion >= 34}, Self.CurrentPPI{$IFEND}); + if not Res then begin + lSize := TSize.Create(GetSystemMetrics(SM_CXMENUCHECK), GetSystemMetrics(SM_CYMENUCHECK)); + if lSize.cx = 0 then begin // error? (Should happen rarely only) + lSize.cx := MulDiv(cDefaultCheckboxSize, Screen.PixelsPerInch, USER_DEFAULT_SCREEN_DPI); + lSize.cy := lSize.cx; + end;// if + end;//if + + Result := TImageList.CreateSize(lSize.cx, lSize.cy); + Result.Handle := ImageList_Create(Result.Width, Result.Height, cFlags, 0, Result.AllocBy); + Result.Masked := True; + Result.BkColor := clWhite; + + // Make the bitmap the same size as the image list is to avoid problems when adding. + BM.SetSize(Result.Width, Result.Height); + BM.Canvas.Brush.Color := MaskColor; + BM.Canvas.Brush.Style := bsSolid; + BM.Canvas.FillRect(Rect(0, 0, BM.Width, BM.Height)); + Result.AddMasked(BM, MaskColor); + + // Add the 20 system checkbox and radiobutton images. + for I := 0 to 19 do + AddSystemImage(Result, I); + if StyleServices.Enabled and StyleServices.IsSystemStyle then + CloseThemeData(Theme); + + finally + BM.Free; + end; +end; + +procedure TVTBaseAncestorVcl.CutToClipboard; +var + lDataObject: IDataObject; +begin + if (GetSelectedCount > 0) then + begin + lDataObject := TVTDataObject.Create(Self, True); + if OleSetClipboard(lDataObject) = S_OK then + begin + MarkCutCopyNodes; + DoStateChange([tsCutPending], [tsCopyPending]); + Invalidate; + end; + end; +end; + +destructor TVTBaseAncestorVcl.Destroy; +begin + // Disconnect all remote MSAA connections + if Assigned(AccessibleItem) then begin + CoDisconnectObject(AccessibleItem, 0); + AccessibleItem := nil; + end; + if Assigned(Accessible) then begin + CoDisconnectObject(Accessible, 0); + Accessible := nil; + end; + + inherited; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTBaseAncestorVcl.PrepareDottedBrush(CurrentDottedBrush: TBrush; Bits: Pointer; const BitsLinesCount: Word): TBrush; +begin + if Assigned(CurrentDottedBrush) then + begin + Result := CurrentDottedBrush; + end else + begin + Result := TBrush.Create; + Result.Bitmap := TBitmap.Create; + end; + + Result.Bitmap.Handle := CreateBitmap(8, 8, 1, 1, Bits); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTBaseAncestorVcl.RedrawWindow(const lprcUpdate: TRect; hrgnUpdate: HRGN; flags: UINT): BOOL; +begin + Result:= Winapi.Windows.RedrawWindow(Handle, lprcUpdate, hrgnUpdate, flags); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTBaseAncestorVcl.RedrawWindow(lprcUpdate: PRect; hrgnUpdate: HRGN; flags: UINT): BOOL; +begin + Result:= Winapi.Windows.RedrawWindow(Handle, lprcUpdate, hrgnUpdate, flags); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTBaseAncestorVcl.InvalidateRect(lpRect: PRect; bErase: BOOL): BOOL; +begin + Result:= WinApi.Windows.InvalidateRect(Handle, lpRect, bErase); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTBaseAncestorVcl.NotifyAccessibleEvent(pEvent: DWord = EVENT_OBJECT_STATECHANGE); +begin + if Assigned(AccessibleItem) then + NotifyWinEvent(pEvent, Handle, OBJID_CLIENT, CHILDID_SELF); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTBaseAncestorVcl.UpdateWindow(): BOOL; +begin + Result:= WinApi.Windows.UpdateWindow(Handle); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTBaseAncestorVcl.WMGetObject(var Message: TMessage); + +begin + if TVTAccessibilityFactory.GetAccessibilityFactory <> nil then + begin + // Create the IAccessibles for the tree view and tree view items, if necessary. + if Accessible = nil then + Accessible := TVTAccessibilityFactory.GetAccessibilityFactory.CreateIAccessible(Self); + if AccessibleItem = nil then + AccessibleItem := TVTAccessibilityFactory.GetAccessibilityFactory.CreateIAccessible(Self); + if Cardinal(Message.LParam) = OBJID_CLIENT then + if Assigned(Accessible) then + Message.Result := LresultFromObject(IID_IAccessible, Message.WParam, Accessible) + else + Message.Result := 0; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTBaseAncestorVcl.ShowScrollBar(Bar: Integer; AShow: Boolean); +begin + WinApi.Windows.ShowScrollBar(Handle, Bar, AShow); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTBaseAncestorVcl.SendWM_SETREDRAW(Updating: Boolean): LRESULT; +begin + Result:= SendMessage(Handle, WM_SETREDRAW, Ord(not Updating), 0); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTBaseAncestorVcl.SetScrollInfo(Bar: Integer; const ScrollInfo: TScrollInfo; Redraw: Boolean): TDimension; +begin + Result:= WinApi.Windows.SetScrollInfo(Handle, Bar, ScrollInfo, Redraw); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTBaseAncestorVcl.SetWindowTheme(const Theme: string); +begin + Winapi.UxTheme.SetWindowTheme(Handle, PWideChar(Theme), nil); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTBaseAncestorVcl.GetScrollInfo(Bar: Integer; var ScrollInfo: TScrollInfo): Boolean; +begin + Result:= WinApi.Windows.GetScrollInfo(Handle, Bar, ScrollInfo); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTBaseAncestorVcl.GetScrollPos(Bar: Integer): TDimension; +begin + Result:= WinApi.Windows.GetScrollPos(Handle, Bar); +end; + +function TVTBaseAncestorVcl.GetTextMetrics(Canvas: TCanvas; var TM: TTextMetric): BOOL; +begin + Result:= WinApi.Windows.GetTextMetrics(Canvas.Handle, TM); +end; + +end. diff --git a/components/virtualtreeview/Source/VirtualTrees.BaseTree.pas b/components/virtualtreeview/Source/VirtualTrees.BaseTree.pas new file mode 100644 index 000000000..8697a7b58 --- /dev/null +++ b/components/virtualtreeview/Source/VirtualTrees.BaseTree.pas @@ -0,0 +1,22658 @@ +unit VirtualTrees.BaseTree; + +interface + +{$if CompilerVersion < 24}{$MESSAGE FATAL 'This version supports only RAD Studio XE3 and higher. Please use V5 from http://www.jam-software.com/virtual-treeview/VirtualTreeViewV5.5.3.zip or https://github.com/Virtual-TreeView/Virtual-TreeView/archive/V5_stable.zip'}{$ifend} + +{$booleval off} // Use fastest possible boolean evaluation + +// For some things to work we need code, which is classified as being unsafe for .NET. +{$WARN UNSAFE_TYPE OFF} +{$WARN UNSAFE_CAST OFF} +{$WARN UNSAFE_CODE OFF} + +{$LEGACYIFEND ON} +{$WARN UNSUPPORTED_CONSTRUCT OFF} + +{$HPPEMIT '#include '} +{$HPPEMIT '#include '} +{$HPPEMIT '#include '} +{$ifdef BCB} + {$HPPEMIT '#pragma comment(lib, "VirtualTreesCR")'} +{$else} + {$HPPEMIT '#pragma comment(lib, "VirtualTreesR")'} +{$endif} +{$HPPEMIT '#pragma comment(lib, "Shell32")'} +{$HPPEMIT '#pragma comment(lib, "uxtheme")'} +{$HPPEMIT '#pragma link "VirtualTrees.Accessibility"'} + +uses + Winapi.Windows, Winapi.Messages, Winapi.ActiveX, Winapi.CommCtrl, + Winapi.UxTheme, Winapi.ShlObj, + System.SysUtils, System.Classes, System.Types, + Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.ImgList, Vcl.StdCtrls, + Vcl.Menus, Vcl.Printers, Vcl.Themes, + System.UITypes, // some types moved from Vcl.* to System.UITypes + VirtualTrees.Types, + VirtualTrees.Colors, + VirtualTrees.DragImage, + VirtualTrees.Header +{$IFDEF VT_FMX} + , VirtualTrees.BaseAncestorFMX +{$ELSE} + , VirtualTrees.BaseAncestorVCL +{$ENDIF} + ; + +{$MinEnumSize 1, make enumerations as small as possible} + +type + {$IFDEF VT_FMX} + TVTBaseAncestor = TVTBaseAncestorFMX; + TCanvas = FMX.Graphics.TCanvas; + {$ELSE} + TVTBaseAncestor = TVTBaseAncestorVcl; + TCanvas = Vcl.Graphics.TCanvas; + TFormatEtcArray = VirtualTrees.Types.TFormatEtcArray; + {$ENDIF} + + // Alias defintions for convenience + TImageIndex = System.UITypes.TImageIndex; + + //these were moved, aliases are for backwards compatibility. + //some may be removed once we sort out excactly what is needed. + + TDimension = VirtualTrees.Types.TDimension; + TColumnIndex = VirtualTrees.Types.TColumnIndex; + TColumnPosition = VirtualTrees.Types.TColumnPosition; + EVirtualTreeError = VirtualTrees.Types.EVirtualTreeError; + TAutoScrollInterval = VirtualTrees.Types.TAutoScrollInterval; + TVTScrollIncrement = VirtualTrees.Types.TVTScrollIncrement; + TFormatArray = VirtualTrees.Types.TFormatArray; + + TVTPaintOption = VirtualTrees.Types.TVTPaintOption; + TVTPaintOptions = VirtualTrees.Types.TVTPaintOptions; + TVTAnimateOption = VirtualTrees.Types.TVTAnimationOption; + TVTAnimateOptions = VirtualTrees.Types.TVTAnimationOptions; + TVTAutoOption = VirtualTrees.Types.TVTAutoOption; + TVTAutoOptions = VirtualTrees.Types.TVTAutoOptions; + TVTSelectionOption = VirtualTrees.Types.TVTSelectionOption; + TVTSelectionOptions = VirtualTrees.Types.TVTSelectionOptions; + TVTEditOptions = VirtualTrees.Types.TVTEditOptions; + TVTMiscOption = VirtualTrees.Types.TVTMiscOption; + TVTMiscOptions = VirtualTrees.Types.TVTMiscOptions; + TVTExportMode = VirtualTrees.Types.TVTExportMode; + TVTStringOption = VirtualTrees.Types.TVTStringOption; + TVTStringOptions = VirtualTrees.Types.TVTStringOptions; + TCustomVirtualTreeOptions= VirtualTrees.Types.TCustomVirtualTreeOptions; + TVirtualTreeOptions = VirtualTrees.Types.TVirtualTreeOptions; + TTreeOptionsClass = VirtualTrees.Types.TTreeOptionsClass; + TCustomStringTreeOptions = VirtualTrees.Types.TCustomStringTreeOptions; + TStringTreeOptions = VirtualTrees.Types.TStringTreeOptions; + + TScrollBarStyle = VirtualTrees.Types.TScrollBarStyle; + TScrollBarOptions = VirtualTrees.Types.TScrollBarOptions; + + TVTColumnOption = VirtualTrees.Types.TVTColumnOption; + TVTColumnOptions = VirtualTrees.Types.TVTColumnOptions; + TVirtualTreeColumnStyle = VirtualTrees.Types.TVirtualTreeColumnStyle; + TSortDirection = VirtualTrees.Types.TSortDirection; + TCheckType = VirtualTrees.Types.TCheckType; + TCheckState = VirtualTrees.Types.TCheckState; + TVTDropMarkMode = VirtualTrees.Types.TVTDropMarkMode; + TScrollDirections = VirtualTrees.Types.TScrollDirections; + TVirtualTreeColumn = VirtualTrees.Header.TVirtualTreeColumn; + TVirtualTreeColumns = VirtualTrees.Header.TVirtualTreeColumns; + TVirtualTreeColumnClass = VirtualTrees.Header.TVirtualTreeColumnClass; + TColumnsArray = VirtualTrees.Header.TColumnsArray; + TCardinalArray = VirtualTrees.Header.TCardinalArray; + TIndexArray = VirtualTrees.Header.TIndexArray; + + TVTColors = VirtualTrees.Colors.TVTColors; + // + +type + TBaseVirtualTree = class; + TVirtualTreeClass = class of TBaseVirtualTree; + + + // This record must already be defined here and not later because otherwise BCB users will not be able + // to compile (conversion done by BCB is wrong). + TCacheEntry = record + Node: PVirtualNode; + AbsoluteTop: TNodeHeight; + end; + + TCache = array of TCacheEntry; + + // Used in the CF_VTREFERENCE clipboard format. + PVTReference = ^TVTReference; + TVTReference = record + Process: Cardinal; + Tree: TBaseVirtualTree; + end; + + + // ----- OLE drag'n drop handling + + IVTDragManager = interface(IUnknown) + ['{C4B25559-14DA-446B-8901-0C879000EB16}'] + procedure ForceDragLeave; stdcall; + function GetDataObject: IDataObject; stdcall; + function GetDragSource: TBaseVirtualTree; stdcall; + function GetIsDropTarget: Boolean; stdcall; + + property DataObject: IDataObject read GetDataObject; + property DragSource: TBaseVirtualTree read GetDragSource; + property IsDropTarget: Boolean read GetIsDropTarget; + end; + + + + PVTHintData = ^TVTHintData; + TVTHintData = record + Tree: TBaseVirtualTree; + Node: PVirtualNode; + Column: TColumnIndex; + HintRect: TRect; // used for draw trees only, string trees get the size from the hint string + HintText: string; // set when size of the hint window is calculated + BidiMode: TBidiMode; + Alignment: TAlignment; + LineBreakStyle: TVTToolTipLineBreakStyle; + end; + + // Communication interface between a tree editor and the tree itself (declared as using stdcall in case it + // is implemented in a (C/C++) DLL). The GUID is not nessecary in Delphi but important for BCB users + // to allow QueryInterface and _uuidof calls. + IVTEditLink = interface + ['{2BE3EAFA-5ACB-45B4-9D9A-B58BCC496E17}'] + function BeginEdit: Boolean; stdcall; // Called when editing actually starts. + function CancelEdit: Boolean; stdcall; // Called when editing has been cancelled by the tree. + function EndEdit: Boolean; stdcall; // Called when editing has been finished by the tree. Returns True if successful, False if edit mode is still active. + function PrepareEdit(Tree: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex): Boolean; stdcall; + // Called after creation to allow a setup. + procedure ProcessMessage(var Message: TMessage); stdcall; + // Used to forward messages to the edit window(s)- + procedure SetBounds(R: TRect); stdcall; // Called to place the editor. + end; + + + TVTNodeExportEvent = procedure (Sender: TBaseVirtualTree; aExportType: TVTExportType; Node: PVirtualNode) of object; + TVTColumnExportEvent = procedure (Sender: TBaseVirtualTree; aExportType: TVTExportType; Column: TVirtualTreeColumn) of object; + TVTTreeExportEvent = procedure(Sender: TBaseVirtualTree; aExportType: TVTExportType) of object; + + TClipboardFormats = class(TStringList) + private + FOwner: TBaseVirtualTree; + public + constructor Create(AOwner: TBaseVirtualTree); virtual; + + function Add(const S: string): Integer; override; + procedure Insert(Index: Integer; const S: string); override; + property Owner: TBaseVirtualTree read FOwner; + end; + + // ----- Event prototypes: + + // node enumeration + TVTGetNodeProc = reference to procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Data: Pointer; var Abort: Boolean); + // node events + TVTChangingEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; var Allowed: Boolean) of object; + TVTCheckChangingEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; var NewState: TCheckState; + var Allowed: Boolean) of object; + TVTChangeEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode) of object; + TVTStructureChangeEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Reason: TChangeReason) of object; + TVTEditCancelEvent = procedure(Sender: TBaseVirtualTree; Column: TColumnIndex) of object; + TVTEditChangingEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; + var Allowed: Boolean) of object; + TVTEditChangeEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex) of object; + TVTFreeNodeEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode) of object; + TVTFocusChangingEvent = procedure(Sender: TBaseVirtualTree; OldNode, NewNode: PVirtualNode; OldColumn, + NewColumn: TColumnIndex; var Allowed: Boolean) of object; + TVTFocusChangeEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex) of object; + TVTAddToSelectionEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode) of object; + TVTRemoveFromSelectionEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode) of object; + TVTGetImageEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex; + var Ghosted: Boolean; var ImageIndex: TImageIndex) of object; + TVTGetImageExEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex; + var Ghosted: Boolean; var ImageIndex: TImageIndex; var ImageList: TCustomImageList) of object; + TVTGetImageTextEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex; + var ImageText: string) of object; + TVTHotNodeChangeEvent = procedure(Sender: TBaseVirtualTree; OldNode, NewNode: PVirtualNode) of object; + TVTInitChildrenEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; var ChildCount: Cardinal) of object; + TVTInitNodeEvent = procedure(Sender: TBaseVirtualTree; ParentNode, Node: PVirtualNode; + var InitialStates: TVirtualNodeInitStates) of object; + TVTPopupEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; const P: TPoint; + var AskParent: Boolean; var PopupMenu: TPopupMenu) of object; + TVTHelpContextEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; + var HelpContext: Integer) of object; + TVTCreateEditorEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; + out EditLink: IVTEditLink) of object; + TVTSaveTreeEvent = procedure(Sender: TBaseVirtualTree; Stream: TStream) of object; + TVTSaveNodeEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Stream: TStream) of object; + TVTBeforeGetCheckStateEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode) of object; + + // header/column events + TVTHeaderAddPopupItemEvent = procedure(const Sender: TObject; const Column: TColumnIndex; var Cmd: TAddPopupItemType) of object; + TVTHeaderClickEvent = procedure(Sender: TVTHeader; HitInfo: TVTHeaderHitInfo) of object; + TVTHeaderMouseEvent = procedure(Sender: TVTHeader; Button: TMouseButton; Shift: TShiftState; X, Y: TDimension) of object; + TVTHeaderMouseMoveEvent = procedure(Sender: TVTHeader; Shift: TShiftState; X, Y: TDimension) of object; + TVTBeforeHeaderHeightTrackingEvent = procedure(Sender: TVTHeader; Shift: TShiftState) of object; + TVTAfterHeaderHeightTrackingEvent = procedure(Sender: TVTHeader) of object; + TVTHeaderHeightTrackingEvent = procedure(Sender: TVTHeader; var P: TPoint; Shift: TShiftState; var Allowed: Boolean) of object; + TVTHeaderHeightDblClickResizeEvent = procedure(Sender: TVTHeader; var P: TPoint; Shift: TShiftState; var Allowed: Boolean) of object; + TVTHeaderNotifyEvent = procedure(Sender: TVTHeader; Column: TColumnIndex) of object; + TVTHeaderDraggingEvent = procedure(Sender: TVTHeader; Column: TColumnIndex; var Allowed: Boolean) of object; + TVTHeaderDraggedEvent = procedure(Sender: TVTHeader; Column: TColumnIndex; OldPosition: Integer) of object; + TVTHeaderDraggedOutEvent = procedure(Sender: TVTHeader; Column: TColumnIndex; DropPosition: TPoint) of object; + TVTHeaderPaintEvent = procedure(Sender: TVTHeader; HeaderCanvas: TCanvas; Column: TVirtualTreeColumn; R: TRect; Hover, + Pressed: Boolean; DropMark: TVTDropMarkMode) of object; + TVTHeaderPaintQueryElementsEvent = procedure(Sender: TVTHeader; var PaintInfo: THeaderPaintInfo; + var Elements: THeaderPaintElements) of object; + TVTAdvancedHeaderPaintEvent = procedure(Sender: TVTHeader; var PaintInfo: THeaderPaintInfo; + const Elements: THeaderPaintElements) of object; + TVTBeforeAutoFitColumnsEvent = procedure(Sender: TVTHeader; var SmartAutoFitType: TSmartAutoFitType) of object; + TVTBeforeAutoFitColumnEvent = procedure(Sender: TVTHeader; Column: TColumnIndex; var SmartAutoFitType: TSmartAutoFitType; + var Allowed: Boolean) of object; + TVTAfterAutoFitColumnEvent = procedure(Sender: TVTHeader; Column: TColumnIndex) of object; + TVTAfterAutoFitColumnsEvent = procedure(Sender: TVTHeader) of object; + TVTColumnCheckChangingEvent = procedure(Sender: TVTHeader; Column: TColumnIndex; var NewState: TCheckState; + var Allowed: Boolean) of object; + TVTColumnClickEvent = procedure (Sender: TBaseVirtualTree; Column: TColumnIndex; Shift: TShiftState) of object; + TVTColumnDblClickEvent = procedure (Sender: TBaseVirtualTree; Column: TColumnIndex; Shift: TShiftState) of object; + TColumnChangeEvent = procedure(const Sender: TBaseVirtualTree; const Column: TColumnIndex; Visible: Boolean) of object; + TVTColumnWidthDblClickResizeEvent = procedure(Sender: TVTHeader; Column: TColumnIndex; Shift: TShiftState; P: TPoint; + var Allowed: Boolean) of object; + TVTBeforeColumnWidthTrackingEvent = procedure(Sender: TVTHeader; Column: TColumnIndex; Shift: TShiftState) of object; + TVTAfterColumnWidthTrackingEvent = procedure(Sender: TVTHeader; Column: TColumnIndex) of object; + TVTColumnWidthTrackingEvent = procedure(Sender: TVTHeader; Column: TColumnIndex; Shift: TShiftState; var TrackPoint: TPoint; P: TPoint; + var Allowed: Boolean) of object; + TVTGetHeaderCursorEvent = procedure(Sender: TVTHeader; var Cursor: TVTCursor) of object; + TVTBeforeGetMaxColumnWidthEvent = procedure(Sender: TVTHeader; Column: TColumnIndex; var UseSmartColumnWidth: Boolean) of object; + TVTAfterGetMaxColumnWidthEvent = procedure(Sender: TVTHeader; Column: TColumnIndex; var MaxWidth: TDimension) of object; + TVTCanSplitterResizeColumnEvent = procedure(Sender: TVTHeader; P: TPoint; Column: TColumnIndex; var Allowed: Boolean) of object; + TVTCanSplitterResizeHeaderEvent = procedure(Sender: TVTHeader; P: TPoint; var Allowed: Boolean) of object; + + // move, copy and node tracking events + TVTNodeMovedEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode) of object; + TVTNodeMovingEvent = procedure(Sender: TBaseVirtualTree; Node, Target: PVirtualNode; + var Allowed: Boolean) of object; + TVTNodeCopiedEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode) of object; + TVTNodeCopyingEvent = procedure(Sender: TBaseVirtualTree; Node, Target: PVirtualNode; + var Allowed: Boolean) of object; + TVTNodeClickEvent = procedure(Sender: TBaseVirtualTree; const HitInfo: THitInfo) of object; + TVTNodeHeightTrackingEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; Shift: TShiftState; + var TrackPoint: TPoint; P: TPoint; var Allowed: Boolean) of object; + TVTNodeHeightDblClickResizeEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; + Shift: TShiftState; P: TPoint; var Allowed: Boolean) of object; + TVTCanSplitterResizeNodeEvent = procedure(Sender: TBaseVirtualTree; P: TPoint; Node: PVirtualNode; + Column: TColumnIndex; var Allowed: Boolean) of object; + + TVTGetUserClipboardFormatsEvent = procedure(Sender: TBaseVirtualTree; var Formats: TFormatEtcArray) of object; + + // drag'n drop/OLE events + TVTCreateDragManagerEvent = procedure(Sender: TBaseVirtualTree; out DragManager: IVTDragManager) of object; + TVTCreateDataObjectEvent = procedure(Sender: TBaseVirtualTree; out IDataObject: TVTDragDataObject) of object; + TVTDragAllowedEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; + var Allowed: Boolean) of object; + TVTDragOverEvent = procedure(Sender: TBaseVirtualTree; Source: TObject; Shift: TShiftState; State: TDragState; + Pt: TPoint; Mode: TDropMode; var Effect: Integer; var Accept: Boolean) of object; + TVTDragDropEvent = procedure(Sender: TBaseVirtualTree; Source: TObject; DataObject: TVTDragDataObject; + Formats: TFormatArray; Shift: TShiftState; Pt: TPoint; var Effect: Integer; Mode: TDropMode) of object; + + // paint events + TVTBeforeItemEraseEvent = procedure(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode; ItemRect: TRect; + var ItemColor: TColor; var EraseAction: TItemEraseAction) of object; + TVTAfterItemEraseEvent = procedure(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode; + ItemRect: TRect) of object; + TVTBeforeItemPaintEvent = procedure(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode; + ItemRect: TRect; var CustomDraw: Boolean) of object; + TVTAfterItemPaintEvent = procedure(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode; + ItemRect: TRect) of object; + TVTBeforeCellPaintEvent = procedure(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode; + Column: TColumnIndex; CellPaintMode: TVTCellPaintMode; CellRect: TRect; var ContentRect: TRect) of object; + TVTAfterCellPaintEvent = procedure(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode; + Column: TColumnIndex; CellRect: TRect) of object; + TVTPaintEvent = procedure(Sender: TBaseVirtualTree; TargetCanvas: TCanvas) of object; + TVTBackgroundPaintEvent = procedure(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; R: TRect; + var Handled: Boolean) of object; + TVTGetLineStyleEvent = procedure(Sender: TBaseVirtualTree; var Bits: Pointer) of object; + TVTMeasureItemEvent = procedure(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode; + var NodeHeight: TDimension) of object; + TVTPaintText = procedure(Sender: TBaseVirtualTree; const TargetCanvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; + TextType: TVSTTextType) of object; + + TVTPrepareButtonImagesEvent = procedure(Sender: TBaseVirtualTree; const APlusBM : TBitmap; const APlusHotBM :TBitmap; + const APlusSelectedHotBM :TBitmap; const AMinusBM : TBitmap; const AMinusHotBM : TBitmap; + const AMinusSelectedHotBM :TBitmap; var ASize : TSize) of object; + + TVTColumnHeaderSpanningEvent = procedure(Sender: TVTHeader; Column: TColumnIndex; var Count: Integer) of object; + + // search, sort + TVTCompareEvent = procedure(Sender: TBaseVirtualTree; Node1, Node2: PVirtualNode; Column: TColumnIndex; + var Result: Integer) of object; + TVTIncrementalSearchEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; const SearchText: string; + var Result: Integer) of object; + + // operations + TVTOperationEvent = procedure(Sender: TBaseVirtualTree; OperationKind: TVTOperationKind) of object; + + TVTHintKind = (vhkText, vhkOwnerDraw); + TVTHintKindEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; var Kind: TVTHintKind) of object; + TVTDrawHintEvent = procedure(Sender: TBaseVirtualTree; HintCanvas: TCanvas; Node: PVirtualNode; R: TRect; Column: TColumnIndex) of object; + TVTGetHintSizeEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; var R: TRect) of object; + + // miscellaneous + TVTBeforeDrawLineImageEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Level: Integer; var PosX: TDimension) of object; + TVTGetNodeDataSizeEvent = procedure(Sender: TBaseVirtualTree; var NodeDataSize: Integer) of object; + TVTKeyActionEvent = procedure(Sender: TBaseVirtualTree; var CharCode: Word; var Shift: TShiftState; + var DoDefault: Boolean) of object; + TVTScrollEvent = procedure(Sender: TBaseVirtualTree; DeltaX, DeltaY: TDimension) of object; + TVTUpdatingEvent = procedure(Sender: TBaseVirtualTree; State: TVTUpdateState) of object; + TVTGetCursorEvent = procedure(Sender: TBaseVirtualTree; var Cursor: TCursor) of object; + TVTStateChangeEvent = procedure(Sender: TBaseVirtualTree; Enter, Leave: TVirtualTreeStates) of object; + TVTGetCellIsEmptyEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; + var IsEmpty: Boolean) of object; + TVTScrollBarShowEvent = procedure(Sender: TBaseVirtualTree; Bar: Integer; Show: Boolean) of object; + + // Helper types for node iterations. + TGetFirstNodeProc = function: PVirtualNode of object; + TGetNextNodeProc = function(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode of object; + + TVZVirtualNodeEnumerationMode = ( + vneAll, + vneChecked, + vneChild, + vneCutCopy, + vneInitialized, + vneLeaf, + vneLevel, + vneNoInit, + vneSelected, + vneVisible, + vneVisibleChild, + vneVisibleNoInitChild, + vneVisibleNoInit + ); + + PVTVirtualNodeEnumeration = ^TVTVirtualNodeEnumeration; + + TVTVirtualNodeEnumerator = record + private + FNode: PVirtualNode; + FCanMoveNext: Boolean; + FEnumeration: PVTVirtualNodeEnumeration; + function GetCurrent: PVirtualNode; inline; + public + function MoveNext: Boolean; inline; + property Current: PVirtualNode read GetCurrent; + end; + + TVTVirtualNodeEnumeration = record + private + FMode: TVZVirtualNodeEnumerationMode; + FTree: TBaseVirtualTree; + // GetNextXxx parameters: + FConsiderChildrenAbove: Boolean; + FNode: PVirtualNode; + FNodeLevel: Cardinal; + FState: TCheckState; + FIncludeFiltered: Boolean; + public + function GetEnumerator: TVTVirtualNodeEnumerator; + private + function GetNext(Node: PVirtualNode): PVirtualNode; + end; + + + // ----- TBaseVirtualTree + TBaseVirtualTree = class abstract(TVTBaseAncestor) + private + FTotalInternalDataSize: Cardinal; // Cache of the sum of the necessary internal data size for all tree + FBorderStyle: TBorderStyle; + FHeader: TVTHeader; + FRoot: PVirtualNode; + FDefaultNodeHeight, + FIndent: TDimension; + FOptions: TCustomVirtualTreeOptions; + FUpdateCount: Cardinal; // update stopper, updates of the tree control are only done if = 0 + FSynchUpdateCount: Cardinal; // synchronizer, causes all events which are usually done via timers + // to happen immediately, regardless of the normal update state + FNodeDataSize: Integer; // number of bytes to allocate with each node (in addition to its base + // structure and the internal data), if -1 then do callback + FStates: TVirtualTreeStates; // various active/pending states the tree needs to consider + FLastSelected, + FFocusedNode: PVirtualNode; + FEditColumn, // column to be edited (focused node) + FFocusedColumn: TColumnIndex; // NoColumn if no columns are active otherwise the last hit column of + // the currently focused node + FHeightTrackPoint: TPoint; // Starting point of a node's height changing operation. + FHeightTrackNode: PVirtualNode; // Node which height is being changed. + FHeightTrackColumn: TColumnIndex; // Initial column where the height changing operation takes place. + FScrollDirections: TScrollDirections; // directions to scroll client area into depending on mouse position + FLastStructureChangeReason: TChangeReason; // Used for delayed structure change event. + FLastStructureChangeNode, // dito + FLastChangedNode, // used for delayed change event + FCurrentHotNode: PVirtualNode; // Node over which the mouse is hovering. + FCurrentHotColumn: TColumnIndex; // Column over which the mouse is hovering. + FHotNodeButtonHit: Boolean; // Indicates wether the mouse is hovering over the hot node's button. + FLastSelRect, + FNewSelRect: TRect; // used while doing draw selection + FHotCursor: TCursor; // can be set to additionally indicate the current hot node + FLastHitInfo: THitInfo; // The THitInfo of the last mouse-down event. + // in Win98 (slide) and Windows 2000 (fade)) + FHintMode: TVTHintMode; // determines the kind of the hint window + FHintData: TVTHintData; // used while preparing the hint window + FChangeDelay: Cardinal; // used to delay OnChange event + FEditDelay: Cardinal; // determines time to elapse before a node goes into edit mode + FPositionCache: TCache; // array which stores node references ordered by vertical positions + // (see also DoValidateCache for more information) + FVisibleCount: Cardinal; // number of currently visible nodes + FStartIndex: Cardinal; // index to start validating cache from + FSelection: TNodeArray; // list of currently selected nodes + FSelectionLocked: Boolean; // prevents the tree from changing the selection + FRangeAnchor: PVirtualNode; // anchor node for selection with the keyboard, determines start of a + // selection range + FCheckPropagationCount: Cardinal; // nesting level of check propagation (WL, 05.02.2004) + FLastSelectionLevel: Integer; // keeps the last node level for constrained multiselection + FDrawSelShiftState: TShiftState; // keeps the initial shift state when the user starts selection with + // the mouse + FEditLink: IVTEditLink; // used to comunicate with an application defined editor + FTempNodeCache: TNodeArray; // used at various places to hold temporarily a bunch of node refs. + FTempNodeCount: Cardinal; // number of nodes in FTempNodeCache + FBackground: TVTBackground; // A background image loadable at design and runtime. + FBackgroundImageTransparent: Boolean; // By default, this is off. When switched on, will try to draw the image + // transparent by using the color of the component as transparent color + + FMargin: TDimension; // horizontal distance to border and columns + FTextMargin: TDimension; // space between the node's text and its horizontal bounds + FBackgroundOffsetX, + FBackgroundOffsetY: TDimension; // used to fine tune the position of the background image + FAnimationDuration: Cardinal; // specifies how long an animation shall take (expanding, hint) + FWantTabs: Boolean; // If True then the tree also consumes the tab key. + FNodeAlignment: TVTNodeAlignment; // determines how to interpret the align member of a node + FHeaderRect: TRect; // Space which the header currently uses in the control (window coords). + FLastHintRect: TRect; // Area which the mouse must leave to reshow a hint. + FUpdateRect: TRect; + FEmptyListMessage: string; // Optional message that will be displayed if no nodes exist in the control. + + // paint support and images + FPlusBM, + FMinusBM, // small bitmaps used for tree buttons + FHotPlusBM, + FHotMinusBM, + FSelectedHotPlusBM, + FSelectedHotMinusBM: TBitmap; // small bitmaps used for hot tree buttons + FImages, // normal images in the tree + FStateImages, // state images in the tree + FCustomCheckImages: TCustomImageList; // application defined check images + FCheckImageKind: TCheckImageKind; // light or dark, cross marks or tick marks + FCheckImages: TCustomImageList; // Reference to global image list to be used for the check images. + //TODO: Use this margin for other images as well + FImagesMargin: TDimension; // The margin used left and right of the checkboxes. + FImageChangeLink, + FStateChangeLink, + FCustomCheckChangeLink: TChangeLink; // connections to the image lists + FOldFontChange: TNotifyEvent; // helper method pointer for tracking font changes in the off screen buffer + FColors: TVTColors; // class comprising all customizable colors in the tree + FButtonStyle: TVTButtonStyle; // style of the tree buttons + FButtonFillMode: TVTButtonFillMode; // for rectangular tree buttons only: how to fill them + FLineStyle: TVTLineStyle; // style of the tree lines + FLineMode: TVTLineMode; // tree lines or bands etc. + FSelectionCurveRadius: Cardinal; // radius for rounded selection rectangles + FSelectionBlendFactor: Byte; // Determines the factor by which the selection rectangle is to be + // faded if enabled. + FDrawSelectionMode: TVTDrawSelectionMode; // determines the paint mode for draw selection + + // alignment and directionality support + FAlignment: TAlignment; // default alignment of the tree if no columns are shown + + // drag'n drop and clipboard support + FDragImageKind: TVTDragImageKind; // determines whether or not and what to show in the drag image + FDragOperations: TDragOperations; // determines which operations are allowed during drag'n drop + FDragThreshold: Integer; // used to determine when to actually start a drag'n drop operation + FDragManager: IVTDragManager; // drag'n drop, cut'n paste + FDropTargetNode: PVirtualNode; // node currently selected as drop target + FLastDropMode: TDropMode; // set while dragging and used to track changes + FDragSelection: TNodeArray; // temporary copy of FSelection used during drag'n drop + FLastDragEffect: Integer; // The last executed drag effect + FDragType: TVTDragType; // used to switch between OLE and VCL drag'n drop + FDragWidth, + FDragHeight: Integer; // size of the drag image, the larger the more CPU power is needed + FClipboardFormats: TClipboardFormats; // a list of clipboard format descriptions enabled for this tree + FLastVCLDragTarget: PVirtualNode; // A node cache for VCL drag'n drop (keywords: DragLeave on DragDrop). + FVCLDragEffect: Integer; // A cache for VCL drag'n drop to keep the current drop effect. + + // scroll support + FScrollBarOptions: TScrollBarOptions; // common properties of horizontal and vertical scrollbar + FAutoScrollInterval: TAutoScrollInterval; // determines speed of auto scrolling + FAutoScrollDelay: Cardinal; // amount of milliseconds to wait until autoscrolling becomes active + FAutoExpandDelay: Cardinal; // amount of milliseconds to wait until a node is expanded if it is the + // drop target + FOffsetX: TDimension; + FOffsetY: TDimension; // Determines left and top scroll offset. + FEffectiveOffsetX: TDimension; // Actual position of the horizontal scroll bar (varies depending on bidi mode). + FRangeX, + FRangeY: TNodeHeight; // current virtual width and height of the tree + FBottomSpace: TDimension; // Extra space below the last node. + + FDefaultPasteMode: TVTNodeAttachMode; // Used to determine where to add pasted nodes to. + FDragScrollStart: Cardinal; // Contains the start time when a tree does auto scrolling as drop target. + + // search + FIncrementalSearch: TVTIncrementalSearch; // Used to determine whether and how incremental search is to be used. + FSearchTimeout: Cardinal; // Number of milliseconds after which to stop incremental searching. + FSearchBuffer: string; // Collects a sequence of keypresses used to do incremental searching. + FLastSearchNode: PVirtualNode; // Reference to node which was last found as search fit. + FSearchDirection: TVTSearchDirection; // Direction to incrementally search the tree. + FSearchStart: TVTSearchStart; // Where to start iteration on each key press. + + // miscellanous + FPanningWindow: TForm; // Helper window for wheel panning + FPanningCursor: TVTCursor; // Current wheel panning cursor. + FLastClickPos: TPoint; // Used for retained drag start and wheel mouse scrolling. + FOperationCount: Cardinal; // Counts how many nested long-running operations are in progress. + FOperationCanceled: Boolean; // Used to indicate that a long-running operation should be canceled. + FChangingTheme: Boolean; // Used to indicate that a theme change is goi ng on + FNextNodeToSelect: PVirtualNode; // Next tree node that we would like to select if the current one gets deleted or looses selection for other reasons. + FPendingSyncProcs:Integer; // Counter that indicates whether we have queued anonymous calls to the min thread, see issue #1199 + + // export + FOnBeforeNodeExport: TVTNodeExportEvent; // called before exporting a node + FOnNodeExport: TVTNodeExportEvent; + FOnAfterNodeExport: TVTNodeExportEvent; // called after exporting a node + FOnBeforeColumnExport: TVTColumnExportEvent; // called before exporting a column + FOnColumnExport: TVTColumnExportEvent; + FOnAfterColumnExport: TVTColumnExportEvent; // called after exporting a column + FOnBeforeTreeExport: TVTTreeExportEvent; // called before starting the export + FOnAfterTreeExport: TVTTreeExportEvent; // called after finishing the export + FOnBeforeHeaderExport: TVTTreeExportEvent; // called before exporting the header + FOnAfterHeaderExport: TVTTreeExportEvent; // called after exporting the header + + // common events + FOnChange: TVTChangeEvent; // selection change + FOnStructureChange: TVTStructureChangeEvent; // structural change like adding nodes etc. + FOnInitChildren: TVTInitChildrenEvent; // called when a node's children are needed (expanding etc.) + FOnInitNode: TVTInitNodeEvent; // called when a node needs to be initialized (child count etc.) + FOnFreeNode: TVTFreeNodeEvent; // called when a node is about to be destroyed, user data can and should + // be freed in this event + FOnGetImage: TVTGetImageEvent; // Used to retrieve the image index of a given node. + FOnGetImageEx: TVTGetImageExEvent; // Used to retrieve the image index of a given node along with a custom + // image list. + FOnGetImageText: TVTGetImageTextEvent; // Used to retrieve the image alternative text of a given node. + // Used by the accessibility interface to provide useful text for status images. + FOnHotChange: TVTHotNodeChangeEvent; // called when the current "hot" node (that is, the node under the mouse) + // changes and hot tracking is enabled + FOnExpanding, // called just before a node is expanded + FOnCollapsing: TVTChangingEvent; // called just before a node is collapsed + FOnChecking: TVTCheckChangingEvent; // called just before a node's check state is changed + FOnExpanded, // called after a node has been expanded + FOnCollapsed, // called after a node has been collapsed + FOnChecked: TVTChangeEvent; // called after a node's check state has been changed + FOnResetNode: TVTChangeEvent; // called when a node is set to be uninitialized + FOnNodeMoving: TVTNodeMovingEvent; // called just before a node is moved from one parent node to another + // (this can be cancelled) + FOnNodeMoved: TVTNodeMovedEvent; // called after a node and its children have been moved to another + // parent node (probably another tree, but within the same application) + FOnNodeCopying: TVTNodeCopyingEvent; // called when a node is copied to another parent node (probably in + // another tree, but within the same application, can be cancelled) + FOnNodeClick: TVTNodeClickEvent; // called when the user clicks on a node + FOnNodeDblClick: TVTNodeClickEvent; // called when the user double clicks on a node + FOnCanSplitterResizeNode: TVTCanSplitterResizeNodeEvent; // called to query the application wether resizing a node is allowed + FOnNodeHeightTracking: TVTNodeHeightTrackingEvent; // called when a node's height is being changed via mouse + FOnNodeHeightDblClickResize: TVTNodeHeightDblClickResizeEvent; // called when a node's vertical splitter is double clicked + FOnNodeCopied: TVTNodeCopiedEvent; // call after a node has been copied + FOnEditing: TVTEditChangingEvent; // called just before a node goes into edit mode + FOnEditCancelled: TVTEditCancelEvent; // called when editing has been cancelled + FOnEdited: TVTEditChangeEvent; // called when editing has successfully been finished + FOnFocusChanging: TVTFocusChangingEvent; // called when the focus is about to go to a new node and/or column + // (can be cancelled) + FOnFocusChanged: TVTFocusChangeEvent; // called when the focus goes to a new node and/or column + FOnAddToSelection: TVTAddToSelectionEvent; // called when a node is added to the selection + FOnRemoveFromSelection: TVTRemoveFromSelectionEvent; // called when a node is removed from the selection + FOnGetPopupMenu: TVTPopupEvent; // called when the popup for a node or the header needs to be shown + FOnGetHelpContext: TVTHelpContextEvent; // called when a node specific help theme should be called + FOnCreateEditor: TVTCreateEditorEvent; // called when a node goes into edit mode, this allows applications + // to supply their own editor + FOnLoadNode, // called after a node has been loaded from a stream (file, clipboard, + // OLE drag'n drop) to allow an application to load their own data + // saved in OnSaveNode + FOnSaveNode: TVTSaveNodeEvent; // called when a node needs to be serialized into a stream + // (see OnLoadNode) to give the application the opportunity to save + // their node specific, persistent data (note: never save memory + // references) + FOnLoadTree, // called after the tree has been loaded from a stream to allow an + // application to load their own data saved in OnSaveTree + FOnSaveTree: TVTSaveTreeEvent; // called after the tree has been saved to a stream to allow an + // application to save its own data + + // header/column mouse events + FOnAfterAutoFitColumn: TVTAfterAutoFitColumnEvent; + FOnAfterAutoFitColumns: TVTAfterAutoFitColumnsEvent; + FOnBeforeAutoFitColumns: TVTBeforeAutoFitColumnsEvent; + FOnBeforeAutoFitColumn: TVTBeforeAutoFitColumnEvent; + FOnHeaderAddPopupItem: TVTHeaderAddPopupItemEvent; + FOnHeaderClick: TVTHeaderClickEvent; + FOnHeaderDblClick: TVTHeaderClickEvent; + FOnAfterHeaderHeightTracking: TVTAfterHeaderHeightTrackingEvent; + FOnBeforeHeaderHeightTracking: TVTBeforeHeaderHeightTrackingEvent; + FOnHeaderHeightTracking: TVTHeaderHeightTrackingEvent; + FOnHeaderHeightDblClickResize: TVTHeaderHeightDblClickResizeEvent; + FOnHeaderMouseDown, + FOnHeaderMouseUp: TVTHeaderMouseEvent; + FOnHeaderMouseMove: TVTHeaderMouseMoveEvent; + FOnAfterGetMaxColumnWidth: TVTAfterGetMaxColumnWidthEvent; + FOnBeforeGetMaxColumnWidth: TVTBeforeGetMaxColumnWidthEvent; + FOnColumnChecked: TVTHeaderNotifyEvent; // triggered when the column is about to be checked + FOnColumnChecking: TVTColumnCheckChangingEvent; + FOnColumnClick: TVTColumnClickEvent; + FOnColumnDblClick: TVTColumnDblClickEvent; + FOnColumnResize: TVTHeaderNotifyEvent; + fOnColumnVisibilityChanged: TColumnChangeEvent; + FOnColumnWidthDblClickResize: TVTColumnWidthDblClickResizeEvent; + FOnAfterColumnWidthTracking: TVTAfterColumnWidthTrackingEvent; + FOnBeforeColumnWidthTracking: TVTBeforeColumnWidthTrackingEvent; + FOnColumnWidthTracking: TVTColumnWidthTrackingEvent; + FOnGetHeaderCursor: TVTGetHeaderCursorEvent; // triggered to allow the app. to use customized cursors for the header + FOnCanSplitterResizeColumn: TVTCanSplitterResizeColumnEvent; + FOnCanSplitterResizeHeader: TVTCanSplitterResizeHeaderEvent; + + // paint events + FOnAfterPaint, // triggered when the tree has entirely been painted + FOnBeforePaint: TVTPaintEvent; // triggered when the tree is about to be painted + FOnAfterItemPaint: TVTAfterItemPaintEvent; // triggered after an item has been painted + FOnBeforeItemPaint: TVTBeforeItemPaintEvent; // triggered when an item is about to be painted + FOnBeforeItemErase: TVTBeforeItemEraseEvent; // triggered when an item's background is about to be erased + FOnAfterItemErase: TVTAfterItemEraseEvent; // triggered after an item's background has been erased + FOnAfterCellPaint: TVTAfterCellPaintEvent; // triggered after a column of an item has been painted + FOnBeforeCellPaint: TVTBeforeCellPaintEvent; // triggered when a column of an item is about to be painted + FOnHeaderDraw: TVTHeaderPaintEvent; // Used when owner draw is enabled for the header and a column is set + // to owner draw mode. + FOnPrepareButtonImages : TVTPrepareButtonImagesEvent; //allow use to customise plus/minus bitmap images + FOnHeaderDrawQueryElements: TVTHeaderPaintQueryElementsEvent; // Used for advanced header painting to query the + // application for the elements, which are drawn by it and which should + // be drawn by the tree. + FOnAdvancedHeaderDraw: TVTAdvancedHeaderPaintEvent; // Used when owner draw is enabled for the header and a column + // is set to owner draw mode. But only if OnHeaderDrawQueryElements + // returns at least one element to be drawn by the application. + // In this case OnHeaderDraw is not used. + FOnGetLineStyle: TVTGetLineStyleEvent; // triggered when a custom line style is used and the pattern brush + // needs to be build + FOnPaintBackground: TVTBackgroundPaintEvent; // triggered if a part of the tree's background must be erased which is + // not covered by any node + FOnMeasureItem: TVTMeasureItemEvent; // Triggered when a node is about to be drawn and its height was not yet + // determined by the application. + FOnColumnHeaderSpanning: TVTColumnHeaderSpanningEvent; // triggered before the header column area been create for painting + FOnGetUserClipboardFormats: TVTGetUserClipboardFormatsEvent; // gives application/descendants the opportunity to + // add own clipboard formats on the fly + FOnPaintText: TVTPaintText; // triggered before either normal or fixed text is painted to allow + // even finer customization (kind of sub cell painting) + // drag'n drop events + FOnCreateDragManager: TVTCreateDragManagerEvent; // called to allow for app./descendant defined drag managers + FOnCreateDataObject: TVTCreateDataObjectEvent; // called to allow for app./descendant defined data objects + FOnDragAllowed: TVTDragAllowedEvent; // used to get permission for manual drag in mouse down + FOnDragOver: TVTDragOverEvent; // called for every mouse move + FOnDragDrop: TVTDragDropEvent; // called on release of mouse button (if drop was allowed) + FOnHeaderDragged: TVTHeaderDraggedEvent; // header (column) drag'n drop + FOnHeaderDraggedOut: TVTHeaderDraggedOutEvent; // header (column) drag'n drop, which did not result in a valid drop. + FOnHeaderDragging: TVTHeaderDraggingEvent; // header (column) drag'n drop + + // miscellanous events + FOnGetNodeDataSize: TVTGetNodeDataSizeEvent; // Called if NodeDataSize is -1. + FOnBeforeDrawLineImage: TVTBeforeDrawLineImageEvent; // Called to allow adjusting the indention of treelines. + FOnKeyAction: TVTKeyActionEvent; // Used to selectively prevent key actions (full expand on Ctrl+'+' etc.). + FOnScroll: TVTScrollEvent; // Called when one or both paint offsets changed. + FOnUpdating: TVTUpdatingEvent; // Called from BeginUpdate, EndUpdate, BeginSynch and EndSynch. + FOnGetCursor: TVTGetCursorEvent; // Called to allow the app. to set individual cursors. + FOnStateChange: TVTStateChangeEvent; // Called whenever a state in the tree changes. + FOnGetCellIsEmpty: TVTGetCellIsEmptyEvent; // Called when the tree needs to know if a cell is empty. + FOnShowScrollBar: TVTScrollBarShowEvent; // Called when a scrollbar is changed in its visibility. + FOnBeforeGetCheckState: TVTBeforeGetCheckStateEvent; // Called before a CheckState for a Node is obtained. + // Gives the application a chance to do special processing + // when a check state is actually required for the first time. + + // search, sort + FOnCompareNodes: TVTCompareEvent; // used during sort + FOnDrawHint: TVTDrawHintEvent; + FOnGetHintSize: TVTGetHintSizeEvent; + FOnGetHintKind: TVTHintKindEvent; + FOnIncrementalSearch: TVTIncrementalSearchEvent; // triggered on every key press (not key down) + FOnMouseEnter: TNotifyEvent; + FOnMouseLeave: TNotifyEvent; + + // operations + FOnStartOperation: TVTOperationEvent; // Called when an operation starts + FOnEndOperation: TVTOperationEvent; // Called when an operation ends + + FVclStyleEnabled: Boolean; + FSelectionCount: Integer; + + procedure CMStyleChanged(var Message: TMessage); message CM_STYLECHANGED; + procedure CMParentDoubleBufferedChange(var Message: TMessage); message CM_PARENTDOUBLEBUFFEREDCHANGED; + + procedure AdjustTotalCount(Node: PVirtualNode; Value: Integer; relative: Boolean = False); + function CalculateCacheEntryCount: Integer; + procedure CalculateVerticalAlignments(var PaintInfo: TVTPaintInfo; var VButtonAlign: TDimension); + function ChangeCheckState(Node: PVirtualNode; Value: TCheckState): Boolean; + function CollectSelectedNodesLTR(MainColumn: Integer; NodeLeft, NodeRight: TDimension; Alignment: TAlignment; OldRect, + NewRect: TRect): Boolean; + function CollectSelectedNodesRTL(MainColumn: Integer; NodeLeft, NodeRight: TDimension; Alignment: TAlignment; OldRect, + NewRect: TRect): Boolean; + procedure ClearNodeBackground(const PaintInfo: TVTPaintInfo; UseBackground, Floating: Boolean; R: TRect); + function CompareNodePositions(Node1, Node2: PVirtualNode; ConsiderChildrenAbove: Boolean = False): Integer; + procedure DrawLineImage(const PaintInfo: TVTPaintInfo; X, Y, H, VAlign: TDimension; Style: TVTLineType; Reverse: Boolean); + function FindInPositionCache(Node: PVirtualNode; var CurrentPos: TNodeHeight): PVirtualNode; overload; + function FindInPositionCache(Position: TDimension; var CurrentPos: TNodeHeight): PVirtualNode; overload; + procedure FixupTotalCount(Node: PVirtualNode); + procedure FixupTotalHeight(Node: PVirtualNode); + function GetBottomNode: PVirtualNode; + function GetCheckState(Node: PVirtualNode): TCheckState; + function GetCheckType(Node: PVirtualNode): TCheckType; + function GetChildCount(Node: PVirtualNode): Cardinal; + function GetChildrenInitialized(Node: PVirtualNode): Boolean; inline; + function GetCutCopyCount: Integer; + function GetDisabled(Node: PVirtualNode): Boolean; + function GetSyncCheckstateWithSelection(Node: PVirtualNode): Boolean; + function GetDragManager: IVTDragManager; + function GetExpanded(Node: PVirtualNode): Boolean; + function GetFiltered(Node: PVirtualNode): Boolean; + function GetFullyVisible(Node: PVirtualNode): Boolean; + function GetHasChildren(Node: PVirtualNode): Boolean; + function GetMultiline(Node: PVirtualNode): Boolean; + function GetNodeHeight(Node: PVirtualNode): TNodeHeight; + function GetNodeParent(Node: PVirtualNode): PVirtualNode; + function GetOffsetXY: TPoint; + function GetRootNodeCount: Cardinal; + function GetSelected(Node: PVirtualNode): Boolean; + function GetTopNode: PVirtualNode; + function GetTotalCount: Cardinal; + function GetVerticalAlignment(Node: PVirtualNode): Byte; + function GetVisible(Node: PVirtualNode): Boolean; + function GetVisiblePath(Node: PVirtualNode): Boolean; + function HandleDrawSelection(X, Y: TDimension): Boolean; + procedure HandleCheckboxClick(pHitNode: PVirtualNode; pKeys: LongInt); + function HasVisibleNextSibling(Node: PVirtualNode): Boolean; + function HasVisiblePreviousSibling(Node: PVirtualNode): Boolean; + procedure ImageListChange(Sender: TObject); + procedure InitializeFirstColumnValues(var PaintInfo: TVTPaintInfo); + procedure InitRootNode(OldSize: Cardinal = 0); + function IsFirstVisibleChild(Parent, Node: PVirtualNode): Boolean; + function IsLastVisibleChild(Parent, Node: PVirtualNode): Boolean; + function MakeNewNode: PVirtualNode; + function PackArray({*}const TheArray: TNodeArray; Count: Integer): Integer; + procedure FakeReadIdent(Reader: TReader); + procedure SetAlignment(const Value: TAlignment); + procedure SetAnimationDuration(const Value: Cardinal); + procedure SetBackground(const Value: TVTBackground); + procedure SetBackGroundImageTransparent(const Value: Boolean); + procedure SetBackgroundOffset(const Index: Integer; const Value: TDimension); + procedure SetBorderStyle(Value: TBorderStyle); + procedure SetBottomNode(Node: PVirtualNode); + procedure SetBottomSpace(const Value: TDimension); + procedure SetButtonFillMode(const Value: TVTButtonFillMode); + procedure SetButtonStyle(const Value: TVTButtonStyle); + procedure SetCheckImageKind(Value: TCheckImageKind); + procedure SetCheckState(Node: PVirtualNode; Value: TCheckState); + procedure SetCheckType(Node: PVirtualNode; Value: TCheckType); + procedure SetClipboardFormats(const Value: TClipboardFormats); + procedure SetColors(const Value: TVTColors); + procedure SetCustomCheckImages(const Value: TCustomImageList); + procedure SetDefaultNodeHeight(Value: TDimension); + procedure SetDisabled(Node: PVirtualNode; Value: Boolean); + procedure SetEmptyListMessage(const Value: string); + procedure SetExpanded(Node: PVirtualNode; Value: Boolean); + procedure SetFocusedColumn(Value: TColumnIndex); + procedure SetFocusedNode(Value: PVirtualNode); + procedure SetFullyVisible(Node: PVirtualNode; Value: Boolean); + procedure SetHasChildren(Node: PVirtualNode; Value: Boolean); + procedure SetHeader(const Value: TVTHeader); + procedure SetHotNode(Value: PVirtualNode); + procedure SetFiltered(Node: PVirtualNode; Value: Boolean); + procedure SetImages(const Value: TCustomImageList); + procedure SetIndent(Value: TDimension); + procedure SetLineMode(const Value: TVTLineMode); + procedure SetLineStyle(const Value: TVTLineStyle); + procedure SetMargin(Value: TDimension); + procedure SetMultiline(Node: PVirtualNode; const Value: Boolean); + procedure SetNodeAlignment(const Value: TVTNodeAlignment); + procedure SetNodeDataSize(Value: Integer); + procedure SetNodeHeight(Node: PVirtualNode; Value: TNodeHeight); + procedure SetNodeParent(Node: PVirtualNode; const Value: PVirtualNode); + procedure SetOffsetX(const Value: TDimension); + procedure SetOffsetXY(const Value: TPoint); + procedure SetOffsetY(const Value: TDimension); + procedure SetOptions(const Value: TCustomVirtualTreeOptions); + procedure SetRootNodeCount(Value: Cardinal); + procedure SetScrollBarOptions(Value: TScrollBarOptions); + procedure SetSearchOption(const Value: TVTIncrementalSearch); + procedure SetSelected(Node: PVirtualNode; Value: Boolean); + procedure SetSelectionCurveRadius(const Value: Cardinal); + procedure SetStateImages(const Value: TCustomImageList); + procedure SetTextMargin(Value: TDimension); + procedure SetTopNode(Node: PVirtualNode); + procedure SetUpdateState(Updating: Boolean); + procedure SetVerticalAlignment(Node: PVirtualNode; Value: Byte); + procedure SetVisible(Node: PVirtualNode; Value: Boolean); + procedure SetVisiblePath(Node: PVirtualNode; Value: Boolean); + procedure PrepareBackGroundPicture(Source: TVTBackground; DrawingBitmap: TBitmap; DrawingBitmapWidth: TDimension; DrawingBitmapHeight: TDimension; ABkgcolor: TColor); + procedure StaticBackground(Source: TVTBackground; Target: TCanvas; OffsetPosition: TPoint; R: TRect; aBkgColor: TColor); + procedure TileBackground(Source: TVTBackground; Target: TCanvas; Offset: TPoint; R: TRect; aBkgColor: TColor); + function ToggleCallback(Step, StepSize: Integer; Data: Pointer): Boolean; + + procedure CMColorChange(var Message: TMessage); message CM_COLORCHANGED; + procedure CMCtl3DChanged(var Message: TMessage); message CM_CTL3DCHANGED; + procedure CMBiDiModeChanged(var Message: TMessage); message CM_BIDIMODECHANGED; + procedure CMBorderChanged(var Message: TMessage); message CM_BORDERCHANGED; + procedure CMDenySubclassing(var Message: TMessage); message CM_DENYSUBCLASSING; + procedure CMDrag(var Message: TCMDrag); message CM_DRAG; + procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED; + procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED; + procedure CMHintShow(var Message: TCMHintShow); message CM_HINTSHOW; + procedure CMHintShowPause(var Message: TCMHintShowPause); message CM_HINTSHOWPAUSE; + procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER; + procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE; + procedure CMMouseWheel(var Message: TCMMouseWheel); message CM_MOUSEWHEEL; + procedure CMSysColorChange(var Message: TMessage); message CM_SYSCOLORCHANGE; + procedure TVMGetItem(var Message: TMessage); message TVM_GETITEM; + procedure TVMGetItemRect(var Message: TMessage); message TVM_GETITEMRECT; + procedure TVMGetNextItem(var Message: TMessage); message TVM_GETNEXTITEM; + procedure WMCancelMode(var Message: TWMCancelMode); message WM_CANCELMODE; + procedure WMChar(var Message: TWMChar); message WM_CHAR; + procedure WMContextMenu(var Message: TWMContextMenu); message WM_CONTEXTMENU; + procedure WMCopy(var Message: TWMCopy); message WM_COPY; + procedure WMCut(var Message: TWMCut); message WM_CUT; + procedure WMEnable(var Message: TWMEnable); message WM_ENABLE; + procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND; + procedure WMGetDlgCode(var Message: TWMGetDlgCode); message WM_GETDLGCODE; + procedure WMHScroll(var Message: TWMHScroll); message WM_HSCROLL; + procedure WMKeyDown(var Message: TWMKeyDown); message WM_KEYDOWN; + procedure WMKeyUp(var Message: TWMKeyUp); message WM_KEYUP; + procedure WMKillFocus(var Msg: TWMKillFocus); message WM_KILLFOCUS; + procedure WMLButtonDblClk(var Message: TWMLButtonDblClk); message WM_LBUTTONDBLCLK; + procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN; + procedure WMLButtonUp(var Message: TWMLButtonUp); message WM_LBUTTONUP; + procedure WMMButtonDblClk(var Message: TWMMButtonDblClk); message WM_MBUTTONDBLCLK; + procedure WMMButtonDown(var Message: TWMMButtonDown); message WM_MBUTTONDOWN; + procedure WMMButtonUp(var Message: TWMMButtonUp); message WM_MBUTTONUP; + procedure WMNCCalcSize(var Message: TWMNCCalcSize); message WM_NCCALCSIZE; + procedure WMNCDestroy(var Message: TWMNCDestroy); message WM_NCDESTROY; + procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST; + procedure WMNCPaint(var Message: TWMNCPaint); message WM_NCPAINT; + procedure WMPaint(var Message: TWMPaint); message WM_PAINT; + procedure WMPaste(var Message: TWMPaste); message WM_PASTE; + procedure WMPrint(var Message: TWMPrint); message WM_PRINT; + procedure WMRButtonDblClk(var Message: TWMRButtonDblClk); message WM_RBUTTONDBLCLK; + procedure WMRButtonDown(var Message: TWMRButtonDown); message WM_RBUTTONDOWN; + procedure WMRButtonUp(var Message: TWMRButtonUp); message WM_RBUTTONUP; + procedure WMSetCursor(var Message: TWMSetCursor); message WM_SETCURSOR; + procedure WMSetFocus(var Msg: TWMSetFocus); message WM_SETFOCUS; + procedure WMSize(var Message: TWMSize); message WM_SIZE; + procedure WMTimer(var Message: TWMTimer); message WM_TIMER; + procedure WMThemeChanged(var Message: TMessage); message WM_THEMECHANGED; + procedure WMVScroll(var Message: TWMVScroll); message WM_VSCROLL; + function GetRangeX: TDimension; + procedure SetDoubleBuffered(const Value: Boolean); + function GetVclStyleEnabled: Boolean; inline; + procedure SetOnPrepareButtonImages(const Value: TVTPrepareButtonImagesEvent); + function IsStored_BackgroundOffsetXY(const Index: Integer): Boolean; + function IsStored_BottomSpace: Boolean; + function IsStored_DefaultNodeHeight: Boolean; + function IsStored_Indent: Boolean; + function IsStored_Margin: Boolean; + function IsStored_TextMargin: Boolean; + protected + FFontChanged: Boolean; // flag for keeping informed about font changes in the off screen buffer // [IPK] - private to protected + procedure AutoScale(); virtual; + procedure AddToSelection(const NewItems: TNodeArray; NewLength: Integer; ForceInsert: Boolean = False); overload; virtual; + procedure AdjustPaintCellRect(var PaintInfo: TVTPaintInfo; var NextNonEmpty: TColumnIndex); virtual; + procedure AdjustPanningCursor(X, Y: TDimension); virtual; + procedure AdjustTotalHeight(Node: PVirtualNode; Value: TNodeHeight; relative: Boolean = False); + procedure AdviseChangeEvent(StructureChange: Boolean; Node: PVirtualNode; Reason: TChangeReason); virtual; + function AllocateInternalDataArea(Size: Cardinal): Cardinal; virtual; + procedure Animate(Steps, Duration: Cardinal; Callback: TVTAnimationCallback; Data: Pointer); virtual; + function CalculateSelectionRect(X, Y: TDimension): Boolean; virtual; + function CanAutoScroll: Boolean; virtual; + function CanShowDragImage: Boolean; virtual; + function CanSplitterResizeNode(P: TPoint; Node: PVirtualNode; Column: TColumnIndex): Boolean; + procedure Change(Node: PVirtualNode); virtual; + procedure ChangeTreeStatesAsync(EnterStates, LeaveStates: TVirtualTreeStates); + procedure ChangeScale(M, D: Integer{$if CompilerVersion >= 31}; isDpiChange: Boolean{$ifend}); override; + function CheckParentCheckState(Node: PVirtualNode; NewCheckState: TCheckState): Boolean; virtual; + procedure ClearDragManager; + procedure ClearSelection(pFireChangeEvent: Boolean); overload; virtual; + procedure ClearTempCache; virtual; + function ColumnIsEmpty(Node: PVirtualNode; Column: TColumnIndex): Boolean; virtual; + function ComputeRTLOffset(ExcludeScrollBar: Boolean = False): TDimension; virtual; + function CountLevelDifference(Node1, Node2: PVirtualNode): Integer; virtual; + function CountVisibleChildren(Node: PVirtualNode): Cardinal; virtual; + procedure CreateParams(var Params: TCreateParams); override; + procedure CreateWnd; override; + procedure DecVisibleCount; + procedure DefineProperties(Filer: TFiler); override; + procedure DeleteNode(Node: PVirtualNode; Reindex: Boolean; ParentClearing: Boolean); overload; + function DetermineDropMode(const P: TPoint; var HitInfo: THitInfo; var NodeRect: TRect): TDropMode; virtual; + procedure DetermineHiddenChildrenFlag(Node: PVirtualNode); virtual; + procedure DetermineHiddenChildrenFlagAllNodes; virtual; + procedure DetermineHitPositionLTR(var HitInfo: THitInfo; Offset, Right: TDimension; Alignment: TAlignment); virtual; + procedure DetermineHitPositionRTL(var HitInfo: THitInfo; Offset, Right: TDimension; Alignment: TAlignment); virtual; + function DetermineLineImageAndSelectLevel(Node: PVirtualNode; var LineImage: TLineImage): Integer; virtual; + function DetermineNextCheckState(CheckType: TCheckType; CheckState: TCheckState): TCheckState; virtual; + function DetermineScrollDirections(X, Y: TDimension): TScrollDirections; virtual; + procedure DoAddToSelection(Node: PVirtualNode); virtual; + procedure DoAdvancedHeaderDraw(var PaintInfo: THeaderPaintInfo; const Elements: THeaderPaintElements); virtual; + procedure DoAfterCellPaint(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; CellRect: TRect); virtual; + procedure DoAfterItemErase(Canvas: TCanvas; Node: PVirtualNode; ItemRect: TRect); virtual; + procedure DoAfterItemPaint(Canvas: TCanvas; Node: PVirtualNode; ItemRect: TRect); virtual; + procedure DoAfterPaint(Canvas: TCanvas); virtual; + procedure DoAutoScroll(X, Y: TDimension); virtual; + function DoBeforeDrag(Node: PVirtualNode; Column: TColumnIndex): Boolean; virtual; + procedure DoBeforeCellPaint(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; + CellPaintMode: TVTCellPaintMode; CellRect: TRect; var ContentRect: TRect); virtual; + procedure DoBeforeItemErase(Canvas: TCanvas; Node: PVirtualNode; ItemRect: TRect; var Color: TColor; + var EraseAction: TItemEraseAction); virtual; + function DoBeforeItemPaint(Canvas: TCanvas; Node: PVirtualNode; ItemRect: TRect): Boolean; virtual; + procedure DoBeforePaint(Canvas: TCanvas); virtual; + function DoCancelEdit: Boolean; virtual; + procedure DoCanEdit(Node: PVirtualNode; Column: TColumnIndex; var Allowed: Boolean); virtual; + procedure DoCanSplitterResizeNode(P: TPoint; Node: PVirtualNode; Column: TColumnIndex; + var Allowed: Boolean); virtual; + procedure DoChange(Node: PVirtualNode); virtual; + procedure DoCheckClick(Node: PVirtualNode; NewCheckState: TCheckState); virtual; + procedure DoChecked(Node: PVirtualNode); virtual; + function DoChecking(Node: PVirtualNode; var NewCheckState: TCheckState): Boolean; virtual; + procedure DoCollapsed(Node: PVirtualNode); virtual; + function DoCollapsing(Node: PVirtualNode): Boolean; virtual; + procedure DoColumnChecked(Column: TColumnIndex); virtual; + function DoColumnChecking(Column: TColumnIndex; var NewCheckState: TCheckState): Boolean; virtual; + procedure DoColumnClick(Column: TColumnIndex; Shift: TShiftState); virtual; + procedure DoColumnDblClick(Column: TColumnIndex; Shift: TShiftState); virtual; + procedure DoColumnResize(Column: TColumnIndex); virtual; + procedure DoColumnVisibilityChanged(const Column: TColumnIndex; Visible: Boolean); virtual; + function DoCompare(Node1, Node2: PVirtualNode; Column: TColumnIndex): Integer; virtual; + function DoCreateDataObject: IDataObject; virtual; + function DoCreateDragManager: IVTDragManager; virtual; + function DoCreateEditor(Node: PVirtualNode; Column: TColumnIndex): IVTEditLink; virtual; + procedure DoDragging(P: TPoint); virtual; + procedure DoDragExpand; virtual; + procedure DoBeforeDrawLineImage(Node: PVirtualNode; Level: Integer; var XPos: TDimension); virtual; + function DoDragOver(Source: TObject; Shift: TShiftState; State: TDragState; Pt: TPoint; Mode: TDropMode; + var Effect: Integer): Boolean; virtual; + procedure DoDragDrop(Source: TObject; const DataObject: TVTDragDataObject; const Formats: TFormatArray; Shift: TShiftState; Pt: TPoint; + var Effect: Integer; Mode: TDropMode); virtual; + procedure DoDrawHint(Canvas: TCanvas; Node: PVirtualNode; R: TRect; Column: + TColumnIndex); + procedure DoEdit; virtual; + procedure DoEndDrag(Target: TObject; X, Y: TDimension); override; + function DoEndEdit(pCancel: Boolean = False): Boolean; virtual; + procedure DoEndOperation(OperationKind: TVTOperationKind); virtual; + procedure DoEnter(); override; + procedure DoExpanded(Node: PVirtualNode); virtual; + function DoExpanding(Node: PVirtualNode): Boolean; virtual; + procedure DoFocusChange(Node: PVirtualNode; Column: TColumnIndex); virtual; + function DoFocusChanging(OldNode, NewNode: PVirtualNode; OldColumn, NewColumn: TColumnIndex): Boolean; virtual; + procedure DoFocusNode(Node: PVirtualNode; Ask: Boolean); virtual; + procedure DoFreeNode(Node: PVirtualNode); virtual; + function DoGetCellContentMargin(Node: PVirtualNode; Column: TColumnIndex; + CellContentMarginType: TVTCellContentMarginType = ccmtAllSides; Canvas: TCanvas = nil): TPoint; virtual; + procedure DoGetCursor(var Cursor: TCursor); virtual; + procedure DoGetHeaderCursor(var Cursor: TVTCursor); virtual; + procedure DoGetHintSize(Node: PVirtualNode; Column: TColumnIndex; var R: + TRect); virtual; + procedure DoGetHintKind(Node: PVirtualNode; Column: TColumnIndex; var Kind: + TVTHintKind); + function DoGetImageIndex(Node: PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex; + var Ghosted: Boolean; var Index: TImageIndex): TCustomImageList; virtual; + procedure DoGetImageText(Node: PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex; var ImageText: string); virtual; + procedure DoGetLineStyle(var Bits: Pointer); virtual; + function DoGetNodeHint(Node: PVirtualNode; Column: TColumnIndex; var LineBreakStyle: TVTTooltipLineBreakStyle): string; virtual; + function DoGetNodeTooltip(Node: PVirtualNode; Column: TColumnIndex; var LineBreakStyle: TVTTooltipLineBreakStyle): string; virtual; + function DoGetNodeExtraWidth(Node: PVirtualNode; Column: TColumnIndex; Canvas: TCanvas = nil): TDimension; virtual; + function DoGetNodeWidth(Node: PVirtualNode; Column: TColumnIndex; Canvas: TCanvas = nil): TDimension; virtual; + function DoGetPopupMenu(Node: PVirtualNode; Column: TColumnIndex; Position: TPoint): TPopupMenu; virtual; + procedure DoGetUserClipboardFormats(var Formats: TFormatEtcArray); virtual; + procedure DoHeaderAddPopupItem(const Column: TColumnIndex; var Cmd: TAddPopupItemType); + procedure DoHeaderClick(const HitInfo: TVTHeaderHitInfo); virtual; + procedure DoHeaderDblClick(const HitInfo: TVTHeaderHitInfo); virtual; + procedure DoHeaderDragged(Column: TColumnIndex; OldPosition: TColumnPosition); virtual; + procedure DoHeaderDraggedOut(Column: TColumnIndex; DropPosition: TPoint); virtual; + function DoHeaderDragging(Column: TColumnIndex): Boolean; virtual; + procedure DoHeaderDraw(Canvas: TCanvas; Column: TVirtualTreeColumn; R: TRect; Hover, Pressed: Boolean; + DropMark: TVTDropMarkMode); virtual; + procedure DoHeaderDrawQueryElements(var PaintInfo: THeaderPaintInfo; var Elements: THeaderPaintElements); virtual; + procedure DoHeaderMouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: TDimension); virtual; + procedure DoHeaderMouseMove(Shift: TShiftState; X, Y: TDimension); virtual; + procedure DoHeaderMouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: TDimension); virtual; + procedure DoHotChange(Old, New: PVirtualNode); virtual; + function DoIncrementalSearch(Node: PVirtualNode; const Text: string): Integer; virtual; + function DoInitChildren(Node: PVirtualNode; var ChildCount: Cardinal): Boolean; virtual; + procedure DoInitNode(Parent, Node: PVirtualNode; var InitStates: TVirtualNodeInitStates); virtual; + function DoKeyAction(var CharCode: Word; var Shift: TShiftState): Boolean; virtual; + procedure DoLoadUserData(Node: PVirtualNode; Stream: TStream); virtual; + procedure DoMeasureItem(TargetCanvas: TCanvas; Node: PVirtualNode; var NodeHeight: TDimension); virtual; + procedure DoMouseEnter(); override; + procedure DoMouseLeave(); override; + procedure DoNodeCopied(Node: PVirtualNode); virtual; + function DoNodeCopying(Node, NewParent: PVirtualNode): Boolean; virtual; + procedure DoNodeClick(const HitInfo: THitInfo); virtual; + procedure DoNodeDblClick(const HitInfo: THitInfo); virtual; + function DoNodeHeightDblClickResize(Node: PVirtualNode; Column: TColumnIndex; Shift: TShiftState; + P: TPoint): Boolean; virtual; + function DoNodeHeightTracking(Node: PVirtualNode; Column: TColumnIndex; Shift: TShiftState; + var TrackPoint: TPoint; P: TPoint): Boolean; virtual; + procedure DoNodeMoved(Node: PVirtualNode); virtual; + function DoNodeMoving(Node, NewParent: PVirtualNode): Boolean; virtual; + function DoPaintBackground(Canvas: TCanvas; R: TRect): Boolean; virtual; + procedure DoPaintDropMark(Canvas: TCanvas; Node: PVirtualNode; R: TRect); virtual; + procedure DoPaintNode(var PaintInfo: TVTPaintInfo); virtual; + procedure DoPaintText(Node: PVirtualNode; const Canvas: TCanvas; Column: TColumnIndex; TextType: TVSTTextType); virtual; + procedure DoPopupMenu(Node: PVirtualNode; Column: TColumnIndex; Position: TPoint); virtual; + procedure DoRemoveFromSelection(Node: PVirtualNode); virtual; + procedure DoReset(Node: PVirtualNode); virtual; + procedure DoSaveUserData(Node: PVirtualNode; Stream: TStream); virtual; + procedure DoScroll(DeltaX, DeltaY: TDimension); virtual; + function DoSetOffsetXY(Value: TPoint; Options: TScrollUpdateOptions; ClipRect: PRect = nil): Boolean; virtual; + procedure DoShowScrollBar(Bar: Integer; Show: Boolean); virtual; + procedure DoStartDrag(var DragObject: TDragObject); override; + procedure DoStartOperation(OperationKind: TVTOperationKind); virtual; + procedure DoStateChange(Enter: TVirtualTreeStates; Leave: TVirtualTreeStates = []); override; + procedure DoStructureChange(Node: PVirtualNode; Reason: TChangeReason); virtual; + procedure DoTimerScroll; virtual; + procedure DoUpdating(State: TVTUpdateState); virtual; + procedure DoColumnHeaderSpanning(Column: TColumnIndex; var Count: Integer); virtual; + function DoValidateCache: Boolean; virtual; + procedure DragAndDrop(AllowedEffects: DWord; const DataObject: TVTDragDataObject; var DragEffect: Integer); virtual; + procedure DragCanceled; override; + function DragDrop(const DataObject: TVTDragDataObject; KeyState: Integer; Pt: TPoint; + var Effect: Integer): HResult; reintroduce; virtual; + function DragEnter(KeyState: Integer; Pt: TPoint; var Effect: Integer): HResult; virtual; + procedure DragFinished; virtual; + procedure DragLeave; virtual; + function DragOver(Source: TObject; KeyState: Integer; DragState: TDragState; Pt: TPoint; + var Effect: Integer): HResult; reintroduce; virtual; + procedure DrawDottedHLine(const PaintInfo: TVTPaintInfo; Left, Right, Top: TDimension); virtual; + procedure DrawDottedVLine(const PaintInfo: TVTPaintInfo; Top, Bottom, Left: TDimension); virtual; + procedure DrawGridHLine(const PaintInfo: TVTPaintInfo; Left, Right, Top: TDimension); virtual; + procedure DrawGridVLine(const PaintInfo: TVTPaintInfo; Top, Bottom, Left: TDimension; pFixedColumn: Boolean = False); virtual; + procedure EndOperation(OperationKind: TVTOperationKind); + procedure EnsureNodeFocused(); virtual; + function FindNodeInSelection(P: PVirtualNode; var Index: Integer; LowBound, HighBound: Integer): Boolean; virtual; + procedure FinishChunkHeader(Stream: TStream; StartPos, EndPos: Integer); virtual; + procedure FontChanged(AFont: TObject); virtual; + function GetBorderDimensions: TSize; virtual; + function GetCheckedCount: Integer; + function GetCheckImage(Node: PVirtualNode; ImgCheckType: TCheckType = ctNone; + ImgCheckState: TCheckState = csUncheckedNormal; ImgEnabled: Boolean = True): Integer; virtual; + function GetColumnClass: TVirtualTreeColumnClass; virtual; + function GetDefaultHintKind: TVTHintKind; virtual; + function GetDoubleBuffered: Boolean; {$if CompilerVersion >= 36}override;{$ifend} + function GetHeaderClass: TVTHeaderClass; virtual; + function GetHintWindowClass: THintWindowClass; virtual; abstract; + procedure GetImageIndex(var Info: TVTPaintInfo; Kind: TVTImageKind; InfoIndex: TVTImageInfoIndex); virtual; + function GetImageSize(Node: PVirtualNode; Kind: TVTImageKind = TVTImageKind.ikNormal; Column: TColumnIndex = 0; IncludePadding: Boolean = True): TSize; virtual; + function GetNodeImageSize(Node: PVirtualNode): TSize; virtual; deprecated 'Use GetImageSize instead'; + function GetMaxRightExtend: TDimension; virtual; + procedure GetNativeClipboardFormats(var Formats: TFormatEtcArray); virtual; + function GetOperationCanceled: Boolean; + function GetOptionsClass: TTreeOptionsClass; virtual; + function GetSelectedCount(): Integer; override; + procedure HandleHotTrack(X, Y: TDimension); virtual; + procedure HandleIncrementalSearch(CharCode: Word); virtual; + procedure HandleMouseDblClick(var Message: TWMMouse; const HitInfo: THitInfo); virtual; + procedure HandleMouseDown(var Message: TWMMouse; var HitInfo: THitInfo); virtual; + procedure HandleMouseUp(var Message: TWMMouse; const HitInfo: THitInfo); virtual; + procedure HandleClickSelection(LastFocused, NewNode: PVirtualNode; Shift: TShiftState; DragPending: Boolean); + function HasImage(Node: PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex): Boolean; virtual; deprecated 'Use GetImageSize instead'; + function HasPopupMenu(Node: PVirtualNode; Column: TColumnIndex; Pos: TPoint): Boolean; virtual; + procedure IncVisibleCount; + procedure InitChildren(Node: PVirtualNode); virtual; + procedure InitNode(Node: PVirtualNode); virtual; + procedure InternalAddFromStream(Stream: TStream; Version: Integer; Node: PVirtualNode); virtual; + function InternalAddToSelection(Node: PVirtualNode; ForceInsert: Boolean): Boolean; overload; + function InternalAddToSelection(const NewItems: TNodeArray; NewLength: Integer; + ForceInsert: Boolean): Boolean; overload; + procedure InternalCacheNode(Node: PVirtualNode); virtual; + procedure InternalClearSelection; virtual; + procedure InternalConnectNode(Node, Destination: PVirtualNode; Target: TBaseVirtualTree; Mode: TVTNodeAttachMode); virtual; + function InternalData(Node: PVirtualNode): Pointer; + procedure InternalDisconnectNode(Node: PVirtualNode; KeepFocus: Boolean; Reindex: Boolean = True; ParentClearing: Boolean = False); virtual; + procedure InternalSetFocusedColumn(const index : TColumnIndex); + procedure InternalRemoveFromSelection(Node: PVirtualNode); virtual; + procedure InterruptValidation(pWaitForValidationTermination: Boolean = True); + procedure InvalidateCache; + function LineWidth(): TDimension; + procedure Loaded; override; + procedure MainColumnChanged; virtual; + procedure MarkCutCopyNodes; override; + procedure MouseMove(Shift: TShiftState; X, Y: TDimension); override; + procedure Notification(AComponent: TComponent; Operation: TOperation); override; + procedure OriginalWMNCPaint(DC: HDC); virtual; + procedure Paint; override; + procedure PaintCheckImage(Canvas: TCanvas; const ImageInfo: TVTImageInfo; Selected: Boolean); virtual; + procedure PaintImage(var PaintInfo: TVTPaintInfo; ImageInfoIndex: TVTImageInfoIndex; DoOverlay: Boolean); virtual; + procedure PaintNodeButton(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; const R: TRect; ButtonX, + ButtonY: TDimension; BidiMode: TBiDiMode); virtual; + procedure PaintTreeLines(const PaintInfo: TVTPaintInfo; IndentSize: TDimension; const LineImage: TLineImage); virtual; + procedure PaintSelectionRectangle(Target: TCanvas; WindowOrgX: TDimension; const SelectionRect: TRect; + TargetRect: TRect); virtual; + procedure PrepareBitmaps(NeedButtons, NeedLines: Boolean); + procedure PrepareCell(var PaintInfo: TVTPaintInfo; WindowOrgX, MaxWidth: TDimension); virtual; + function ReadChunk(Stream: TStream; Version: Integer; Node: PVirtualNode; ChunkType, + ChunkSize: Integer): Boolean; virtual; + procedure ReadNode(Stream: TStream; Version: Integer; Node: PVirtualNode); virtual; + procedure RedirectFontChangeEvent(Canvas: TCanvas); virtual; + procedure RemoveFromSelection(Node: PVirtualNode); virtual; + procedure UpdateNextNodeToSelect(Node: PVirtualNode); virtual; + procedure ResetRangeAnchor; virtual; + procedure RestoreFontChangeEvent(Canvas: TCanvas); virtual; + procedure SelectNodes(StartNode, EndNode: PVirtualNode; AddOnly: Boolean); virtual; + procedure SetChildCount(Node: PVirtualNode; NewChildCount: Cardinal); virtual; + procedure SetFocusedNodeAndColumn(Node: PVirtualNode; Column: TColumnIndex); virtual; + procedure SetRangeX(value: TDimension); + procedure SetWindowTheme(const Theme: string); override; + procedure SetVisibleCount(value : Cardinal); + procedure SkipNode(Stream: TStream); virtual; + procedure StartOperation(OperationKind: TVTOperationKind); + procedure StartWheelPanning(Position: TPoint); virtual; + procedure StopTimer(ID: Integer); + procedure StopWheelPanning; virtual; + procedure StructureChange(Node: PVirtualNode; Reason: TChangeReason); virtual; + function SuggestDropEffect(Source: TObject; Shift: TShiftState; Pt: TPoint; AllowedEffects: Integer): Integer; virtual; + procedure ToggleSelection(StartNode, EndNode: PVirtualNode); virtual; + procedure TrySetFocus(); + procedure UnselectNodes(StartNode, EndNode: PVirtualNode); virtual; + procedure UpdateColumnCheckState(Col: TVirtualTreeColumn); + procedure UpdateDesigner; virtual; + procedure UpdateEditBounds; virtual; + procedure UpdateHeaderRect; virtual; + procedure UpdateStyleElements; override; + procedure ValidateCache; virtual; + procedure ValidateNodeDataSize(var Size: Integer); virtual; + procedure WndProc(var Message: TMessage); override; + procedure WriteChunks(Stream: TStream; Node: PVirtualNode); virtual; + procedure WriteNode(Stream: TStream; Node: PVirtualNode); override; + class procedure RaiseVTError(const Msg: string; HelpContext: Integer); static; + + procedure VclStyleChanged; virtual; + property VclStyleEnabled: Boolean read GetVclStyleEnabled; + property TotalInternalDataSize: Cardinal read FTotalInternalDataSize; + // Mitigator function to use the correct style service for this context (either the style assigned to the control for Delphi > 10.4 or the application style) + function StyleServices(AControl: TControl = nil): TCustomStyleServices; + property Alignment: TAlignment read FAlignment write SetAlignment default taLeftJustify; + property AnimationDuration: Cardinal read FAnimationDuration write SetAnimationDuration default 200; + property AutoExpandDelay: Cardinal read FAutoExpandDelay write FAutoExpandDelay default 1000; + property AutoScrollDelay: Cardinal read FAutoScrollDelay write FAutoScrollDelay default 1000; + property AutoScrollInterval: TAutoScrollInterval read FAutoScrollInterval write FAutoScrollInterval default 1; + property Background: TVTBackground read FBackground write SetBackground; + property BackGroundImageTransparent: Boolean read FBackGroundImageTransparent write SetBackGroundImageTransparent default False; + property BackgroundOffsetX: TDimension index 0 read FBackgroundOffsetX write SetBackgroundOffset stored IsStored_BackgroundOffsetXY; // default 0; + property BackgroundOffsetY: TDimension index 1 read FBackgroundOffsetY write SetBackgroundOffset stored IsStored_BackgroundOffsetXY; // default 0; + property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default TFormBorderStyle.bsSingle; + property BottomSpace: TDimension read FBottomSpace write SetBottomSpace stored IsStored_BottomSpace; //default 0; + property ButtonFillMode: TVTButtonFillMode read FButtonFillMode write SetButtonFillMode default fmTreeColor; + property ButtonStyle: TVTButtonStyle read FButtonStyle write SetButtonStyle default bsRectangle; + property ChangeDelay: Cardinal read FChangeDelay write FChangeDelay default 0; + property CheckImageKind: TCheckImageKind read FCheckImageKind write SetCheckImageKind stored False default ckSystemDefault; // deprecated, see issue #622 + property ClipboardFormats: TClipboardFormats read FClipboardFormats write SetClipboardFormats; + property Colors: TVTColors read FColors write SetColors; + property CustomCheckImages: TCustomImageList read FCustomCheckImages write SetCustomCheckImages; + property DefaultHintKind: TVTHintKind read GetDefaultHintKind; + property DefaultNodeHeight: TDimension read FDefaultNodeHeight write SetDefaultNodeHeight stored IsStored_DefaultNodeHeight; + property DefaultPasteMode: TVTNodeAttachMode read FDefaultPasteMode write FDefaultPasteMode default amAddChildLast; + property DragHeight: Integer read FDragHeight write FDragHeight default 350; + property DragImageKind: TVTDragImageKind read FDragImageKind write FDragImageKind default diComplete; + property DragOperations: TDragOperations read FDragOperations write FDragOperations default [doCopy, doMove]; + property DragSelection: TNodeArray read FDragSelection; + property LastDragEffect: Integer read FLastDragEffect; + property DragType: TVTDragType read FDragType write FDragType default dtOLE; + property DragWidth: Integer read FDragWidth write FDragWidth default 200; + property DrawSelectionMode: TVTDrawSelectionMode read FDrawSelectionMode write FDrawSelectionMode + default smDottedRectangle; + property EditColumn: TColumnIndex read FEditColumn write FEditColumn; + property EditDelay: Cardinal read FEditDelay write FEditDelay default 1000; + property EffectiveOffsetX: TDimension read FEffectiveOffsetX; + property HeaderRect: TRect read FHeaderRect; + property HintMode: TVTHintMode read FHintMode write FHintMode default hmDefault; + property HintData: TVTHintData read FHintData write FHintData; + property HotCursor: TCursor read FHotCursor write FHotCursor default crDefault; + property Images: TCustomImageList read FImages write SetImages; + property IncrementalSearch: TVTIncrementalSearch read FIncrementalSearch write SetSearchOption default isNone; + property IncrementalSearchDirection: TVTSearchDirection read FSearchDirection write FSearchDirection default sdForward; + property IncrementalSearchStart: TVTSearchStart read FSearchStart write FSearchStart default ssFocusedNode; + property IncrementalSearchTimeout: Cardinal read FSearchTimeout write FSearchTimeout default 1000; + property Indent: TDimension read FIndent write SetIndent stored IsStored_Indent; // default 18; + property LastClickPos: TPoint read FLastClickPos write FLastClickPos; + property LastDropMode: TDropMode read FLastDropMode write FLastDropMode; + property LastHintRect: TRect read FLastHintRect write FLastHintRect; + property LineMode: TVTLineMode read FLineMode write SetLineMode default lmNormal; + property LineStyle: TVTLineStyle read FLineStyle write SetLineStyle default lsDotted; + property Margin: TDimension read FMargin write SetMargin stored IsStored_Margin; // default 4; + property NextNodeToSelect: PVirtualNode read FNextNodeToSelect; // Next tree node that we would like to select if the current one gets deleted + property NodeAlignment: TVTNodeAlignment read FNodeAlignment write SetNodeAlignment default naProportional; + property NodeDataSize: Integer read FNodeDataSize write SetNodeDataSize default -1; + property OperationCanceled: Boolean read GetOperationCanceled; + property HotMinusBM: TBitmap read FHotMinusBM; + property HotPlusBM: TBitmap read FHotPlusBM; + property MinusBM: TBitmap read FMinusBM; + property PlusBM: TBitmap read FPlusBM; + property RangeX: TDimension read GetRangeX;// Returns the width of the virtual tree in pixels, (not ClientWidth). If there are columns it returns the total width of all of them; otherwise it returns the maximum of the all the line's data widths. + property RangeY: TNodeHeight read FRangeY; + property RootNodeCount: Cardinal read GetRootNodeCount write SetRootNodeCount default 0; + property ScrollBarOptions: TScrollBarOptions read FScrollBarOptions write SetScrollBarOptions; + property SelectionBlendFactor: Byte read FSelectionBlendFactor write FSelectionBlendFactor default 128; + property SelectionCurveRadius: Cardinal read FSelectionCurveRadius write SetSelectionCurveRadius default 0; + property StateImages: TCustomImageList read FStateImages write SetStateImages; + property TextMargin: TDimension read FTextMargin write SetTextMargin stored IsStored_TextMargin; + property TreeOptions: TCustomVirtualTreeOptions read FOptions write SetOptions; + property WantTabs: Boolean read FWantTabs write FWantTabs default False; + property SyncCheckstateWithSelection[Node: PVirtualNode]: Boolean read GetSyncCheckstateWithSelection; + + property OnAddToSelection: TVTAddToSelectionEvent read FOnAddToSelection write FOnAddToSelection; + property OnAdvancedHeaderDraw: TVTAdvancedHeaderPaintEvent read FOnAdvancedHeaderDraw write FOnAdvancedHeaderDraw; + property OnAfterAutoFitColumn: TVTAfterAutoFitColumnEvent read FOnAfterAutoFitColumn write FOnAfterAutoFitColumn; + property OnAfterAutoFitColumns: TVTAfterAutoFitColumnsEvent read FOnAfterAutoFitColumns write FOnAfterAutoFitColumns; + property OnAfterCellPaint: TVTAfterCellPaintEvent read FOnAfterCellPaint write FOnAfterCellPaint; + property OnAfterColumnExport : TVTColumnExportEvent read FOnAfterColumnExport write FOnAfterColumnExport; + property OnAfterColumnWidthTracking: TVTAfterColumnWidthTrackingEvent read FOnAfterColumnWidthTracking write FOnAfterColumnWidthTracking; + property OnAfterGetMaxColumnWidth: TVTAfterGetMaxColumnWidthEvent read FOnAfterGetMaxColumnWidth write FOnAfterGetMaxColumnWidth; + property OnAfterHeaderExport: TVTTreeExportEvent read FOnAfterHeaderExport write FOnAfterHeaderExport; + property OnAfterHeaderHeightTracking: TVTAfterHeaderHeightTrackingEvent read FOnAfterHeaderHeightTracking + write FOnAfterHeaderHeightTracking; + property OnAfterItemErase: TVTAfterItemEraseEvent read FOnAfterItemErase write FOnAfterItemErase; + property OnAfterItemPaint: TVTAfterItemPaintEvent read FOnAfterItemPaint write FOnAfterItemPaint; + property OnAfterNodeExport: TVTNodeExportEvent read FOnAfterNodeExport write FOnAfterNodeExport; + property OnAfterPaint: TVTPaintEvent read FOnAfterPaint write FOnAfterPaint; + property OnAfterTreeExport: TVTTreeExportEvent read FOnAfterTreeExport write FOnAfterTreeExport; + property OnBeforeAutoFitColumn: TVTBeforeAutoFitColumnEvent read FOnBeforeAutoFitColumn write FOnBeforeAutoFitColumn; + property OnBeforeAutoFitColumns: TVTBeforeAutoFitColumnsEvent read FOnBeforeAutoFitColumns write FOnBeforeAutoFitColumns; + property OnBeforeCellPaint: TVTBeforeCellPaintEvent read FOnBeforeCellPaint write FOnBeforeCellPaint; + property OnBeforeColumnExport: TVTColumnExportEvent read FOnBeforeColumnExport write FOnBeforeColumnExport; + property OnBeforeColumnWidthTracking: TVTBeforeColumnWidthTrackingEvent read FOnBeforeColumnWidthTracking + write FOnBeforeColumnWidthTracking; + property OnBeforeDrawTreeLine: TVTBeforeDrawLineImageEvent read FOnBeforeDrawLineImage write FOnBeforeDrawLineImage; + property OnBeforeGetMaxColumnWidth: TVTBeforeGetMaxColumnWidthEvent read FOnBeforeGetMaxColumnWidth write FOnBeforeGetMaxColumnWidth; + property OnBeforeHeaderExport: TVTTreeExportEvent read FOnBeforeHeaderExport write FOnBeforeHeaderExport; + property OnBeforeHeaderHeightTracking: TVTBeforeHeaderHeightTrackingEvent read FOnBeforeHeaderHeightTracking + write FOnBeforeHeaderHeightTracking; + property OnBeforeItemErase: TVTBeforeItemEraseEvent read FOnBeforeItemErase write FOnBeforeItemErase; + property OnBeforeItemPaint: TVTBeforeItemPaintEvent read FOnBeforeItemPaint write FOnBeforeItemPaint; + property OnBeforeNodeExport: TVTNodeExportEvent read FOnBeforeNodeExport write FOnBeforeNodeExport; + property OnBeforePaint: TVTPaintEvent read FOnBeforePaint write FOnBeforePaint; + property OnBeforeTreeExport: TVTTreeExportEvent read FOnBeforeTreeExport write FOnBeforeTreeExport; + property OnCanSplitterResizeColumn: TVTCanSplitterResizeColumnEvent read FOnCanSplitterResizeColumn write FOnCanSplitterResizeColumn; + property OnCanSplitterResizeHeader: TVTCanSplitterResizeHeaderEvent read FOnCanSplitterResizeHeader write FOnCanSplitterResizeHeader; + property OnCanSplitterResizeNode: TVTCanSplitterResizeNodeEvent read FOnCanSplitterResizeNode write FOnCanSplitterResizeNode; + property OnChange: TVTChangeEvent read FOnChange write FOnChange; + property OnChecked: TVTChangeEvent read FOnChecked write FOnChecked; + property OnChecking: TVTCheckChangingEvent read FOnChecking write FOnChecking; + property OnCollapsed: TVTChangeEvent read FOnCollapsed write FOnCollapsed; + property OnCollapsing: TVTChangingEvent read FOnCollapsing write FOnCollapsing; + property OnColumnChecked: TVTHeaderNotifyEvent read FOnColumnChecked write FOnColumnChecked; + property OnColumnChecking: TVTColumnCheckChangingEvent read FOnColumnChecking write FOnColumnChecking; + property OnColumnClick: TVTColumnClickEvent read FOnColumnClick write FOnColumnClick; + property OnColumnDblClick: TVTColumnDblClickEvent read FOnColumnDblClick write FOnColumnDblClick; + property OnColumnExport : TVTColumnExportEvent read FOnColumnExport write FOnColumnExport; + property OnColumnResize: TVTHeaderNotifyEvent read FOnColumnResize write FOnColumnResize; + property OnColumnVisibilityChanged: TColumnChangeEvent read fOnColumnVisibilityChanged write fOnColumnVisibilityChanged; + property OnColumnWidthDblClickResize: TVTColumnWidthDblClickResizeEvent read FOnColumnWidthDblClickResize + write FOnColumnWidthDblClickResize; + property OnColumnWidthTracking: TVTColumnWidthTrackingEvent read FOnColumnWidthTracking write FOnColumnWidthTracking; + property OnCompareNodes: TVTCompareEvent read FOnCompareNodes write FOnCompareNodes; + property OnCreateDataObject: TVTCreateDataObjectEvent read FOnCreateDataObject write FOnCreateDataObject; + property OnCreateDragManager: TVTCreateDragManagerEvent read FOnCreateDragManager write FOnCreateDragManager; + property OnCreateEditor: TVTCreateEditorEvent read FOnCreateEditor write FOnCreateEditor; + property OnDragAllowed: TVTDragAllowedEvent read FOnDragAllowed write FOnDragAllowed; + property OnDragOver: TVTDragOverEvent read FOnDragOver write FOnDragOver; + property OnDragDrop: TVTDragDropEvent read FOnDragDrop write FOnDragDrop; + property OnDrawHint: TVTDrawHintEvent read FOnDrawHint write FOnDrawHint; + property OnEditCancelled: TVTEditCancelEvent read FOnEditCancelled write FOnEditCancelled; + property OnEditing: TVTEditChangingEvent read FOnEditing write FOnEditing; + property OnEdited: TVTEditChangeEvent read FOnEdited write FOnEdited; + property OnEndOperation: TVTOperationEvent read FOnEndOperation write FOnEndOperation; + property OnExpanded: TVTChangeEvent read FOnExpanded write FOnExpanded; + property OnExpanding: TVTChangingEvent read FOnExpanding write FOnExpanding; + property OnFocusChanged: TVTFocusChangeEvent read FOnFocusChanged write FOnFocusChanged; + property OnFocusChanging: TVTFocusChangingEvent read FOnFocusChanging write FOnFocusChanging; + property OnFreeNode: TVTFreeNodeEvent read FOnFreeNode write FOnFreeNode; + property OnGetCellIsEmpty: TVTGetCellIsEmptyEvent read FOnGetCellIsEmpty write FOnGetCellIsEmpty; + property OnGetCursor: TVTGetCursorEvent read FOnGetCursor write FOnGetCursor; + property OnGetHeaderCursor: TVTGetHeaderCursorEvent read FOnGetHeaderCursor write FOnGetHeaderCursor; + property OnGetHelpContext: TVTHelpContextEvent read FOnGetHelpContext write FOnGetHelpContext; + property OnGetHintSize: TVTGetHintSizeEvent read FOnGetHintSize write + FOnGetHintSize; + property OnGetHintKind: TVTHintKindEvent read FOnGetHintKind write + FOnGetHintKind; + property OnGetImageIndex: TVTGetImageEvent read FOnGetImage write FOnGetImage; + property OnGetImageIndexEx: TVTGetImageExEvent read FOnGetImageEx write FOnGetImageEx; + property OnGetImageText: TVTGetImageTextEvent read FOnGetImageText write FOnGetImageText; + property OnGetLineStyle: TVTGetLineStyleEvent read FOnGetLineStyle write FOnGetLineStyle; + property OnGetNodeDataSize: TVTGetNodeDataSizeEvent read FOnGetNodeDataSize write FOnGetNodeDataSize; + property OnGetPopupMenu: TVTPopupEvent read FOnGetPopupMenu write FOnGetPopupMenu; + property OnGetUserClipboardFormats: TVTGetUserClipboardFormatsEvent read FOnGetUserClipboardFormats + write FOnGetUserClipboardFormats; + property OnHeaderAddPopupItem: TVTHeaderAddPopupItemEvent read FOnHeaderAddPopupItem write FOnHeaderAddPopupItem; + property OnHeaderClick: TVTHeaderClickEvent read FOnHeaderClick write FOnHeaderClick; + property OnHeaderDblClick: TVTHeaderClickEvent read FOnHeaderDblClick write FOnHeaderDblClick; + property OnHeaderDragged: TVTHeaderDraggedEvent read FOnHeaderDragged write FOnHeaderDragged; + property OnHeaderDraggedOut: TVTHeaderDraggedOutEvent read FOnHeaderDraggedOut write FOnHeaderDraggedOut; + property OnHeaderDragging: TVTHeaderDraggingEvent read FOnHeaderDragging write FOnHeaderDragging; + property OnHeaderDraw: TVTHeaderPaintEvent read FOnHeaderDraw write FOnHeaderDraw; + property OnHeaderDrawQueryElements: TVTHeaderPaintQueryElementsEvent read FOnHeaderDrawQueryElements + write FOnHeaderDrawQueryElements; + property OnHeaderHeightTracking: TVTHeaderHeightTrackingEvent read FOnHeaderHeightTracking + write FOnHeaderHeightTracking; + property OnHeaderHeightDblClickResize: TVTHeaderHeightDblClickResizeEvent read FOnHeaderHeightDblClickResize + write FOnHeaderHeightDblClickResize; + property OnHeaderMouseDown: TVTHeaderMouseEvent read FOnHeaderMouseDown write FOnHeaderMouseDown; + property OnHeaderMouseMove: TVTHeaderMouseMoveEvent read FOnHeaderMouseMove write FOnHeaderMouseMove; + property OnHeaderMouseUp: TVTHeaderMouseEvent read FOnHeaderMouseUp write FOnHeaderMouseUp; + property OnHotChange: TVTHotNodeChangeEvent read FOnHotChange write FOnHotChange; + property OnIncrementalSearch: TVTIncrementalSearchEvent read FOnIncrementalSearch write FOnIncrementalSearch; + property OnInitChildren: TVTInitChildrenEvent read FOnInitChildren write FOnInitChildren; + property OnInitNode: TVTInitNodeEvent read FOnInitNode write FOnInitNode; + property OnKeyAction: TVTKeyActionEvent read FOnKeyAction write FOnKeyAction; + property OnLoadNode: TVTSaveNodeEvent read FOnLoadNode write FOnLoadNode; + property OnLoadTree: TVTSaveTreeEvent read FOnLoadTree write FOnLoadTree; + property OnMeasureItem: TVTMeasureItemEvent read FOnMeasureItem write FOnMeasureItem; + property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter; + property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave; + property OnNodeClick: TVTNodeClickEvent read FOnNodeClick write FOnNodeClick; + property OnNodeCopied: TVTNodeCopiedEvent read FOnNodeCopied write FOnNodeCopied; + property OnNodeCopying: TVTNodeCopyingEvent read FOnNodeCopying write FOnNodeCopying; + property OnNodeDblClick: TVTNodeClickEvent read FOnNodeDblClick write FOnNodeDblClick; + property OnNodeExport: TVTNodeExportEvent read FOnNodeExport write FOnNodeExport; + property OnNodeHeightTracking: TVTNodeHeightTrackingEvent read FOnNodeHeightTracking write FOnNodeHeightTracking; + property OnNodeHeightDblClickResize: TVTNodeHeightDblClickResizeEvent read FOnNodeHeightDblClickResize + write FOnNodeHeightDblClickResize; + property OnNodeMoved: TVTNodeMovedEvent read FOnNodeMoved write FOnNodeMoved; + property OnNodeMoving: TVTNodeMovingEvent read FOnNodeMoving write FOnNodeMoving; + property OnPaintBackground: TVTBackgroundPaintEvent read FOnPaintBackground write FOnPaintBackground; + property OnPaintText: TVTPaintText read FOnPaintText write FOnPaintText; + property OnPrepareButtonBitmaps : TVTPrepareButtonImagesEvent read FOnPrepareButtonImages write SetOnPrepareButtonImages; + property OnRemoveFromSelection: TVTRemoveFromSelectionEvent read FOnRemoveFromSelection write FOnRemoveFromSelection; + property OnResetNode: TVTChangeEvent read FOnResetNode write FOnResetNode; + property OnSaveNode: TVTSaveNodeEvent read FOnSaveNode write FOnSaveNode; + property OnSaveTree: TVTSaveTreeEvent read FOnSaveTree write FOnSaveTree; + property OnScroll: TVTScrollEvent read FOnScroll write FOnScroll; + property OnShowScrollBar: TVTScrollBarShowEvent read FOnShowScrollBar write FOnShowScrollBar; + property OnBeforeGetCheckState: TVTBeforeGetCheckStateEvent read FOnBeforeGetCheckState write FOnBeforeGetCheckState; + property OnStartOperation: TVTOperationEvent read FOnStartOperation write FOnStartOperation; + property OnStateChange: TVTStateChangeEvent read FOnStateChange write FOnStateChange; + property OnStructureChange: TVTStructureChangeEvent read FOnStructureChange write FOnStructureChange; + property OnUpdating: TVTUpdatingEvent read FOnUpdating write FOnUpdating; + property OnColumnHeaderSpanning: TVTColumnHeaderSpanningEvent read FOnColumnHeaderSpanning write FOnColumnHeaderSpanning; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + function AbsoluteIndex(Node: PVirtualNode): Cardinal; + function AddChild(Parent: PVirtualNode; UserData: Pointer = nil): PVirtualNode; overload; virtual; + function AddChild(Parent: PVirtualNode; const UserData: IInterface): PVirtualNode; overload; + function AddChild(Parent: PVirtualNode; const UserData: TObject): PVirtualNode; overload; + procedure AddFromStream(Stream: TStream; TargetNode: PVirtualNode); + procedure AddToSelection(Node: PVirtualNode; NotifySynced: Boolean); overload; virtual; + procedure AfterConstruction; override; + procedure Assign(Source: TPersistent); override; + procedure BeginDrag(Immediate: Boolean; Threshold: Integer = -1); + procedure BeginSynch; + procedure BeginUpdate; virtual; + procedure CancelCutOrCopy; + function CancelEditNode: Boolean; + procedure CancelOperation; + function CanEdit(Node: PVirtualNode; Column: TColumnIndex): Boolean; virtual; + function CanFocus: Boolean; override; + procedure Clear; virtual; + procedure ClearChecked; + procedure ClearSelection(); overload; inline; + function CopyTo(Source: PVirtualNode; Tree: TBaseVirtualTree; Mode: TVTNodeAttachMode; + ChildrenOnly: Boolean): PVirtualNode; overload; + function CopyTo(Source, Target: PVirtualNode; Mode: TVTNodeAttachMode; + ChildrenOnly: Boolean): PVirtualNode; overload; + procedure CutToClipboard(); override; + procedure DeleteChildren(Node: PVirtualNode; ResetHasChildren: Boolean = False); + procedure DeleteNode(Node: PVirtualNode; pReIndex: Boolean = True); overload; inline; + procedure DeleteNodes(const pNodes: TNodeArray); + procedure DeleteSelectedNodes; virtual; + function Dragging: Boolean; + procedure DrawGridLine(Canvas: TCanvas; R: TRect); virtual; + function EditNode(Node: PVirtualNode; Column: TColumnIndex): Boolean; virtual; + function EndEditNode: Boolean; + procedure EndSynch; + procedure EndUpdate; virtual; + procedure EnsureNodeSelected(pAfterDeletion: Boolean); virtual; + function ExecuteAction(Action: TBasicAction): Boolean; override; + procedure FinishCutOrCopy; + procedure FlushClipboard; + procedure FullCollapse(Node: PVirtualNode = nil); virtual; + procedure FullExpand(Node: PVirtualNode = nil); virtual; + function GetControlsAlignment: TAlignment; override; + function GetDisplayRect(Node: PVirtualNode; Column: TColumnIndex; TextOnly: Boolean; Unclipped: Boolean = False; + ApplyCellContentMargin: Boolean = False): TRect; + function GetEffectivelyFiltered(Node: PVirtualNode): Boolean; + function GetEffectivelyVisible(Node: PVirtualNode): Boolean; + function GetFirst(ConsiderChildrenAbove: Boolean = False): PVirtualNode; + function GetFirstChecked(State: TCheckState = csCheckedNormal; ConsiderChildrenAbove: Boolean = False): PVirtualNode; + function GetFirstChild(Node: PVirtualNode): PVirtualNode; + function GetFirstChildNoInit(Node: PVirtualNode): PVirtualNode; + function GetFirstCutCopy(ConsiderChildrenAbove: Boolean = False): PVirtualNode; + function GetFirstInitialized(ConsiderChildrenAbove: Boolean = False): PVirtualNode; + function GetFirstLeaf: PVirtualNode; + function GetFirstLevel(NodeLevel: Cardinal): PVirtualNode; + function GetFirstNoInit(ConsiderChildrenAbove: Boolean = False): PVirtualNode; + function GetFirstSelected(ConsiderChildrenAbove: Boolean = False): PVirtualNode; + function GetFirstVisible(Node: PVirtualNode = nil; ConsiderChildrenAbove: Boolean = True; + IncludeFiltered: Boolean = False): PVirtualNode; + function GetFirstVisibleChild(Node: PVirtualNode; IncludeFiltered: Boolean = False): PVirtualNode; + function GetFirstVisibleChildNoInit(Node: PVirtualNode; IncludeFiltered: Boolean = False): PVirtualNode; + function GetFirstVisibleNoInit(Node: PVirtualNode = nil; ConsiderChildrenAbove: Boolean = True; + IncludeFiltered: Boolean = False): PVirtualNode; + procedure GetHitTestInfoAt(X, Y: TDimension; Relative: Boolean; var HitInfo: THitInfo; ShiftState: TShiftState=[]); virtual; + function GetLast(Node: PVirtualNode = nil; ConsiderChildrenAbove: Boolean = False): PVirtualNode; + function GetLastInitialized(Node: PVirtualNode = nil; ConsiderChildrenAbove: Boolean = False): PVirtualNode; + function GetLastNoInit(Node: PVirtualNode = nil; ConsiderChildrenAbove: Boolean = False): PVirtualNode; + function GetLastChild(Node: PVirtualNode): PVirtualNode; + function GetLastChildNoInit(Node: PVirtualNode): PVirtualNode; + function GetLastSelected(ConsiderChildrenAbove: Boolean = False): PVirtualNode; + function GetLastVisible(Node: PVirtualNode = nil; ConsiderChildrenAbove: Boolean = True; + IncludeFiltered: Boolean = False): PVirtualNode; + function GetLastVisibleChild(Node: PVirtualNode; IncludeFiltered: Boolean = False): PVirtualNode; + function GetLastVisibleChildNoInit(Node: PVirtualNode; IncludeFiltered: Boolean = False): PVirtualNode; + function GetLastVisibleNoInit(Node: PVirtualNode = nil; ConsiderChildrenAbove: Boolean = True; + IncludeFiltered: Boolean = False): PVirtualNode; + function GetMaxColumnWidth(Column: TColumnIndex; UseSmartColumnWidth: Boolean = False): TDimension; virtual; + function GetNext(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode; + function GetNextChecked(Node: PVirtualNode; State: TCheckState = csCheckedNormal; + ConsiderChildrenAbove: Boolean = False): PVirtualNode; overload; + function GetNextChecked(Node: PVirtualNode; ConsiderChildrenAbove: Boolean): PVirtualNode; overload; + function GetNextCutCopy(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode; + function GetNextInitialized(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode; + function GetNextLeaf(Node: PVirtualNode): PVirtualNode; + function GetNextLevel(Node: PVirtualNode; NodeLevel: Cardinal): PVirtualNode; + function GetNextNoInit(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode; + function GetNextSelected(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode; + function GetNextSibling(Node: PVirtualNode): PVirtualNode; + function GetNextSiblingNoInit(Node: PVirtualNode): PVirtualNode; + function GetNextVisible(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = True): PVirtualNode; + function GetNextVisibleNoInit(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = True): PVirtualNode; + function GetNextVisibleSibling(Node: PVirtualNode; IncludeFiltered: Boolean = False): PVirtualNode; + function GetNextVisibleSiblingNoInit(Node: PVirtualNode; IncludeFiltered: Boolean = False): PVirtualNode; + function GetNodeAt(const P: TPoint): PVirtualNode; overload; inline; + function GetNodeAt(X, Y: TDimension): PVirtualNode; overload; + function GetNodeAt(X, Y: TDimension; Relative: Boolean; var NodeTop: TDimension): PVirtualNode; overload; + function GetNodeData(Node: PVirtualNode): Pointer; overload; + function GetNodeData(pNode: PVirtualNode): T; overload; inline; + function GetSelectedData(): TArray; overload; + function GetInterfaceFromNodeData(pNode: PVirtualNode): T; overload; inline; + function GetNodeDataAt(pXCoord: Integer; pYCoord: Integer): T; + function GetFirstSelectedNodeData(): T; + function GetNodeLevel(Node: PVirtualNode): Cardinal; + function GetNodeLevelForSelectConstraint(Node: PVirtualNode): integer; + function GetOffset(pElement: TVTElement; pNode: PVirtualNode): TDimension; + procedure GetOffsets(pNode: PVirtualNode; out pOffsets: TVTOffsets; pElement: TVTElement = TVTElement.ofsEndOfClientArea; pColumn: Integer = NoColumn); + function GetPrevious(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode; + function GetPreviousChecked(Node: PVirtualNode; State: TCheckState = csCheckedNormal; + ConsiderChildrenAbove: Boolean = False): PVirtualNode; + function GetPreviousCutCopy(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode; + function GetPreviousInitialized(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode; + function GetPreviousLeaf(Node: PVirtualNode): PVirtualNode; + function GetPreviousLevel(Node: PVirtualNode; NodeLevel: Cardinal): PVirtualNode; + function GetPreviousNoInit(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode; + function GetPreviousSelected(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode; + function GetPreviousSibling(Node: PVirtualNode): PVirtualNode; + function GetPreviousSiblingNoInit(Node: PVirtualNode): PVirtualNode; + function GetPreviousVisible(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = True): PVirtualNode; + function GetPreviousVisibleNoInit(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = True): PVirtualNode; + function GetPreviousVisibleSibling(Node: PVirtualNode; IncludeFiltered: Boolean = False): PVirtualNode; + function GetPreviousVisibleSiblingNoInit(Node: PVirtualNode; IncludeFiltered: Boolean = False): PVirtualNode; + function GetSortedCutCopySet(Resolve: Boolean): TNodeArray; override; + function GetSortedSelection(Resolve: Boolean): TNodeArray; override; + procedure GetTextInfo(Node: PVirtualNode; Column: TColumnIndex; const AFont: TFont; var R: TRect; + var Text: string); virtual; + function GetTreeRect: TRect; + function GetVisibleParent(Node: PVirtualNode; IncludeFiltered: Boolean = False): PVirtualNode; + function GetTopInvisibleParent(Node: PVirtualNode): PVirtualNode; + function HasAsParent(Node, PotentialParent: PVirtualNode): Boolean; + function InsertNode(Node: PVirtualNode; Mode: TVTNodeAttachMode; UserData: Pointer = nil): PVirtualNode; + procedure InvalidateChildren(Node: PVirtualNode; Recursive: Boolean); + procedure InvalidateColumn(Column: TColumnIndex); + function InvalidateNode(Node: PVirtualNode): TRect; virtual; + procedure InvalidateToBottom(Node: PVirtualNode); + procedure InvertSelection(VisibleOnly: Boolean); + function IsEditing: Boolean; + function IsMouseSelecting: Boolean; + function IsEmpty: Boolean; inline; + function IsUpdating(): Boolean; + function IterateSubtree(StartNode: PVirtualNode; Callback: TVTGetNodeProc; Data: Pointer; Filter: TVirtualNodeStates = []; + DoInit: Boolean = False; ChildNodesOnly: Boolean = False): PVirtualNode; + procedure LoadFromFile(const FileName: TFileName); virtual; + procedure LoadFromStream(Stream: TStream); virtual; + procedure MeasureItemHeight(const Canvas: TCanvas; Node: PVirtualNode); virtual; + procedure MoveTo(Source, Target: PVirtualNode; Mode: TVTNodeAttachMode; ChildrenOnly: Boolean); overload; + procedure MoveTo(Node: PVirtualNode; Tree: TBaseVirtualTree; Mode: TVTNodeAttachMode; + ChildrenOnly: Boolean); overload; + procedure PaintTree(TargetCanvas: TCanvas; Window: TRect; Target: TPoint; PaintOptions: TVTInternalPaintOptions; + PixelFormat: TPixelFormat = pfDevice); virtual; + procedure PrepareDragImage(HotSpot: TPoint; const DataObject: TVTDragDataObject); + procedure Print(Printer: TPrinter; PrintHeader: Boolean); + function ProcessDrop(const DataObject: TVTDragDataObject; TargetNode: PVirtualNode; var Effect: Integer; Mode: + TVTNodeAttachMode): Boolean; + function ProcessOLEData(Source: TBaseVirtualTree; const DataObject: IDataObject; TargetNode: PVirtualNode; + Mode: TVTNodeAttachMode; Optimized: Boolean): Boolean; + procedure RepaintNode(Node: PVirtualNode); + procedure ReinitChildren(Node: PVirtualNode; Recursive: Boolean; ForceReinit: Boolean = False); virtual; + procedure InitRecursive(Node: PVirtualNode; Levels: Cardinal = MaxInt; pVisibleOnly: Boolean = True); + procedure ReinitNode(Node: PVirtualNode; Recursive: Boolean; ForceReinit: Boolean = False); virtual; + procedure ResetNode(Node: PVirtualNode); virtual; + procedure SaveToFile(const FileName: TFileName); + procedure SaveToStream(Stream: TStream; Node: PVirtualNode = nil); virtual; + function ScaledPixels(pPixels: TDimension): TDimension; + procedure ScaleNodeHeights(M, D: TDimension); + function ScrollIntoView(Node: PVirtualNode; Center: Boolean; Horizontally: Boolean = False): Boolean; overload; + function ScrollIntoView(Column: TColumnIndex; Center: Boolean; Node: PVirtualNode = nil): Boolean; overload; + procedure SelectAll(VisibleOnly: Boolean); + procedure SetCheckStateForAll(aCheckState: TCheckState; pSelectedOnly: Boolean; pExcludeDisabled: Boolean = True); + procedure SetNodeData(pNode: PVirtualNode; pUserData: Pointer); overload; inline; + procedure SetNodeData(pNode: PVirtualNode; const pUserData: IInterface); overload; inline; + procedure SetNodeData(pNode: PVirtualNode; pUserData: T); overload; + procedure Sort(Node: PVirtualNode; Column: TColumnIndex; Direction: TSortDirection; DoInit: Boolean = True); override; + procedure SortTree(Column: TColumnIndex; Direction: TSortDirection; DoInit: Boolean = True); virtual; + procedure ToggleNode(Node: PVirtualNode); + procedure UpdateHorizontalRange; virtual; + procedure UpdateHorizontalScrollBar(DoRepaint: Boolean); + procedure UpdateRanges; + procedure UpdateScrollBars(DoRepaint: Boolean); virtual; + procedure UpdateVerticalRange; + procedure UpdateVerticalScrollBar(DoRepaint: Boolean); + function UseRightToLeftReading: Boolean; + procedure ValidateChildren(Node: PVirtualNode; Recursive: Boolean); + procedure ValidateNode(Node: PVirtualNode; Recursive: Boolean); + + { Enumerations } + function Nodes(ConsiderChildrenAbove: Boolean = False): TVTVirtualNodeEnumeration; + function CheckedNodes(State: TCheckState = csCheckedNormal; ConsiderChildrenAbove: Boolean = False): TVTVirtualNodeEnumeration; + function ChildNodes(Node: PVirtualNode): TVTVirtualNodeEnumeration; + function CutCopyNodes(ConsiderChildrenAbove: Boolean = False): TVTVirtualNodeEnumeration; + function InitializedNodes(ConsiderChildrenAbove: Boolean = False): TVTVirtualNodeEnumeration; + function LeafNodes: TVTVirtualNodeEnumeration; + function LevelNodes(NodeLevel: Cardinal): TVTVirtualNodeEnumeration; + function NoInitNodes(ConsiderChildrenAbove: Boolean = False): TVTVirtualNodeEnumeration; + function SelectedNodes(ConsiderChildrenAbove: Boolean = False): TVTVirtualNodeEnumeration; + function VisibleNodes(Node: PVirtualNode = nil; ConsiderChildrenAbove: Boolean = True; + IncludeFiltered: Boolean = False): TVTVirtualNodeEnumeration; + function VisibleChildNodes(Node: PVirtualNode; IncludeFiltered: Boolean = False): TVTVirtualNodeEnumeration; + function VisibleChildNoInitNodes(Node: PVirtualNode; IncludeFiltered: Boolean = False): TVTVirtualNodeEnumeration; + function VisibleNoInitNodes(Node: PVirtualNode = nil; ConsiderChildrenAbove: Boolean = True; + IncludeFiltered: Boolean = False): TVTVirtualNodeEnumeration; + property BottomNode: PVirtualNode read GetBottomNode write SetBottomNode; + property CheckedCount: Integer read GetCheckedCount; + property CheckImages: TCustomImageList read FCheckImages; + property CheckState[Node: PVirtualNode]: TCheckState read GetCheckState write SetCheckState; + property CheckType[Node: PVirtualNode]: TCheckType read GetCheckType write SetCheckType; + property ChildCount[Node: PVirtualNode]: Cardinal read GetChildCount write SetChildCount; + property ChildrenInitialized[Node: PVirtualNode]: Boolean read GetChildrenInitialized; + property CutCopyCount: Integer read GetCutCopyCount; + property DragManager: IVTDragManager read GetDragManager; + property DropTargetNode: PVirtualNode read FDropTargetNode write FDropTargetNode; + property EditLink: IVTEditLink read FEditLink; + property EmptyListMessage: string read FEmptyListMessage write SetEmptyListMessage; + property Expanded[Node: PVirtualNode]: Boolean read GetExpanded write SetExpanded; + property FocusedColumn: TColumnIndex read FFocusedColumn write SetFocusedColumn default InvalidColumn; + property FocusedNode: PVirtualNode read FFocusedNode write SetFocusedNode; + property Font; + property FullyVisible[Node: PVirtualNode]: Boolean read GetFullyVisible write SetFullyVisible; + property HasChildren[Node: PVirtualNode]: Boolean read GetHasChildren write SetHasChildren; + property Header: TVTHeader read FHeader write SetHeader; + property HotNode: PVirtualNode read FCurrentHotNode write SetHotNode; + property HotColumn: TColumnIndex read FCurrentHotColumn; + property IsDisabled[Node: PVirtualNode]: Boolean read GetDisabled write SetDisabled; + property IsEffectivelyFiltered[Node: PVirtualNode]: Boolean read GetEffectivelyFiltered; + property IsEffectivelyVisible[Node: PVirtualNode]: Boolean read GetEffectivelyVisible; + property IsFiltered[Node: PVirtualNode]: Boolean read GetFiltered write SetFiltered; + property IsVisible[Node: PVirtualNode]: Boolean read GetVisible write SetVisible; + property MultiLine[Node: PVirtualNode]: Boolean read GetMultiline write SetMultiline; + property NodeHeight[Node: PVirtualNode]: TNodeHeight read GetNodeHeight write SetNodeHeight; + property NodeParent[Node: PVirtualNode]: PVirtualNode read GetNodeParent write SetNodeParent; + property OffsetX: TDimension read FOffsetX write SetOffsetX; + property OffsetXY: TPoint read GetOffsetXY write SetOffsetXY; + property OffsetY: TDimension read FOffsetY write SetOffsetY; + property OperationCount: Cardinal read FOperationCount; + property RootNode: PVirtualNode read FRoot; + property SearchBuffer: string read FSearchBuffer; + property Selected[Node: PVirtualNode]: Boolean read GetSelected write SetSelected; + property SelectionLocked: Boolean read FSelectionLocked write FSelectionLocked; + property TotalCount: Cardinal read GetTotalCount; + property TreeStates: TVirtualTreeStates read FStates write FStates; + property SelectedCount: Integer read FSelectionCount; + property TopNode: PVirtualNode read GetTopNode write SetTopNode; + property VerticalAlignment[Node: PVirtualNode]: Byte read GetVerticalAlignment write SetVerticalAlignment; + property VisibleCount: Cardinal read FVisibleCount; + property VisiblePath[Node: PVirtualNode]: Boolean read GetVisiblePath write SetVisiblePath; + property UpdateCount: Cardinal read FUpdateCount; + property DoubleBuffered: Boolean read GetDoubleBuffered write SetDoubleBuffered default True; + end; + + TVTDrawNodeEvent = procedure(Sender: TBaseVirtualTree; const PaintInfo: TVTPaintInfo) of object; + TVTGetCellContentMarginEvent = procedure(Sender: TBaseVirtualTree; HintCanvas: TCanvas; Node: PVirtualNode; + Column: TColumnIndex; CellContentMarginType: TVTCellContentMarginType; var CellContentMargin: TPoint) of object; + TVTGetNodeWidthEvent = procedure(Sender: TBaseVirtualTree; HintCanvas: TCanvas; Node: PVirtualNode; + Column: TColumnIndex; var NodeWidth: TDimension) of object; + + +// utility routines +function TreeFromNode(Node: PVirtualNode): TBaseVirtualTree; + + +//---------------------------------------------------------------------------------------------------------------------- + +implementation + +uses + Winapi.MMSystem, // for animation timer (does not include further resources) + System.Math, + System.SyncObjs, + System.StrUtils, + Clipbrd, + Vcl.Consts, + Vcl.ExtCtrls, + Vcl.AxCtrls, // TOLEStream + Vcl.StdActns, // for standard action support + Vcl.GraphUtil, // accessibility helper class + VirtualTrees.StyleHooks, + VirtualTrees.WorkerThread, + VirtualTrees.ClipBoard, + VirtualTrees.Utils, + VirtualTrees.DragnDrop; + +resourcestring + // Localizable strings. + SEditLinkIsNil = 'Edit link must not be nil.'; + SWrongMoveError = 'Target node cannot be a child node of the node to be moved.'; + SWrongStreamFormat = 'Unable to load tree structure, the format is wrong.'; + SWrongStreamVersion = 'Unable to load tree structure, the version is unknown.'; + SStreamTooSmall = 'Unable to load tree structure, not enough data available.'; + SCorruptStream1 = 'Stream data corrupt. A node''s anchor chunk is missing.'; + SCorruptStream2 = 'Stream data corrupt. Unexpected data after node''s end position.'; + +const + ClipboardStates = [tsCopyPending, tsCutPending]; + DefaultScrollUpdateFlags = [suoRepaintHeader, suoRepaintScrollBars, suoScrollClientArea, suoUpdateNCArea]; + TreeNodeSize = (SizeOf(TVirtualNode) + (SizeOf(Pointer) - 1)) and not (SizeOf(Pointer) - 1); // used for node allocation and access to internal data + /// Default value of the DefaultText property + MouseButtonDown = [tsLeftButtonDown, tsMiddleButtonDown, tsRightButtonDown]; + + // Do not modify the copyright in any way! Usage of this unit is prohibited without the copyright notice + // in the compiled binary file. + Copyright: string = 'Virtual Treeview © 1999-2021 Mike Lischke, Joachim Marder'; + + + +type + //These allow us access to protected members in the classes + TVirtualTreeColumnsCracker = class(TVirtualTreeColumns); + TVTHeaderCracker = class(TVTHeader); + TVirtualTreeColumnCracker = class(TVirtualTreeColumn); + TBaseVirtualTreeCracker = class(TBaseVirtualTree); + + // streaming support + TMagicID = array[0..5] of WideChar; + + // base information about a node + TBaseChunkBody = packed record + ChildCount: Cardinal; + NodeHeight: TDimension; + States: TVirtualNodeStates; + Align: Byte; + CheckState: TCheckState; + CheckType: TCheckType; + Reserved: Cardinal; + end; + + TBaseChunk = packed record + Header: TChunkHeader; + Body: TBaseChunkBody; + end; + + // Toggle animation modes. + TToggleAnimationMode = ( + tamScrollUp, + tamScrollDown, + tamNoScroll + ); + + // Internally used data for animations. + TToggleAnimationData = record + Window: HWND; // copy of the tree's window handle + DC: TControlCanvas; // the DC of the window to erase uncovered parts + Brush: TBrush; // the brush to be used to erase uncovered parts + R1, + R2: TRect; // animation rectangles + Mode1, + Mode2: TToggleAnimationMode; // animation modes + ScaleFactor: Double; // the factor between the missing step size when doing two animations + MissedSteps: Double; + end; + + +const + MagicID: TMagicID = (#$2045, 'V', 'T', WideChar(VTTreeStreamVersion), ' ', #$2046); + +var + gWatcher: TCriticalSection = nil; + gInitialized: Integer = 0; // >0 if global structures have been initialized; otherwise 0 + NeedToUnitialize: Boolean = False; // True if the OLE subsystem could be initialized successfully. + +//---------------------------------------------------------------------------------------------------------------------- + +function TreeFromNode(Node: PVirtualNode): TBaseVirtualTree; + +// Returns the tree the node currently belongs to or nil if the node is not attached to a tree. + +begin + Assert(Assigned(Node), 'Node must not be nil.'); + + // The root node is marked by having its NextSibling (and PrevSibling) pointing to itself. + while Assigned(Node) and (Node.NextSibling <> Node) do + Node := Node.Parent; + if Assigned(Node) then + Result := TBaseVirtualTree(Node.Parent) + else + Result := nil; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure QuickSort(const TheArray: TNodeArray; L, R: Integer); + +var + I, J: Integer; + P, T: Pointer; + +begin + repeat + I := L; + J := R; + P := TheArray[(L + R) shr 1]; + repeat + while PAnsiChar(TheArray[I]) < PAnsiChar(P) do + System.Inc(I); + while PAnsiChar(TheArray[J]) > PAnsiChar(P) do + System.Dec(J); + if I <= J then + begin + T := TheArray[I]; + TheArray[I] := TheArray[J]; + TheArray[J] := T; + System.Inc(I); + System.Dec(J); + end; + until I > J; + if L < J then + QuickSort(TheArray, L, J); + L := I; + until I >= R; +end; + +//----------------- TVTVirtualNodeEnumerator --------------------------------------------------------------------------- + +function TVTVirtualNodeEnumerator.GetCurrent: PVirtualNode; + +begin + Result := FNode; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTVirtualNodeEnumerator.MoveNext: Boolean; + +begin + Result := FCanMoveNext; + if Result then + begin + FNode := FEnumeration.GetNext(FNode); + Result := FNode <> nil; + FCanMoveNext := Result; + end; +end; + +//----------------- TVTVirtualNodeEnumeration -------------------------------------------------------------------------- + +function TVTVirtualNodeEnumeration.GetEnumerator: TVTVirtualNodeEnumerator; + +begin + Result.FNode := nil; + Result.FCanMoveNext := True; + Result.FEnumeration := @Self; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTVirtualNodeEnumeration.GetNext(Node: PVirtualNode): PVirtualNode; +begin + case FMode of + vneAll: + if Node = nil then + Result := FTree.GetFirst(FConsiderChildrenAbove) + else + Result := FTree.GetNext(Node, FConsiderChildrenAbove); + + vneChecked: + if Node = nil then + Result := FTree.GetFirstChecked(FState, FConsiderChildrenAbove) + else + Result := FTree.GetNextChecked(Node, FState, FConsiderChildrenAbove); + + vneChild: + if Node = nil then + Result := FTree.GetFirstChild(FNode) + else + Result := FTree.GetNextSibling(Node); + + vneCutCopy: + if Node = nil then + Result := FTree.GetFirstCutCopy(FConsiderChildrenAbove) + else + Result := FTree.GetNextCutCopy(Node, FConsiderChildrenAbove); + + vneInitialized: + if Node = nil then + Result := FTree.GetFirstInitialized(FConsiderChildrenAbove) + else + Result := FTree.GetNextInitialized(Node, FConsiderChildrenAbove); + + vneLeaf: + if Node = nil then + Result := FTree.GetFirstLeaf + else + Result := FTree.GetNextLeaf(Node); + + vneLevel: + if Node = nil then + Result := FTree.GetFirstLevel(FNodeLevel) + else + Result := FTree.GetNextLevel(Node, FNodeLevel); + + vneNoInit: + if Node = nil then + Result := FTree.GetFirstNoInit(FConsiderChildrenAbove) + else + Result := FTree.GetNextNoInit(Node, FConsiderChildrenAbove); + + vneSelected: + if Node = nil then + Result := FTree.GetFirstSelected(FConsiderChildrenAbove) + else + Result := FTree.GetNextSelected(Node, FConsiderChildrenAbove); + + vneVisible: + begin + if Node = nil then + begin + Result := FTree.GetFirstVisible(FNode, FConsiderChildrenAbove, FIncludeFiltered); + if FIncludeFiltered or not FTree.IsEffectivelyFiltered[Result] then + Exit; + end; + repeat + Result := FTree.GetNextVisible(Node{, FConsiderChildrenAbove}); + until not Assigned(Result) or FIncludeFiltered or not FTree.IsEffectivelyFiltered[Result]; + end; + + vneVisibleChild: + if Node = nil then + Result := FTree.GetFirstVisibleChild(FNode, FIncludeFiltered) + else + Result := FTree.GetNextVisibleSibling(Node, FIncludeFiltered); + + vneVisibleNoInitChild: + if Node = nil then + Result := FTree.GetFirstVisibleChildNoInit(FNode, FIncludeFiltered) + else + Result := FTree.GetNextVisibleSiblingNoInit(Node, FIncludeFiltered); + + vneVisibleNoInit: + begin + if Node = nil then + begin + Result := FTree.GetFirstVisibleNoInit(FNode, FConsiderChildrenAbove, FIncludeFiltered); + if FIncludeFiltered or not FTree.IsEffectivelyFiltered[Result] then + Exit; + end; + repeat + Result := FTree.GetNextVisibleNoInit(Node, FConsiderChildrenAbove); + until not Assigned(Result) or FIncludeFiltered or not FTree.IsEffectivelyFiltered[Result]; + end; + else + Result := nil; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure InitializeGlobalStructures(); + +// initialization of stuff global to the unit +begin + if (gInitialized > 0) or (AtomicIncrement(gInitialized) <> 1) then // Ensure threadsafe that this code is executed only once + exit; + + // This watcher is used whenever a global structure could be modified by more than one thread. + gWatcher := TCriticalSection.Create(); + + // Initialize OLE subsystem for drag'n drop and clipboard operations. + NeedToUnitialize := not IsLibrary and Succeeded(OleInitialize(nil)); + + // Register the tree reference clipboard format. + CF_VTREFERENCE := RegisterClipboardFormat(CFSTR_VTREFERENCE); + CF_VTHEADERREFERENCE := RegisterClipboardFormat(CFSTR_VTHEADERREFERENCE); + + // Clipboard format registration. + // Native clipboard format. Needs a new identifier and has an average priority to allow other formats to take over. + // This format is supposed to use the IStream storage format but unfortunately this does not work when + // OLEFlushClipboard is used. Hence it is disabled until somebody finds a solution. + CF_VIRTUALTREE := RegisterVTClipboardFormat(CFSTR_VIRTUALTREE, TBaseVirtualTree, 50, TYMED_HGLOBAL {or TYMED_ISTREAM}); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure FinalizeGlobalStructures(); + +var + HintWasEnabled: Boolean; + +begin + if gInitialized = 0 then + exit; // Was not initialized + + if NeedToUnitialize then + OleUninitialize; + + // If VT is used in a package and its special hint window was used then the last instance of this + // window is not freed correctly (bug in the VCL). We explicitely tell the application to free it + // otherwise an AV is raised due to access to an invalid memory area. + if ModuleIsPackage then + begin + HintWasEnabled := Application.ShowHint; + Application.ShowHint := False; + if HintWasEnabled then + Application.ShowHint := True; + end; + gWatcher.Free; + gWatcher := nil; +end; + +//----------------- TClipboardFormats ---------------------------------------------------------------------------------- + +constructor TClipboardFormats.Create(AOwner: TBaseVirtualTree); + +begin + FOwner := AOwner; + Sorted := True; + Duplicates := dupIgnore; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TClipboardFormats.Add(const S: string): Integer; + +// Restrict additions to the clipbard formats to only those which are registered with the owner tree or one of its +// ancestors. + +var + Format: Word; + RegisteredClass: TVirtualTreeClass; + +begin + RegisteredClass := TClipboardFormatList.FindFormat(S, Format); + if Assigned(RegisteredClass) and FOwner.ClassType.InheritsFrom(RegisteredClass) then + Result := inherited Add(S) + else + Result := -1; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TClipboardFormats.Insert(Index: Integer; const S: string); + +// Restrict additions to the clipbard formats to only those which are registered with the owner tree or one of its +// ancestors. + +var + Format: Word; + RegisteredClass: TVirtualTreeClass; + +begin + RegisteredClass := TClipboardFormatList.FindFormat(S, Format); + if Assigned(RegisteredClass) and FOwner.ClassType.InheritsFrom(RegisteredClass) then + inherited Insert(Index, S); +end; + +//----------------- TBaseVirtualTree ----------------------------------------------------------------------------------- + +constructor TBaseVirtualTree.Create(AOwner: TComponent); + +begin + InitializeGlobalStructures(); + + inherited; + + ControlStyle := ControlStyle - [csSetCaption] + [csCaptureMouse, csOpaque, csReplicatable, csDisplayDragImage, + csReflector]; + FTotalInternalDataSize := 0; + FNodeDataSize := -1; + Width := 200; + Height := 100; + TabStop := True; + ParentColor := False; + FDefaultNodeHeight := cInitialDefaultNodeHeight; + FDragOperations := [doCopy, doMove]; + FHotCursor := crDefault; + FScrollBarOptions := TScrollBarOptions.Create(Self); + FFocusedColumn := NoColumn; + FDragImageKind := diComplete; + FLastSelectionLevel := -1; + FSelectionBlendFactor := 128; + + FIndent := 18; + + FPlusBM := TBitmap.Create; + FHotPlusBM := TBitmap.Create; + FMinusBM := TBitmap.Create; + FHotMinusBM := TBitmap.Create; + FSelectedHotPlusBM := TBitmap.Create; + FSelectedHotMinusBM := TBitmap.Create; + + FBorderStyle := TFormBorderStyle.bsSingle; + FButtonStyle := bsRectangle; + FButtonFillMode := fmTreeColor; + + FHeader := GetHeaderClass.Create(Self); + + // we have an own double buffer handling + inherited DoubleBuffered := False; + + FCheckImageKind := ckSystemDefault; + + FImageChangeLink := TChangeLink.Create; + FImageChangeLink.OnChange := ImageListChange; + FStateChangeLink := TChangeLink.Create; + FStateChangeLink.OnChange := ImageListChange; + FCustomCheckChangeLink := TChangeLink.Create; + FCustomCheckChangeLink.OnChange := ImageListChange; + + FAutoExpandDelay := 1000; + FAutoScrollDelay := 1000; + FAutoScrollInterval := 1; + + FBackground := TVTBackground.Create; + // Similar to the Transparent property of TImage, + // this flag is Off by default. + FBackGroundImageTransparent := False; + + FDefaultPasteMode := amAddChildLast; + FMargin := 4; + FTextMargin := cDefaultTextMargin; + FImagesMargin := 2; + FLastDragEffect := DROPEFFECT_NONE; + FDragType := dtOLE; + FDragHeight := 350; + FDragWidth := 200; + + FColors := TVTColors.Create(Self); + FEditDelay := 1000; + + FAnimationDuration := 200; + FSearchTimeout := 1000; + FSearchStart := ssFocusedNode; + FNodeAlignment := naProportional; + FLineStyle := lsDotted; + FIncrementalSearch := isNone; + FClipboardFormats := TClipboardFormats.Create(Self); + FOptions := GetOptionsClass.Create(Self); + + Touch.InteractiveGestures := [igPan, igPressAndTap]; + Touch.InteractiveGestureOptions := [igoPanInertia, + igoPanSingleFingerHorizontal, igoPanSingleFingerVertical, + igoPanGutter, igoParentPassthrough]; + + if not (csDesigning in ComponentState) then //Don't create worker thread in IDE, there is no use for it + TWorkerThread.AddThreadReference(); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +destructor TBaseVirtualTree.Destroy(); +var + WasValidating: Boolean; +begin + WasValidating := (tsValidating in FStates) or (tsValidationNeeded in FStates); // Checking tsValidating is not enough, the TWorkerThread may be stuck in the first call to ChangeTreeStatesAsync() + InterruptValidation(True); + if WasValidating then + begin + // Make sure we dequeue the two synchronized calls from ChangeTreeStatesAsync(), fixes mem leak and AV reported in issue #1001, but is more a workaround. + while CheckSynchronize() and (FPendingSyncProcs>0) do + Sleep(1); + end;// if + FOptions.InternalSetMiscOptions(FOptions.MiscOptions - [toReadOnly]); //SetMiscOptions has side effects + // Make sure there is no reference remaining to the releasing tree. + TWorkerThread.ReleaseThreadReference(IsLibrary); // see issue #1245 + StopWheelPanning; + CancelEditNode; + + // Just in case it didn't happen already release the edit link. + FEditLink := nil; + FClipboardFormats.Free; + // Clear will also free the drag manager if it is still alive. + Clear; + FColors.Free; + FBackground.Free; + + if CheckImageKind = ckSystemDefault then + FCheckImages.Free; + FScrollBarOptions.Free; + + // The window handle must be destroyed before the header is freed because it is needed in WM_NCDESTROY. + if HandleAllocated then + DestroyWindowHandle; + + // Release FDottedBrush in case WM_NCDESTROY hasn't been triggered. + if Assigned(DottedBrushTreeLines) then + begin + DottedBrushTreeLines.Bitmap.Free(); + DottedBrushTreeLines.Free; + DottedBrushTreeLines:= nil; + end; + + FHeader.Free; + FHeader := nil; // Do not use FreeAndNil() before checking issue #497 + FreeAndNil(FOptions); // WM_NCDESTROY accesses FOptions + + FreeMem(FRoot); + + FPlusBM.Free; + FHotPlusBM.Free; + FMinusBM.Free; + FHotMinusBM.Free; + FSelectedHotPlusBM.Free; + FSelectedHotMinusBM.Free; + + // Fixes issue #1002 + Images := nil; + StateImages := nil; + CustomCheckImages := nil; + + FImageChangeLink.Free; + FStateChangeLink.Free; + FCustomCheckChangeLink.Free; + + inherited; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.AdjustTotalCount(Node: PVirtualNode; Value: Integer; Relative: Boolean = False); + +// Sets a node's total count to the given value and recursively adjusts the parent's total count +// (actually, the adjustment is done iteratively to avoid function call overheads). + +var + Difference: Integer; + Run: PVirtualNode; + +begin + if Relative then + Difference := Value + else + Difference := Value - Integer(Node.TotalCount); + if Difference <> 0 then + begin + Run := Node; + // Root node has as parent the tree view. + while Assigned(Run) and (Run <> Pointer(Self)) do + begin + System.Inc(Integer(Run.TotalCount), Difference); + Run := Run.Parent; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.AdjustTotalHeight(Node: PVirtualNode; Value: TNodeHeight; Relative: Boolean = False); + +// Sets a node's total height to the given value and recursively adjusts the parent's total height. + +var + Difference: TNodeHeight; + Run: PVirtualNode; + +begin + if Relative then + Difference := Value + else + Difference := Value - Node.TotalHeight; + if Difference <> 0 then + begin + Run := Node; + repeat + Inc(Run.TotalHeight, Difference); + + // If the node is not visible or the parent node is not expanded or we are already at the top + // then nothing more remains to do. + if not (vsVisible in Run.States) or (Run = FRoot) or + (Run.Parent = nil) or not (vsExpanded in Run.Parent.States) then + Break; + + Run := Run.Parent; + until False; + end; + + UpdateVerticalRange; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.CalculateCacheEntryCount: Integer; + +// Calculates the size of the position cache. + +begin + if FVisibleCount > 1 then + Result := Ceil(FVisibleCount / CacheThreshold) + else + Result := 0; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.CalculateVerticalAlignments(var PaintInfo: TVTPaintInfo; var VButtonAlign: TDimension); + +// Calculates the vertical alignment of the given node and its associated expand/collapse button during +// a node paint cycle depending on the required node alignment style. + +begin + With PaintInfo do begin + // For absolute alignment the calculation is trivial. + case FNodeAlignment of + naFromTop: + VAlign := Node.Align; + naFromBottom: + VAlign := NodeHeight[Node] - Node.Align; + else // naProportional + // Consider button and line alignment, but make sure neither the image nor the button (whichever is taller) + // go out of the entire node height (100% means bottom alignment to the node's bounds). + if (ImageInfo[iiNormal].Index >= 0) or (ImageInfo[iiState].Index >= 0) then + begin + if (ImageInfo[iiNormal].Index >= 0) then + VAlign := ImageInfo[iiNormal].Images.Height + else + VAlign := ImageInfo[iiState].Images.Height; + VAlign := MulDiv((NodeHeight[Node] - VAlign), Node.Align, 100) + Divide(VAlign, 2); + end + else + if toShowButtons in FOptions.PaintOptions then + VAlign := MulDiv((NodeHeight[Node] - FPlusBM.Height), Node.Align, 100) + Divide(FPlusBM.Height, 2) + else + VAlign := MulDiv(Node.NodeHeight, Node.Align, 100); + end; + + VButtonAlign := VAlign - FPlusBM.Height div 2 - (FPlusBM.Height and 1); + end;// With PaintInfo +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.ChangeCheckState(Node: PVirtualNode; Value: TCheckState): Boolean; + +// Sets the check state of the node according to the given value and the node's check type. +// If the check state must be propagated to the parent nodes and one of them refuses to change then +// nothing happens and False is returned, otherwise True. + +var + Run: PVirtualNode; + UncheckedCount, + MixedCheckCount, + CheckedCount: Cardinal; + +begin + Result := not (vsChecking in Node.States); + with Node^ do + if Result then + begin + Include(States, vsChecking); + try + if not (vsInitialized in States) then + InitNode(Node) + else if CheckState = Value then + begin + // Value didn't change and node was initialized, so nothing to do + Result := False; + Exit; + end;//if + + // Indicate that we are going to propagate check states up and down the hierarchy. + if FCheckPropagationCount = 0 then begin + // Do not enter tsCheckPropagation more than once + DoStateChange([tsCheckPropagation]); + BeginUpdate(); + end; + System.Inc(FCheckPropagationCount); + try + // Do actions which are associated with the given check state. + case CheckType of + // Check state change with additional consequences for check states of the children. + ctTriStateCheckBox: + begin + // Propagate state down to the children. + if toAutoTristateTracking in FOptions.AutoOptions then + case Value of + csUncheckedNormal: + if Node.ChildCount > 0 then + begin + Run := FirstChild; + CheckedCount := 0; + MixedCheckCount := 0; + UncheckedCount := 0; + while Assigned(Run) do + begin + if Run.CheckType in [ctCheckBox, ctTriStateCheckBox] then + begin + if not Self.GetCheckState(Run).IsDisabled() then + SetCheckState(Run, csUncheckedNormal); + // Check if the new child state was set successfully, otherwise we have to adjust the + // node's new check state accordingly. + case Self.GetCheckState(Run) of + csCheckedNormal, csCheckedDisabled: + System.Inc(CheckedCount); + csMixedNormal: + System.Inc(MixedCheckCount); + csUncheckedNormal, csUncheckedDisabled: + System.Inc(UncheckedCount); + end; + end; + Run := Run.NextSibling; + end; + + // If there is still a mixed state child node checkbox then this node must be mixed checked too. + if MixedCheckCount > 0 then + Value := csMixedNormal + else + // If nodes are normally checked child nodes then the unchecked count determines what + // to set for the node itself. + if CheckedCount > 0 then + if UncheckedCount > 0 then + Value := csMixedNormal + else + Value := csCheckedNormal; + end; + csCheckedNormal: + if Node.ChildCount > 0 then + begin + Run := FirstChild; + CheckedCount := 0; + MixedCheckCount := 0; + UncheckedCount := 0; + while Assigned(Run) do + begin + if Run.CheckType in [ctCheckBox, ctTriStateCheckBox] then + begin + if not Self.GetCheckState(Run).IsDisabled() then + SetCheckState(Run, csCheckedNormal); + // Check if the new child state was set successfully, otherwise we have to adjust the + // node's new check state accordingly. + case Self.GetCheckState(Run) of + csCheckedNormal: + System.Inc(CheckedCount); + csMixedNormal: + System.Inc(MixedCheckCount); + csUncheckedNormal: + System.Inc(UncheckedCount); + end; + end; + Run := Run.NextSibling; + end; + + // If there is still a mixed state child node checkbox then this node must be mixed checked too. + if MixedCheckCount > 0 then + Value := csMixedNormal + else + // If nodes are normally checked child nodes then the unchecked count determines what + // to set for the node itself. + if CheckedCount > 0 then + if UncheckedCount > 0 then + Value := csMixedNormal + else + Value := csCheckedNormal; + end; + end; + end; + // radio button check state change + ctRadioButton: + if Value = csCheckedNormal then + begin + Value := csCheckedNormal; + // Make sure only this node is checked. + Run := Parent.FirstChild; + while Assigned(Run) do + begin + if Run.CheckType = ctRadioButton then + Run.CheckState := csUncheckedNormal; + Run := Run.NextSibling; + end; + Invalidate; + end; + end; + + if Result then + CheckState := Value // Set new check state + else + CheckState := Self.GetCheckState(Node).GetUnpressed(); // Reset dynamic check state. + + // Propagate state up to the parent. + if not (vsInitialized in Parent.States) then + InitNode(Parent); + if (toAutoTristateTracking in FOptions.AutoOptions) and ([vsChecking, vsDisabled] * Parent.States = []) and + (CheckType in [ctCheckBox, ctTriStateCheckBox]) and (Parent <> FRoot) and + (Parent.CheckType = ctTriStateCheckBox) then + Result := CheckParentCheckState(Node, Value) + else + Result := True; + + InvalidateNode(Node); + finally + System.Dec(FCheckPropagationCount); // WL, 05.02.2004 + if FCheckPropagationCount = 0 then begin + // Allow state change event after all check operations finished + DoStateChange([], [tsCheckPropagation]); + EndUpdate(); + end; + end; + finally + Exclude(States, vsChecking); + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.CollectSelectedNodesLTR(MainColumn: Integer; NodeLeft, NodeRight: TDimension; Alignment: TAlignment; + OldRect, NewRect: TRect): Boolean; + +// Helper routine used when a draw selection takes place. This version handles left-to-right directionality. +// In the process of adding or removing nodes the current selection is modified which requires to pack it after +// the function returns. Another side effect of this method is that a temporary list of nodes will be created +// (see also InternalCacheNode) which must be inserted into the current selection by the caller. + +var + Run, + NextNode: PVirtualNode; + TextRight, + TextLeft, + CurrentTop, + CurrentRight, + NextTop: TDimension; + NextColumn, + Dummy: Integer; + DummyLeft: TDimension; + + MinY, MaxY: TDimension; + LabelOffset: TDimension; + IsInOldRect, + IsInNewRect: Boolean; + NodeWidth: TDimension; + + // quick check variables for various parameters + DoSwitch, + AutoSpan: Boolean; + SimpleSelection: Boolean; + +begin + // A priori nothing changes. + Result := False; + + // Determine minimum and maximum vertical coordinates to limit iteration to. + MinY := Min(OldRect.Top, NewRect.Top); + MaxY := Max(OldRect.Bottom, NewRect.Bottom); + + // Initialize short hand variables to speed up tests below. + DoSwitch := ssCtrl in FDrawSelShiftState; + AutoSpan := FHeader.UseColumns and (toAutoSpanColumns in FOptions.AutoOptions); + SimpleSelection := toSimpleDrawSelection in FOptions.SelectionOptions; + // This is the node to start with. + Run := GetNodeAt(0, MinY, False, CurrentTop); + + if Assigned(Run) then + begin + LabelOffset := GetOffset(TVTElement.ofsLabel, Run); + + // ----- main loop + // Change selection depending on the node's rectangle being in the selection rectangle or not, but + // touch only those nodes which overlap either the old selection rectangle or the new one but not both. + repeat + // Collect offsets for check, normal and state images. + TextLeft := NodeLeft + LabelOffset; + NextTop := CurrentTop + NodeHeight[Run]; + + // Simple selection allows to draw the selection rectangle anywhere. No intersection with node captions is + // required. Only top and bottom bounds of the rectangle matter. + if SimpleSelection or (toFullRowSelect in FOptions.SelectionOptions) then + begin + IsInOldRect := (NextTop > OldRect.Top) and (CurrentTop < OldRect.Bottom) and + ((FHeader.Columns.Count = 0) or (FHeader.Columns.TotalWidth > OldRect.Left)) and ((NodeLeft + LabelOffset) < OldRect.Right); + IsInNewRect := (NextTop > NewRect.Top) and (CurrentTop < NewRect.Bottom) and + ((FHeader.Columns.Count = 0) or (FHeader.Columns.TotalWidth > NewRect.Left)) and ((NodeLeft + LabelOffset) < NewRect.Right); + end + else + begin + // The right column border might be extended if column spanning is enabled. + if AutoSpan then + begin + with FHeader.Columns do + begin + NextColumn := MainColumn; + repeat + Dummy := GetNextVisibleColumn(NextColumn); + if (Dummy = InvalidColumn) or not ColumnIsEmpty(Run, Dummy) or + (Items[Dummy].BidiMode <> bdLeftToRight) then + Break; + NextColumn := Dummy; + until False; + if NextColumn = MainColumn then + CurrentRight := NodeRight + else + GetColumnBounds(NextColumn, DummyLeft, CurrentRight); + end; + end + else + CurrentRight := NodeRight; + // Check if we need the node's width. This is the case when the node is not left aligned or the + // left border of the selection rectangle is to the right of the left node border. + if (TextLeft < OldRect.Left) or (TextLeft < NewRect.Left) or (Alignment <> taLeftJustify) then + begin + NodeWidth := DoGetNodeWidth(Run, MainColumn); + if NodeWidth >= (CurrentRight - TextLeft) then + TextRight := CurrentRight + else + case Alignment of + taLeftJustify: + TextRight := TextLeft + NodeWidth; + taCenter: + begin + TextLeft := Divide(TextLeft + CurrentRight - NodeWidth, 2); + TextRight := TextLeft + NodeWidth; + end; + else + // taRightJustify + TextRight := CurrentRight; + TextLeft := TextRight - NodeWidth; + end; + end + else + TextRight := CurrentRight; + + // Now determine whether we need to change the state. + IsInOldRect := (OldRect.Left <= TextRight) and (OldRect.Right >= TextLeft) and + (NextTop > OldRect.Top) and (CurrentTop < OldRect.Bottom); + IsInNewRect := (NewRect.Left <= TextRight) and (NewRect.Right >= TextLeft) and + (NextTop > NewRect.Top) and (CurrentTop < NewRect.Bottom); + end; + + if IsInOldRect xor IsInNewRect then + begin + Result := True; + if DoSwitch then + begin + if vsSelected in Run.States then + InternalRemoveFromSelection(Run) + else + InternalCacheNode(Run); + end + else + begin + if IsInNewRect then + InternalCacheNode(Run) + else + InternalRemoveFromSelection(Run); + end; + end; + CurrentTop := NextTop; + // Get next visible node and update left node position. + NextNode := GetNextVisibleNoInit(Run, True); + if NextNode = nil then + Break; + Inc(NodeLeft, CountLevelDifference(Run, NextNode) * FIndent); + Run := NextNode; + until CurrentTop > MaxY; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.CollectSelectedNodesRTL(MainColumn: Integer; NodeLeft, NodeRight: TDimension; Alignment: TAlignment; + OldRect, NewRect: TRect): Boolean; + +// Helper routine used when a draw selection takes place. This version handles right-to-left directionality. +// See also comments in CollectSelectedNodesLTR. + +var + Run, + NextNode: PVirtualNode; + NextColumn, + Dummy: Integer; + + DummyRight, + TextRight, + TextLeft, + CheckOffset, + CurrentTop, + CurrentLeft, + NextTop, + NodeWidth, + MinY, MaxY: TDimension; + IsInOldRect, + IsInNewRect: Boolean; + + // quick check variables for various parameters + WithCheck, + WithStateImages, + DoSwitch, + AutoSpan: Boolean; + SimpleSelection: Boolean; + +begin + // A priori nothing changes. + Result := False; + // Switch the alignment to the opposite value in RTL context. + ChangeBiDiModeAlignment(Alignment); + + // Determine minimum and maximum vertical coordinates to limit iteration to. + MinY := Min(OldRect.Top, NewRect.Top); + MaxY := Max(OldRect.Bottom, NewRect.Bottom); + + // Initialize short hand variables to speed up tests below. + DoSwitch := ssCtrl in FDrawSelShiftState; + WithCheck := (toCheckSupport in FOptions.MiscOptions) and Assigned(FCheckImages); + // Don't check the events here as descendant trees might have overriden the DoGetImageIndex method. + WithStateImages := Assigned(FStateImages) or Assigned(OnGetImageIndexEx); + if WithCheck then + CheckOffset := FCheckImages.Width + FImagesMargin + else + CheckOffset := 0; + AutoSpan := FHeader.UseColumns and (toAutoSpanColumns in FOptions.AutoOptions); + SimpleSelection := toSimpleDrawSelection in FOptions.SelectionOptions; + // This is the node to start with. + Run := GetNodeAt(0, MinY, False, CurrentTop); + + if Assigned(Run) then + begin + // The initial minimal left border is determined by the identation level of the node and is dynamically adjusted. + if toShowRoot in FOptions.PaintOptions then + Dec(NodeRight, (TDimension((GetNodeLevel(Run) + 1)) * FIndent) + FMargin) + else + Dec(NodeRight, (TDimension(GetNodeLevel(Run)) * FIndent) + FMargin); + + // ----- main loop + // Change selection depending on the node's rectangle being in the selection rectangle or not, but + // touch only those nodes which overlap either the old selection rectangle or the new one but not both. + repeat + // Collect offsets for check, normal and state images. + TextRight := NodeRight; + if WithCheck and (Run.CheckType <> ctNone) then + Dec(TextRight, CheckOffset); + Dec(TextRight, GetImageSize(Run, ikNormal, MainColumn).cx); + if WithStateImages then + Dec(TextRight, GetImageSize(Run, ikState, MainColumn).cx); + NextTop := CurrentTop + NodeHeight[Run]; + + // Simple selection allows to draw the selection rectangle anywhere. No intersection with node captions is + // required. Only top and bottom bounds of the rectangle matter. + if SimpleSelection then + begin + IsInOldRect := (NextTop > OldRect.Top) and (CurrentTop < OldRect.Bottom); + IsInNewRect := (NextTop > NewRect.Top) and (CurrentTop < NewRect.Bottom); + end + else + begin // The left column border might be extended if column spanning is enabled. + if AutoSpan then + begin + NextColumn := MainColumn; + repeat + Dummy := FHeader.Columns.GetPreviousVisibleColumn(NextColumn); + if (Dummy = InvalidColumn) or not ColumnIsEmpty(Run, Dummy) or + (FHeader.Columns[Dummy].BiDiMode = bdLeftToRight) then + Break; + NextColumn := Dummy; + until False; + if NextColumn = MainColumn then + CurrentLeft := NodeLeft + else + FHeader.Columns.GetColumnBounds(NextColumn, CurrentLeft, DummyRight); + end + else + CurrentLeft := NodeLeft; + // Check if we need the node's width. This is the case when the node is not left aligned (in RTL context this // means actually right aligned) or the right border of the selection rectangle is to the left + // of the right node border. + if (TextRight > OldRect.Right) or (TextRight > NewRect.Right) or (Alignment <> taRightJustify) then + begin + NodeWidth := DoGetNodeWidth(Run, MainColumn); + if NodeWidth >= (TextRight - CurrentLeft) then + TextLeft := CurrentLeft + else + case Alignment of + taLeftJustify: + begin + TextLeft := CurrentLeft; + TextRight := TextLeft + NodeWidth; + end; + taCenter: + begin + TextLeft := Divide(TextRight + CurrentLeft - NodeWidth, 2); + TextRight := TextLeft + NodeWidth; + end; + else + // taRightJustify + TextLeft := TextRight - NodeWidth; + end; + end + else + TextLeft := CurrentLeft; + + // Now determine whether we need to change the state. + IsInOldRect := (OldRect.Right >= TextLeft) and (OldRect.Left <= TextRight) and + (NextTop > OldRect.Top) and (CurrentTop < OldRect.Bottom); + IsInNewRect := (NewRect.Right >= TextLeft) and (NewRect.Left <= TextRight) and + (NextTop > NewRect.Top) and (CurrentTop < NewRect.Bottom); + end; + + if IsInOldRect xor IsInNewRect then + begin + Result := True; + if DoSwitch then + begin + if vsSelected in Run.States then + InternalRemoveFromSelection(Run) + else + InternalCacheNode(Run); + end + else + begin + if IsInNewRect then + InternalCacheNode(Run) + else + InternalRemoveFromSelection(Run); + end; + end; + CurrentTop := NextTop; + // Get next visible node and update left node position. + NextNode := GetNextVisibleNoInit(Run, True); + if NextNode = nil then + Break; + Dec(NodeRight, CountLevelDifference(Run, NextNode) * FIndent); + Run := NextNode; + until CurrentTop > MaxY; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.ClearNodeBackground(const PaintInfo: TVTPaintInfo; UseBackground, Floating: Boolean; + R: TRect); + +// Erases a node's background depending on what the application decides to do. +// UseBackground determines whether or not to use the background picture, while Floating indicates +// that R is given in coordinates of the small node bitmap or the superordinated target bitmap used in PaintTree. + +var + BackColor: TColor; + EraseAction: TItemEraseAction; + Offset: TPoint; + +begin + BackColor := FColors.BackGroundColor; + with PaintInfo do + begin + EraseAction := eaDefault; + + if Floating then + begin + Offset := Point(-FEffectiveOffsetX, R.Top); + OffsetRect(R, 0, -Offset.Y); + end + else + Offset := Point(0, 0); + + DoBeforeItemErase(Canvas, Node, R, BackColor, EraseAction); + + with Canvas do + begin + case EraseAction of + eaNone: + ; + eaColor: + begin + // User has given a new background color. + Brush.Color := BackColor; + FillRect(R); + end; + else // eaDefault + if UseBackground then + begin + if toStaticBackground in TreeOptions.PaintOptions then + StaticBackground(FBackground, Canvas, Offset, R, FColors.BackGroundColor) + else + TileBackground(FBackground, Canvas, Offset, R, FColors.BackGroundColor); + end + else + begin + if (poDrawSelection in PaintOptions) and (toFullRowSelect in FOptions.SelectionOptions) and + (vsSelected in Node.States) and not (toUseBlendedSelection in FOptions.PaintOptions) and not + (tsUseExplorerTheme in FStates) then + begin + if toShowHorzGridLines in FOptions.PaintOptions then + begin + Brush.Color := BackColor; + FillRect(Rect(R.Left, R.Bottom - 1, R.Right, R.Bottom)); + Dec(R.Bottom); + end; + if Focused or (toPopupMode in FOptions.PaintOptions) then + begin + Brush.Color := FColors.FocusedSelectionColor; + Pen.Color := FColors.FocusedSelectionBorderColor; + end + else + begin + Brush.Color := FColors.UnfocusedSelectionColor; + Pen.Color := FColors.UnfocusedSelectionBorderColor; + end; + + RoundRect(R.Left, R.Top, R.Right, R.Bottom, FSelectionCurveRadius, FSelectionCurveRadius); + end + else + begin + Brush.Color := BackColor; + FillRect(R); + end; + end; + end; + DoAfterItemErase(Canvas, Node, R); + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.CompareNodePositions(Node1, Node2: PVirtualNode; ConsiderChildrenAbove: Boolean = False): Integer; + +// Tries hard and smart to quickly determine whether Node1's structural position is before Node2's position. +// If ConsiderChildrenAbove is True, the nodes will be compared with their visual order in mind. +// Returns 0 if Node1 = Node2, < 0 if Node1 is located before Node2 else > 0. + +var + Run1, + Run2: PVirtualNode; + Level1, + Level2: Cardinal; + +begin + Assert(Assigned(Node1) and Assigned(Node2), 'Nodes must never be nil.'); + + if Node1 = Node2 then + Result := 0 + else + begin + if HasAsParent(Node1, Node2) then + Result := IfThen(ConsiderChildrenAbove and (toChildrenAbove in FOptions.PaintOptions), -1, 1) + else + if HasAsParent(Node2, Node1) then + Result := IfThen(ConsiderChildrenAbove and (toChildrenAbove in FOptions.PaintOptions), 1, -1) + else + begin + // the given nodes are neither equal nor are they parents of each other, so go up to FRoot + // for each node and compare the child indices of the top level parents + // Note: neither Node1 nor Node2 can be FRoot at this point as this (a bit strange) circumstance would + // be caught by the previous code. + + // start lookup at the same level + Level1 := GetNodeLevel(Node1); + Level2 := GetNodeLevel(Node2); + Run1 := Node1; + while Level1 > Level2 do + begin + Run1 := Run1.Parent; + System.Dec(Level1); + end; + Run2 := Node2; + while Level2 > Level1 do + begin + Run2 := Run2.Parent; + System.Dec(Level2); + end; + + // now go up until we find a common parent node (loop will safely stop at FRoot if the nodes + // don't share a common parent) + while Run1.Parent <> Run2.Parent do + begin + Run1 := Run1.Parent; + Run2 := Run2.Parent; + end; + Result := Integer(Run1.Index) - Integer(Run2.Index); + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DrawLineImage(const PaintInfo: TVTPaintInfo; X, Y, H, VAlign: TDimension; Style: TVTLineType; + Reverse: Boolean); + +// Draws (depending on Style) one of the 5 line types of the tree. +// If Reverse is True then a right-to-left column is being drawn, hence horizontal lines must be mirrored. +// X and Y describe the left upper corner of the line image rectangle, while H denotes its height (and width). + +var + HalfWidth, + TargetX: TDimension; + +begin + HalfWidth := Divide(FIndent, 2); + if Reverse then + TargetX := 0 + else + TargetX := FIndent - 1; + + with PaintInfo.Canvas do + begin + case Style of + ltBottomRight: + begin + DrawDottedVLine(PaintInfo, Y + VAlign, Y + H, X + HalfWidth); + DrawDottedHLine(PaintInfo, X + HalfWidth, X + TargetX, Y + VAlign); + end; + ltTopDown: + DrawDottedVLine(PaintInfo, Y, Y + H, X + HalfWidth); + ltTopDownRight: + begin + DrawDottedVLine(PaintInfo, Y, Y + H, X + HalfWidth); + DrawDottedHLine(PaintInfo, X + HalfWidth, X + TargetX, Y + VAlign); + end; + ltRight: + DrawDottedHLine(PaintInfo, X + HalfWidth, X + TargetX, Y + VAlign); + ltTopRight: + begin + DrawDottedVLine(PaintInfo, Y, Y + VAlign, X + HalfWidth); + DrawDottedHLine(PaintInfo, X + HalfWidth, X + TargetX, Y + VAlign); + end; + ltLeft: // left can also mean right for RTL context + if Reverse then + DrawDottedVLine(PaintInfo, Y, Y + H, X + FIndent) + else + DrawDottedVLine(PaintInfo, Y, Y + H, X); + ltLeftBottom: + if Reverse then + begin + DrawDottedVLine(PaintInfo, Y, Y + H, X + FIndent); + DrawDottedHLine(PaintInfo, X, X + FIndent, Y + H); + end + else + begin + DrawDottedVLine(PaintInfo, Y, Y + H, X); + DrawDottedHLine(PaintInfo, X, X + FIndent, Y + H); + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.FindInPositionCache(Node: PVirtualNode; var CurrentPos: TNodeHeight): PVirtualNode; + +// Looks through the position cache and returns the node whose top position is the largest one which is smaller or equal +// to the position of the given node. + +var + L, H, I: Integer; + +begin + L := 0; + H := High(FPositionCache); + while L <= H do + begin + I := (L + H) shr 1; + if CompareNodePositions(FPositionCache[I].Node, Node) <= 0 then + L := I + 1 + else + H := I - 1; + end; + if L = 0 then // High(FPositionCache) = -1 + begin + Result := nil; + CurrentPos := 0; + end + else + begin + Result := FPositionCache[L - 1].Node; + CurrentPos := FPositionCache[L - 1].AbsoluteTop; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.FindInPositionCache(Position: TDimension; var CurrentPos: TNodeHeight): PVirtualNode; + +// Looks through the position cache and returns the node whose top position is the largest one which is smaller or equal +// to the given vertical position. +// The returned node does not necessarily occupy the given position but is the nearest one to start +// iterating from to approach the real node for a given position. CurrentPos receives the actual position of the found +// node which is needed for further iteration. + +var + L, H, I: Integer; + +begin + L := 0; + H := High(FPositionCache); + while L <= H do + begin + I := (L + H) shr 1; + if FPositionCache[I].AbsoluteTop <= Position then + L := I + 1 + else + H := I - 1; + end; + if L = 0 then // High(FPositionCache) = -1 + begin + Result := nil; + CurrentPos := 0; + end + else + begin + Result := FPositionCache[L - 1].Node; + CurrentPos := FPositionCache[L - 1].AbsoluteTop; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.FixupTotalCount(Node: PVirtualNode); + +// Called after loading a subtree from stream. The child count in each node is already set but not +// their total count. + +var + Child: PVirtualNode; + +begin + // Initial total count is set to one on node creation. + Child := Node.FirstChild; + while Assigned(Child) do + begin + FixupTotalCount(Child); + System.Inc(Node.TotalCount, Child.TotalCount); + Child := Child.NextSibling; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.FixupTotalHeight(Node: PVirtualNode); + +// Called after loading a subtree from stream. The individual height of each node is set already, +// but their total height needs an adjustment depending on their visibility state. + +var + Child: PVirtualNode; + +begin + // Initial total height is set to the node height on load. + Child := Node.FirstChild; + + if vsExpanded in Node.States then + begin + while Assigned(Child) do + begin + FixupTotalHeight(Child); + if vsVisible in Child.States then + Inc(Node.TotalHeight, Child.TotalHeight); + Child := Child.NextSibling; + end; + end + else + begin + // The node is collapsed, so just update the total height of its child nodes. + while Assigned(Child) do + begin + FixupTotalHeight(Child); + Child := Child.NextSibling; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetBottomNode: PVirtualNode; + +begin + Result := GetNodeAt(0, ClientHeight - 1); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetCheckedCount: Integer; + +var + Node: PVirtualNode; + +begin + Result := 0; + Node := GetFirstChecked; + while Assigned(Node) do + begin + System.Inc(Result); + Node := GetNextChecked(Node); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetCheckState(Node: PVirtualNode): TCheckState; + +begin + if Assigned(FOnBeforeGetCheckState) then + FOnBeforeGetCheckState(Self, Node); + + Result := Node.CheckState; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetCheckType(Node: PVirtualNode): TCheckType; + +begin + Result := Node.CheckType; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetChildCount(Node: PVirtualNode): Cardinal; +begin + if (Node = nil) or (Node = FRoot) then + Exit(FRoot.ChildCount); + if not GetChildrenInitialized(Node) then + InitChildren(Node); + Exit(Node.ChildCount); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetChildrenInitialized(Node: PVirtualNode): Boolean; + +begin + Result := not (vsHasChildren in Node.States) or (Node.ChildCount > 0); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetCutCopyCount: Integer; + +var + Node: PVirtualNode; + +begin + Result := 0; + Node := GetFirstCutCopy; + while Assigned(Node) do + begin + System.Inc(Result); + Node := GetNextCutCopy(Node); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetDisabled(Node: PVirtualNode): Boolean; + +begin + Result := Assigned(Node) and (vsDisabled in Node.States); +end; + +//---------------------------------------------------------------------------------------------------------------------- +// whether the sync of checkbox with selection is allowed for this node +function TBaseVirtualTree.GetSyncCheckstateWithSelection(Node: PVirtualNode): Boolean; + +begin + Result := (toSyncCheckboxesWithSelection in FOptions.SelectionOptions) + and (toCheckSupport in FOptions.MiscOptions) + and Assigned(FCheckImages) + and (Node.CheckType = ctCheckBox); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetDragManager: IVTDragManager; + +// Returns the internal drag manager interface. If this does not yet exist then it is created here. + +begin + if FDragManager = nil then + begin + FDragManager := DoCreateDragManager; + if FDragManager = nil then + FDragManager := TVTDragManager.Create(Self) as IVTDragManager; + end; + + Result := FDragManager; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetExpanded(Node: PVirtualNode): Boolean; + +begin + if Assigned(Node) then + Result := vsExpanded in Node.States + else + Result := False; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetFiltered(Node: PVirtualNode): Boolean; + +begin + Result := vsFiltered in Node.States; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetFullyVisible(Node: PVirtualNode): Boolean; + +// Determines whether the given node has the visibility flag set as well as all its parents are expanded. + +begin + Assert(Assigned(Node), 'Invalid parameter.'); + Result := vsVisible in Node.States; + if Result and (Node <> FRoot) then + Result := VisiblePath[Node]; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetHasChildren(Node: PVirtualNode): Boolean; + +begin + if Assigned(Node) then + Result := vsHasChildren in Node.States + else + Result := vsHasChildren in FRoot.States; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetMultiline(Node: PVirtualNode): Boolean; + +begin + Result := Assigned(Node) and (Node <> FRoot) and (vsMultiline in Node.States); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetNodeHeight(Node: PVirtualNode): TNodeHeight; + +begin + if Assigned(Node) and (Node <> FRoot) then + begin + if (toVariableNodeHeight in FOptions.MiscOptions) and not (vsDeleting in Node.States) then + begin + if not (vsInitialized in Node.States) then + InitNode(Node); + + // Ensure the node's height is determined. + MeasureItemHeight(Self.Canvas, Node); + end; + Result := Node.NodeHeight; + end + else + Result := 0; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetNodeParent(Node: PVirtualNode): PVirtualNode; + +begin + if Assigned(Node) and (Node.Parent <> FRoot) then + Result := Node.Parent + else + Result := nil; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetOffset(pElement: TVTElement; pNode: PVirtualNode): TDimension; +// Calculates the offset of the given element +var + lOffsets: TVTOffsets; +begin + GetOffsets(pNode, lOffsets, pElement); + Exit(lOffsets[pElement]); +end; + +procedure TBaseVirtualTree.GetOffsets(pNode: PVirtualNode; out pOffsets: TVTOffsets; pElement: TVTElement = TVTElement.ofsEndOfClientArea; pColumn: Integer = NoColumn); +// Calculates the offset up to the given element and supplies them in an array. +var + lNodeLevel: Integer; + lNodeIndent: TDimension; +begin + // If no specific column was given, assume the main column + if pColumn = -1 then + pColumn := Header.MainColumn; + + // Left Margin + pOffsets[TVTElement.ofsMargin] := FMargin; + if pElement = ofsMargin then + exit; + + pOffsets[TVTElement.ofsToggleButton] := pOffsets[TVTElement.ofsMargin]; + pOffsets[TVTElement.ofsCheckBox] := pOffsets[TVTElement.ofsMargin]; + if (pColumn = Header.MainColumn) then + begin + if not (toFixedIndent in TreeOptions.PaintOptions) then + begin + // plus Indent + lNodeLevel := GetNodeLevel(pNode); + if toShowRoot in FOptions.PaintOptions then + System.Inc(lNodeLevel); + end + else + lNodeLevel := 1; + lNodeIndent := lNodeLevel * TDimension(FIndent); + // toggle buttons + Inc(pOffsets[TVTElement.ofsToggleButton], lNodeIndent); + Dec(pOffsets[TVTElement.ofsToggleButton], Divide((TDimension(FIndent) - FPlusBM.Width), 2) - 1 + FPlusBM.Width); //Compare PaintTree() relative line 107 + // checkbox + Inc(pOffsets[TVTElement.ofsCheckBox], lNodeIndent); + end;//if MainColumn + + // The area in which the toggle buttons are painted must have exactly the size of one indent level + if pElement <= TVTElement.ofsToggleButton then + exit; + + if (toCheckSupport in TreeOptions.MiscOptions) and Assigned(FCheckImages) and (pNode.CheckType <> ctNone) and (pColumn = Header.MainColumn) then + begin + Inc(pOffsets[TVTElement.ofsCheckBox], fImagesMargin); + + // right of checkbox, left of state image + pOffsets[TVTElement.ofsStateImage] := pOffsets[TVTElement.ofsCheckBox] + FCheckImages.Width + fImagesMargin; + end else + pOffsets[TVTElement.ofsStateImage] := pOffsets[TVTElement.ofsCheckBox]; + if pElement <= TVTElement.ofsStateImage then + exit; + + // right of left image, left of normal image + pOffsets[TVTElement.ofsImage] := pOffsets[TVTElement.ofsStateImage] + GetImageSize(pNode, TVTImageKind.ikState, pColumn).cx; + if pElement = TVTElement.ofsImage then + exit; + + // label + pOffsets[TVTElement.ofsLabel] := pOffsets[TVTElement.ofsImage] + GetImageSize(pNode, TVTImageKind.ikNormal, pColumn).cx; + pOffsets[TVTElement.ofsText] := pOffsets[TVTElement.ofsLabel] + FTextMargin; + Dec(pOffsets[TVTElement.ofsText]); //TODO: This should no longer be necessary once issue #369 is resolved. + if pElement <= TVTElement.ofsText then + exit; + + // End of text + pOffsets[TVTElement.ofsRightOfText] := pOffsets[TVTElement.ofsText] + DoGetNodeWidth(pNode, pColumn) + DoGetNodeExtraWidth(pNode, pColumn); + + // end of client area + pOffsets[TVTElement.ofsEndOfClientArea] := Max(FRangeX, ClientWidth) - FTextMargin; +end; + +function TBaseVirtualTree.GetOffsetXY: TPoint; + +begin + Result := Point(FOffsetX, FOffsetY); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetRangeX: TDimension; +begin + Result := Max(0, FRangeX); +end; + +function TBaseVirtualTree.GetRootNodeCount: Cardinal; + +begin + Result := FRoot.ChildCount; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetSelected(Node: PVirtualNode): Boolean; + +begin + Result := Assigned(Node) and (vsSelected in Node.States); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetSelectedCount: Integer; +begin + Exit(FSelectionCount); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetSelectedData: TArray; +var + lItem: PVirtualNode; + i: Integer; +begin + SetLEngth(Result, Self.SelectedCount); + i := 0; + lItem := Self.GetFirstSelected; + while Assigned(lItem) do + begin + Result[i] := Self.GetNodeData(lItem); + lItem := Self.GetNextSelected(lItem); + System.Inc(i); + end; + SetLength(Result, i); // See issue #927, SelectedCount may not yet be updated. +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetTopNode: PVirtualNode; + +var + Dummy: TDimension; + +begin + Result := GetNodeAt(0, 0, True, Dummy); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetTotalCount(): Cardinal; + +begin + Assert(GetCurrentThreadId = MainThreadId, 'UI controls may only be used in UI thread.'); // FUpdateCount is not thread-safe! So do not write it in non-UI threads. + System.Inc(FUpdateCount); + try + ValidateNode(FRoot, True); + finally + System.Dec(FUpdateCount); + end; + // The root node itself doesn't count as node. + Result := FRoot.TotalCount - 1; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetVclStyleEnabled: Boolean; +begin + Exit(FVclStyleEnabled); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetVerticalAlignment(Node: PVirtualNode): Byte; + +begin + Result := Node.Align; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetVisible(Node: PVirtualNode): Boolean; + +// Determines if the given node is marked as being visible. + +begin + if Node = nil then + Node := FRoot; + + if not (vsInitialized in Node.States) then + InitNode(Node); + + Result := vsVisible in Node.States; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetVisiblePath(Node: PVirtualNode): Boolean; + +// Determines if all parents of the given node are expanded and have the visibility flag set. + +begin + Assert(Assigned(Node) and (Node <> FRoot), 'Invalid parameters.'); + + // FRoot is always expanded + repeat + Node := Node.Parent; + until (Node = FRoot) or not (vsExpanded in Node.States) or not (vsVisible in Node.States); + + Result := Node = FRoot; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.HandleClickSelection(LastFocused, NewNode: PVirtualNode; Shift: TShiftState; + DragPending: Boolean); + +// Handles multi-selection with mouse click. + +begin + // Ctrl key down + if ssCtrl in Shift then + begin + if ssShift in Shift then + begin + SelectNodes(FRangeAnchor, NewNode, True); + end + else + begin + if not (toSiblingSelectConstraint in FOptions.SelectionOptions) then + FRangeAnchor := NewNode; + // Delay selection change if a drag operation is pending. + // Otherwise switch selection state here. + if DragPending then + DoStateChange([tsToggleFocusedSelection]) + else + if vsSelected in NewNode.States then + RemoveFromSelection(NewNode) + else + AddToSelection(NewNode, True); + end; + end + else + // Shift key down + if ssShift in Shift then + begin + if FRangeAnchor = nil then + FRangeAnchor := FRoot.FirstChild; + + // select node range + if Assigned(FRangeAnchor) then + begin + SelectNodes(FRangeAnchor, NewNode, False); + Invalidate; + end; + end + else + begin + // any other case + if not (vsSelected in NewNode.States) then + AddToSelection(NewNode, True); + // assign new reference item + FRangeAnchor := NewNode; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.HandleDrawSelection(X, Y: TDimension): Boolean; + +// Handles multi-selection with a focus rectangle. +// Result is True if something changed in selection. + +var + OldRect, + NewRect: TRect; + MainColumn: TColumnIndex; + MaxValue: Integer; + + // limits of a node and its text + NodeLeft, + NodeRight: TDimension; + + // alignment and directionality + CurrentBidiMode: TBidiMode; + CurrentAlignment: TAlignment; + +begin + Result := False; + + // Selection changes are only done if the user drew a selection rectangle large + // enough to exceed the threshold. + if (FRoot.TotalCount > 1) and (tsDrawSelecting in FStates) then + begin + // Effective handling of node selection is done by using two rectangles stored in FSelectRec. + OldRect := OrderRect(FLastSelRect); + NewRect := OrderRect(FNewSelRect); + ClearTempCache; + + MainColumn := FHeader.MainColumn; + + // Alignment and bidi mode determine where the node text is located within a node. + if MainColumn <= NoColumn then + begin + CurrentBidiMode := BidiMode; + CurrentAlignment := Alignment; + end + else + begin + CurrentBidiMode := FHeader.Columns[MainColumn].BidiMode; + CurrentAlignment := FHeader.Columns[MainColumn].Alignment; + end; + + // Determine initial left border of first node (take column reordering into account). + if FHeader.UseColumns then + begin + // The mouse coordinates don't include any horizontal scrolling hence take this also + // out from the returned column position. + NodeLeft := FHeader.Columns[MainColumn].Left + FEffectiveOffsetX; + NodeRight := NodeLeft + FHeader.Columns[MainColumn].Width; + end + else + begin + NodeLeft := 0 + FEffectiveOffsetX; + NodeRight := NodeLeft + ClientWidth; + end; + if CurrentBidiMode = bdLeftToRight then + Result := CollectSelectedNodesLTR(MainColumn, NodeLeft, NodeRight, CurrentAlignment, OldRect, NewRect) + else + Result := CollectSelectedNodesRTL(MainColumn, NodeLeft, NodeRight, CurrentAlignment, OldRect, NewRect); + end; + + if Result then + begin + // Do some housekeeping if there was a change. + MaxValue := PackArray(FSelection, FSelectionCount); + if MaxValue > -1 then + begin + FSelectionCount := MaxValue; + SetLength(FSelection, FSelectionCount); + end; + if FTempNodeCount > 0 then + begin + if tsClearOnNewSelection in fStates then + begin + DoStateChange([], [tsClearOnNewSelection]); + ClearSelection(False); + end; + + AddToSelection(FTempNodeCache, FTempNodeCount); + ClearTempCache; + end; + + Change(nil); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.HasVisibleNextSibling(Node: PVirtualNode): Boolean; + +// Helper method to determine if the given node has a visible next sibling. This is needed to +// draw correct tree lines. + +begin + // Check if there is a sibling at all. + Result := Assigned(Node.NextSibling); + + if Result then + begin + repeat + Node := Node.NextSibling; + Result := IsEffectivelyVisible[Node]; + until Result or (Node.NextSibling = nil); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.HasVisiblePreviousSibling(Node: PVirtualNode): Boolean; + +// Helper method to determine if the given node has a visible previous sibling. This is needed to +// draw correct tree lines. + +begin + // Check if there is a sibling at all. + Result := Assigned(Node.PrevSibling); + + if Result then + begin + repeat + Node := Node.PrevSibling; + Result := IsEffectivelyVisible[Node]; + until Result or (Node.PrevSibling = nil); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.ImageListChange(Sender: TObject); + +begin + if not (csDestroying in ComponentState) then + Invalidate; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.InitializeFirstColumnValues(var PaintInfo: TVTPaintInfo); + +// Determines initial index, position and cell size of the first visible column. + +begin + PaintInfo.Column := FHeader.Columns.GetFirstVisibleColumn; + with FHeader.Columns, PaintInfo do + begin + if Column > NoColumn then + begin + CellRect.Right := CellRect.Left + Items[Column].Width; + Position := Items[Column].Position; + end + else + Position := 0; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.InitRecursive(Node: PVirtualNode; Levels: Cardinal = MaxInt; pVisibleOnly: Boolean = True); + +// Initializes a node and optionally its children up to a certain level. +// The sepcified number of levels are latrive to the givne Node. + +var + Run: PVirtualNode; +begin + if not Assigned(Node) then + Node := FRoot; + + if (Node <> FRoot) and not (vsInitialized in Node.States) then + InitNode(Node); + if (Levels = 0) or (pVisibleOnly and not (vsExpanded in Node.States)) then + exit; + Run := Node.FirstChild; + + while Assigned(Run) do + begin + InitRecursive(Run, Levels - 1, pVisibleOnly); + Run := Run.NextSibling; + end; +end; + +procedure TBaseVirtualTree.InitRootNode(OldSize: Cardinal = 0); + +// Reinitializes the root node. + +var + NewSize: Cardinal; + +begin + NewSize := TreeNodeSize + FTotalInternalDataSize; + if FRoot = nil then + FRoot := AllocMem(NewSize) + else + begin + ReallocMem(FRoot, NewSize); + ZeroMemory(PByte(FRoot) + OldSize, NewSize - OldSize); + end; + + with FRoot^ do + begin + // Indication that this node is the root node. + SetPrevSibling(FRoot); + SetNextSibling(FRoot); + SetParent(Pointer(Self)); + States := [vsInitialized, vsExpanded, vsHasChildren, vsVisible]; + TotalHeight := FDefaultNodeHeight; + TotalCount := 1; + SetNodeHeight(FDefaultNodeHeight); + Align := 50; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.InterruptValidation(pWaitForValidationTermination: Boolean = True); + +var + WasValidating: Boolean; +begin + DoStateChange([tsStopValidation], [tsUseCache]); + + // Check the worker thread existance. It might already be gone (usually on destruction of the last tree). + WasValidating := (tsValidating in FStates); + TWorkerThread.RemoveTree(Self, pWaitForValidationTermination); + if WasValidating then + InvalidateCache(); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.IsFirstVisibleChild(Parent, Node: PVirtualNode): Boolean; + +// Helper method to check if Node is the same as the first visible child of Parent. + +var + Run: PVirtualNode; + +begin + // Find first visible child. + Run := Parent.FirstChild; + while Assigned(Run) and not IsEffectivelyVisible[Run] do + Run := Run.NextSibling; + + Result := Assigned(Run) and (Run = Node); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.IsLastVisibleChild(Parent, Node: PVirtualNode): Boolean; + +// Helper method to check if Node is the same as the last visible child of Parent. + +var + Run: PVirtualNode; + +begin + // Find last visible child. + Run := Parent.LastChild; + while Assigned(Run) and not IsEffectivelyVisible[Run] do + Run := Run.PrevSibling; + + Result := Assigned(Run) and (Run = Node); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.MakeNewNode: PVirtualNode; + +var + Size: Cardinal; + +begin + Size := TreeNodeSize; + if (csDesigning in ComponentState) and (FNodeDataSize < 0) then + System.Inc(Size, SizeOf(Pointer)) // Fixes #702 + else + begin // Make sure FNodeDataSize is valid. + if FNodeDataSize < 0 then // NodeDataSize may be 0 for descendant controls that use only InternalData. + ValidateNodeDataSize(FNodeDataSize); + + // Take record alignment into account. + System.Inc(Size, FNodeDataSize); + end; + + Result := AllocMem(Size + FTotalInternalDataSize); + + // Fill in some default values. + with Result^ do + begin + TotalCount := 1; + TotalHeight := FDefaultNodeHeight; + SetNodeHeight(FDefaultNodeHeight); + States := [vsVisible]; + Align := 50; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.PackArray({*}const TheArray: TNodeArray; Count: Integer): Integer; assembler; +// *This is an optimization to get as near as possible with the PUREPASCAL code without the +// compiler generating a _DynArrayAddRef call. We still modify the array's content via pointers. + +// Removes all entries from the selection array which are no longer in use. The selection array must be sorted for this +// algo to work. Values which must be removed are marked with bit 0 (LSB) set. This little trick works because memory +// is always allocated DWORD aligned. Since the selection array must be sorted while determining the entries to be +// removed it is much more efficient to increment the entry in question instead of setting it to nil (which would break +// the ordered appearance of the list). +// +// On enter EAX contains self reference, EDX the address to TheArray and ECX Count +// The returned value is the number of remaining entries in the array, so the caller can reallocate (shorten) +// the selection array if needed or -1 if nothing needs to be changed. + +{$IF Defined(CPUX64) or Defined(VT_FMX)} +var + Source, Dest: ^PVirtualNode; + ConstOne: NativeInt; +begin + Source := Pointer(TheArray); + ConstOne := 1; + Result := 0; + // Do the fastest scan possible to find the first entry + while (Count <> 0) and {not Odd(NativeInt(Source^))} (NativeInt(Source^) and ConstOne = 0) do + begin + System.Inc(Result); + System.Inc(Source); + System.Dec(Count); + end; + + if Count <> 0 then + begin + Dest := Source; + repeat + // Skip odd entries + if {not Odd(NativeInt(Source^))} NativeInt(Source^) and ConstOne = 0 then + begin + Dest^ := Source^; + System.Inc(Result); + System.Inc(Dest); + end; + System.Inc(Source); // Point to the next entry + System.Dec(Count); + until Count = 0; + end; +end; +{$else} +asm + PUSH EBX + PUSH EDI + PUSH ESI + MOV ESI, EDX + MOV EDX, -1 + JCXZ @@Finish // Empty list? + INC EDX // init remaining entries counter + MOV EDI, ESI // source and destination point to the list memory + MOV EBX, 1 // use a register instead of immediate operant to check against +@@PreScan: + TEST [ESI], EBX // do the fastest scan possible to find the first entry + // which must be removed + JNZ @@DoMainLoop + INC EDX + ADD ESI, 4 + DEC ECX + JNZ @@PreScan + JMP @@Finish + +@@DoMainLoop: + MOV EDI, ESI +@@MainLoop: + TEST [ESI], EBX // odd entry? + JNE @@Skip // yes, so skip this one + MOVSD // else move the entry to new location + INC EDX // count the moved entries + DEC ECX + JNZ @@MainLoop // do it until all entries are processed + JMP @@Finish + +@@Skip: + ADD ESI, 4 // point to the next entry + DEC ECX + JNZ @@MainLoop // do it until all entries are processed +@@Finish: + MOV EAX, EDX // prepare return value + POP ESI + POP EDI + POP EBX +end; +{$IFEND} + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.PrepareBitmaps(NeedButtons, NeedLines: Boolean); + +// initializes the contents of the internal bitmaps + +const + LineBitsDotted: array [0..8] of Word = ($55, $AA, $55, $AA, $55, $AA, $55, $AA, $55); + LineBitsSolid: array [0..7] of Word = (0, 0, 0, 0, 0, 0, 0, 0); + +var + Bits: Pointer; + Size: TSize; + Theme: HTHEME; + R: TRect; + BitsLinesCount: Word; + + //--------------- local function -------------------------------------------- + + procedure FillBitmap (ABitmap: TBitmap); + begin + with ABitmap, Canvas do + begin + SetSize(Size.cx, Size.cy); + + if (tsUseThemes in FStates) and (toUseExplorerTheme in FOptions.PaintOptions) or VclStyleEnabled then + begin + if (FHeader.MainColumn > NoColumn) then + Brush.Color := FHeader.Columns[FHeader.MainColumn].GetEffectiveColor + else + Brush.Color := FColors.BackGroundColor; + end + else + Brush.Color := clFuchsia; + + Transparent := True; + TransparentColor := Brush.Color; + + FillRect(Rect(0, 0, Width, Height)); + end; + end; + + //--------------- end local function ---------------------------------------- + +const + cMinExpandoHeight = 11; // pixels @100% +begin + if VclStyleEnabled and (seClient in StyleElements) then + begin + if NeedButtons then begin + if StyleServices.GetElementSize(FPlusBM.Canvas.Handle, StyleServices.GetElementDetails(tcbCategoryGlyphClosed), TElementSize.esActual, Size) then + begin + Size.cx := Max(Size.cx, cMinExpandoHeight); // Use min size of 11, see issue #1035 / RSP-33715 + Size.cx := ScaledPixels(Size.cx) // I would have expected that the returned value is dpi-sclaed, but this is not the case in RAD Studio 10.4.1. See issue #984 + end + else + Size.cx := ScaledPixels(cMinExpandoHeight); + Size.cy := Size.cx; + FillBitmap(FPlusBM); + FillBitmap(FHotPlusBM); + FillBitmap(FSelectedHotPlusBM); + FillBitmap(FMinusBM); + FillBitmap(FHotMinusBM); + FillBitmap(FSelectedHotMinusBM); + R := Rect(0,0,Size. cx,Size.cy); + // tcbCategoryGlyphClosed, tcbCategoryGlyphOpened from CategoryButtons + StyleServices.DrawElement(FPlusBM.Canvas.Handle, StyleServices.GetElementDetails(tcbCategoryGlyphClosed), R {$IF CompilerVersion >= 34}, nil, FCurrentPPI{$IFEND}); + StyleServices.DrawElement(FMinusBM.Canvas.Handle, StyleServices.GetElementDetails(tcbCategoryGlyphOpened), R {$IF CompilerVersion >= 34}, nil, FCurrentPPI{$IFEND}); + FHotMinusBM.Canvas.Draw(0, 0, FMinusBM); + FSelectedHotMinusBM.Canvas.Draw(0, 0, FMinusBM); + FHotPlusBM.Canvas.Draw(0, 0, FPlusBM); + FSelectedHotPlusBM.Canvas.Draw(0, 0, FPlusBM); + if Assigned(FOnPrepareButtonImages) then + FOnPrepareButtonImages(Self, FPlusBM, FHotPlusBM, FSelectedHotPlusBM, FMinusBM, FHotMinusBM, FSelectedHotMinusBM, size); + end;//if NeedButtons + end// if VclStyleEnabled + else + begin // No stlye + Size.cx := ScaledPixels(9); + Size.cy := ScaledPixels(9); + if tsUseThemes in FStates then + begin + R := Rect(0, 0, 100, 100); + {$if CompilerVersion >= 33} + if TOSVersion.Check(10) and (TOSVersion.Build >= 15063) then + Theme := OpenThemeDataForDPI(Handle, 'TREEVIEW', Self.FCurrentPPI) + else + Theme := OpenThemeData(Handle, 'TREEVIEW'); + {$else} + Theme := OpenThemeData(Handle, 'TREEVIEW'); + {$ifend} + GetThemePartSize(Theme, FPlusBM.Canvas.Handle, TVP_GLYPH, GLPS_OPENED, @R, TS_TRUE, Size); + end + else + Theme := 0; + + if NeedButtons then + begin + //VCL Themes do not really have ability to provide tree plus/minus images when not using the + //windows theme. The bitmap style designer doesn't have any elements for them, and you + //cannot name any elements you add, which makes it useless. + //To mitigate this, Hook up the OnPrepareButtonImages and draw them yourself. + if Assigned(FOnPrepareButtonImages) then + begin + FillBitmap(FPlusBM); + FillBitmap(FHotPlusBM); + FillBitmap(FSelectedHotPlusBM); + FillBitmap(FMinusBM); + FillBitmap(FHotMinusBM); + FillBitmap(FSelectedHotMinusBM); + FOnPrepareButtonImages(Self, FPlusBM, FHotPlusBM, FSelectedHotPlusBM, FMinusBM, FHotMinusBM, FSelectedHotMinusBM, size); + end + else + begin + with FMinusBM, Canvas do + begin + // box is always of odd size + FillBitmap(FMinusBM); + FillBitmap(FHotMinusBM); + FillBitmap(FSelectedHotMinusBM); + // Weil die selbstgezeichneten Bitmaps sehen im Vcl Style scheiße aus + // Because the self-drawn bitmaps view Vcl Style shit + if Theme = 0 then + begin + if not(tsUseExplorerTheme in FStates) then + begin + if FButtonStyle = bsTriangle then + begin + FMinusBM.Canvas.Brush.Color := clBlack; + FMinusBM.Canvas.Pen.Color := clBlack; + FMinusBM.Canvas.Polygon([Point(0, 2), Point(8, 2), Point(4, 6)]); + end + else + begin + // Button style is rectangular. Now ButtonFillMode determines how to fill the interior. + if FButtonFillMode in [fmTreeColor, fmWindowColor, fmTransparent] then + begin + case FButtonFillMode of + fmTreeColor: + FMinusBM.Canvas.Brush.Color := FColors.BackGroundColor; + fmWindowColor: + FMinusBM.Canvas.Brush.Color := clWindow; + end; + Pen.Color := FColors.TreeLineColor; + Rectangle(0, 0, Width, Height); + Pen.Color := FColors.NodeFontColor; + MoveTo(2, Width div 2); + LineTo(Width - 2, Width div 2); + end + end; + FHotMinusBM.Canvas.Draw(0, 0, FMinusBM); + FSelectedHotMinusBM.Canvas.Draw(0, 0, FMinusBM); + end; + end; + end; + with FPlusBM, Canvas do + begin + FillBitmap(FPlusBM); + FillBitmap(FHotPlusBM); + FillBitmap(FSelectedHotPlusBM); + if Theme = 0 then + begin + if not(tsUseExplorerTheme in FStates) then + begin + if FButtonStyle = bsTriangle then + begin + FPlusBM.Canvas.Brush.Color := clBlack; + FPlusBM.Canvas.Pen.Color := clBlack; + FPlusBM.Canvas.Polygon([Point(2, 0), Point(6, 4), Point(2, 8)]); + end + else + begin + // Button style is rectangular. Now ButtonFillMode determines how to fill the interior. + if FButtonFillMode in [fmTreeColor, fmWindowColor, fmTransparent] then + begin + case FButtonFillMode of + fmTreeColor: + FPlusBM.Canvas.Brush.Color := FColors.BackGroundColor; + fmWindowColor: + FPlusBM.Canvas.Brush.Color := clWindow; + end; + Pen.Color := FColors.TreeLineColor; + Rectangle(0, 0, Width, Height); + Pen.Color := FColors.NodeFontColor; + MoveTo(2, Width div 2); + LineTo(Width - 2, Width div 2); + MoveTo(Width div 2, 2); + LineTo(Width div 2, Width - 2); + end + end; + FHotPlusBM.Canvas.Draw(0, 0, FPlusBM); + FSelectedHotPlusBM.Canvas.Draw(0, 0, FPlusBM); + end; + end; + end; + + + // Overwrite glyph images if theme is active. + if (tsUseThemes in FStates) and (Theme <> 0) then + begin + R := Rect(0, 0, Size.cx, Size.cy); + DrawThemeBackground(Theme, FPlusBM.Canvas.Handle, TVP_GLYPH, GLPS_CLOSED, R, nil); + DrawThemeBackground(Theme, FMinusBM.Canvas.Handle, TVP_GLYPH, GLPS_OPENED, R, nil); + if tsUseExplorerTheme in FStates then + begin + DrawThemeBackground(Theme, FHotPlusBM.Canvas.Handle, TVP_HOTGLYPH, GLPS_CLOSED, R, nil); + DrawThemeBackground(Theme, FSelectedHotPlusBM.Canvas.Handle, TVP_HOTGLYPH, GLPS_CLOSED, R, nil); + DrawThemeBackground(Theme, FHotMinusBM.Canvas.Handle, TVP_HOTGLYPH, GLPS_OPENED, R, nil); + DrawThemeBackground(Theme, FSelectedHotMinusBM.Canvas.Handle, TVP_HOTGLYPH, GLPS_OPENED, R, nil); + end + else + begin + FHotPlusBM.Canvas.Draw(0, 0, FPlusBM); + FSelectedHotPlusBM.Canvas.Draw(0, 0, FPlusBM); + FHotMinusBM.Canvas.Draw(0, 0, FMinusBM); + FSelectedHotMinusBM.Canvas.Draw(0, 0, FMinusBM); + end; + end; + end; + if tsUseThemes in FStates then + CloseThemeData(Theme); + end;// if NeedButtons + end;// else + + if NeedLines then + begin + case FLineStyle of + lsDotted: + begin + Bits := @LineBitsDotted; + BitsLinesCount:= Length(LineBitsDotted); + end; + lsSolid: + begin + Bits := @LineBitsSolid; + BitsLinesCount:= Length(LineBitsSolid); + end; + else // lsCustomStyle + Bits := @LineBitsDotted; + DoGetLineStyle(Bits); + BitsLinesCount:= Length(LineBitsDotted); + end; + DottedBrushTreeLines:= PrepareDottedBrush(DottedBrushTreeLines, Bits, BitsLinesCount); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.SetAlignment(const Value: TAlignment); + +begin + if FAlignment <> Value then + begin + FAlignment := Value; + if not (csLoading in ComponentState) then + Invalidate; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.SetAnimationDuration(const Value: Cardinal); + +begin + FAnimationDuration := Value; + if FAnimationDuration = 0 then + FOptions.AnimationOptions := FOptions.AnimationOptions - [toAnimatedToggle] + else + FOptions.AnimationOptions := FOptions.AnimationOptions + [toAnimatedToggle] +end; + +//---------------------------------------------------------------------------------------------------------------------- +{ New, Support for transparent background: + * Image types: BMP, PNG, GIF, ICO, EMF, TIFF and WMF are automatically identified to support transparent background + * Also detects certain third party image classes registered for PNG, GIF and other image types so that the + transparency related code is used for them. See the code below. + * If some other third party image class is registered that is not detected, + set the flag BackgroundTransparentExternalType explicitly in order to properly do + transparent painting. +} +procedure TBaseVirtualTree.SetBackground(const Value: TVTBackground); + +begin + FBackground.Assign(Value); + Invalidate; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.SetBackGroundImageTransparent(const Value: Boolean); + +begin + if Value <> FBackGroundImageTransparent then + begin + FBackGroundImageTransparent := Value; + Invalidate; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.SetBackgroundOffset(const Index: Integer; const Value: TDimension); + +begin + case Index of + 0: + if FBackgroundOffsetX <> Value then + begin + FBackgroundOffsetX := Value; + Invalidate; + end; + 1: + if FBackgroundOffsetY <> Value then + begin + FBackgroundOffsetY := Value; + Invalidate; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.SetBorderStyle(Value: TBorderStyle); + +begin + if FBorderStyle <> Value then + begin + FBorderStyle := Value; + RecreateWnd; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.SetBottomNode(Node: PVirtualNode); + +var + Run: PVirtualNode; + R: TRect; + +begin + if Assigned(Node) then + begin + // make sure all parents of the node are expanded + Run := Node.Parent; + while Run <> FRoot do + begin + if not (vsExpanded in Run.States) then + ToggleNode(Run); + Run := Run.Parent; + end; + R := GetDisplayRect(Node, FHeader.MainColumn, True); + DoSetOffsetXY(Point(FOffsetX, FOffsetY + ClientHeight - R.Top - NodeHeight[Node]), + [suoRepaintScrollBars, suoUpdateNCArea]); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.SetBottomSpace(const Value: TDimension); + +begin + if FBottomSpace <> Value then + begin + FBottomSpace := Value; + UpdateVerticalScrollBar(True); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.SetButtonFillMode(const Value: TVTButtonFillMode); + +begin + if FButtonFillMode <> Value then + begin + if Value = TVTButtonFillMode.fmShaded then // no longer supported + FButtonFillMode := TVTButtonFillMode.fmTreeColor + else + FButtonFillMode := Value; + if not (csLoading in ComponentState) then + begin + PrepareBitmaps(True, False); + if HandleAllocated then + Invalidate; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.SetButtonStyle(const Value: TVTButtonStyle); + +begin + if FButtonStyle <> Value then + begin + FButtonStyle := Value; + if not (csLoading in ComponentState) then + begin + PrepareBitmaps(True, False); + if HandleAllocated then + Invalidate; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.SetCheckState(Node: PVirtualNode; Value: TCheckState); + +begin + if (Node.CheckState <> Value) and DoChecking(Node, Value) then + DoCheckClick(Node, Value); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.SetCheckStateForAll(aCheckState: TCheckState; pSelectedOnly: Boolean; pExcludeDisabled: Boolean = True); + +// Changes the check state for all or for all seledcted nodes. +// aCheckState: The new check state. +// pSelectedOnly: If passed True, only the selected nodes will bechnaged, if passed False all nodes in the control will be changed. +// pExcludeDisabled: Optiopnal. If passed True (the default value), disabled checkboxes won't be changed, if passed False disabled checkboxes will be altered too. + +var + lItem : PVirtualNode; +begin + With Self do begin + Screen.Cursor := crHourGlass; + BeginUpdate; + try + if pSelectedOnly then + lItem := GetFirstSelected + else + lItem := GetFirst; + //for i:=0 to List.Items.Count-1 do begin + while Assigned(lItem) do begin + if not pExcludeDisabled or not CheckState[lItem].IsDisabled() then + CheckState[lItem] := aCheckState; + if pSelectedOnly then + lItem := GetNextSelected(lItem) + else + lItem := GetNext(lItem); + end;//while + finally + Screen.Cursor := crDefault; + EndUpdate; + end;//try..finally + end;//With +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.SetCheckType(Node: PVirtualNode; Value: TCheckType); + +begin + if (Node.CheckType <> Value) and not (toReadOnly in FOptions.MiscOptions) then + begin + Node.CheckType := Value; + if (Value <> ctTriStateCheckBox) and (Node.CheckState in [csMixedNormal, csMixedPressed]) then + Node.CheckState := csUncheckedNormal;// reset check state if it doesn't fit the new check type + // For check boxes with tri-state check box parents we have to initialize differently. + if (toAutoTriStateTracking in FOptions.AutoOptions) and (Value in [ctCheckBox, ctTriStateCheckBox]) and + (Node.Parent <> FRoot) then + begin + if not (vsInitialized in Node.Parent.States) then + InitNode(Node.Parent); + if (Node.Parent.CheckType = ctTriStateCheckBox) then begin + if (GetCheckState(Node.Parent) in [csUncheckedNormal, csUncheckedDisabled]) then + CheckState[Node] := csUncheckedNormal + else if (GetCheckState(Node.Parent) in [csCheckedNormal, csCheckedDisabled]) then + CheckState[Node] := csCheckedNormal; + end;//if + end;//if + InvalidateNode(Node); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.SetChildCount(Node: PVirtualNode; NewChildCount: Cardinal); + +// Changes a node's child structure to accomodate the new child count. This is used to add or delete +// child nodes to/from the end of the node's child list. To insert or delete a specific node a separate +// routine is used. + +var + Remaining: Cardinal; + Index: Cardinal; + Child: PVirtualNode; + Count: Integer; + NewHeight: TNodeHeight; +begin + if not (toReadOnly in FOptions.MiscOptions) then + begin + if Node = nil then + Node := FRoot; + + Assert(GetCurrentThreadId = MainThreadId, 'UI controls may only be changed in UI thread.'); + if NewChildCount = 0 then + DeleteChildren(Node) + else + begin + // If nothing changed then do nothing. + if NewChildCount <> Node.ChildCount then + begin + InterruptValidation; + + if NewChildCount > Node.ChildCount then + begin + Remaining := NewChildCount - Node.ChildCount; + Count := Remaining; + NewHeight := Node.TotalHeight; + + // New nodes to add. + if Assigned(Node.LastChild) then + Index := Node.LastChild.Index + 1 + else + begin + Index := 0; + Include(Node.States, vsHasChildren); + end; + Node.States := Node.States - [vsAllChildrenHidden, vsHeightMeasured]; + if (vsExpanded in Node.States) and FullyVisible[Node] then + System.Inc(FVisibleCount, Count); // Do this before a possible init of the sub-nodes in DoMeasureItem() + + // New nodes are by default always visible, so we don't need to check the visibility. + while Remaining > 0 do + begin + Child := MakeNewNode; + Child.SetIndex(Index); + Child.SetPrevSibling(Node.LastChild); + if Assigned(Node.LastChild) then + Node.LastChild.SetNextSibling(Child); + Child.SetParent(Node); + Node.SetLastChild(Child); + if Node.FirstChild = nil then + Node.SetFirstChild(Child); + System.Dec(Remaining); + System.Inc(Index); + + if (toVariableNodeHeight in FOptions.MiscOptions) then + GetNodeHeight(Child); + Inc(NewHeight, Child.TotalHeight); + end; + + if vsExpanded in Node.States then + AdjustTotalHeight(Node, NewHeight, False); + + AdjustTotalCount(Node, Count, True); + Node.SetChildCount(NewChildCount); + if (FUpdateCount = 0) and (toAutoSort in FOptions.AutoOptions) and (FHeader.SortColumn > InvalidColumn) then + Sort(Node, FHeader.SortColumn, FHeader.SortDirection, True); + + InvalidateCache; + end//if NewChildCount > Node.ChildCount + else + begin + // Nodes have to be deleted. + Remaining := Node.ChildCount - NewChildCount; + while Remaining > 0 do + begin + DeleteNode(Node.LastChild); + System.Dec(Remaining); + end; + end; + + if FUpdateCount = 0 then + begin + ValidateCache; + UpdateScrollBars(True); + Invalidate; + end; + + if Node = FRoot then + StructureChange(nil, crChildAdded) + else + StructureChange(Node, crChildAdded); + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.SetClipboardFormats(const Value: TClipboardFormats); + +var + I: Integer; + +begin + // Add string by string instead doing an Assign or AddStrings because the list may return -1 for + // invalid entries which cause trouble for the standard implementation. + FClipboardFormats.Clear; + for I := 0 to Value.Count - 1 do + FClipboardFormats.Add(Value[I]); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.SetColors(const Value: TVTColors); + +begin + FColors.Assign(Value); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.SetCheckImageKind(Value: TCheckImageKind); +begin + if (Value < Low(Value)) or (Value> High(Value)) then + Value := ckSystemDefault; + // property is deprecated. See issue #622 + if FCheckImageKind <> Value then + begin + if FCheckImageKind = ckSystemDefault then + FreeAndNil(FCheckImages); + FCheckImageKind := Value; + if Value = ckCustom then + FCheckImages := FCustomCheckImages + else if HandleAllocated then + FCheckImages := CreateSystemImageSet(); + if HandleAllocated and (FUpdateCount = 0) and not (csLoading in ComponentState) then + InvalidateRect(nil, False); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.SetCustomCheckImages(const Value: TCustomImageList); + +begin + if FCustomCheckImages <> Value then + begin + if Assigned(FCustomCheckImages) then + begin + FCustomCheckImages.UnRegisterChanges(FCustomCheckChangeLink); + FCustomCheckImages.RemoveFreeNotification(Self); + // Reset the internal check image list reference too, if necessary. + if FCheckImages = FCustomCheckImages then + FCheckImages := nil; + end; + FCustomCheckImages := Value; + if Assigned(FCustomCheckImages) then + begin + // If custom check images are assigned, we switch the property CheckImageKind to ckCustom so that they are actually used + CheckImageKind := ckCustom; + FCustomCheckImages.RegisterChanges(FCustomCheckChangeLink); + FCustomCheckImages.FreeNotification(Self); + end + else + CheckImageKind := ckSystemDefault; + if not (csLoading in ComponentState) then + Invalidate; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.SetDefaultNodeHeight(Value: TDimension); + +begin + if Value = 0 then + Value := cInitialDefaultNodeHeight; + if FDefaultNodeHeight <> Value then + begin + Inc(FRoot.TotalHeight, Value - FDefaultNodeHeight); + FRoot.SetNodeHeight(FRoot.NodeHeight + Value - FDefaultNodeHeight); + FDefaultNodeHeight := Value; + InvalidateCache; + if (FUpdateCount = 0) and HandleAllocated and not (csLoading in ComponentState) then + begin + ValidateCache; + UpdateScrollBars(True); + ScrollIntoView(FFocusedNode, toCenterScrollIntoView in FOptions.SelectionOptions, True); + Invalidate; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.SetDisabled(Node: PVirtualNode; Value: Boolean); + +begin + if Assigned(Node) and (Value xor (vsDisabled in Node.States)) then + begin + if Value then + Include(Node.States, vsDisabled) + else + Exclude(Node.States, vsDisabled); + + if FUpdateCount = 0 then + InvalidateNode(Node); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.SetDoubleBuffered(const Value: Boolean); +begin + // empty by intention, we do our own buffering +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetDoubleBuffered: Boolean; +begin + Result := True; // we do our own buffering +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.SetEmptyListMessage(const Value: string); + +begin + if Value <> EmptyListMessage then + begin + FEmptyListMessage := Value; + Invalidate; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.SetExpanded(Node: PVirtualNode; Value: Boolean); + +begin + if Assigned(Node) and (Node <> FRoot) and (Value xor (vsExpanded in Node.States)) then + ToggleNode(Node); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.SetFocusedColumn(Value: TColumnIndex); + +begin + if (FFocusedColumn <> Value) and + DoFocusChanging(FFocusedNode, FFocusedNode, FFocusedColumn, Value) then + begin + CancelEditNode; + InvalidateColumn(FFocusedColumn); + InvalidateColumn(Value); + FFocusedColumn := Value; + if Assigned(FFocusedNode) and not (toDisableAutoscrollOnFocus in FOptions.AutoOptions) then + begin + if ScrollIntoView(FFocusedNode, toCenterScrollIntoView in FOptions.SelectionOptions, True) then + InvalidateNode(FFocusedNode); + end; + + if Assigned(FDropTargetNode) then + InvalidateNode(FDropTargetNode); + + DoFocusChange(FFocusedNode, FFocusedColumn); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.SetFocusedNode(Value: PVirtualNode); + +var + WasDifferent: Boolean; + +begin + WasDifferent := Value <> FFocusedNode; + DoFocusNode(Value, True); + // Do change event only if there was actually a change. + if WasDifferent and (FFocusedNode = Value) then + DoFocusChange(FFocusedNode, FFocusedColumn); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.SetFullyVisible(Node: PVirtualNode; Value: Boolean); + +// This method ensures that a node is visible and all its parent nodes are expanded and also visible +// if Value is True. Otherwise the visibility flag of the node is reset but the expand state +// of the parent nodes stays untouched. + +begin + Assert(Assigned(Node) and (Node <> FRoot), 'Invalid parameter'); + + IsVisible[Node] := Value; + if Value then + begin + repeat + Node := Node.Parent; + if Node = FRoot then + Break; + if not (vsExpanded in Node.States) then + ToggleNode(Node); + if not (vsVisible in Node.States) then + IsVisible[Node] := True; + until False; + end; + ScrollIntoView(Node, False); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.SetHasChildren(Node: PVirtualNode; Value: Boolean); + +begin + if Assigned(Node) and not (toReadOnly in FOptions.MiscOptions) then + begin + if Value then + Include(Node.States, vsHasChildren) + else + begin + Exclude(Node.States, vsHasChildren); + DeleteChildren(Node); + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.SetHeader(const Value: TVTHeader); + +begin + FHeader.Assign(Value); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.SetHotNode(Value: PVirtualNode); + +begin + FCurrentHotNode := Value; +end; + + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.SetFiltered(Node: PVirtualNode; Value: Boolean); + +// Sets the 'filtered' flag of the given node according to Value and updates all dependent states. + +var + NeedUpdate: Boolean; + +begin + Assert(Assigned(Node) and (Node <> FRoot), 'Invalid parameter.'); + + // Initialize the node if necessary as this might change the filtered state. + if not (vsInitialized in Node.States) then + InitNode(Node); + + if Value <> (vsFiltered in Node.States) then + begin + InterruptValidation; + NeedUpdate := False; + if Value then + begin + Include(Node.States, vsFiltered); + if not (toShowFilteredNodes in FOptions.PaintOptions) then + begin + if (vsInitializing in Node.States) and not (vsHasChildren in Node.States) then + AdjustTotalHeight(Node, 0, False) + else + AdjustTotalHeight(Node, -NodeHeight[Node], True); + if FullyVisible[Node] then + begin + System.Dec(FVisibleCount); + NeedUpdate := True; + end; + if FocusedNode = Node then + FocusedNode := nil; + end; + + if FUpdateCount = 0 then + DetermineHiddenChildrenFlag(Node.Parent) + else + Include(FStates, tsUpdateHiddenChildrenNeeded); + end + else + begin + Exclude(Node.States, vsFiltered); + if not (toShowFilteredNodes in FOptions.PaintOptions) then + begin + AdjustTotalHeight(Node, NodeHeight[Node], True); + if FullyVisible[Node] then + begin + System.Inc(FVisibleCount); + NeedUpdate := True; + end; + end; + + if vsVisible in Node.States then + // Update the hidden children flag of the parent. + // Since this node is now visible we simply have to remove the flag. + Exclude(Node.Parent.States, vsAllChildrenHidden); + end; + + InvalidateCache; + if NeedUpdate and (FUpdateCount = 0) then + begin + ValidateCache; + UpdateScrollBars(True); + Invalidate; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- +procedure TBaseVirtualTree.SetImages(const Value: TCustomImageList); + +begin + if FImages <> Value then + begin + if Assigned(FImages) then + begin + FImages.UnRegisterChanges(FImageChangeLink); + FImages.RemoveFreeNotification(Self); + end; + FImages := Value; + if Assigned(FImages) then + begin + FImages.RegisterChanges(FImageChangeLink); + FImages.FreeNotification(Self); + end; + if not (csLoading in ComponentState) then + Invalidate; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.SetIndent(Value: TDimension); + +begin + if FIndent <> Value then + begin + FIndent := Value; + if not (csLoading in ComponentState) and (FUpdateCount = 0) and HandleAllocated then + begin + UpdateScrollBars(True); + Invalidate; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.SetLineMode(const Value: TVTLineMode); + +begin + if FLineMode <> Value then + begin + FLineMode := Value; + if HandleAllocated and not (csLoading in ComponentState) then + Invalidate; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.SetLineStyle(const Value: TVTLineStyle); + +begin + if FLineStyle <> Value then + begin + FLineStyle := Value; + if not (csLoading in ComponentState) then + begin + PrepareBitmaps(False, True); + if HandleAllocated then + Invalidate; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.SetMargin(Value: TDimension); + +begin + if FMargin <> Value then + begin + FMargin := Value; + if HandleAllocated and not (csLoading in ComponentState) then + Invalidate; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.SetMultiline(Node: PVirtualNode; const Value: Boolean); + +begin + if Assigned(Node) and (Node <> FRoot) then + if Value <> (vsMultiline in Node.States) then + begin + if Value then + Include(Node.States, vsMultiline) + else + Exclude(Node.States, vsMultiline); + + if FUpdateCount = 0 then + InvalidateNode(Node); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.SetNodeAlignment(const Value: TVTNodeAlignment); + +begin + if FNodeAlignment <> Value then + begin + FNodeAlignment := Value; + if HandleAllocated and not (csReading in ComponentState) then + Invalidate; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.SetNodeData(pNode: PVirtualNode; pUserData: Pointer); + + // Can be used to set user data of a PVirtualNode with the size of a pointer, useful for setting + // A pointer to a record or a reference to a class instance. + +var + NodeData: PPointer; +begin + // Check if there is initial user data and there is also enough user data space allocated. + Assert(FNodeDataSize >= SizeOf(Pointer), Self.Classname + ': Cannot set initial user data because there is not enough user data space allocated.'); + NodeData := pNode.GetData(); + NodeData^ := pUserData; + Include(pNode.States, vsOnFreeNodeCallRequired); +end; + +procedure TBaseVirtualTree.SetNodeData(pNode: PVirtualNode; pUserData: T); + + // Can be used to set user data of a PVirtualNode to a class instance. + +begin + pNode.SetData(pUserData); +end; + +procedure TBaseVirtualTree.SetNodeData(pNode: PVirtualNode; const pUserData: IInterface); + + // Can be used to set user data of a PVirtualNode to a class instance, + // will take care about reference counting. + +begin + pNode.SetData(pUserData); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.SetNodeDataSize(Value: Integer); + +var + LastRootCount: Cardinal; + +begin + if Value < -1 then + Value := -1; + if FNodeDataSize <> Value then + begin + FNodeDataSize := Value; + if not (csLoading in ComponentState) and not (csDesigning in ComponentState) then + begin + LastRootCount := FRoot.ChildCount; + Clear; + SetRootNodeCount(LastRootCount); + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.SetNodeHeight(Node: PVirtualNode; Value: TNodeHeight); + +var + Difference: TDimension; + +begin + Assert(Assigned(Node), 'SetNodeHeight() cannot be called with Node = nil'); + Assert((Node <> FRoot), 'SetNodeHeight() cannot be called for the root node FRoot'); + if (Node.NodeHeight <> Value) then + begin + Difference := Value - Node.NodeHeight; + Node.SetNodeHeight(Value); + + // If the node is effectively filtered out, nothing else has to be done, as it is not visible anyway. + if not IsEffectivelyFiltered[Node] then + begin + AdjustTotalHeight(Node, Difference, True); + + // If an edit operation is currently active then update the editors boundaries as well. + UpdateEditBounds; + + InvalidateCache; + // Stay away from touching the node cache while it is being validated. + if not (tsValidating in FStates) and FullyVisible[Node] then + begin + if (FUpdateCount = 0) and ([tsPainting, tsSizing] * FStates = []) then + begin + ValidateCache; + InvalidateToBottom(Node); + UpdateScrollBars(True); + end; + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.SetNodeParent(Node: PVirtualNode; const Value: PVirtualNode); + +begin + if Assigned(Node) and Assigned(Value) and (Node.Parent <> Value) then + MoveTo(Node, Value, amAddChildLast, False); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.SetOffsetX(const Value: TDimension); + +begin + DoSetOffsetXY(Point(Value, FOffsetY), DefaultScrollUpdateFlags); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.SetOffsetXY(const Value: TPoint); + +begin + DoSetOffsetXY(Value, DefaultScrollUpdateFlags); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.SetOffsetY(const Value: TDimension); + +begin + DoSetOffsetXY(Point(FOffsetX, Value), DefaultScrollUpdateFlags); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.SetOnPrepareButtonImages(const Value: TVTPrepareButtonImagesEvent); +begin + FOnPrepareButtonImages := Value; + PrepareBitmaps(True, False); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.SetOptions(const Value: TCustomVirtualTreeOptions); + +begin + FOptions.Assign(Value); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.SetRangeX(value: TDimension); +begin + FRangeX := value; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.SetRootNodeCount(Value: Cardinal); + +begin + // Don't set the root node count until all other properties (in particular the OnInitNode event) have been set. + if csLoading in ComponentState then + begin + FRoot.SetChildCount(Value); + DoStateChange([tsNeedRootCountUpdate]); + end + else + if FRoot.ChildCount <> Value then + begin + BeginUpdate; + InterruptValidation; + SetChildCount(FRoot, Value); + EndUpdate; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.SetScrollBarOptions(Value: TScrollBarOptions); + +begin + FScrollBarOptions.Assign(Value); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.SetSearchOption(const Value: TVTIncrementalSearch); + +begin + if FIncrementalSearch <> Value then + begin + FIncrementalSearch := Value; + if FIncrementalSearch = isNone then + begin + StopTimer(SearchTimer); + FSearchBuffer := ''; + FLastSearchNode := nil; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.SetSelected(Node: PVirtualNode; Value: Boolean); + +begin + if not FSelectionLocked and Assigned(Node) and (Node <> FRoot) and (Value xor (vsSelected in Node.States)) then + begin + if Value then + begin + if FSelectionCount = 0 then + FRangeAnchor := Node + else begin + if not (toMultiSelect in FOptions.SelectionOptions) then + ClearSelection; + if FRangeAnchor = nil then + FRangeAnchor := Node; + end; + + AddToSelection(Node, True); + + if not (toMultiSelect in FOptions.SelectionOptions) then + FocusedNode := GetFirstSelected; // if only one node can be selected, make sure the focused node changes with the selected node + // Make sure there is a valid column selected (if there are columns at all). + if ((FFocusedColumn < 0) or not (coVisible in FHeader.Columns[FFocusedColumn].Options)) and + (FHeader.MainColumn > NoColumn) then + if ([coVisible, coAllowFocus] * FHeader.Columns[FHeader.MainColumn].Options = [coVisible, coAllowFocus]) then + FFocusedColumn := FHeader.MainColumn + else + FFocusedColumn := FHeader.Columns.GetFirstVisibleColumn(True); + end + else + begin + RemoveFromSelection(Node); + if FSelectionCount = 0 then + ResetRangeAnchor; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.SetSelectionCurveRadius(const Value: Cardinal); + +begin + if FSelectionCurveRadius <> Value then + begin + FSelectionCurveRadius := Value; + if HandleAllocated and not (csLoading in ComponentState) then + Invalidate; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.SetStateImages(const Value: TCustomImageList); + +begin + if FStateImages <> Value then + begin + if Assigned(FStateImages) then + begin + FStateImages.UnRegisterChanges(FStateChangeLink); + FStateImages.RemoveFreeNotification(Self); + end; + FStateImages := Value; + if Assigned(FStateImages) then + begin + FStateImages.RegisterChanges(FStateChangeLink); + FStateImages.FreeNotification(Self); + end; + if HandleAllocated and not (csLoading in ComponentState) then + Invalidate; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.SetTextMargin(Value: TDimension); + +begin + if FTextMargin <> Value then + begin + FTextMargin := Value; + if not (csLoading in ComponentState) then + Invalidate; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.SetTopNode(Node: PVirtualNode); + +var + R: TRect; + Run: PVirtualNode; + +begin + if Assigned(Node) then + begin + // make sure all parents of the node are expanded + Run := Node.Parent; + while Run <> FRoot do + begin + if not (vsExpanded in Run.States) then + ToggleNode(Run); + Run := Run.Parent; + end; + R := GetDisplayRect(Node, FHeader.MainColumn, True); + SetOffsetY(FOffsetY - R.Top); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.SetUpdateState(Updating: Boolean); + +begin + // The check for visibility is necessary otherwise the tree is automatically shown when + // updating is allowed. As this happens internally the VCL does not get notified and + // still assumes the control is hidden. This results in weird "cannot focus invisible control" errors. + if Visible and HandleAllocated and (FUpdateCount = 0) then + SendWM_SETREDRAW(Updating); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.SetVerticalAlignment(Node: PVirtualNode; Value: Byte); + +begin + if Value > 100 then + Value := 100; + if Node.Align <> Value then + begin + Node.Align := Value; + if FullyVisible[Node] and not IsEffectivelyFiltered[Node] then + InvalidateNode(Node); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.SetVisible(Node: PVirtualNode; Value: Boolean); + +// Sets the visibility style of the given node according to Value. + +var + NeedUpdate: Boolean; + +begin + Assert(Assigned(Node) and (Node <> FRoot), 'Invalid parameter.'); + + if Value <> (vsVisible in Node.States) then + begin + InterruptValidation; + NeedUpdate := False; + if Value then + begin + Include(Node.States, vsVisible); + if vsExpanded in Node.Parent.States then + AdjustTotalHeight(Node.Parent, Node.TotalHeight, True); + if VisiblePath[Node] then + begin + System.Inc(FVisibleCount, CountVisibleChildren(Node) + Cardinal(IfThen(IsEffectivelyVisible[Node], 1))); + NeedUpdate := True; + end; + + // Update the hidden children flag of the parent. + // Since this node is now visible we simply have to remove the flag. + if not IsEffectivelyFiltered[Node] then + Exclude(Node.Parent.States, vsAllChildrenHidden); + end + else + begin + if vsExpanded in Node.Parent.States then + AdjustTotalHeight(Node.Parent, -Node.TotalHeight, True); + if VisiblePath[Node] then + begin + System.Dec(FVisibleCount, CountVisibleChildren(Node) + Cardinal(IfThen(IsEffectivelyVisible[Node], 1))); + NeedUpdate := True; + end; + Exclude(Node.States, vsVisible); + + if FUpdateCount = 0 then + DetermineHiddenChildrenFlag(Node.Parent) + else + Include(FStates, tsUpdateHiddenChildrenNeeded); + end; + + InvalidateCache; + if NeedUpdate and (FUpdateCount = 0) then + begin + ValidateCache; + UpdateScrollBars(True); + Invalidate; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.SetVisiblePath(Node: PVirtualNode; Value: Boolean); + +// If Value is True then all parent nodes of Node are expanded. + +begin + Assert(Assigned(Node) and (Node <> FRoot), 'Invalid parameter.'); + + if Value then + begin + repeat + Node := Node.Parent; + if Node = FRoot then + Break; + if not (vsExpanded in Node.States) then + ToggleNode(Node); + until False; + end; +end; + +// ---------------------------------------------------------------------------------------------------------------------- +procedure TBaseVirtualTree.PrepareBackGroundPicture(Source: TVTBackground; + DrawingBitmap: TBitmap; DrawingBitmapWidth: TDimension; DrawingBitmapHeight: TDimension; ABkgcolor: TColor); +const + DST = $00AA0029; // Ternary Raster Operation - Destination unchanged + + // fill background will work for transparent images and + // will not disturb non-transparent ones + procedure FillDrawBitmapWithBackGroundColor; + begin + DrawingBitmap.Canvas.Brush.Color := ABkgcolor; + DrawingBitmap.Canvas.FillRect(Rect(0, 0, DrawingBitmap.Width, DrawingBitmap.Height)); + end; + +begin + DrawingBitmap.SetSize(DrawingBitmapWidth, DrawingBitmapHeight); + + if (Source.Graphic is TBitmap) and + (FBackGroundImageTransparent or Source.Bitmap.TRANSPARENT) + then + begin + FillDrawBitmapWithBackGroundColor; + MaskBlt(DrawingBitmap.Canvas.Handle, 0, 0, Source.Width, Source.Height, + Source.Bitmap.Canvas.Handle, 0, 0, Source.Bitmap.MaskHandle, 0, 0, + MakeROP4(DST, SRCCOPY)); + end + else + begin + // Similar to TImage's Transparent property behavior, we don't want + // to draw transparent if the following flag is OFF. + if FBackGroundImageTransparent then + FillDrawBitmapWithBackGroundColor; + DrawingBitmap.Canvas.Draw(0, 0, Source.Graphic); + end +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.StaticBackground(Source: TVTBackground; Target: TCanvas; OffsetPosition: TPoint; R: TRect; aBkgColor: TColor); + +// Draws the given source graphic so that it stays static in the given rectangle which is relative to the target bitmap. +// The graphic is aligned so that it always starts at the upper left corner of the target canvas. +// Offset gives the position of the target window as a possible superordinated surface. + +const + DST = $00AA0029; // Ternary Raster Operation - Destination unchanged + +var + PicRect: TRect; + AreaRect: TRect; + DrawRect: TRect; + DrawingBitmap: TBitmap; +begin + DrawingBitmap := TBitmap.Create; + try + // clear background + Target.Brush.Color := aBkgColor; + Target.FillRect(R); + + // Picture rect in relation to client viewscreen. + PicRect := Rect(FBackgroundOffsetX, FBackgroundOffsetY, FBackgroundOffsetX + Source.Width, FBackgroundOffsetY + Source.Height); + + // Area to be draw in relation to client viewscreen. + AreaRect := Rect(OffsetPosition.X + R.Left, OffsetPosition.Y + R.Top, OffsetPosition.X + R.Right, OffsetPosition.Y + R.Bottom); + + // If picture falls in AreaRect, return intersection (DrawRect). + if IntersectRect(DrawRect, PicRect, AreaRect) then + begin + PrepareBackGroundPicture(Source, DrawingBitmap, Source.Width, Source.Height, aBkgColor); + // copy image to destination + BitBlt(Target.Handle, DrawRect.Left - OffsetPosition.X, DrawRect.Top - OffsetPosition.Y, (DrawRect.Right - OffsetPosition.X) - (DrawRect.Left - OffsetPosition.X), + (DrawRect.Bottom - OffsetPosition.Y) - (DrawRect.Top - OffsetPosition.Y) + R.Top, DrawingBitmap.Canvas.Handle, DrawRect.Left - PicRect.Left, DrawRect.Top - PicRect.Top, + SRCCOPY); + end; + finally + DrawingBitmap.Free; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.StopTimer(ID: Integer); + +begin + if HandleAllocated then + KillTimer(Handle, ID); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.SetWindowTheme(const Theme: string); + +begin + FChangingTheme := True; + + inherited; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +//used by TCustomVirtualTreeOptions +procedure TBaseVirtualTree.SetVisibleCount(value : Cardinal); +begin + FVisibleCount := value; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.TileBackground(Source: TVTBackground; Target: TCanvas; Offset: TPoint; R: TRect; aBkgColor: TColor); + +// Draws the given source graphic so that it tiles into the given rectangle which is relative to the target bitmap. +// The graphic is aligned so that it always starts at the upper left corner of the target canvas. +// Offset gives the position of the target window in an possible superordinated surface. + +var + SourceX, + SourceY, + TargetX, + DeltaY: TDimension; + DrawingBitmap: TBitmap; +begin + DrawingBitmap := TBitmap.Create; + try + PrepareBackGroundPicture(Source, DrawingBitmap, Source.Width, Source.Height, aBkgColor); + with Target do + begin + SourceY := (R.Top + Offset.Y + FBackgroundOffsetY) mod Source.Height; + // Always wrap the source coordinates into positive range. + if SourceY < 0 then + SourceY := Source.Height + SourceY; + + // Tile image vertically until target rect is filled. + while R.Top < R.Bottom do + begin + SourceX := (R.Left + Offset.X + FBackgroundOffsetX) mod Source.Width; + // always wrap the source coordinates into positive range + if SourceX < 0 then + SourceX := Source.Width + SourceX; + + TargetX := R.Left; + // height of strip to draw + DeltaY := Min(R.Bottom - R.Top, Source.Height - SourceY); + + // tile the image horizontally + while TargetX < R.Right do + begin + BitBlt(Handle, TargetX, R.Top, Min(R.Right - TargetX, Source.Width - SourceX), DeltaY, + DrawingBitmap.Canvas.Handle, SourceX, SourceY, SRCCOPY); + Inc(TargetX, Source.Width - SourceX); + SourceX := 0; + end; + Inc(R.Top, Source.Height - SourceY); + SourceY := 0; + end; + end; + finally + DrawingBitmap.Free; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.ToggleCallback(Step, StepSize: Integer; Data: Pointer): Boolean; + +var + Column: TColumnIndex; + Run: TRect; + SecondaryStepSize: Integer; + + //--------------- local functions ------------------------------------------- + + procedure EraseLine; + + var + LocalBrush: TBrush; + + begin + with TToggleAnimationData(Data^), FHeader.Columns do + begin + // Iterate through all columns and erase background in their local color. + // LocalBrush is a brush in the color of the particular column. + Column := GetFirstVisibleColumn; + while (Column > InvalidColumn) and (Run.Left < ClientWidth) do + begin + GetColumnBounds(Column, Run.Left, Run.Right); + if coParentColor in Items[Column].Options then + begin + DC.Brush := Brush; + DC.FillRect(Run); + end + else + begin + LocalBrush := TBrush.Create; + if VclStyleEnabled then + LocalBrush.Color := FColors.BackGroundColor + else + LocalBrush.Color := Items[Column].Color; + DC.Brush := LocalBrush; + DC.FillRect(Run); + LocalBrush.Free; + end; + Column := GetNextVisibleColumn(Column); + end; + end; + end; + + //--------------------------------------------------------------------------- + + procedure DoScrollUp(DC: TCanvas; Brush: TBrush; Area: TRect; Steps: Integer); + + begin + ScrollDC(DC.Handle, 0, -Steps, Area, Area, 0, nil); + + if Step = 0 then + if not FHeader.UseColumns then + begin + DC.Brush := Brush; + DC.FillRect(Rect(Area.Left, Area.Bottom - Steps - 1, Area.Right, Area.Bottom)); + end + else + begin + Run := Rect(Area.Left, Area.Bottom - Steps - 1, Area.Right, Area.Bottom); + EraseLine; + end; + end; + + //--------------------------------------------------------------------------- + + procedure DoScrollDown(DC: TCanvas; Brush: TBrush; Area: TRect; Steps: Integer); + + begin + ScrollDC(DC.Handle, 0, Steps, Area, Area, 0, nil); + + if Step = 0 then + if not FHeader.UseColumns then + begin + DC.Brush := Brush; + DC.FillRect(Rect(Area.Left, Area.Top, Area.Right, Area.Top + Steps + 1)); + end + else + begin + Run := Rect(Area.Left, Area.Top, Area.Right, Area.Top + Steps + 1); + EraseLine; + end; + end; + + //--------------- end local functions --------------------------------------- + +begin + Result := True; + if StepSize > 0 then + begin + SecondaryStepSize := 0; + with TToggleAnimationData(Data^) do + begin + if Mode1 <> tamNoScroll then + begin + if Mode1 = tamScrollUp then + DoScrollUp(DC, Brush, R1, StepSize) + else + DoScrollDown(DC, Brush, R1, StepSize); + + if (Mode2 <> tamNoScroll) and (ScaleFactor > 0) then + begin + // As this routine is able to scroll two independent areas at once, the missing StepSize is + // computed in that case. To ensure the maximal accuracy the rounding error is accumulated. + SecondaryStepSize := Round((StepSize + MissedSteps) * ScaleFactor); + MissedSteps := MissedSteps + StepSize * ScaleFactor - SecondaryStepSize; + end; + end + else + SecondaryStepSize := StepSize; + + if Mode2 <> tamNoScroll then + if Mode2 = tamScrollUp then + DoScrollUp(DC, Brush, R2, SecondaryStepSize) + else + DoScrollDown(DC, Brush, R2, SecondaryStepSize); + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.CMColorChange(var Message: TMessage); + +begin + if not (csLoading in ComponentState) then + begin + PrepareBitmaps(True, False); + if HandleAllocated then + Invalidate; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.CMCtl3DChanged(var Message: TMessage); + +begin + inherited; + if FBorderStyle = bsSingle then + RecreateWnd; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.CMBiDiModeChanged(var Message: TMessage); + +begin + inherited; + + if UseRightToLeftAlignment then + FEffectiveOffsetX := FRangeX - ClientWidth + FOffsetX + else + FEffectiveOffsetX := -FOffsetX; + if FEffectiveOffsetX < 0 then + FEffectiveOffsetX := 0; + + if toAutoBidiColumnOrdering in FOptions.AutoOptions then + TVirtualTreeColumnsCracker(FHeader.Columns).ReorderColumns(UseRightToLeftAlignment); + FHeader.Invalidate(nil); +end; + +procedure TBaseVirtualTree.CMBorderChanged(var Message: TMessage); +begin + inherited; + if VclStyleEnabled and (seBorder in StyleElements) then + RecreateWnd; +end; + +procedure TBaseVirtualTree.CMParentDoubleBufferedChange(var Message: TMessage); +begin + // empty by intention, we do our own buffering +end; + +procedure TBaseVirtualTree.CMStyleChanged(var Message: TMessage); +begin + VclStyleChanged; + RecreateWnd; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.CMDenySubclassing(var Message: TMessage); + +// If a Windows XP Theme Manager component is used in the application it will try to subclass all controls which do not +// explicitly deny this. Virtual Treeview knows how to handle XP themes so it does not need subclassing. + +begin + Message.Result := 1; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.CMDrag(var Message: TCMDrag); + +var + S: TObject; + ShiftState: Integer; + P: TPoint; + Formats: TFormatArray; + Effect: Integer; + +begin + with Message, DragRec^ do + begin + S := Source; + Formats := nil; + + // Let the ancestor handle dock operations. + if S is TDragDockObject then + inherited + else + begin + // We need an extra check for the control drag object as there might be other objects not derived from this class (e.g. TActionDragObject). + // Original line of code (see issue #1295): if not (tsUserDragObject in FStates) and (S is TBaseDragControlObject) then + if (S.ClassName = TDragControlObject.ClassName) or (S.ClassName = TDragControlObjectEx.ClassName) then // see issue #1295 + S := (S as TBaseDragControlObject).Control; + case DragMessage of + dmDragEnter, dmDragLeave, dmDragMove: + begin + if DragMessage = dmDragEnter then + DoStateChange([tsVCLDragging]); + if DragMessage = dmDragLeave then + DoStateChange([tsVCLDragFinished], [tsVCLDragging]); + + if DragMessage = dmDragMove then + with ScreenToClient(Pos) do + DoAutoScroll(X, Y); + + ShiftState := 0; + // Alt key will be queried by the KeysToShiftState function in DragOver. + if GetKeyState(VK_SHIFT) < 0 then + ShiftState := ShiftState or MK_SHIFT; + if GetKeyState(VK_CONTROL) < 0 then + ShiftState := ShiftState or MK_CONTROL; + + // Allowed drop effects are simulated for VCL dd. + Effect := DROPEFFECT_MOVE or DROPEFFECT_COPY; + DragOver(S, ShiftState, TDragState(DragMessage), Pos, Effect); + FLastVCLDragTarget := FDropTargetNode; + FVCLDragEffect := Effect; + if (DragMessage = dmDragLeave) and Assigned(FDropTargetNode) then + begin + InvalidateNode(FDropTargetNode); + FDropTargetNode := nil; + end; + Result := LRESULT(Effect); + end; + dmDragDrop: + begin + ShiftState := 0; + // Alt key will be queried by the KeysToShiftState function in DragOver + if GetKeyState(VK_SHIFT) < 0 then + ShiftState := ShiftState or MK_SHIFT; + if GetKeyState(VK_CONTROL) < 0 then + ShiftState := ShiftState or MK_CONTROL; + + // allowed drop effects are simulated for VCL dd, + // replace target node with cached node from other VCL dd messages + if Assigned(FDropTargetNode) then + InvalidateNode(FDropTargetNode); + FDropTargetNode := FLastVCLDragTarget; + P := Point(Pos.X, Pos.Y); + P := ScreenToClient(P); + try + DoDragDrop(S, nil, Formats, KeysToShiftState(ShiftState), P, FVCLDragEffect, FLastDropMode); + finally + if Assigned(FDropTargetNode) then + begin + InvalidateNode(FDropTargetNode); + FDropTargetNode := nil; + end; + end; + end; + dmFindTarget: + begin + Result := LRESULT(ControlAtPos(ScreenToClient(Pos), False)); + if Result = 0 then + Result := LRESULT(Self); + + // This is a reliable place to check whether VCL drag has + // really begun. + if tsVCLDragPending in FStates then + DoStateChange([tsVCLDragging], [tsVCLDragPending, tsEditPending, tsClearPending]); + end; + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.CMEnabledChanged(var Message: TMessage); + +begin + inherited; + + // Need to invalidate the non-client area as well, since the header must be redrawn too. + if csDesigning in ComponentState then + RedrawWindow(nil, 0, RDW_FRAME or RDW_INVALIDATE or RDW_NOERASE or RDW_NOCHILDREN); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.CMFontChanged(var Message: TMessage); + +var + HeaderMessage: TMessage; + +begin + inherited; + AutoScale(); + + HeaderMessage.Msg := CM_PARENTFONTCHANGED; + HeaderMessage.WParam := 0; + HeaderMessage.LParam := 0; + HeaderMessage.Result := 0; + TVTHeaderCracker(FHeader).HandleMessage(HeaderMessage); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.CMHintShow(var Message: TCMHintShow); + +// Determines hint message (tooltip) and out-of-hint rect. +// Note: A special handling is needed here because we cannot pass wide strings back to the caller. +// I had to introduce the hint data record anyway so we can use this to pass the hint string. +// We still need to set a dummy hint string in the message to make the VCL showing the hint window. + +var + NodeRect: TRect; + SpanColumn, + Dummy, + ColLeft, + ColRight: Integer; + HitInfo: THitInfo; + ShowOwnHint: Boolean; + IsFocusedOrEditing: Boolean; + ParentForm: TCustomForm; + BottomRightCellContentMargin: TPoint; + HintKind: TVTHintKind; +begin + with Message do + begin + Result := 1; + + if PtInRect(FLastHintRect, HintInfo.CursorPos) then + Exit; + + // Determine node for which to show hint/tooltip. + with HintInfo^ do + GetHitTestInfoAt(CursorPos.X, CursorPos.Y, True, HitInfo, []); + + // Make sure a hint is only shown if the tree or at least its parent form is active. + // Active editing is ok too as long as we don't want the hint for the current edit node. + if IsEditing then + IsFocusedOrEditing := HitInfo.HitNode <> FFocusedNode + else + begin + IsFocusedOrEditing := Focused; + ParentForm := GetParentForm(Self); + if Assigned(ParentForm) then + IsFocusedOrEditing := ParentForm.Focused or Application.Active; + end; + + if (GetCapture = 0) and ShowHint and not (Dragging or IsMouseSelecting) and ([tsScrolling] * FStates = []) and + (FHeader.States = []) and IsFocusedOrEditing then + begin + with HintInfo^ do + begin + Result := 0; + ShowOwnHint := False; + + //workaround for issue #291 + //it duplicates parts of the following code and code in TVirtualTreeHintWindow + HintStr := ''; + if FHeader.UseColumns and (hoShowHint in FHeader.Options) and FHeader.InHeader(CursorPos) then + begin + CursorRect := FHeaderRect; + // Convert the cursor rectangle into real client coordinates. + OffsetRect(CursorRect, 0, -Integer(FHeader.Height)); + HitInfo.HitColumn := TVirtualTreeColumnsCracker(FHeader.Columns).GetColumnAndBounds(CursorPos, CursorRect.Left, CursorRect.Right); + if (HitInfo.HitColumn > NoColumn) and not (csLButtonDown in ControlState) and + (FHeader.Columns[HitInfo.HitColumn].Hint <> '') then + HintStr := FHeader.Columns[HitInfo.HitColumn].Hint; + end + else + if HintMode = hmDefault then + HintStr := GetShortHint(Hint) + else + if Assigned(HitInfo.HitNode) and (HitInfo.HitColumn > InvalidColumn) then + begin + if HintMode = hmToolTip then + HintStr := DoGetNodeToolTip(HitInfo.HitNode, HitInfo.HitColumn, fHintData.LineBreakStyle) + else + HintStr := DoGetNodeHint(HitInfo.HitNode, HitInfo.HitColumn, fHintData.LineBreakStyle); + end; + + // First check whether there is a header hint to show. + if FHeader.UseColumns and (hoShowHint in FHeader.Options) and FHeader.InHeader(CursorPos) then + begin + CursorRect := FHeaderRect; + // Convert the cursor rectangle into real client coordinates. + OffsetRect(CursorRect, 0, -Integer(FHeader.Height)); + HitInfo.HitColumn := TVirtualTreeColumnsCracker(FHeader.Columns).GetColumnAndBounds(CursorPos, CursorRect.Left, CursorRect.Right); + // align the vertical hint position on the bottom bound of the header, but + // avoid overlapping of mouse cursor and hint + HintPos.Y := Max(HintPos.Y, ClientToScreen(Point(0, CursorRect.Bottom)).Y); + // Note: the test for the left mouse button in ControlState might cause problems whenever the VCL does not + // realize when the button is released. This, for instance, happens when doing OLE drag'n drop and + // cancel this with ESC. + if (HitInfo.HitColumn > NoColumn) and not (csLButtonDown in ControlState) then + begin + HintStr := FHeader.Columns[HitInfo.HitColumn].Hint; + if HintStr = '' then + with FHeader.Columns[HitInfo.HitColumn] do + begin + if (2 * FMargin + CaptionWidth + 1) >= Width then + HintStr := CaptionText; + end; + if HintStr <> '' then + ShowOwnHint := True + else + Result := 1; + end + else + Result := 1; + end + else + begin + // Default mode is handled as would the tree be a usual VCL control (no own hint window necessary). + if FHintMode = hmDefault then + HintStr := GetShortHint(Hint) + else + begin + if Assigned(HitInfo.HitNode) and (HitInfo.HitColumn > InvalidColumn) then + begin + // An owner-draw tree should only display a hint when at least + // its OnGetHintSize event handler is assigned. + DoGetHintKind(HitInfo.HitNode, HitInfo.HitColumn, HintKind); + FHintData.HintRect := Rect(0, 0, 0, 0); + if (HintKind = vhkOwnerDraw) then + begin + DoGetHintSize(HitInfo.HitNode, HitInfo.HitColumn, FHintData.HintRect); + ShowOwnHint := not IsRectEmpty(FHintData.HintRect); + end + else + // For trees displaying text hints, a decision about showing the hint or not is based + // on the hint string (if it is empty then no hint is shown). + ShowOwnHint := True; + + if ShowOwnHint then + begin + if HitInfo.HitColumn > NoColumn then + begin + FHeader.Columns.GetColumnBounds(HitInfo.HitColumn, ColLeft, ColRight); + // The right column border might be extended if column spanning is enabled. + if toAutoSpanColumns in FOptions.AutoOptions then + begin + SpanColumn := HitInfo.HitColumn; + repeat + Dummy := FHeader.Columns.GetNextVisibleColumn(SpanColumn); + if (Dummy = InvalidColumn) or not ColumnIsEmpty(HitInfo.HitNode, Dummy) then + Break; + SpanColumn := Dummy; + until False; + if SpanColumn <> HitInfo.HitColumn then + FHeader.Columns.GetColumnBounds(SpanColumn, Dummy, ColRight); + end; + end + else + begin + ColLeft := 0; + ColRight := ClientWidth; + end; + + if FHintMode <> hmTooltip then + begin + // Node specific hint text. + CursorRect := GetDisplayRect(HitInfo.HitNode, HitInfo.HitColumn, False); + CursorRect.Left := ColLeft; + CursorRect.Right := ColRight; + // Align the vertical hint position on the bottom bound of the node, but + // avoid overlapping of mouse cursor and hint. + HintPos.Y := Max(HintPos.Y, ClientToScreen(CursorRect.BottomRight).Y) + ScaledPixels(2); + end + else + begin + // Tool tip to show. This means the full caption of the node must be displayed. + if vsMultiline in HitInfo.HitNode.States then + begin + if hiOnItemLabel in HitInfo.HitPositions then + begin + ShowOwnHint := True; + NodeRect := GetDisplayRect(HitInfo.HitNode, HitInfo.HitColumn, True, False); + end + else + ShowOwnHint := False; + end + else + begin + NodeRect := GetDisplayRect(HitInfo.HitNode, HitInfo.HitColumn, True, True, True); + BottomRightCellContentMargin := DoGetCellContentMargin(HitInfo.HitNode, HitInfo.HitColumn, ccmtBottomRightOnly); + + ShowOwnHint := (HitInfo.HitColumn > InvalidColumn) and PtInRect(NodeRect, CursorPos) and + (CursorPos.X <= ColRight) and (CursorPos.X >= ColLeft) and + ( + // Show hint also if the node text is partially out of the client area. + // "ColRight - 1", since the right column border is not part of this cell. + ( (NodeRect.Right + BottomRightCellContentMargin.X) > Min(ColRight - 1, ClientWidth) ) or + (NodeRect.Left < Max(ColLeft, 0)) or + ( (NodeRect.Bottom + BottomRightCellContentMargin.Y) > ClientHeight ) or + (NodeRect.Top < 0) + ); + end; + + if ShowOwnHint then + begin + // Node specific hint text given will be retrieved when needed. + HintPos := ClientToScreen(Point(NodeRect.Left, NodeRect.Top)); + CursorRect := NodeRect; + end + else + // nothing to show + Result := 1; + end; + end + else + Result := 1; // Avoid hint if this is a draw tree returning an empty hint rectangle. + end + else + begin + // No node so fall back to control's hint (if indicated) or show nothing. + if FHintMode = hmHintAndDefault then + begin + HintStr := GetShortHint(Hint); + + // Fix for the problem: Default Hint once shown stayed even when + // node hint was to be displayed. The reason was that CursorRect + // was for the full client area. Now reducing it to remove the + // columns from it. + if BidiMode = bdLeftToRight then + CursorRect.Left := Header.Columns.TotalWidth + else + CursorRect.right := CursorRect.right - Header.Columns.TotalWidth; + + if Length(HintStr) = 0 then + Result := 1 + else + ShowOwnHint := True; + end + else + Result := 1; + end; + end; + end; + + // Set our own hint window class and prepare structure to be passed to the hint window. + if ShowOwnHint and (Result = 0) then + begin + HintWindowClass := GetHintWindowClass; + FHintData.HintText := HintStr; + FHintData.Tree := Self; + FHintData.Column := HitInfo.HitColumn; + FHintData.Node := HitInfo.HitNode; + FLastHintRect := CursorRect; + HintData := @FHintData; + end + else + FLastHintRect := Rect(0, 0, 0, 0); + end; + + // Remind that a hint is about to show. + if Result = 0 then + DoStateChange([tsHint]) + else + DoStateChange([], [tsHint]); + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.CMHintShowPause(var Message: TCMHintShowPause); + +// Tells the application that the tree (and only the tree) does not want a delayed tool tip. +// Normal hints / header hints use the default delay (except for the first time). + + begin + if ShowHint and (FHintMode = hmToolTip) then + Message.Pause^ := 0; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.CMMouseEnter(var Message: TMessage); +begin + DoMouseEnter(); + inherited; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.CMMouseLeave(var Message: TMessage); + +var + LeaveStates: TVirtualTreeStates; + +begin + // Reset the last used hint rectangle in case the mouse enters the window within the bounds + if Assigned(FHintData.Tree) then + FHintData.Tree.FLastHintRect := Rect(0, 0, 0, 0); + + LeaveStates := [tsHint]; + if not (tsPanning in FStates) then + begin + StopTimer(ScrollTimer); + LeaveStates := LeaveStates + [tsScrollPending, tsScrolling]; + end; + DoStateChange([], LeaveStates); + if Assigned(FCurrentHotNode) then + begin + DoHotChange(FCurrentHotNode, nil); + if (toHotTrack in FOptions.PaintOptions) or (toCheckSupport in FOptions.MiscOptions) then + InvalidateNode(FCurrentHotNode); + FCurrentHotNode := nil; + end; + + if Assigned(Header) then + begin + with TVirtualTreeColumnsCracker(Header.Columns) do + begin + DownIndex := NoColumn; + HoverIndex := NoColumn; + CheckBoxHit := False; + end; + end; + DoMouseLeave(); + inherited; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.CMMouseWheel(var Message: TCMMouseWheel); + +var + ScrollAmount: TDimension; + ScrollLines: DWORD; + RTLFactor: Integer; + WheelFactor: Double; + +begin + StopWheelPanning; + + inherited; + + if Message.Result = 0 then + begin + with Message do + begin + Result := 1; + WheelFactor := WheelDelta / WHEEL_DELTA; + if (FRangeY > ClientHeight) and (not (ssShift in ShiftState)) then + begin + // Scroll vertically if there's something to scroll... + if ssCtrl in ShiftState then + ScrollAmount := Trunc(WheelFactor * ClientHeight) + else + begin + SystemParametersInfo(SPI_GETWHEELSCROLLLINES, 0, @ScrollLines, 0); + if ScrollLines = WHEEL_PAGESCROLL then + ScrollAmount := Trunc(WheelFactor * ClientHeight) + else + ScrollAmount := Integer(Trunc(WheelFactor * ScrollLines * FDefaultNodeHeight)); + end; + SetOffsetY(FOffsetY + ScrollAmount); + end + else + begin + // ...else scroll horizontally if there's something to scroll. + if UseRightToLeftAlignment then + RTLFactor := -1 + else + RTLFactor := 1; + + if ssCtrl in ShiftState then + ScrollAmount := Trunc(WheelFactor * (ClientWidth - FHeader.Columns.GetVisibleFixedWidth)) + else + begin + SystemParametersInfo(SPI_GETWHEELSCROLLLINES, 0, @ScrollLines, 0); + if ScrollLines = WHEEL_PAGESCROLL then + ScrollAmount := Trunc(WheelFactor * (ClientWidth - FHeader.Columns.GetVisibleFixedWidth)) + else + ScrollAmount := Trunc(WheelFactor * ScrollLines * FHeader.Columns.GetScrollWidth); + end; + SetOffsetX(FOffsetX + RTLFactor * ScrollAmount); + end; + end; + + end; + +end; + +//---------------------------------------------------------------------------------------------------------------------- +procedure TBaseVirtualTree.CMSysColorChange(var Message: TMessage); + +begin + inherited; + Message.Msg := WM_SYSCOLORCHANGE; + DefaultHandler(Message); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.TVMGetItem(var Message: TMessage); + +// Screen reader support function. The method returns information about a particular node. + +const + StateMask = TVIS_STATEIMAGEMASK or TVIS_OVERLAYMASK or TVIS_EXPANDED or TVIS_DROPHILITED or TVIS_CUT or + TVIS_SELECTED or TVIS_FOCUSED; + +var + Item: PTVItemEx; + Node: PVirtualNode; + Ghosted: Boolean; + ImageIndex: TImageIndex; + R: TRect; + Text: string; +begin + // We can only return valid data if a nodes reference is given. + Item := Pointer(Message.LParam); + Message.Result := Ord(((Item.mask and TVIF_HANDLE) <> 0) and Assigned(Item.hItem)); + if Message.Result = 1 then + begin + Node := Pointer(Item.hItem); + // Child count requested? + if (Item.mask and TVIF_CHILDREN) <> 0 then + Item.cChildren := Node.ChildCount; + // Index for normal image requested? + if (Item.mask and TVIF_IMAGE) <> 0 then + begin + ImageIndex := -1; + DoGetImageIndex(Node, ikNormal, -1, Ghosted, ImageIndex); + Item.iImage := ImageIndex; + end; + // Index for selected image requested? + if (Item.mask and TVIF_SELECTEDIMAGE) <> 0 then + begin + ImageIndex := -1; + DoGetImageIndex(Node, ikSelected, -1, Ghosted, ImageIndex); + Item.iSelectedImage := ImageIndex; + end; + // State info requested? + if (Item.mask and TVIF_STATE) <> 0 then + begin + // Everything, which is possible is returned. + Item.stateMask := StateMask; + Item.state := 0; + if Node = FFocusedNode then + Item.state := Item.state or TVIS_FOCUSED; + if vsSelected in Node.States then + Item.state := Item.state or TVIS_SELECTED; + if vsCutOrCopy in Node.States then + Item.state := Item.state or TVIS_CUT; + if Node = FDropTargetNode then + Item.state := Item.state or TVIS_DROPHILITED; + if vsExpanded in Node.States then + Item.state := Item.state or TVIS_EXPANDED; + + // Construct state image and overlay image indices. They are zero based, btw. + // and -1 means there is no image. + ImageIndex := -1; + DoGetImageIndex(Node, ikState, -1, Ghosted, ImageIndex); + Item.state := Item.state or Byte(IndexToStateImageMask(ImageIndex + 1)); + ImageIndex := -1; + DoGetImageIndex(Node, ikOverlay, -1, Ghosted, ImageIndex); + Item.state := Item.state or Byte(IndexToOverlayMask(ImageIndex + 1)); + end; + // Node caption requested? + if (Item.mask and TVIF_TEXT) <> 0 then + begin + GetTextInfo(Node, -1, Font, R, Text); + + StrLCopy(Item.pszText, PWideChar(Text), Item.cchTextMax - 1); + Item.pszText[Length(Text)] := #0; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.TVMGetItemRect(var Message: TMessage); + +// Screen read support function. This method returns a node's display rectangle. + +var + TextOnly: Boolean; + Node: PVirtualNode; + +begin + // The lparam member is used two-way. On enter it contains a pointer to the item (node). + // On exit it is to be considered as pointer to a rectangle structure. + Node := Pointer(Pointer(Message.LParam)^); + Message.Result := Ord(IsVisible[Node]); + if Message.Result <> 0 then + begin + TextOnly := Message.WParam <> 0; + PRect(Message.LParam)^ := GetDisplayRect(Node, NoColumn, TextOnly); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.TVMGetNextItem(var Message: TMessage); + +// Screen read support function. This method returns a node depending on the requested case. + +var + Node: PVirtualNode; + +begin + // Start with a nil result. + Message.Result := 0; + Node := Pointer(Message.LParam); + case Message.WParam of + TVGN_CARET: + Message.Result := LRESULT(FFocusedNode); + TVGN_CHILD: + if Assigned(Node) then + Message.Result := LRESULT(GetFirstChild(Node)); + TVGN_DROPHILITE: + Message.Result := LRESULT(FDropTargetNode); + TVGN_FIRSTVISIBLE: + Message.Result := LRESULT(GetFirstVisible(nil, True)); + TVGN_LASTVISIBLE: + Message.Result := LRESULT(GetLastVisible(nil, True)); + TVGN_NEXT: + if Assigned(Node) then + Message.Result := LRESULT(GetNextSibling(Node)); + TVGN_NEXTVISIBLE: + if Assigned(Node) then + Message.Result := LRESULT(GetNextVisible(Node, True)); + TVGN_PARENT: + if Assigned(Node) and (Node <> FRoot) and (Node.Parent <> FRoot) then + Message.Result := LRESULT(Node.Parent); + TVGN_PREVIOUS: + if Assigned(Node) then + Message.Result := LRESULT(GetPreviousSibling(Node)); + TVGN_PREVIOUSVISIBLE: + if Assigned(Node) then + Message.Result := LRESULT(GetPreviousVisible(Node, True)); + TVGN_ROOT: + Message.Result := LRESULT(GetFirst); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.WMCancelMode(var Message: TWMCancelMode); + +begin + // Clear any transient state. + StopTimer(ExpandTimer); + StopTimer(EditTimer); + StopTimer(HeaderTimer); + StopTimer(ScrollTimer); + StopTimer(SearchTimer); + StopTimer(ThemeChangedTimer); + FSearchBuffer := ''; + FLastSearchNode := nil; + + DoStateChange([], [tsClearPending, tsEditPending, tsOLEDragPending, tsVCLDragPending, tsDrawSelecting, + tsDrawSelPending, tsIncrementalSearching]); + + inherited; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.WMChar(var Message: TWMChar); + +begin + if tsIncrementalSearchPending in FStates then + begin + HandleIncrementalSearch(Message.CharCode); + DoStateChange([], [tsIncrementalSearchPending]); + end; + + inherited; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.WMContextMenu(var Message: TWMContextMenu); + +// This method is called when a popup menu is about to be displayed. +// We have to cancel some pending states here to avoid interferences. + +var + HitInfo: THitInfo; + pt: TPoint; +begin + DoStateChange([], [tsClearPending, tsEditPending, tsOLEDragPending, tsVCLDragPending, tsPopupMenuShown]); + + if not Assigned(PopupMenu) then begin + // convert screen coordinates to client + pt := ScreenToClient(Point(Message.XPos, Message.YPos)); + GetHitTestInfoAt(pt.x, pt.y, True, HitInfo); // ShiftState is not used anyway here + DoPopupMenu(HitInfo.HitNode, HitInfo.HitColumn, pt); + end; + + if not (tsPopupMenuShown in FStates) then + inherited; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.WMCopy(var Message: TWMCopy); + +begin + CopyToClipboard; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.WMCut(var Message: TWMCut); + +begin + CutToClipboard; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.WMEnable(var Message: TWMEnable); + +begin + inherited; + RedrawWindow(nil, 0, RDW_FRAME or RDW_INVALIDATE or RDW_NOERASE or RDW_NOCHILDREN); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.WMEraseBkgnd(var Message: TWMEraseBkgnd); + +begin + Message.Result := 1; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.WMGetDlgCode(var Message: TWMGetDlgCode); + +begin + Message.Result := DLGC_WANTCHARS or DLGC_WANTARROWS; + if FWantTabs then + Message.Result := Message.Result or DLGC_WANTTAB; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.WMHScroll(var Message: TWMHScroll); + + //--------------- local functions ------------------------------------------- + + function GetRealScrollPosition: TDimension; + + var + SI: TScrollInfo; + Bar: Integer; + + begin + SI.cbSize := SizeOf(TScrollInfo); + SI.fMask := SIF_TRACKPOS; + Bar := SB_HORZ; + GetScrollInfo(Bar, SI); + Result := SI.nTrackPos; + end; + + //--------------- end local functions --------------------------------------- + +var + RTLFactor: Integer; + +begin + if UseRightToLeftAlignment then + RTLFactor := -1 + else + RTLFactor := 1; + + case Message.ScrollCode of + SB_BOTTOM: + SetOffsetX(-FRangeX); + SB_ENDSCROLL: + begin + DoStateChange([], [tsThumbTracking]); + // avoiding to adjust the vertical scroll position while tracking makes it much smoother + // but we need to adjust the final position here then + UpdateHorizontalScrollBar(False); + end; + SB_LINELEFT: + SetOffsetX(FOffsetX + RTLFactor * FScrollBarOptions.HorizontalIncrement); + SB_LINERIGHT: + SetOffsetX(FOffsetX - RTLFactor * FScrollBarOptions.HorizontalIncrement); + SB_PAGELEFT: + SetOffsetX(FOffsetX + RTLFactor * (ClientWidth - FHeader.Columns.GetVisibleFixedWidth)); + SB_PAGERIGHT: + SetOffsetX(FOffsetX - RTLFactor * (ClientWidth - FHeader.Columns.GetVisibleFixedWidth)); + SB_THUMBPOSITION, + SB_THUMBTRACK: + begin + DoStateChange([tsThumbTracking]); + if UseRightToLeftAlignment then + SetOffsetX(-FRangeX + ClientWidth + GetRealScrollPosition) + else + SetOffsetX(-GetRealScrollPosition); + end; + SB_TOP: + SetOffsetX(0); + end; + + Message.Result := 0; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.WMKeyDown(var Message: TWMKeyDown); + +// Keyboard event handling for node focus, selection, node specific popup menus and help invokation. +// For a detailed description of every action done here read the help. + +var + Shift: TShiftState; + Node, Temp, + LastFocused: PVirtualNode; + Offset: Integer; + ClearPending, + NeedInvalidate, + DoRangeSelect, + PerformMultiSelect: Boolean; + Context: Integer; + ParentControl: TWinControl; + R: TRect; + NewCheckState: TCheckState; + TempColumn, + NewColumn: TColumnIndex; + ActAsGrid: Boolean; + ForceSelection: Boolean; + NewWidth, + NewHeight: Integer; + RTLFactor: Integer; + + // for tabulator handling + GetStartColumn: function(ConsiderAllowFocus: Boolean = False): TColumnIndex of object; + GetNextColumn: function(Column: TColumnIndex; ConsiderAllowFocus: Boolean = False): TColumnIndex of object; + GetNextNode: TGetNextNodeProc; + + KeyState: TKeyboardState; + Buffer: array[0..1] of AnsiChar; + + //--------------- local functions ------------------------------------------- + function getPreviousVisibleAutoSpanColumn(acolumn: TColumnIndex; anode: PVirtualNode): TColumnIndex; + var + PrevColumn: Integer; + begin + if (not assigned(anode)) + or (not FHeader.UseColumns) + or (not (toAutoSpanColumns in FOptions.AutoOptions)) + or (acolumn = FHeader.MainColumn) then + begin + //previously existing logic + result := FHeader.Columns.GetPreviousVisibleColumn(acolumn, True); + exit; + end; + //consider auto spanning + with FHeader.Columns do //standard loop for auto span + begin + PrevColumn := acolumn; + repeat + result := FHeader.Columns.GetPreviousVisibleColumn(PrevColumn); + if (result = InvalidColumn) or + (not ColumnIsEmpty(anode, result)) + //Any other BidiMode is not supported as already + //documented by original developer + or (Items[result].BidiMode <> bdLeftToRight) then + Break; + PrevColumn := result; + until False; + end; + end; + + //--------------------------------------------------------------------------- + function getNextVisibleAutoSpanColumn(acolumn: TColumnIndex; anode: PVirtualNode): TColumnIndex; + var + NextColumn: Integer; + begin + if (not assigned(anode)) + or (not FHeader.UseColumns) + or (not (toAutoSpanColumns in FOptions.AutoOptions)) + or (acolumn = FHeader.MainColumn) then + begin + //previously existing logic + result := FHeader.Columns.GetNextVisibleColumn(acolumn, True); + exit; + end; + //consider auto spanning + with FHeader.Columns do //standard loop for auto span + begin + NextColumn := acolumn; + repeat + result := FHeader.Columns.GetNextVisibleColumn(NextColumn); + if (result = InvalidColumn) or + not ColumnIsEmpty(anode, result) + //Any other BidiMode is not supported as already + //documented by original developer + or (Items[result].BidiMode <> bdLeftToRight) then + Break; + NextColumn := result; + until False; + end; + end; + + //--------------------------------------------------------------------------- + function isEmptyAutoSpanColumn(acolumn: TColumnIndex; anode: PVirtualNode): boolean; + var + previousColumn: Integer; + begin + result := false; + if (not assigned(anode)) + or (not FHeader.UseColumns) + or (not (toAutoSpanColumns in FOptions.AutoOptions)) + or (acolumn = FHeader.MainColumn) then + exit; + with FHeader.Columns do + begin + previousColumn := FHeader.Columns.GetPreviousVisibleColumn(acolumn); + if (previousColumn = InvalidColumn) //there is no previous column + //Any other BidiMode is not supported as already + //documented by original developer + or (Items[acolumn].BidiMode <> bdLeftToRight) then + exit; //returning false + result := ColumnIsEmpty(anode, acolumn); + end; + end; + + + //--------------- end local functions --------------------------------------- + +begin + // Make form key preview work and let application modify the key if it wants this. + inherited; + + with Message do + begin + Shift := KeyDataToShiftState(KeyData); + // Ask the application if the default key handling is desired. + if DoKeyAction(CharCode, Shift) then + begin + if (CharCode in [VK_HOME, VK_END, VK_PRIOR, VK_NEXT, VK_UP, VK_DOWN, VK_LEFT, VK_RIGHT, VK_BACK, VK_TAB]) and (RootNode.FirstChild <> nil) then + begin + PerformMultiSelect := (ssShift in Shift) and (toMultiSelect in FOptions.SelectionOptions) and not IsEditing; + + // Flag to avoid range selection in case of single node advance. + DoRangeSelect := (CharCode in [VK_HOME, VK_END, VK_PRIOR, VK_NEXT]) and PerformMultiSelect and not IsEditing; + + NeedInvalidate := DoRangeSelect or (FSelectionCount > 1); + ActAsGrid := toGridExtensions in FOptions.MiscOptions; + ClearPending := (Shift = []) or (ActAsGrid and not (ssShift in Shift)) or + not (toMultiSelect in FOptions.SelectionOptions) or (CharCode in [VK_TAB, VK_BACK]); + + // Keep old focused node for range selection. Use a default node if none was focused until now. + LastFocused := FFocusedNode; + if (LastFocused = nil) and (Shift <> []) then + LastFocused := GetFirstVisible(nil, True); + + // Set an initial range anchor if there is not yet one. + if FRangeAnchor = nil then + FRangeAnchor := GetFirstSelected; + if FRangeAnchor = nil then + FRangeAnchor := GetFirst; + + if UseRightToLeftAlignment then + RTLFactor := -1 + else + RTLFactor := 1; + + // Determine new focused node. + case CharCode of + VK_HOME, VK_END: + begin + if (CharCode = VK_END) xor UseRightToLeftAlignment then + begin + GetStartColumn := FHeader.Columns.GetLastVisibleColumn; + GetNextColumn := FHeader.Columns.GetPreviousVisibleColumn; + GetNextNode := GetPreviousVisible; + Node := GetLastVisible(nil, True); + end + else + begin + GetStartColumn := FHeader.Columns.GetFirstVisibleColumn; + GetNextColumn := FHeader.Columns.GetNextVisibleColumn; + GetNextNode := GetNextVisible; + Node := GetFirstVisible(nil, True); + end; + + // Advance to next/previous visible column. + if FHeader.UseColumns then + NewColumn := GetStartColumn + else + NewColumn := NoColumn; + // Find a column for the new/current node which can be focused. + // Make the 'DoFocusChanging' for finding a valid column + // identifiable from the 'DoFocusChanging' raised later on by + // "FocusedNode := Node;" + while (NewColumn > NoColumn) and not DoFocusChanging(FFocusedNode, FFocusedNode, FFocusedColumn, NewColumn) do + NewColumn := GetNextColumn(NewColumn); + if NewColumn > InvalidColumn then + begin + if (Shift = [ssCtrl]) and not ActAsGrid then + begin + ScrollIntoView(Node, toCenterScrollIntoView in FOptions.SelectionOptions, + not (toDisableAutoscrollOnFocus in FOptions.AutoOptions)); + if (CharCode = VK_HOME) and not UseRightToLeftAlignment then + SetOffsetX(0) + else + SetOffsetX(-MaxInt); + end + else + begin + if not ActAsGrid or (ssCtrl in Shift) then + FocusedNode := Node; + //fix: In grid mode, if full row select option is ON, + //then also go to the node determined from the earlier logic + if ActAsGrid and (toFullRowSelect in FOptions.SelectionOptions) then + FocusedNode := Node; + if ActAsGrid and not (toFullRowSelect in FOptions.SelectionOptions) then + begin + FocusedColumn := NewColumn; + // fix: If auto span is ON the last column may be a merged column. So take + // care of selecting the whole merged column on END key. + if (CharCode = VK_END) and isEmptyAutoSpanColumn(NewColumn, FFocusedNode) then + FocusedColumn := getPreviousVisibleAutoSpanColumn(NewColumn, FFocusedNode); + end; + end; + end; + end; + VK_PRIOR: + if Shift = [ssCtrl, ssShift] then + SetOffsetX(FOffsetX + ClientWidth) + else + if [ssShift, ssAlt] = Shift then + begin + if FFocusedColumn <= NoColumn then + NewColumn := FHeader.Columns.GetFirstVisibleColumn + else + begin + Offset := FHeader.Columns.GetVisibleFixedWidth; + NewColumn := FFocusedColumn; + while True do + begin + TempColumn := FHeader.Columns.GetPreviousVisibleColumn(NewColumn); + NewWidth := FHeader.Columns[NewColumn].Width; + if (TempColumn <= NoColumn) or + (Offset + NewWidth >= ClientWidth) or + (coFixed in FHeader.Columns[TempColumn].Options) then + Break; + NewColumn := TempColumn; + Inc(Offset, NewWidth); + end; + end; + SetFocusedColumn(NewColumn); + end + else + if ssCtrl in Shift then + SetOffsetY(FOffsetY + ClientHeight) + else + begin + Offset := 0; + // If there's no focused node then just take the very first visible one. + if FFocusedNode = nil then + Node := GetFirstVisible(nil, True) + else + begin + // Go up as many nodes as comprise together a size of ClientHeight. + Node := FFocusedNode; + while True do + begin + Temp := GetPreviousVisible(Node, True); + NewHeight := NodeHeight[Node]; + if (Temp = nil) or (Offset + NewHeight >= ClientHeight) then + Break; + Node := Temp; + Inc(Offset, NodeHeight[Node]); + end; + end; + FocusedNode := Node; + end; + VK_NEXT: + if Shift = [ssCtrl, ssShift] then + SetOffsetX(FOffsetX - ClientWidth) + else + if [ssShift, ssAlt] = Shift then + begin + if FFocusedColumn <= NoColumn then + NewColumn := FHeader.Columns.GetFirstVisibleColumn + else + begin + Offset := FHeader.Columns.GetVisibleFixedWidth; + NewColumn := FFocusedColumn; + while True do + begin + TempColumn := FHeader.Columns.GetNextVisibleColumn(NewColumn); + NewWidth := FHeader.Columns[NewColumn].Width; + if (TempColumn <= NoColumn) or + (Offset + NewWidth >= ClientWidth) or + (coFixed in FHeader.Columns[TempColumn].Options) then + Break; + NewColumn := TempColumn; + Inc(Offset, NewWidth); + end; + end; + SetFocusedColumn(NewColumn); + end + else + if ssCtrl in Shift then + SetOffsetY(FOffsetY - ClientHeight) + else + begin + Offset := 0; + // If there's no focused node then just take the very last one. + if FFocusedNode = nil then + Node := GetLastVisible(nil, True) + else + begin + // Go up as many nodes as comprise together a size of ClientHeight. + Node := FFocusedNode; + while True do + begin + Temp := GetNextVisible(Node, True); + NewHeight := NodeHeight[Node]; + if (Temp = nil) or (Offset + NewHeight >= ClientHeight) then + Break; + Node := Temp; + Inc(Offset, NewHeight); + end; + end; + FocusedNode := Node; + end; + VK_UP: + begin + // scrolling without selection change + if ssCtrl in Shift then + SetOffsetY(FOffsetY + FDefaultNodeHeight) + else + begin + if FFocusedNode = nil then + Node := GetLastVisible(nil, True) + else + Node := GetPreviousVisible(FFocusedNode, True); + + if Assigned(Node) then + begin + if not EndEditNode then + exit; + if (not PerformMultiSelect or (CompareNodePositions(LastFocused, Node) < -1)) and Assigned(FFocusedNode) then + ClearSelection(False); // Clear selection only if more than one node was skipped. See issue #926 + if FFocusedColumn <= NoColumn then + FFocusedColumn := FHeader.MainColumn; + FocusedNode := Node; + end + else + if Assigned(FFocusedNode) then + InvalidateNode(FFocusedNode); + end; + end; + VK_DOWN: + begin + // scrolling without selection change + if ssCtrl in Shift then + SetOffsetY(FOffsetY - FDefaultNodeHeight) + else + begin + if FFocusedNode = nil then + Node := GetFirstVisible(nil, True) + else + Node := GetNextVisible(FFocusedNode, True); + + if Assigned(Node) then + begin + if not EndEditNode then + exit; + if (not PerformMultiSelect or (CompareNodePositions(LastFocused, Node) > 1)) and Assigned(FFocusedNode) then + ClearSelection(False); // Clear selection only if more than one node was skipped. See issue #926 + if FFocusedColumn <= NoColumn then + FFocusedColumn := FHeader.MainColumn; + FocusedNode := Node; + end + else + if Assigned(FFocusedNode) then + InvalidateNode(FFocusedNode); + end; + end; + VK_LEFT: + begin + // special handling + if ssCtrl in Shift then + SetOffsetX(FOffsetX + RTLFactor * FHeader.Columns.GetScrollWidth) + else + begin + // other special cases + Context := NoColumn; + if (toExtendedFocus in FOptions.SelectionOptions) and (toGridExtensions in FOptions.MiscOptions) then + begin + Context := getPreviousVisibleAutoSpanColumn(FFocusedColumn, FFocusedNode); + if Context > NoColumn then + FocusedColumn := Context; + end + else + if Assigned(FFocusedNode) and (vsExpanded in FFocusedNode.States) and + (Shift = []) and (vsHasChildren in FFocusedNode.States) then + ToggleNode(FFocusedNode) + else + begin + if FFocusedNode = nil then + FocusedNode := GetFirstVisible(nil, True) + else + begin + if FFocusedNode.Parent <> FRoot then + Node := FFocusedNode.Parent + else + Node := nil; + if Assigned(Node) then + begin + if PerformMultiSelect then + begin + // and a third special case + if FFocusedNode.Index > 0 then + DoRangeSelect := True + else + if CompareNodePositions(Node, FRangeAnchor) > 0 then + RemoveFromSelection(FFocusedNode); + end; + FocusedNode := Node; + end + else begin + // If already a root node is selected, then scroll to the left as there is nothing else we could do. #691 + SetOffsetX(FOffsetX + RTLFactor * FHeader.Columns.GetScrollWidth); + end;//else + end; + end; + end; + end; + VK_RIGHT: + begin + // special handling + if ssCtrl in Shift then + SetOffsetX(FOffsetX - RTLFactor * FHeader.Columns.GetScrollWidth) + else + begin + // other special cases + Context := NoColumn; + if (toExtendedFocus in FOptions.SelectionOptions) and (toGridExtensions in FOptions.MiscOptions) then + begin + Context := getNextVisibleAutoSpanColumn(FFocusedColumn, FFocusedNode); + if Context > NoColumn then + FocusedColumn := Context; + end + else + if Assigned(FFocusedNode) and not (vsExpanded in FFocusedNode.States) and + (Shift = []) and (vsHasChildren in FFocusedNode.States) then + ToggleNode(FFocusedNode) + else + begin + if FFocusedNode = nil then + FocusedNode := GetFirstVisible(nil, True) + else + begin + Node := GetFirstVisibleChild(FFocusedNode); + if Assigned(Node) then + begin + if PerformMultiSelect and (CompareNodePositions(Node, FRangeAnchor) < 0) then + RemoveFromSelection(FFocusedNode); + FocusedNode := Node; + end + else begin + // If already a leaf node is selected, then scroll to the right as there is nothing else we could do. #691 + SetOffsetX(FOffsetX - RTLFactor * FHeader.Columns.GetScrollWidth); + end;//else + end; + end; + end; + end; + VK_BACK: + if tsIncrementalSearching in FStates then + DoStateChange([tsIncrementalSearchPending]) + else + if Assigned(FFocusedNode) and (FFocusedNode.Parent <> FRoot) then + FocusedNode := FocusedNode.Parent; + VK_TAB: + if (toExtendedFocus in FOptions.SelectionOptions) and FHeader.UseColumns then + begin + // In order to avoid duplicating source code just to change the direction + // we use function variables. + if ssShift in Shift then + begin + GetStartColumn := FHeader.Columns.GetLastVisibleColumn; + GetNextColumn := FHeader.Columns.GetPreviousVisibleColumn; + GetNextNode := GetPreviousVisible; + end + else + begin + GetStartColumn := FHeader.Columns.GetFirstVisibleColumn; + GetNextColumn := FHeader.Columns.GetNextVisibleColumn; + GetNextNode := GetNextVisible; + end; + + // Advance to next/previous visible column/node. + Node := FFocusedNode; + NewColumn := GetNextColumn(FFocusedColumn, True); + repeat + // Find a column for the current node which can be focused. + while (NewColumn > NoColumn) and not DoFocusChanging(FFocusedNode, Node, FFocusedColumn, NewColumn) + //Fix: for Tab Key to properly skip the empty auto span column + or isEmptyAutoSpanColumn(NewColumn, Node) do + NewColumn := GetNextColumn(NewColumn, True); + + if NewColumn > NoColumn then + begin + // Set new node and column in one go. + SetFocusedNodeAndColumn(Node, NewColumn); + Break; + end; + + // No next column was accepted for the current node. So advance to next node and try again. + Node := GetNextNode(Node); + NewColumn := GetStartColumn; + + // fix: From last column, the Tab key should always go to next row irrespective of auto span + // Similarly the Shift-Tab key should go to previos row from first column + if (Node <> nil) and (NewColumn > NoColumn) then + SetFocusedNodeAndColumn(Node, NewColumn); + + until Node = nil; + end; + end; + + // Clear old selection if required but take care to select the new focused node if it was not selected before. + ForceSelection := False; + if ClearPending and ((LastFocused <> FFocusedNode) or (FSelectionCount <> 1)) then + begin + ClearSelection(not Assigned(FFocusedNode)); + ForceSelection := True; + end; + + // Determine new selection anchor. + if Shift = [] then + begin + FRangeAnchor := FFocusedNode; + FLastSelectionLevel := GetNodeLevelForSelectConstraint(FFocusedNode); + end; + + if Assigned(FFocusedNode) then + begin + // Finally change the selection for a specific range of nodes. + if DoRangeSelect then + ToggleSelection(LastFocused, FFocusedNode) + // Make sure the new focused node is also selected. + else if (LastFocused <> FFocusedNode) then begin + if ForceSelection then + AddToSelection(FFocusedNode, False) + else + ToggleSelection(LastFocused, FFocusedNode); // See issue #926 + end; + end; + + // If a repaint is needed then paint the entire tree because of the ClearSelection call, + if NeedInvalidate then + Invalidate; + end + else + begin + // Second chance for keys not directly concerned with selection changes. + + // For +, -, /, * keys on the main keyboard (not numpad) there is no virtual key code defined. + // We have to do special processing to get them working too. + GetKeyboardState(KeyState); + // Avoid conversion to control characters. We have captured the control key state already in Shift. + KeyState[VK_CONTROL] := 0; + if ToASCII(Message.CharCode, (Message.KeyData shr 16) and 7, KeyState, PChar(@Buffer), 0) > 0 then + begin + case Buffer[0] of + '*': + CharCode := VK_MULTIPLY; + '+': + CharCode := VK_ADD; + '/': + CharCode := VK_DIVIDE; + '-': + CharCode := VK_SUBTRACT; + end; + end; + + // According to https://web.archive.org/web/20041129085958/http://www.it-faq.pl/mskb/99/337.HTM + // there is a problem with ToASCII when used in conjunction with dead chars. + // The article recommends to call ToASCII twice to restore a deleted flag in the key message + // structure under certain circumstances. It turned out it is best to always call ToASCII twice. + ToASCII(Message.CharCode, (Message.KeyData shr 16) and 7, KeyState, PChar(@Buffer), 0); + + case CharCode of + VK_F2: + if (Shift = []) and Assigned(FFocusedNode) and CanEdit(FFocusedNode, FFocusedColumn) then + begin + FEditColumn := FFocusedColumn; + DoEdit; + end; + VK_ADD: + if not (tsIncrementalSearching in FStates) then + begin + if ssCtrl in Shift then begin// When changing this code review issue #781 + if ((toReverseFullExpandHotKey in TreeOptions.MiscOptions) and (Shift = [ssCtrl])) xor (Shift = [ssCtrl, ssShift]) then + FullExpand + else if Shift = [ssCtrl] then + FHeader.AutoFitColumns + end + else if Shift = [] then begin + if Assigned(FFocusedNode) and not (vsExpanded in FFocusedNode.States) then + ToggleNode(FFocusedNode); + end// if Shift = [] + else + DoStateChange([tsIncrementalSearchPending]); + end;//if not (tsIncrementalSearching in FStates) + VK_SUBTRACT: + if not (tsIncrementalSearching in FStates) then + begin + if ssCtrl in Shift then + if (toReverseFullExpandHotKey in TreeOptions.MiscOptions) xor (ssShift in Shift) then + FullCollapse + else + FHeader.RestoreColumns + else + if Assigned(FFocusedNode) and (vsExpanded in FFocusedNode.States) then + ToggleNode(FFocusedNode); + end + else + DoStateChange([tsIncrementalSearchPending]); + VK_MULTIPLY: + if not (tsIncrementalSearching in FStates) then + begin + if Assigned(FFocusedNode) then + FullExpand(FFocusedNode); + end + else + DoStateChange([tsIncrementalSearchPending]); + VK_DIVIDE: + if not (tsIncrementalSearching in FStates) then + begin + if Assigned(FFocusedNode) then + FullCollapse(FFocusedNode); + end + else + DoStateChange([tsIncrementalSearchPending]); + VK_ESCAPE: // cancel actions currently in progress + begin + if IsMouseSelecting then + begin + DoStateChange([], [tsDrawSelecting, tsDrawSelPending]); + Invalidate; + end + else + if IsEditing then + CancelEditNode; + end; + VK_SPACE: + if (toCheckSupport in FOptions.MiscOptions) and Assigned(FFocusedNode) and + (FFocusedNode.CheckType <> ctNone) then + begin + NewCheckState := DetermineNextCheckState(FFocusedNode.CheckType, GetCheckState(FFocusedNode)); + if DoChecking(FFocusedNode, NewCheckState) then + begin + if SelectedCount > 1 then + SetCheckStateForAll(NewCheckState, True) + else + DoCheckClick(FFocusedNode, NewCheckState); + end; + end + else + DoStateChange([tsIncrementalSearchPending]); + VK_F1: + if Assigned(FOnGetHelpContext) then + begin + Context := 0; + if Assigned(FFocusedNode) then + begin + Node := FFocusedNode; + // Traverse the tree structure up to the root. + repeat + FOnGetHelpContext(Self, Node, IfThen(FFocusedColumn > NoColumn, FFocusedColumn, 0), Context); + Node := Node.Parent; + until (Node = FRoot) or (Context <> 0); + end; + + // If no help context could be found try the tree's one or its parent's contexts. + ParentControl := Self; + while Assigned(ParentControl) and (Context = 0) do + begin + Context := ParentControl.HelpContext; + ParentControl := ParentControl.Parent; + end; + if Context <> 0 then + Application.HelpContext(Context); + end; + VK_APPS: + if Assigned(FFocusedNode) then + begin + R := GetDisplayRect(FFocusedNode, FFocusedColumn, True); + Offset := DoGetNodeWidth(FFocusedNode, FFocusedColumn); + if FFocusedColumn >= 0 then + begin + if Offset > FHeader.Columns[FFocusedColumn].Width then + Offset := FHeader.Columns[FFocusedColumn].Width; + end + else + begin + if Offset > ClientWidth then + Offset := ClientWidth; + end; + DoPopupMenu(FFocusedNode, FFocusedColumn, Point(R.Left + Offset div 2, (R.Top + R.Bottom) div 2)); + end + else + DoPopupMenu(nil, FFocusedColumn, Point(-1, -1)); + Ord('a'), Ord('A'): + if ssCtrl in Shift then + SelectAll(True) + else + DoStateChange([tsIncrementalSearchPending]); + else + begin + // Use the key for incremental search. + // Since we are dealing with Unicode all the time there should be a more sophisticated way + // of checking for valid characters for incremental search. + // This is available but would require to include a significant amount of Unicode character + // properties, so we stick with the simple space check. + if ((Shift * [ssCtrl, ssAlt] = []) or ((Shift * [ssCtrl, ssAlt] = [ssCtrl, ssAlt]))) and (CharCode >= 32) then + DoStateChange([tsIncrementalSearchPending]); + end; + end; + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.WMKeyUp(var Message: TWMKeyUp); + +begin + inherited; + + case Message.CharCode of + VK_TAB: + EnsureNodeFocused(); // Always select a node if the control gets the focus via TAB key, #237 + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.WMKillFocus(var Msg: TWMKillFocus); + +var + Form: TCustomForm; + Control: TWinControl; + Pos: TSmallPoint; + Unknown: IUnknown; + +begin + inherited; + + // Remove hint if shown currently. + if tsHint in Self.FStates then + Application.CancelHint; + + // Stop wheel panning if active. + StopWheelPanning; + + // Don't let any timer continue if the tree is no longer the active control (except change timers). + StopTimer(ExpandTimer); + StopTimer(EditTimer); + StopTimer(HeaderTimer); + StopTimer(ScrollTimer); + StopTimer(SearchTimer); + FSearchBuffer := ''; + FLastSearchNode := nil; + + DoStateChange([], [tsScrollPending, tsScrolling, tsEditPending, tsLeftButtonDown, tsRightButtonDown, + tsMiddleButtonDown, tsOLEDragPending, tsVCLDragPending, tsIncrementalSearching, tsNodeHeightTrackPending, + tsNodeHeightTracking]); + + if (FSelectionCount > 0) or not (toGhostedIfUnfocused in FOptions.PaintOptions) then + Invalidate + else + if Assigned(FFocusedNode) then + InvalidateNode(FFocusedNode); + + // Workaround for wrapped non-VCL controls (like TWebBrowser), which do not use VCL mechanisms and + // leave the ActiveControl property in the wrong state, which causes trouble when the control is refocused. + Form := GetParentForm(Self); + if Assigned(Form) and (Form.ActiveControl = Self) then + begin + Cardinal(Pos) := GetMessagePos; + Control := FindVCLWindow(SmallPointToPoint(Pos)); + // Every control derived from TOleControl has potentially the focus problem. In order to avoid including + // the OleCtrls unit (which will, among others, include Variants), which would allow to test for the TOleControl + // class, the IOleClientSite interface is used for the test, which is supported by TOleControl and a good indicator. + if Assigned(Control) and Control.GetInterface(IOleClientSite, Unknown) then + Form.ActiveControl := nil; + + // For other classes the active control should not be modified. Otherwise you need two clicks to select it. + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.WMLButtonDblClk(var Message: TWMLButtonDblClk); + +var + HitInfo: THitInfo; + +begin + DoStateChange([tsLeftDblClick]); + try + // get information about the hit, before calling inherited, is this may change the scroll postion and so the node under the mouse would chnage and would no longer be the one the user actually clicked + GetHitTestInfoAt(Message.XPos, Message.YPos, True, HitInfo, KeysToShiftState(Message.Keys)); + HandleMouseDblClick(Message, HitInfo); + // Call inherited after doing our standard handling, as the event handler may close the form or re-fill the control, so our clicked node would be no longer valid. + // Our standard handling does not do that. + inherited; + // #909 + // if we show a modal form in the HandleMouseDblClick(), the mouse capture wont be released + if csCaptureMouse in ControlStyle then MouseCapture := False; + finally + DoStateChange([], [tsLeftDblClick]); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.WMLButtonDown(var Message: TWMLButtonDown); + +var + HitInfo: THitInfo; + +begin + DoStateChange([tsLeftButtonDown]); + inherited; + + // get information about the hit + GetHitTestInfoAt(Message.XPos, Message.YPos, True, HitInfo, KeysToShiftState(Message.Keys)); + HandleMouseDown(Message, HitInfo); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.WMLButtonUp(var Message: TWMLButtonUp); + +var + HitInfo: THitInfo; + +begin + DoStateChange([], [tsLeftButtonDown, tsNodeHeightTracking, tsNodeHeightTrackPending]); + + // get information about the hit + GetHitTestInfoAt(Message.XPos, Message.YPos, True, HitInfo, KeysToShiftState(Message.Keys)); + HandleMouseUp(Message, HitInfo); + + inherited; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.WMMButtonDblClk(var Message: TWMMButtonDblClk); + +var + HitInfo: THitInfo; + +begin + DoStateChange([tsMiddleDblClick]); + inherited; + + // get information about the hit + if toMiddleClickSelect in FOptions.SelectionOptions then + begin + GetHitTestInfoAt(Message.XPos, Message.YPos, True, HitInfo, KeysToShiftState(Message.Keys)); + HandleMouseDblClick(Message, HitInfo); + end; + DoStateChange([], [tsMiddleDblClick]); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.WMMButtonDown(var Message: TWMMButtonDown); + +var + HitInfo: THitInfo; + +begin + DoStateChange([tsMiddleButtonDown]); + + if FHeader.States = [] then + begin + inherited; + + // Start wheel panning or scrolling if not already active, allowed and scrolling is useful at all. + if (toWheelPanning in FOptions.MiscOptions) and not (tsPanning in FStates) and + ((FRangeX > ClientWidth) or (FRangeY > ClientHeight)) then + begin + FLastClickPos := SmallPointToPoint(Message.Pos); + StartWheelPanning(FLastClickPos); + end + else + begin + StopWheelPanning; + + // Get information about the hit. + if toMiddleClickSelect in FOptions.SelectionOptions then + begin + GetHitTestInfoAt(Message.XPos, Message.YPos, True, HitInfo, KeysToShiftState(Message.Keys)); + HandleMouseDown(Message, HitInfo); + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.WMMButtonUp(var Message: TWMMButtonUp); + +var + HitInfo: THitInfo; + +begin + DoStateChange([], [tsMiddleButtonDown]); + + if not (tsPanning in FStates) then + if FHeader.States = [] then + begin + inherited; + + // get information about the hit + if toMiddleClickSelect in FOptions.SelectionOptions then + begin + GetHitTestInfoAt(Message.XPos, Message.YPos, True, HitInfo, KeysToShiftState(Message.Keys)); + HandleMouseUp(Message, HitInfo); + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.WMNCCalcSize(var Message: TWMNCCalcSize); + +begin + inherited; + + with FHeader do + if hoVisible in FHeader.Options then + with Message.CalcSize_Params^ do + Inc(rgrc[0].Top, Height); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.WMNCDestroy(var Message: TWMNCDestroy); + +// Used to release a reference of the drag manager. This is the only reliable way we get notified about +// window destruction, because of the automatic release of a window if its parent window is freed. + +begin + InterruptValidation; + + StopTimer(ChangeTimer); + StopTimer(StructureChangeTimer); + + if not (csDesigning in ComponentState) and HandleAllocated then + RevokeDragDrop(Handle); + + inherited; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.WMNCHitTest(var Message: TWMNCHitTest); + +begin + inherited; + if (hoVisible in FHeader.Options) and + FHeader.InHeader(ScreenToClient(SmallPointToPoint(Message.Pos))) then + Message.Result := HTBORDER; +end; + +//---------------------------------------------------------------------------------------------------------------------- + + +procedure TBaseVirtualTree.WMNCPaint(var Message: TWMNCPaint); + +var + DC: HDC; + R: TRect; + Flags: DWORD; + ExStyle: Integer; + TempRgn: HRGN; + BorderWidth, + BorderHeight: Integer; + +begin + if tsUseThemes in FStates then + begin + // If theming is enabled and the client edge border is set for the window then prevent the default window proc + // from painting the old border to avoid flickering. + ExStyle := GetWindowLong(Handle, GWL_EXSTYLE); + if (ExStyle and WS_EX_CLIENTEDGE) <> 0 then + begin + GetWindowRect(Handle, R); + // Determine width of the client edge. + BorderWidth := GetSystemMetrics(SM_CXEDGE); + BorderHeight := GetSystemMetrics(SM_CYEDGE); + InflateRect(R, -BorderWidth, -BorderHeight); + TempRgn := CreateRectRgnIndirect(R); + // Exclude the border from the message region if there is one. Otherwise just use the inflated + // window area region. + if Message.Rgn <> 1 then + CombineRgn(TempRgn, Message.Rgn, TempRgn, RGN_AND); + DefWindowProc(Handle, Message.Msg, WPARAM(TempRgn), 0); + DeleteObject(TempRgn); + end + else + DefaultHandler(Message); + end + else + DefaultHandler(Message); + + Flags := DCX_CACHE or DCX_CLIPSIBLINGS or DCX_WINDOW or DCX_VALIDATE; + + if (Message.Rgn = 1) then + DC := GetDCEx(Handle, 0, Flags) + else + DC := GetDCEx(Handle, Message.Rgn, Flags or DCX_INTERSECTRGN); + + if DC <> 0 then + try + OriginalWMNCPaint(DC); + finally + ReleaseDC(Handle, DC); + end; + if (((tsUseThemes in FStates) and not VclStyleEnabled) or (VclStyleEnabled and (seBorder in StyleElements))) then + StyleServices.PaintBorder(Self, False) + else + if (VclStyleEnabled and not (seBorder in StyleElements)) then + TStyleManager.SystemStyle.PaintBorder(Self, False) +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.WMPaint(var Message: TWMPaint); +var + DC: HDC; +begin + if tsVCLDragging in FStates then + ImageList_DragShowNolock(False); + if csPaintCopy in ControlState then + FUpdateRect := ClientRect + else + GetUpdateRect(Handle, FUpdateRect, True); + + inherited; + + if tsVCLDragging in FStates then + ImageList_DragShowNolock(True); + + if hoVisible in FHeader.Options then + begin + DC := GetDCEx(Handle, 0, DCX_CACHE or DCX_CLIPSIBLINGS or DCX_WINDOW or DCX_VALIDATE); + if DC <> 0 then + try + FHeader.Columns.PaintHeader(DC, FHeaderRect, -FEffectiveOffsetX); + finally + ReleaseDC(Handle, DC); + end; + end;//if header visible +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.WMPaste(var Message: TWMPaste); + +begin + PasteFromClipboard; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.WMPrint(var Message: TWMPrint); + +// This message is sent to request that the tree draws itself to a given device context. This includes not only +// the client area but also the non-client area (header!). + +begin + // Draw only if the window is visible or visibility is not required. + if ((Message.Flags and PRF_CHECKVISIBLE) = 0) or IsWindowVisible(Handle) then + Header.Columns.PaintHeader(Message.DC, FHeaderRect, -FEffectiveOffsetX); + + inherited; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.WMRButtonDblClk(var Message: TWMRButtonDblClk); + +var + HitInfo: THitInfo; + +begin + DoStateChange([tsRightDblClick]); + inherited; + + // get information about the hit + if toMiddleClickSelect in FOptions.SelectionOptions then + begin + GetHitTestInfoAt(Message.XPos, Message.YPos, True, HitInfo, KeysToShiftState(Message.Keys)); + HandleMouseDblClick(Message, HitInfo); + end; + DoStateChange([], [tsRightDblClick]); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.WMRButtonDown(var Message: TWMRButtonDown); + +var + HitInfo: THitInfo; + RemoveSynchMode: Boolean; // Needed to restore tsSynchMode correctly + +begin + DoStateChange([tsRightButtonDown]); + + if FHeader.States = [] then + begin + inherited; + + // get information about the hit + if toRightClickSelect in FOptions.SelectionOptions then + begin + GetHitTestInfoAt(Message.XPos, Message.YPos, True, HitInfo, KeysToShiftState(Message.Keys)); + // Go temporarily into sync mode to avoid a delayed change event for the node when selecting. #679 + RemoveSynchMode := not (tsSynchMode in FStates); + Include(FStates, tsSynchMode); + HandleMouseDown(Message, HitInfo); + if RemoveSynchMode then + Exclude(FStates, tsSynchMode); + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.WMRButtonUp(var Message: TWMRButtonUp); + +// handle right click selection and node specific popup menu + +var + HitInfo: THitInfo; + +begin + DoStateChange([], [tsRightButtonDown]); + + if FHeader.States = [] then + begin + Application.CancelHint; + + if IsMouseSelecting and Assigned(PopupMenu) then + begin + // Reset selection state already here, before the inherited handler opens the default menu. + DoStateChange([], [tsDrawSelecting, tsDrawSelPending]); + Invalidate; + end; + + inherited; + + // get information about the hit + GetHitTestInfoAt(Message.XPos, Message.YPos, True, HitInfo, KeysToShiftState(Message.Keys)); + + if toRightClickSelect in FOptions.SelectionOptions then + HandleMouseUp(Message, HitInfo); + + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.WMSetCursor(var Message: TWMSetCursor); + +// Sets the hot node mouse cursor for the tree. Cursor changes for the header are handled in Header.HandleMessage. + +var + NewCursor: TCursor; + HitInfo: THitInfo; + P: TPoint; + Node: PVirtualNode; + +begin + with Message do + begin + // Feature: design-time header #415 + // Allow header to handle cursor and return control's default if it did nothing + if (CursorWnd = Handle) and not (tsPanning in FStates) then + begin + if not TVTHeaderCracker(FHeader).HandleMessage(TMessage(Message)) then + begin + // Apply own cursors only if there is no global cursor set. + if Screen.Cursor = crDefault then + begin + // node resizing and hot tracking - for run-time only + if not (csDesigning in ComponentState) then + begin + NewCursor := crDefault; + if (toNodeHeightResize in FOptions.MiscOptions) then + begin + GetCursorPos(P); + P := ScreenToClient(P); + GetHitTestInfoAt(P.X, P.Y, True, HitInfo, []); + if (hiOnItem in HitInfo.HitPositions) and + ([hiUpperSplitter, hiLowerSplitter] * HitInfo.HitPositions <> []) then + begin + if hiUpperSplitter in HitInfo.HitPositions then + Node := GetPreviousVisible(HitInfo.HitNode, True) + else + Node := HitInfo.HitNode; + + if CanSplitterResizeNode(P, Node, HitInfo.HitColumn) then + NewCursor := crVSplit; + end; + end; + + if (NewCursor = crDefault) then + if (toHotTrack in FOptions.PaintOptions) and Assigned(FCurrentHotNode) and (FHotCursor <> crDefault) then + NewCursor := FHotCursor + else + NewCursor := Cursor; + + DoGetCursor(NewCursor); + end + else + NewCursor := Cursor; + Winapi.Windows.SetCursor(Screen.Cursors[NewCursor]); + Message.Result := 1; + end + else + inherited; + end; + end + else + inherited; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.WMSetFocus(var Msg: TWMSetFocus); + +begin + inherited; + if (FSelectionCount > 0) or not (toGhostedIfUnfocused in FOptions.PaintOptions) then + Invalidate; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.WMSize(var Message: TWMSize); + +begin + inherited; + + // Need to update scroll bars here. This will cause a recursion because of the change of the client area + // when changing a scrollbar. Usually this is no problem since with the second level recursion no change of the + // window size happens (the same values for the scrollbars are set, which shouldn't cause a window size change). + // Appearently, this applies not to all systems, however. + if HandleAllocated and ([tsSizing, tsWindowCreating] * FStates = []) and (ClientHeight > 0) then + try + DoStateChange([tsSizing]); + // This call will invalidate the entire non-client area which needs recalculation on resize. + TVTHeaderCracker(FHeader).RescaleHeader; + TVTHeaderCracker(FHeader).UpdateSpringColumns; + UpdateScrollBars(True); + + if (tsEditing in FStates) and not FHeader.UseColumns then + UpdateEditBounds; + finally + DoStateChange([], [tsSizing]); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.WMThemeChanged(var Message: TMessage); + +begin + inherited; + + if StyleServices.Enabled and (toThemeAware in TreeOptions.PaintOptions) then + DoStateChange([tsUseThemes]) + else + DoStateChange([], [tsUseThemes]); + + // Updating the visuals here will not work correctly. Therefore we postpone + // the update by using a timer. + if not FChangingTheme then + SetTimer(Handle, ThemeChangedTimer, ThemeChangedTimerDelay, nil); + FChangingTheme := False; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.WMTimer(var Message: TWMTimer); + +// centralized timer handling happens here + +begin + with Message do + begin + case TimerID of + ExpandTimer: + DoDragExpand; + EditTimer: + DoEdit; + ScrollTimer: + begin + if tsScrollPending in FStates then + begin + Application.CancelHint; + // Scroll delay has elapsed, set to normal scroll interval now. + SetTimer(Handle, ScrollTimer, FAutoScrollInterval, nil); + DoStateChange([tsScrolling], [tsScrollPending]); + end; + DoTimerScroll; + end; + ChangeTimer: + if tsChangePending in FStates then // see issue #602 + DoChange(FLastChangedNode); + StructureChangeTimer: + DoStructureChange(FLastStructureChangeNode, FLastStructureChangeReason); + SearchTimer: + begin + // When this event triggers then the user did not pressed any key for the specified timeout period. + // Hence incremental searching is stopped. + DoStateChange([], [tsIncrementalSearching]); + StopTimer(SearchTimer); + FSearchBuffer := ''; + FLastSearchNode := nil; + end; + ThemeChangedTimer: + begin + StopTimer(ThemeChangedTimer); + RecreateWnd; + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.WMVScroll(var Message: TWMVScroll); + + //--------------- local functions ------------------------------------------- + + function GetRealScrollPosition: TDimension; + + var + SI: TScrollInfo; + Bar: Integer; + + begin + SI.cbSize := SizeOf(TScrollInfo); + SI.fMask := SIF_TRACKPOS; + Bar := SB_VERT; + GetScrollInfo(Bar, SI); + Result := SI.nTrackPos; + end; + + //--------------- end local functions --------------------------------------- + +begin + case Message.ScrollCode of + SB_BOTTOM: + SetOffsetY(-FRoot.TotalHeight); + SB_ENDSCROLL: + begin + DoStateChange([], [tsThumbTracking]); + // Avoiding to adjust the horizontal scroll position while tracking makes scrolling much smoother + // but we need to adjust the final position here then. + UpdateScrollBars(True); + // Really weird invalidation needed here (and I do it only because it happens so rarely), because + // when showing the horizontal scrollbar while scrolling down using the down arrow button, + // the button will be repainted on mouse up (at the wrong place in the far right lower corner)... + RedrawWindow(nil, 0, RDW_FRAME or RDW_INVALIDATE or RDW_NOERASE or RDW_NOCHILDREN); + end; + SB_LINEUP: + SetOffsetY(FOffsetY + FScrollBarOptions.VerticalIncrement); + SB_LINEDOWN: + SetOffsetY(FOffsetY - FScrollBarOptions.VerticalIncrement); + SB_PAGEUP: + SetOffsetY(FOffsetY + ClientHeight); + SB_PAGEDOWN: + SetOffsetY(FOffsetY - ClientHeight); + + SB_THUMBPOSITION, + SB_THUMBTRACK: + begin + DoStateChange([tsThumbTracking]); + SetOffsetY(-GetRealScrollPosition); + end; + SB_TOP: + SetOffsetY(0); + end; + Message.Result := 0; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.AddToSelection(Node: PVirtualNode; NotifySynced: Boolean); + +var + Changed: Boolean; + RemoveSyncAfterChange: Boolean; +begin + if not FSelectionLocked then + begin + Assert(Assigned(Node), 'Node must not be nil!'); + Changed := InternalAddToSelection(Node, False); + if Changed then + begin + UpdateNextNodeToSelect(Node); + if (SelectedCount = 1) then + FocusedNode := Node; // if only one node is selected, make sure the focused node changes with the selected node + InvalidateNode(Node); + RemoveSyncAfterChange := NotifySynced and not (tsSynchMode in fStates); + if RemoveSyncAfterChange then + Include(FStates, tsSynchMode); + try + Change(Node); + finally + if RemoveSyncAfterChange then + Exclude(FStates, tsSynchMode); + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.AddToSelection(const NewItems: TNodeArray; NewLength: Integer; ForceInsert: Boolean = False); + +// Adds the given items all at once into the current selection array. NewLength is the amount of +// nodes to add (necessary to allow NewItems to be larger than the actual used entries). +// ForceInsert is True if nodes must be inserted without consideration of level select constraint or +// already set selected flags (e.g. when loading from stream). +// Note: In the case ForceInsert is True the caller is responsible for making sure the new nodes aren't already in the +// selection array! + +var + Changed: Boolean; + +begin + Changed := InternalAddToSelection(NewItems, NewLength, ForceInsert); + if Changed then + begin + if NewLength = 1 then + begin + InvalidateNode(NewItems[0]); + Change(NewItems[0]); + end + else + begin + Invalidate; + Change(nil); + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.AdjustPaintCellRect(var PaintInfo: TVTPaintInfo; var NextNonEmpty: TColumnIndex); + +// Used in descendants to modify the paint rectangle of the current column while painting a certain node. + +begin + // Since cells are always drawn from left to right the next column index is independent of the + // bidi mode, but not the column borders, which might change depending on the cell's content. + NextNonEmpty := FHeader.Columns.GetNextVisibleColumn(PaintInfo.Column); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.AdjustPanningCursor(X, Y: TDimension); + +// Triggered by a mouse move when wheel panning/scrolling is active. +// Loads the proper cursor which indicates into which direction scrolling is done. + +var + NewCursor: TPanningCursor; + NewCursorHandle: HCURSOR; + ScrollHorizontal, + ScrollVertical: Boolean; + +begin + ScrollHorizontal := FRangeX > ClientWidth; + ScrollVertical := FRangeY > ClientHeight; + + if (Abs(X - FLastClickPos.X) < 8) and (Abs(Y - FLastClickPos.Y) < 8) then + begin + // Mouse is in the neutral zone. + if ScrollHorizontal then + begin + if ScrollVertical then + NewCursor := TPanningCursor.MOVEALL + else + NewCursor := TPanningCursor.MOVEEW; + end + else + NewCursor := TPanningCursor.MOVENS; + end + else + begin + // One of 8 directions applies: north, north-east, east, south-east, south, south-west, west and north-west. + // Check also if scrolling in the particular direction is possible. + if ScrollVertical and ScrollHorizontal then + begin + // All directions allowed. + if X - FLastClickPos.X < -8 then + begin + // Left hand side. + if Y - FLastClickPos.Y < -8 then + NewCursor := TPanningCursor.MOVENW + else + if Y - FLastClickPos.Y > 8 then + NewCursor := TPanningCursor.MOVESW + else + NewCursor := TPanningCursor.MOVEW; + end + else + if X - FLastClickPos.X > 8 then + begin + // Right hand side. + if Y - FLastClickPos.Y < -8 then + NewCursor := TPanningCursor.MOVENE + + else + if Y - FLastClickPos.Y > 8 then + NewCursor := TPanningCursor.MOVESE + else + NewCursor := TPanningCursor.MOVEE; + end + else + begin + // Up or down. + if Y < FLastClickPos.Y then + NewCursor := TPanningCursor.MOVEN + else + NewCursor := TPanningCursor.MOVES; + end; + end + else + if ScrollHorizontal then + begin + // Only horizontal movement allowed. + if X < FLastClickPos.X then + NewCursor := TPanningCursor.MOVEW + else + NewCursor := TPanningCursor.MOVEE; + end + else + begin + // Only vertical movement allowed. + if Y < FLastClickPos.Y then + NewCursor := TPanningCursor.MOVEN + else + NewCursor := TPanningCursor.MOVES; + end; + end; + + // Now load the cursor and apply it. + NewCursorHandle := LoadCursor(0, MAKEINTRESOURCE(NewCursor)); + if FPanningCursor <> NewCursorHandle then + begin + DeleteObject(FPanningCursor); + FPanningCursor := NewCursorHandle; + Winapi.Windows.SetCursor(FPanningCursor); + end + else + DeleteObject(NewCursorHandle); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.AdviseChangeEvent(StructureChange: Boolean; Node: PVirtualNode; Reason: TChangeReason); + +// Used to register a delayed change event. If StructureChange is False then we have a selection change event (without +// a specific reason) otherwise it is a structure change. + +begin + if StructureChange then + begin + if tsStructureChangePending in FStates then + StopTimer(StructureChangeTimer) + else + DoStateChange([tsStructureChangePending]); + + FLastStructureChangeNode := Node; + if FLastStructureChangeReason = crIgnore then + FLastStructureChangeReason := Reason + else + if Reason <> crIgnore then + FLastStructureChangeReason := crAccumulated; + end + else + begin + if tsChangePending in FStates then + StopTimer(ChangeTimer) + else + DoStateChange([tsChangePending]); + + FLastChangedNode := Node; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.AllocateInternalDataArea(Size: Cardinal): Cardinal; + +// Simple registration method to be called by each descendant to claim their internal data area. +// Result is the offset from the begin of the node to the internal data area of the calling tree class. + +begin + Assert((FRoot = nil) or (FRoot.ChildCount = 0), 'Internal data allocation must be done before any node is created.'); + Result := TreeNodeSize + FTotalInternalDataSize; + System.Inc(FTotalInternalDataSize, (Size + (SizeOf(Pointer) - 1)) and not (SizeOf(Pointer) - 1)); + InitRootNode(Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.Animate(Steps, Duration: Cardinal; Callback: TVTAnimationCallback; Data: Pointer); + +// This method does the calculation part of an animation as used for node toggling and hint animations. +// Steps is the maximum amount of animation steps to do and Duration determines the milliseconds the animation +// has to run. Callback is a task specific method which is called in the loop for every step and Data is simply +// something to pass on to the callback. +// The callback is called with the current step, the current step size and the Data parameter. Since the step amount +// as well as the step size are possibly adjusted during the animation, it is impossible to determine if the current +// step is the last step, even if the original step amount is known. To solve this problem the callback will be +// called after the loop has finished with a step size of 0 indicating so to execute any post processing. + +var + StepSize, + RemainingTime, + RemainingSteps, + NextTimeStep, + CurrentStep, + StartTime: Cardinal; + CurrentTime: Int64; + +begin + if not (tsInAnimation in FStates) and (Duration > 0) then + begin + DoStateChange([tsInAnimation]); + try + RemainingTime := Duration; + RemainingSteps := Steps; + + // Determine the initial step size which is either 1 if the needed steps are less than the number of + // steps possible given by the duration or > 1 otherwise. + StepSize := Round(Max(1, RemainingSteps / Duration)); + RemainingSteps := RemainingSteps div StepSize; + CurrentStep := 0; + + while (RemainingSteps > 0) and (RemainingTime > 0) and not Application.Terminated do + begin + StartTime := timeGetTime; + NextTimeStep := StartTime + RemainingTime div RemainingSteps; + if not Callback(CurrentStep, StepSize, Data) then + Break; + + // Keep duration for this step for rest calculation. + CurrentTime := timeGetTime; + // Wait until the calculated time has been reached. + while CurrentTime < NextTimeStep do + CurrentTime := timeGetTime; + + // Subtract the time this step really needed. + if RemainingTime >= CurrentTime - StartTime then + begin + System.Dec(RemainingTime, CurrentTime - StartTime); + System.Dec(RemainingSteps); + end + else + begin + RemainingTime := 0; + RemainingSteps := 0; + end; + // If the remaining time per step is less than one time step then we have to decrease the + // step count and increase the step size. + if (RemainingSteps > 0) and ((RemainingTime div RemainingSteps) < 1) then + begin + repeat + System.Inc(StepSize); + RemainingSteps := RemainingTime div StepSize; + until (RemainingSteps <= 0) or ((RemainingTime div RemainingSteps) >= 1); + end; + CurrentStep := Steps - RemainingSteps; + end; + + if not Application.Terminated then + Callback(0, 0, Data); + finally + DoStateChange([], [tsInAnimation]); + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.StartOperation(OperationKind: TVTOperationKind); + +// Called to indicate that a long-running operation has been started. + +begin + System.Inc(FOperationCount); + if FOperationCount = 1 then + FOperationCanceled := False; + DoStartOperation(OperationKind); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.CalculateSelectionRect(X, Y: TDimension): Boolean; + +// Recalculates old and new selection rectangle given that X, Y are new mouse coordinates. +// Returns True if there was a change since the last call. + +var + MaxValue: TDimension; + +begin + if tsDrawSelecting in FStates then + FLastSelRect := FNewSelRect; + FNewSelRect.BottomRight := Point(X + FEffectiveOffsetX, Y - FOffsetY); + if FNewSelRect.Right < 0 then + FNewSelRect.Right := 0; + if FNewSelRect.Bottom < 0 then + FNewSelRect.Bottom := 0; + MaxValue := ClientWidth; + if FRangeX > MaxValue then + MaxValue := FRangeX; + if FNewSelRect.Right > MaxValue then + FNewSelRect.Right := MaxValue; + MaxValue := ClientHeight; + if FRangeY > MaxValue then + MaxValue := FRangeY; + if FNewSelRect.Bottom > MaxValue then + FNewSelRect.Bottom := MaxValue; + + Result := not CompareMem(@FLastSelRect, @FNewSelRect, SizeOf(FNewSelRect)); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.CanAutoScroll: Boolean; + +// Determines if auto scrolling is currently allowed. + +var + IsDropTarget: Boolean; + IsDrawSelecting: Boolean; + IsWheelPanning: Boolean; + +begin + // Don't scroll the client area if the header is currently doing tracking or dragging. + // Do auto scroll only if there is a draw selection in progress or the tree is the current drop target or + // wheel panning/scrolling is active. + IsDropTarget := Assigned(FDragManager) and DragManager.IsDropTarget; + IsDrawSelecting := [tsDrawSelPending, tsDrawSelecting] * FStates <> []; + IsWheelPanning := tsPanning in FStates; + Result := ((toAutoScroll in FOptions.AutoOptions) or IsWheelPanning) and + (FHeader.States = []) and (IsDrawSelecting or IsDropTarget or (tsVCLDragging in FStates) or IsWheelPanning); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.CanShowDragImage: Boolean; + +// Determines whether a drag image should be shown. + +begin + Result := FDragImageKind <> diNoImage; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.CanSplitterResizeNode(P: TPoint; Node: PVirtualNode; Column: TColumnIndex): Boolean; + +begin + Result := (toNodeHeightResize in FOptions.MiscOptions) and Assigned(Node) and (Node <> FRoot) and + (Column > NoColumn) and (coFixed in FHeader.Columns[Column].Options); + DoCanSplitterResizeNode(P, Node, Column, Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.Change(Node: PVirtualNode); + +begin + AdviseChangeEvent(False, Node, crIgnore); + + if FUpdateCount = 0 then + begin + if (FChangeDelay > 0) and HandleAllocated and not (tsSynchMode in FStates) then + SetTimer(Handle, ChangeTimer, FChangeDelay, nil) + else + DoChange(Node); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.ChangeScale(M, D: Integer{$if CompilerVersion >= 31}; isDpiChange: Boolean{$ifend}); +begin + if (M <> D) then + begin + BeginUpdate(); + try + ScaleNodeHeights(M, D); + SetDefaultNodeHeight(MulDiv(FDefaultNodeHeight, M, D)); + Indent := MulDiv(Indent, M, D); + FTextMargin := MulDiv(FTextMargin, M, D); + FMargin := MulDiv(FMargin, M, D); + FImagesMargin := MulDiv(FImagesMargin, M, D); + finally + EndUpdate(); + end;//try..finally + end;// if M<>D + inherited ChangeScale(M, D{$if CompilerVersion >= 31}, isDpiChange{$ifend}); + if (M <> D) then + begin + // Scale header + TVTHeaderCracker(FHeader).ChangeScale(M, D); + // Scale utility images, #796 + if FCheckImageKind = ckSystemDefault then begin + FreeAndNil(FCheckImages); + if HandleAllocated then + FCheckImages := CreateSystemImageSet(); + end; + UpdateHeaderRect(); + PrepareBitmaps(True, False); // See issue #991 + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.ScaleNodeHeights(M, D: TDimension); +var + Run: PVirtualNode; + lNewNodeTotalHeight: Cardinal; +begin + // Scale also node heights + BeginUpdate(); + try + Run := GetFirstNoInit(); + while Assigned(Run) do + begin + if vsInitialized in Run.States then + SetNodeHeight(Run, MulDiv(Run.NodeHeight, M, D)) + else // prevent initialization of non-initialzed nodes + begin + Run.SetNodeHeight(MulDiv(Run.NodeHeight, M, D)); + // The next three lines fix issue #1000 + lNewNodeTotalHeight := MulDiv(Run.TotalHeight, M, D); + FRoot.TotalHeight := Cardinal(Int64(FRoot.TotalHeight) + Int64(lNewNodeTotalHeight) - Int64(Run.TotalHeight)); // Avoiding EIntOverflow exception. + Run.TotalHeight := lNewNodeTotalHeight; + end; + Run := GetNextNoInit(Run); + end; // while + finally + EndUpdate(); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.ChangeTreeStatesAsync(EnterStates, LeaveStates: TVirtualTreeStates); +begin + //TODO: If this works reliable, move to TWorkerThread + if not (csDestroying in ComponentState) then + begin + AtomicIncrement(FPendingSyncProcs); + TThread.Synchronize(nil, procedure + begin + //Decrement invoke refs + AtomicDecrement(FPendingSyncProcs); + // Prevent invalid combination tsUseCache + tsValidationNeeded (#915) + if not ((tsUseCache in EnterStates) and (tsValidationNeeded in FStates + LeaveStates)) then + DoStateChange(EnterStates, LeaveStates); + if (tsValidating in FStates) and (tsValidating in LeaveStates) then + UpdateEditBounds(); + end); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.CheckParentCheckState(Node: PVirtualNode; NewCheckState: TCheckState): Boolean; + +// Checks all siblings of node to determine which check state Node's parent must get. + +var + CheckCount, + BoxCount: Cardinal; + PartialCheck: Boolean; + Run: PVirtualNode; + +begin + CheckCount := 0; + BoxCount := 0; + PartialCheck := False; + Run := Node.Parent.FirstChild; + while Assigned(Run) do + begin + if Run = Node then + begin + // The given node cannot be checked because it does not yet have its new check state (as this depends + // on the outcome of this method). Instead NewCheckState is used as this contains the new state the node + // will get if this method returns True. + if Run.CheckType in [ctCheckBox, ctTriStateCheckBox] then + begin + System.Inc(BoxCount); + if NewCheckState.IsChecked then + System.Inc(CheckCount); + PartialCheck := PartialCheck or (NewCheckState = csMixedNormal); + end; + end + else + if Run.CheckType in [ctCheckBox, ctTriStateCheckBox] then + begin + System.Inc(BoxCount); + if GetCheckState(Run).IsChecked then + System.Inc(CheckCount); + PartialCheck := PartialCheck or (GetCheckState(Run) = csMixedNormal); + end; + Run := Run.NextSibling; + end; + + if (CheckCount = 0) and not PartialCheck then + NewCheckState := csUncheckedNormal + else + if CheckCount < BoxCount then + NewCheckState := csMixedNormal + else + NewCheckState := csCheckedNormal; + + Node := Node.Parent; + Result := DoChecking(Node, NewCheckState); + if Result then + begin + DoCheckClick(Node, NewCheckState); + // Recursively adjust parent of parent. + // This is already done in the function DoCheckClick() called in the above line + // We revent unnecessary upward recursion by commenting this code. + // with Node^ do + // begin + // if not (vsInitialized in Parent.States) then + // InitNode(Parent); + // if ([vsChecking, vsDisabled] * Parent.States = []) and (Parent <> FRoot) and + // (Parent.CheckType = ctTriStateCheckBox) then + // Result := CheckParentCheckState(Node, NewCheckState); + // end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.ClearTempCache; + +// make sure the temporary node cache is in a reliable state + +begin + FTempNodeCache := nil; + FTempNodeCount := 0; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.ColumnIsEmpty(Node: PVirtualNode; Column: TColumnIndex): Boolean; + +// Returns True if the given column is to be considered as being empty. This will usually be determined by +// descendants as the base tree implementation has not enough information to decide. + +begin + Result := True; + if Assigned(FOnGetCellIsEmpty) then + FOnGetCellIsEmpty(Self, Node, Column, Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.ComputeRTLOffset(ExcludeScrollBar: Boolean): TDimension; + +// Computes the horizontal offset needed when all columns are automatically right aligned (in RTL bidi mode). +// ExcludeScrollBar determines if the left-hand vertical scrollbar is to be included (if visible) or not. + +var + HeaderWidth: TDimension; + ScrollBarVisible: Boolean; +begin + ScrollBarVisible := (FRangeY > ClientHeight) and (ScrollBarOptions.ScrollBars in [TScrollStyle.ssVertical, TScrollStyle.ssBoth]); + if ScrollBarVisible then + Result := GetSystemMetrics(SM_CXVSCROLL) + else + Result := 0; + + // Make everything right aligned. + HeaderWidth := FHeaderRect.Right - FHeaderRect.Left; + if FRangeX + Result <= HeaderWidth then + Result := HeaderWidth - FRangeX; + // Otherwise take only left-hand vertical scrollbar into account. + + if ScrollBarVisible and ExcludeScrollBar then + Dec(Result, GetSystemMetrics(SM_CXVSCROLL)); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.CountLevelDifference(Node1, Node2: PVirtualNode): Integer; + +// This method counts how many indentation levels the given nodes are apart. If both nodes have the same parent then the +// difference is 0 otherwise the result is basically GetNodeLevel(Node2) - GetNodeLevel(Node1), but with sign. +// If the result is negative then Node2 is less intended than Node1. + +var + Level1, Level2: Integer; + +begin + Assert(Assigned(Node1) and Assigned(Node2), 'Both nodes must be Assigned.'); + + Level1 := 0; + while Node1.Parent <> FRoot do + begin + System.Inc(Level1); + Node1 := Node1.Parent; + end; + + Level2 := 0; + while Node2.Parent <> FRoot do + begin + System.Inc(Level2); + Node2 := Node2.Parent; + end; + + Result := Level2 - Level1; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.CountVisibleChildren(Node: PVirtualNode): Cardinal; + +// Returns the number of visible child nodes of the given node. + +begin + Result := 0; + + // The node's direct children... + if vsExpanded in Node.States then + begin + // ...and their children. + Node := Node.FirstChild; + while Assigned(Node) do + begin + if vsVisible in Node.States then + System.Inc(Result, CountVisibleChildren(Node) + Cardinal(IfThen(IsEffectivelyVisible[Node], 1))); + Node := Node.NextSibling; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.CreateParams(var Params: TCreateParams); + +const + ScrollBar: array[TScrollStyle] of Cardinal = (0, WS_HSCROLL, WS_VSCROLL, WS_HSCROLL or WS_VSCROLL); + +begin + inherited CreateParams(Params); + + with Params do + begin + Style := Style or WS_CLIPCHILDREN or WS_CLIPSIBLINGS or ScrollBar[ScrollBarOptions.ScrollBars]; + if toFullRepaintOnResize in FOptions.MiscOptions then + WindowClass.style := WindowClass.style or CS_HREDRAW or CS_VREDRAW + else + WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW); + if FBorderStyle = bsSingle then + begin + if Ctl3D then + begin + ExStyle := ExStyle or WS_EX_CLIENTEDGE; + Style := Style and not WS_BORDER; + end + else + Style := Style or WS_BORDER; + end + else + Style := Style and not WS_BORDER; + + AddBiDiModeExStyle(ExStyle); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.CreateWnd; + +// Initializes data which depends on a valid window handle. + +begin + VclStyleChanged(); // Moved here due to issue #986 + DoStateChange([tsWindowCreating]); + inherited; + DoStateChange([], [tsWindowCreating]); + + if not Assigned(FCheckImages) then + FCheckImages := CreateSystemImageSet(); + + if ((StyleServices.Enabled ) and (toThemeAware in TreeOptions.PaintOptions) ) then + begin + DoStateChange([tsUseThemes]); + if (toUseExplorerTheme in FOptions.PaintOptions) then + begin + DoStateChange([tsUseExplorerTheme]); + SetWindowTheme('explorer'); + end + else + DoStateChange([], [tsUseExplorerTheme]); + end + else + DoStateChange([], [tsUseThemes, tsUseExplorerTheme]); + + AutoScale(); + // Because of the special recursion and update stopper when creating the window (or resizing it) + // we have to manually trigger the auto size calculation here. + if hsNeedScaling in FHeader.States then + TVTHeaderCracker(FHeader).RescaleHeader; + if hoAutoResize in FHeader.Options then + TVirtualTreeColumnsCracker(FHeader.Columns).AdjustAutoSize(InvalidColumn); + + PrepareBitmaps(True, True); + + // Register tree as OLE drop target. + if not (csDesigning in ComponentState) and not (csLoading in ComponentState) and ((hoDrag in Header.Options) or (toAcceptOLEDrop in TreeOptions.MiscOptions)) then // will be done in Loaded after all inherited settings are loaded from the DFMs + RegisterDragDrop(Handle, DragManager as IDropTarget); + + UpdateScrollBars(True); + UpdateHeaderRect; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.FakeReadIdent(Reader: TReader); +begin + Assert(Reader.NextValue = vaIdent); + Reader.ReadIdent; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DecVisibleCount; +begin + System.Dec(FVisibleCount); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DefineProperties(Filer: TFiler); + +// There were heavy changes in some properties during development of VT. This method helps to make migration easier +// by reading old properties manually and put them into the new properties as appropriate. +// Note: these old properties are never written again and silently disappear. +// June 2002: Meanwhile another task is done here too: working around the problem that TCollection is not streamed +// correctly when using Visual Form Inheritance (VFI). + +var + StoreIt: Boolean; + +begin + inherited; + + // The header can prevent writing columns altogether. + if TVTHeaderCracker(FHeader).CanWriteColumns then + begin + // Check if we inherit from an ancestor form (Visual Form Inheritance). + StoreIt := Filer.Ancestor = nil; + // If there is an ancestor then save columns only if they are different to the base set. + if not StoreIt then + StoreIt := not FHeader.Columns.Equals(TBaseVirtualTree(Filer.Ancestor).FHeader.Columns); + end + else + StoreIt := False; + + Filer.DefineProperty('Columns', TVTHeaderCracker(FHeader).ReadColumns, TVTHeaderCracker(FHeader).WriteColumns, StoreIt); + + // #622 made old DFMs incompatible with new VTW - so the program is compiled successfully + // and then suddenly crashes at user site in runtime. + Filer.DefineProperty('CheckImageKind', FakeReadIdent, nil, false); + /// #730 removed property HintAnimation + Filer.DefineProperty('HintAnimation', FakeReadIdent, nil, false); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.DetermineDropMode(const P: TPoint; var HitInfo: THitInfo; var NodeRect: TRect): TDropMode; + +// Determine the DropMode. + +var + ImageHit: Boolean; + LabelHit: Boolean; + ItemHit: Boolean; + +begin + ImageHit := HitInfo.HitPositions * [hiOnNormalIcon, hiOnStateIcon] <> []; + LabelHit := hiOnItemLabel in HitInfo.HitPositions; + ItemHit := (hiOnItem in HitInfo.HitPositions); + + // In report mode only direct hits of the node captions/images in the main column are accepted as hits. + if (toReportMode in FOptions.MiscOptions) and not (ItemHit or ((LabelHit or ImageHit) and + (HitInfo.HitColumn = FHeader.MainColumn))) then + HitInfo.HitNode := nil; + + if Assigned(HitInfo.HitNode) then + begin + if LabelHit or ImageHit or not (toShowDropmark in FOptions.PaintOptions) then + Result := dmOnNode + else + if Divide(NodeRect.Top + NodeRect.Bottom, 2) > P.Y then + Result := dmAbove + else + Result := dmBelow; + end + else + Result := dmNowhere; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DetermineHiddenChildrenFlag(Node: PVirtualNode); + +// Update the hidden children flag of the given node. + +var + Run: PVirtualNode; + +begin + if Node.ChildCount = 0 then + begin + if vsHasChildren in Node.States then + Exclude(Node.States, vsAllChildrenHidden) + else + Include(Node.States, vsAllChildrenHidden); + end + else + begin + // Iterate through all siblings and stop when one visible is found. + Run := Node.FirstChild; + while Assigned(Run) and not IsEffectivelyVisible[Run] do + Run := Run.NextSibling; + if Assigned(Run) then + Exclude(Node.States, vsAllChildrenHidden) + else + Include(Node.States, vsAllChildrenHidden); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DetermineHiddenChildrenFlagAllNodes; + +var + Run: PVirtualNode; + +begin + Run := GetFirstNoInit(False); + while Assigned(Run) do + begin + DetermineHiddenChildrenFlag(Run); + Run := GetNextNoInit(Run); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DetermineHitPositionLTR(var HitInfo: THitInfo; Offset, Right: TDimension; + Alignment: TAlignment); + +// This method determines the hit position within a node with left-to-right orientation. + +var + MainColumnHit: Boolean; + lIndent, + TextWidth, + ImageOffset: TDimension; + lOffsets: TVTOffsets; +begin + MainColumnHit := HitInfo.HitColumn = FHeader.MainColumn; + GetOffsets(HitInfo.HitNode, lOffsets, ofsRightOfText, HitInfo.HitColumn); + + if (MainColumnHit and (Offset < lOffsets[ofsCheckbox])) then + begin + // Position is to the left of calculated indentation which can only happen for the main column. + // Check whether it corresponds to a button/checkbox. + if (toShowButtons in FOptions.PaintOptions) and (vsHasChildren in HitInfo.HitNode.States) then + begin + // Position of button is interpreted very generously to avoid forcing the user + // to click exactly into the 9x9 pixels area. The entire node height and one full + // indentation level is accepted as button hit. + if Offset >= lOffsets[ofsCheckbox] - FIndent then + Include(HitInfo.HitPositions, hiOnItemButton); + if Offset > lOffsets[ofsToggleButton] then + Include(HitInfo.HitPositions, hiOnItemButtonExact); + end; + // no button hit so position is on indent + if HitInfo.HitPositions = [] then + Include(HitInfo.HitPositions, hiOnItemIndent); + end + else + begin + // The next hit positions can be: + // - on the check box + // - on the state image + // - on the normal image + // - to the left of the text area + // - on the label or + // - to the right of the text area + // (in this order). + + // In report mode no hit other than in the main column is possible. + if MainColumnHit or not (toReportMode in FOptions.MiscOptions) then + begin + if MainColumnHit and (Offset < lOffsets[ofsStateImage]) then + begin + HitInfo.HitPositions := [hiOnItem]; + if (HitInfo.HitNode.CheckType <> ctNone) then + Include(HitInfo.HitPositions, hiOnItemCheckBox); + end + else + begin + ImageOffset := lOffsets[ofsImage]; + if Offset < ImageOffset then + Include(HitInfo.HitPositions, hiOnStateIcon) + else + begin + ImageOffset := lOffsets[ofsLabel]; + if Offset < ImageOffset then + Include(HitInfo.HitPositions, hiOnNormalIcon) + else + begin + TextWidth := lOffsets[ofsRightOfText] - lOffsets[ofsText]; + // ImageOffset contains now the left border of the node label area. This is used to calculate the + // correct alignment in the column. + + // Check if the text can be aligned at all. This is only possible if there is enough room + // in the remaining text rectangle. + if TextWidth > Right - ImageOffset then + Include(HitInfo.HitPositions, hiOnItemLabel) + else + begin + case Alignment of + taCenter: + begin + lIndent := Divide(ImageOffset + Right - TextWidth, 2); + if Offset < lIndent then + Include(HitInfo.HitPositions, hiOnItemLeft) + else + if Offset < lIndent + TextWidth then + Include(HitInfo.HitPositions, hiOnItemLabel) + else + Include(HitInfo.HitPositions, hiOnItemRight); + end; + taRightJustify: + begin + lIndent := Right - TextWidth; + if Offset < lIndent then + Include(HitInfo.HitPositions, hiOnItemLeft) + else + Include(HitInfo.HitPositions, hiOnItemLabel); + end; + else // taLeftJustify + if Offset < ImageOffset + TextWidth then + Include(HitInfo.HitPositions, hiOnItemLabel) + else + Include(HitInfo.HitPositions, hiOnItemRight); + end; + end; + end; + end; + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DetermineHitPositionRTL(var HitInfo: THitInfo; Offset, Right: TDimension; Alignment: TAlignment); + +// This method determines the hit position within a node with right-to-left orientation. + +var + MainColumnHit: Boolean; + Run: PVirtualNode; + Indent, + TextWidth, + ImageOffset: TDimension; + +begin + MainColumnHit := HitInfo.HitColumn = FHeader.MainColumn; + + // If columns are not used or the main column is hit then the tree indentation must be considered too. + if MainColumnHit then + begin + if toFixedIndent in FOptions.PaintOptions then + Dec(Right, FIndent) + else + begin + Run := HitInfo.HitNode; + while (Run.Parent <> FRoot) do + begin + Dec(Right, FIndent); + Run := Run.Parent; + end; + if toShowRoot in FOptions.PaintOptions then + Dec(Right, FIndent); + end; + end; + + if Offset >= Right then + begin + // Position is to the right of calculated indentation which can only happen for the main column. + // Check whether it corresponds to a button/checkbox. + if (toShowButtons in FOptions.PaintOptions) and (vsHasChildren in HitInfo.HitNode.States) then + begin + // Position of button is interpreted very generously to avoid forcing the user + // to click exactly into the 9x9 pixels area. The entire node height and one full + // indentation level is accepted as button hit. + if Offset <= Right + FIndent then + Include(HitInfo.HitPositions, hiOnItemButton); + if Offset <= Right + FPlusBM.Width then + Include(HitInfo.HitPositions, hiOnItemButtonExact); + end; + // no button hit so position is on indent + if HitInfo.HitPositions = [] then + Include(HitInfo.HitPositions, hiOnItemIndent); + end + else + begin + // The next hit positions can be: + // - on the check box + // - on the state image + // - on the normal image + // - to the left of the text area + // - on the label or + // - to the right of the text area + // (in this order). + + // In report mode no hit other than in the main column is possible. + if MainColumnHit or not (toReportMode in FOptions.MiscOptions) then + begin + ImageOffset := Right - FMargin; + + // Check support is only available for the main column. + if MainColumnHit and (toCheckSupport in FOptions.MiscOptions) and Assigned(FCheckImages) and + (HitInfo.HitNode.CheckType <> ctNone) then + Dec(ImageOffset, FCheckImages.Width + FImagesMargin); + + if MainColumnHit and (Offset > ImageOffset) then + begin + HitInfo.HitPositions := [hiOnItem]; + if (HitInfo.HitNode.CheckType <> ctNone) then + Include(HitInfo.HitPositions, hiOnItemCheckBox); + end + else + begin + Dec(ImageOffset, GetImageSize(HitInfo.HitNode, ikState, HitInfo.HitColumn).cx); + if Offset > ImageOffset then + Include(HitInfo.HitPositions, hiOnStateIcon) + else + begin + Dec(ImageOffset, GetImageSize(HitInfo.HitNode, ikNormal, HitInfo.HitColumn).cx); + if Offset > ImageOffset then + Include(HitInfo.HitPositions, hiOnNormalIcon) + else + begin + // ImageOffset contains now the right border of the node label area. This is used to calculate the + // correct alignment in the column. + TextWidth := DoGetNodeWidth(HitInfo.HitNode, HitInfo.HitColumn); + + // Check if the text can be aligned at all. This is only possible if there is enough room + // in the remaining text rectangle. + if TextWidth > ImageOffset then + Include(HitInfo.HitPositions, hiOnItemLabel) + else + begin + // Consider bidi mode here. In RTL context does left alignment actually mean right alignment + // and vice versa. + ChangeBiDiModeAlignment(Alignment); + + case Alignment of + taCenter: + begin + Indent := Divide(ImageOffset - TextWidth, 2); + if Offset < Indent then + Include(HitInfo.HitPositions, hiOnItemLeft) + else + if Offset < Indent + TextWidth then + Include(HitInfo.HitPositions, hiOnItemLabel) + else + Include(HitInfo.HitPositions, hiOnItemRight); + end; + taRightJustify: + begin + Indent := ImageOffset - TextWidth; + if Offset < Indent then + Include(HitInfo.HitPositions, hiOnItemLeft) + else + Include(HitInfo.HitPositions, hiOnItemLabel); + end; + else // taLeftJustify + if Offset > TextWidth then + Include(HitInfo.HitPositions, hiOnItemRight) + else + Include(HitInfo.HitPositions, hiOnItemLabel); + end; + end; + end; + end; + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.DetermineLineImageAndSelectLevel(Node: PVirtualNode; var LineImage: TLineImage): Integer; + +// This method is used during paint cycles and initializes an array of line type IDs. These IDs are used to paint +// the tree lines in front of the given node. +// Additionally an initial count of selected parents is determined and returned which is used for specific painting. + +var + X: Integer; + Indent: Integer; + Run: PVirtualNode; + +begin + Result := 0; + if toShowRoot in FOptions.PaintOptions then + X := 1 + else + X := 0; + Run := Node; + // Determine indentation level of top node. + while Run.Parent <> FRoot do + begin + System.Inc(X); + Run := Run.Parent; + // Count selected nodes (FRoot is never selected). + if vsSelected in Run.States then + System.Inc(Result); + end; + + // Set initial size of line index array, this will automatically initialized all entries to ltNone. + SetLength(LineImage, X); + Indent := X - 1; + + // Only use lines if requested. + if (toShowTreeLines in FOptions.PaintOptions) and + (not (toHideTreeLinesIfThemed in FOptions.PaintOptions) or not (tsUseThemes in FStates)) then + begin + if toChildrenAbove in FOptions.PaintOptions then + begin + System.Dec(X); + if not HasVisiblePreviousSibling(Node) then + begin + if (Node.Parent <> FRoot) or HasVisibleNextSibling(Node) then + LineImage[X] := ltBottomRight + else + LineImage[X] := ltRight; + end + else + if (Node.Parent = FRoot) and (not HasVisibleNextSibling(Node)) then + LineImage[X] := ltTopRight + else + LineImage[X] := ltTopDownRight; + + // Now go up to the root to determine the rest. + Run := Node.Parent; + while Run <> FRoot do + begin + System.Dec(X); + if HasVisiblePreviousSibling(Run) then + LineImage[X] := ltTopDown + else + LineImage[X] := ltNone; + + Run := Run.Parent; + end; + end + else + begin + // Start over parent traversal if necessary. + Run := Node; + + if Run.Parent <> FRoot then + begin + // The very last image (the one immediately before the item label) is different. + if HasVisibleNextSibling(Run) then + LineImage[X - 1] := ltTopDownRight + else + LineImage[X - 1] := ltTopRight; + Run := Run.Parent; + + // Now go up all parents. + repeat + if Run.Parent = FRoot then + Break; + System.Dec(X); + if HasVisibleNextSibling(Run) then + LineImage[X - 1] := ltTopDown + else + LineImage[X - 1] := ltNone; + Run := Run.Parent; + until False; + end; + + // Prepare root level. Run points at this stage to a top level node. + if (toShowRoot in FOptions.PaintOptions) and ((toShowTreeLines in FOptions.PaintOptions) and + (not (toHideTreeLinesIfThemed in FOptions.PaintOptions) or not (tsUseThemes in FStates))) then + begin + // Is the top node a root node? + if Run = Node then + begin + // First child gets the bottom-right bitmap if it isn't also the only child. + if IsFirstVisibleChild(FRoot, Run) then + // Is it the only child? + if IsLastVisibleChild(FRoot, Run) then + LineImage[0] := ltRight + else + LineImage[0] := ltBottomRight + else + // real last child + if IsLastVisibleChild(FRoot, Run) then + LineImage[0] := ltTopRight + else + LineImage[0] := ltTopDownRight; + end + else + begin + // No, top node is not a top level node. So we need different painting. + if HasVisibleNextSibling(Run) then + LineImage[0] := ltTopDown + else + LineImage[0] := ltNone; + end; + end; + end; + end; + + if (tsUseExplorerTheme in FStates) and HasChildren[Node] and (Indent >= 0) + and not ((vsAllChildrenHidden in Node.States) and (toAutoHideButtons in TreeOptions.AutoOptions)) then + LineImage[Indent] := ltNone; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.DetermineNextCheckState(CheckType: TCheckType; CheckState: TCheckState): TCheckState; + +// Determines the next check state in case the user click the check image or pressed the space key. + +begin + case CheckType of + ctTriStateCheckBox, + ctButton, + ctCheckBox: + begin + Result := CheckState.GetToggled(); + end;//ctCheckbox + ctRadioButton: + Result := csCheckedNormal; + else + Result := csMixedNormal; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.DetermineScrollDirections(X, Y: TDimension): TScrollDirections; + +// Determines which direction the client area must be scrolled depending on the given position. + +begin + Result:= []; + + if CanAutoScroll then + begin + // Calculation for wheel panning/scrolling is a bit different to normal auto scroll. + if tsPanning in FStates then + begin + if (X - FLastClickPos.X) < -8 then + Include(Result, TScrollDirection.sdLeft); + if (X - FLastClickPos.X) > 8 then + Include(Result, TScrollDirection.sdRight); + + if (Y - FLastClickPos.Y) < -8 then + Include(Result, TScrollDirection.sdUp); + if (Y - FLastClickPos.Y) > 8 then + Include(Result, TScrollDirection.sdDown); + end + else + begin + if (X < FDefaultNodeHeight) and (FEffectiveOffsetX <> 0) then + Include(Result, TScrollDirection.sdLeft); + if (ClientWidth + FEffectiveOffsetX < FRangeX) and (X > ClientWidth - FDefaultNodeHeight) then + Include(Result, TScrollDirection.sdRight); + + if (Y < FDefaultNodeHeight) and (FOffsetY <> 0) then + Include(Result, TScrollDirection.sdUp); + if (ClientHeight - FOffsetY < FRangeY) and (Y > ClientHeight - FDefaultNodeHeight) then + Include(Result, TScrollDirection.sdDown); + + // Since scrolling during dragging is not handled via the timer we do a check here whether the auto + // scroll timeout already has elapsed or not. + if (Result <> []) and + ((Assigned(FDragManager) and DragManager.IsDropTarget) or + (FindDragTarget(Point(X, Y), False) = Self)) then + begin + if FDragScrollStart = 0 then + FDragScrollStart := timeGetTime; + // Reset any scroll direction to avoid scroll in the case the user is dragging and the auto scroll time has not + // yet elapsed. + if ((Int64(timeGetTime) - FDragScrollStart) < FAutoScrollDelay) then + Result := []; + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoAddToSelection(Node: PVirtualNode); +begin + if Assigned(FOnAddToSelection) then + FOnAddToSelection(Self, Node); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoAdvancedHeaderDraw(var PaintInfo: THeaderPaintInfo; const Elements: THeaderPaintElements); + +begin + if Assigned(FOnAdvancedHeaderDraw) then + FOnAdvancedHeaderDraw(FHeader, PaintInfo, Elements); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoAfterCellPaint(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; CellRect: TRect); + +begin + if Assigned(FOnAfterCellPaint) then + FOnAfterCellPaint(Self, Canvas, Node, Column, CellRect); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoAfterItemErase(Canvas: TCanvas; Node: PVirtualNode; ItemRect: TRect); + +begin + if Assigned(FOnAfterItemErase) then + FOnAfterItemErase(Self, Canvas, Node, ItemRect); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoAfterItemPaint(Canvas: TCanvas; Node: PVirtualNode; ItemRect: TRect); + +begin + if Assigned(FOnAfterItemPaint) then + FOnAfterItemPaint(Self, Canvas, Node, ItemRect); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoAfterPaint(Canvas: TCanvas); + +begin + if Assigned(FOnAfterPaint) then + FOnAfterPaint(Self, Canvas); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoAutoScroll(X, Y: TDimension); + +begin + FScrollDirections := DetermineScrollDirections(X, Y); + + if not (tsPanning in FStates) then + begin + if FScrollDirections = [] then + begin + if ((FStates * [tsScrollPending, tsScrolling]) <> []) then + begin + StopTimer(ScrollTimer); + DoStateChange([], [tsScrollPending, tsScrolling]); + end; + end + else + begin + // start auto scroll if not yet done + if (FStates * [tsScrollPending, tsScrolling]) = [] then + begin + DoStateChange([tsScrollPending]); + SetTimer(Handle, ScrollTimer, FAutoScrollDelay, nil); + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.DoBeforeDrag(Node: PVirtualNode; Column: TColumnIndex): Boolean; + +begin + Result := False; + if Assigned(FOnDragAllowed) then + FOnDragAllowed(Self, Node, Column, Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoBeforeCellPaint(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; + CellPaintMode: TVTCellPaintMode; CellRect: TRect; var ContentRect: TRect); + +var + UpdateRect: TRect; + +begin + if Assigned(FOnBeforeCellPaint) then + begin + if CellPaintMode = cpmGetContentMargin then + begin + // Prevent drawing if we are only about to get the margin. As this also clears the update rect we need to save it. + GetUpdateRect(Handle, UpdateRect, False); + SetUpdateState(True); + end; + + Canvas.Font.Assign(Self.Font); // Fixes issue #298 + FOnBeforeCellPaint(Self, Canvas, Node, Column, CellPaintMode, CellRect, ContentRect); + + if CellPaintMode = cpmGetContentMargin then + SetUpdateState(False); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoBeforeItemErase(Canvas: TCanvas; Node: PVirtualNode; ItemRect: TRect; var Color: TColor; + var EraseAction: TItemEraseAction); + +begin + if Assigned(FOnBeforeItemErase) then + FOnBeforeItemErase(Self, Canvas, Node, ItemRect, Color, EraseAction); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.DoBeforeItemPaint(Canvas: TCanvas; Node: PVirtualNode; ItemRect: TRect): Boolean; + +begin + // By default custom draw will not be used, so the tree handles drawing the node. + Result := False; + if Assigned(FOnBeforeItemPaint) then + FOnBeforeItemPaint(Self, Canvas, Node, ItemRect, Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoBeforePaint(Canvas: TCanvas); + +begin + if Assigned(FOnBeforePaint) then + FOnBeforePaint(Self, Canvas); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.DoCancelEdit(): Boolean; + +// Called when the current edit action or a pending edit must be cancelled. + +begin + Result := DoEndEdit(True); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.DoEndEdit(pCancel: Boolean = False): Boolean; + +// Called to finish a current edit action or stop the edit timer if an edit operation is pending. +// Pass True if the edit should be cancelled, pass False if the new text should be used and saved. +// Returns True if editing was successfully ended/canceled or the control was not in edit mode. +// Returns False if the control could not leave the edit mode e.g. due to an invalid value that was entered. + +begin + StopTimer(EditTimer); + DoStateChange([], [tsEditPending]); + if not (tsEditing in FStates) then + Exit(True); + if pCancel then + Result := FEditLink.CancelEdit + else + Result := FEditLink.EndEdit; + if Result then + begin + DoStateChange([], [tsEditing]); + FEditLink := nil; + if Assigned(FOnEdited) then + FOnEdited(Self, FFocusedNode, FEditColumn); + end; + TrySetFocus(); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoCanEdit(Node: PVirtualNode; Column: TColumnIndex; var Allowed: Boolean); + +begin + if Assigned(FOnEditing) then + FOnEditing(Self, Node, Column, Allowed); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoCanSplitterResizeNode(P: TPoint; Node: PVirtualNode; Column: TColumnIndex; + var Allowed: Boolean); + +begin + if Assigned(FOnCanSplitterResizeNode) then + FOnCanSplitterResizeNode(Self, P, Node, Column, Allowed); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoChange(Node: PVirtualNode); + +begin + StopTimer(ChangeTimer); + if Assigned(FOnChange) then + FOnChange(Self, Node); + + // This is a good place to reset the cached node. This is the same as the node passed in here. + // This is necessary to allow descendants to override this method and get the node then. + DoStateChange([], [tsChangePending]); + FLastChangedNode := nil; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoCheckClick(Node: PVirtualNode; NewCheckState: TCheckState); + +begin + if ChangeCheckState(Node, NewCheckState) then + begin + DoChecked(Node); + if SyncCheckstateWithSelection[Node] then + begin + // selection should follow check state + if (NewCheckState = csCheckedNormal) then + Selected[node] := true + else + Selected[node] := false; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoChecked(Node: PVirtualNode); + +begin + if Assigned(FOnChecked) then + FOnChecked(Self, Node); + if (Self.UpdateCount = 0) then // See issue #1174 + NotifyAccessibleEvent(); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.DoChecking(Node: PVirtualNode; var NewCheckState: TCheckState): Boolean; + +// Determines if a node is allowed to change its check state to NewCheckState. + +begin + if (toReadOnly in FOptions.MiscOptions) or (vsDisabled in Node.States) then + Result := False + else + begin + Result := True; + if Assigned(FOnChecking) then + FOnChecking(Self, Node, NewCheckState, Result); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoCollapsed(Node: PVirtualNode); +var + lFirstSelected: PVirtualNode; + lParent: PVirtualNode; +begin + if Assigned(FOnCollapsed) then + FOnCollapsed(Self, Node); + + if (Self.UpdateCount = 0) then // See issue #1174 + NotifyAccessibleEvent(); + + if (toAlwaysSelectNode in TreeOptions.SelectionOptions) then + begin + // Select the next visible parent if the currently selected node gets invisible due to a collapse + // This makes the VT behave more like the Win32 custom TreeView control + // This makes only sense no no multi selection is allowed and if there is a selected node at all + lFirstSelected := GetFirstSelected(); + if Assigned(lFirstSelected) and not FullyVisible[lFirstSelected] then + begin + lParent := GetVisibleParent(lFirstSelected); + Selected[lFirstSelected] := False; + Selected[lParent] := True; + end;//if + //if there is (still) no selected node, then use FNextNodeToSelect to select one + if SelectedCount = 0 then + EnsureNodeSelected(False); + end;//if +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.DoCollapsing(Node: PVirtualNode): Boolean; + +begin + Result := True; + if Assigned(FOnCollapsing) then + FOnCollapsing(Self, Node, Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoColumnChecked(Column: TColumnIndex); +begin + if Assigned(FOnColumnChecked) then + FOnColumnChecked(Self.FHeader, Column); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.DoColumnChecking(Column: TColumnIndex; var NewCheckState: TCheckState): Boolean; + +// Determines if a column is allowed to change its check state to NewCheckState. + +begin + Result := True; + if Assigned(FOnColumnChecking) then + FOnColumnChecking(Self.Header, Column, NewCheckState, Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoColumnClick(Column: TColumnIndex; Shift: TShiftState); + +begin + if Assigned(FOnColumnClick) then + FOnColumnClick(Self, Column, Shift); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoColumnDblClick(Column: TColumnIndex; Shift: TShiftState); + +begin + if Assigned(FOnColumnDblClick) then + FOnColumnDblClick(Self, Column, Shift); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoColumnHeaderSpanning(Column: TColumnIndex; var Count: Integer); +begin + if Assigned(FOnColumnHeaderSpanning) then + FOnColumnHeaderSpanning(Self.Header, Column, Count); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoColumnResize(Column: TColumnIndex); + +var + R: TRect; + Run: PVirtualNode; + +begin + if not (csLoading in ComponentState) and HandleAllocated then + begin + // Reset all vsHeightMeasured flags if we are in multiline mode. + Run := GetFirstInitialized; + while Assigned(Run) do + begin + if vsMultiline in Run.States then + Exclude(Run.States, vsHeightMeasured); + Run := GetNextInitialized(Run); + end; + if Header.Columns.UpdateCount = 0 then + UpdateHorizontalScrollBar(True); + if Column > NoColumn then + begin + // Invalidate client area from the current column all to the right (or left in RTL mode). + R := ClientRect; + if not (toAutoSpanColumns in FOptions.AutoOptions) then + if UseRightToLeftAlignment then + R.Right := FHeader.Columns[Column].Left + FHeader.Columns[Column].Width + ComputeRTLOffset + else + R.Left := FHeader.Columns[Column].Left; + InvalidateRect(@R, False); + FHeader.Invalidate(FHeader.Columns[Column], True); + end; + if [hsColumnWidthTracking, hsResizing] * FHeader.States = [hsColumnWidthTracking] then + UpdateWindow(); + + if not (IsUpdating) then + UpdateDesigner; // design time only + + if Assigned(FOnColumnResize) and not (hsResizing in FHeader.States) then + FOnColumnResize(FHeader, Column); + + // If the tree is currently in edit state then notify edit link. + if tsEditing in FStates then + UpdateEditBounds; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoColumnVisibilityChanged(const Column: TColumnIndex; Visible: Boolean); + // Triggers the OnColumnVisibilityChanged event. +begin + if Assigned(OnColumnVisibilityChanged) then + OnColumnVisibilityChanged(Self, Column, Visible); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.DoCompare(Node1, Node2: PVirtualNode; Column: TColumnIndex): Integer; + +begin + Result := 0; + if Assigned(FOnCompareNodes) then + FOnCompareNodes(Self, Node1, Node2, Column, Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.DoCreateDataObject: IDataObject; + +begin + Result := nil; + if Assigned(FOnCreateDataObject) then + FOnCreateDataObject(Self, Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.DoCreateDragManager: IVTDragManager; + +begin + Result := nil; + if Assigned(FOnCreateDragManager) then + FOnCreateDragManager(Self, Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.DoCreateEditor(Node: PVirtualNode; Column: TColumnIndex): IVTEditLink; + +begin + Result := nil; + if Assigned(FOnCreateEditor) then + FOnCreateEditor(Self, Node, Column, Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoDragging(P: TPoint); + +// Initiates finally the drag'n drop operation and returns after DD is finished. + + //--------------- local function -------------------------------------------- + + function GetDragOperations: Integer; + + begin + if FDragOperations = [] then + Result := DROPEFFECT_COPY or DROPEFFECT_MOVE or DROPEFFECT_LINK + else + begin + Result := 0; + if doCopy in FDragOperations then + Result := Result or DROPEFFECT_COPY; + if doLink in FDragOperations then + Result := Result or DROPEFFECT_LINK; + if doMove in FDragOperations then + Result := Result or DROPEFFECT_MOVE; + end; + end; + + //--------------- end local function ---------------------------------------- + +var + AllowedEffects: Integer; + DragObject: TDragObject; + + DataObject: IDataObject; + +begin + DataObject := nil; + // Dragging is dragging, nothing else. + DoCancelEdit; + + if Assigned(FCurrentHotNode) then + begin + InvalidateNode(FCurrentHotNode); + FCurrentHotNode := nil; + end; + // Select the focused node if not already done. + if Assigned(FFocusedNode) and not (vsSelected in FFocusedNode.States) then + begin + InternalAddToSelection(FFocusedNode, False); + InvalidateNode(FFocusedNode); + end; + + UpdateWindow(); + + // Keep a list of all currently selected nodes as this list might change, + // but we have probably to delete currently selected nodes. + FDragSelection := GetSortedSelection(True); + try + DoStateChange([tsOLEDragging], [tsOLEDragPending, tsClearPending]); + + // An application might create a drag object like used during VCL dd. This is not required for OLE dd but + // required as parameter. + DragObject := nil; + DoStartDrag(DragObject); + DragObject.Free; + + DataObject := DragManager.DataObject; + PrepareDragImage(P, DataObject); + + FLastDropMode := dmOnNode; + // Don't forget to initialize the result. It might never be touched. + FLastDragEffect := DROPEFFECT_NONE; + AllowedEffects := GetDragOperations; + try + DragAndDrop(AllowedEffects, DataObject, FLastDragEffect); + DragManager.ForceDragLeave; + finally + GetCursorPos(P); + P := ScreenToClient(P); + DoEndDrag(Self, P.X, P.Y); + + // Finish the operation. + if (FLastDragEffect = DROPEFFECT_MOVE) and (toAutoDeleteMovedNodes in TreeOptions.AutoOptions) then + begin + // The operation was a move so delete the previously selected nodes. + DeleteSelectedNodes; + end; + + DoStateChange([], [tsOLEDragging]); + end; + finally + FDragSelection := nil; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoDragExpand; +begin + StopTimer(ExpandTimer); + if Assigned(FDropTargetNode) and (vsHasChildren in FDropTargetNode.States) and + not (vsExpanded in FDropTargetNode.States) then + begin + ToggleNode(FDropTargetNode); + UpdateWindow(); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.DoDragOver(Source: TObject; Shift: TShiftState; State: TDragState; Pt: TPoint; Mode: TDropMode; + var Effect: Integer): Boolean; + +begin + Result := False; + if Assigned(FOnDragOver) then + FOnDragOver(Self, Source, Shift, State, Pt, Mode, Effect, Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoDragDrop(Source: TObject; const DataObject: TVTDragDataObject; const Formats: TFormatArray; + Shift: TShiftState; Pt: TPoint; var Effect: Integer; Mode: TDropMode); + +begin + if Assigned(FOnDragDrop) then + FOnDragDrop(Self, Source, DataObject, Formats, Shift, Pt, Effect, Mode); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoBeforeDrawLineImage(Node: PVirtualNode; Level: Integer; var XPos: TDimension); + +begin + if Assigned(FOnBeforeDrawLineImage) then + FOnBeforeDrawLineImage(Self, Node, Level, XPos); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoEdit; + +begin + Application.CancelHint; + StopTimer(ScrollTimer); + StopTimer(EditTimer); + DoStateChange([], [tsEditPending]); + if Assigned(FFocusedNode) and not (vsDisabled in FFocusedNode.States) and + not (toReadOnly in FOptions.MiscOptions) and (FEditLink = nil) then + begin + InternalSetFocusedColumn(FEditColumn); + ScrollIntoView(FFocusedNode, toCenterScrollIntoView in FOptions.SelectionOptions, not (toDisableAutoscrollOnEdit in FOptions.AutoOptions)); + FEditLink := DoCreateEditor(FFocusedNode, FEditColumn); + if Assigned(FEditLink) then + begin + DoStateChange([tsEditing], [tsDrawSelecting, tsDrawSelPending, tsToggleFocusedSelection, tsOLEDragPending, + tsOLEDragging, tsClearPending, tsDrawSelPending, tsScrollPending, tsScrolling]); + if FEditLink.PrepareEdit(Self, FFocusedNode, FEditColumn) then + begin + UpdateEditBounds; + // Node needs repaint because the selection rectangle and static text must disappear. + InvalidateNode(FFocusedNode); + if not FEditLink.BeginEdit then + DoStateChange([], [tsEditing]); + end + else + DoStateChange([], [tsEditing]); + if not (tsEditing in FStates) then + FEditLink := nil; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoEndDrag(Target: TObject; X, Y: TDimension); + +// Does some housekeeping for VCL drag'n drop; + +begin + inherited; + + DragFinished; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoEndOperation(OperationKind: TVTOperationKind); + +begin + if Assigned(FOnEndOperation) then + FOnEndOperation(Self, OperationKind); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoEnter(); +begin + inherited; + EnsureNodeSelected(False); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoExpanded(Node: PVirtualNode); + +begin + if Assigned(FOnExpanded) then + FOnExpanded(Self, Node); + if (Self.UpdateCount = 0) then // See issue #1174 + NotifyAccessibleEvent(); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.DoExpanding(Node: PVirtualNode): Boolean; + +begin + Result := True; + if Assigned(FOnExpanding) then + FOnExpanding(Self, Node, Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoFocusChange(Node: PVirtualNode; Column: TColumnIndex); + +begin + if Assigned(FOnFocusChanged) then + FOnFocusChanged(Self, Node, Column); + NotifyAccessibleEvent(EVENT_OBJECT_LOCATIONCHANGE); + NotifyAccessibleEvent(EVENT_OBJECT_NAMECHANGE); + NotifyAccessibleEvent(EVENT_OBJECT_VALUECHANGE); + NotifyAccessibleEvent(EVENT_OBJECT_STATECHANGE); + NotifyAccessibleEvent(EVENT_OBJECT_SELECTION); + NotifyAccessibleEvent(EVENT_OBJECT_FOCUS); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.DoFocusChanging(OldNode, NewNode: PVirtualNode; OldColumn, NewColumn: TColumnIndex): Boolean; + +begin + Result := (OldColumn = NewColumn) or FHeader.AllowFocus(NewColumn); + if Assigned(FOnFocusChanging) then + FOnFocusChanging(Self, OldNode, NewNode, OldColumn, NewColumn, Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoFocusNode(Node: PVirtualNode; Ask: Boolean); + +begin + if not (tsEditing in FStates) or EndEditNode then + begin + if Node = FRoot then + Node := nil; + if (FFocusedNode <> Node) and (not Ask or DoFocusChanging(FFocusedNode, Node, FFocusedColumn, FFocusedColumn)) then + begin + if Assigned(FFocusedNode) then + begin + // Do automatic collapsing of last focused node if enabled. This is however only done if + // old and new focused node have a common parent node. + if (toAutoExpand in FOptions.AutoOptions) and Assigned(Node) and (Node.Parent = FFocusedNode.Parent) and + (vsExpanded in FFocusedNode.States) then + ToggleNode(FFocusedNode) + else + InvalidateNode(FFocusedNode); + end; + FFocusedNode := Node; + end; + + // Have to scroll the node into view, even it is the same node as before. + if Assigned(FFocusedNode) then + begin + // Make sure a valid column is set if columns are used and no column has currently the focus. + // We should also check if the maincolumn is allowfocus + if FHeader.UseColumns and (not FHeader.Columns.IsValidColumn(FFocusedColumn)) + and FHeader.AllowFocus(FHeader.MainColumn) then + FFocusedColumn := FHeader.MainColumn; + // Do automatic expansion of the newly focused node if enabled. + if (toAutoExpand in FOptions.AutoOptions) and not (vsExpanded in FFocusedNode.States) then + ToggleNode(FFocusedNode); + InvalidateNode(FFocusedNode); + if (FUpdateCount = 0) and not (toDisableAutoscrollOnFocus in FOptions.AutoOptions) then + ScrollIntoView(FFocusedNode, (toCenterScrollIntoView in FOptions.SelectionOptions) and + (MouseButtonDown * FStates = []), not (toFullRowSelect in FOptions.SelectionOptions) ); + end; + + // Reset range anchor if necessary. + if FSelectionCount = 0 then + ResetRangeAnchor; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoFreeNode(Node: PVirtualNode); + +var + IntfData: IInterface; +begin + // Prevent invalid references + if Node = FLastChangedNode then + FLastChangedNode := nil; + if Node = FCurrentHotNode then + FCurrentHotNode := nil; + if Node = FDropTargetNode then + FDropTargetNode := nil; + if Node = FLastStructureChangeNode then + FLastStructureChangeNode := nil; + if Node = FFocusedNode then + FFocusedNode := nil; + if Node = FNextNodeToSelect then + UpdateNextNodeToSelect(Node); + if Node = FLastHitInfo.HitNode then + FLastHitInfo.HitNode := nil; + // fire event + if Assigned(FOnFreeNode) and ([vsInitialized, vsOnFreeNodeCallRequired] * Node.States <> []) then + FOnFreeNode(Self, Node); + + if vsReleaseCallOnUserDataRequired in Node.States then + begin + // Data may have been set to nil, in which case we can't call _Release on it + IntfData := GetInterfaceFromNodeData(Node); + if Assigned(IntfData) then + IntfData._Release(); + end; + + FreeMem(Node); + if Self.UpdateCount = 0 then + EnsureNodeSelected(True); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.DoGetCellContentMargin(Node: PVirtualNode; Column: TColumnIndex; + CellContentMarginType: TVTCellContentMarginType = ccmtAllSides; Canvas: TCanvas = nil): TPoint; + +// Determines the margins of the content rectangle caused by DoBeforeCellPaint. +// Note that shrinking the content rectangle results in positive margins whereas enlarging the content rectangle results +// in negative margins. + +var + CellRect, + ContentRect: TRect; + +begin + Result := Point(0, 0); + + if Assigned(FOnBeforeCellPaint) then // Otherwise DoBeforeCellPaint has no effect. + begin + if Canvas = nil then + Canvas := Self.Canvas; + + // Determine then node's cell rectangle and content rectangle before calling DoBeforeCellPaint. + CellRect := GetDisplayRect(Node, Column, True); + ContentRect := CellRect; + DoBeforeCellPaint(Canvas, Node, Column, cpmGetContentMargin, CellRect, ContentRect); + + // Calculate the changes caused by DoBeforeCellPaint. + case CellContentMarginType of + ccmtAllSides: + // Calculate the width difference and high difference. + Result := Point((CellRect.Right - CellRect.Left) - (ContentRect.Right - ContentRect.Left), + (CellRect.Bottom - CellRect.Top) - (ContentRect.Bottom - ContentRect.Top)); + ccmtTopLeftOnly: + // Calculate the left margin and top margin only. + Result := Point(ContentRect.Left - CellRect.Left, ContentRect.Top - CellRect.Top); + ccmtBottomRightOnly: + // Calculate the right margin and bottom margin only. + Result := Point(CellRect.Right - ContentRect.Right, CellRect.Bottom - ContentRect.Bottom); + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoGetCursor(var Cursor: TCursor); + +begin + if Assigned(FOnGetCursor) then + FOnGetCursor(Self, Cursor); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoGetHeaderCursor(var Cursor: TVTCursor); + +begin + if Assigned(FOnGetHeaderCursor) then + FOnGetHeaderCursor(FHeader, Cursor); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.DoGetImageIndex(Node: PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex; + var Ghosted: Boolean; var Index: TImageIndex): TCustomImageList; + +// Queries the application/descendant about certain image properties for a node. +// Returns a custom image list if given by the callee, otherwise nil. +const + cTVTImageKind2String: Array [TVTImageKind] of string = ('ikNormal', 'ikSelected', 'ikState', 'ikOverlay'); +begin + if (Kind = ikState) and Assigned(StateImages) then + Result := Self.StateImages + else + Result := Self.Images; + // First try the enhanced event to allow for custom image lists. + if Assigned(FOnGetImageEx) then + FOnGetImageEx(Self, Node, Kind, Column, Ghosted, Index, Result) + else if Assigned(FOnGetImage) then + FOnGetImage(Self, Node, Kind, Column, Ghosted, Index); + + Assert((Index < 0) or Assigned(Result), 'An image index was supplied for TVTImageKind.' + cTVTImageKind2String[Kind] + ' but no image list was supplied.'); + if not Assigned(Result) then + Index := -1; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoGetImageText(Node: PVirtualNode; Kind: TVTImageKind; + Column: TColumnIndex; var ImageText: string); + +// Queries the application/descendant about alternative image text for a node. + +begin + if Assigned(FOnGetImageText) then + FOnGetImageText(Self, Node, Kind, Column, ImageText); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoGetLineStyle(var Bits: Pointer); + +begin + if Assigned(FOnGetLineStyle) then + FOnGetLineStyle(Self, Bits); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.DoGetNodeHint(Node: PVirtualNode; Column: TColumnIndex; + var LineBreakStyle: TVTTooltipLineBreakStyle): string; + +begin + Result := Hint; + LineBreakStyle := hlbDefault; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.DoGetNodeTooltip(Node: PVirtualNode; Column: TColumnIndex; + var LineBreakStyle: TVTTooltipLineBreakStyle): string; + +begin + Result := Hint; + LineBreakStyle := hlbDefault; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.DoGetNodeExtraWidth(Node: PVirtualNode; Column: TColumnIndex; Canvas: TCanvas = nil): TDimension; + +// Returns the pixel width of extra space occupied by node contents (for example, static text). + +begin + Result := 0; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.DoGetNodeWidth(Node: PVirtualNode; Column: TColumnIndex; Canvas: TCanvas = nil): TDimension; + +// Returns the pixel width of a node. + +begin + Result := 0; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.DoGetPopupMenu(Node: PVirtualNode; Column: TColumnIndex; Position: TPoint): TPopupMenu; + +// Queries the application whether there is a node specific popup menu. + +var + Run: PVirtualNode; + AskParent: Boolean; + +begin + Result := nil; + if Assigned(FOnGetPopupMenu) then + begin + Run := Node; + + if Assigned(Run) then + begin + AskParent := True; + repeat + FOnGetPopupMenu(Self, Run, Column, Position, AskParent, Result); + Run := Run.Parent; + until (Run = FRoot) or Assigned(Result) or not AskParent; + end + else + FOnGetPopupMenu(Self, nil, NoColumn, Position, AskParent, Result); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoGetUserClipboardFormats(var Formats: TFormatEtcArray); + +begin + if Assigned(FOnGetUserClipboardFormats) then + FOnGetUserClipboardFormats(Self, Formats); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoHeaderAddPopupItem(const Column: TColumnIndex; var Cmd: TAddPopupItemType); + +begin + if Assigned(FOnHeaderAddPopupItem) then + FOnHeaderAddPopupItem(Self, Column, Cmd); + +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoHeaderClick(const HitInfo: TVTHeaderHitInfo); + +begin + if Assigned(FOnHeaderClick) then + FOnHeaderClick(FHeader, HitInfo); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoHeaderDblClick(const HitInfo: TVTHeaderHitInfo); + +begin + if Assigned(FOnHeaderDblClick) then + FOnHeaderDblClick(FHeader, HitInfo); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoHeaderDragged(Column: TColumnIndex; OldPosition: TColumnPosition); + +begin + if Assigned(FOnHeaderDragged) then + FOnHeaderDragged(FHeader, Column, OldPosition); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoHeaderDraggedOut(Column: TColumnIndex; DropPosition: TPoint); + +begin + if Assigned(FOnHeaderDraggedOut) then + FOnHeaderDraggedOut(FHeader, Column, DropPosition); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.DoHeaderDragging(Column: TColumnIndex): Boolean; + +begin + Result := True; + if Assigned(FOnHeaderDragging) then + FOnHeaderDragging(FHeader, Column, Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoHeaderDraw(Canvas: TCanvas; Column: TVirtualTreeColumn; R: TRect; Hover, Pressed: Boolean; + DropMark: TVTDropMarkMode); + +begin + if Assigned(FOnHeaderDraw) then + FOnHeaderDraw(FHeader, Canvas, Column, R, Hover, Pressed, DropMark); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoHeaderDrawQueryElements(var PaintInfo: THeaderPaintInfo; var Elements: THeaderPaintElements); + +begin + if Assigned(FOnHeaderDrawQueryElements) then + FOnHeaderDrawQueryElements(FHeader, PaintInfo, Elements); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoHeaderMouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: TDimension); + +begin + if Assigned(FOnHeaderMouseDown) then + FOnHeaderMouseDown(FHeader, Button, Shift, X, Y); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoHeaderMouseMove(Shift: TShiftState; X, Y: TDimension); + +begin + if Assigned(FOnHeaderMouseMove) then + FOnHeaderMouseMove(FHeader, Shift, X, Y); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoHeaderMouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: TDimension); + +begin + if Assigned(FOnHeaderMouseUp) then + FOnHeaderMouseUp(FHeader, Button, Shift, X, Y); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoHotChange(Old, New: PVirtualNode); + +begin + if Assigned(FOnHotChange) then + FOnHotChange(Self, Old, New); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.DoIncrementalSearch(Node: PVirtualNode; const Text: string): Integer; + +begin + Result := 0; + if Assigned(FOnIncrementalSearch) then + FOnIncrementalSearch(Self, Node, Text, Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.DoInitChildren(Node: PVirtualNode; var ChildCount: Cardinal): Boolean; +/// The function calls the OnInitChildren and returns True if the event was called; it returns False if the caller can expect that no changes have been made to ChildCount +begin + if Assigned(FOnInitChildren) then + begin + FOnInitChildren(Self, Node, ChildCount); + Result := True; + end + else + Result := False; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoInitNode(Parent, Node: PVirtualNode; var InitStates: TVirtualNodeInitStates); + +begin + if Assigned(FOnInitNode) then + FOnInitNode(Self, Parent, Node, InitStates); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.DoKeyAction(var CharCode: Word; var Shift: TShiftState): Boolean; + +begin + Result := True; + if Assigned(FOnKeyAction) then + FOnKeyAction(Self, CharCode, Shift, Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoLoadUserData(Node: PVirtualNode; Stream: TStream); + +begin + if Assigned(FOnLoadNode) then + if Node = FRoot then + FOnLoadNode(Self, nil, Stream) + else + FOnLoadNode(Self, Node, Stream); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoMeasureItem(TargetCanvas: TCanvas; Node: PVirtualNode; var NodeHeight: TDimension); + +begin + if not (vsInitialized in Node.States) then + InitNode(Node); + if Assigned(FOnMeasureItem) then + FOnMeasureItem(Self, TargetCanvas, Node, NodeHeight); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoMouseEnter(); + +begin + if Assigned(FOnMouseEnter) then + FOnMouseEnter(Self); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoMouseLeave; + +begin + if Assigned(FOnMouseLeave) then + FOnMouseLeave(Self); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoNodeCopied(Node: PVirtualNode); + +begin + if Assigned(FOnNodeCopied) then + FOnNodeCopied(Self, Node); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.DoNodeCopying(Node, NewParent: PVirtualNode): Boolean; + +begin + Result := True; + if Assigned(FOnNodeCopying) then + FOnNodeCopying(Self, Node, NewParent, Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoNodeClick(const HitInfo: THitInfo); + +begin + if Assigned(FOnNodeClick) then + FOnNodeClick(Self, HitInfo); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoNodeDblClick(const HitInfo: THitInfo); + +begin + if Assigned(FOnNodeDblClick) then + FOnNodeDblClick(Self, HitInfo); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.DoNodeHeightDblClickResize(Node: PVirtualNode; Column: TColumnIndex; Shift: TShiftState; + P: TPoint): Boolean; + +begin + Result := True; + if Assigned(FOnNodeHeightDblClickResize) then + FOnNodeHeightDblClickResize(Self, Node, Column, Shift, P, Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.DoNodeHeightTracking(Node: PVirtualNode; Column: TColumnIndex; Shift: TShiftState; + var TrackPoint: TPoint; P: TPoint): Boolean; + +begin + Result := True; + if Assigned(FOnNodeHeightTracking) then + FOnNodeHeightTracking(Self, Node, Column, Shift, TrackPoint, P, Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoNodeMoved(Node: PVirtualNode); + +begin + if Assigned(FOnNodeMoved) then + FOnNodeMoved(Self, Node); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.DoNodeMoving(Node, NewParent: PVirtualNode): Boolean; + +begin + Result := True; + if Assigned(FOnNodeMoving) then + FOnNodeMoving(Self, Node, NewParent, Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.DoPaintBackground(Canvas: TCanvas; R: TRect): Boolean; + +begin + Result := False; + if Assigned(FOnPaintBackground) then + FOnPaintBackground(Self, Canvas, R, Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoPaintDropMark(Canvas: TCanvas; Node: PVirtualNode; R: TRect); + +// draws the drop mark into the given rectangle +// Note: Changed properties of the given canvas should be reset to their previous values. + +var + SaveBrushColor: TColor; + SavePenStyle: TPenStyle; + +begin + if FLastDropMode in [dmAbove, dmBelow] then + with Canvas do + begin + SavePenStyle := Pen.Style; + Pen.Style := psClear; + SaveBrushColor := Brush.Color; + Brush.Color := FColors.DropMarkColor; + + if FLastDropMode = dmAbove then + begin + Polygon([Point(R.Left + 2, R.Top), + Point(R.Right - 2, R.Top), + Point(R.Right - 2, R.Top + 6), + Point(R.Right - 6, R.Top + 2), + Point(R.Left + 6 , R.Top + 2), + Point(R.Left + 2, R.Top + 6) + ]); + end + else + Polygon([Point(R.Left + 2, R.Bottom - 1), + Point(R.Right - 2, R.Bottom - 1), + Point(R.Right - 2, R.Bottom - 8), + Point(R.Right - 7, R.Bottom - 3), + Point(R.Left + 7 , R.Bottom - 3), + Point(R.Left + 2, R.Bottom - 8) + ]); + Brush.Color := SaveBrushColor; + Pen.Style := SavePenStyle; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoPaintNode(var PaintInfo: TVTPaintInfo); + +begin +end; + +procedure TBaseVirtualTree.DoPaintText(Node: PVirtualNode; const Canvas: TCanvas; Column: TColumnIndex; TextType: TVSTTextType); +begin + if Assigned(FOnPaintText) then + FOnPaintText(Self, Canvas, Node, Column, TextType); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoPopupMenu(Node: PVirtualNode; Column: TColumnIndex; Position: TPoint); + +// Support for node dependent popup menus. + +var + Menu: TPopupMenu; + +begin + Menu := DoGetPopupMenu(Node, Column, Position); + + if Assigned(Menu) then + begin + DoStateChange([tsPopupMenuShown]); + StopTimer(EditTimer); + Menu.PopupComponent := Self; + with ClientToScreen(Position) do + Menu.Popup(X, Y); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoRemoveFromSelection(Node: PVirtualNode); + +begin + if Assigned(FOnRemoveFromSelection) then + FOnRemoveFromSelection(Self, Node); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoReset(Node: PVirtualNode); + +begin + if Assigned(FOnResetNode) then + FOnResetNode(Self, Node); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoSaveUserData(Node: PVirtualNode; Stream: TStream); + +begin + if Assigned(FOnSaveNode) then + if Node = FRoot then + FOnSaveNode(Self, nil, Stream) + else + FOnSaveNode(Self, Node, Stream); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoScroll(DeltaX, DeltaY: TDimension); + +begin + if Assigned(FOnScroll) then + FOnScroll(Self, DeltaX, DeltaY); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.DoSetOffsetXY(Value: TPoint; Options: TScrollUpdateOptions; ClipRect: PRect = nil): Boolean; + +// Actual offset setter used to scroll the client area, update scroll bars and invalidating the header (all optional). +// Returns True if the offset really changed otherwise False is returned. + +var + DeltaX: TDimension; + DeltaY: TDimension; + DWPStructure: HDWP; + I: Integer; + P: TPoint; + R: TRect; + +begin + // Range check, order is important here. + if Value.X < (ClientWidth - FRangeX) then + Value.X := ClientWidth - FRangeX; + if Value.X > 0 then + Value.X := 0; + DeltaX := Value.X - FOffsetX; + if UseRightToLeftAlignment then + DeltaX := -DeltaX; + if Value.Y < (ClientHeight - FRangeY) then + Value.Y := ClientHeight - FRangeY; + if Value.Y > 0 then + Value.Y := 0; + DeltaY := Value.Y - FOffsetY; + + Result := (DeltaX <> 0) or (DeltaY <> 0); + if Result then + begin + FOffsetX := Value.X; + FOffsetY := Value.Y; + Result := True; + + if tsHint in Self.FStates then + Application.CancelHint; + if FUpdateCount = 0 then + begin + // The drag image from VCL controls need special consideration. + if tsVCLDragging in FStates then + ImageList_DragShowNolock(False); + + if (suoScrollClientArea in Options) and not (tsToggling in FStates) then + begin + // Have to invalidate the entire window if there's a background. + if (toShowBackground in FOptions.PaintOptions) and Assigned(FBackground.Graphic) then + begin + // Since we don't use ScrollWindow here we have to move all client windows ourselves. + DWPStructure := BeginDeferWindowPos(ControlCount); + for I := 0 to ControlCount - 1 do + if Controls[I] is TWinControl then + begin + with Controls[I] as TWinControl do + DWPStructure := DeferWindowPos(DWPStructure, Handle, 0, Left + DeltaX, Top + DeltaY, 0, 0, + SWP_NOZORDER or SWP_NOACTIVATE or SWP_NOSIZE); + if DWPStructure = 0 then + Break; + end; + if DWPStructure <> 0 then + EndDeferWindowPos(DWPStructure); + InvalidateRect(nil, False); + end + else + begin + if (DeltaX <> 0) and (Header.Columns.GetVisibleFixedWidth > 0) then + begin + // When fixed columns exists we have to scroll separately horizontally and vertically. + // Horizontally is scroll only the client area not occupied by fixed columns and + // vertically entire client area (or clipping area if one exists). + R := ClientRect; + R.Left := Header.Columns.GetVisibleFixedWidth; + + ScrollWindow(Handle, DeltaX, 0, @R, @R); + if DeltaY <> 0 then + ScrollWindow(Handle, 0, DeltaY, ClipRect, ClipRect); + end + else + ScrollWindow(Handle, DeltaX, DeltaY, ClipRect, ClipRect); + end; + end; + + if suoUpdateNCArea in Options then + begin + if DeltaX <> 0 then + begin + UpdateHorizontalScrollBar(suoRepaintScrollBars in Options); + if (suoRepaintHeader in Options) and (hoVisible in FHeader.Options) then + FHeader.Invalidate(nil); + if not (tsSizing in FStates) and (FScrollBarOptions.ScrollBars in [System.UITypes.TScrollStyle.ssHorizontal, System.UITypes.TScrollStyle.ssBoth]) then + UpdateVerticalScrollBar(suoRepaintScrollBars in Options); + end; + + if (DeltaY <> 0) and ([tsThumbTracking, tsSizing] * FStates = []) then + begin + UpdateVerticalScrollBar(suoRepaintScrollBars in Options); + if not (FHeader.UseColumns or IsMouseSelecting) and + (FScrollBarOptions.ScrollBars in [System.UITypes.TScrollStyle.ssHorizontal, System.UITypes.TScrollStyle.ssBoth]) then + UpdateHorizontalScrollBar(suoRepaintScrollBars in Options); + end; + end; + + if tsVCLDragging in FStates then + ImageList_DragShowNolock(True); + end; + + // Finally update "hot" node if hot tracking is activated + GetCursorPos(P); + P := ScreenToClient(P); + if PtInRect(ClientRect, P) then + HandleHotTrack(P.X, P.Y); + + DoScroll(DeltaX, DeltaY); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoShowScrollBar(Bar: Integer; Show: Boolean); + +begin + ShowScrollBar(Bar, Show); + + if Assigned(FOnShowScrollBar) then + FOnShowScrollBar(Self, Bar, Show); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoStartDrag(var DragObject: TDragObject); + +begin + inherited; + + // Check if the application created an own drag object. This is needed to pass the correct source in + // OnDragOver and OnDragDrop. + if Assigned(DragObject) then + DoStateChange([tsUserDragObject]); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoStartOperation(OperationKind: TVTOperationKind); + +begin + if Assigned(FOnStartOperation) then + FOnStartOperation(Self, OperationKind); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoStateChange(Enter: TVirtualTreeStates; Leave: TVirtualTreeStates = []); + +var + ActualEnter, + ActualLeave: TVirtualTreeStates; + +begin + if Assigned(FOnStateChange) then + begin + ActualEnter := Enter - FStates; + ActualLeave := FStates * Leave; + if (ActualEnter + ActualLeave) <> [] then + FOnStateChange(Self, Enter, Leave); + end; + FStates := FStates + Enter - Leave; + Assert(FStates * [tsUseCache, tsValidationNeeded] <> [tsUseCache, tsValidationNeeded], 'Invalid state. tsUseCache and tsValidationNeeded are mutually exclusive and must not be set at the same time'); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoStructureChange(Node: PVirtualNode; Reason: TChangeReason); + +begin + StopTimer(StructureChangeTimer); + if Assigned(FOnStructureChange) then + FOnStructureChange(Self, Node, Reason); + + // This is a good place to reset the cached node and reason. These are the same as the values passed in here. + // This is necessary to allow descendants to override this method and get them. + DoStateChange([], [tsStructureChangePending]); + FLastStructureChangeNode := nil; + FLastStructureChangeReason := crIgnore; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoTimerScroll; + +var + P, + ClientP: TPoint; + InRect, + Panning: Boolean; + R, + ClipRect: TRect; + DeltaX, + DeltaY: Integer; + +begin + GetCursorPos(P); + R := ClientRect; + ClipRect := R; + MapWindowPoints(Handle, 0, R, 2); + InRect := PtInRect(R, P); + ClientP := ScreenToClient(P); + Panning := tsPanning in FStates; + + if IsMouseSelecting or InRect or Panning then + begin + DeltaX := 0; + DeltaY := 0; + if sdUp in FScrollDirections then + begin + if Panning then + DeltaY := FLastClickPos.Y - ClientP.Y - 8 + else + if InRect then + DeltaY := Min(FScrollBarOptions.VerticalIncrement, ClientHeight) + else + DeltaY := Min(FScrollBarOptions.VerticalIncrement, ClientHeight) * Abs(R.Top - P.Y); + if FOffsetY = 0 then + Exclude(FScrollDirections, sdUp); + end; + + if sdDown in FScrollDirections then + begin + if Panning then + DeltaY := FLastClickPos.Y - ClientP.Y + 8 + else + if InRect then + DeltaY := -Min(FScrollBarOptions.VerticalIncrement, ClientHeight) + else + DeltaY := -Min(FScrollBarOptions.VerticalIncrement, ClientHeight) * Abs(P.Y - R.Bottom); + if (ClientHeight - FOffsetY) = FRangeY then + Exclude(FScrollDirections, sdDown); + end; + + if sdLeft in FScrollDirections then + begin + if Panning then + DeltaX := FLastClickPos.X - ClientP.X - 8 + else + if InRect then + DeltaX := FScrollBarOptions.HorizontalIncrement + else + DeltaX := FScrollBarOptions.HorizontalIncrement * Abs(R.Left - P.X); + if FEffectiveOffsetX = 0 then + Exclude(FScrollDirections, sdleft); + end; + + if sdRight in FScrollDirections then + begin + if Panning then + DeltaX := FLastClickPos.X - ClientP.X + 8 + else + if InRect then + DeltaX := -FScrollBarOptions.HorizontalIncrement + else + DeltaX := -FScrollBarOptions.HorizontalIncrement * Abs(P.X - R.Right); + + if (ClientWidth + FEffectiveOffsetX) = FRangeX then + Exclude(FScrollDirections, sdRight); + end; + + if UseRightToLeftAlignment then + DeltaX := - DeltaX; + + if IsMouseSelecting then + begin + // In order to avoid scrolling the area which needs a repaint due to the changed selection rectangle + // we limit the scroll area explicitely. + OffsetRect(ClipRect, DeltaX, DeltaY); + DoSetOffsetXY(Point(FOffsetX + DeltaX, FOffsetY + DeltaY), DefaultScrollUpdateFlags, @ClipRect); + // When selecting with the mouse then either update only the parts of the window which have been uncovered + // by the scroll operation if no change in the selection happend or invalidate and redraw the entire + // client area otherwise (to avoid the time consuming task of determining the display rectangles of every + // changed node). + if CalculateSelectionRect(ClientP.X, ClientP.Y) and HandleDrawSelection(ClientP.X, ClientP.Y) then + InvalidateRect(nil, False) + else + begin + // The selection did not change so invalidate only the part of the window which really needs an update. + // 1) Invalidate the parts uncovered by the scroll operation. Add another offset range, we have to + // scroll only one stripe but have to update two. + OffsetRect(ClipRect, DeltaX, DeltaY); + SubtractRect(ClipRect, ClientRect, ClipRect); + InvalidateRect(@ClipRect, False); + + // 2) Invalidate the selection rectangles. + UnionRect(ClipRect, OrderRect(FNewSelRect), OrderRect(FLastSelRect)); + OffsetRect(ClipRect, FOffsetX, FOffsetY); + InvalidateRect(@ClipRect, False); + end; + end + else + begin + // Scroll only if there is no drag'n drop in progress. Drag'n drop scrolling is handled in DragOver. + if ((FDragManager = nil) or not DragManager.IsDropTarget) and ((DeltaX <> 0) or (DeltaY <> 0)) then + DoSetOffsetXY(Point(FOffsetX + DeltaX, FOffsetY + DeltaY), DefaultScrollUpdateFlags, nil); + end; + UpdateWindow(); + + if (FScrollDirections = []) and not (tsPanning in FStates) then + begin + StopTimer(ScrollTimer); + DoStateChange([], [tsScrollPending, tsScrolling]); + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoUpdating(State: TVTUpdateState); + +begin + if Assigned(FOnUpdating) then + FOnUpdating(Self, State); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.DoValidateCache(): Boolean; + +// This method fills the cache, which is used to speed up searching for nodes. +// The strategy is simple: Take the current number of visible nodes and distribute evenly a number of marks +// (which are stored in FPositionCache) so that iterating through the tree doesn't cost too much time. +// If there are less than 'CacheThreshold' nodes in the tree then the cache remains empty. +// Result is True if the cache was filled without interruption, otherwise False. +// Note: You can adjust the maximum number of nodes between two cache entries by changing CacheThreshold. + +var + EntryCount, + Index: Cardinal; + CurrentNode, + Temp: PVirtualNode; + CurrentTop: TNodeHeight; +begin + EntryCount := 0; + if not (tsStopValidation in FStates) then + begin + if FStartIndex = 0 then + FPositionCache := nil; + + EntryCount := CalculateCacheEntryCount; + SetLength(FPositionCache, EntryCount); + if FStartIndex > EntryCount then + FStartIndex := EntryCount; + + // Optimize validation by starting with FStartIndex if set. + if (FStartIndex > 0) and Assigned(FPositionCache[FStartIndex - 1].Node) then + begin + // Index is the current entry in FPositionCache. + Index := FStartIndex - 1; + // Running term for absolute top value. + CurrentTop := FPositionCache[Index].AbsoluteTop; + // Running node pointer. + CurrentNode := FPositionCache[Index].Node; + end + else + begin + // Index is the current entry in FPositionCache. + Index := 0; + // Running term for absolute top value. + CurrentTop := 0; + // Running node pointer. + CurrentNode := GetFirstVisibleNoInit(nil, True); + end; + + // EntryCount serves as counter for processed nodes here. This value can always start at 0 as + // the validation either starts also at index 0 or an index which is always a multiple of CacheThreshold + // and EntryCount is only used with modulo CacheThreshold. + EntryCount := 0; + if Assigned(CurrentNode) then + begin + while not (tsStopValidation in FStates) do + begin + // If the cache is full then stop the loop. + if (Integer(Index) >= Length(FPositionCache)) then + Break; + if (EntryCount mod CacheThreshold) = 0 then + begin + // New cache entry to set up. + with FPositionCache[Index] do + begin + Node := CurrentNode; // 2 EAccessViolation seen here in TreeSize V4.3.1, 1 in V4.4.0 (Write of address 00000000) + AbsoluteTop := CurrentTop; + end; + System.Inc(Index); + end; + + Inc(CurrentTop, NodeHeight[CurrentNode]); + // Advance to next visible node. + Temp := GetNextVisibleNoInit(CurrentNode, True); + // If there is no further node then stop the loop. + if (Temp = nil) then // CHANGED: 17.09.2013 - Veit Zimmermann + Break; // CHANGED: 17.09.2013 - Veit Zimmermann + + CurrentNode := Temp; + System.Inc(EntryCount); + end; + end; + // Finalize the position cache so no nil entry remains there. + if not (tsStopValidation in FStates) and (Integer(Index) <= High(FPositionCache)) then + begin + SetLength(FPositionCache, Index + 1); + with FPositionCache[Index] do + begin + Node := CurrentNode; + AbsoluteTop := CurrentTop; + end; + end; + end; + + Result := (EntryCount > 0) and not (tsStopValidation in FStates); + + // In variable node height mode it might have happend that some or all of the nodes have been adjusted in their + // height. During validation updates of the scrollbars is disabled so let's do this here. + if Result and (toVariableNodeHeight in FOptions.MiscOptions) then + begin + TThread.Queue(nil, procedure begin UpdateScrollBars(True) end); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DragAndDrop(AllowedEffects: Dword; const DataObject: TVTDragDataObject; var DragEffect: Integer); +var + lDragEffect: DWord; // required for type compatibility with SHDoDragDrop +begin + lDragEffect := DWord(DragEffect); + SHDoDragDrop(Self.Handle, DataObject, nil, AllowedEffects, lDragEffect); // supports drag hints on Windows Vista and later + DragEffect := Integer(lDragEffect); + end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DragCanceled; + +// Does some housekeeping for VCL drag'n drop; + +begin + inherited; + + DragFinished; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.DragDrop(const DataObject: TVTDragDataObject; KeyState: Integer; Pt: TPoint; + var Effect: Integer): HResult; + +var + Shift: TShiftState; + EnumFormat: IEnumFormatEtc; + Fetched: Integer; + OLEFormat: TFormatEtc; + Formats: TFormatArray; + +begin + StopTimer(ExpandTimer); + StopTimer(ScrollTimer); + DoStateChange([], [tsScrollPending, tsScrolling]); + Formats := nil; + + // Ask explicitly again whether the action is allowed. Otherwise we may accept a drop which is intentionally not + // allowed but cannot be prevented by the application because when the tree was scrolling while dropping + // no DragOver event is created by the OLE subsystem. + Result := DragOver(DragManager.DragSource, KeyState, dsDragMove, Pt, Effect); + try + if (Result <> NOERROR) or ((Effect and not DROPEFFECT_SCROLL) = DROPEFFECT_NONE) then + Result := E_FAIL + else + begin + try + Shift := KeysToShiftState(KeyState); + if tsRightButtonDown in FStates then + Include(Shift, ssRight) + else if tsMiddleButtonDown in FStates then + Include(Shift, ssMiddle) + else + Include(Shift, ssLeft); + Pt := ScreenToClient(Pt); + // Determine which formats we can get and pass them along with the data object to the drop handler. + Result := DataObject.EnumFormatEtc(DATADIR_GET, EnumFormat); + if Failed(Result) then + Abort; + Result := EnumFormat.Reset; + if Failed(Result) then + Abort; + // create a list of available formats + while EnumFormat.Next(1, OLEFormat, @Fetched) = S_OK do + begin + SetLength(Formats, Length(Formats) + 1); + Formats[High(Formats)] := OLEFormat.cfFormat; + end; + DoDragDrop(DragManager.DragSource, DataObject, Formats, Shift, Pt, Effect, FLastDropMode); + except + // An unhandled exception here leaks memory. + Application.HandleException(Self); + Result := E_UNEXPECTED; + end; + end; + finally + if Assigned(FDropTargetNode) then + begin + InvalidateNode(FDropTargetNode); + FDropTargetNode := nil; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.DragEnter(KeyState: Integer; Pt: TPoint; var Effect: Integer): HResult; + +// callback routine for the drop target interface + +var + Shift: TShiftState; + Accept: Boolean; + R: TRect; + HitInfo: THitInfo; + +begin + try + if not (toAcceptOLEDrop in TreeOptions.MiscOptions) then + begin + Effect := DROPEFFECT_NONE; + Exit(NOERROR); + end; + + // Determine acceptance of drag operation and reset scroll start time. + FDragScrollStart := 0; + + Shift := KeysToShiftState(KeyState); + if tsLeftButtonDown in FStates then + Include(Shift, ssLeft); + if tsMiddleButtonDown in FStates then + Include(Shift, ssMiddle); + if tsRightButtonDown in FStates then + Include(Shift, ssRight); + Pt := ScreenToClient(Pt); + Effect := SuggestDropEffect(DragManager.DragSource, Shift, Pt, Effect); + Accept := DoDragOver(DragManager.DragSource, Shift, dsDragEnter, Pt, FLastDropMode, Effect); + if not Accept then + Effect := DROPEFFECT_NONE + else + begin + // Set initial drop target node and drop mode. + GetHitTestInfoAt(Pt.X, Pt.Y, True, HitInfo, Shift); + if Assigned(HitInfo.HitNode) then + begin + FDropTargetNode := HitInfo.HitNode; + R := GetDisplayRect(HitInfo.HitNode, FHeader.MainColumn, False); + //VSOFT CHANGE - changed back to 4.8.5 behaviour + if (hiOnItemLabel in HitInfo.HitPositions) or ((hiOnItem in HitInfo.HitPositions) and + ((toFullRowDrag in FOptions.MiscOptions){ or (toFullRowSelect in FOptions.SelectionOptions)}))then + FLastDropMode := dmOnNode + else + if ((R.Top + R.Bottom) div 2) > Pt.Y then + FLastDropMode := dmAbove + else + FLastDropMode := dmBelow; + end + else + FLastDropMode := dmNowhere; + end; + Result := NOERROR; + except + Result := E_UNEXPECTED; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DragFinished; + +// Called by DragCancelled or EndDrag to make up for the still missing mouse button up messages. +// These are important for such important things like popup menus. + +var + P: TPoint; + +begin + if [tsOLEDragging, tsVCLDragPending, tsVCLDragging, tsVCLDragFinished] * FStates = [] then + Exit; + + DoStateChange([], [tsVCLDragPending, tsVCLDragging, tsUserDragObject, tsVCLDragFinished]); + + GetCursorPos(P); + P := ScreenToClient(P); + if tsRightButtonDown in FStates then + Perform(WM_RBUTTONUP, 0, LPARAM(Integer(PointToSmallPoint(P)))) + else + if tsMiddleButtonDown in FStates then + Perform(WM_MBUTTONUP, 0, LPARAM(Integer(PointToSmallPoint(P)))) + else + Perform(WM_LBUTTONUP, 0, LPARAM(Integer(PointToSmallPoint(P)))); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DragLeave; + +var + Effect: Integer; + +begin + StopTimer(ExpandTimer); + + if Assigned(FDropTargetNode) then + begin + InvalidateNode(FDropTargetNode); + FDropTargetNode := nil; + end; + + UpdateWindow(); + + Effect := 0; + DoDragOver(nil, [], TDragState.dsDragLeave, Point(0, 0), FLastDropMode, Effect); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.DragOver(Source: TObject; KeyState: Integer; DragState: TDragState; Pt: TPoint; + var Effect: Integer): HResult; + +// callback routine for the drop target interface + +var + Shift: TShiftState; + Accept, + WindowScrolled: Boolean; + OldR, R: TRect; + NewDropMode: TDropMode; + HitInfo: THitInfo; + DragPos: TPoint; + LastNode: PVirtualNode; + DeltaX, + DeltaY: TDimension; + ScrollOptions: TScrollUpdateOptions; + +begin + ScrollOptions := DefaultScrollUpdateFlags; + + try + DragPos := Pt; + Pt := ScreenToClient(Pt); + + // Check if we have to scroll the client area. + FScrollDirections := DetermineScrollDirections(Pt.X, Pt.Y); + DeltaX := 0; + DeltaY := 0; + if FScrollDirections <> [] then + begin + // Determine amount to scroll. + if sdUp in FScrollDirections then + begin + DeltaY := Min(FScrollBarOptions.VerticalIncrement, ClientHeight); + if FOffsetY = 0 then + Exclude(FScrollDirections, sdUp); + end; + if sdDown in FScrollDirections then + begin + DeltaY := -Min(FScrollBarOptions.VerticalIncrement, ClientHeight); + if (ClientHeight - FOffsetY) = FRangeY then + Exclude(FScrollDirections, sdDown); + end; + if sdLeft in FScrollDirections then + begin + DeltaX := FScrollBarOptions.HorizontalIncrement; + if FEffectiveOffsetX = 0 then + Exclude(FScrollDirections, sdleft); + end; + if sdRight in FScrollDirections then + begin + DeltaX := -FScrollBarOptions.HorizontalIncrement; + if (ClientWidth + FEffectiveOffsetX) = FRangeX then + Exclude(FScrollDirections, sdRight); + end; + WindowScrolled := DoSetOffsetXY(Point(FOffsetX + DeltaX, FOffsetY + DeltaY), ScrollOptions, nil); + end + else + WindowScrolled := False; + + // Determine acceptance of drag operation as well as drag target. + Shift := KeysToShiftState(KeyState); + if tsLeftButtonDown in FStates then + Include(Shift, ssLeft); + if tsMiddleButtonDown in FStates then + Include(Shift, ssMiddle); + if tsRightButtonDown in FStates then + Include(Shift, ssRight); + GetHitTestInfoAt(Pt.X, Pt.Y, True, HitInfo, Shift); + + if Assigned(HitInfo.HitNode) then + R := GetDisplayRect(HitInfo.HitNode, NoColumn, False) + else + R := Rect(0, 0, 0, 0); + NewDropMode := DetermineDropMode(Pt, HitInfo, R); + + if (HitInfo.HitNode <> FDropTargetNode) or (FLastDropMode <> NewDropMode) then + begin + // Something in the tree will change. This requires to update the screen and/or the drag image. + FLastDropMode := NewDropMode; + if HitInfo.HitNode <> FDropTargetNode then + begin + StopTimer(ExpandTimer); + // The last target node is needed for the rectangle determination but must already be set for + // the recapture call, hence it must be stored somewhere. + LastNode := FDropTargetNode; + FDropTargetNode := HitInfo.HitNode; + // In order to show a selection rectangle a column must be focused. + if FFocusedColumn <= NoColumn then + FFocusedColumn := FHeader.MainColumn; + + if Assigned(LastNode) and Assigned(FDropTargetNode) then + begin + // Optimize the case that the selection moved between two nodes. + OldR := GetDisplayRect(LastNode, NoColumn, False); + UnionRect(R, R, OldR); + InvalidateRect(@R, False); + end + else + begin + if Assigned(LastNode) then + begin + // Repaint last target node. + OldR := GetDisplayRect(LastNode, NoColumn, False); + InvalidateRect(@OldR, False); + end + else + InvalidateRect(@R, False); + end; + + // Start auto expand timer if necessary. + if (toAutoDropExpand in FOptions.AutoOptions) and Assigned(FDropTargetNode) and + (vsHasChildren in FDropTargetNode.States) then + SetTimer(Handle, ExpandTimer, FAutoExpandDelay, nil); + end + else + begin + InvalidateRect(@R, False); + end; + end; + + Update; + + Effect := SuggestDropEffect(Source, Shift, Pt, Effect); + Accept := DoDragOver(Source, Shift, DragState, Pt, FLastDropMode, Effect); + if not Accept then + Effect := DROPEFFECT_NONE; + if WindowScrolled then + Effect := Effect or Integer(DROPEFFECT_SCROLL); + Result := NOERROR; + except + Result := E_UNEXPECTED; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DrawDottedHLine(const PaintInfo: TVTPaintInfo; Left, Right, Top: TDimension); +// Draws a horizontal line with alternating pixels +var + R: TRect; +begin + R := Rect(Min(Left, Right), Top, Max(Left, Right) + 1, Top + 1); + PaintInfo.Canvas.Brush.Color := FColors.BackGroundColor; + Winapi.Windows.FillRect(PaintInfo.Canvas.Handle, R, DottedBrushTreeLines.Handle); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DrawDottedVLine(const PaintInfo: TVTPaintInfo; Top, Bottom, Left: TDimension); +// Draws a vertical line with alternating pixels +var + R: TRect; +begin + R := Rect(Left, Min(Top, Bottom), Left + 1, Max(Top, Bottom) + 1); + PaintInfo.Canvas.Brush.Color := FColors.BackGroundColor; + Winapi.Windows.FillRect(PaintInfo.Canvas.Handle, R, DottedBrushTreeLines.Handle); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DrawGridLine(Canvas: TCanvas; R: TRect); +begin + Canvas.Brush.Color := FColors.GridLineColor; + Canvas.Brush.Style := bsSolid; + Canvas.FillRect(R); + //StyleServices.DrawElement(Canvas.Handle, StyleServices.GetElementDetails(tlGroupHeaderLineOpenSelectedNotFocused), R {$IF CompilerVersion >= 34}, @R, CurrentPPI{$IFEND}); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DrawGridHLine(const PaintInfo: TVTPaintInfo; Left, Right, Top: TDimension); +// Draws a horizontal grid line +var + R: TRect; +begin + R := Rect(Min(Left, Right), Top, Max(Left, Right) + LineWidth, Top + LineWidth); + DrawGridLine(PaintInfo.Canvas, R) +end; + + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DrawGridVLine(const PaintInfo: TVTPaintInfo; Top, Bottom, Left: TDimension; pFixedColumn: Boolean = False); +// Draws a vertical grid line +var + R: TRect; +begin + R := Rect(Left, Min(Top, Bottom), Left + LineWidth, Max(Top, Bottom) + LineWidth); + if pFixedColumn and (TVtPaintOption.toShowVertGridLines in TreeOptions.PaintOptions) then // In case we showe grid lines, we must use a color for the fixed column that differentiates from the normal gridlines + StyleServices.DrawElement(PaintInfo.Canvas.Handle, StyleServices.GetElementDetails(tlGroupHeaderLineOpenHot), R {$IF CompilerVersion >= 34}, @R, CurrentPPI{$IFEND}) + else begin + if StyleServices.IsSystemStyle then // This approach does not work well for many VCL styles, so we added an else case + begin + DrawGridLine(PaintInfo.Canvas, R) + //StyleServices.DrawElement(PaintInfo.Canvas.Handle, StyleServices.GetElementDetails(tlGroupHeaderLineOpenSelectedNotFocused), R {$IF CompilerVersion >= 34}, @R, CurrentPPI{$IFEND}) + end + else begin + DrawGridLine(PaintInfo.Canvas, R) + //StyleServices.DrawElement(PaintInfo.Canvas.Handle, StyleServices.GetElementDetails(tbGroupBoxNormal), R {$IF CompilerVersion >= 34}, @R, CurrentPPI{$IFEND}); + end; + end;// else +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.EndOperation(OperationKind: TVTOperationKind); + +// Called to indicate that a long-running operation has finished. + +begin + Assert(FOperationCount > 0, 'EndOperation must not be called when no operation in progress.'); + System.Dec(FOperationCount); + DoEndOperation(OperationKind); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.EnsureNodeFocused(); +begin + if FocusedNode = nil then + FocusedNode := Self.GetFirstSelected(); + if FocusedNode = nil then + FocusedNode := Self.GetFirstVisible(); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.EnsureNodeSelected(pAfterDeletion: Boolean); +begin + if IsEmpty then + exit; // Nothing to do + if (toAlwaysSelectNode in TreeOptions.SelectionOptions) or (pAfterDeletion and (toSelectNextNodeOnRemoval in TreeOptions.SelectionOptions)) then + begin + if (SelectedCount = 0) and not SelectionLocked then + begin + if not Assigned(FNextNodeToSelect) then + begin + FNextNodeToSelect := GetFirstVisible; + // Avoid selecting a disabled node, see #954 + while Assigned(FNextNodeToSelect) and IsDisabled[FNextNodeToSelect] do + FNextNodeToSelect := GetNextVisible(FNextNodeToSelect); + end; + Selected[FNextNodeToSelect] := True; + Self.ScrollIntoView(Self.GetFirstSelected, False); + end;// if nothing selected + EnsureNodeFocused(); + end;//if toAlwaysSelectNode +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.FindNodeInSelection(P: PVirtualNode; var Index: Integer; LowBound, + HighBound: Integer): Boolean; + +// Search routine to find a specific node in the selection array. +// LowBound and HighBound determine the range in which to search the node. +// Either value can be -1 to denote the maximum range otherwise LowBound must be less or equal HighBound. + +var + L, H, + I: Integer; + +begin + Result := False; + L := 0; + if LowBound >= 0 then + L := LowBound; + H := FSelectionCount - 1; + if HighBound >= 0 then + H := HighBound; + while L <= H do + begin + I := (L + H) shr 1; + if PAnsiChar(FSelection[I]) < PAnsiChar(P) then + L := I + 1 + else + begin + H := I - 1; + if FSelection[I] = P then + begin + Result := True; + L := I; + end; + end; + end; + Index := L; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.FinishChunkHeader(Stream: TStream; StartPos, EndPos: Integer); + +// used while streaming out a node to finally write out the size of the chunk + +var + Size: Integer; + +begin + // seek back to the second entry in the chunk header + Stream.Position := StartPos + SizeOf(Size); + // determine size of chunk without the chunk header + Size := EndPos - StartPos - SizeOf(TChunkHeader); + // write the size... + Stream.Write(Size, SizeOf(Size)); + // ... and seek to the last endposition + Stream.Position := EndPos; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.FontChanged(AFont: TObject); + +// Little helper function for font changes (as they are not tracked in TBitmap/TCanvas.OnChange). + +begin + FFontChanged := True; + if Assigned(FOldFontChange) then + FOldFontChange(AFont); + //if not (tsPainting in TreeStates) then AutoScale(); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetBorderDimensions: TSize; + +// Returns the overall width of the current window border, depending on border styles. +// Note: these numbers represent the system's standards not special properties, which can be set for TWinControl +// (e.g. bevels, border width). + +var + Styles: Integer; + +begin + Result.cx := 0; + Result.cy := 0; + + Styles := GetWindowLong(Handle, GWL_STYLE); + if (Styles and WS_BORDER) <> 0 then + begin + Dec(Result.cx); + Dec(Result.cy); + end; + if (Styles and WS_THICKFRAME) <> 0 then + begin + Dec(Result.cx, GetSystemMetrics(SM_CXFIXEDFRAME)); + Dec(Result.cy, GetSystemMetrics(SM_CYFIXEDFRAME)); + end; + Styles := GetWindowLong(Handle, GWL_EXSTYLE); + if (Styles and WS_EX_CLIENTEDGE) <> 0 then + begin + Dec(Result.cx, GetSystemMetrics(SM_CXEDGE)); + Dec(Result.cy, GetSystemMetrics(SM_CYEDGE)); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetCheckImage(Node: PVirtualNode; ImgCheckType: TCheckType = ctNone; ImgCheckState: + TCheckState = csUncheckedNormal; ImgEnabled: Boolean = True): Integer; + +// Determines the index into the check image list for the given node depending on the check type +// and enabled state. + +const + // Four dimensional array consisting of image indices for the check type, the check state, the enabled state and the + // hot state. + CheckStateToCheckImage: array[ctCheckBox..ctButton, csUncheckedNormal..csMixedPressed, Boolean, Boolean] of Integer = ( + // ctCheckBox, ctTriStateCheckBox + ( + // csUncheckedNormal (disabled [not hot, hot], enabled [not hot, hot]) + ((ckCheckUncheckedDisabled, ckCheckUncheckedDisabled), (ckCheckUncheckedNormal, ckCheckUncheckedHot)), + // csUncheckedPressed (disabled [not hot, hot], enabled [not hot, hot]) + ((ckCheckUncheckedDisabled, ckCheckUncheckedDisabled), (ckCheckUncheckedPressed, ckCheckUncheckedPressed)), + // csCheckedNormal + ((ckCheckCheckedDisabled, ckCheckCheckedDisabled), (ckCheckCheckedNormal, ckCheckCheckedHot)), + // csCheckedPressed + ((ckCheckCheckedDisabled, ckCheckCheckedDisabled), (ckCheckCheckedPressed, ckCheckCheckedPressed)), + // csMixedNormal + ((ckCheckMixedDisabled, ckCheckMixedDisabled), (ckCheckMixedNormal, ckCheckMixedHot)), + // csMixedPressed + ((ckCheckMixedDisabled, ckCheckMixedDisabled), (ckCheckMixedPressed, ckCheckMixedPressed)) + ), + // ctRadioButton + ( + // csUncheckedNormal (disabled [not hot, hot], enabled [not hot, hot]) + ((ckRadioUncheckedDisabled, ckRadioUncheckedDisabled), (ckRadioUncheckedNormal, ckRadioUncheckedHot)), + // csUncheckedPressed (disabled [not hot, hot], enabled [not hot, hot]) + ((ckRadioUncheckedDisabled, ckRadioUncheckedDisabled), (ckRadioUncheckedPressed, ckRadioUncheckedPressed)), + // csCheckedNormal + ((ckRadioCheckedDisabled, ckRadioCheckedDisabled), (ckRadioCheckedNormal, ckRadioCheckedHot)), + // csCheckedPressed + ((ckRadioCheckedDisabled, ckRadioCheckedDisabled), (ckRadioCheckedPressed, ckRadioCheckedPressed)), + // csMixedNormal (should never appear with ctRadioButton) + ((ckCheckMixedDisabled, ckCheckMixedDisabled), (ckCheckMixedNormal, ckCheckMixedHot)), + // csMixedPressed (should never appear with ctRadioButton) + ((ckCheckMixedDisabled, ckCheckMixedDisabled), (ckCheckMixedPressed, ckCheckMixedPressed)) + ), + // ctButton + ( + // csUncheckedNormal (disabled [not hot, hot], enabled [not hot, hot]) + ((ckButtonDisabled, ckButtonDisabled), (ckButtonNormal, ckButtonHot)), + // csUncheckedPressed (disabled [not hot, hot], enabled [not hot, hot]) + ((ckButtonDisabled, ckButtonDisabled), (ckButtonPressed, ckButtonPressed)), + // csCheckedNormal + ((ckButtonDisabled, ckButtonDisabled), (ckButtonNormal, ckButtonHot)), + // csCheckedPressed + ((ckButtonDisabled, ckButtonDisabled), (ckButtonPressed, ckButtonPressed)), + // csMixedNormal (should never appear with ctButton) + ((ckCheckMixedDisabled, ckCheckMixedDisabled), (ckCheckMixedNormal, ckCheckMixedHot)), + // csMixedPressed (should never appear with ctButton) + ((ckCheckMixedDisabled, ckCheckMixedDisabled), (ckCheckMixedPressed, ckCheckMixedPressed)) + ) + ); + +var + IsHot: Boolean; + +begin + if Assigned(Node) then + begin + ImgCheckType := Node.CheckType; + ImgCheckState := GetCheckState(Node); + ImgEnabled := not (vsDisabled in Node.States) and Self.Enabled; + + IsHot := Node = FCurrentHotNode; + end + else + IsHot := False; + + if ImgCheckState.IsDisabled then begin // disabled image? + // We need to use disabled images, so map ImgCheckState value from disabled to normal, as disabled state is expressed by ImgEnabled. + ImgEnabled := False; + ImgCheckState := ImgCheckState.GetEnabled(); + end;//if + + if ImgCheckType = ctTriStateCheckBox then + ImgCheckType := ctCheckBox; + if IsHot and (ImgCheckState in [csCheckedNormal, csUncheckedNormal]) and (GetKeyState(VK_LBUTTON) < 0) and (hiOnItemCheckbox in FLastHitInfo.HitPositions) then + System.Inc(ImgCheckState); // Advance to pressed state + + if ImgCheckType = ctNone then + Result := -1 + else + Result := CheckStateToCheckImage[ImgCheckType, ImgCheckState, ImgEnabled, IsHot]; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetColumnClass: TVirtualTreeColumnClass; + +begin + Result := TVirtualTreeColumn; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetHeaderClass: TVTHeaderClass; + +begin + Result := TVTHeader; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.GetImageIndex(var Info: TVTPaintInfo; Kind: TVTImageKind; InfoIndex: TVTImageInfoIndex); + +// Retrieves the image index and an eventual customized image list for drawing. + +var + CustomImages: TCustomImageList; + +begin + with Info do + begin + ImageInfo[InfoIndex].Index := -1; + ImageInfo[InfoIndex].Ghosted := False; + + CustomImages := DoGetImageIndex(Node, Kind, Column, ImageInfo[InfoIndex].Ghosted, ImageInfo[InfoIndex].Index); + if Assigned(CustomImages) then + ImageInfo[InfoIndex].Images := CustomImages + end; +end; + +function TBaseVirtualTree.GetImageSize(Node: PVirtualNode; Kind: TVTImageKind = TVTImageKind.ikNormal; Column: TColumnIndex = 0; IncludePadding: Boolean = True): TSize; + +// Determines whether the given node has got an image of the given kind in the given column. +// Returns the size of the image, or (0,0) if no image is available +// The given node will be implicitly initialized if needed. + +var + Ghosted: Boolean; + Index: TImageIndex; + lImageList: TCustomImageList; +begin + if not Assigned(OnGetImageIndexEx) and (((Kind = TVTImageKind.ikNormal) and not Assigned(fImages)) + or ((Kind = TVTImageKind.ikState) and not Assigned(fStateImages))) then + begin + Result.cx := 0; + Result.cy := 0; + end; + if not (vsInitialized in Node.States) then + InitNode(Node); + Index := -1; + Ghosted := False; + lImageList := DoGetImageIndex(Node, Kind, Column, Ghosted, Index); + if (Index > NoImage) or (Index = EmptyImage) then begin + if IncludePadding then + Result.cx := lImageList.Width + ScaledPixels(2) + else + Result.cx := lImageList.Width; + Result.cy := lImageList.Height; + end + else begin + Result.cx := 0; + Result.cy := 0; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.IsEmpty: Boolean; +begin + Result := (Self.ChildCount[nil] = 0); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetNodeImageSize(Node: PVirtualNode): TSize; + + // Returns the size of an image + // Override if you need different sized images for certain nodes. +begin + Result := GetImageSize(Node); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetMaxRightExtend(): TDimension; + +// Determines the maximum with of the currently visible part of the tree, depending on the length +// of the node texts. This method is used for determining the horizontal scroll range if no columns are used. + +var + Node, + NextNode: PVirtualNode; + TopPosition: TDimension; + CurrentWidth: TDimension; + +begin + Node := GetNodeAt(0, 0, True, TopPosition); + Result := 0; + if not Assigned(Node) then + exit; + + while Assigned(Node) do + begin + if not (vsInitialized in Node.States) then + InitNode(Node); + CurrentWidth := GetOffset(TVTElement.ofsRightOfText, Node); + if Result < (CurrentWidth) then + Result := CurrentWidth; + Inc(TopPosition, NodeHeight[Node]); + if TopPosition > Height then + Break; + + // Get next visible node and update left node position. + NextNode := GetNextVisible(Node, True); + if NextNode = nil then + Break; + Node := NextNode; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.GetNativeClipboardFormats(var Formats: TFormatEtcArray); + +// Returns the supported clipboard formats of the tree. + +begin + TClipboardFormatList.EnumerateFormats(TVirtualTreeClass(ClassType), Formats, FClipboardFormats); + // Ask application/descendants for self defined formats. + DoGetUserClipboardFormats(Formats); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetOperationCanceled; + +begin + Result := FOperationCanceled and (FOperationCount > 0); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetOptionsClass: TTreeOptionsClass; + +begin + Result := TCustomVirtualTreeOptions; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.HandleHotTrack(X, Y: TDimension); + +// Updates the current "hot" node. + +var + HitInfo: THitInfo; + CheckPositions: THitPositions; + ButtonIsHit, + DoInvalidate: Boolean; + oldHotNode : PVirtualNode; +begin + if not IsMouseCursorVisible then + begin + if Assigned(FCurrentHotNode) then + begin + InvalidateNode(FCurrentHotNode); + FCurrentHotNode := nil; + end; + Exit; + end;//if not IsMouseCursorVisible + + DoInvalidate := False; + oldHotNode := FCurrentHotNode; + // Get information about the hit. + GetHitTestInfoAt(X, Y, True, HitInfo, []); + + // Only make the new node being "hot" if its label is hit or full row selection is enabled. + CheckPositions := [hiOnItemLabel, hiOnItemCheckbox]; + + // If running under Windows Vista using the explorer theme hitting the buttons makes the node hot, too. + if tsUseExplorerTheme in FStates then + Include(CheckPositions, hiOnItemButtonExact); + + if (CheckPositions * HitInfo.HitPositions = []) and + (not (toFullRowSelect in FOptions.SelectionOptions) or (hiNowhere in HitInfo.HitPositions)) then + FCurrentHotNode := nil + else + FCurrentHotNode := HitInfo.HitNode; + if (FCurrentHotNode <> oldHotNode) or (HitInfo.HitColumn <> FCurrentHotColumn) then + begin + DoInvalidate := (toHotTrack in FOptions.PaintOptions) or (toCheckSupport in FOptions.MiscOptions) or (oldHotNode <> FCurrentHotNode); + DoHotChange(oldHotNode, HitInfo.HitNode); + if Assigned(oldHotNode) and DoInvalidate then + InvalidateNode(oldHotNode); + FCurrentHotColumn := HitInfo.HitColumn; + end; + + ButtonIsHit := (hiOnItemButtonExact in HitInfo.HitPositions); + if Assigned(HitInfo.HitNode) and ((FHotNodeButtonHit <> ButtonIsHit) or (FCurrentHotNode <> oldHotNode) or DoInvalidate) then + begin + FHotNodeButtonHit := ButtonIsHit; + InvalidateNode(HitInfo.HitNode); + end + else + if not Assigned(HitInfo.HitNode) then + FHotNodeButtonHit := False; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.HandleIncrementalSearch(CharCode: Word); + +var + Run, Stop: PVirtualNode; + GetNextNode: TGetNextNodeProc; + NewSearchText: string; + SingleLetter, + PreviousSearch: Boolean; // True if VK_BACK was sent. + SearchDirection: TVTSearchDirection; + + //--------------- local functions ------------------------------------------- + + procedure SetupNavigation; + + // If the search buffer is empty then we start searching with the next node after the last one, otherwise + // we continue with the last one. Node navigation function is set up too here, to avoid frequent checks. + + var + FindNextNode: Boolean; + + begin + FindNextNode := (Length(FSearchBuffer) = 0) or (Run = nil) or SingleLetter or PreviousSearch; + case FIncrementalSearch of + isVisibleOnly: + if SearchDirection = sdForward then + begin + GetNextNode := GetNextVisible; + if FindNextNode then + begin + if Run = nil then + Run := GetFirstVisible(nil, True) + else + begin + Run := GetNextVisible(Run, True); + // Do wrap around. + if Run = nil then + Run := GetFirstVisible(nil, True); + end; + end; + end + else + begin + GetNextNode := GetPreviousVisible; + if FindNextNode then + begin + if Run = nil then + Run := GetLastVisible(nil, True) + else + begin + Run := GetPreviousVisible(Run, True); + // Do wrap around. + if Run = nil then + Run := GetLastVisible(nil, True); + end; + end; + end; + isInitializedOnly: + if SearchDirection = sdForward then + begin + GetNextNode := GetNextNoInit; + if FindNextNode then + begin + if Run = nil then + Run := GetFirstNoInit + else + begin + Run := GetNextNoInit(Run); + // Do wrap around. + if Run = nil then + Run := GetFirstNoInit; + end; + end; + end + else + begin + GetNextNode := GetPreviousNoInit; + if FindNextNode then + begin + if Run = nil then + Run := GetLastNoInit + else + begin + Run := GetPreviousNoInit(Run); + // Do wrap around. + if Run = nil then + Run := GetLastNoInit; + end; + end; + end; + else + // isAll + if SearchDirection = sdForward then + begin + GetNextNode := GetNext; + if FindNextNode then + begin + if Run = nil then + Run := GetFirst + else + begin + Run := GetNext(Run); + // Do wrap around. + if Run = nil then + Run := GetFirst; + end; + end; + end + else + begin + GetNextNode := GetPrevious; + if FindNextNode then + begin + if Run = nil then + Run := GetLast + else + begin + Run := GetPrevious(Run); + // Do wrap around. + if Run = nil then + Run := GetLast; + end; + end; + end; + end; + end; + + //--------------------------------------------------------------------------- + + function CodePageFromLocale(Language: LCID): Integer; + + // Determines the code page for a given locale. + // Unfortunately there is no easier way than this, currently. + + var + Buf: array[0..6] of Char; + + begin + GetLocaleInfo(Language, LOCALE_IDEFAULTANSICODEPAGE, Buf, 6); + Result := StrToIntDef(Buf, GetACP); + end; + + //--------------------------------------------------------------------------- + + function KeyUnicode(C: Char): WideChar; + // Converts the given character into its corresponding Unicode character + // depending on the active keyboard layout. + begin + Result := C; //!!!!!! + end; + + //--------------- end local functions --------------------------------------- + +var + FoundMatch: Boolean; + NewChar: WideChar; + +begin + StopTimer(SearchTimer); + + if FIncrementalSearch <> isNone then + begin + if CharCode <> 0 then + begin + DoStateChange([tsIncrementalSearching]); + + // Convert the given virtual key code into a Unicode character based on the current locale. + NewChar := KeyUnicode(Char(CharCode)); + PreviousSearch := NewChar = WideChar(VK_BACK); + // We cannot do a search with an empty search buffer. + if not PreviousSearch or (FSearchBuffer <> '') then + begin + // Determine which method to use to advance nodes and the start node to search from. + case FSearchStart of + ssAlwaysStartOver: + Run := nil; + ssFocusedNode: + Run := FFocusedNode; + else // ssLastHit + Run := FLastSearchNode; + end; + + // Make sure the start node corresponds to the search criterion. + if Assigned(Run) then + begin + case FIncrementalSearch of + isInitializedOnly: + if not (vsInitialized in Run.States) then + Run := nil; + isVisibleOnly: + if not FullyVisible[Run] or IsEffectivelyFiltered[Run] then + Run := nil; + end; + end; + Stop := Run; + + // VK_BACK temporarily changes search direction to opposite mode. + if PreviousSearch then + begin + if SearchDirection = sdBackward then + SearchDirection := sdForward + else + SearchDirection := sdBackward; + end + else + SearchDirection := FSearchDirection; + // The "single letter mode" is used to advance quickly from node to node when pressing the same key several times. + SingleLetter := (Length(FSearchBuffer) = 1) and not PreviousSearch and (FSearchBuffer[1] = NewChar); + // However if the current hit (if there is one) would fit also with a repeated character then + // don't use single letter mode. + if SingleLetter and (DoIncrementalSearch(Run, FSearchBuffer + NewChar) = 0) then + SingleLetter := False; + SetupNavigation; + FoundMatch := False; + + if Assigned(Run) then + begin + if SingleLetter then + NewSearchText := FSearchBuffer + else + if PreviousSearch then + begin + SetLength(FSearchBuffer, Length(FSearchBuffer) - 1); + NewSearchText := FSearchBuffer; + end + else + NewSearchText := FSearchBuffer + NewChar; + + repeat + if DoIncrementalSearch(Run, NewSearchText) = 0 then + begin + FoundMatch := True; + Break; + end; + + // Advance to next node if we have not found a match. + Run := GetNextNode(Run); + // Do wrap around start or end of tree. + if (Run <> Stop) and (Run = nil) then + SetupNavigation; + until Run = Stop; + end; + + if FoundMatch then + begin + ClearSelection; + FSearchBuffer := NewSearchText; + FLastSearchNode := Run; + FocusedNode := Run; + AddToSelection(Run, False); + FLastSearchNode := Run; + end + else + // Play an acoustic signal if nothing could be found but don't beep if only the currently + // focused node matches. + if Assigned(Run) and (DoIncrementalSearch(Run, NewSearchText) <> 0) then + Beep; + end; + end; + + // Restart search timeout interval. + SetTimer(Handle, SearchTimer, FSearchTimeout, nil); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.HandleMouseDblClick(var Message: TWMMouse; const HitInfo: THitInfo); + +var + Node: PVirtualNode; + MayEdit: Boolean; + +begin + MayEdit := not (tsEditing in FStates) and (toEditOnDblClick in FOptions.MiscOptions); + if tsEditPending in FStates then + begin + StopTimer(EditTimer); + DoStateChange([], [tsEditPending]); + end; + + if not (tsEditing in FStates) or DoEndEdit then + begin + if HitInfo.HitColumn = FHeader.Columns.ClickIndex then + DoColumnDblClick(HitInfo.HitColumn, KeysToShiftState(Message.Keys)); + + if HitInfo.HitNode <> nil then + DoNodeDblClick(HitInfo); + + Node := nil; + if (hiOnItem in HitInfo.HitPositions) and (HitInfo.HitColumn > NoColumn) and + (coFixed in FHeader.Columns[HitInfo.HitColumn].Options) then + begin + if hiUpperSplitter in HitInfo.HitPositions then + Node := GetPreviousVisible(HitInfo.HitNode, True) + else + if hiLowerSplitter in HitInfo.HitPositions then + Node := HitInfo.HitNode; + end; + + if Assigned(Node) and (Node <> FRoot) and (toNodeHeightDblClickResize in FOptions.MiscOptions) then + begin + if DoNodeHeightDblClickResize(Node, HitInfo.HitColumn, KeysToShiftState(Message.Keys), Point(Message.XPos, Message.YPos)) then + begin + SetNodeHeight(Node, FDefaultNodeHeight); + UpdateWindow(); + MayEdit := False; + end; + end + else + if hiOnItemCheckBox in HitInfo.HitPositions then + begin + HandleCheckboxClick(HitInfo.HitNode, Message.Keys); + MayEdit := False; + end// if hiOnItemCheckBox + else + begin + if hiOnItemButton in HitInfo.HitPositions then + begin + ToggleNode(HitInfo.HitNode); + MayEdit := False; + end + else + begin + if toToggleOnDblClick in FOptions.MiscOptions then + begin + if ((([hiOnItemButton, hiOnItemLabel, hiOnNormalIcon, hiOnStateIcon] * HitInfo.HitPositions) <> []) or + ((toFullRowSelect in FOptions.SelectionOptions) and Assigned(HitInfo.HitNode))) then + begin + ToggleNode(HitInfo.HitNode); + MayEdit := False; + end; + end; + end; + end; + end; + + if MayEdit and Assigned(FFocusedNode) and (FFocusedNode = HitInfo.HitNode) and + (FFocusedColumn = HitInfo.HitColumn) and CanEdit(FFocusedNode, HitInfo.HitColumn) then + begin + DoStateChange([tsEditPending]); + FEditColumn := FFocusedColumn; + SetTimer(Handle, EditTimer, 0, nil); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.HandleCheckboxClick(pHitNode: PVirtualNode; pKeys: LongInt); +var + NewCheckState: TCheckState; +begin + NewCheckState := DetermineNextCheckState(pHitNode.CheckType, pHitNode.CheckState); + if (ssLeft in KeysToShiftState(pKeys)) and DoChecking(pHitNode, NewCheckState) then + begin + if (Self.SelectedCount > 1) and (Selected[pHitNode]) and not (toSyncCheckboxesWithSelection in TreeOptions.SelectionOptions) then + SetCheckStateForAll(NewCheckState, True) + else + DoCheckClick(pHitNode, NewCheckState); + end;//if ssLeft +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.HandleMouseDown(var Message: TWMMouse; var HitInfo: THitInfo); + +// centralized mouse button down handling + +var + LastFocused: PVirtualNode; + Column: TColumnIndex; + ShiftState: TShiftState; + + // helper variables to shorten boolean equations/expressions + AutoDrag, // automatic (or allowed) drag start + IsLabelHit, // the node's caption or images are hit + IsCellHit, // for grid extension or full row select (but not check box, button) + IsAnyHit, // either IsHit or IsCellHit + IsHeightTracking, // height tracking + MultiSelect, // multiselection is enabled + ShiftEmpty, // ShiftState = [] + NodeSelected: Boolean; // the new node (if any) is selected + NewColumn: Boolean; // column changed + NewNode: Boolean; // Node changed. + NeedChangeEvent: Boolean; // change event is required for selection change + CanClear: Boolean; + AltPressed: Boolean; // Pressing the Alt key enables special processing for selection. + FullRowDrag: Boolean; // Start dragging anywhere within a node's bound. + NodeRect: TRect; + + //--------------- local functions ------------------------------------------- + + //Fix for issue: 310 whenever there is a need to invalidate a column, consider + //auto spanned columns if applicable + procedure invalidateWithAutoSpan(acolumn: TColumnIndex; anode: PVirtualNode); + var + NextColumn: Integer; + Dummy: TColumnIndex; + begin + if (not FHeader.UseColumns) or (not (toAutoSpanColumns in FOptions.AutoOptions)) + or (acolumn = FHeader.MainColumn) then + begin + //no need to find auto spanned next columns + InvalidateColumn(acolumn); + exit; + end; + //invalidate auto spanned columns too + with FHeader.Columns do //standard loop for auto span + begin + NextColumn := acolumn; + repeat + InvalidateColumn(NextColumn); + Dummy := GetNextVisibleColumn(NextColumn); + if (Dummy = InvalidColumn) or + not ColumnIsEmpty(anode, Dummy) + or + (Items[Dummy].BidiMode <> bdLeftToRight) then + Break; + NextColumn := Dummy; + until False; + end; + end; + + //--------------- end local functions --------------------------------------- + +begin + if tsPanning in FStates then + begin + StopWheelPanning; + Exit; + end; + + if tsEditPending in FStates then + begin + StopTimer(EditTimer); + DoStateChange([], [tsEditPending]); + end; + + FLastHitInfo := HitInfo; // Save for later use in OnNodeClick event, see issue #692 + if (tsEditing in FStates) then begin + if not DoEndEdit then + exit; + // Repeat the hit test as an OnEdited event might got triggered that could modify the tree. + GetHitTestInfoAt(Message.XPos, Message.YPos, True, HitInfo, KeysToShiftState(Message.Keys)); + end;//if tsEditing + + // Focus change. Don't use the SetFocus method as this does not work for MDI Winapi.Windows. + if not Focused and CanFocus then + begin + Winapi.Windows.SetFocus(Handle); + // Repeat the hit test as an OnExit event might got triggered that could modify the tree. + GetHitTestInfoAt(Message.XPos, Message.YPos, True, HitInfo, KeysToShiftState(Message.Keys)); + FLastHitInfo := HitInfo; // See issue #1297 + end; + + if IsEmpty then + Exit; // Nothing to do + + // Keep clicked column in case the application needs it. + FHeader.Columns.ClickIndex := HitInfo.HitColumn; + + // Change column only if we have hit the node label. + if (hiOnItemLabel in HitInfo.HitPositions) or + (toFullRowSelect in FOptions.SelectionOptions) or + (toGridExtensions in FOptions.MiscOptions) then + begin + NewColumn := FFocusedColumn <> HitInfo.HitColumn; + if toExtendedFocus in FOptions.SelectionOptions then + Column := HitInfo.HitColumn + else + Column := FHeader.MainColumn; + end + else + begin + NewColumn := False; + Column := FFocusedColumn; + end; + + if NewColumn and not FHeader.AllowFocus(Column) then + begin + NewColumn := False; + Column := FFocusedColumn; + end; + + NewNode := FFocusedNode <> HitInfo.HitNode; + + // Translate keys and filter out shift and control key. + ShiftState := KeysToShiftState(Message.Keys) * [ssShift, ssCtrl, ssAlt]; + if ssAlt in ShiftState then + begin + AltPressed := True; + // Remove the Alt key from the shift state. It is not meaningful there. + Exclude(ShiftState, ssAlt); + end + else + AltPressed := False; + + // Various combinations determine what states the tree enters now. + // We initialize shorthand variables to avoid the following expressions getting too large + // and to avoid repeative expensive checks. + IsLabelHit := not AltPressed and not (toSimpleDrawSelection in FOptions.SelectionOptions) and + ((hiOnItemLabel in HitInfo.HitPositions) or (hiOnNormalIcon in HitInfo.HitPositions)); + + IsCellHit := not IsLabelHit and Assigned(HitInfo.HitNode) and + ([hiOnItemButton, hiOnItemCheckBox, hiNoWhere] * HitInfo.HitPositions = []) and + ((toFullRowSelect in FOptions.SelectionOptions) or + ((toGridExtensions in FOptions.MiscOptions) and (HitInfo.HitColumn > NoColumn))); + + IsAnyHit := IsLabelHit or IsCellHit; + MultiSelect := toMultiSelect in FOptions.SelectionOptions; + ShiftEmpty := ShiftState = []; + NodeSelected := IsAnyHit and (vsSelected in HitInfo.HitNode.States); + + // Determine the Drag behavior. + if MultiSelect and not (toDisableDrawSelection in FOptions.SelectionOptions) then + begin + // We have MultiSelect and want to draw a selection rectangle. + // We will start a full row drag only in case a label was hit, + // otherwise a multi selection will start. + FullRowDrag := (toFullRowDrag in FOptions.MiscOptions) and IsCellHit and + not (hiNowhere in HitInfo.HitPositions) and + (NodeSelected or (hiOnItemLabel in HitInfo.HitPositions) or (hiOnNormalIcon in HitInfo.HitPositions)); + end + else // No MultiSelect, hence we can start a drag anywhere in the row. + FullRowDrag := toFullRowDrag in FOptions.MiscOptions; + + IsHeightTracking := (Message.Msg = WM_LBUTTONDOWN) and + (hiOnItem in HitInfo.HitPositions) and + ([hiUpperSplitter, hiLowerSplitter] * HitInfo.HitPositions <> []); + + // Dragging might be started in the inherited handler manually (which is discouraged for stability reasons) + // the test for manual mode is done below (after the focused node is set). + AutoDrag := ((DragMode = TDragMode.dmAutomatic) or Dragging) and (not IsCellHit or FullRowDrag); + + // Query the application to learn if dragging may start now (if set to dmManual). + if Assigned(HitInfo.HitNode) and not AutoDrag and (DragMode = TDragMode.dmManual) then + AutoDrag := DoBeforeDrag(HitInfo.HitNode, Column) and (FullRowDrag or IsLabelHit); + + // handle node height tracking + if IsHeightTracking then + begin + if hiUpperSplitter in HitInfo.HitPositions then + FHeightTrackNode := GetPreviousVisible(HitInfo.HitNode, True) + else + FHeightTrackNode := HitInfo.HitNode; + + if CanSplitterResizeNode(Point(Message.XPos, Message.YPos), FHeightTrackNode, HitInfo.HitColumn) then + begin + FHeightTrackColumn := HitInfo.HitColumn; + NodeRect := GetDisplayRect(FHeightTrackNode, FHeightTrackColumn, False); + FHeightTrackPoint := Point(NodeRect.Left, NodeRect.Top); + DoStateChange([tsNodeHeightTrackPending]); + Exit; + end; + end; + + // handle button clicks + if (hiOnItemButton in HitInfo.HitPositions) and (vsHasChildren in HitInfo.HitNode.States) then + begin + ToggleNode(HitInfo.HitNode); + Exit; + end; + + // check event + if hiOnItemCheckBox in HitInfo.HitPositions then + begin + HandleCheckboxClick(HitInfo.HitNode, Message.Keys); + Exit; + end; + + // Keep this node's level in case we need it for constraint selection. + if (FRoot.ChildCount > 0) and ShiftEmpty or (FSelectionCount = 0) then + if Assigned(HitInfo.HitNode) then + FLastSelectionLevel := GetNodeLevelForSelectConstraint(HitInfo.HitNode) + else + FLastSelectionLevel := GetNodeLevelForSelectConstraint(GetLastVisibleNoInit(nil, True)); + + // immediate clearance + // Determine for the right mouse button if there is a popup menu. In this case and if drag'n drop is pending + // the current selection has to stay as it is. + with HitInfo, Message do + CanClear := not AutoDrag and + (not (tsRightButtonDown in FStates) or not HasPopupMenu(HitNode, HitColumn, Point(XPos, YPos))); + + // pending clearance + if MultiSelect and ShiftEmpty and not (hiOnItemCheckbox in HitInfo.HitPositions) and IsAnyHit and AutoDrag and + NodeSelected and not FSelectionLocked + then + DoStateChange([tsClearPending]); + + // User starts a selection with a selection rectangle. + if not (toDisableDrawSelection in FOptions.SelectionOptions) and not (IsLabelHit or FullRowDrag) and MultiSelect then + begin + SetCapture(Handle); + DoStateChange([tsDrawSelPending]); + FDrawSelShiftState := ShiftState; + FNewSelRect := Rect(Message.XPos + FEffectiveOffsetX, Message.YPos - FOffsetY, Message.XPos + FEffectiveOffsetX, + Message.YPos - FOffsetY); + FLastSelRect := Rect(0, 0, 0, 0); + end; + + NeedChangeEvent := FSelectionCount >= 1; + if not FSelectionLocked and ((not (IsAnyHit or FullRowDrag) and MultiSelect and ShiftEmpty) or + (IsAnyHit and (not NodeSelected or (NodeSelected and CanClear)) and (ShiftEmpty or not MultiSelect or (tsRightButtonDown in FStates)))) then + begin + // If the currently hit node was already selected then we have to reselect it again after clearing the current + // selection, but without a change event if it is the only selected node. + // The same applies if the Alt key is pressed, which allows to start drawing the selection rectangle also + // on node captions and images. Here the previous selection state does not matter, though. + if NodeSelected or (AltPressed and Assigned(HitInfo.HitNode) and (HitInfo.HitColumn = FHeader.MainColumn)) and not (hiNowhere in HitInfo.HitPositions) then + begin + InternalClearSelection; + InternalAddToSelection(HitInfo.HitNode, True); + if NeedChangeEvent then + begin + Invalidate; + Change(HitInfo.HitNode); + end; + end + else if (toAlwaysSelectNode in Self.TreeOptions.SelectionOptions) then + begin + if not (hiNowhere in HitInfo.HitPositions) then + ClearSelection(False) + else + if not (ssCtrl in ShiftState) then + DoStateChange([tsClearOnNewSelection], []); + end + else + ClearSelection(False); + end; + + // pending node edit + if Focused and + ((hiOnItemLabel in HitInfo.HitPositions) or ((toGridExtensions in FOptions.MiscOptions) and + (hiOnItem in HitInfo.HitPositions))) and NodeSelected and not NewColumn and ShiftEmpty and (SelectedCount = 1) then + begin + DoStateChange([tsEditPending]); + end; + + if not (toDisableDrawSelection in FOptions.SelectionOptions) + and not (IsLabelHit or FullRowDrag) and (MultiSelect or (hiNowhere in HitInfo.HitPositions)) then + begin + // The original code here was moved up to fix issue #187. + // In order not to break the semantics of this procedure, we are leaving these if statements here + if not IsCellHit then begin + if NeedChangeEvent then + Change(nil); + Exit; + end; + end; + + // Keep current mouse position. + FLastClickPos := Point(Message.XPos, Message.YPos); + + // Handle selection and node focus change. + if (IsLabelHit or IsCellHit) and + DoFocusChanging(FFocusedNode, HitInfo.HitNode, FFocusedColumn, Column) then + begin + if NewColumn then + begin + + if not Assigned(FFocusedNode) then + InvalidateColumn(FFocusedColumn) + else + invalidateWithAutoSpan(FFocusedColumn, FFocusedNode); //fix: issue 310 + if not Assigned(HitInfo.HitNode) then + InvalidateColumn(Column) + else + invalidateWithAutoSpan(Column, HitInfo.HitNode); //fix: issue 310 + FFocusedColumn := Column; + end; + if DragKind = dkDock then + begin + StopTimer(ScrollTimer); + DoStateChange([], [tsScrollPending, tsScrolling]); + end; + // Get the currently focused node to make multiple multi-selection blocks possible. + LastFocused := FFocusedNode; + if NewNode then + DoFocusNode(HitInfo.HitNode, False); + + if MultiSelect and not ShiftEmpty and not (tsRightButtonDown in FStates) then + HandleClickSelection(LastFocused, HitInfo.HitNode, ShiftState, AutoDrag) + else + begin + if ShiftEmpty then + FRangeAnchor := HitInfo.HitNode; + + // If the hit node is not yet selected then do it now. + if not NodeSelected then + AddToSelection(HitInfo.HitNode, True); + end; + + if NewNode or NewColumn then + begin + ScrollIntoView(FFocusedNode, False, + not (toDisableAutoscrollOnFocus in FOptions.AutoOptions) + and not (toFullRowSelect in FOptions.SelectionOptions)); + + DoFocusChange(FFocusedNode, FFocusedColumn); + end; + end; + + if (SelectedCount = 0) and NeedChangeEvent then + Change(nil); + + // Drag'n drop initiation + // If we lost focus in the interim the button states would be cleared in WM_KILLFOCUS. + if AutoDrag and IsAnyHit and (FStates * [tsLeftButtonDown, tsRightButtonDown, tsMiddleButtonDown] <> []) then + BeginDrag(False); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.HandleMouseUp(var Message: TWMMouse; const HitInfo: THitInfo); + +// Counterpart to the mouse down handler. + +var + ReselectFocusedNode: Boolean; + +begin + ReleaseCapture; + + if not (tsVCLDragPending in FStates) then + begin + // reset pending or persistent states + if IsMouseSelecting then + begin + DoStateChange([], [tsDrawSelecting, tsDrawSelPending, tsToggleFocusedSelection, tsClearOnNewSelection]); + Invalidate; + end; + + if tsClearPending in FStates then + begin + ReselectFocusedNode := Assigned(FFocusedNode) and (vsSelected in FFocusedNode.States); + ClearSelection; + if ReselectFocusedNode then + AddToSelection(FFocusedNode, False); + end; + + if (tsToggleFocusedSelection in FStates) and (HitInfo.HitNode = FFocusedNode) and Assigned(HitInfo.HitNode) then //Prevent AV when dereferencing HitInfo.HitNode below, see bug #100 + begin + if vsSelected in HitInfo.HitNode.States then + begin + if not (toAlwaysSelectNode in TreeOptions.SelectionOptions) or (Self.SelectedCount > 1) then + RemoveFromSelection(HitInfo.HitNode); + end + else + AddToSelection(HitInfo.HitNode, False); + end; + + DoStateChange([], [tsOLEDragPending, tsOLEDragging, tsClearPending, tsDrawSelPending, tsToggleFocusedSelection, + tsScrollPending, tsScrolling]); + StopTimer(ScrollTimer); + + if (FHeader.Columns.ClickIndex > NoColumn) and (FHeader.Columns.ClickIndex = HitInfo.HitColumn) then + DoColumnClick(HitInfo.HitColumn, KeysToShiftState(Message.Keys)); + + if FLastHitInfo.HitNode <> nil then begin // Use THitInfo of mouse down here, see issue #692 + DoNodeClick(FLastHitInfo); + if Assigned(FLastHitInfo.HitNode) then begin + InvalidateNode(FLastHitInfo.HitNode); + FLastHitInfo.HitNode := nil; // prevent firing the event again + end;//if + end; + + // handle a pending edit event + if tsEditPending in FStates then + begin + // Is the mouse still over the same node? + if (HitInfo.HitNode = FFocusedNode) and (hiOnItem in HitInfo.HitPositions) and + (toEditOnClick in FOptions.MiscOptions) and (FFocusedColumn = HitInfo.HitColumn) and + CanEdit(FFocusedNode, HitInfo.HitColumn) then + begin + FEditColumn := FFocusedColumn; + SetTimer(Handle, EditTimer, FEditDelay, nil); + end + else + DoStateChange([], [tsEditPending]); + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.HasImage(Node: PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex): Boolean; + +// Determines whether the given node has got an image of the given kind in the given column. +// Returns True if so, otherwise False. +// The given node will be implicitly initialized if needed. + +var + Ghosted: Boolean; + Index: TImageIndex; + +begin + if not (vsInitialized in Node.States) then + InitNode(Node); + + Index := -1; + Ghosted := False; + DoGetImageIndex(Node, Kind, Column, Ghosted, Index); + Result := Index > -1; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.HasPopupMenu(Node: PVirtualNode; Column: TColumnIndex; Pos: TPoint): Boolean; + +// Determines whether the tree got a popup menu, either in its PopupMenu property, via the OnGetPopupMenu event or +// through inheritance. The latter case must be checked by the descendant which must override this method. + +begin + Result := Assigned(PopupMenu) or Assigned(DoGetPopupMenu(Node, Column, Pos)); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.IncVisibleCount; +begin + System.Inc(FVisibleCount); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.InitChildren(Node: PVirtualNode); + +// Initiates the initialization of the child number of the given node. + +var + Count: Cardinal; + +begin + if Assigned(Node) and (Node <> FRoot) and (vsHasChildren in Node.States) then + begin + Count := Node.ChildCount; + if DoInitChildren(Node, Count) then + begin + SetChildCount(Node, Count); + if Count = 0 then + Exclude(Node.States, vsHasChildren); + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.InitNode(Node: PVirtualNode); + +// Initiates the initialization of the given node to allow the application to load needed data for it. + +var + InitStates: TVirtualNodeInitStates; + MustAdjustInternalVariables: Boolean; + ParentCheckState, SelfCheckState: TCheckState; +begin + with Node^ do + begin + Include(States, vsInitializing); + try + InitStates := []; + if vsInitialized in States then + Include(InitStates, ivsReInit); + Include(States, vsInitialized); + if Parent = FRoot then + DoInitNode(nil, Node, InitStates) + else + DoInitNode(Parent, Node, InitStates); + + // Fix: Any parent check state must be propagated here. + // Because the CheckType is normally set in DoInitNode + // by the App. + if (Node.CheckType = ctTriStateCheckBox) and (toAutoTristateTracking in FOptions.AutoOptions) then + begin + ParentCheckState := Self.GetCheckState(Node.Parent); + SelfCheckState := Self.GetCheckState(Node); + if ((ParentCheckState = csCheckedNormal) + or (ParentCheckState = csUncheckedNormal)) + and (not SelfCheckState.IsDisabled()) + and (SelfCheckState <> ParentCheckState) + and (Parent <> FRoot) + then + SetCheckState(Node, Node.Parent.CheckState); + end + else if (toSyncCheckboxesWithSelection in TreeOptions.SelectionOptions) then + Node.CheckType := TCheckType.ctCheckBox; + + if ivsDisabled in InitStates then + Include(States, vsDisabled); + if ivsHasChildren in InitStates then + Include(States, vsHasChildren); + if ivsSelected in InitStates then + InternalAddToSelection(Node, False); + if ivsMultiline in InitStates then + Include(States, vsMultiline); + if ivsFiltered in InitStates then + begin + MustAdjustInternalVariables := not ((ivsReInit in InitStates) and (vsFiltered in States)); + + Include(States, vsFiltered); + + if not (toShowFilteredNodes in FOptions.PaintOptions) and MustAdjustInternalVariables then + begin + AdjustTotalHeight(Node, -NodeHeight, True); + if FullyVisible[Node] then + System.Dec(FVisibleCount); + if FUpdateCount = 0 then + UpdateScrollBars(True); + end; + end; + + // Expanded may already be set (when called from ReinitNode) or be set in DoInitNode, allow both. + if (vsExpanded in Node.States) xor (ivsExpanded in InitStates) then + begin + // Expand node if not yet done (this will automatically initialize child nodes). + if ivsExpanded in InitStates then + ToggleNode(Node) + else + // If the node already was expanded then explicitly trigger child initialization. + if vsHasChildren in Node.States then + InitChildren(Node); + end; + finally + Exclude(States, vsInitializing); + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.InternalAddFromStream(Stream: TStream; Version: Integer; Node: PVirtualNode); + +// Loads all details for Node (including its children) from the given stream. +// Because the new nodes might be selected this method also fixes the selection array. + +var + Stop: PVirtualNode; + Index: Integer; + LastTotalHeight: TDimension; + WasFullyVisible: Boolean; + +begin + Assert(Node <> FRoot, 'The root node cannot be loaded from stream.'); + + // Keep the current total height value of Node as it has already been applied + // but might change in the load and fixup code. We have to adjust that afterwards. + LastTotalHeight := Node.TotalHeight; + WasFullyVisible := FullyVisible[Node] and not IsEffectivelyFiltered[Node]; + + // Read in the new nodes. + ReadNode(Stream, Version, Node); + + // One time update of node-internal states and the global visibility counter. + // This is located here to ease and speed up the loading process. + FixupTotalCount(Node); + AdjustTotalCount(Node.Parent, Node.TotalCount - 1, True); // -1 because Node itself was already set. + FixupTotalHeight(Node); + AdjustTotalHeight(Node.Parent, Node.TotalHeight - LastTotalHeight, True); + + // New nodes are always visible, so the visible node count has been increased already. + // If Node is now invisible we have to take back this increment and don't need to add any visible child node. + if not FullyVisible[Node] or IsEffectivelyFiltered[Node] then + begin + if WasFullyVisible then + System.Dec(FVisibleCount); + end + else + // It can never happen that the node is now fully visible but was not before as this would require + // that the visibility state of one of its parents has changed, which cannot happen during loading. + System.Inc(FVisibleCount, CountVisibleChildren(Node)); + + // Fix selection array. + ClearTempCache; + if Node = FRoot then + Stop := nil + else + Stop := Node.NextSibling; + + if toMultiSelect in FOptions.SelectionOptions then + begin + // Add all nodes which were selected before to the current selection (unless they are already there). + while Node <> Stop do + begin + if (vsSelected in Node.States) and not FindNodeInSelection(Node, Index, 0, High(FSelection)) then + InternalCacheNode(Node); + Node := GetNextNoInit(Node); + end; + if FTempNodeCount > 0 then + AddToSelection(FTempNodeCache, FTempNodeCount, True); + ClearTempCache; + end + else // No further selected nodes allowed so delete the corresponding flag in all new nodes. + while Node <> Stop do + begin + Exclude(Node.States, vsSelected); + Node := GetNextNoInit(Node); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.InternalAddToSelection(Node: PVirtualNode; ForceInsert: Boolean): Boolean; +var + lSingletonNodeArray: TNodeArray; +begin + Assert(Assigned(Node), 'Node must not be nil!'); + SetLength(lSingletonNodeArray, 1); + lSingletonNodeArray[0] := Node; + Result := InternalAddToSelection(lSingletonNodeArray, 1, ForceInsert); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.InternalAddToSelection(const NewItems: TNodeArray; NewLength: Integer; + ForceInsert: Boolean): Boolean; + +// Internal version of method AddToSelection which does not trigger OnChange events + +var + I, J: Integer; + CurrentEnd: Integer; + Constrained, + SiblingConstrained: Boolean; + lPreviousSelectedCount: Integer; + AddedNodesSize: Integer; + PTmpNode: PVirtualNode; + +begin + lPreviousSelectedCount := FSelectionCount; + // The idea behind this code is to use a kind of reverse merge sort. QuickSort is quite fast + // and would do the job here too but has a serious problem with already sorted lists like FSelection. + + // current number of valid entries + AddedNodesSize := 0; + + // 1) Remove already selected items, mark all other as being selected. + if ForceInsert then + begin + //Fix: For already selected node when selected, this path + //is used that didn't contain the Constraint logic. Added. + Constrained := toLevelSelectConstraint in FOptions.SelectionOptions; + if Constrained and (FLastSelectionLevel = -1) then + FLastSelectionLevel := GetNodeLevelForSelectConstraint(NewItems[0]); + AddedNodesSize := NewLength; + end + else + begin + Constrained := toLevelSelectConstraint in FOptions.SelectionOptions; + if Constrained and (FLastSelectionLevel = -1) then + FLastSelectionLevel := GetNodeLevelForSelectConstraint(NewItems[0]); + SiblingConstrained := toSiblingSelectConstraint in FOptions.SelectionOptions; + if SiblingConstrained and (FRangeAnchor = nil) then + FRangeAnchor := NewItems[0]; + + for I := 0 to NewLength - 1 do + if ([vsSelected, vsDisabled] * NewItems[I].States <> []) or + (Constrained and (Cardinal(FLastSelectionLevel) <> GetNodeLevel(NewItems[I]))) or + (SiblingConstrained and (FRangeAnchor.Parent <> NewItems[I].Parent)) + then + System.Inc(PAnsiChar(NewItems[I])) // mark as invalid by setting the LSB + else + System.Inc(AddedNodesSize); + end; + + I := PackArray(NewItems, NewLength); + if I > -1 then + NewLength := I; + + Result := NewLength > 0; + if Result then + begin + // 2) Sort the new item list so we can easily traverse it. + if NewLength > 1 then + QuickSort(NewItems, 0, NewLength - 1); + // 3) Make room in FSelection for the new items. + if lPreviousSelectedCount + NewLength >= Length(FSelection) then + SetLength(FSelection, lPreviousSelectedCount + NewLength); + + // 4) Merge in new items + J := NewLength - 1; + CurrentEnd := lPreviousSelectedCount - 1; + + while J >= 0 do + begin + // First insert all new entries which are greater than the greatest entry in the old list. + // If the current end marker is < 0 then there's nothing more to move in the selection + // array and only the remaining new items must be inserted. + if CurrentEnd >= 0 then + begin + while (J >= 0) and (PAnsiChar(NewItems[J]) > PAnsiChar(FSelection[CurrentEnd])) do + begin + FSelection[CurrentEnd + J + 1] := NewItems[J]; + System.Dec(J); + end; + // early out if nothing more needs to be copied + if J < 0 then + Break; + end + else + begin + // insert remaining new entries at position 0 + System.Move(NewItems[0], FSelection[0], (J + 1) * SizeOf(Pointer)); + // nothing more to do so exit main loop + Break; + end; + + // find the last entry in the remaining selection list which is smaller then the largest + // entry in the remaining new items list + FindNodeInSelection(NewItems[J], I, 0, CurrentEnd); + System.Dec(I); + // move all entries which are greater than the greatest entry in the new items list up + // so the remaining gap travels down to where new items must be inserted + System.Move(FSelection[I + 1], FSelection[I + J + 2], (CurrentEnd - I) * SizeOf(Pointer)); + CurrentEnd := I; + end; + + // update selection count + System.Inc(FSelectionCount, AddedNodesSize); + + // post process added nodes + // First set vsSelected flag for all newly selected nodes, then fire event + for I := 0 to AddedNodesSize - 1 do + Include(NewItems[I].States, vsSelected); + + for I := 0 to AddedNodesSize - 1 do + begin + PTmpNode := NewItems[I]; + // call on add event callbackevent + DoAddToSelection(PTmpNode); + if SyncCheckstateWithSelection[PTmpNode] then + checkstate[PTmpNode] := csCheckedNormal; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.InternalCacheNode(Node: PVirtualNode); + +// Adds the given node to the temporary node cache (used when collecting possibly large amounts of nodes). + +var + Len: Cardinal; + +begin + Len := Length(FTempNodeCache); + if FTempNodeCount = Len then + begin + if Len < 100 then + Len := 100 + else + Len := Len + Len div 10; + SetLength(FTempNodeCache, Len); + end; + FTempNodeCache[FTempNodeCount] := Node; + System.Inc(FTempNodeCount); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.InternalClearSelection(); + +var + Count: Integer; + lNode: PVirtualNode; +begin + // It is possible that there are invalid node references in the selection array + // if the tree update is locked and changes in the structure were made. + // Handle this potentially dangerous situation by packing the selection array explicitely. + if IsUpdating then + begin + Count := PackArray(FSelection, FSelectionCount); + if Count > -1 then + begin + FSelectionCount := Count; + SetLength(FSelection, FSelectionCount); + end; + end; + + while FSelectionCount > 0 do + begin + System.Dec(FSelectionCount); + lNode := FSelection[FSelectionCount]; + //sync path note: deselect when click on another or on outside area + Exclude(lNode.States, vsSelected); + if SyncCheckstateWithSelection[lNode] then + CheckState[lNode] := csUncheckedNormal; + DoRemoveFromSelection(lNode); + end; + ResetRangeAnchor; + FSelection := nil; + DoStateChange([], [tsClearPending]); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.InternalConnectNode(Node, Destination: PVirtualNode; Target: TBaseVirtualTree; + Mode: TVTNodeAttachMode); + +// Connects Node with Destination depending on Mode. +// No error checking takes place. Node as well as Destination must be valid. Node must never be a root node and +// Destination must not be a root node if Mode is amInsertBefore or amInsertAfter. + +var + Run: PVirtualNode; + +begin + // Keep in mind that the destination node might belong to another tree. + with Target do + begin + case Mode of + amInsertBefore: + begin + Node.SetPrevSibling(Destination.PrevSibling); + Destination.SetPrevSibling(Node); + Node.SetNextSibling(Destination); + Node.SetParent(Destination.Parent); + Node.SetIndex(Destination.Index); + if Node.PrevSibling = nil then + Node.Parent.SetFirstChild(Node) + else + Node.PrevSibling.SetNextSibling(Node); + + // reindex all following nodes + Run := Destination; + while Assigned(Run) do + begin + Run.SetIndex(Run.Index + 1); + Run := Run.NextSibling; + end; + end; + amInsertAfter: + begin + Node.SetNextSibling(Destination.NextSibling); + Destination.SetNextSibling(Node); + Node.SetPrevSibling(Destination); + Node.SetParent(Destination.Parent); + if Node.NextSibling = nil then + Node.Parent.SetLastChild(Node) + else + Node.NextSibling.SetPrevSibling(Node); + Node.SetIndex(Destination.Index); + + // reindex all following nodes + Run := Node; + while Assigned(Run) do + begin + Run.SetIndex(Run.Index + 1); + Run := Run.NextSibling; + end; + end; + amAddChildFirst: + begin + if Assigned(Destination.FirstChild) then + begin + // If there's a first child then there must also be a last child. + Destination.FirstChild.SetPrevSibling(Node); + Node.SetNextSibling(Destination.FirstChild); + Destination.SetFirstChild(Node); + end + else + begin + // First child node at this location. + Destination.SetFirstChild(Node); + Destination.SetLastChild(Node); + Node.SetNextSibling(nil); + end; + Node.SetPrevSibling(nil); + Node.SetParent(Destination); + Node.SetIndex(0); + // reindex all following nodes + Run := Node.NextSibling; + while Assigned(Run) do + begin + Run.SetIndex(Run.Index + 1); + Run := Run.NextSibling; + end; + end; + amAddChildLast: + begin + if Assigned(Destination.LastChild) then + begin + // If there's a last child then there must also be a first child. + Destination.LastChild.SetNextSibling(Node); + Node.SetPrevSibling(Destination.LastChild); + Destination.SetLastChild(Node); + end + else + begin + // first child node at this location + Destination.SetFirstChild(Node); + Destination.SetLastChild(Node); + Node.SetPrevSibling(nil); + end; + Node.SetNextSibling(nil); + Node.SetParent(Destination); + if Assigned(Node.PrevSibling) then + Node.SetIndex(Node.PrevSibling.Index + 1) + else + Node.SetIndex(0); + end; + else + // amNoWhere: do nothing + end; + // Remove temporary states. + Node.States := Node.States - [vsChecking, vsCutOrCopy, vsDeleting]; + + if (Mode <> amNoWhere) then begin + Node.Parent.SetChildCount(Node.Parent.ChildCount + 1); + Include(Node.Parent.States, vsHasChildren); + AdjustTotalCount(Node.Parent, Node.TotalCount, True); + + // Add the new node's height only if its parent is expanded. + if (vsExpanded in Node.Parent.States) and (vsVisible in Node.States) then begin + AdjustTotalHeight(Node.Parent, Node.TotalHeight, True); + System.Inc(FVisibleCount, CountVisibleChildren(Node) + Cardinal(IfThen(IsEffectivelyVisible[Node], 1))); + end;//if + + // Update the hidden children flag of the parent. + if (Node.Parent <> FRoot) then + begin + // If we have added a visible node then simply remove the all-children-hidden flag. + if IsEffectivelyVisible[Node] then + Exclude(Node.Parent.States, vsAllChildrenHidden) + else begin + // If we have added an invisible node and this is the only child node then + // make sure the all-children-hidden flag is in a determined state. + // If there were child nodes before then no action is needed. + if Node.Parent.ChildCount = 1 then + Include(Node.Parent.States, vsAllChildrenHidden); + end;//else + end; //if Node.Parent <> FRoot + end;//if Mode <> amNoWhere + end;//With +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.InternalData(Node: PVirtualNode): Pointer; + +begin + Result := nil; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.InternalDisconnectNode(Node: PVirtualNode; KeepFocus: Boolean; Reindex: Boolean = True; ParentClearing: Boolean = False); + +// Disconnects the given node from its parent and siblings. The node's pointer are not reset so they can still be used +// after return from this method (probably a very short time only!). +// If KeepFocus is True then the focused node is not reset. This is useful if the given node is reconnected to the tree +// immediately after return of this method and should stay being the focused node if it was it before. +// Note: Node must not be nil or the root node. + +var + Parent, + Run: PVirtualNode; + Index: Integer; + AdjustHeight: Boolean; + +begin + Assert(Assigned(Node) and (Node <> FRoot), 'Node must neither be nil nor the root node.'); + + if (Node = FFocusedNode) and not KeepFocus then + begin + DoFocusNode(nil, False); + DoFocusChange(FFocusedNode, FFocusedColumn); + end; + + if Node = FRangeAnchor then + ResetRangeAnchor; + + // Update the hidden children flag of the parent. + if (Node.Parent <> FRoot) and not (ParentClearing) then + if FUpdateCount = 0 then + DetermineHiddenChildrenFlag(Node.Parent) + else + Include(FStates, tsUpdateHiddenChildrenNeeded); + + if not (vsDeleting in Node.States) then + begin + // Some states are only temporary so take them out. + Node.States := Node.States - [vsChecking]; + Parent := Node.Parent; + Parent.SetChildCount(Parent.ChildCount - 1); + AdjustHeight := (vsExpanded in Parent.States) and (vsVisible in Node.States); + if Parent.ChildCount = 0 then + begin + Parent.States := Parent.States - [vsAllChildrenHidden, vsHasChildren]; + if (Parent <> FRoot) and (vsExpanded in Parent.States) then + Exclude(Parent.States, vsExpanded); + end; + AdjustTotalCount(Parent, -Integer(Node.TotalCount), True); + if AdjustHeight then + AdjustTotalHeight(Parent, -Node.TotalHeight, True); + if FullyVisible[Node] then + System.Dec(FVisibleCount, CountVisibleChildren(Node) + Cardinal(IfThen(IsEffectivelyVisible[Node], 1))); + + if Assigned(Node.PrevSibling) then + Node.PrevSibling.SetNextSibling(Node.NextSibling) + else + Parent.SetFirstChild(Node.NextSibling); + + if Assigned(Node.NextSibling) then + begin + Node.NextSibling.SetPrevSibling(Node.PrevSibling); + // Reindex all following nodes. + if Reindex then + begin + Run := Node.NextSibling; + Index := Node.Index; + while Assigned(Run) do + begin + Run.SetIndex(Index); + System.Inc(Index); + Run := Run.NextSibling; + end; + end; + end + else + Parent.SetLastChild(Node.PrevSibling); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.InternalRemoveFromSelection(Node: PVirtualNode); + +// Special version to mark a node to be no longer in the current selection. PackArray must +// be used to remove finally those entries. + +var + Index: Integer; + +begin + // Because pointers are always DWORD aligned we can simply increment all those + // which we want to have removed (see also PackArray) and still have the + // order in the list preserved. + if FindNodeInSelection(Node, Index, -1, -1) then + begin + //sync path note: deselect when overlapping drawselection is made + Exclude(Node.States, vsSelected); + if SyncCheckstateWithSelection[Node] then + Node.CheckState := csUncheckedNormal; // Avoid using SetCheckState() as it handles toSyncCheckboxesWithSelection as well. + System.Inc(PAnsiChar(FSelection[Index])); + DoRemoveFromSelection(Node); + Change(Node); // Calling Change() here fixes issue #1047 + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.InternalSetFocusedColumn(const index: TColumnIndex); +begin + FFocusedColumn := index; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.InvalidateCache; + +// Marks the cache as invalid. + +begin + DoStateChange([tsValidationNeeded], [tsUseCache]); + //ChangeTreeStatesAsync([csValidationNeeded], [csUseCache]); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.MarkCutCopyNodes; + +// Sets the vsCutOrCopy style in every currently selected but not disabled node to indicate it is +// now part of a clipboard operation. + +var + Nodes: TNodeArray; + I: Integer; + +begin + Nodes := nil; + if FSelectionCount > 0 then + begin + // need the current selection sorted to exclude selected nodes which are children, grandchildren etc. of + // already selected nodes + Nodes := GetSortedSelection(False); + for I := 0 to High(Nodes) do + with Nodes[I]^ do + if not (vsDisabled in States) then + Include(States, vsCutOrCopy); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.Loaded; + +var + LastRootCount: Cardinal; + IsReadOnly: Boolean; + +begin + inherited; + + // Call RegisterDragDrop after all visual inheritance changes to MiscOptions have been applied. + if not (csDesigning in ComponentState) and HandleAllocated and ((hoDrag in Header.Options) or (toAcceptOLEDrop in TreeOptions.MiscOptions)) then + RegisterDragDrop(Handle, DragManager as IDropTarget); + + // If a root node count has been set during load of the tree then update its child structure now + // as this hasn't been done yet in this case. + if (tsNeedRootCountUpdate in FStates) and (FRoot.ChildCount > 0) then + begin + DoStateChange([], [tsNeedRootCountUpdate]); + IsReadOnly := toReadOnly in FOptions.MiscOptions; + FOptions.InternalSetMiscOptions(FOptions.MiscOptions - [toReadOnly]); + LastRootCount := FRoot.ChildCount; + FRoot.SetChildCount(0); + BeginUpdate; + SetChildCount(FRoot, LastRootCount); + EndUpdate; + if IsReadOnly then + FOptions.InternalSetMiscOptions(FOptions.MiscOptions + [toReadOnly]); + end; + + // Prevent the object inspector at design time from marking the header as being modified + // when auto resize is enabled. + Updating; + try + TVTHeaderCracker(FHeader).UpdateMainColumn; + TVirtualTreeColumnsCracker(FHeader.Columns).FixPositions; + if toAutoBidiColumnOrdering in FOptions.AutoOptions then + TVirtualTreeColumnsCracker(FHeader.Columns).ReorderColumns(UseRightToLeftAlignment); + // Because of the special recursion and update stopper when creating the window (or resizing it) + // we have to manually trigger the auto size calculation here. + if hsNeedScaling in FHeader.States then + TVTHeaderCracker(FHeader).RescaleHeader + else + TVTHeaderCracker(FHeader).RecalculateHeader; + if hoAutoResize in FHeader.Options then + TVirtualTreeColumnsCracker(FHeader.Columns).AdjustAutoSize(InvalidColumn, True); + finally + Updated; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.MainColumnChanged; + +begin + DoCancelEdit; + NotifyAccessibleEvent(); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.MouseMove(Shift: TShiftState; X, Y: TDimension); + +var + R: TRect; + +begin + if tsNodeHeightTrackPending in FStates then + begin + // Remove hint if shown currently. + Application.CancelHint; + + // Stop wheel panning if active. + StopWheelPanning; + + // Stop timers + StopTimer(ExpandTimer); + StopTimer(EditTimer); + StopTimer(HeaderTimer); + StopTimer(ScrollTimer); + StopTimer(SearchTimer); + FSearchBuffer := ''; + FLastSearchNode := nil; + + DoStateChange([tsNodeHeightTracking], [tsScrollPending, tsScrolling, tsEditPending, tsOLEDragPending, tsVCLDragPending, + tsIncrementalSearching, tsNodeHeightTrackPending]); + end; + + if tsDrawSelPending in FStates then + begin + // Remove current selection in case the user clicked somewhere in the window (but not a node) + // and moved the mouse. + if CalculateSelectionRect(X, Y) then + begin + InvalidateRect(@FNewSelRect, False); + UpdateWindow(); + if (Abs(FNewSelRect.Right - FNewSelRect.Left) > Mouse.DragThreshold) or + (Abs(FNewSelRect.Bottom - FNewSelRect.Top) > Mouse.DragThreshold) then + begin + if tsClearPending in FStates then + begin + DoStateChange([], [tsClearPending]); + ClearSelection; + end; + DoStateChange([tsDrawSelecting], [tsDrawSelPending]); + + // Reset to main column for multiselection. + FocusedColumn := FHeader.MainColumn; + + // The current rectangle may already include some node captions. Handle this. + if HandleDrawSelection(X, Y) then + InvalidateRect(nil, False); + end; + end; + end + else + begin + if tsNodeHeightTracking in FStates then + begin + // Handle height tracking. + if DoNodeHeightTracking(FHeightTrackNode, FHeightTrackColumn, TVTHeaderCracker(FHeader).GetShiftState, FHeightTrackPoint, Point(X, Y)) then + begin + // Avoid negative (or zero) node heights. + if FHeightTrackPoint.Y >= Y then + Y := FHeightTrackPoint.Y + 1; + SetNodeHeight(FHeightTrackNode, Y - FHeightTrackPoint.Y); + UpdateWindow(); + Exit; + end; + end; + + // Really start dragging if the mouse has been moved more than the threshold. + if (tsOLEDragPending in FStates) and + ( + ((Abs(FLastClickPos.X - X) >= FDragThreshold) and (X > 0)) or // Check >0 to fix issue #833 + ((Abs(FLastClickPos.Y - Y) >= FDragThreshold) and (Y > 0)) + ) + then + DoDragging(FLastClickPos) + else + begin + if CanAutoScroll then + DoAutoScroll(X, Y); + if tsPanning in FStates then + AdjustPanningCursor(X, Y); + if not IsMouseSelecting then + begin + HandleHotTrack(X, Y); + inherited MouseMove(Shift, X, Y); + end + else + begin + // Handle draw selection if required, but don't do the work twice if the + // auto scrolling code already cares about the selection. + if not (tsScrolling in FStates) and CalculateSelectionRect(X, Y) then + begin + // If something in the selection changed then invalidate the entire + // tree instead trying to figure out the display rects of all changed nodes. + if HandleDrawSelection(X, Y) then + InvalidateRect(nil, False) + else + begin + UnionRect(R, OrderRect(FNewSelRect), OrderRect(FLastSelRect)); + OffsetRect(R, -FEffectiveOffsetX, FOffsetY); + InvalidateRect(@R, False); + end; + UpdateWindow(); + end; + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.Notification(AComponent: TComponent; Operation: TOperation); + +begin + if (AComponent <> Self) and (Operation = opRemove) then + begin + // Check for components linked to the tree. + if AComponent = FImages then + begin + Images := nil; + if not (csDestroying in ComponentState) then + Invalidate; + end + else + if AComponent = FStateImages then + begin + StateImages := nil; + if not (csDestroying in ComponentState) then + Invalidate; + end + else + if AComponent = FCustomCheckImages then + begin + CustomCheckImages := nil; + FCheckImageKind := ckSystemDefault; + if not (csDestroying in ComponentState) then + Invalidate; + end + else + if AComponent = PopupMenu then + PopupMenu := nil + else + // Check for components linked to the header. + if Assigned(FHeader) then + begin + if AComponent = FHeader.Images then + FHeader.Images := nil + else + if AComponent = FHeader.PopupMenu then + FHeader.PopupMenu := nil; + end; + end; + inherited; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.OriginalWMNCPaint(DC: HDC); + +// Unfortunately, the painting for the non-client area in TControl is not always correct and does also not consider +// existing clipping regions, so it has been modified here to take this into account. + +const + InnerStyles: array[TBevelCut] of Integer = (0, BDR_SUNKENINNER, BDR_RAISEDINNER, 0); + OuterStyles: array[TBevelCut] of Integer = (0, BDR_SUNKENOUTER, BDR_RAISEDOUTER, 0); + EdgeStyles: array[TBevelKind] of Integer = (0, 0, BF_SOFT, BF_FLAT); + Ctl3DStyles: array[Boolean] of Integer = (BF_MONO, 0); + +var + RC, RW: TRect; + EdgeSize: Integer; + Size: TSize; + +begin + if (BevelKind <> bkNone) or (BorderWidth > 0) then + begin + RC := Rect(0, 0, Width, Height); + Size := GetBorderDimensions; + InflateRect(RC, Size.cx, Size.cy); + + RW := RC; + + if BevelKind <> bkNone then + begin + DrawEdge(DC, RC, InnerStyles[BevelInner] or OuterStyles[BevelOuter], Byte(BevelEdges) or EdgeStyles[BevelKind] or + Ctl3DStyles[Ctl3D]); + + EdgeSize := 0; + if BevelInner <> bvNone then + Inc(EdgeSize, BevelWidth); + if BevelOuter <> bvNone then + Inc(EdgeSize, BevelWidth); + if beLeft in BevelEdges then + Inc(RC.Left, EdgeSize); + if beTop in BevelEdges then + Inc(RC.Top, EdgeSize); + if beRight in BevelEdges then + Dec(RC.Right, EdgeSize); + if beBottom in BevelEdges then + Dec(RC.Bottom, EdgeSize); + end; + + // Repaint only the part in the original clipping region and not yet drawn parts. + IntersectClipRect(DC, RC.Left, RC.Top, RC.Right, RC.Bottom); + + // Determine inner rectangle to exclude (RC corresponds then to the client area). + InflateRect(RC, -Integer(BorderWidth), -Integer(BorderWidth)); + + // Remove the inner rectangle. + ExcludeClipRect(DC, RC.Left, RC.Top, RC.Right, RC.Bottom); + + // Erase parts not drawn. + Brush.Color := FColors.BorderColor; + Winapi.Windows.FillRect(DC, RW, Brush.Handle); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.Paint; + +// Window paint routine. Used when the tree window needs to be updated. + +var + Window: TRect; + Target: TPoint; + Temp: TDimension; + Options: TVTInternalPaintOptions; + RTLOffset: TDimension; + +begin + + Options := [poBackground, poColumnColor, poDrawFocusRect, poDrawDropMark, poDrawSelection, poGridLines]; + if UseRightToLeftAlignment and FHeader.UseColumns then + RTLOffset := ComputeRTLOffset(True) + else + RTLOffset := 0; + + // The update rect has already been filled in WMPaint, as it is the window's update rect, which gets + // reset when BeginPaint is called (in the ancestor). + // The difference to the DC's clipbox is that it is also valid with internal paint operations used + // e.g. by the Explorer while dragging, but show window content while dragging is disabled. + if not IsRectEmpty(FUpdateRect) then + begin + Temp := Header.Columns.GetVisibleFixedWidth; + if Temp = 0 then + begin + Window := FUpdateRect; + Target := Window.TopLeft; + + // The clipping rectangle is given in client coordinates of the window. We have to convert it into + // a sliding window of the tree image. + OffsetRect(Window, FEffectiveOffsetX - RTLOffset, -FOffsetY); + PaintTree(Canvas, Window, Target, Options); + end + else + begin + // First part, fixed columns + Window := ClientRect; + Window.Right := Temp; + Target := Window.TopLeft; + + OffsetRect(Window, -RTLOffset, -FOffsetY); + PaintTree(Canvas, Window, Target, Options); + + // Second part, other columns + Window := GetClientRect; + + if Temp > Window.Right then + Exit; + + Window.Left := Temp; + Target := Window.TopLeft; + + OffsetRect(Window, FEffectiveOffsetX - RTLOffset, -FOffsetY); + PaintTree(Canvas, Window, Target, Options); + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.PaintCheckImage(Canvas: TCanvas; const ImageInfo: TVTImageInfo; Selected: Boolean); + +var + ForegroundColor: COLORREF; + R: TRect; + Details, lSizeDetails: TThemedElementDetails; + lSize: TSize; + Theme: HTHEME; + lCheckImages: TCustomImageList; +begin + with ImageInfo do + begin + if (tsUseThemes in FStates) and (FCheckImageKind = ckSystemDefault) then + begin + Details.Element := teButton; + case Index of + // ctRadioButton + 1 : Details := StyleServices.GetElementDetails(tbRadioButtonUncheckedNormal); + 2 : Details := StyleServices.GetElementDetails(tbRadioButtonUncheckedHot); + 3 : Details := StyleServices.GetElementDetails(tbRadioButtonUncheckedPressed); + 4 : Details := StyleServices.GetElementDetails(tbRadioButtonUncheckedDisabled); + 5 : Details := StyleServices.GetElementDetails(tbRadioButtonCheckedNormal); + 6 : Details := StyleServices.GetElementDetails(tbRadioButtonCheckedHot); + 7 : Details := StyleServices.GetElementDetails(tbRadioButtonCheckedPressed); + 8 : Details := StyleServices.GetElementDetails(tbRadioButtonCheckedDisabled); + // ct(TriState)CheckBox + 9 : Details := StyleServices.GetElementDetails(tbCheckBoxUncheckedNormal); + 10 : Details := StyleServices.GetElementDetails(tbCheckBoxUncheckedHot); + 11 : Details := StyleServices.GetElementDetails(tbCheckBoxUncheckedPressed); + 12 : Details := StyleServices.GetElementDetails(tbCheckBoxUncheckedDisabled); + 13 : Details := StyleServices.GetElementDetails(tbCheckBoxCheckedNormal); + 14 : Details := StyleServices.GetElementDetails(tbCheckBoxCheckedHot); + 15 : Details := StyleServices.GetElementDetails(tbCheckBoxCheckedPressed); + 16 : Details := StyleServices.GetElementDetails(tbCheckBoxCheckedDisabled); + 17 : Details := StyleServices.GetElementDetails(tbCheckBoxMixedNormal); + 18 : Details := StyleServices.GetElementDetails(tbCheckBoxMixedHot); + 19 : Details := StyleServices.GetElementDetails(tbCheckBoxMixedPressed); + 20 : Details := StyleServices.GetElementDetails(tbCheckBoxMixedDisabled); + // ctButton + ckButtonNormal: Details := StyleServices.GetElementDetails(tbPushButtonNormal); + ckButtonHot: Details := StyleServices.GetElementDetails(tbPushButtonHot); + ckButtonPressed: Details := StyleServices.GetElementDetails(tbPushButtonPressed); + ckButtonDisabled: Details := StyleServices.GetElementDetails(tbPushButtonDisabled); + else + Details := StyleServices.GetElementDetails(tbButtonRoot); + end; + if StyleServices.IsSystemStyle {and not (Index in [ckButtonNormal..ckButtonDisabled])} then + begin + Theme := OpenThemeData(Handle, 'BUTTON'); + GetThemePartSize(Theme, Canvas.Handle, Details.Part, Details.State, nil, TS_TRUE, lSize); + if (Index in [ckButtonNormal..ckButtonDisabled]) then begin + lSizeDetails := StyleServices.GetElementDetails(tbCheckBoxCheckedNormal); // Size of dropdown button should be based on size of checkboxes + GetThemePartSize(Theme, Canvas.Handle, lSizeDetails.Part, lSizeDetails.State, nil, TS_TRUE, lSize); + // dropdown buttons should be slightly larger than checkboxes, see issue #887 + lSize.cx := Round(lSize.cx * 1.15); + lSize.cy := Round(lSize.cy * 1.1); + end; + R := Rect(XPos, YPos, XPos + lSize.cx, YPos + lSize.cy); + if (Index in [ckButtonNormal..ckButtonDisabled]) then + R.Offset(-1, 0); // Eliminate 1 pixel border around Windows themed button + DrawThemeBackground(Theme, Canvas.Handle, Details.Part, Details.State, R, nil); + CloseThemeData(Theme); + end + else + begin + if (Index in [ckButtonNormal..ckButtonDisabled]) or not StyleServices.GetElementSize(Canvas.Handle, Details, TElementSize.esActual, lSize{$IF CompilerVersion >= 34}, CurrentPPI{$IFEND}) then begin + // radio buttons fail in RAD Studio 10 Seattle and lower, fallback to checkbox images. See issue #615 + if not StyleServices.GetElementSize(Canvas.Handle, StyleServices.GetElementDetails(tbCheckBoxUncheckedNormal), TElementSize.esActual, lSize{$IF CompilerVersion >= 34}, CurrentPPI{$IFEND}) then + lSize := TSize.Create(GetSystemMetrics(SM_CXMENUCHECK), GetSystemMetrics(SM_CYMENUCHECK)); + end;//if + R := Rect(XPos, YPos, XPos + lSize.cx, YPos + lSize.cy); + StyleServices.DrawElement(Canvas.Handle, Details, R {$IF CompilerVersion >= 34}, nil, FCurrentPPI{$IFEND}); + Canvas.Refresh; // Every time you give a Canvas.Handle away to some other code you can't control you have to call Canvas.Refresh afterwards because the Canvas object and the HDC can be out of sync. + end; + if (Index in [ckButtonNormal..ckButtonDisabled]) then begin + Canvas.Pen.Color := clGray; + // These constants have been determined by test using various themes and dpi-scalings + DrawArrow(Canvas, TScrollDirection.sdDown, Point(R.Left + Round(lSize.cx * 0.22), R.Top + Round(lSize.cy * 0.33)), Round(lSize.cx *0.28)); + end;//if + end + else begin + if Assigned(FCheckImages) then + lCheckImages := FCheckImages + else + lCheckImages := FCustomCheckImages; + with lCheckImages do + begin + if Selected and not Ghosted then + begin + if Focused or (TVTPaintOption.toPopupMode in FOptions.PaintOptions) then + ForegroundColor := ColorToRGB(FColors.FocusedSelectionColor) + else + ForegroundColor := ColorToRGB(FColors.UnfocusedSelectionColor); + end + else + ForegroundColor := GetRGBColor(BlendColor); + + ImageList_DrawEx(Handle, Index, Canvas.Handle, XPos, YPos, 0, 0, GetRGBColor(BkColor), ForegroundColor, + ILD_TRANSPARENT); + end; + end; //else + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + + +procedure TBaseVirtualTree.PaintImage(var PaintInfo: TVTPaintInfo; ImageInfoIndex: TVTImageInfoIndex; DoOverlay: Boolean); +const + Style: array[TImageType] of Cardinal = (0, ILD_MASK); +var + ExtraStyle: Cardinal; + CutNode: Boolean; + PaintFocused: Boolean; + DrawEnabled: Boolean; + CustomOverlayDrawing: Boolean; // False if the built-in overloay drawing of TImageList should be used, True if custom drawing should take place. +begin + with PaintInfo do + begin + CutNode := (vsCutOrCopy in Node.States) and (tsCutPending in FStates); + PaintFocused := Focused or (toGhostedIfUnfocused in FOptions.PaintOptions); + + // Since the overlay image must be specified together with the image to draw + // it is meaningfull to retrieve it in advance. + if DoOverlay then + GetImageIndex(PaintInfo, ikOverlay, iiOverlay) + else + PaintInfo.ImageInfo[iiOverlay].Index := -1; + + DrawEnabled := not (vsDisabled in Node.States) and Enabled; + with ImageInfo[ImageInfoIndex] do + begin + if (vsSelected in Node.States) and not(Ghosted or CutNode) then + begin + if PaintFocused or (toPopupMode in FOptions.PaintOptions) then + Images.BlendColor := FColors.FocusedSelectionColor + else + Images.BlendColor := FColors.UnfocusedSelectionColor; + end + else + Images.BlendColor := Color; + + ExtraStyle := ILD_TRANSPARENT; + // If the user returned an index >= 15 then we cannot use the built-in overlay image drawing. + // Instead we do it manually. Also of the image list of the normal and the overlay icon is different, + // we can't use the built-in drawing. See issue #779. + if (ImageInfo[iiOverlay].Index > -1) then begin + CustomOverlayDrawing := (ImageInfo[iiOverlay].Index >= 15) or (ImageInfo[iiOverlay].Images <> ImageInfo[iiNormal].Images); + if not CustomOverlayDrawing then + ExtraStyle := ILD_TRANSPARENT or ILD_OVERLAYMASK and IndexToOverlayMask(ImageInfo[iiOverlay].Index + 1); + end + else + CustomOverlayDrawing := False; + + // Blend image if enabled and the tree has the focus (or ghosted images must be drawn also if unfocused) ... + if (toUseBlendedImages in FOptions.PaintOptions) and PaintFocused + // ... and the image is ghosted... + and (Ghosted or + // ... or it is not the check image and the node is selected (but selection is not for the entire row)... + ((vsSelected in Node.States) and + not (toFullRowSelect in FOptions.SelectionOptions) and + not (toGridExtensions in FOptions.MiscOptions)) or + // ... or the node must be shown in cut mode. + CutNode) then + ExtraStyle := ExtraStyle or ILD_BLEND50; + + if (vsSelected in Node.States) and not Ghosted then + Images.BlendColor := clDefault; + + DrawImage(Images, Index, Canvas, XPos, YPos, Style[Images.ImageType] or ExtraStyle, DrawEnabled); + + // Now, draw the overlay. This circumnavigates limitations in the overlay mask index (it has to be 4 bits in size, + // anything larger will be truncated by the ILD_OVERLAYMASK). + // However this will only be done if the overlay image index is > 15, to avoid breaking code that relies + // on overlay image indices (e.g. when using system image lists). + if CustomOverlayDrawing then begin + ExtraStyle := ExtraStyle and not ILD_BLEND50; // Fixes issue #551 + // Note: XPos and YPos are those of the normal images. + DrawImage(ImageInfo[iiOverlay].Images, ImageInfo[iiOverlay].Index, Canvas, XPos, YPos, + Style[ImageInfo[iiOverlay].Images.ImageType] or ExtraStyle, DrawEnabled); + end;//if + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.PaintNodeButton(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; const R: TRect; + ButtonX, ButtonY: TDimension; BidiMode: TBiDiMode); + +var + Bitmap: TBitmap; + XPos: TDimension; + IsHot: Boolean; + IsSelected : boolean; + Theme: HTHEME; + Glyph: Integer; + State: Integer; + Pos: TRect; + +begin + IsHot := (FCurrentHotNode = Node) and FHotNodeButtonHit; + IsSelected := (vsSelected in Node.States); + + // Draw the node's plus/minus button according to the directionality. + if BidiMode = bdLeftToRight then + XPos := R.Left + ButtonX + else + XPos := R.Right - ButtonX - FPlusBM.Width; + + if (tsUseExplorerTheme in FStates) and not VclStyleEnabled then + begin + Glyph := IfThen(IsHot, TVP_HOTGLYPH, TVP_GLYPH); + State := IfThen(vsExpanded in Node.States, GLPS_OPENED, GLPS_CLOSED); + Pos := Rect(XPos, R.Top + ButtonY, XPos + FPlusBM.Width, R.Top + ButtonY + FPlusBM.Height); + Theme := OpenThemeData(Handle, 'TREEVIEW'); + DrawThemeBackground(Theme, Canvas.Handle, Glyph, State, Pos, nil); + CloseThemeData(Theme); + end + else + begin + if vsExpanded in Node.States then + begin + if IsHot then + begin + if IsSelected then + BitMap := FSelectedHotMinusBM + else + Bitmap := FHotMinusBM; + end + else + Bitmap := FMinusBM; + end + else + begin + if IsHot then + begin + if IsSelected then + BitMap := FSelectedHotPlusBM + else + Bitmap := FHotPlusBM; + end + else + Bitmap := FPlusBM; + end; + // Need to draw this masked. + Canvas.Draw(XPos, R.Top + ButtonY, Bitmap); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.PaintTreeLines(const PaintInfo: TVTPaintInfo; IndentSize: TDimension; const LineImage: TLineImage); + +var + I: Integer; + XPos, + Offset: TDimension; + NewStyles: TLineImage; + +begin + NewStyles := nil; + + with PaintInfo do + begin + if BidiMode = bdLeftToRight then + begin + XPos := CellRect.Left + PaintInfo.Offsets[ofsMargin]; + Offset := FIndent; + end + else + begin + Offset := -FIndent; + XPos := CellRect.Right - PaintInfo.Offsets[ofsMargin] + Offset; + end; + + case FLineMode of + lmBands: + if poGridLines in PaintInfo.PaintOptions then + begin + // Convert the line images in correct bands. + SetLength(NewStyles, Length(LineImage)); + for I := IndentSize - 1 downto 0 do + begin + if (vsExpanded in Node.States) and not (vsAllChildrenHidden in Node.States) then + NewStyles[I] := ltLeft + else + case LineImage[I] of + ltRight, + ltBottomRight, + ltTopDownRight, + ltTopRight: + NewStyles[I] := ltLeftBottom; + ltNone: + // Have to take over the image to the right of this one. A no line entry can never appear as + // last entry so I don't need an end check here. + if LineImage[I + 1] in [ltNone, ltTopRight] then + NewStyles[I] := NewStyles[I + 1] + else + NewStyles[I] := ltLeft; + ltTopDown: + // Have to check the image to the right of this one. A top down line can never appear as + // last entry so I don't need an end check here. + if LineImage[I + 1] in [ltNone, ltTopRight] then + NewStyles[I] := NewStyles[I + 1] + else + NewStyles[I] := ltLeft; + end; + end; + + PaintInfo.Canvas.Font.Color := FColors.GridLineColor; + for I := 0 to IndentSize - 1 do + begin + DoBeforeDrawLineImage(PaintInfo.Node, I + Ord(not (toShowRoot in TreeOptions.PaintOptions)), XPos); + DrawLineImage(PaintInfo, XPos, CellRect.Top, NodeHeight[Node] - 1, VAlign - 1, NewStyles[I], + BidiMode <> bdLeftToRight); + Inc(XPos, Offset); + end; + end; + else // lmNormal + PaintInfo.Canvas.Font.Color := FColors.TreeLineColor; + for I := 0 to IndentSize - 1 do + begin + DoBeforeDrawLineImage(PaintInfo.Node, I + Ord(not (toShowRoot in TreeOptions.PaintOptions)), XPos); + DrawLineImage(PaintInfo, XPos, CellRect.Top, NodeHeight[Node], VAlign - 1, LineImage[I], + BidiMode <> bdLeftToRight); + Inc(XPos, Offset); + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.PaintSelectionRectangle(Target: TCanvas; WindowOrgX: TDimension; const SelectionRect: TRect; + TargetRect: TRect); + +// Helper routine to draw a selection rectangle in the mode determined by DrawSelectionMode. + +var + BlendRect: TRect; + TextColorBackup, + BackColorBackup: COLORREF; // used to restore forground and background colors when drawing a selection rectangle + +begin + if ((FDrawSelectionMode = smDottedRectangle) and not (tsUseThemes in FStates)) then + begin + // Classical selection rectangle using dotted borderlines. + TextColorBackup := GetTextColor(Target.Handle); + SetTextColor(Target.Handle, $FFFFFF); + BackColorBackup := GetBkColor(Target.Handle); + SetBkColor(Target.Handle, 0); + Target.DrawFocusRect(SelectionRect); + SetTextColor(Target.Handle, TextColorBackup); + SetBkColor(Target.Handle, BackColorBackup); + end + else + begin + // Modern alpha blended style. + OffsetRect(TargetRect, WindowOrgX, 0); + if IntersectRect(BlendRect, OrderRect(SelectionRect), TargetRect) then + begin + OffsetRect(BlendRect, -WindowOrgX, 0); + AlphaBlend(0, Target.Handle, BlendRect, Point(0, 0), bmConstantAlphaAndColor, FSelectionBlendFactor, + ColorToRGB(FColors.SelectionRectangleBlendColor)); + + Target.Brush.Color := FColors.SelectionRectangleBorderColor; + Target.FrameRect(SelectionRect); + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.PrepareCell(var PaintInfo: TVTPaintInfo; WindowOrgX, MaxWidth: TDimension); + +// This method is called immediately before a cell's content is drawn und is responsible to paint selection colors etc. + +var + TextColorBackup, + BackColorBackup: COLORREF; + FocusRect, + InnerRect: TRect; + RowRect: TRect; + Theme: HTHEME; +const + TREIS_HOTSELECTED = 6; + + //--------------- local functions ------------------------------------------- + + procedure AlphaBlendSelection(Color: TColor); + + var + R: TRect; + + begin + // Take into account any window offset and size limitations in the target bitmap, as this is only as large + // as necessary and might not cover the whole node. For normal painting this does not matter (because of + // clipping) but for the MMX code there is no such check and it will crash badly when bitmap boundaries are + // crossed. + R := InnerRect; + OffsetRect(R, -WindowOrgX, 0); + if R.Left < 0 then + R.Left := 0; + if R.Right > MaxWidth then + R.Right := MaxWidth; + AlphaBlend(0, PaintInfo.Canvas.Handle, R, Point(0, 0), bmConstantAlphaAndColor, + FSelectionBlendFactor, ColorToRGB(Color)); + end; + + //--------------------------------------------------------------------------- + + procedure DrawBackground(State: Integer); + begin + // if the full row selection is disabled or toGridExtensions is in the MiscOptions, draw the selection + // into the InnerRect, otherwise into the RowRect + if not (toFullRowSelect in FOptions.SelectionOptions) or (toGridExtensions in FOptions.MiscOptions) then + DrawThemeBackground(Theme, PaintInfo.Canvas.Handle, TVP_TREEITEM, State, InnerRect, nil) + else + DrawThemeBackground(Theme, PaintInfo.Canvas.Handle, TVP_TREEITEM, State, RowRect, nil); + end; + + procedure DrawThemedFocusRect(State: Integer); + var + Theme: HTHEME; + begin + Theme := OpenThemeData(Application.ActiveFormHandle, 'Explorer::ItemsView'); + if not (toFullRowSelect in FOptions.SelectionOptions) or (toGridExtensions in FOptions.MiscOptions) then + DrawThemeBackground(Theme, PaintInfo.Canvas.Handle, LVP_LISTDETAIL, State, InnerRect, nil) + else + DrawThemeBackground(Theme, PaintInfo.Canvas.Handle, LVP_LISTDETAIL, State, RowRect, nil); + CloseThemeData(Theme); + end; + + //--------------- end local functions --------------------------------------- + +begin + if tsUseExplorerTheme in FStates then + begin + Theme := OpenThemeData(Application.ActiveFormHandle, 'Explorer::TreeView'); + RowRect := Rect(0, PaintInfo.CellRect.Top, FRangeX, PaintInfo.CellRect.Bottom); + if (Header.Columns.Count = 0) and (toFullRowSelect in TreeOptions.SelectionOptions) then + RowRect.Right := Max(ClientWidth, RowRect.Right); + if toShowVertGridLines in FOptions.PaintOptions then + Dec(RowRect.Right); + end; + + with PaintInfo, Canvas do + begin + // Fill cell background if its color differs from tree background. + with FHeader.Columns do + if poColumnColor in PaintOptions then + begin + Brush.Color := Items[Column].GetEffectiveColor; + FillRect(CellRect); + end; + + // Let the application customize the cell background and the content rectangle. + DoBeforeCellPaint(Canvas, Node, Column, cpmPaint, CellRect, ContentRect); + + InnerRect := ContentRect; + + // The selection rectangle depends on alignment. + if not (toGridExtensions in FOptions.MiscOptions) then + begin + case Alignment of + taLeftJustify: + if InnerRect.Left + NodeWidth < InnerRect.Right then + InnerRect.Right := InnerRect.Left + NodeWidth; + taCenter: + if (InnerRect.Right - InnerRect.Left) > NodeWidth then + begin + InnerRect.Left := Divide(InnerRect.Left + InnerRect.Right - NodeWidth, 2); + InnerRect.Right := InnerRect.Left + NodeWidth; + end; + taRightJustify: + if (InnerRect.Right - InnerRect.Left) > NodeWidth then + InnerRect.Left := InnerRect.Right - NodeWidth; + end; + end; + + if (Column = FFocusedColumn) or (toFullRowSelect in FOptions.SelectionOptions) then + begin + // Fill the selection rectangle. + if poDrawSelection in PaintOptions then + begin + if Node = FDropTargetNode then + begin + if (FLastDropMode = dmOnNode) or (vsSelected in Node.States) then + begin + Brush.Color := FColors.DropTargetColor; + Pen.Color := FColors.DropTargetBorderColor; + + if (toGridExtensions in FOptions.MiscOptions) or + (toFullRowSelect in FOptions.SelectionOptions) then + InnerRect := CellRect; + if not IsRectEmpty(InnerRect) then + if tsUseExplorerTheme in FStates then + DrawBackground(TREIS_SELECTED) + else + if (toUseBlendedSelection in FOptions.PaintOptions) then + AlphaBlendSelection(Brush.Color) + else + RoundRect(InnerRect.Left, InnerRect.Top, InnerRect.Right, InnerRect.Bottom, FSelectionCurveRadius, FSelectionCurveRadius); + end + else + begin + Brush.Style := bsClear; + end; + end + else + if vsSelected in Node.States then + begin + if Focused or (toPopupMode in FOptions.PaintOptions) then + begin + Brush.Color := FColors.FocusedSelectionColor; + Pen.Color := FColors.FocusedSelectionBorderColor; + end + else + begin + Brush.Color := FColors.UnfocusedSelectionColor; + Pen.Color := FColors.UnfocusedSelectionBorderColor; + end; + if (toGridExtensions in FOptions.MiscOptions) or (toFullRowSelect in FOptions.SelectionOptions) then + InnerRect := CellRect; + if not IsRectEmpty(InnerRect) then + if tsUseExplorerTheme in FStates then + begin + // If the node is also hot, its background will be drawn later. + if not (toHotTrack in FOptions.PaintOptions) or (Node <> FCurrentHotNode) or + ((Column <> FCurrentHotColumn) and not (toFullRowSelect in FOptions.SelectionOptions)) then + DrawBackground(IfThen(Self.Focused, TREIS_SELECTED, TREIS_SELECTEDNOTFOCUS)); + end + else + if (toUseBlendedSelection in FOptions.PaintOptions) then + AlphaBlendSelection(Brush.Color) + else + RoundRect(InnerRect.Left, InnerRect.Top, InnerRect.Right, InnerRect.Bottom, FSelectionCurveRadius, FSelectionCurveRadius); + end; + end; + end; + + if (tsUseExplorerTheme in FStates) and (toHotTrack in FOptions.PaintOptions) and (Node = FCurrentHotNode) and + ((Column = FCurrentHotColumn) or (toFullRowSelect in FOptions.SelectionOptions)) then + DrawBackground(IfThen((vsSelected in Node.States) and not (toAlwaysHideSelection in FOptions.PaintOptions), + TREIS_HOTSELECTED, TREIS_HOT)); + + if (Column = FFocusedColumn) or (toFullRowSelect in FOptions.SelectionOptions) then + begin + // draw focus rect + if (poDrawFocusRect in PaintOptions) and + (Focused or (toPopupMode in FOptions.PaintOptions)) and (FFocusedNode = Node) and + ( (Column = FFocusedColumn) or + (not (toExtendedFocus in FOptions.SelectionOptions) and + (toFullRowSelect in FOptions.SelectionOptions) and + (tsUseExplorerTheme in FStates) ) ) then + begin + TextColorBackup := GetTextColor(Handle); + SetTextColor(Handle, $FFFFFF); + BackColorBackup := GetBkColor(Handle); + SetBkColor(Handle, 0); + + if not (toExtendedFocus in FOptions.SelectionOptions) and (toFullRowSelect in FOptions.SelectionOptions) and + (tsUseExplorerTheme in FStates) then + FocusRect := RowRect + else + if toGridExtensions in FOptions.MiscOptions then + FocusRect := CellRect + else + FocusRect := InnerRect; + + if tsUseExplorerTheme in FStates then + InflateRect(FocusRect, -1, -1); + + if (tsUseExplorerTheme in FStates) then + begin + //Draw focused unselected style like Windows 7 Explorer + if not (vsSelected in Node.States) then + DrawThemedFocusRect(LIS_NORMAL) + else + DrawBackground(TREIS_HOTSELECTED); + end + else + Winapi.Windows.DrawFocusRect(Handle, FocusRect); + SetTextColor(Handle, TextColorBackup); + SetBkColor(Handle, BackColorBackup); + end; + end; + end; + + if tsUseExplorerTheme in FStates then + CloseThemeData(Theme); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +class procedure TBaseVirtualTree.RaiseVTError(const Msg: string; HelpContext: Integer); + +begin + raise EVirtualTreeError.CreateHelp(Msg, HelpContext); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.ReadChunk(Stream: TStream; Version: Integer; Node: PVirtualNode; ChunkType, + ChunkSize: Integer): Boolean; + +// Called while loading a tree structure, Node is already valid (allocated) at this point. +// The function handles the base and user chunks, any other chunk is marked as being unknown (result becomes False) +// and skipped. descendants may handle them by overriding this method. +// Returns True if the chunk could be handled, otherwise False. +type + TAdvancedVersion2Identifier = packed record + ChildCount: Cardinal; + NodeHeight: TDimension; + States: Word; + Align: Byte; + CheckState: TCheckState; + CheckType: TCheckType; + Reserved: Cardinal; + end; + +var + IdBody: TAdvancedVersion2Identifier; + ChunkBody: TBaseChunkBody; + Run: PVirtualNode; + LastPosition: Integer; + +begin + case ChunkType of + BaseChunk: + begin + // Load base chunk's body (chunk header has already been consumed). + case Version of + 1: + begin + with ChunkBody do + begin + // In version prior to 2 there was a smaller chunk body. Hence we have to read it entry by entry now. + Stream.Read(ChildCount, SizeOf(ChildCount)); + Stream.Read(NodeHeight, SizeOf(NodeHeight)); + // TVirtualNodeStates was a byte sized type in version 1. + States := []; + Stream.Read(States, SizeOf(Byte)); + // vsVisible is now in the place where vsSelected was before, but every node was visible in the old version + // so we need to fix this too. + if vsVisible in States then + //sync path note: prior version stream reading, ignored for syncing + Include(States, vsSelected) + else + Include(States, vsVisible); + Stream.Read(Align, SizeOf(Align)); + Stream.Read(CheckState, SizeOf(CheckState)); + Stream.Read(CheckType, SizeOf(CheckType)); + end; + end; + 2: + begin + ZeroMemory(@IdBody, SizeOf(IdBody)); + Stream.Read(IdBody, SizeOf(IdBody)); + // If Align is greater than zero, we have a stream prior to VT version 6.2 + if IdBody.Align > 0 then + with ChunkBody do + begin + ChildCount := IdBody.ChildCount; + NodeHeight := IdBody.NodeHeight; + States := []; + System.Move(IdBody.States, States, SizeOf(IdBody.States)); + CheckState := IdBody.CheckState; + CheckType := IdBody.CheckType; + Reserved := IdBody.Reserved; + end + else + begin + // Stream is compatible with current size of TBaseChunkBody + Stream.Position := Stream.Position - SizeOf(IdBody); + Stream.Read(ChunkBody, SizeOf(ChunkBody)); + end; + end; + 3: + Stream.Read(ChunkBody, SizeOf(ChunkBody)); + end; + + with Node^ do + begin + // Set states first, in case the node is invisible. + States := ChunkBody.States; + SetNodeHeight(ChunkBody.NodeHeight); + TotalHeight := NodeHeight; + Align := ChunkBody.Align; + CheckState := ChunkBody.CheckState; + CheckType := ChunkBody.CheckType; + SetChildCount(ChunkBody.ChildCount); + + // Create and read child nodes. + while ChunkBody.ChildCount > 0 do + begin + Run := MakeNewNode; + + Run.SetPrevSibling(Node.LastChild); + if Assigned(Run.PrevSibling) then + Run.SetIndex(Run.PrevSibling.Index + 1); + if Assigned(Node.LastChild) then + Node.LastChild.SetNextSibling(Run) + else + Node.SetFirstChild(Run); + Node.SetLastChild(Run); + Run.SetParent(Node); + + ReadNode(Stream, Version, Run); + System.Dec(ChunkBody.ChildCount); + end; + end; + Result := True; + end; + UserChunk: + if ChunkSize > 0 then + begin + // need to know whether the data was read + LastPosition := Stream.Position; + DoLoadUserData(Node, Stream); + // compare stream position to learn whether the data was read + Result := Stream.Position > LastPosition; + // Improve stability by advancing the stream to the chunk's real end if + // the application did not read what has been written. + if not Result or (Stream.Position <> (LastPosition + ChunkSize)) then + Stream.Position := LastPosition + ChunkSize; + end + else + Result := True; + else + // unknown chunk, skip it + Stream.Position := Stream.Position + ChunkSize; + Result := False; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.ReadNode(Stream: TStream; Version: Integer; Node: PVirtualNode); + +// Reads the anchor chunk of each node and initiates reading the sub chunks for this node + +var + Header: TChunkHeader; + EndPosition: Integer; + +begin + with Stream do + begin + // Read anchor chunk of the node. + Stream.Read(Header, SizeOf(Header)); + if Header.ChunkType = NodeChunk then + begin + EndPosition := Stream.Position + Header.ChunkSize; + // Read all subchunks until the indicated chunk end position is reached in the stream. + while Position < EndPosition do + begin + // Read new chunk header. + Stream.Read(Header, SizeOf(Header)); + ReadChunk(Stream, Version, Node, Header.ChunkType, Header.ChunkSize); + end; + // If the last chunk does not end at the given end position then there is something wrong. + if Position <> EndPosition then + RaiseVTError(SCorruptStream2, hcTFCorruptStream2); + end + else + RaiseVTError(SCorruptStream1, hcTFCorruptStream1); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.RedirectFontChangeEvent(Canvas: TCanvas); + +begin + if @Canvas.Font.OnChange <> @FOldFontChange then + begin + FOldFontChange := Canvas.Font.OnChange; + Canvas.Font.OnChange := FontChanged; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.RemoveFromSelection(Node: PVirtualNode); + +var + Index: Integer; + +begin + if not FSelectionLocked then + begin + Assert(Assigned(Node), 'Node must not be nil!'); + Assert(GetCurrentThreadId = MainThreadId, Self.Classname + '.RemoveFromSelection() must only be called from UI thread.'); + if vsSelected in Node.States then + begin + Assert(FSelectionCount > 0, 'if one node has set the vsSelected flag, SelectionCount must be >0.'); + //sync path note: deselect when a ctrl click removes a selection + Exclude(Node.States, vsSelected); + if SyncCheckstateWithSelection[Node] then + Node.CheckState := csUncheckedNormal; // Avoid using SetCheckState() as it handles toSyncCheckboxesWithSelection as well. + + if FindNodeInSelection(Node, Index, -1, -1) and (Index < FSelectionCount - 1) then + System.Move(FSelection[Index + 1], FSelection[Index], (FSelectionCount - Index - 1) * SizeOf(Pointer)); + if FSelectionCount > 0 then + System.Dec(FSelectionCount); + SetLength(FSelection, FSelectionCount); + + if FSelectionCount = 0 then + ResetRangeAnchor; + + if FSelectionCount <= 1 then + UpdateNextNodeToSelect(Node); + + DoRemoveFromSelection(Node); + InvalidateNode(Node); + Change(Node); + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.UpdateNextNodeToSelect(Node: PVirtualNode); + +// save a potential node to select after the currently selected node will be deleted. +// This will make the VT to behave more like the Win32 TreeView, which always selecta a new node if the currently +// selected one gets deleted. + +begin + if ([toAlwaysSelectNode, toSelectNextNodeOnRemoval] * TreeOptions.SelectionOptions) = [] then + Exit; + if GetNextSibling(Node) <> nil then + FNextNodeToSelect := GetNextSibling(Node) + else if GetPreviousSibling(Node) <> nil then + FNextNodeToSelect := GetPreviousSibling(Node) + else if Node.Parent <> FRoot then + FNextNodeToSelect := Node.Parent + else + FNextNodeToSelect := nil; +end;//if Assigned(Node); + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.ResetRangeAnchor; + +// Called when there is no selected node anymore and the selection range anchor needs a new value. + +begin + FRangeAnchor := FFocusedNode; + FLastSelectionLevel := -1; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.RestoreFontChangeEvent(Canvas: TCanvas); + +begin + Canvas.Font.OnChange := FOldFontChange; + FOldFontChange := nil; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.SelectNodes(StartNode, EndNode: PVirtualNode; AddOnly: Boolean); + +// Selects a range of nodes and unselects all other eventually selected nodes which are not in this range if +// AddOnly is False. +// EndNode must be visible while StartNode does not necessarily as in the case where the last focused node is the start +// node but it is a child of a node which has been collapsed previously. In this case the first visible parent node +// is used as start node. StartNode can be nil in which case the very first node in the tree is used. + +var + NodeFrom, + NodeTo, + LastAnchor: PVirtualNode; + Index: Integer; + +begin + Assert(Assigned(EndNode), 'EndNode must not be nil!'); + if not FSelectionLocked then + begin + ClearTempCache; + if StartNode = nil then + StartNode := GetFirstVisibleNoInit(nil, True) + else + if not FullyVisible[StartNode] then + begin + StartNode := GetPreviousVisible(StartNode, True); + if StartNode = nil then + StartNode := GetFirstVisibleNoInit(nil, True); + end; + + if CompareNodePositions(StartNode, EndNode, True) < 0 then + begin + NodeFrom := StartNode; + NodeTo := EndNode; + end + else + begin + NodeFrom := EndNode; + NodeTo := StartNode; + end; + + // The range anchor will be reset by the following call. + LastAnchor := FRangeAnchor; + if not AddOnly then + InternalClearSelection; + + while NodeFrom <> NodeTo do + begin + InternalCacheNode(NodeFrom); + NodeFrom := GetNextVisible(NodeFrom, True); + end; + // select last node too + InternalCacheNode(NodeFrom); + // now add them all in "one" step + AddToSelection(FTempNodeCache, FTempNodeCount); + ClearTempCache; + if Assigned(LastAnchor) and FindNodeInSelection(LastAnchor, Index, -1, -1) then + FRangeAnchor := LastAnchor; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.SetFocusedNodeAndColumn(Node: PVirtualNode; Column: TColumnIndex); + +var + OldColumn: TColumnIndex; + WasDifferent: Boolean; + +begin + if not FHeader.AllowFocus(Column) then + Column := FFocusedColumn; + + WasDifferent := (Node <> FFocusedNode) or (Column <> FFocusedColumn); + + OldColumn := FFocusedColumn; + FFocusedColumn := Column; + + DoFocusNode(Node, True); + + // Check if the change was accepted. + if FFocusedNode = Node then + begin + CancelEditNode; + if WasDifferent then + DoFocusChange(FFocusedNode, FFocusedColumn); + end + else + // If the user did not accept the new cell to focus then set also the focused column back + // to its original state. + FFocusedColumn := OldColumn; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.SkipNode(Stream: TStream); + +// Skips the data for the next node in the given stream (including the child nodes). + +var + Header: TChunkHeader; + +begin + with Stream do + begin + // read achor chunk of the node + Stream.Read(Header, SizeOf(Header)); + if Header.ChunkType = NodeChunk then + Stream.Position := Stream.Position + Header.ChunkSize + else + RaiseVTError(SCorruptStream1, hcTFCorruptStream1); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.StartWheelPanning(Position: TPoint); + +// Called when wheel panning should start. A little helper window is created to indicate the reference position, +// which determines in which direction and how far wheel panning/scrolling will happen. + + //--------------- local function -------------------------------------------- + function CreatePanningWindow(const ImageName: TPanningCursor; const Pos: TPoint): TForm; + var + Form: TForm; + Image: TImage; + PanningImage: TIcon; + begin + Form := TForm.Create(Self); + Form.PopupMode := pmExplicit; + Form.PopupParent := GetParentForm(Self); + Form.TransparentColor := True; + Form.TransparentColorValue := clBtnFace; + Form.Width := ScaledPixels(32); + Form.Height := Form.Width; + Form.BorderStyle := bsNone; + Form.StyleElements := []; + Image := TImage.Create(Form); + Image.Left := 0; + Image.Top := 0; + Image.Parent := Form; + Image.Align := TAlign.alClient; + + PanningImage := TIcon.Create; + try + PanningImage.Handle := LoadImage(0, MAKEINTRESOURCE(ImageName), IMAGE_CURSOR, Form.Width, Form.Height, LR_DEFAULTCOLOR or LR_LOADTRANSPARENT); + Image.Picture.Assign(PanningImage); + Form.Left := Pos.X - (PanningImage.Width div 2); + Form.Top := Pos.Y - (PanningImage.Height div 2); + finally + PanningImage.Free; + end; + Form.Position := poDesigned; + // This prevents a focus chnage compare to using TForm.Show() + ShowWindow(Form.Handle, SW_SHOWNOACTIVATE); + Form.Visible := True; + Exit(Form); + end; + //--------------- end local function ---------------------------------------- + +var + ImageName: TPanningCursor; + Pt: TPoint; + +begin + StopTimer(ScrollTimer); + DoStateChange([tsPanning]); + + // Determine correct cursor + if FRangeX > ClientWidth then + begin + if FRangeY > ClientHeight then + ImageName := TPanningCursor.MOVEALL + else + ImageName := TPanningCursor.MOVEEW; + end + else + ImageName := TPanningCursor.MOVENS; + + // Create the helper window and show it at the given position without activating it. + Pt := ClientToScreen(Position); + FPanningWindow := CreatePanningWindow(ImageName, Pt); + + // Setup the panscroll timer and capture all mouse input. + TrySetFocus(); + SetCapture(Handle); + SetTimer(Handle, ScrollTimer, 20, nil); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.StopWheelPanning; + +// Stops panning if currently active and destroys the helper window. + +begin + if tsPanning in FStates then + begin + // Release the mouse capture and stop the panscroll timer. + StopTimer(ScrollTimer); + ReleaseCapture; + DoStateChange([], [tsPanning]); + + // Destroy the helper window. + if Assigned(FPanningWindow) then + FPanningWindow.Release; + DeleteObject(FPanningCursor); + FPanningCursor := 0; + Winapi.Windows.SetCursor(Screen.Cursors[Cursor]); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.StructureChange(Node: PVirtualNode; Reason: TChangeReason); + +begin + AdviseChangeEvent(True, Node, Reason); + + if FUpdateCount = 0 then + begin + if (FChangeDelay > 0) and HandleAllocated and not (tsSynchMode in FStates) then + SetTimer(Handle, StructureChangeTimer, FChangeDelay, nil) + else + DoStructureChange(Node, Reason); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.StyleServices(AControl: TControl): TCustomStyleServices; +begin + if AControl = nil then + AControl := Self; + Result := VTStyleServices(AControl); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.SuggestDropEffect(Source: TObject; Shift: TShiftState; Pt: TPoint; + AllowedEffects: Integer): Integer; + +// determines the drop action to take if the drag'n drop operation ends on this tree +// Note: Source can be any Delphi object not just a virtual tree + +begin + Result := AllowedEffects; + + // prefer MOVE if source and target are the same control, otherwise whatever is allowed as initial value + if Assigned(Source) and (Source = Self) then + if (AllowedEffects and DROPEFFECT_MOVE) <> 0 then + Result := DROPEFFECT_MOVE + else // no change + else + // drag between different applicatons + if (AllowedEffects and DROPEFFECT_COPY) <> 0 then + Result := DROPEFFECT_COPY; + + // consider modifier keys and what is allowed at the moment, if none of the following conditions apply then + // the initial value just set is used + if ssCtrl in Shift then + begin + // copy or link + if ssShift in Shift then + begin + // link + if (AllowedEffects and DROPEFFECT_LINK) <> 0 then + Result := DROPEFFECT_LINK; + end + else + begin + // copy + if (AllowedEffects and DROPEFFECT_COPY) <> 0 then + Result := DROPEFFECT_COPY; + end; + end + else + begin + // move, link or default + if ssShift in Shift then + begin + // move + if (AllowedEffects and DROPEFFECT_MOVE) <> 0 then + Result := DROPEFFECT_MOVE; + end + else + begin + // link or default + if ssAlt in Shift then + begin + // link + if (AllowedEffects and DROPEFFECT_LINK) <> 0 then + Result := DROPEFFECT_LINK; + end; + // else default + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.ToggleSelection(StartNode, EndNode: PVirtualNode); + +// Switchs the selection state of a range of nodes. +// Note: This method is specifically designed to help selecting ranges with the keyboard and considers therefore +// the range anchor. + +var + NodeFrom, + NodeTo: PVirtualNode; + NewSize: Integer; + Position: Integer; + +begin + if not FSelectionLocked then + begin + Assert(Assigned(EndNode), 'EndNode must not be nil!'); + if StartNode = nil then + StartNode := FRoot.FirstChild + else + if not FullyVisible[StartNode] then + StartNode := GetPreviousVisible(StartNode, True); + + Position := CompareNodePositions(StartNode, EndNode); + // nothing to do if start and end node are the same + if Position <> 0 then + begin + if Position < 0 then + begin + NodeFrom := StartNode; + NodeTo := EndNode; + end + else + begin + NodeFrom := EndNode; + NodeTo := StartNode; + end; + + ClearTempCache; + + // 1) toggle the start node if it is before the range anchor + if CompareNodePositions(NodeFrom, FRangeAnchor) < 0 then + if not (vsSelected in NodeFrom.States) then + InternalCacheNode(NodeFrom) + else + InternalRemoveFromSelection(NodeFrom); + + // 2) toggle all nodes within the range + NodeFrom := GetNextVisible(NodeFrom, True); + while NodeFrom <> NodeTo do + begin + if not (vsSelected in NodeFrom.States) then + InternalCacheNode(NodeFrom) + else + InternalRemoveFromSelection(NodeFrom); + NodeFrom := GetNextVisible(NodeFrom, True); + end; + + // 3) toggle end node if it is after the range anchor + if CompareNodePositions(NodeFrom, FRangeAnchor) > 0 then + if not (vsSelected in NodeFrom.States) then + InternalCacheNode(NodeFrom) + else + InternalRemoveFromSelection(NodeFrom); + + // Do some housekeeping if there was a change. + NewSize := PackArray(FSelection, FSelectionCount); + if NewSize > -1 then + begin + FSelectionCount := NewSize; + SetLength(FSelection, FSelectionCount); + end; + // If the range went over the anchor then we need to reselect it. + if not (vsSelected in FRangeAnchor.States) then + InternalCacheNode(FRangeAnchor); + if FTempNodeCount > 0 then + AddToSelection(FTempNodeCache, FTempNodeCount); + ClearTempCache; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.TrySetFocus(); +begin + if Visible and CanFocus then + begin + try + Self.SetFocus(); + except + on EInvalidOperation do + Exit; + end; + end;//if +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.UnselectNodes(StartNode, EndNode: PVirtualNode); + +// Deselects a range of nodes. +// EndNode must be visible while StartNode must not as in the case where the last focused node is the start node +// but it is a child of a node which has been collapsed previously. In this case the first visible parent node +// is used as start node. StartNode can be nil in which case the very first node in the tree is used. + +var + NodeFrom, + NodeTo: PVirtualNode; + NewSize: Integer; + +begin + if not FSelectionLocked then + begin + Assert(Assigned(EndNode), 'EndNode must not be nil!'); + + if StartNode = nil then + StartNode := FRoot.FirstChild + else + if not FullyVisible[StartNode] then + begin + StartNode := GetPreviousVisible(StartNode, True); + if StartNode = nil then + StartNode := FRoot.FirstChild; + end; + + if CompareNodePositions(StartNode, EndNode) < 0 then + begin + NodeFrom := StartNode; + NodeTo := EndNode; + end + else + begin + NodeFrom := EndNode; + NodeTo := StartNode; + end; + + while NodeFrom <> NodeTo do + begin + InternalRemoveFromSelection(NodeFrom); + NodeFrom := GetNextVisible(NodeFrom, True); + end; + // Deselect last node too. + InternalRemoveFromSelection(NodeFrom); + + // Do some housekeeping. + NewSize := PackArray(FSelection, FSelectionCount); + if NewSize > -1 then + begin + FSelectionCount := NewSize; + SetLength(FSelection, FSelectionCount); + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.UpdateColumnCheckState(Col: TVirtualTreeColumn); +var + NewCheckState: TCheckState; +begin + NewCheckState := DetermineNextCheckState(Col.CheckType, Col.CheckState); + if (Col.CheckState <> NewCheckState) and DoColumnChecking(Col.Index, NewCheckState) then + begin + Col.CheckState := NewCheckState; + DoColumnChecked(Col.Index); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.UpdateDesigner; + +var + ParentForm: TCustomForm; + +begin + if (csDesigning in ComponentState) and not (csUpdating in ComponentState) then + begin + ParentForm := GetParentForm(Self); + if Assigned(ParentForm) and Assigned(ParentForm.Designer) then + ParentForm.Designer.Modified; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.UpdateHeaderRect(); + +// Calculates the rectangle the header occupies in non-client area. +// These coordinates are in window rectangle. + +var + OffsetX, + OffsetY: TDimension; + EdgeSize: TDimension; + Size: TSize; + +begin + FHeaderRect := Rect(0, 0, Width, Height); + + // Consider borders... + if HandleAllocated then begin // Prevent preliminary creation of window handle, see issue #933 + Size := GetBorderDimensions(); + InflateRect(FHeaderRect, Size.cx, Size.cy); + end; + + // ... and bevels. + OffsetX := BorderWidth; + OffsetY := BorderWidth; + if BevelKind <> TBevelKind.bkNone then + begin + EdgeSize := 0; + if BevelInner <> TBevelCut.bvNone then + Inc(EdgeSize, BevelWidth); + if BevelOuter <> TBevelCut.bvNone then + Inc(EdgeSize, BevelWidth); + if TBevelEdge.beLeft in BevelEdges then + Inc(OffsetX, EdgeSize); + if TBevelEdge.beTop in BevelEdges then + Inc(OffsetY, EdgeSize); + end; + + InflateRect(FHeaderRect, -OffsetX, -OffsetY); + + if hoVisible in FHeader.Options then + begin + if FHeaderRect.Left <= FHeaderRect.Right then + FHeaderRect.Bottom := FHeaderRect.Top + FHeader.Height + else + FHeaderRect := Rect(0, 0, 0, 0); + end + else + FHeaderRect.Bottom := FHeaderRect.Top; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.UpdateEditBounds; + +// Used to update the bounds of the current node editor if editing is currently active. + +var + R: TRect; + CurrentAlignment: TAlignment; + CurrentBidiMode: TBidiMode; + offsets : TVTOffsets; + offset : TDimension; + +begin + if (tsEditing in FStates) and Assigned(FFocusedNode) and + (FEditColumn < FHeader.Columns.Count) then // prevent EArgumentOutOfRangeException + begin + if (GetCurrentThreadId <> MainThreadID) then + begin + // UpdateEditBounds() will be called at the end of the thread + Exit; + end; + if vsMultiline in FFocusedNode.States then + R := GetDisplayRect(FFocusedNode, FEditColumn, True, False) + else if not (toGridExtensions in FOptions.MiscOptions) then + R := GetDisplayRect(FFocusedNode, FEditColumn, True, True); + + if (toGridExtensions in FOptions.MiscOptions) then + begin + // Use the whole cell when grid extensions are on. + R := GetDisplayRect(FFocusedNode, FEditColumn, False, False); + if FEditColumn = FHeader.MainColumn then + begin + // Calculate an offset for the main column. + GetOffsets(FFocusedNode, offsets, ofsLabel, FEditColumn); + offset := offsets[ofsLabel]; +// if offsets[ofsToggleButton] < 0 then +// Inc(offset, offsets[ofsToggleButton]); + end + else + offset := 0; + + // Adjust edit bounds depending on alignment and bidi mode. + if FEditColumn <= NoColumn then + begin + CurrentAlignment := Alignment; + CurrentBidiMode := BiDiMode; + end + else + begin + CurrentAlignment := FHeader.Columns[FEditColumn].Alignment; + CurrentBidiMode := FHeader.Columns[FEditColumn].BiDiMode; + end; + // Consider bidi mode here. In RTL context does left alignment actually mean right alignment and vice versa. + if CurrentBidiMode <> bdLeftToRight then + ChangeBiDiModeAlignment(CurrentAlignment); + if CurrentAlignment = taLeftJustify then + begin + if CurrentBiDiMode = bdLeftToRight then + Inc(R.Left, offset) + else + Dec(R.Right, offset); + end + else + begin + if CurrentBiDiMode = bdLeftToRight then + Inc(R.Left, offset) + else + Dec(R.Right, offset); + end; + end; + if toShowHorzGridLines in TreeOptions.PaintOptions then + Dec(R.Bottom); + R.Bottom := R.Top + R.Bottom - R.Top; + FEditLink.SetBounds(R); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +const + ScrollMasks: array[Boolean] of Cardinal = (0, SIF_DISABLENOSCROLL); + +const // Region identifiers for GetRandomRgn + CLIPRGN = 1; + METARGN = 2; + APIRGN = 3; + SYSRGN = 4; + +function GetRandomRgn(DC: HDC; Rgn: HRGN; iNum: Integer): Integer; stdcall; external 'GDI32.DLL'; + +procedure TBaseVirtualTree.ValidateCache(); + +// Starts cache validation if not already done by adding this instance to the worker thread's waiter list +// (if not already there) and signalling the thread it can start validating. + +begin + // stop validation if it is currently validating this tree's cache. + InterruptValidation(); + + FStartIndex := 0; + if (tsValidationNeeded in FStates) and (FVisibleCount > CacheThreshold) then + begin + // Tell the thread this tree needs actually something to do. + TWorkerThread.AddTree(Self); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.ValidateNodeDataSize(var Size: Integer); + +begin + Size := SizeOf(Pointer); + if Assigned(FOnGetNodeDataSize) then + FOnGetNodeDataSize(Self, Size); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.VclStyleChanged(); + + // Updates the member FVclStyleEnabled, should be called initially and when the VCL style changes + +begin + FVclStyleEnabled := StyleServices.Enabled and not StyleServices.IsSystemStyle {$IF CompilerVersion < 35} and not (csDesigning in ComponentState) {$ifend}; + Header.StyleChanged(); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +//PROFILE-NO +procedure TBaseVirtualTree.WndProc(var Message: TMessage); + +var + Handled: Boolean; + +begin + Handled := False; + + // Try the header whether it needs to take this message. + if Assigned(FHeader) and (FHeader.States <> []) then + Handled := TVTHeaderCracker(FHeader).HandleMessage(Message); + if not Handled then + begin + // For auto drag mode, let tree handle itself, instead of TControl. + if not (csDesigning in ComponentState) and + ((Message.Msg = WM_LBUTTONDOWN) or (Message.Msg = WM_LBUTTONDBLCLK)) then + begin + if (DragMode = dmAutomatic) and (DragKind = dkDrag) then + begin + if IsControlMouseMsg(TWMMouse(Message)) then + Handled := True; + if not Handled then + begin + ControlState := ControlState + [csLButtonDown]; + Dispatch(Message); // overrides TControl's BeginDrag + Handled := True; + end; + end; + end; + + if not Handled and Assigned(FHeader) then + Handled := TVTHeaderCracker(FHeader).HandleMessage(Message); + + if not Handled then + begin + if (Message.Msg in [WM_NCLBUTTONDOWN, WM_NCRBUTTONDOWN, WM_NCMBUTTONDOWN]) and not Focused then + TrySetFocus; + inherited; + end; + end; +end; +//PROFILE-YES + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.WriteChunks(Stream: TStream; Node: PVirtualNode); + +// Writes the core chunks for Node into the stream. +// Note: descendants can optionally override this method to add other node specific chunks. +// Keep in mind that this method is also called for the root node. Using this fact in descendants you can +// create a kind of "global" chunks not directly bound to a specific node. + +var + Header: TChunkHeader; + LastPosition, + ChunkSize: Integer; + Chunk: TBaseChunk; + Run: PVirtualNode; + +begin + with Stream do + begin + // 1. The base chunk... + LastPosition := Position; + Chunk.Header.ChunkType := BaseChunk; + with Node^, Chunk do + begin + Body.ChildCount := ChildCount; + Body.NodeHeight := NodeHeight; + // Some states are only temporary so take them out as they make no sense at the new location. + Body.States := States - [vsChecking, vsCutOrCopy, vsDeleting, vsOnFreeNodeCallRequired, vsHeightMeasured]; + Body.Align := Align; + Body.CheckState := GetCheckState(Node); + Body.CheckType := CheckType; + Body.Reserved := 0; + end; + // write the base chunk + Write(Chunk, SizeOf(Chunk)); + + // 2. ... directly followed by the child node chunks (actually they are child chunks of + // the base chunk) + if vsInitialized in Node.States then + begin + Run := Node.FirstChild; + while Assigned(Run) do + begin + WriteNode(Stream, Run); + Run := Run.NextSibling; + end; + end; + + FinishChunkHeader(Stream, LastPosition, Position); + + // 3. write user data + LastPosition := Position; + Header.ChunkType := UserChunk; + Write(Header, SizeOf(Header)); + DoSaveUserData(Node, Stream); + // check if the application actually wrote data + ChunkSize := Position - LastPosition - SizeOf(TChunkHeader); + // seek back to start of chunk if nothing has been written + if ChunkSize = 0 then + begin + Position := LastPosition; + Size := Size - SizeOf(Header); + end + else + FinishChunkHeader(Stream, LastPosition, Position); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.WriteNode(Stream: TStream; Node: PVirtualNode); + +// Writes the "cover" chunk for Node to Stream and initiates writing child nodes and chunks. + +var + LastPosition: Integer; + Header: TChunkHeader; + +begin + // Initialize the node first if necessary and wanted. + if toInitOnSave in FOptions.MiscOptions then + begin + if not (vsInitialized in Node.States) then + InitNode(Node); + if (vsHasChildren in Node.States) and (Node.ChildCount = 0) then + InitChildren(Node); + end; + + with Stream do + begin + LastPosition := Position; + // Emit the anchor chunk. + Header.ChunkType := NodeChunk; + Write(Header, SizeOf(Header)); + // Write other chunks to stream taking their size into this chunk's size. + WriteChunks(Stream, Node); + + // Update chunk size. + FinishChunkHeader(Stream, LastPosition, Position); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.AbsoluteIndex(Node: PVirtualNode): Cardinal; + +begin + Result := 0; + while Assigned(Node) and (Node <> FRoot) do + begin + if not (vsInitialized in Node.States) then + InitNode(Node); + if Assigned(Node.PrevSibling) then + begin + // if there's a previous sibling then add its total count to the result + Node := Node.PrevSibling; + System.Inc(Result, Node.TotalCount); + end + else + begin + Node := Node.Parent; + if Node <> FRoot then + System.Inc(Result); + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.AddChild(Parent: PVirtualNode; UserData: Pointer = nil): PVirtualNode; + +// Adds a new node to the given parent node. This is simply done by increasing the child count of the +// parent node. If Parent is nil then the new node is added as (last) top level node. +// UserData can be used to set the first SizeOf(Pointer) bytes of the user data area to an initial value which can be used +// in OnInitNode and will also cause to trigger the OnFreeNode event (if <> nil) even if the node is not yet +// "officially" initialized. +// AddChild is a compatibility method and will implicitly validate the parent node. This is however +// against the virtual paradigm and hence I dissuade from its usage. + +begin + if not (toReadOnly in FOptions.MiscOptions) then + Result := InsertNode(Parent, TVTNodeAttachMode.amAddChildLast, UserData) + else + Result := nil; +end; + +function TBaseVirtualTree.AddChild(Parent: PVirtualNode; const UserData: IInterface): PVirtualNode; +begin + UserData._AddRef(); + Result := AddChild(Parent, Pointer(UserData)); + Include(Result.States, vsReleaseCallOnUserDataRequired); +end; + +function TBaseVirtualTree.AddChild(Parent: PVirtualNode; const UserData: TObject): PVirtualNode; +begin + Result := AddChild(Parent, Pointer(UserData)); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.AddFromStream(Stream: TStream; TargetNode: PVirtualNode); + +// loads nodes from the given stream and adds them to TargetNode +// the current content is not cleared before the load process starts (see also LoadFromStream) + +var + ThisID: TMagicID; + Version, + Count: Cardinal; + Node: PVirtualNode; + +begin + if not (toReadOnly in FOptions.MiscOptions) then + begin + // check first whether this is a stream we can read + Stream.ReadBuffer(ThisID, SizeOf(TMagicID)); + if (ThisID[0] = MagicID[0]) and + (ThisID[1] = MagicID[1]) and + (ThisID[2] = MagicID[2]) and + (ThisID[5] = MagicID[5]) then + begin + Version := Word(ThisID[3]); + if Version <= VTTreeStreamVersion then + begin + BeginUpdate; + try + if Version < 2 then + Count := MaxInt + else + Stream.ReadBuffer(Count, SizeOf(Count)); + + while (Stream.Position < Stream.Size) and (Count > 0) do + begin + System.Dec(Count); + Node := MakeNewNode; + InternalConnectNode(Node, TargetNode, Self, amAddChildLast); + InternalAddFromStream(Stream, Version, Node); + end; + if TargetNode = FRoot then + DoNodeCopied(nil) + else + DoNodeCopied(TargetNode); + finally + EndUpdate; + end; + end + else + RaiseVTError(SWrongStreamVersion, hcTFWrongStreamVersion); + end + else + RaiseVTError(SWrongStreamVersion, hcTFWrongStreamVersion); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.AfterConstruction; + +begin + inherited; + + if FRoot = nil then + InitRootNode; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.Assign(Source: TPersistent); + +begin + if (Source is TBaseVirtualTree) and not (toReadOnly in FOptions.MiscOptions) then + with Source as TBaseVirtualTree do + begin + Self.Align := Align; + Self.Anchors := Anchors; + Self.AutoScrollDelay := AutoScrollDelay; + Self.AutoScrollInterval := AutoScrollInterval; + Self.AutoSize := AutoSize; + Self.Background := Background; + Self.BevelEdges := BevelEdges; + Self.BevelInner := BevelInner; + Self.BevelKind := BevelKind; + Self.BevelOuter := BevelOuter; + Self.BevelWidth := BevelWidth; + Self.BiDiMode := BiDiMode; + Self.BorderStyle := BorderStyle; + Self.BorderWidth := BorderWidth; + Self.ChangeDelay := ChangeDelay; + Self.CheckImageKind := CheckImageKind; + Self.Color := Color; + Self.Colors.Assign(Colors); + Self.Constraints.Assign(Constraints); + Self.Ctl3D := Ctl3D; + Self.DefaultNodeHeight := DefaultNodeHeight; + Self.DefaultPasteMode := DefaultPasteMode; + Self.DragCursor := DragCursor; + Self.DragImageKind := DragImageKind; + Self.DragKind := DragKind; + Self.DragMode := DragMode; + Self.Enabled := Enabled; + Self.Font := Font; + Self.Header := Header; + Self.HintMode := HintMode; + Self.HotCursor := HotCursor; + Self.Images := Images; + Self.ImeMode := ImeMode; + Self.ImeName := ImeName; + Self.Indent := Indent; + Self.Margin := Margin; + Self.NodeAlignment := NodeAlignment; + Self.NodeDataSize := NodeDataSize; + Self.TreeOptions := TreeOptions; + Self.ParentBiDiMode := ParentBiDiMode; + Self.ParentColor := ParentColor; + Self.ParentCtl3D := ParentCtl3D; + Self.ParentFont := ParentFont; + Self.ParentShowHint := ParentShowHint; + Self.PopupMenu := PopupMenu; + Self.RootNodeCount := RootNodeCount; + Self.ScrollBarOptions := ScrollBarOptions; + Self.ShowHint := ShowHint; + Self.StateImages := StateImages; + Self.StyleElements := StyleElements; + Self.TabOrder := TabOrder; + Self.TabStop := TabStop; + Self.Visible := Visible; + Self.SelectionCurveRadius := SelectionCurveRadius; + Self.SelectionBlendFactor := SelectionBlendFactor; + Self.EmptyListMessage := EmptyListMessage; + end + else + inherited; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.AutoScale(); + +// If toAutoChangeScale is set, this method ensures that the default node height is set correctly. + +var + lTextHeight: TDimension; +begin + if HandleAllocated and (toAutoChangeScale in TreeOptions.AutoOptions) then + begin + Canvas.Font.Assign(Self.Font); + lTextHeight := Canvas.TextHeight('Tg') + TextMargin; + if Assigned(Images) then + lTextHeight := Max(lTextHeight, Images.Height + IfThen(fImagesMargin > 1, fImagesMargin div 2, fImagesMargin)); // ImagesMargin is the distance between two Images / checboxes. Don't count it twice vertically => div 2 + // By default, we only ensure that DefaultNodeHeight is large enough. + // If the form's dpi has changed, we scale up and down the DefaultNodeHeight, See issue #677. + if (lTextHeight <> Self.DefaultNodeHeight) then begin + ScaleNodeHeights(lTextHeight, DefaultNodeHeight); + Self.DefaultNodeHeight := lTextHeight; + end;// if + end;// if HandelAllocated +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.BeginDrag(Immediate: Boolean; Threshold: Integer); + +// Reintroduced method to allow to start OLE drag'n drop as well as VCL drag'n drop. + +begin + if FDragType = dtVCL then + begin + DoStateChange([tsVCLDragPending]); + inherited; + end + else + if (FStates * [tsOLEDragPending, tsOLEDragging]) = [] then + begin + // Drag start position has already been recorded in WMMouseDown. + if Threshold < 0 then + FDragThreshold := Mouse.DragThreshold + else + FDragThreshold := Threshold; + if Immediate then + DoDragging(FLastClickPos) + else + DoStateChange([tsOLEDragPending]); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.BeginSynch; + +// Starts the synchronous update mode (if not already active). + +begin + if not (csDestroying in ComponentState) then + begin + if FSynchUpdateCount = 0 then + begin + DoUpdating(usBeginSynch); + + // Stop all timers... + StopTimer(ChangeTimer); + StopTimer(StructureChangeTimer); + StopTimer(ExpandTimer); + StopTimer(EditTimer); + StopTimer(HeaderTimer); + StopTimer(ScrollTimer); + StopTimer(SearchTimer); + FSearchBuffer := ''; + FLastSearchNode := nil; + DoStateChange([], [tsEditPending, tsScrollPending, tsScrolling, tsIncrementalSearching]); + + // ...and trigger pending update states. + if tsStructureChangePending in FStates then + DoStructureChange(FLastStructureChangeNode, FLastStructureChangeReason); + if tsChangePending in FStates then + DoChange(FLastChangedNode); + end + else + DoUpdating(usSynch); + end; + System.Inc(FSynchUpdateCount); + DoStateChange([tsSynchMode]); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.BeginUpdate; + +begin + Assert(GetCurrentThreadId = MainThreadId, 'UI controls like ' + Classname + ' should only be manipulated through the main thread.'); + if not (csDestroying in ComponentState) then + begin + if FUpdateCount = 0 then + begin + DoUpdating(usBegin); + SetUpdateState(True); + end + else + DoUpdating(usUpdate); + end; + System.Inc(FUpdateCount); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.CancelCutOrCopy; + +// Resets nodes which are marked as being cut. + +var + Run: PVirtualNode; + +begin + if ([tsCutPending, tsCopyPending] * FStates) <> [] then + begin + Run := FRoot.FirstChild; + while Assigned(Run) do + begin + if vsCutOrCopy in Run.States then + Exclude(Run.States, vsCutOrCopy); + Run := GetNextNoInit(Run); + end; + end; + DoStateChange([], [tsCutPending, tsCopyPending]); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.CancelEditNode: Boolean; + +// Called by the application or the current edit link to cancel the edit action. + +begin + if HandleAllocated and ([tsEditing, tsEditPending] * FStates <> []) then + Result := DoCancelEdit + else + Result := True; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.CancelOperation; + +// Called by the application to cancel a long-running operation. + +begin + if FOperationCount > 0 then + FOperationCanceled := True; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.CanEdit(Node: PVirtualNode; Column: TColumnIndex): Boolean; + +// Returns True if the given node can be edited. + +begin + Result := (toEditable in FOptions.MiscOptions) and Enabled and not (toReadOnly in FOptions.MiscOptions) + and ((Column < 0) or (coEditable in FHeader.Columns[Column].Options)); + DoCanEdit(Node, Column, Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.CanFocus: Boolean; + +var + Form: TCustomForm; + +begin + Result := inherited CanFocus; + + if Result and not (csDesigning in ComponentState) then + begin + Form := GetParentForm(Self); + Result := (Form = nil) or (Form.Enabled and Form.Visible); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.Clear; + +begin + if (not IsEmpty and not (toReadOnly in FOptions.MiscOptions)) or (csDestroying in ComponentState) then + begin + BeginUpdate; + try + InterruptValidation; + if IsEditing then + CancelEditNode; + + if ClipboardStates * FStates <> [] then + begin + OleSetClipboard(nil); + DoStateChange([], ClipboardStates); + end; + ClearSelection; + FFocusedNode := nil; + FLastSelected := nil; + FCurrentHotNode := nil; + FDropTargetNode := nil; + FLastChangedNode := nil; + FRangeAnchor := nil; + FLastVCLDragTarget := nil; + FLastSearchNode := nil; + DeleteChildren(FRoot, True); + FOffsetX := 0; + FOffsetY := 0; + + finally + EndUpdate; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.ClearChecked; + +var + Node: PVirtualNode; + +begin + Node := RootNode.FirstChild; + while Assigned(Node) do + begin + if Node.CheckState <> csUncheckedNormal then + CheckState[Node] := csUncheckedNormal; + Node := GetNextNoInit(Node); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.ClearSelection(); +begin + ClearSelection(True); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.ClearDragManager; +begin + Pointer(FDragManager) := nil; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.ClearSelection(pFireChangeEvent: Boolean); + +var + Node: PVirtualNode; + Dummy: TDimension; + R: TRect; + Counter: Integer; + +begin + Assert(GetCurrentThreadId = MainThreadId, Self.Classname + '.ClearSelection() must only be called from UI thread.'); + if not FSelectionLocked and (FSelectionCount > 0) and not (csDestroying in ComponentState) then + begin + if (FUpdateCount = 0) and HandleAllocated and (FVisibleCount > 0) then + begin + // Iterate through nodes currently visible in the client area and invalidate them. + Node := GetNodeAt(0, 0, True, Dummy); + if Assigned(Node) then + R := GetDisplayRect(Node, NoColumn, False); + Counter := FSelectionCount; + + while Assigned(Node) do + begin + R.Bottom := R.Top + NodeHeight[Node]; + if vsSelected in Node.States then + begin + InvalidateRect(@R, False); + System.Dec(Counter); + // Only try as many nodes as are selected. + if Counter = 0 then + Break; + end; + R.Top := R.Bottom; + if R.Top > ClientHeight then + Break; + Node := GetNextVisibleNoInit(Node, True); + end; + end; + + InternalClearSelection; + if pFireChangeEvent then + Change(nil); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.CopyTo(Source: PVirtualNode; Tree: TBaseVirtualTree; Mode: TVTNodeAttachMode; + ChildrenOnly: Boolean): PVirtualNode; + +// A simplified CopyTo method to allow to copy nodes to the root of another tree. + +begin + Result := CopyTo(Source, Tree.FRoot, Mode, ChildrenOnly); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.CopyTo(Source, Target: PVirtualNode; Mode: TVTNodeAttachMode; + ChildrenOnly: Boolean): PVirtualNode; + +// Copies Source and all its child nodes to Target. +// Mode is used to specify further where to add the new node actually (as sibling of Target or as child of Target). +// Result is the newly created node to which source has been copied if ChildrenOnly is False or just contains Target +// in the other case. +// ChildrenOnly determines whether to copy also the source node or only its child nodes. + +var + TargetTree: TBaseVirtualTree; + Stream: TMemoryStream; + +begin + Assert(TreeFromNode(Source) = Self, 'The source tree must contain the source node.'); + + Result := nil; + if (Mode <> amNoWhere) and Assigned(Source) and (Source <> FRoot) then + begin + // Assume that an empty destination means the root in this (the source) tree. + if Target = nil then + begin + TargetTree := Self; + Target := FRoot; + Mode := amAddChildFirst; + end + else + TargetTree := TreeFromNode(Target); + + if not (toReadOnly in TargetTree.TreeOptions.MiscOptions) then + begin + if Target = TargetTree.FRoot then + begin + case Mode of + amInsertBefore: + Mode := amAddChildFirst; + amInsertAfter: + Mode := amAddChildLast; + end; + end; + + Stream := TMemoryStream.Create; + try + // Write all nodes into a temprary stream depending on the ChildrenOnly flag. + if not ChildrenOnly then + WriteNode(Stream, Source) + else + begin + Source := Source.FirstChild; + while Assigned(Source) do + begin + WriteNode(Stream, Source); + Source := Source.NextSibling; + end; + end; + // Now load the serialized nodes into the target node (tree). + TargetTree.BeginUpdate; + try + Stream.Position := 0; + while Stream.Position < Stream.Size do + begin + Result := TargetTree.MakeNewNode; + InternalConnectNode(Result, Target, TargetTree, Mode); + TargetTree.InternalAddFromStream(Stream, VTTreeStreamVersion, Result); + if not DoNodeCopying(Result, Target) then + begin + TargetTree.DeleteNode(Result); + Result := nil; + end + else + DoNodeCopied(Result); + end; + if ChildrenOnly then + Result := Target; + finally + TargetTree.EndUpdate; + end; + finally + Stream.Free; + end; + + with TargetTree do + begin + InvalidateCache; + if FUpdateCount = 0 then + begin + ValidateCache; + UpdateScrollBars(True); + Invalidate; + end; + StructureChange(Source, crNodeCopied); + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DeleteChildren(Node: PVirtualNode; ResetHasChildren: Boolean = False); + +// Removes all children and their children from memory without changing the vsHasChildren style by default. + +var + Run, + Mark: PVirtualNode; + LastTop, + LastLeft: TDimension; + NewSize: Integer; + ParentVisible: Boolean; + +begin + if Assigned(Node) and (Node.ChildCount > 0) and not (toReadOnly in FOptions.MiscOptions) then + begin + Assert(not (tsIterating in FStates), 'Deleting nodes during tree iteration leads to invalid pointers.'); + + // The code below uses some flags for speed improvements which may cause invalid pointers if updates of + // the tree happen. Hence switch updates off until we have finished the operation. + System.Inc(FUpdateCount); + try + InterruptValidation; + LastLeft := -FEffectiveOffsetX; + LastTop := FOffsetY; + + // Make a local copy of the visibility state of this node to speed up + // adjusting the visible nodes count. + ParentVisible := Node = FRoot; + if not ParentVisible then + ParentVisible := FullyVisible[Node] and (vsExpanded in Node.States); + + // Show that we are clearing the child list, to avoid registering structure change events. + Run := Node.LastChild; + while Assigned(Run) do + begin + if ParentVisible and IsEffectivelyVisible[Run] then + System.Dec(FVisibleCount); + + Include(Run.States, vsDeleting); + Mark := Run; + Run := Run.PrevSibling; + // Important, to avoid exchange of invalid pointers while disconnecting the node. + if Assigned(Run) then + Run.SetNextSibling(nil); + DeleteNode(Mark, False, True); + end; + if ResetHasChildren then + Exclude(Node.States, vsHasChildren); + if Node <> FRoot then + Exclude(Node.States, vsExpanded); + Node.SetChildCount(0); + if (Node = FRoot) or (vsDeleting in Node.States) then + begin + Node.TotalHeight := FDefaultNodeHeight + NodeHeight[Node]; + Node.TotalCount := 1; + end + else + begin + AdjustTotalHeight(Node, NodeHeight[Node]); + AdjustTotalCount(Node, 1); + end; + Node.SetFirstChild(nil); + Node.SetLastChild(nil); + finally + System.Dec(FUpdateCount); + end; + + InvalidateCache; + if FUpdateCount = 0 then + begin + NewSize := PackArray(FSelection, FSelectionCount); + if NewSize > -1 then + begin + FSelectionCount := NewSize; + SetLength(FSelection, FSelectionCount); + end; + + ValidateCache; + UpdateScrollBars(True); + // Invalidate entire tree if it scrolled e.g. to make the last node also the + // bottom node in the treeview. + if (LastLeft <> FOffsetX) or (LastTop <> FOffsetY) then + Invalidate + else + InvalidateToBottom(Node); + if tsChangePending in FStates then begin + DoChange(FLastChangedNode); + EnsureNodeSelected(True); + end; + end; + StructureChange(Node, crChildDeleted); + end + else if ResetHasChildren then + Exclude(Node.States, vsHasChildren); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DeleteNode(Node: PVirtualNode; Reindex: Boolean; ParentClearing: Boolean); + +var + LastTop, + LastLeft: TDimension; + LastParent: PVirtualNode; + WasInSynchMode: Boolean; + +begin + if Assigned(Node) and (Node <> FRoot) and not (toReadOnly in FOptions.MiscOptions) then + begin + Assert(not (tsIterating in FStates), 'Deleting nodes during tree iteration leads to invalid pointers.'); + + // Determine parent node for structure change notification. + LastParent := Node.Parent; + + if not ParentClearing then + begin + if LastParent = FRoot then + StructureChange(nil, crChildDeleted) + else + StructureChange(LastParent, crChildDeleted); + if Node = FNextNodeToSelect then + FNextNodeToSelect := nil; + end; + + LastLeft := -FEffectiveOffsetX; + LastTop := FOffsetY; + + if tsHint in FStates then + begin + Application.CancelHint; + DoStateChange([], [tsHint]); + end; + + if not ParentClearing then + InterruptValidation; + + DeleteChildren(Node); + + if vsSelected in Node.States then + begin + if FUpdateCount = 0 then + begin + // Go temporarily into sync mode to avoid a delayed change event for the node + // when unselecting. + WasInSynchMode := tsSynchMode in FStates; + Include(FStates, tsSynchMode); + RemoveFromSelection(Node); + //EnsureNodeSelected(); // also done in DoFreeNode() + if not WasInSynchMode then + Exclude(FStates, tsSynchMode); + InvalidateToBottom(LastParent); + end + else + InternalRemoveFromSelection(Node); + end + else + InvalidateToBottom(LastParent); + + InternalDisconnectNode(Node, False, Reindex); + DoFreeNode(Node); + + if not ParentClearing then + begin + if FUpdateCount = 0 then + DetermineHiddenChildrenFlag(LastParent) + else + Include(FStates, tsUpdateHiddenChildrenNeeded); + InvalidateCache; + if FUpdateCount = 0 then + begin + ValidateCache; + UpdateScrollBars(True); + // Invalidate entire tree if it scrolled e.g. to make the last node also the + // bottom node in the treeview. + if (LastLeft <> FOffsetX) or (LastTop <> FOffsetY) then + Invalidate; + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DeleteNode(Node: PVirtualNode; pReIndex: Boolean = True); +begin + DeleteNode(Node, pReIndex, False); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DeleteNodes(const pNodes: TNodeArray); + + // Deletes all given nodes. + // Best performance is achieved if nodes are sorted by parent + +var + I: Integer; + LevelChange: Boolean; +begin + if Length(pNodes) = 0 then + exit; // Prevent range error below when empty array is passen. See issue #1288 + BeginUpdate; + try + for I := High(pNodes) downto 1 do + begin + LevelChange := pNodes[I].Parent <> pNodes[I - 1].Parent; + DeleteNode(pNodes[I], LevelChange, False); + end; + DeleteNode(pNodes[0]); + finally + EndUpdate; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DeleteSelectedNodes; + +// Deletes all currently selected nodes (including their child nodes). + +var + lNodes: TNodeArray; +begin + lNodes := nil; + if (FSelectionCount > 0) and not (toReadOnly in FOptions.MiscOptions) then + begin + lNodes := GetSortedSelection(True); + DeleteNodes(lNodes); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.Dragging: Boolean; + +begin + // Check for both OLE drag'n drop as well as VCL drag'n drop. + Result := ([tsOLEDragPending, tsOLEDragging] * FStates <> []) or inherited Dragging; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.EditNode(Node: PVirtualNode; Column: TColumnIndex): Boolean; + +// Application triggered edit event for the given node. +// Returns True if the tree started editing otherwise False. + +begin + Assert(Assigned(Node), 'Node must not be nil.'); + Assert((Column > InvalidColumn) and (Column < FHeader.Columns.Count), + 'Column must be a valid column index (-1 if no header is shown).'); + + Result := tsEditing in FStates; + // If the tree is already editing then we don't disrupt this. + if not Result and not (toReadOnly in FOptions.MiscOptions) then + begin + FocusedNode := Node; + if Assigned(FFocusedNode) and (Node = FFocusedNode) and CanEdit(FFocusedNode, Column) then + begin + FEditColumn := Column; + if not (vsInitialized in Node.States) then + InitNode(Node); + DoEdit; + Result := tsEditing in FStates; + end + else + Result := False; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.EndEditNode: Boolean; + +// Called to finish a current edit action or stop the edit timer if an edit operation is pending. +// Returns True if editing was successfully ended or the control was not in edit mode +// Returns False if the control could not leave the edit mode e.g. due to an invalid value that was entered. + +begin + if [tsEditing, tsEditPending] * FStates <> [] then + Result := DoEndEdit + else + Result := True; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.EndSynch; + +begin + if FSynchUpdateCount > 0 then + System.Dec(FSynchUpdateCount); + + if not (csDestroying in ComponentState) then + begin + if FSynchUpdateCount = 0 then + begin + DoStateChange([], [tsSynchMode]); + DoUpdating(usEndSynch); + end + else + DoUpdating(usSynch); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.EndUpdate; + +var + NewSize: Integer; + +begin + if FUpdateCount = 0 then + exit; + System.Dec(FUpdateCount); + + if not (csDestroying in ComponentState) then + begin + if (FUpdateCount = 0) then + begin + if tsUpdateHiddenChildrenNeeded in FStates then + begin + DetermineHiddenChildrenFlagAllNodes; + Exclude(FStates, tsUpdateHiddenChildrenNeeded); + end; + + NewSize := PackArray(FSelection, FSelectionCount); + if NewSize > -1 then + begin + FSelectionCount := NewSize; + SetLength(FSelection, FSelectionCount); + end; + + InvalidateCache; + ValidateCache; + if HandleAllocated then + UpdateScrollBars(False); + + if tsStructureChangePending in FStates then + DoStructureChange(FLastStructureChangeNode, FLastStructureChangeReason); + try + if tsChangePending in FStates then + DoChange(FLastChangedNode); + finally + if (toAutoSort in FOptions.AutoOptions) then + SortTree(FHeader.SortColumn, FHeader.SortDirection, True); + + SetUpdateState(False); + if HandleAllocated then + Invalidate; + UpdateDesigner; + end; + NotifyAccessibleEvent(); // See issue #1174 + + DoUpdating(usEnd); + EnsureNodeSelected(False); + end + else + DoUpdating(usUpdate); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.ExecuteAction(Action: TBasicAction): Boolean; + +// Some support for standard actions. + +begin + Result := inherited ExecuteAction(Action); + + if not Result then + begin + Result := Action is TEditSelectAll; + if Result then + SelectAll(False) + else + begin + Result := Action is TEditCopy; + if Result then + CopyToClipboard + else + if not (toReadOnly in FOptions.MiscOptions) then + begin + Result := Action is TEditCut; + if Result then + CutToClipboard + else + begin + Result := Action is TEditPaste; + if Result then + PasteFromClipboard + else + begin + Result := Action is TEditDelete; + if Result then + DeleteSelectedNodes; + end; + end; + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.FinishCutOrCopy; + +// Deletes nodes which are marked as being cutted. + +var + Run: PVirtualNode; + +begin + if tsCutPending in FStates then + begin + Run := FRoot.FirstChild; + while Assigned(Run) do + begin + if vsCutOrCopy in Run.States then + DeleteNode(Run); + Run := GetNextNoInit(Run); + end; + DoStateChange([], [tsCutPending]); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.FlushClipboard; + +// Used to render the data which is currently on the clipboard (finishes delayed rendering). + +begin + if ClipboardStates * FStates <> [] then + begin + DoStateChange([tsClipboardFlushing]); + OleFlushClipboard; + CancelCutOrCopy; + DoStateChange([], [tsClipboardFlushing]); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.FullCollapse(Node: PVirtualNode = nil); + +// This routine collapses all expanded nodes in the subtree given by Node or the whole tree if Node is FRoot or nil. +// Only nodes which are expanded will be collapsed. This excludes uninitialized nodes but nodes marked as visible +// will still be collapsed if they are expanded. + +var + Stop: PVirtualNode; + +begin + if FRoot.TotalCount > 1 then + begin + if Node = FRoot then + Node := nil; + + DoStateChange([tsCollapsing]); + BeginUpdate; + try + Stop := Node; + Node := GetLastVisibleNoInit(Node, True); + + if Assigned(Node) then + begin + repeat + if [vsHasChildren, vsExpanded] * Node.States = [vsHasChildren, vsExpanded] then + ToggleNode(Node); + Node := GetPreviousNoInit(Node, True); + until (Node = Stop) or not Assigned(Node); + + // Collapse the start node too. + if Assigned(Stop) and ([vsHasChildren, vsExpanded] * Stop.States = [vsHasChildren, vsExpanded]) then + ToggleNode(Stop); + end; + finally + EndUpdate; + DoStateChange([], [tsCollapsing]); + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.FullExpand(Node: PVirtualNode = nil); + +// This routine expands all collapsed nodes in the subtree given by Node or the whole tree if Node is FRoot or nil. +// All nodes on the way down are initialized so this procedure might take a long time. +// Since all nodes are validated, the tree cannot make use of optimatizations. Hence it is counter productive and you +// should consider avoiding its use. + +var + Stop: PVirtualNode; + +begin + if FRoot.TotalCount > 1 then + begin + DoStateChange([tsExpanding]); + StartOperation(TVTOperationKind.okExpand); + BeginUpdate; + try + if Node = nil then + begin + Node := FRoot.FirstChild; + Stop := nil; + end + else + begin + Stop := Node.NextSibling; + if Stop = nil then + begin + Stop := Node; + repeat + Stop := Stop.Parent; + until (Stop = FRoot) or Assigned(Stop.NextSibling); + if Stop = FRoot then + Stop := nil + else + Stop := Stop.NextSibling; + end; + end; + + // Initialize the start node. Others will be initialized in GetNext. + if not (vsInitialized in Node.States) then + InitNode(Node); + + repeat + if not (vsExpanded in Node.States) then + ToggleNode(Node); + Node := GetNext(Node); + until (Node = Stop) or OperationCanceled; + finally + EndOperation(TVTOperationKind.okExpand); + EndUpdate; + DoStateChange([], [tsExpanding]); + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetControlsAlignment: TAlignment; + +begin + Result := FAlignment; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetDisplayRect(Node: PVirtualNode; Column: TColumnIndex; TextOnly: Boolean; + Unclipped: Boolean = False; ApplyCellContentMargin: Boolean = False): TRect; + +// Determines the client coordinates the given node covers, depending on scrolling, expand state etc. +// If the given node cannot be found (because one of its parents is collapsed or it is invisible) then an empty +// rectangle is returned. +// If TextOnly is True then only the text bounds are returned, that is, the resulting rectangle's left and right border +// are updated according to bidi mode, alignment and text width of the node. +// If Unclipped is True (which only makes sense if also TextOnly is True) then the calculated text rectangle is +// not clipped if the text does not entirely fit into the text space. This is special handling needed for hints. +// If ApplyCellContentMargin is True (which only makes sense if also TextOnly is True) then the calculated text +// rectangle respects the cell content margin. +// If Column is -1 then the entire client width is used before determining the node's width otherwise the bounds of the +// particular column are used. +// Note: Column must be a valid column and is used independent of whether the header is visible or not. + +var + Temp: PVirtualNode; + LeftOffset: TDimension; + TopOffset: TNodeHeight; + CacheIsAvailable: Boolean; + TextWidth: TDimension; + CurrentBidiMode: TBidiMode; + CurrentAlignment: TAlignment; + MaxUnclippedHeight: TDimension; + TM: TTextMetric; + ExtraVerticalMargin: TDimension; + lOffsets: TVTOffsets; +begin + Assert(Assigned(Node), 'Node must not be nil.'); + Assert(Node <> FRoot, 'Node must not be the hidden root node.'); + + if not (vsInitialized in Node.States) then + InitNode(Node); + + Result := Rect(0, 0, 0, 0); + + // Check whether the node is visible (determine indentation level btw.). + if not IsEffectivelyVisible[Node] then + Exit; + + // Here we know the node is visible. + TopOffset := 0; + CacheIsAvailable := False; + if tsUseCache in FStates then + begin + // If we can use the position cache then do a binary search to find a cached node which is as close as possible + // to the current node. Iterate then through all following and visible nodes and sum up their heights. + Temp := FindInPositionCache(Node, TopOffset); + CacheIsAvailable := Assigned(Temp); + while Assigned(Temp) and (Temp <> Node) do + begin + Inc(TopOffset, NodeHeight[Temp]); + Temp := GetNextVisibleNoInit(Temp, True); + end; + end; + if not CacheIsAvailable then + begin + // If the cache is not available then go straight through all nodes up to the root and sum up their heights. + Temp := Node; + repeat + Temp := GetPreviousVisibleNoInit(Temp, True); + if Temp = nil then + Break; + Inc(TopOffset, NodeHeight[Temp]); + until False; + end; + + Result := Rect(0, TopOffset, Max(FRangeX, ClientWidth), TopOffset + NodeHeight[Node]); + + // Limit left and right bounds to the given column (if any) and move bounds according to current scroll state. + if Column > NoColumn then + begin + FHeader.Columns.GetColumnBounds(Column, Result.Left, Result.Right); + // The right column border is not part of this cell. + Dec(Result.Right); + OffsetRect(Result, 0, FOffsetY); + end + else + OffsetRect(Result, -FEffectiveOffsetX, FOffsetY); + + // Limit left and right bounds further if only the text area is required. + if TextOnly then + begin + // If the text of a node is involved then we have to consider directionality and alignment too. + if Column <= NoColumn then + begin + CurrentBidiMode := BidiMode; + CurrentAlignment := Alignment; + end + else + begin + CurrentBidiMode := FHeader.Columns[Column].BidiMode; + CurrentAlignment := FHeader.Columns[Column].Alignment; + end; + + GetOffsets(Node, lOffsets, TVTElement.ofsLabel, Column); + LeftOffset := lOffSets[TVTElement.ofsLabel]; + // Offset contains now the distance from the left or right border of the rectangle (depending on bidi mode). + // Now consider the alignment too and calculate the final result. + if CurrentBidiMode = bdLeftToRight then + begin + Inc(Result.Left, LeftOffset); + // Left-to-right reading does not need any special adjustment of the alignment. + end + else + begin + Dec(Result.Right, LeftOffset); + + // Consider bidi mode here. In RTL context does left alignment actually mean right alignment and vice versa. + ChangeBiDiModeAlignment(CurrentAlignment); + end; + + TextWidth := DoGetNodeWidth(Node, Column); + + // Keep cell height before applying cell content margin in order to increase cell height if text does not fit + // and Unclipped it true (see below). + MaxUnclippedHeight := Result.Bottom - Result.Top; + + if ApplyCellContentMargin then + DoBeforeCellPaint(Self.Canvas, Node, Column, cpmGetContentMargin, Result, Result); + + if Unclipped then + begin + // The caller requested the text coordinates unclipped. This means they must be calculated so as would + // there be enough space, regardless of column bounds etc. + // The layout still depends on the available space too, because this determines the position + // of the unclipped text rectangle. + if Result.Right - Result.Left < TextWidth - 1 then + if CurrentBidiMode = bdLeftToRight then + CurrentAlignment := taLeftJustify + else + CurrentAlignment := taRightJustify; + + // Increase cell height (up to MaxUnclippedHeight determined above) if text does not fit. + GetTextMetrics(Self.Canvas, TM); + ExtraVerticalMargin := System.Math.Min(TM.tmHeight, MaxUnclippedHeight) - (Result.Bottom - Result.Top); + if ExtraVerticalMargin > 0 then + InflateRect(Result, 0, Divide(ExtraVerticalMargin + 1, 2)); + + case CurrentAlignment of + taCenter: + begin + Result.Left := Divide(Result.Left + Result.Right - TextWidth, 2); + Result.Right := Result.Left + TextWidth; + end; + taRightJustify: + Result.Left := Result.Right - TextWidth; + else // taLeftJustify + Result.Right := Result.Left + TextWidth - 1; + end; + end + else + // Modify rectangle only if the text fits entirely into the given room. + if Result.Right - Result.Left > TextWidth then + case CurrentAlignment of + taCenter: + begin + Result.Left := Divide(Result.Left + Result.Right - TextWidth, 2); + Result.Right := Result.Left + TextWidth; + end; + taRightJustify: + Result.Left := Result.Right - TextWidth; + else // taLeftJustify + Result.Right := Result.Left + TextWidth; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetEffectivelyFiltered(Node: PVirtualNode): Boolean; + +// Checks if a node is effectively filtered out. This depends on the nodes state and the paint options. + +begin + if Assigned(Node) then + Result := (vsFiltered in Node.States) and not (toShowFilteredNodes in FOptions.PaintOptions) + else + Result := False; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetEffectivelyVisible(Node: PVirtualNode): Boolean; + +begin + Result := (vsVisible in Node.States) and not IsEffectivelyFiltered[Node]; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetFirst(ConsiderChildrenAbove: Boolean = False): PVirtualNode; + +// Returns the first node in the tree while optionally considering toChildrenAbove. + +begin + if ConsiderChildrenAbove and (toChildrenAbove in FOptions.PaintOptions) then + begin + if vsHasChildren in FRoot.States then + begin + Result := FRoot; + + // Child nodes are the first choice if possible. + if Assigned(Result.FirstChild) then + begin + while Assigned(Result.FirstChild) do + begin + Result := Result.FirstChild; + if not (vsInitialized in Result.States) then + InitNode(Result); + + if (vsHasChildren in Result.States) and (Result.ChildCount = 0) then + InitChildren(Result); + end; + end + else + Result := nil; + end + else + Result := nil; + end + else + Result := FRoot.FirstChild; + + if Assigned(Result) and not (vsInitialized in Result.States) then + InitNode(Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetFirstChecked(State: TCheckState = csCheckedNormal; + ConsiderChildrenAbove: Boolean = False): PVirtualNode; + +// Returns the first node in the tree with the given check state. + +begin + Result := GetNextChecked(nil, State, ConsiderChildrenAbove); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetFirstChild(Node: PVirtualNode): PVirtualNode; + +// Returns the first child of the given node. The result node is initialized before exit. + +begin + if (Node = nil) or (Node = FRoot) then + Result := FRoot.FirstChild + else + begin + if not (vsInitialized in Node.States) then + InitNode(Node); + if vsHasChildren in Node.States then + begin + if Node.ChildCount = 0 then + InitChildren(Node); + Result := Node.FirstChild; + end + else + Result := nil; + end; + + if Assigned(Result) and not (vsInitialized in Result.States) then + InitNode(Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetFirstChildNoInit(Node: PVirtualNode): PVirtualNode; +// Determines the first child of the given node but does not initialize it. + +begin + if (Node = nil) or (Node = FRoot) then + Result := FRoot.FirstChild + else + begin + if vsHasChildren in Node.States then + Result := Node.FirstChild + else + Result := nil; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetFirstCutCopy(ConsiderChildrenAbove: Boolean = False): PVirtualNode; + +// Returns the first node in the tree which is currently marked for a clipboard operation. +// See also GetNextCutCopy for comments on initialization. + +begin + Result := GetNextCutCopy(nil, ConsiderChildrenAbove); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetFirstInitialized(ConsiderChildrenAbove: Boolean = False): PVirtualNode; + +// Returns the first node which is already initialized. + +begin + Result := GetFirstNoInit(ConsiderChildrenAbove); + if Assigned(Result) and not (vsInitialized in Result.States) then + Result := GetNextInitialized(Result, ConsiderChildrenAbove); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetFirstLeaf: PVirtualNode; + +// Returns the first node in the tree which has currently no children. +// The result is initialized if necessary. + +begin + Result := GetNextLeaf(nil); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetFirstLevel(NodeLevel: Cardinal): PVirtualNode; + +// Returns the first node in the tree on a specific level. +// The result is initialized if necessary. + +begin + Result := GetFirstNoInit(True); + while Assigned(Result) and (GetNodeLevel(Result) <> NodeLevel) do + Result := GetNextNoInit(Result, True); + + if Assigned(Result) and (GetNodeLevel(Result) <> NodeLevel) then // i.e. there is no node with the desired level in the tree + Result := nil; + + if Assigned(Result) and not (vsInitialized in Result.States) then + InitNode(Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetFirstNoInit(ConsiderChildrenAbove: Boolean = False): PVirtualNode; + +// Returns the first node in the tree while optionally considering toChildrenAbove. +// No initialization is performed. + +begin + if ConsiderChildrenAbove and (toChildrenAbove in FOptions.PaintOptions) then + begin + if vsHasChildren in FRoot.States then + begin + Result := FRoot; + + // Child nodes are the first choice if possible. + if Assigned(Result.FirstChild) then + begin + while Assigned(Result.FirstChild) do + Result := Result.FirstChild; + end + else + Result := nil; + end + else + Result := nil; + end + else + Result := FRoot.FirstChild; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetFirstSelected(ConsiderChildrenAbove: Boolean = False): PVirtualNode; + +// Returns the first node in the current selection while optionally considering toChildrenAbove. + +begin + Result := GetNextSelected(nil, ConsiderChildrenAbove); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetFirstVisible(Node: PVirtualNode = nil; ConsiderChildrenAbove: Boolean = True; + IncludeFiltered: Boolean = False): PVirtualNode; + +// Returns the first visible node in the tree while optionally considering toChildrenAbove. +// If necessary nodes are initialized on demand. + +begin + Result := Node; + if not Assigned(Result) then + Result := FRoot; + + if vsHasChildren in Result.States then + begin + if Result.ChildCount = 0 then + InitChildren(Result); + + // Child nodes are the first choice if possible. + if Assigned(Result.FirstChild) then + begin + Result := GetFirstChild(Result); + + if ConsiderChildrenAbove and (toChildrenAbove in FOptions.PaintOptions) then + begin + repeat + // Search the first visible sibling. + while Assigned(Result.NextSibling) and not (vsVisible in Result.States) do + begin + Result := Result.NextSibling; + // Init node on demand as this might change the visibility. + if not (vsInitialized in Result.States) then + InitNode(Result); + end; + + // If there are no visible siblings take the parent. + if not (vsVisible in Result.States) then + begin + Result := Result.Parent; + if Result = FRoot then + Result := nil; + Break; + end + else + begin + if (vsHasChildren in Result.States) and (Result.ChildCount = 0) then + InitChildren(Result); + if (not Assigned(Result.FirstChild)) or (not (vsExpanded in Result.States)) then + Break; + end; + + Result := Result.FirstChild; + if not (vsInitialized in Result.States) then + InitNode(Result); + until False; + end + else + begin + // If there are no children or the first child is not visible then search the sibling nodes or traverse parents. + if not (vsVisible in Result.States) then + begin + repeat + // Is there a next sibling? + if Assigned(Result.NextSibling) then + begin + Result := Result.NextSibling; + // The visible state can be removed during initialization so init the node first. + if not (vsInitialized in Result.States) then + InitNode(Result); + if vsVisible in Result.States then + Break; + end + else + begin + // No sibling anymore, so use the parent's next sibling. + if Result.Parent <> FRoot then + Result := Result.Parent + else + begin + // There are no further nodes to examine, hence there is no further visible node. + Result := nil; + Break; + end; + end; + until False; + end; + end; + end + else + Result := nil; + end + else + Result := nil; + + if Assigned(Result) and not IncludeFiltered and IsEffectivelyFiltered[Result] then + Result := GetNextVisible(Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetFirstVisibleChild(Node: PVirtualNode; IncludeFiltered: Boolean = False): PVirtualNode; + +// Returns the first visible child node of Node. If necessary nodes are initialized on demand. + +begin + if Node = nil then + Node := FRoot; + Result := GetFirstChild(Node); + + if Assigned(Result) and (not (vsVisible in Result.States) or + (not IncludeFiltered and IsEffectivelyFiltered[Result])) then + Result := GetNextVisibleSibling(Result, IncludeFiltered); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetFirstVisibleChildNoInit(Node: PVirtualNode; IncludeFiltered: Boolean = False): PVirtualNode; + +// Returns the first visible child node of Node. + +begin + if Node = nil then + Node := FRoot; + Result := Node.FirstChild; + if Assigned(Result) and (not (vsVisible in Result.States) or + (not IncludeFiltered and IsEffectivelyFiltered[Result])) then + Result := GetNextVisibleSiblingNoInit(Result, IncludeFiltered); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetFirstVisibleNoInit(Node: PVirtualNode = nil; + ConsiderChildrenAbove: Boolean = True; IncludeFiltered: Boolean = False): PVirtualNode; + +// Returns the first visible node in the tree or given subtree while optionally considering toChildrenAbove. +// No initialization is performed. + +begin + Result := Node; + if not Assigned(Result) then + Result := FRoot; + + if vsHasChildren in Result.States then + begin + // Child nodes are the first choice if possible. + if Assigned(Result.FirstChild) then + begin + Result := Result.FirstChild; + + if ConsiderChildrenAbove and (toChildrenAbove in FOptions.PaintOptions) then + begin + repeat + // Search the first visible sibling. + while Assigned(Result.NextSibling) and not (vsVisible in Result.States) do + Result := Result.NextSibling; + + // If there a no visible siblings take the parent. + if not (vsVisible in Result.States) then + begin + Result := Result.Parent; + if Result = FRoot then + Result := nil; + Break; + end + else + if (not Assigned(Result.FirstChild)) or (not (vsExpanded in Result.States))then + Break; + + Result := Result.FirstChild; + until False; + end + else + begin + // If there are no children or the first child is not visible then search the sibling nodes or traverse parents. + if not (vsVisible in Result.States) then + begin + repeat + // Is there a next sibling? + if Assigned(Result.NextSibling) then + begin + Result := Result.NextSibling; + if vsVisible in Result.States then + Break; + end + else + begin + // No sibling anymore, so use the parent's next sibling. + if Result.Parent <> FRoot then + Result := Result.Parent + else + begin + // There are no further nodes to examine, hence there is no further visible node. + Result := nil; + Break; + end; + end; + until False; + end; + end; + end + else + Result := nil; + end + else + Result := nil; + + if Assigned(Result) and not IncludeFiltered and IsEffectivelyFiltered[Result] then + Result := GetNextVisibleNoInit(Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.GetHitTestInfoAt(X, Y: TDimension; Relative: Boolean; var HitInfo: THitInfo; ShiftState: TShiftState=[]); + +// Determines the node that occupies the specified point or nil if there's none. The parameter Relative determines +// whether to consider X and Y as being client coordinates (if True) or as being absolute tree coordinates. +// HitInfo is filled with flags describing the hit further. + +var + ColLeft, + ColRight: TDimension; + NodeTop: TDimension; + InitialColumn, + NextColumn: TColumnIndex; + CurrentBidiMode: TBidiMode; + CurrentAlignment: TAlignment; + NodeRect: TRect; + +begin + HitInfo.HitNode := nil; + HitInfo.HitPositions := []; + HitInfo.HitColumn := NoColumn; + + if ShiftState=[] then + ShiftState:= KeyboardStateToShiftState(); + HitInfo.ShiftState:= ShiftState; + + // Determine if point lies in the tree's client area. + if X < 0 then + Include(HitInfo.HitPositions, hiToLeft) + else + if X > Max(FRangeX, ClientWidth) then + Include(HitInfo.HitPositions, hiToRight); + + if Y < 0 then + Include(HitInfo.HitPositions, hiAbove) + else + if Y > Max(FRangeY, ClientHeight) then + Include(HitInfo.HitPositions, hiBelow); + + // Convert position into absolute coordinate if necessary. + if Relative then + begin + if X >= Header.Columns.GetVisibleFixedWidth then + Inc(X, FEffectiveOffsetX); + Inc(Y, -FOffsetY); + end; + HitInfo.HitPoint.X := X; + HitInfo.HitPoint.Y := Y; + + // If the point is in the tree area then check the nodes. + if HitInfo.HitPositions = [] then + begin + HitInfo.HitNode := GetNodeAt(X, Y, False, NodeTop); + if HitInfo.HitNode = nil then + Include(HitInfo.HitPositions, hiNowhere) + else + begin + // At this point we need some info about the node, so it must be initialized. + if not (vsInitialized in HitInfo.HitNode.States) then + InitNode(HitInfo.HitNode); + + if FHeader.UseColumns then + begin + HitInfo.HitColumn := TVirtualTreeColumnsCracker(FHeader.Columns).GetColumnAndBounds(Point(X, Y), ColLeft, ColRight, False); + // If auto column spanning is enabled then look for the last non empty column. + if toAutoSpanColumns in FOptions.AutoOptions then + begin + InitialColumn := HitInfo.HitColumn; + // Search to the left of the hit column for empty columns. + while (HitInfo.HitColumn > NoColumn) and ColumnIsEmpty(HitInfo.HitNode, HitInfo.HitColumn) do + begin + NextColumn := FHeader.Columns.GetPreviousVisibleColumn(HitInfo.HitColumn); + if NextColumn = InvalidColumn then + Break; + HitInfo.HitColumn := NextColumn; + Dec(ColLeft, FHeader.Columns[NextColumn].Width); + end; + // Search to the right of the hit column for empty columns. + repeat + InitialColumn := FHeader.Columns.GetNextVisibleColumn(InitialColumn); + if (InitialColumn = InvalidColumn) or not ColumnIsEmpty(HitInfo.HitNode, InitialColumn) then + Break; + Inc(ColRight, FHeader.Columns[InitialColumn].Width); + until False; + end; + // Make the X position and the right border relative to the start of the column. + Dec(X, ColLeft); + Dec(ColRight, ColLeft); + end + else + begin + HitInfo.HitColumn := NoColumn; + ColRight := Max(FRangeX, ClientWidth); + end; + ColLeft := 0; + + if HitInfo.HitColumn = InvalidColumn then + Include(HitInfo.HitPositions, hiNowhere) + else + begin + // From now on X is in "column" coordinates (relative to the left column border). + HitInfo.HitPositions := [hiOnItem]; + + // Avoid getting the display rect if this is not necessary. + if toNodeHeightResize in FOptions.MiscOptions then + begin + NodeRect := GetDisplayRect(HitInfo.HitNode, HitInfo.HitColumn, False); + if Y <= (NodeRect.Top - FOffsetY + 1) then + Include(HitInfo.HitPositions, hiUpperSplitter) + else + if Y >= (NodeRect.Bottom - FOffsetY - 3) then + Include(HitInfo.HitPositions, hiLowerSplitter); + end; + + if HitInfo.HitColumn <= NoColumn then + begin + CurrentBidiMode := BidiMode; + CurrentAlignment := Alignment; + end + else + begin + CurrentBidiMode := FHeader.Columns[HitInfo.HitColumn].BidiMode; + CurrentAlignment := FHeader.Columns[HitInfo.HitColumn].Alignment; + end; + + if CurrentBidiMode = bdLeftToRight then + DetermineHitPositionLTR(HitInfo, X, ColRight, CurrentAlignment) + else + DetermineHitPositionRTL(HitInfo, X, ColRight, CurrentAlignment); + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetLast(Node: PVirtualNode = nil; ConsiderChildrenAbove: Boolean = False): PVirtualNode; + +// Returns the very last node in the tree branch given by Node and initializes the nodes all the way down including the +// result. toChildrenAbove is optionally considered. By using Node = nil the very last node in the tree is returned. + +var + Next: PVirtualNode; + +begin + Result := GetLastChild(Node); + if not ConsiderChildrenAbove or not (toChildrenAbove in FOptions.PaintOptions) then + while Assigned(Result) do + begin + // Test if there is a next last child. If not keep the node from the last run. + // Otherwise use the next last child. + Next := GetLastChild(Result); + if Next = nil then + Break; + Result := Next; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetLastInitialized(Node: PVirtualNode = nil; + ConsiderChildrenAbove: Boolean = False): PVirtualNode; + +// Returns the very last initialized child node in the tree branch given by Node. + +begin + Result := GetLastNoInit(Node, ConsiderChildrenAbove); + if Assigned(Result) and not (vsInitialized in Result.States) then + Result := GetPreviousInitialized(Result, ConsiderChildrenAbove); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetLastNoInit(Node: PVirtualNode = nil; ConsiderChildrenAbove: Boolean = False): PVirtualNode; + +// Returns the very last node in the tree branch given by Node without initialization. + +var + Next: PVirtualNode; + +begin + Result := GetLastChildNoInit(Node); + if not ConsiderChildrenAbove or not (toChildrenAbove in FOptions.PaintOptions) then + while Assigned(Result) do + begin + // Test if there is a next last child. If not keep the node from the last run. + // Otherwise use the next last child. + Next := GetLastChildNoInit(Result); + if Next = nil then + Break; + Result := Next; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetLastChild(Node: PVirtualNode): PVirtualNode; + +// Determines the last child of the given node and initializes it if there is one. + +begin + if (Node = nil) or (Node = FRoot) then + Result := FRoot.LastChild + else + begin + if not (vsInitialized in Node.States) then + InitNode(Node); + if vsHasChildren in Node.States then + begin + if Node.ChildCount = 0 then + InitChildren(Node); + Result := Node.LastChild; + end + else + Result := nil; + end; + + if Assigned(Result) and not (vsInitialized in Result.States) then + InitNode(Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetLastChildNoInit(Node: PVirtualNode): PVirtualNode; + +// Determines the last child of the given node but does not initialize it. + +begin + if (Node = nil) or (Node = FRoot) then + Result := FRoot.LastChild + else + begin + if vsHasChildren in Node.States then + Result := Node.LastChild + else + Result := nil; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetLastSelected(ConsiderChildrenAbove: Boolean = False): PVirtualNode; + +// Returns the last node in the current selection while optionally considering toChildrenAbove. + +begin + Result := GetPreviousSelected(nil, ConsiderChildrenAbove); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetLastVisible(Node: PVirtualNode = nil; ConsiderChildrenAbove: Boolean = True; + IncludeFiltered: Boolean = False): PVirtualNode; + +// Returns the very last visible node in the tree while optionally considering toChildrenAbove. +// The nodes are intialized all the way up including the result node. + +var + Run: PVirtualNode; + +begin + Result := GetLastVisibleNoInit(Node, ConsiderChildrenAbove); + + Run := Result; + while Assigned(Run) and (Run <> Node) and (Run <> RootNode) do + begin + if not (vsInitialized in Run.States) then + InitNode(Run); + Run := Run.Parent; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetLastVisibleChild(Node: PVirtualNode; IncludeFiltered: Boolean = False): PVirtualNode; + +// Determines the last visible child of the given node and initializes it if necessary. + +begin + if (Node = nil) or (Node = FRoot) then + Result := GetLastChild(FRoot) + else + if FullyVisible[Node] and (vsExpanded in Node.States) then + Result := GetLastChild(Node) + else + Result := nil; + + if Assigned(Result) and (not (vsVisible in Result.States) or + (not IncludeFiltered and IsEffectivelyFiltered[Result])) then + Result := GetPreviousVisibleSibling(Result, IncludeFiltered); + + if Assigned(Result) and not (vsInitialized in Result.States) then + InitNode(Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetLastVisibleChildNoInit(Node: PVirtualNode; IncludeFiltered: Boolean = False): PVirtualNode; + +// Determines the last visible child of the given node without initialization. + +begin + if (Node = nil) or (Node = FRoot) then + Result := GetLastChildNoInit(FRoot) + else + if FullyVisible[Node] and (vsExpanded in Node.States) then + Result := GetLastChildNoInit(Node) + else + Result := nil; + + if Assigned(Result) and (not (vsVisible in Result.States) or + (not IncludeFiltered and IsEffectivelyFiltered[Result])) then + Result := GetPreviousVisibleSiblingNoInit(Result, IncludeFiltered); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetLastVisibleNoInit(Node: PVirtualNode = nil; + ConsiderChildrenAbove: Boolean = True; IncludeFiltered: Boolean = False): PVirtualNode; + +// Returns the very last visible node in the tree while optionally considering toChildrenAbove. +// Note that the visibility of all ancestor nodes of the resulting node must not be considered. +// No initialization is performed. + + //--------------- local functions ------------------------------------------- + + function GetNodeIsVisible(ChildNode: PVirtualNode): Boolean; + begin + Result := (vsVisible in ChildNode.States) and + (IncludeFiltered or not IsEffectivelyFiltered[ChildNode]); + end; + + function GetNodeHasVisibleChildren(ChildNode: PVirtualNode): Boolean; + begin + Result := (vsHasChildren in ChildNode.States) and + (vsExpanded in ChildNode.States) and + not (vsAllChildrenHidden in ChildNode.States); + end; + + function IterateChildren(ParentNode: PVirtualNode): PVirtualNode; + var + Run: PVirtualNode; + begin + Result := nil; + + Run := GetLastChildNoInit(ParentNode); // Do not use 'GetLastVisibleChildNoInit' here (see above). + while Assigned(Run) do + begin + if ConsiderChildrenAbove and (toChildrenAbove in FOptions.PaintOptions) then + begin + if GetNodeIsVisible(Run) then + Result := Run + else if GetNodeHasVisibleChildren(Run) then + Result := IterateChildren(Run); + end else + begin + if GetNodeHasVisibleChildren(Run) then + Result := IterateChildren(Run) + else if GetNodeIsVisible(Run) then + Result := Run; + end; + + if Assigned(Result) then + break; + + Run := GetPreviousSiblingNoInit(Run); + end; + end; + + //--------------- end local functions --------------------------------------- + +var + Run: PVirtualNode; + +begin + Result := nil; + + // First, check wether the given node and all its parents are expanded. + // If not, there can not be any visible child node. + Run := Node; + while Assigned(Run) and (Run <> RootNode) do + begin + if not (vsExpanded in Run.States) then + exit; + Run := Run.Parent; + end; + + Result := IterateChildren(Node); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetMaxColumnWidth(Column: TColumnIndex; UseSmartColumnWidth: Boolean = False): TDimension; + +// This method determines the width of the largest node in the given column. +// If UseSmartColumnWidth is True then only the visible nodes which are in view will be considered +// Note: If UseSmartColumnWidth is False then every visible node in the tree will be initialized contradicting so +// the virtual paradigm. + +var + Run, + LastNode, + NextNode: PVirtualNode; + TextLeft, + CurrentWidth: TDimension; + lOffsets: TVTOffsets; +begin + if OperationCanceled then + begin + // Behave non-destructive. + Result := FHeader.Columns[Column].Width; + Exit; + end + else + Result := 0; + + StartOperation(okGetMaxColumnWidth); + try + if Assigned(FOnBeforeGetMaxColumnWidth) then + FOnBeforeGetMaxColumnWidth(FHeader, Column, UseSmartColumnWidth); + + if UseSmartColumnWidth then // Get first visible node which is in view. + Run := GetTopNode + else + Run := GetFirstVisible(nil, True); + + // Decide where to stop. + if UseSmartColumnWidth then + LastNode := GetNextVisible(BottomNode) + else + LastNode := nil; + + if hoAutoResizeInclCaption in FHeader.Options then + Result := Result + (2 * Header.Columns[Column].Margin + Header.Columns[Column].CaptionWidth + 2); + + while Assigned(Run) and not OperationCanceled do + begin + GetOffsets(Run, lOffsets, TVTElement.ofsLabel, Column); + TextLeft := lOffsets[TVTElement.ofsLabel]; + CurrentWidth := DoGetNodeWidth(Run, Column); + Inc(CurrentWidth, DoGetNodeExtraWidth(Run, Column)); + Inc(CurrentWidth, DoGetCellContentMargin(Run, Column).X); + + // Background for fix: + // DoGetNodeWidth works correctly to return just the + // headerwidth in vsMultiline state of the node. But the + // following code was adding TextLeft unnecessarily. This + // caused a width increase each time a column splitter + // was double-clicked for the option hoDblClickResize that + // really does not apply for vsMultiline case. + // Fix: If the node is multiline, leave the current width as + // it is as returned by DoGetNodeWidth logic above. + if (Column > NoColumn) and (vsMultiline in Run.States) then + Result := CurrentWidth + else + if Result < (TextLeft + CurrentWidth) then + Result := TextLeft + CurrentWidth; + + // Get next visible node and update left node position if needed. + NextNode := GetNextVisible(Run, True); + if NextNode = LastNode then + Break; + Run := NextNode; + end; + if toShowVertGridLines in FOptions.PaintOptions then + Inc(Result); + + if Assigned(FOnAfterGetMaxColumnWidth) then + FOnAfterGetMaxColumnWidth(FHeader, Column, Result); + + finally + EndOperation(okGetMaxColumnWidth); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetNext(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode; + +// Returns next node in tree while optionally considering toChildrenAbove. The Result will be initialized if needed. + +begin + Result := Node; + if Assigned(Result) then + begin + Assert(Result <> FRoot, 'Node must not be the hidden root node.'); + + if ConsiderChildrenAbove and (toChildrenAbove in FOptions.PaintOptions) then + begin + // If this node has no siblings use the parent. + if not Assigned(Result.NextSibling) then + begin + Result := Result.Parent; + if Result = FRoot then + begin + Result := nil; + end; + end + else + begin + // There is at least one sibling so take it. + Result := Result.NextSibling; + + // Has this node got children? Initialize them if necessary. + if (vsHasChildren in Result.States) and (Result.ChildCount = 0) then + InitChildren(Result); + + // Now take a look at the children. + while Assigned(Result.FirstChild) do + begin + Result := Result.FirstChild; + if (vsHasChildren in Result.States) and (Result.ChildCount = 0) then + InitChildren(Result); + end; + end; + end + else + begin + // Has this node got children? + if vsHasChildren in Result.States then + begin + // Yes, there are child nodes. Initialize them if necessary. + if Result.ChildCount = 0 then + InitChildren(Result); + end; + + // if there is no child node try siblings + if Assigned(Result.FirstChild) then + Result := Result.FirstChild + else + begin + repeat + // Is there a next sibling? + if Assigned(Result.NextSibling) then + begin + Result := Result.NextSibling; + Break; + end + else + begin + // No sibling anymore, so use the parent's next sibling. + if Result.Parent <> FRoot then + Result := Result.Parent + else + begin + // There are no further nodes to examine, hence there is no further visible node. + Result := nil; + Break; + end; + end; + until False; + end; + end; + end; + + if Assigned(Result) and not (vsInitialized in Result.States) then + InitNode(Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetNextChecked(Node: PVirtualNode; State: TCheckState = csCheckedNormal; + ConsiderChildrenAbove: Boolean = False): PVirtualNode; + +begin + if (Node = nil) or (Node = FRoot) then + Result := GetFirstNoInit(ConsiderChildrenAbove) + else + Result := GetNextNoInit(Node, ConsiderChildrenAbove); + + while Assigned(Result) and (GetCheckState(Result) <> State) do + Result := GetNextNoInit(Result, ConsiderChildrenAbove); + + if Assigned(Result) and not (vsInitialized in Result.States) then + InitNode(Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetNextChecked(Node: PVirtualNode; ConsiderChildrenAbove: Boolean): PVirtualNode; +begin + Result := Self.GetNextChecked(Node, csCheckedNormal, ConsiderChildrenAbove); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetNextCutCopy(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode; + +// Returns the next node in the tree which is currently marked for a clipboard operation. Since only visible nodes can +// be marked (or they are hidden after they have been marked) it is not necessary to initialize nodes to check for +// child nodes. The result, however, is initialized if necessary. + +begin + if ClipboardStates * FStates <> [] then + begin + if (Node = nil) or (Node = FRoot) then + Result := GetFirstNoInit(ConsiderChildrenAbove) + else + Result := GetNextNoInit(Node, ConsiderChildrenAbove); + while Assigned(Result) and not (vsCutOrCopy in Result.States) do + Result := GetNextNoInit(Result, ConsiderChildrenAbove); + if Assigned(Result) and not (vsInitialized in Result.States) then + InitNode(Result); + end + else + Result := nil; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetNextInitialized(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode; + +// Returns the next node in tree which is initialized. + +begin + Result := Node; + repeat + Result := GetNextNoInit(Result, ConsiderChildrenAbove); + until (Result = nil) or (vsInitialized in Result.States); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetNextLeaf(Node: PVirtualNode): PVirtualNode; + +// Returns the next node in the tree which has currently no children. +// The result is initialized if necessary. + +begin + if (Node = nil) or (Node = FRoot) then + Result := FRoot.FirstChild + else + Result := GetNext(Node); + while Assigned(Result) and (vsHasChildren in Result.States) do + Result := GetNext(Result); + if Assigned(Result) and not (vsInitialized in Result.States) then + InitNode(Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetNextLevel(Node: PVirtualNode; NodeLevel: Cardinal): PVirtualNode; + +// Returns the next node in the tree on a specific level. +// The result is initialized if necessary. + +var + StartNodeLevel: Cardinal; + +begin + Result := nil; + + if Assigned(Node) and (Node <> FRoot) then + begin + StartNodeLevel := GetNodeLevel(Node); + + if StartNodeLevel < NodeLevel then + begin + Result := GetNext(Node); + if Assigned(Result) and (GetNodeLevel(Result) <> NodeLevel) then + Result := GetNextLevel(Result, NodeLevel); + end + else + if StartNodeLevel = NodeLevel then + begin + Result := Node.NextSibling; + if not Assigned(Result) then // i.e. start node was a last sibling + begin + Result := Node.Parent; + if Assigned(Result) then + begin + // go to next anchestor of the start node which has a next sibling (if exists) + while Assigned(Result) and not Assigned(Result.NextSibling) do + Result := Result.Parent; + if Assigned(Result) then + Result := GetNextLevel(Result.NextSibling, NodeLevel); + end; + end; + end + else + // i.e. StartNodeLevel > NodeLevel + Result := GetNextLevel(Node.Parent, NodeLevel); + end; + + if Assigned(Result) and not (vsInitialized in Result.States) then + InitNode(Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetNextNoInit(Node: PVirtualNode; ConsiderChildrenAbove: Boolean): PVirtualNode; + +// Optimized version of GetNext performing no initialization, but optionally considering toChildrenAbove. + +begin + Result := Node; + if Assigned(Result) then + begin + Assert(Result <> FRoot, 'Node must not be the hidden root node.'); + + if ConsiderChildrenAbove and (toChildrenAbove in FOptions.PaintOptions) then + begin + // If this node has no siblings use the parent. + if not Assigned(Result.NextSibling) then + begin + Result := Result.Parent; + if Result = FRoot then + begin + Result := nil; + end; + end + else + begin + // There is at least one sibling so take it. + Result := Result.NextSibling; + + // Now take a look at the children. + while Assigned(Result.FirstChild) do + begin + Result := Result.FirstChild; + end; + end; + end + else + begin + // If there is no child node try siblings. + if Assigned(Result.FirstChild) then + Result := Result.FirstChild + else + begin + repeat + // Is there a next sibling? + if Assigned(Result.NextSibling) then + begin + Result := Result.NextSibling; + Break; + end + else + begin + // No sibling anymore, so use the parent's next sibling. + if Result.Parent <> FRoot then + Result := Result.Parent + else + begin + // There are no further nodes to examine, hence there is no further visible node. + Result := nil; + Break; + end; + end; + until False; + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetNextSelected(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode; + +// Returns the next node in the tree which is currently selected. Since children of unitialized nodes cannot be +// in the current selection (because they simply do not exist yet) it is not necessary to initialize nodes here. +// The result however is initialized if necessary. + +begin + if FSelectionCount > 0 then + begin + if (Node = nil) or (Node = FRoot) then + Result := GetFirstNoInit(ConsiderChildrenAbove) + else + Result := GetNextNoInit(Node, ConsiderChildrenAbove); + while Assigned(Result) and not (vsSelected in Result.States) do + Result := GetNextNoInit(Result, ConsiderChildrenAbove); + if Assigned(Result) and not (vsInitialized in Result.States) then + InitNode(Result); + end + else + Result := nil; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetNextSibling(Node: PVirtualNode): PVirtualNode; + +// Returns the next sibling of Node and initializes it if necessary. + +begin + Result := Node; + if Assigned(Result) then + begin + Assert(Result <> FRoot, 'Node must not be the hidden root node.'); + + Result := Result.NextSibling; + if Assigned(Result) and not (vsInitialized in Result.States) then + InitNode(Result); + end; +end; + +function TBaseVirtualTree.GetNextSiblingNoInit(Node: PVirtualNode): PVirtualNode; + +// Returns the next sibling of Node. + +begin + Result := Node; + if Assigned(Result) then + begin + Assert(Result <> FRoot, 'Node must not be the hidden root node.'); + + Result := Result.NextSibling; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetNextVisible(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = True): PVirtualNode; + +// Returns next node in tree, with regard to Node, which is visible. +// Nodes which need an initialization (including the result) are initialized. +// toChildrenAbove is optionally considered which is the default here. + +var + TopInvisibleParent: PVirtualNode; + ForceSearch: Boolean; + +begin + Result := Node; + if not Assigned(Result) then Exit; + + Assert(Result <> FRoot, 'Node must not be the hidden root node.'); + + repeat + // If any ancestor is invisible, then find the last (furthest) parent node + // which is invisible to skip invisible subtrees. Otherwise we will + // likely go unnecessarily through a whole bunch of invisible nodes. + TopInvisibleParent := GetTopInvisibleParent(Result); + if Assigned(TopInvisibleParent) then + Result := TopInvisibleParent; + + if ConsiderChildrenAbove and (toChildrenAbove in FOptions.PaintOptions) then + begin + repeat + // If there a no siblings anymore, go up one level. + if not Assigned(Result.NextSibling) then + begin + Result := Result.Parent; + if Result = FRoot then + begin + Result := nil; + Break; + end; + + if not (vsInitialized in Result.States) then + InitNode(Result); + end + else + begin + // There is at least one sibling so take it. + Result := Result.NextSibling; + if not (vsInitialized in Result.States) then + InitNode(Result); + if not (vsVisible in Result.States) then + Continue; + + // Now take a look at the children. As the children are initialized + // while toggling, we don't need to call 'InitChildren' beforehand here. + while (vsExpanded in Result.States) and Assigned(Result.FirstChild) do + begin + Result := Result.FirstChild; + if not (vsInitialized in Result.States) then + InitNode(Result); + if not (vsVisible in Result.States) then + Break; + end; + end; + + // If we found a visible node we don't need to search any longer. + // As it has already been initialized above, we don't need to call 'InitNode' here. + if vsVisible in Result.States then + Break; + until False; + end + else + begin + ForceSearch := True; + // If we found an invisible ancestor, we must not check its children. + // Remember, that TopInvisibleParent can be effectively invisible merely due to + // its own parent's expansion state despite being visible itself. + if Result <> TopInvisibleParent then + begin + if not (vsInitialized in Result.States) then + InitNode(Result); + + // Child nodes are the first choice if the current node is known to be visible. + if (vsVisible in Result.States) and (vsExpanded in Result.States) then + begin + // Initialize the node's children if necessary. + if (vsHasChildren in Result.States) and (Result.ChildCount = 0) then + InitChildren(Result); + + if Assigned(Result.FirstChild) then + begin + Result := Result.FirstChild; + if not (vsInitialized in Result.States) then + InitNode(Result); + ForceSearch := False; + end; + end; + end; + + // If there are no children or the first child is not visible then search the sibling nodes or traverse parents. + if ForceSearch or not (vsVisible in Result.States) then + begin + repeat + // Is there a next sibling? + if Assigned(Result.NextSibling) then + begin + Result := Result.NextSibling; + if not (vsInitialized in Result.States) then + InitNode(Result); + if vsVisible in Result.States then + Break; + end + // No sibling anymore, so use the parent's next sibling. + else if Result.Parent <> FRoot then + Result := Result.Parent + else + begin + // There are no further nodes to examine, hence there is no further visible node. + Result := nil; + Break; + end; + until False; + end; + end; + until not Assigned(Result) or IsEffectivelyVisible[Result]; + + Assert(Result <> Node, 'Node cannot be its own visible successor.'); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetNextVisibleNoInit(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = True): PVirtualNode; + +// Returns the next node in tree, with regard to Node, which is visible. +// No initialization is done. +// toChildrenAbove is optionally considered which is the default here. + +var + TopInvisibleParent: PVirtualNode; + ForceSearch: Boolean; + +begin + Result := Node; + if not Assigned(Result) then Exit; + + Assert(Result <> FRoot, 'Node must not be the hidden root node.'); + + repeat + // If any ancestor is invisible, then find the last (furthest) parent node + // which is invisible to skip invisible subtrees. Otherwise we will + // likely go unnecessarily through a whole bunch of invisible nodes. + TopInvisibleParent := GetTopInvisibleParent(Result); + if Assigned(TopInvisibleParent) then + Result := TopInvisibleParent; + + if ConsiderChildrenAbove and (toChildrenAbove in FOptions.PaintOptions) then + begin + repeat + // If there are no siblings anymore, go up one level. + if not Assigned(Result.NextSibling) then + begin + Result := Result.Parent; + if Result = FRoot then + begin + Result := nil; + Break; + end; + end + else + begin + // There is at least one sibling so take it. + Result := Result.NextSibling; + if not (vsVisible in Result.States) then + Continue; + + // Now take a look at the children. + while (vsExpanded in Result.States) and Assigned(Result.FirstChild) do + begin + Result := Result.FirstChild; + if not (vsVisible in Result.States) then + Break; + end; + end; + + // If we found a visible node we don't need to search any longer. + if vsVisible in Result.States then + Break; + until False; + end + else + begin + // Child nodes are the first choice if the current node is known to be visible. + // Remember, that TopInvisibleParent can be effectively invisible merely due to + // its own parent's expansion state despite being visible itself. + if (vsVisible in Result.States) and (vsExpanded in Result.States) and + (Result <> TopInvisibleParent) and Assigned(Result.FirstChild) then + begin + Result := Result.FirstChild; + ForceSearch := False; + end else + ForceSearch := True; + + // If there are no children or the first child is not visible then search the sibling nodes or traverse parents. + if ForceSearch or not (vsVisible in Result.States) then + begin + repeat + // Is there a next sibling? + if Assigned(Result.NextSibling) then + begin + Result := Result.NextSibling; + if vsVisible in Result.States then + Break; + end + // No sibling anymore, so use the parent's next sibling. + else if Result.Parent <> FRoot then + Result := Result.Parent + else + begin + // There are no further nodes to examine, hence there is no further visible node. + Result := nil; + Break; + end; + until False; + end; + end; + until not Assigned(Result) or IsEffectivelyVisible[Result]; + + Assert(Result <> Node, 'Node cannot be its own visible successor.'); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetNextVisibleSibling(Node: PVirtualNode; IncludeFiltered: Boolean = False): PVirtualNode; + +// Returns the next visible sibling after Node. Initialization is done implicitly. + +begin + Assert(Assigned(Node) and (Node <> FRoot), 'Invalid parameter.'); + + Result := Node; + repeat + Result := GetNextSibling(Result); + until not Assigned(Result) or ((vsVisible in Result.States) and + (IncludeFiltered or not IsEffectivelyFiltered[Result])); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetNextVisibleSiblingNoInit(Node: PVirtualNode; IncludeFiltered: Boolean = False): PVirtualNode; + +// Returns the next visible sibling after Node. + +begin + Assert(Assigned(Node) and (Node <> FRoot), 'Invalid parameter.'); + + Result := Node; + repeat + Result := Result.NextSibling; + until not Assigned(Result) or ((vsVisible in Result.States) and + (IncludeFiltered or not IsEffectivelyFiltered[Result])); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetNodeAt(X, Y: TDimension): PVirtualNode; + +// Overloaded variant of GetNodeAt to easy life of application developers which do not need to have the exact +// top position returned and always use client coordinates. + +var + Dummy: TDimension; + +begin + Result := GetNodeAt(X, Y, True, Dummy); +end; + +function TBaseVirtualTree.GetNodeAt(const P: TPoint): PVirtualNode; +begin + Result := GetNodeAt(P.X, P.Y); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetNodeAt(X, Y: TDimension; Relative: Boolean; var NodeTop: TDimension): PVirtualNode; + +// This method returns the node that occupies the specified point, or nil if there's none. +// If Releative is True then X and Y are given in client coordinates otherwise they are considered as being +// absolute values into the virtual tree image (regardless of the current offsets in the tree window). +// NodeTop gets the absolute or relative top position of the node returned or is untouched if no node +// could be found. + +var + AbsolutePos, + CurrentPos: TNodeHeight; + +begin + if Y < 0 then + Y := 0; + + AbsolutePos := Y; + if Relative then + Inc(AbsolutePos, -FOffsetY); + + // CurrentPos tracks a running term of the current position to test for. + // It corresponds always to the top position of the currently considered node. + CurrentPos := 0; + + // If the cache is available then use it. + if tsUseCache in FStates then + Result := FindInPositionCache(AbsolutePos, CurrentPos) + else + Result := GetFirstVisibleNoInit(nil, True); + + // Determine node, of which position and height corresponds to the scroll position most closely. + while Assigned(Result) and (Result <> FRoot) do + begin + if AbsolutePos < (CurrentPos + NodeHeight[Result]) then + Break; + Inc(CurrentPos, NodeHeight[Result]); + Result := GetNextVisibleNoInit(Result, True); + end; + + if Result = FRoot then + Result := nil; + + // Since the given vertical position is likely not the same as the top position + // of the found node this top position is returned. + if Assigned(Result) then + begin + NodeTop := CurrentPos; + if Relative then + Inc(NodeTop, FOffsetY); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + + +function TBaseVirtualTree.GetNodeData(Node: PVirtualNode): Pointer; + +// Returns the address of the user defined data area in the node. + +begin + Assert((FNodeDataSize > 0) or not Assigned(Node), 'NodeDataSize not initialized.'); + if (FNodeDataSize <= 0) or (Node = nil) or (Node = FRoot) then + Result := nil + else + begin + Result := Node.GetData(); + Include(Node.States, vsOnFreeNodeCallRequired); // We now need to call OnFreeNode, see bug #323 + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetNodeData(pNode: PVirtualNode): T; + +// Returns the associated data converted to the class given in the generic part of the function. + +var + P: Pointer; +begin + P := Self.GetNodeData(pNode); + if Assigned(P) then + Exit(T(P^)) + else + Exit(Default(T)); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetInterfaceFromNodeData(pNode: PVirtualNode): T; +begin + if Assigned(pNode) then + Result := T(Self.GetNodeData(pNode)^) + else + Result := nil; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetNodeDataAt(pXCoord, pYCoord: Integer): T; + +// Returns the associated data at the specified coordinates converted to the type given in the generic part of the function. + +var + lNode: PVirtualNode; +begin + lNode := GetNodeAt(pXCoord, pYCoord); + Result := Self.GetNodeData(lNode); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetFirstSelectedNodeData(): T; + +// Returns of the first selected node associated data converted to the type given in the generic part of the function. + +begin + Result := Self.GetNodeData(GetFirstSelected()); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetNodeLevel(Node: PVirtualNode): Cardinal; + +// returns the level of the given node + +var + Run: PVirtualNode; + +begin + Result := 0; + if Assigned(Node) and (Node <> FRoot) then + begin + Run := Node.Parent; + while Run <> FRoot do + begin + Run := Run.Parent; + System.Inc(Result); + end; + end; +end; + + +//---------------------------------------------------------------------------------------------------------------------- +// Function introduced to avoid spaghetti code to fix setting of FLastSelectionLevel +// at various places that now needs to avoid setting it for a disabled node +function TBaseVirtualTree.GetNodeLevelForSelectConstraint(Node: PVirtualNode): integer; +begin + if Assigned(Node) and not (vsDisabled in Node.States) then + result := GetNodeLevel(Node) + else + result := -1; +end; + + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetPrevious(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode; + +// Returns previous node in tree. If ConsiderChildrenAbove is True the function considers +// whether toChildrenAbove is currently set, otherwise the result will always be the previous +// node in top-down order regardless of the current PaintOptions. +// The Result will be initialized if needed. + +var + Run: PVirtualNode; + +begin + Result := Node; + if Assigned(Result) then + begin + Assert(Result <> FRoot, 'Node must not be the hidden root node.'); + + if ConsiderChildrenAbove and (toChildrenAbove in FOptions.PaintOptions) then + begin + // Has this node got children? Initialize them if necessary. + if (vsHasChildren in Result.States) and (Result.ChildCount = 0) then + InitChildren(Result); + + // If there is a last child, take it; if not try the previous sibling. + if Assigned(Result.LastChild) then + Result := Result.LastChild + else + if Assigned(Result.PrevSibling) then + Result := Result.PrevSibling + else + begin + // If neither a last child nor a previous sibling exist, go the tree upwards and + // look, wether one of the parent nodes have a previous sibling. If not the result + // will ne nil. + repeat + Result := Result.Parent; + Run := nil; + if Result <> FRoot then + Run := Result.PrevSibling + else + Result := nil; + until Assigned(Run) or (Result = nil); + + if Assigned(Run) then + Result := Run; + end; + end + else + begin + // Is there a previous sibling? + if Assigned(Node.PrevSibling) then + begin + // Go down and find the last child node. + Result := GetLast(Node.PrevSibling); + if Result = nil then + Result := Node.PrevSibling; + end + else + // no previous sibling so the parent of the node is the previous visible node + if Node.Parent <> FRoot then + Result := Node.Parent + else + Result := nil; + end; + end; + + if Assigned(Result) and not (vsInitialized in Result.States) then + InitNode(Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetPreviousChecked(Node: PVirtualNode; State: TCheckState = csCheckedNormal; + ConsiderChildrenAbove: Boolean = False): PVirtualNode; + +begin + if (Node = nil) or (Node = FRoot) then + Result := GetLastNoInit(nil, ConsiderChildrenAbove) + else + Result := GetPreviousNoInit(Node, ConsiderChildrenAbove); + + while Assigned(Result) and (GetCheckState(Result) <> State) do + Result := GetPreviousNoInit(Result, ConsiderChildrenAbove); + + if Assigned(Result) and not (vsInitialized in Result.States) then + InitNode(Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetPreviousCutCopy(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode; + +// Returns the previous node in the tree which is currently marked for a clipboard operation. Since only visible nodes can +// be marked (or they are hidden after they have been marked) it is not necessary to initialize nodes to check for +// child nodes. The result, however, is initialized if necessary. + +begin + if ClipboardStates * FStates <> [] then + begin + if (Node = nil) or (Node = FRoot) then + Result := GetLastNoInit(nil, ConsiderChildrenAbove) + else + Result := GetPreviousNoInit(Node, ConsiderChildrenAbove); + while Assigned(Result) and not (vsCutOrCopy in Result.States) do + Result := GetPreviousNoInit(Result, ConsiderChildrenAbove); + if Assigned(Result) and not (vsInitialized in Result.States) then + InitNode(Result); + end + else + Result := nil; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetPreviousInitialized(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode; + +// Returns the previous node in tree which is initialized. + +begin + Result := Node; + repeat + Result := GetPreviousNoInit(Result, ConsiderChildrenAbove); + until (Result = nil) or (vsInitialized in Result.States); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetPreviousLeaf(Node: PVirtualNode): PVirtualNode; + +// Returns the previous node in the tree which has currently no children. +// The result is initialized if necessary. + +begin + if (Node = nil) or (Node = FRoot) then + Result := FRoot.LastChild + else + Result := GetPrevious(Node); + while Assigned(Result) and (vsHasChildren in Result.States) do + Result := GetPrevious(Result); + if Assigned(Result) and not (vsInitialized in Result.States) then + InitNode(Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetPreviousLevel(Node: PVirtualNode; NodeLevel: Cardinal): PVirtualNode; + +// Returns the previous node in the tree on a specific level. +// The result is initialized if necessary. + +var + StartNodeLevel: Cardinal; + Run: PVirtualNode; + +begin + Result := nil; + + if Assigned(Node) and (Node <> FRoot) then + begin + StartNodeLevel := GetNodeLevel(Node); + + if StartNodeLevel < NodeLevel then + begin + Result := Node.PrevSibling; + if Assigned(Result) then + begin + // go to last descendant of previous sibling with desired node level (if exists) + Run := Result; + while Assigned(Run) and (GetNodeLevel(Run) < NodeLevel) do + begin + Result := Run; + Run := GetLastChild(Run); + end; + if Assigned(Run) and (GetNodeLevel(Run) = NodeLevel) then + Result := Run + else + begin + if Assigned(Result.PrevSibling) then + Result := GetPreviousLevel(Result, NodeLevel) + else + if Assigned(Result) and (Result.Parent <> FRoot) then + Result := GetPreviousLevel(Result.Parent, NodeLevel) + else + Result := nil; + end; + end + else + Result := GetPreviousLevel(Node.Parent, NodeLevel); + end + else + if StartNodeLevel = NodeLevel then + begin + Result := Node.PrevSibling; + if not Assigned(Result) then // i.e. start node was a first sibling + begin + Result := Node.Parent; + if Assigned(Result) then + Result := GetPreviousLevel(Result, NodeLevel); + end; + end + else // i.e. StartNodeLevel > NodeLevel + Result := GetPreviousLevel(Node.Parent, NodeLevel); + end; + + if Assigned(Result) and not (vsInitialized in Result.States) then + InitNode(Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetPreviousNoInit(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode; + +// Returns previous node in tree, optionally considering toChildrenAbove. No initialization is performed. + +var + Run: PVirtualNode; + +begin + Result := Node; + if Assigned(Result) then + begin + Assert(Result <> FRoot, 'Node must not be the hidden root node.'); + + if ConsiderChildrenAbove and (toChildrenAbove in FOptions.PaintOptions) then + begin + // If there is a last child, take it; if not try the previous sibling. + if Assigned(Result.LastChild) then + Result := Result.LastChild + else + if Assigned(Result.PrevSibling) then + Result := Result.PrevSibling + else + begin + // If neither a last child nor a previous sibling exist, go the tree upwards and + // look, wether one of the parent nodes have a previous sibling. If not the result + // will ne nil. + repeat + Result := Result.Parent; + Run := nil; + if Result <> FRoot then + Run := Result.PrevSibling + else + Result := nil; + until Assigned(Run) or (Result = nil); + + if Assigned(Run) then + Result := Run; + end; + end + else + begin + // Is there a previous sibling? + if Assigned(Node.PrevSibling) then + begin + // Go down and find the last child node. + Result := GetLastNoInit(Node.PrevSibling); + if Result = nil then + Result := Node.PrevSibling; + end + else + // No previous sibling so the parent of the node is the previous node. + if Node.Parent <> FRoot then + Result := Node.Parent + else + Result := nil; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetPreviousSelected(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode; + +// Returns the previous node in the tree which is currently selected. Since children of unitialized nodes cannot be +// in the current selection (because they simply do not exist yet) it is not necessary to initialize nodes here. +// The result however is initialized if necessary. + +begin + if FSelectionCount > 0 then + begin + if (Node = nil) or (Node = FRoot) then + Result := GetLastNoInit(nil, ConsiderChildrenAbove) + else + Result := GetPreviousNoInit(Node, ConsiderChildrenAbove); + while Assigned(Result) and not (vsSelected in Result.States) do + Result := GetPreviousNoInit(Result, ConsiderChildrenAbove); + if Assigned(Result) and not (vsInitialized in Result.States) then + InitNode(Result); + end + else + Result := nil; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetPreviousSibling(Node: PVirtualNode): PVirtualNode; + +// Returns the previous sibling of Node and initializes it if necessary. + +begin + Result := Node; + if Assigned(Result) then + begin + Assert(Result <> FRoot, 'Node must not be the hidden root node.'); + + Result := Result.PrevSibling; + if Assigned(Result) and not (vsInitialized in Result.States) then + InitNode(Result); + end; +end; + +function TBaseVirtualTree.GetPreviousSiblingNoInit(Node: PVirtualNode): PVirtualNode; + +// Returns the previous sibling of Node + +begin + Result := Node; + if Assigned(Result) then + begin + Assert(Result <> FRoot, 'Node must not be the hidden root node.'); + + Result := Result.PrevSibling; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetPreviousVisible(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = True): PVirtualNode; + +// Returns the previous node in tree, with regard to Node, which is visible. +// Nodes which need an initialization (including the result) are initialized. +// toChildrenAbove is optionally considered which is the default here. + +var + TopInvisibleParent: PVirtualNode; + ForceSearch: Boolean; + +begin + Result := Node; + if not Assigned(Result) then Exit; + + Assert(Result <> FRoot, 'Node must not be the hidden root node.'); + + repeat + // If any ancestor is invisible, then find the last (furthest) parent node + // which is invisible to skip invisible subtrees. Otherwise we will + // likely go unnecessarily through a whole bunch of invisible nodes. + TopInvisibleParent := GetTopInvisibleParent(Result); + if Assigned(TopInvisibleParent) then + Result := TopInvisibleParent; + + if ConsiderChildrenAbove and (toChildrenAbove in FOptions.PaintOptions) then + begin + ForceSearch := True; + // If we found an invisible ancestor, we must not check its children. + // Remember, that TopInvisibleParent can be effectively invisible merely due to + // its own parent's expansion state despite being visible itself. + if Result <> TopInvisibleParent then + begin + if not (vsInitialized in Result.States) then + InitNode(Result); + + if (vsVisible in Result.States) and (vsExpanded in Result.States) then + begin + // Initialiue the node's children if necessary. + if (vsHasChildren in Result.States) and (Result.ChildCount = 0) then + InitChildren(Result); + + // Child nodes are the first choice if the current node is known to be visible. + if Assigned(Result.LastChild) then + begin + Result := Result.LastChild; + if not (vsInitialized in Result.States) then + InitNode(Result); + ForceSearch := False; + end; + end; + end; + + if ForceSearch or not (vsVisible in Result.States) then + begin + repeat + // Is there a previous sibling? + if Assigned(Result.PrevSibling) then + begin + Result := Result.PrevSibling; + if not (vsInitialized in Result.States) then + InitNode(Result); + if vsVisible in Result.States then + Break; + end + // No sibling anymore, so use the parent's previous sibling. + else if Result.Parent <> FRoot then + Result := Result.Parent + // There are no further nodes to examine, hence there is no further visible node. + else + begin + Result := nil; + Break; + end; + until False; + end; + end + else + begin + repeat + // If there are no sibling anymore, go up one level. + if not Assigned(Result.PrevSibling) then + begin + Result := Result.Parent; + if Result = FRoot then + begin + Result := nil; + Break; + end; + if not (vsInitialized in Result.States) then + InitNode(Result); + end else + begin + Result := Result.PrevSibling; + if not (vsInitialized in Result.States) then + InitNode(Result); + if not (vsVisible in Result.States) then + Continue; + + // Now take a look at the children. As the children are initialized + // while toggling, we don't need to call 'InitChildren' beforehand here. + while (vsExpanded in Result.States) and Assigned(Result.LastChild) do + begin + Result := Result.LastChild; + if not (vsInitialized in Result.States) then + InitNode(Result); + if not (vsVisible in Result.States) then + Break; + end; + end; + + // If we found a visible node we don't need to search any longer. + if vsVisible in Result.States then + Break; + until False; + end; + + if Assigned(Result) and not (vsInitialized in Result.States) then + InitNode(Result); + until not Assigned(Result) or IsEffectivelyVisible[Result]; + + Assert(Result <> Node, 'Node cannot be its own visible predecessor.'); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetPreviousVisibleNoInit(Node: PVirtualNode; + ConsiderChildrenAbove: Boolean = True): PVirtualNode; + +// Returns the previous node in tree, with regard to Node, which is visible. +// No initialization is done. +// toChildrenAbove is optionally considered which is the default here. + +var + TopInvisibleParent: PVirtualNode; + ForceSearch: Boolean; + +begin + Result := Node; + if not Assigned(Result) then Exit; + + Assert(Result <> FRoot, 'Node must not be the hidden root node.'); + + repeat + // If any ancestor is invisible, then find the last (furthest) parent node + // which is invisible to skip invisible subtrees. Otherwise we will + // likely go unnecessarily through a whole bunch of invisible nodes. + TopInvisibleParent := GetTopInvisibleParent(Result); + if Assigned(TopInvisibleParent) then + Result := TopInvisibleParent; + + if ConsiderChildrenAbove and (toChildrenAbove in FOptions.PaintOptions) then + begin + // Child nodes are the first choice if the current node is known to be visible. + // Remember, that TopInvisibleParent can be effectively invisible merely due to + // its own parent's expansion state despite being visible itself. + if (vsVisible in Result.States) and (vsExpanded in Result.States) and + (Result <> TopInvisibleParent) and Assigned(Result.LastChild) then + begin + Result := Result.LastChild; + ForceSearch := False; + end else + ForceSearch := True; + + if ForceSearch or not (vsVisible in Result.States) then + begin + repeat + // Is there a previous sibling? + if Assigned(Result.PrevSibling) then + begin + Result := Result.PrevSibling; + if vsVisible in Result.States then + Break; + end + // No sibling anymore, so use the parent's previous sibling. + else if Result.Parent <> FRoot then + Result := Result.Parent + // There are no further nodes to examine, hence there is no further visible node. + else + begin + Result := nil; + Break; + end; + until False; + end; + end + else + begin + repeat + // If there are no siblings anymore, go up one level. + if not Assigned(Result.PrevSibling) then + begin + Result := Result.Parent; + if Result = FRoot then + begin + Result := nil; + Break; + end; + end + else + begin + // There is at least one sibling so take it. + Result := Result.PrevSibling; + if not (vsVisible in Result.States) then + Continue; + + // Now take a look at the children. + while (vsExpanded in Result.States) and Assigned(Result.LastChild) do + begin + Result := Result.LastChild; + if not (vsVisible in Result.States) then + Break; + end; + end; + + // If we found a visible node we don't need to search any longer. + if vsVisible in Result.States then + Break; + until False; + end; + until not Assigned(Result) or IsEffectivelyVisible[Result]; + + Assert(Result <> Node, 'Node cannot be its own visible predecessor.'); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetPreviousVisibleSibling(Node: PVirtualNode; IncludeFiltered: Boolean = False): PVirtualNode; + +// Returns the previous visible sibling before Node. Initialization is done implicitly. + +begin + Assert(Assigned(Node) and (Node <> FRoot), 'Invalid parameter.'); + + Result := Node; + repeat + Result := GetPreviousSibling(Result); + until not Assigned(Result) or ((vsVisible in Result.States) and + (IncludeFiltered or not IsEffectivelyFiltered[Result])); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetPreviousVisibleSiblingNoInit(Node: PVirtualNode; + IncludeFiltered: Boolean = False): PVirtualNode; + +// Returns the previous visible sibling before Node. + +begin + Assert(Assigned(Node) and (Node <> FRoot), 'Invalid parameter.'); + + Result := Node; + repeat + Result := Result.PrevSibling; + until not Assigned(Result) or ((vsVisible in Result.States) and + (IncludeFiltered or not IsEffectivelyFiltered[Result])); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.Nodes(ConsiderChildrenAbove: Boolean): TVTVirtualNodeEnumeration; + +// Enumeration for all nodes + +begin + Result.FMode := vneAll; + Result.FTree := Self; + Result.FConsiderChildrenAbove := ConsiderChildrenAbove; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.CheckedNodes(State: TCheckState; ConsiderChildrenAbove: Boolean): TVTVirtualNodeEnumeration; + +// Enumeration for all checked nodes + +begin + Result.FMode := vneChecked; + Result.FTree := Self; + Result.FState := State; + Result.FConsiderChildrenAbove := ConsiderChildrenAbove; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.ChildNodes(Node: PVirtualNode): TVTVirtualNodeEnumeration; + +// Enumeration for child nodes + +begin + Result.FMode := vneChild; + Result.FTree := Self; + Result.FNode := Node; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.CutCopyNodes(ConsiderChildrenAbove: Boolean): TVTVirtualNodeEnumeration; + +// Enumeration for cut copy node + +begin + Result.FMode := vneCutCopy; + Result.FTree := Self; + Result.FConsiderChildrenAbove := ConsiderChildrenAbove; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.CutToClipboard; +begin + if (toReadOnly in TreeOptions.MiscOptions) then + exit; + inherited; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.InitializedNodes(ConsiderChildrenAbove: Boolean): TVTVirtualNodeEnumeration; + +// Enumeration for initialized nodes + +begin + Result.FMode := vneInitialized; + Result.FTree := Self; + Result.FConsiderChildrenAbove := ConsiderChildrenAbove; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.LeafNodes: TVTVirtualNodeEnumeration; + +// Enumeration for leaf nodes + +begin + Result.FMode := vneLeaf; + Result.FTree := Self; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.LevelNodes(NodeLevel: Cardinal): TVTVirtualNodeEnumeration; + +// Enumeration for level nodes + +begin + Result.FMode := vneLevel; + Result.FTree := Self; + Result.FNodeLevel := NodeLevel; +end; + +function TBaseVirtualTree.LineWidth: TDimension; +// Returns the width in pixels that should be used to draw grid lines, see issue #1203 +begin + // Always use line width of 1 for older Delphi versions. + {$if CompilerVersion < 31} + Exit(1); + {$else} + if FCurrentPPI < 200 then + Exit(1) // Always use 1 pixel is scaled <=200% + else + Exit(MulDiv(1, Self.FCurrentPPI, 132)); // Use 132 dpi instead of the typical 96 so that line width increase slightly slower than the actual scaling, so we have a 3px line at 400% + {$ifend} +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.NoInitNodes(ConsiderChildrenAbove: Boolean): TVTVirtualNodeEnumeration; + +// Enumeration for no init nodes +begin + Result.FMode := vneNoInit; + Result.FTree := Self; + Result.FConsiderChildrenAbove := ConsiderChildrenAbove; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.SelectedNodes(ConsiderChildrenAbove: Boolean): TVTVirtualNodeEnumeration; + +// Enumeration for selected nodes + +begin + Result.FMode := vneSelected; + Result.FTree := Self; + Result.FConsiderChildrenAbove := ConsiderChildrenAbove; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.VisibleNodes(Node: PVirtualNode; ConsiderChildrenAbove: Boolean; + IncludeFiltered: Boolean): TVTVirtualNodeEnumeration; + +// Enumeration for visible nodes + +begin + Result.FMode := vneVisible; + Result.FTree := Self; + Result.FNode := Node; + Result.FConsiderChildrenAbove := ConsiderChildrenAbove; + Result.FIncludeFiltered := IncludeFiltered; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.VisibleChildNodes(Node: PVirtualNode; IncludeFiltered: Boolean): TVTVirtualNodeEnumeration; + +// Enumeration for visible child nodes + +begin + Result.FMode := vneVisibleChild; + Result.FTree := Self; + Result.FNode := Node; + Result.FIncludeFiltered := IncludeFiltered; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.VisibleChildNoInitNodes(Node: PVirtualNode; IncludeFiltered: Boolean): TVTVirtualNodeEnumeration; + +// Enumeration for visible child no init nodes + +begin + Result.FMode := vneVisibleNoInitChild; + Result.FTree := Self; + Result.FNode := Node; + Result.FIncludeFiltered := IncludeFiltered; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.VisibleNoInitNodes(Node: PVirtualNode; ConsiderChildrenAbove: Boolean; + IncludeFiltered: Boolean): TVTVirtualNodeEnumeration; + +// Enumeration for visible no init nodes + +begin + Result.FMode := vneVisibleNoInit; + Result.FTree := Self; + Result.FNode := Node; + Result.FConsiderChildrenAbove := ConsiderChildrenAbove; + Result.FIncludeFiltered := IncludeFiltered; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetSortedCutCopySet(Resolve: Boolean): TNodeArray; + +// Same as GetSortedSelection but with nodes marked as being part in the current cut/copy set (e.g. for clipboard). + +var + Run: PVirtualNode; + Counter: Cardinal; + + //--------------- local function -------------------------------------------- + + procedure IncludeThisNode(Node: PVirtualNode); + + // adds the given node to the result + + var + Len: Cardinal; + + begin + Len := Length(Result); + if Counter = Len then + begin + if Len < 100 then + Len := 100 + else + Len := Len + Len div 10; + SetLength(Result, Len); + end; + Result[Counter] := Node; + System.Inc(Counter); + end; + + //--------------- end local function ---------------------------------------- + +begin + Run := FRoot.FirstChild; + Counter := 0; + if Resolve then + begin + // Resolving is actually easy: just find the first cutted node in logical order + // and then never go deeper in level than this node as long as there's a sibling node. + // Restart the search for a cutted node (at any level) if there are no further siblings. + while Assigned(Run) do + begin + if vsCutOrCopy in Run.States then + begin + IncludeThisNode(Run); + if Assigned(Run.NextSibling) then + Run := Run.NextSibling + else + begin + // If there are no further siblings then go up one or more levels until a node is + // found or all nodes have been processed. Although we consider here only initialized + // nodes we don't need to make any special checks as only initialized nodes can also be selected. + repeat + Run := Run.Parent; + until (Run = FRoot) or Assigned(Run.NextSibling); + if Run = FRoot then + Break + else + Run := Run.NextSibling; + end; + end + else + Run := GetNextNoInit(Run); + end; + end + else + while Assigned(Run) do + begin + if vsCutOrCopy in Run.States then + IncludeThisNode(Run); + Run := GetNextNoInit(Run); + end; + + // set the resulting array to its real length + SetLength(Result, Counter); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetSortedSelection(Resolve: Boolean): TNodeArray; + +// Returns a list of selected nodes sorted in logical order, that is, as they appear in the tree. +// If Resolve is True then nodes which are children of other selected nodes are not put into the new array. +// This feature is in particuar important when doing drag'n drop as in this case all selected node plus their children +// need to be considered. A selected node which is child (grand child etc.) of another selected node is then +// automatically included and doesn't need to be explicitely mentioned in the returned selection array. +// +// Note: The caller is responsible for freeing the array. Allocation is done here. Usually, though, freeing the array +// doesn't need additional attention as it is automatically freed by Delphi when it gets out of scope. + +var + Run: PVirtualNode; + Counter: Cardinal; + +begin + SetLength(Result, FSelectionCount); + if FSelectionCount > 0 then + begin + Run := FRoot.FirstChild; + Counter := 0; + if Resolve then + begin + // Resolving is actually easy: just find the first selected node in logical order + // and then never go deeper in level than this node as long as there's a sibling node. + // Restart the search for a selected node (at any level) if there are no further siblings. + while Assigned(Run) do + begin + if vsSelected in Run.States then + begin + Result[Counter] := Run; + System.Inc(Counter); + if Assigned(Run.NextSibling) then + Run := Run.NextSibling + else + begin + // If there are no further siblings then go up one or more levels until a node is + // found or all nodes have been processed. Although we consider here only initialized + // nodes we don't need to make any special checks as only initialized nodes can also be selected. + repeat + Run := Run.Parent; + until (Run = FRoot) or Assigned(Run.NextSibling); + if Run = FRoot then + Break + else + Run := Run.NextSibling; + end; + end + else + Run := GetNextNoInit(Run); + end; + end + else + while Assigned(Run) do + begin + if vsSelected in Run.States then + begin + Result[Counter] := Run; + System.Inc(Counter); + end; + Run := GetNextNoInit(Run); + end; + + // Since we may have skipped some nodes the result array is likely to be smaller than the + // selection array, hence shorten the result to true length. + if Integer(Counter) < Length(Result) then + SetLength(Result, Counter); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.GetTextInfo(Node: PVirtualNode; Column: TColumnIndex; const AFont: TFont; var R: TRect; + var Text: string); + +// Generic base method for editors, hint windows etc. to get some info about a node. + +begin + R := Rect(0, 0, 0, 0); + Text := ''; + if Assigned(Font) then // 1 EConvertError due to Font being nil seen here in 01/2019, See issue #878 + AFont.Assign(Font); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetTreeRect: TRect; + +// Returns the true size of the tree in pixels. This size is at least ClientHeight x ClientWidth and depends on +// the expand state, header size etc. +// Note: if no columns are used then the width of the tree is determined by the largest node which is currently in the +// client area. This might however not be the largest node in the entire tree. + +begin + Result := Rect(0, 0, Max(FRangeX, ClientWidth), Max(FRangeY, ClientHeight)); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetVisibleParent(Node: PVirtualNode; IncludeFiltered: Boolean = False): PVirtualNode; + +// Returns the first (nearest) parent node of Node which is visible. +// This method is one of the seldom cases where the hidden root node could be returned. + +begin + Assert(Assigned(Node), 'Node must not be nil.'); + Assert(Node <> FRoot, 'Node must not be the hidden root node.'); + + Result := Node.Parent; + while (Result <> FRoot) and (not FullyVisible[Result] or (not IncludeFiltered and IsEffectivelyFiltered[Result])) do + Result := Result.Parent; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetTopInvisibleParent(Node: PVirtualNode): PVirtualNode; + +// Returns the last (furthest) parent node of Node which is invisible. + +var + Run: PVirtualNode; + +begin + Assert(Assigned(Node), 'Node must not be nil.'); + Assert(Node <> FRoot, 'Node must not be the hidden root node.'); + + Result := nil; + + Run := Node.Parent; + while (Run <> FRoot) do + begin + if not ( (vsVisible in Run.States) and (vsExpanded in Run.Parent.States) ) then + Result := Run; + Run := Run.Parent; + end; + +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.HasAsParent(Node, PotentialParent: PVirtualNode): Boolean; + +// Determines whether Node has got PotentialParent as one of its parents. + +var + Run: PVirtualNode; + +begin + Result := Assigned(Node) and Assigned(PotentialParent) and (Node <> PotentialParent); + if Result then + begin + Run := Node; + while (Run <> FRoot) and (Run <> PotentialParent) do + Run := Run.Parent; + Result := Run = PotentialParent; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.InsertNode(Node: PVirtualNode; Mode: TVTNodeAttachMode; UserData: Pointer = nil): PVirtualNode; + +// Adds a new node relative to Node. The final position is determined by Mode. +// UserData can be used to set the first SizeOf(Pointer) bytes of the user data area to an initial value which can be used +// in OnInitNode and will also cause to trigger the OnFreeNode event (if <> nil) even if the node is not yet +// "officially" initialized. +// InsertNode is a compatibility method and will implicitly validate the given node if the new node +// is to be added as child node. This is however against the virtual paradigm and hence I dissuade from its usage. + +begin + if Mode <> amNoWhere then + begin + CancelEditNode; + + if Node = nil then + Node := FRoot; + // we need a new node... + Result := MakeNewNode; + // avoid erronous attach modes + if Node = FRoot then + begin + case Mode of + amInsertBefore: + Mode := amAddChildFirst; + amInsertAfter: + Mode := amAddChildLast; + end; + end; + + // Validate given node in case the new node becomes its child. + if (Mode in [amAddChildFirst, amAddChildLast]) and not (vsInitialized in Node.States) then + InitNode(Node); + InternalConnectNode(Result, Node, Self, Mode); + + // Check if there is initial user data and there is also enough user data space allocated. + if Assigned(UserData) then + SetNodeData(Result, UserData); + + if FUpdateCount = 0 then + begin + case Mode of + amInsertBefore, + amInsertAfter: + begin + // Here no initialization is necessary because *if* a node has already got children then it + // must also be initialized. + // Note: Node can never be FRoot at this point. + StructureChange(Result, crNodeAdded); + // If auto sort is enabled then sort the node or its parent (depending on the insert mode). + if (toAutoSort in FOptions.AutoOptions) and (FHeader.SortColumn > InvalidColumn) then + Sort(Node.Parent, FHeader.SortColumn, FHeader.SortDirection, True); + InvalidateToBottom(Result) + end; + amAddChildFirst, + amAddChildLast: + begin + StructureChange(Node, crChildAdded); + // If auto sort is enabled then sort the node or its parent (depending on the insert mode). + if (toAutoSort in FOptions.AutoOptions) and (FHeader.SortColumn > InvalidColumn) then + Sort(Node, FHeader.SortColumn, FHeader.SortDirection, True); + InvalidateToBottom(Node); + end; + end; + InvalidateCache(); + UpdateScrollBars(True); + end; + end + else + Result := nil; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.InvalidateChildren(Node: PVirtualNode; Recursive: Boolean); + +// Invalidates Node and its immediate children. +// If Recursive is True then all grandchildren are invalidated as well. +// The node itself is initialized if necessary and its child nodes are created (and initialized too if +// Recursive is True). + +var + Run: PVirtualNode; + +begin + if Assigned(Node) then + begin + if not (vsInitialized in Node.States) then + InitNode(Node); + InvalidateNode(Node); + if (vsHasChildren in Node.States) and (Node.ChildCount = 0) then + InitChildren(Node); + Run := Node.FirstChild; + end + else + Run := FRoot.FirstChild; + + while Assigned(Run) do + begin + InvalidateNode(Run); + if Recursive then + InvalidateChildren(Run, True); + Run := Run.NextSibling; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.InvalidateColumn(Column: TColumnIndex); + +// Invalidates the client area part of a column. + +var + R: TRect; + +begin + if (FUpdateCount = 0) and HandleAllocated and FHeader.Columns.IsValidColumn(Column) then + begin + R := ClientRect; + FHeader.Columns.GetColumnBounds(Column, R.Left, R.Right); + InvalidateRect(@R, False); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.InvalidateNode(Node: PVirtualNode): TRect; + +// Initiates repaint of the given node and returns the just invalidated rectangle. + +begin + Assert(Assigned(Node), 'Node must not be nil.'); + Assert(GetCurrentThreadId = MainThreadId, 'UI controls may only be chnaged in UI thread.'); + // Reset height measured flag too to cause a re-issue of the OnMeasureItem event. + Exclude(Node.States, vsHeightMeasured); + if (FUpdateCount = 0) and HandleAllocated then + begin + Result := GetDisplayRect(Node, NoColumn, False); + InvalidateRect(@Result, False); + end + else + result := Rect(-1,-1,-1,-1); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.InvalidateToBottom(Node: PVirtualNode); + +// Initiates repaint of client area starting at given node. If this node is not visible or not yet initialized +// then nothing happens. + +var + R: TRect; + +begin + if (FUpdateCount = 0) and HandleAllocated then + begin + if (Node = nil) or (Node = FRoot) then + Invalidate + else + if (vsInitialized in Node.States) and IsEffectivelyVisible[Node] then + begin + R := GetDisplayRect(Node, NoColumn, False); + if R.Top < ClientHeight then + begin + if (toChildrenAbove in FOptions.PaintOptions) and (vsExpanded in Node.States) then + Dec(R.Top, Node.TotalHeight + NodeHeight[Node]); + R.Bottom := ClientHeight; + InvalidateRect(@R, False); + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.InvertSelection(VisibleOnly: Boolean); + +// Inverts the current selection (so nodes which are selected become unselected and vice versa). +// If VisibleOnly is True then only visible nodes are considered. + +var + Run: PVirtualNode; + NewSize: Integer; + NextFunction: TGetNextNodeProc; + TriggerChange: Boolean; + +begin + if not FSelectionLocked and (toMultiSelect in FOptions.SelectionOptions) then + begin + Run := FRoot.FirstChild; + ClearTempCache; + if VisibleOnly then + NextFunction := GetNextVisibleNoInit + else + NextFunction := GetNextNoInit; + while Assigned(Run) do + begin + if vsSelected in Run.States then + InternalRemoveFromSelection(Run) + else + InternalCacheNode(Run); + Run := NextFunction(Run); + end; + + // do some housekeeping + // Need to trigger the OnChange event from here if nodes were only deleted but not added. + TriggerChange := False; + NewSize := PackArray(FSelection, FSelectionCount); + if NewSize > -1 then + begin + FSelectionCount := NewSize; + SetLength(FSelection, FSelectionCount); + TriggerChange := True; + end; + if FTempNodeCount > 0 then + begin + AddToSelection(FTempNodeCache, FTempNodeCount); + ClearTempCache; + TriggerChange := False; + end; + Invalidate; + if TriggerChange then + Change(nil); + if Self.SelectedCount = 0 then + FNextNodeToSelect := nil;//Ensure that no other node is selected now + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.IsEditing: Boolean; + +begin + Result := tsEditing in FStates; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.IsMouseSelecting: Boolean; + +begin + Result := (tsDrawSelPending in FStates) or (tsDrawSelecting in FStates); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.IsStored_BackgroundOffsetXY(const Index: Integer): Boolean; +begin + case Index of + 0: + Result:= CompareValue(FBackgroundOffsetX, 0)<>EqualsValue; + 1: + Result:= CompareValue(FBackgroundOffsetY, 0)<>EqualsValue; + else + // Clear warning only + Result:= false; + RaiseVTError('Unknown index in TBaseVirtualTree.IsStored_BackgroundOffsetXY', 0); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.IsStored_BottomSpace: Boolean; +begin + Result:= CompareValue(FBottomSpace, 0)<>EqualsValue; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.IsStored_DefaultNodeHeight: Boolean; +begin + Result:= CompareValue(FDefaultNodeHeight, cInitialDefaultNodeHeight)<>EqualsValue; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.IsStored_Indent: Boolean; +begin + Result:= CompareValue(FIndent, 18)<>EqualsValue; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.IsStored_Margin: Boolean; +begin + Result:= CompareValue(FMargin, 4)<>EqualsValue; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.IsStored_TextMargin: Boolean; +begin + Result:= CompareValue(FTextMargin, cDefaultTextMargin) <> EqualsValue; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.IsUpdating: Boolean; +// The tree does currently not update its window because a BeginUpdate has not yet ended. +begin + Exit(UpdateCount > 0); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.IterateSubtree(StartNode: PVirtualNode; Callback: TVTGetNodeProc; Data: Pointer; + Filter: TVirtualNodeStates = []; DoInit: Boolean = False; ChildNodesOnly: Boolean = False): PVirtualNode; + +// Iterates through the all children and grandchildren etc. of Node (or the entire tree if Node = nil) +// and calls for each node the provided callback method (which must not be empty). +// Filter determines which nodes to consider (an empty set denotes all nodes). +// If DoInit is True then nodes which aren't initialized yet will be initialized. +// Note: During execution of the callback the application can set Abort to True. In this case the iteration is stopped +// and the last accessed node (the one on which the callback set Abort to True) is returned to the caller. +// Otherwise (no abort) nil is returned. + +var + Stop: PVirtualNode; + Abort: Boolean; + GetNextNode: TGetNextNodeProc; + WasIterating: Boolean; + +begin + Assert(StartNode <> FRoot, 'Node must not be the hidden root node.'); + + WasIterating := tsIterating in FStates; + DoStateChange([tsIterating]); + try + // prepare function to be used when advancing + if DoInit then + GetNextNode := GetNext + else + GetNextNode := GetNextNoInit; + + Abort := False; + Result := StartNode; + if Result = nil then + Stop := nil + else + begin + if not (vsInitialized in Result.States) and DoInit then + InitNode(Result); + + // The stopper does not need to be initialized since it is not taken into the enumeration. + Stop := Result.NextSibling; + if Stop = nil then + begin + Stop := Result; + repeat + Stop := Stop.Parent; + until (Stop = FRoot) or Assigned(Stop.NextSibling); + if Stop = FRoot then + Stop := nil + else + Stop := Stop.NextSibling; + end; + end; + + // Use first node if we start with the root. + if Result = nil then + Result := GetFirstNoInit; + + if Assigned(Result) then + begin + if not (vsInitialized in Result.States) and DoInit then + InitNode(Result); + + // Skip given node if only the child nodes are requested. + if ChildNodesOnly then + begin + if Result.ChildCount = 0 then + Result := nil + else if StartNode <> nil then + Result := GetNextNode(Result); + end; + + if Filter = [] then + begin + // unfiltered loop + while Assigned(Result) and (Result <> Stop) do + begin + Callback(Self, Result, Data, Abort); + if Abort then + Break; + Result := GetNextNode(Result); + end; + end + else + begin + // filtered loop + while Assigned(Result) and (Result <> Stop) do + begin + if Result.States * Filter = Filter then + Callback(Self, Result, Data, Abort); + if Abort then + Break; + Result := GetNextNode(Result); + end; + end; + end; + + if not Abort then + Result := nil; + finally + if not WasIterating then + DoStateChange([], [tsIterating]); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.LoadFromFile(const FileName: TFileName); + +var + FileStream: TFileStream; + +begin + FileStream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); + try + LoadFromStream(FileStream); + finally + FileStream.Free; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.LoadFromStream(Stream: TStream); + +// Clears the current content of the tree and loads a new structure from the given stream. + +var + ThisID: TMagicID; + Version, + Count: Cardinal; + Node: PVirtualNode; + +begin + if not (toReadOnly in FOptions.MiscOptions) then + begin + Clear; + // Check first whether this is a stream we can read. + if Stream.Read(ThisID, SizeOf(TMagicID)) < SizeOf(TMagicID) then + RaiseVTError(SStreamTooSmall, hcTFStreamTooSmall); + + if (ThisID[0] = MagicID[0]) and + (ThisID[1] = MagicID[1]) and + (ThisID[2] = MagicID[2]) and + (ThisID[5] = MagicID[5]) then + begin + Version := Word(ThisID[3]); + if Version <= VTTreeStreamVersion then + begin + BeginUpdate; + try + if Version < 2 then + Count := MaxInt + else + Stream.ReadBuffer(Count, SizeOf(Count)); + + while (Stream.Position < Stream.Size) and (Count > 0) do + begin + System.Dec(Count); + Node := MakeNewNode; + InternalConnectNode(Node, FRoot, Self, amAddChildLast); + InternalAddFromStream(Stream, Version, Node); + end; + DoNodeCopied(nil); + if Assigned(FOnLoadTree) then + FOnLoadTree(Self, Stream); + finally + EndUpdate; + end; + end + else + RaiseVTError(SWrongStreamVersion, hcTFWrongStreamVersion); + end + else + RaiseVTError(SWrongStreamFormat, hcTFWrongStreamFormat); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.MeasureItemHeight(const Canvas: TCanvas; Node: PVirtualNode); + +// If the height of the given node has not yet been measured then do it now. + +var + NewNodeHeight: TDimension; + +begin + if not (vsHeightMeasured in Node.States) then + begin + Include(Node.States, vsHeightMeasured); + if (toVariableNodeHeight in FOptions.MiscOptions) then + begin + NewNodeHeight := Node.NodeHeight; + // Anonymous methods help to make this thread safe easily. + if (MainThreadId <> GetCurrentThreadId) then + begin + AtomicIncrement(FPendingSyncProcs); + TThread.Synchronize(nil, + procedure + begin + //swish:Decrement invoke refs + AtomicDecrement(FPendingSyncProcs); + DoMeasureItem(Canvas, Node, NewNodeHeight); + SetNodeHeight(Node, NewNodeHeight); + end + ) + end + else + begin + DoMeasureItem(Canvas, Node, NewNodeHeight); + SetNodeHeight(Node, NewNodeHeight); + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.MoveTo(Node: PVirtualNode; Tree: TBaseVirtualTree; Mode: TVTNodeAttachMode; + ChildrenOnly: Boolean); + +// A simplified method to allow to move nodes to the root of another tree. + +begin + MoveTo(Node, Tree.FRoot, Mode, ChildrenOnly); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.MoveTo(Source, Target: PVirtualNode; Mode: TVTNodeAttachMode; ChildrenOnly: Boolean); + +// Moves the given node (and all its children) to Target. Source must belong to the tree instance which calls this +// MoveTo method. Mode determines how to connect Source to Target. +// This method might involve a change of the tree if Target belongs to a different tree than Source. + +var + TargetTree: TBaseVirtualTree; + Allowed: Boolean; + NewNode: PVirtualNode; + Stream: TMemoryStream; + +begin + Assert(TreeFromNode(Source) = Self, 'The source tree must contain the source node.'); + + // When moving nodes then source and target must not be the same node unless only the source's children are + // moved and they are inserted before or after the node itself. + Allowed := (Source <> Target) or ((Mode in [amInsertBefore, amInsertAfter]) and ChildrenOnly); + + if Allowed and (Mode <> amNoWhere) and Assigned(Source) and (Source <> FRoot) and + not (toReadOnly in FOptions.MiscOptions) then + begin + // Assume that an empty destination means the root in this (the source) tree. + if Target = nil then + begin + TargetTree := Self; + Target := FRoot; + Mode := amAddChildFirst; + end + else + TargetTree := TreeFromNode(Target); + + if Target = TargetTree.FRoot then + begin + case Mode of + amInsertBefore: + Mode := amAddChildFirst; + amInsertAfter: + Mode := amAddChildLast; + end; + end; + + // Make sure the target node is initialized. + if not (vsInitialized in Target.States) then + TargetTree.InitNode(Target) + else + if (vsHasChildren in Target.States) and (Target.ChildCount = 0) then + TargetTree.InitChildren(Target); + + if TargetTree = Self then + begin + // Simple case: move node(s) within the same tree. + if Target = FRoot then + Allowed := DoNodeMoving(Source, nil) + else + Allowed := DoNodeMoving(Source, Target); + if Allowed then + begin + // Check first that Source is not added as new child to a target node which + // is already a child of Source. + // Consider the case Source and Target are the same node, but only child nodes are moved. + if (Source <> Target) and HasAsParent(Target, Source) then + RaiseVTError(SWrongMoveError, hcTFWrongMoveError); + + if not ChildrenOnly then + begin + // Disconnect from old location. + InternalDisconnectNode(Source, True); + // Connect to new location. + InternalConnectNode(Source, Target, Self, Mode); + DoNodeMoved(Source); + end + else + begin + // Only child nodes should be moved. Insertion order depends on move mode. + if Mode = amAddChildFirst then + begin + Source := Source.LastChild; + while Assigned(Source) do + begin + NewNode := Source.PrevSibling; + // Disconnect from old location. + InternalDisconnectNode(Source, True, False); + // Connect to new location. + InternalConnectNode(Source, Target, Self, Mode); + DoNodeMoved(Source); + Source := NewNode; + end; + end + else + begin + Source := Source.FirstChild; + while Assigned(Source) do + begin + NewNode := Source.NextSibling; + // Disconnect from old location. + InternalDisconnectNode(Source, True, False); + // Connect to new location. + InternalConnectNode(Source, Target, Self, Mode); + DoNodeMoved(Source); + Source := NewNode; + end; + end; + end; + end; + end + else + begin + // Difficult case: move node(s) to another tree. + // In opposition to node copying we ask only once if moving is allowed because + // we cannot take back a move once done. + if Target = TargetTree.FRoot then + Allowed := DoNodeMoving(Source, nil) + else + Allowed := DoNodeMoving(Source, Target); + + if Allowed then + begin + Stream := TMemoryStream.Create; + try + // Write all nodes into a temporary stream depending on the ChildrenOnly flag. + if not ChildrenOnly then + WriteNode(Stream, Source) + else + begin + Source := Source.FirstChild; + while Assigned(Source) do + begin + WriteNode(Stream, Source); + Source := Source.NextSibling; + end; + end; + // Now load the serialized nodes into the target node (tree). + TargetTree.BeginUpdate; + try + Stream.Position := 0; + while Stream.Position < Stream.Size do + begin + NewNode := TargetTree.MakeNewNode; + InternalConnectNode(NewNode, Target, TargetTree, Mode); + TargetTree.InternalAddFromStream(Stream, VTTreeStreamVersion, NewNode); + DoNodeMoved(NewNode); + end; + finally + TargetTree.EndUpdate; + end; + finally + Stream.Free; + end; + // finally delete original nodes + BeginUpdate; + try + if ChildrenOnly then + DeleteChildren(Source) + else + DeleteNode(Source); + finally + EndUpdate; + end; + end; + end; + + InvalidateCache; + if (FUpdateCount = 0) and Allowed then + begin + ValidateCache; + UpdateScrollBars(True); + Invalidate; + if TargetTree <> Self then + TargetTree.Invalidate; + end; + StructureChange(Source, crNodeMoved); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.PaintTree(TargetCanvas: TCanvas; Window: TRect; Target: TPoint; + PaintOptions: TVTInternalPaintOptions; PixelFormat: TPixelFormat); + +// This is the core paint routine of the tree. It is responsible for maintaining the paint cycles per node as well +// as coordinating drawing of the various parts of the tree image. +// TargetCanvas is the canvas to which to draw the tree image. This is usually the tree window itself but could well +// be a bitmap or printer canvas. +// Window determines which part of the entire tree image to draw. The full size of the virtual image is determined +// by GetTreeRect. +// Target is the position in TargetCanvas where to draw the tree part specified by Window. +// PaintOptions determines what of the tree to draw. For different tasks usually different parts need to be drawn, with +// a full image in the window, selected only nodes for a drag image etc. + +const + ImageKind: array[Boolean] of TVTImageKind = (ikNormal, ikSelected); + +var + DrawSelectionRect, + UseBackground, + ShowCheckImages, + UseColumns, + IsMainColumn: Boolean; + + IndentSize, + ButtonY: TDimension; // Y position of toggle button within the node's rect + LineImage: TLineImage; + PaintInfo: TVTPaintInfo; // all necessary information about a node to pass to the paint routines + + R, // the area of an entire node in its local coordinate + TargetRect, // the area of a node (part) in the target canvas + SelectionRect, // ordered rectangle used for drawing the selection focus rect + ClipRect: TRect; // area to which the canvas will be clipped when painting a node's content + NextColumn: TColumnIndex; + BaseOffset: TDimension; // top position of the top node to draw given in absolute tree coordinates + NodeBitmap: TBitmap; // small buffer to draw flicker free + MaximumRight, // maximum horizontal target position + MaximumBottom: TDimension; // maximum vertical target position + SelectLevel: Integer; // > 0 if current node is selected or child/grandchild etc. of a selected node + FirstColumn: TColumnIndex; // index of first column which is at least partially visible in the given window + + MaxRight, + ColLeft, + ColRight: TDimension; + + SavedTargetDC: Integer; + PaintWidth: TDimension; + CurrentNodeHeight: TDimension; + lEmptyListTextMargin: TDimension; + + CellIsTouchingClientRight: Boolean; + CellIsInLastColumn: Boolean; + ColumnIsFixed: Boolean; + +begin + if not (tsPainting in FStates) then + begin + DoStateChange([tsPainting]); + try + DoBeforePaint(TargetCanvas); + + if poUnbuffered in PaintOptions then + SavedTargetDC := SaveDC(TargetCanvas.Handle) + else + SavedTargetDC := 0; + + // Prepare paint info structure. + ZeroMemory(@PaintInfo, SizeOf(PaintInfo)); + + PaintWidth := Window.Right - Window.Left; + + if not (poUnbuffered in PaintOptions) then + begin + // Create small bitmaps and initialize default values. + // The bitmaps are used to paint one node at a time and to draw the result to the target (e.g. screen) in one step, + // to prevent flickering. + NodeBitmap := TBitmap.Create; + // For alpha blending we need the 32 bit pixel format. For other targets there might be a need for a certain + // pixel format (e.g. printing). + if ((FDrawSelectionMode = smBlendedRectangle) or (tsUseThemes in FStates) or + (toUseBlendedSelection in FOptions.PaintOptions)) then + NodeBitmap.PixelFormat := pf32Bit + else + NodeBitmap.PixelFormat := PixelFormat; + + NodeBitmap.Width := PaintWidth; + + // Make sure the buffer bitmap and target bitmap use the same transformation mode. + SetMapMode(NodeBitmap.Canvas.Handle, GetMapMode(TargetCanvas.Handle)); + PaintInfo.Canvas := NodeBitmap.Canvas; + end + else + begin + PaintInfo.Canvas := TargetCanvas; + NodeBitmap := nil; + end; + + // Lock the canvas to avoid that it gets freed on the way. + PaintInfo.Canvas.Lock; + try + // Prepare the current selection rectangle once. The corner points are absolute tree coordinates. + SelectionRect := OrderRect(FNewSelRect); + DrawSelectionRect := IsMouseSelecting and not IsRectEmpty(SelectionRect) and (GetKeyState(VK_LBUTTON) < 0); + + // R represents an entire node (all columns), but is a bit unprecise when it comes to + // trees without any column defined, because FRangeX only represents the maximum width of all + // nodes in the client area (not all defined nodes). There might be, however, wider nodes somewhere. Without full + // validation I cannot better determine the width, though. By using at least the control's width it is ensured + // that the tree is fully displayed on screen. + R := Rect(0, 0, Max(FRangeX, ClientWidth), 0); + + // For quick checks some intermediate variables are used. + UseBackground := (toShowBackground in FOptions.PaintOptions) and Assigned(FBackground.Graphic) and + (poBackground in PaintOptions); + ShowCheckImages := Assigned(FCheckImages) and (toCheckSupport in FOptions.MiscOptions); + UseColumns := FHeader.UseColumns; + + // Adjust paint options to tree settings. Hide selection if told so or the tree is unfocused. + if (toAlwaysHideSelection in FOptions.PaintOptions) or + (not Focused and (toHideSelection in FOptions.PaintOptions)) then + Exclude(PaintOptions, poDrawSelection); + if toHideFocusRect in FOptions.PaintOptions then + Exclude(PaintOptions, poDrawFocusRect); + + // Determine node to start drawing with. + BaseOffset := 0; + PaintInfo.Node := GetNodeAt(0, Window.Top, False, BaseOffset); + if PaintInfo.Node = nil then + BaseOffset := Window.Top; + + // Transform selection rectangle into node bitmap coordinates. + if DrawSelectionRect then + OffsetRect(SelectionRect, 0, -BaseOffset); + + // The target rectangle holds the coordinates of the exact area to blit in target canvas coordinates. + // It is usually smaller than an entire node and wanders while the paint loop advances. + MaximumRight := Target.X + (Window.Right - Window.Left); + MaximumBottom := Target.Y + (Window.Bottom - Window.Top); + + TargetRect := Rect(Target.X, Target.Y - (Window.Top - BaseOffset), MaximumRight, 0); + TargetRect.Bottom := TargetRect.Top; + TargetCanvas.Font := Self.Font; + + // This marker gets the index of the first column which is visible in the given window. + // This is needed for column based background colors. + FirstColumn := InvalidColumn; + + if Assigned(PaintInfo.Node) then + begin + + // ----- main node paint loop + while Assigned(PaintInfo.Node) do + begin + // Determine LineImage, SelectionLevel and IndentSize + SelectLevel := DetermineLineImageAndSelectLevel(PaintInfo.Node, LineImage); + IndentSize := Length(LineImage); + + // Initialize node if not already done. + if not (vsInitialized in PaintInfo.Node.States) then + InitNode(PaintInfo.Node); + if (vsSelected in PaintInfo.Node.States) and not (toChildrenAbove in FOptions.PaintOptions) then + System.Inc(SelectLevel); + + // Ensure the node's height is determined. + MeasureItemHeight(PaintInfo.Canvas, PaintInfo.Node); + + // Adjust the brush origin for dotted lines depending on the current source position. + // It is applied some lines later, as the canvas might get reallocated, when changing the node bitmap. + PaintInfo.BrushOrigin := Point(Window.Left and 1, BaseOffset and 1); + Inc(BaseOffset, PaintInfo.Node.NodeHeight); + + TargetRect.Bottom := TargetRect.Top + PaintInfo.Node.NodeHeight; + + // If poSelectedOnly is active then do the following stuff only for selected nodes or nodes + // which are children of selected nodes. + if (SelectLevel > 0) or not (poSelectedOnly in PaintOptions) then + begin + if not (poUnbuffered in PaintOptions) then + begin + // Adjust height of temporary node bitmap. + with NodeBitmap do + begin + if Height <> PaintInfo.Node.NodeHeight then + begin + // Avoid that the VCL copies the bitmap while changing its height. + Height := 0; + Height := PaintInfo.Node.NodeHeight; + SetCanvasOrigin(Canvas, Window.Left, 0); + end; + end; + end + else + begin + SetCanvasOrigin(PaintInfo.Canvas, -TargetRect.Left + Window.Left, -TargetRect.Top); + ClipCanvas(PaintInfo.Canvas, Rect(0, 0, TargetRect.Right - TargetRect.Left, + Min(TargetRect.Bottom - TargetRect.Top, MaximumBottom - TargetRect.Top))); // See issue #579 + end; + + // Set the origin of the canvas' brush. This depends on the node heights. + with PaintInfo do + SetBrushOrigin(Canvas, BrushOrigin.X, BrushOrigin.Y); + + CurrentNodeHeight := PaintInfo.Node.NodeHeight; + R.Bottom := CurrentNodeHeight; + + // Let application decide whether the node should normally be drawn or by the application itself. + if not DoBeforeItemPaint(PaintInfo.Canvas, PaintInfo.Node, R) then + begin + // Init paint options for the background painting. + PaintInfo.PaintOptions := PaintOptions; + + // The node background can contain a single color, a bitmap or can be drawn by the application. + ClearNodeBackground(PaintInfo, UseBackground, True, Rect(Window.Left, TargetRect.Top, Window.Right, + TargetRect.Bottom)); + + // Prepare column, position and node clipping rectangle. + PaintInfo.CellRect := R; + if UseColumns then + InitializeFirstColumnValues(PaintInfo); + + // Now go through all visible columns (there's still one run if columns aren't used). + with TVirtualTreeColumnsCracker(FHeader.Columns) do + begin + while ((PaintInfo.Column > InvalidColumn) or not UseColumns) + and (PaintInfo.CellRect.Left < Window.Right) do + begin + if UseColumns then + begin + PaintInfo.Column := PositionToIndex[PaintInfo.Position]; + if FirstColumn = InvalidColumn then + FirstColumn := PaintInfo.Column; + PaintInfo.BidiMode := Items[PaintInfo.Column].BiDiMode; + PaintInfo.Alignment := Items[PaintInfo.Column].Alignment; + end + else + begin + PaintInfo.Column := NoColumn; + PaintInfo.BidiMode := BidiMode; + PaintInfo.Alignment := FAlignment; + end; + GetOffSets(PaintInfo.Node, PaintInfo.Offsets, TVTElement.ofsText, PaintInfo.Column); + + PaintInfo.PaintOptions := PaintOptions; + with PaintInfo do + begin + if (tsEditing in FStates) and (Node = FFocusedNode) and + ((Column = FEditColumn) or not UseColumns) then + Exclude(PaintOptions, poDrawSelection); + if not UseColumns or + ((vsSelected in Node.States) and (toFullRowSelect in FOptions.SelectionOptions) and + (poDrawSelection in PaintOptions)) or + (coParentColor in Items[PaintInfo.Column].Options) or + ((coStyleColor in Items[PaintInfo.Column].Options) and VclStyleEnabled) + then + Exclude(PaintOptions, poColumnColor); + end; + IsMainColumn := PaintInfo.Column = FHeader.MainColumn; + + // Consider bidi mode here. In RTL context means left alignment actually right alignment and vice versa. + if PaintInfo.BidiMode <> bdLeftToRight then + ChangeBiDiModeAlignment(PaintInfo.Alignment); + + // Paint the current cell if it is marked as being visible or columns aren't used and + // if this cell belongs to the main column if only the main column should be drawn. + if (not UseColumns or (coVisible in Items[PaintInfo.Column].Options)) and + (not (poMainOnly in PaintOptions) or IsMainColumn) then + begin + AdjustPaintCellRect(PaintInfo, NextColumn); + + // Paint the cell only if it is in the current window. + if PaintInfo.CellRect.Right > Window.Left then + begin + with PaintInfo do + begin + // Fill in remaining values in the paint info structure. + NodeWidth := DoGetNodeWidth(Node, Column, Canvas); + + if ShowCheckImages and IsMainColumn then + begin + ImageInfo[iiCheck].Index := GetCheckImage(Node); + ImageInfo[iiCheck].Images := FCheckImages; + ImageInfo[iiCheck].Ghosted := False; + end + else + ImageInfo[iiCheck].Index := -1; + GetImageIndex(PaintInfo, ikState, iiState); + GetImageIndex(PaintInfo, ImageKind[vsSelected in Node.States], iiNormal); + + CalculateVerticalAlignments(PaintInfo, ButtonY); + // Take the space for the tree lines into account. + PaintInfo.AdjustImageCoordinates(); + if UseColumns then + begin + ClipRect := CellRect; + if poUnbuffered in PaintOptions then + begin + ClipRect.Left := Max(ClipRect.Left, Window.Left); + ClipRect.Right := Min(ClipRect.Right, Window.Right); + ClipRect.Top := Max(ClipRect.Top, Window.Top - (BaseOffset - CurrentNodeHeight)); + ClipRect.Bottom := ClipRect.Bottom - Max(TargetRect.Bottom - MaximumBottom, 0); + end; + ClipCanvas(Canvas, ClipRect); + end; + + // Paint the horizontal grid line. + if (poGridLines in PaintOptions) and (toShowHorzGridLines in FOptions.PaintOptions) then + begin + Canvas.Font.Color := FColors.GridLineColor; + if IsMainColumn and (FLineMode = lmBands) then + begin + if BidiMode = bdLeftToRight then + begin + DrawGridHLine(PaintInfo, CellRect.Left + PaintInfo.Offsets[ofsCheckBox] - fImagesMargin, CellRect.Right - LineWidth, CellRect.Bottom - LineWidth); + end + else + begin + DrawGridHLine(PaintInfo, CellRect.Left, CellRect.Right - IfThen(toFixedIndent in FOptions.PaintOptions, LineWidth, IndentSize) * FIndent - 1, CellRect.Bottom - LineWidth); + end; + end + else + DrawGridHLine(PaintInfo, CellRect.Left, CellRect.Right, CellRect.Bottom - LineWidth); + + Dec(CellRect.Bottom); + Dec(ContentRect.Bottom); + end; + + if UseColumns then + begin + ColumnIsFixed := coFixed in FHeader.Columns[Column].Options; + // Paint vertical grid line. + if (poGridLines in PaintOptions) and (toShowVertGridLines in FOptions.PaintOptions) then + begin + // These variables and the nested if conditions shall make the logic + // easier to understand. + CellIsTouchingClientRight := PaintInfo.CellRect.Right = ClientRect.Right; + CellIsInLastColumn := Position = TColumnPosition(Count - 1); + + // Don't draw if this is the last column and the header is in autosize mode. + if not ((hoAutoResize in FHeader.Options) and CellIsInLastColumn) then + begin + // We have to take spanned cells into account which we determine + // by checking if CellRect.Right equals the Window.Right. + // But since the PaintTree procedure is called twice in + // TBaseVirtualTree.Paint (i.e. for fixed columns and other columns. + // CellIsTouchingClientRight does not work for fixed columns.) + // we have to paint fixed column grid line anyway. + if not CellIsTouchingClientRight or ColumnIsFixed then + begin + if (BidiMode = bdLeftToRight) or not ColumnIsEmpty(Node, Column) then + begin + DrawGridVLine(PaintInfo, CellRect.Top, CellRect.Bottom, CellRect.Right - LineWidth, ColumnIsFixed and (NextColumn >= 0)); + end; + + Dec(CellRect.Right); + end; + end; + // Reduce the content rect size nonetheless to retain correct alignment + // relative to header content (especially if "PaintInfo.Alignment = alRightJustify"). + Dec(ContentRect.Right); + end// if poGridLines + else + begin + if ColumnIsFixed then + begin + if (BidiMode = bdLeftToRight) or not ColumnIsEmpty(Node, Column) then + begin + DrawGridVLine(PaintInfo, CellRect.Top, CellRect.Bottom, CellRect.Right - LineWidth, ColumnIsFixed and (NextColumn >= 0)); + end; + Dec(CellRect.Right); + end; + end//else + end; + + // Prepare background and focus rect for the current cell. + PrepareCell(PaintInfo, Window.Left, PaintWidth); + + // Some parts are only drawn for the main column. + if IsMainColumn then + begin + if (toShowTreeLines in FOptions.PaintOptions) and + (not (toHideTreeLinesIfThemed in FOptions.PaintOptions) or + not (tsUseThemes in FStates)) then + PaintTreeLines(PaintInfo, IfThen(toFixedIndent in FOptions.PaintOptions, 1, + IndentSize), LineImage); + // Show node button if allowed, if there child nodes and at least one of the child + // nodes is visible or auto button hiding is disabled. + if (toShowButtons in FOptions.PaintOptions) and (vsHasChildren in Node.States) and + not ((vsAllChildrenHidden in Node.States) and + (toAutoHideButtons in TreeOptions.AutoOptions)) and + ((toShowRoot in TreeOptions.PaintOptions) or (GetNodeLevel(Node) > 0)) + then + PaintNodeButton(Canvas, Node, Column, CellRect, Offsets[ofsToggleButton], ButtonY, BidiMode); // Relative X position of toggle button is needed for proper BiDi calculation + + if ImageInfo[iiCheck].Index > -1 then + PaintCheckImage(Canvas, PaintInfo.ImageInfo[iiCheck], vsSelected in PaintInfo.Node.States); + end; + + if ImageInfo[iiState].Index > -1 then + PaintImage(PaintInfo, iiState, False); + if ImageInfo[iiNormal].Index > -1 then + PaintImage(PaintInfo, iiNormal, True); + + // Now let descendants or applications draw whatever they want, + // but don't draw the node if it is currently being edited. + if not ((tsEditing in FStates) and (Node = FFocusedNode) and + ((Column = FEditColumn) or not UseColumns)) then + DoPaintNode(PaintInfo); + + DoAfterCellPaint(Canvas, Node, Column, CellRect); + end; + end; + + // leave after first run if columns aren't used + if not UseColumns then + Break; + end + else + NextColumn := GetNextVisibleColumn(PaintInfo.Column); + + SelectClipRgn(PaintInfo.Canvas.Handle, 0); + // Stop column loop if there are no further columns in the given window. + if (PaintInfo.CellRect.Left >= Window.Right) or (NextColumn = InvalidColumn) then + Break; + + // Move on to next column which might not be the one immediately following the current one + // because of auto span feature. + PaintInfo.Position := Items[NextColumn].Position; + + // Move clip rectangle and continue. + if coVisible in Items[NextColumn].Options then + with PaintInfo do + begin + TVirtualTreeColumnCracker(Items[NextColumn]).GetAbsoluteBounds(CellRect.Left, CellRect.Right); + CellRect.Bottom := Node.NodeHeight; + ContentRect.Bottom := Node.NodeHeight; + end; + end; + end; + + // This node is finished, notify descendants/application. + with PaintInfo do + begin + DoAfterItemPaint(Canvas, Node, R); + + // Final touch for this node: mark it if it is the current drop target node. + if (Node = FDropTargetNode) and (toShowDropmark in FOptions.PaintOptions) and + (poDrawDropMark in PaintOptions) then + DoPaintDropMark(Canvas, Node, R); + end; + end; // if not DoBeforeItemPaint() (no custom drawing) + + + with PaintInfo.Canvas do + begin + if DrawSelectionRect then + begin + PaintSelectionRectangle(PaintInfo.Canvas, Window.Left, SelectionRect, Rect(0, 0, PaintWidth, + CurrentNodeHeight)); + end; + + // Put the constructed node image onto the target canvas. + if not (poUnbuffered in PaintOptions) then + with NodeBitmap do + BitBlt(TargetCanvas.Handle, TargetRect.Left, TargetRect.Top, TargetRect.Width, TargetRect.Height, Canvas.Handle, Window.Left, 0, SRCCOPY); + end; + end; + + Inc(TargetRect.Top, PaintInfo.Node.NodeHeight); + if TargetRect.Top >= MaximumBottom then + Break; + + // Keep selection rectangle coordinates in sync. + if DrawSelectionRect then + OffsetRect(SelectionRect, 0, -PaintInfo.Node.NodeHeight); + + // Advance to next visible node. + PaintInfo.Node := GetNextVisible(PaintInfo.Node, True); + end; + end; + + // Erase rest of window not covered by a node. + if TargetRect.Top < MaximumBottom then + begin + // Keep the horizontal target position to determine the selection rectangle offset later (if necessary). + BaseOffset := Target.X; + Target := TargetRect.TopLeft; + R := Rect(TargetRect.Left, 0, TargetRect.Left, MaximumBottom - Target.Y); + TargetRect := Rect(0, 0, MaximumRight - Target.X, MaximumBottom - Target.Y); + + if not (poUnbuffered in PaintOptions) then + begin + // Avoid unnecessary copying of bitmap content. This will destroy the DC handle too. + NodeBitmap.Height := 0; + NodeBitmap.PixelFormat := pf32Bit; + NodeBitmap.SetSize(TargetRect.Right - TargetRect.Left, TargetRect.Bottom - TargetRect.Top); + end; + + // Call back application/descendants whether they want to erase this area. + if not DoPaintBackground(PaintInfo.Canvas, TargetRect) then + begin + if UseBackground then + begin + SetCanvasOrigin(PaintInfo.Canvas, 0, 0); + if toStaticBackground in TreeOptions.PaintOptions then + StaticBackground(FBackground, PaintInfo.Canvas, Target, TargetRect, FColors.BackGroundColor) + else + TileBackground(FBackground, PaintInfo.Canvas, Target, TargetRect, FColors.BackGroundColor); + end + else + begin + // Consider here also colors of the columns. + SetCanvasOrigin(PaintInfo.Canvas, Target.X, 0); // This line caused issue #313 when it was placed above the if-statement + if UseColumns then + begin + with FHeader.Columns do + begin + // If there is no content in the tree then the first column has not yet been determined. + if FirstColumn = InvalidColumn then + begin + FirstColumn := GetFirstVisibleColumn; + repeat + if FirstColumn <> InvalidColumn then + begin + R.Left := Items[FirstColumn].Left; + R.Right := R.Left + Items[FirstColumn].Width; + if R.Right > TargetRect.Left then + Break; + FirstColumn := GetNextVisibleColumn(FirstColumn); + end; + until FirstColumn = InvalidColumn; + end + else + begin + R.Left := Items[FirstColumn].Left; + R.Right := R.Left + Items[FirstColumn].Width; + end; + + // Initialize MaxRight. + MaxRight := Target.X - 1; + + PaintInfo.Canvas.Font.Color := FColors.GridLineColor; + while (FirstColumn <> InvalidColumn) and (MaxRight < TargetRect.Right + Target.X) do + begin + // Determine left and right coordinate of the current column + ColLeft := Items[FirstColumn].Left; + ColRight := (ColLeft + Items[FirstColumn].Width); + + // Check wether this column needs to be painted at all. + if (ColRight >= MaxRight) then + begin + R.Left := MaxRight; // Continue where we left off + R.Right := ColRight; // Paint to the right of the column + MaxRight := ColRight; // And record were to start the next column. + + if (poGridLines in PaintOptions) and + (toFullVertGridLines in FOptions.PaintOptions) and + (toShowVertGridLines in FOptions.PaintOptions) and + (not (hoAutoResize in FHeader.Options) or (Cardinal(FirstColumn) < TColumnPosition(Count - 1))) then + begin + DrawGridVLine(PaintInfo, R.Top, R.Bottom, R.Right - 1); + Dec(R.Right); + end; + + if not (coParentColor in Items[FirstColumn].Options) then + PaintInfo.Canvas.Brush.Color := Items[FirstColumn].Color + else + PaintInfo.Canvas.Brush.Color := FColors.BackGroundColor; + PaintInfo.Canvas.FillRect(R); + end; + FirstColumn := GetNextVisibleColumn(FirstColumn); + end; + + // Erase also the part of the tree not covert by a column. + if R.Right < TargetRect.Right + Target.X then + begin + R.Left := R.Right; + R.Right := TargetRect.Right + Target.X; + // Prevent erasing the last vertical grid line. + if (poGridLines in PaintOptions) and + (toFullVertGridLines in FOptions.PaintOptions) and (toShowVertGridLines in FOptions.PaintOptions) and + (not (hoAutoResize in FHeader.Options)) then + Inc(R.Left); + PaintInfo.Canvas.Brush.Color := FColors.BackGroundColor; + PaintInfo.Canvas.FillRect(R); + end; + end; + SetCanvasOrigin(PaintInfo.Canvas, 0, 0); + end + else + begin + // No columns nor bitmap background. Simply erase it with the tree color. + SetCanvasOrigin(PaintInfo.Canvas, 0, 0); + PaintInfo.Canvas.Brush.Color := FColors.BackGroundColor; + PaintInfo.Canvas.FillRect(TargetRect); + end; + end; + end; + SetCanvasOrigin(PaintInfo.Canvas, 0, 0); + + if DrawSelectionRect then + begin + R := OrderRect(FNewSelRect); + // Remap the selection rectangle to the current window of the tree. + // Since Target has been used for other tasks BaseOffset got the left extent of the target position here. + OffsetRect(R, -Target.X + BaseOffset - Window.Left, -Target.Y + FOffsetY); + SetBrushOrigin(PaintInfo.Canvas, 0, Target.X and 1); + PaintSelectionRectangle(PaintInfo.Canvas, 0, R, TargetRect); + end; + + if not (poUnBuffered in PaintOptions) then + with Target, NodeBitmap do + BitBlt(TargetCanvas.Handle, X, Y, Width, Height, Canvas.Handle, 0, 0, SRCCOPY); + end; + finally + PaintInfo.Canvas.Unlock; + if poUnbuffered in PaintOptions then + RestoreDC(TargetCanvas.Handle, SavedTargetDC) + else + NodeBitmap.Free; + end;//try..finally + + if (FEmptyListMessage <> '') and ((ChildCount[nil] = 0) or (GetFirstVisible = nil)) then + begin + // output a message if no items are to display + Canvas.Font := Self.Font; + Canvas.Font.Size := Round(Canvas.Font.Size * 1.25); // Use slightly larger font to attract awareness of user, there is enough space ince the list is empty. + SetBkMode(TargetCanvas.Handle, TRANSPARENT); + lEmptyListTextMargin := ScaledPixels(Max(cDefaultTextMargin, Self.TextMargin) * 2); // Since the list is empty and the font is slightly larger make sure text id not too close at the edges so that it looks good. + R.Left := OffSetX + lEmptyListTextMargin; + R.Top := lEmptyListTextMargin; + R.Right := R.Left + Width - lEmptyListTextMargin; + R.Bottom := Height - lEmptyListTextMargin; + TargetCanvas.Font.Color := StyleServices.GetStyleFontColor(TStyleFont.sfTreeItemTextDisabled);//clGrayText; + TargetCanvas.TextRect(R, FEmptyListMessage, [tfNoClip, tfLeft, tfWordBreak, tfExpandTabs]); + end; + + DoAfterPaint(TargetCanvas); + finally + DoStateChange([], [tsPainting]); + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.PrepareDragImage(HotSpot: TPoint; const DataObject: TVTDragDataObject); + +// Initiates an image drag operation. HotSpot is the position of the mouse in client coordinates. + +var + PaintOptions: TVTInternalPaintOptions; + TreeRect, + PaintRect: TRect; + LocalSpot, + PaintTarget: TPoint; + lDragImage: TVTDragImage; // drag image management + Image: TBitmap; + +begin + if CanShowDragImage then + begin + lDragImage := TVTDragImage.Create(Self); + try + // Determine the drag rectangle which is a square around the hot spot. Operate in virtual tree space. + LocalSpot := HotSpot; + Dec(LocalSpot.X, -FEffectiveOffsetX); + Dec(LocalSpot.Y, FOffsetY); + TreeRect := Rect(LocalSpot.X - FDragWidth div 2, LocalSpot.Y - FDragHeight div 2, LocalSpot.X + FDragWidth div 2, + LocalSpot.Y + FDragHeight div 2); + + // Check that we have a valid rectangle. + PaintRect := TreeRect; + if TreeRect.Left < 0 then + begin + PaintTarget.X := -TreeRect.Left; + PaintRect.Left := 0; + end + else + PaintTarget.X := 0; + if TreeRect.Top < 0 then + begin + PaintTarget.Y := -TreeRect.Top; + PaintRect.Top := 0; + end + else + PaintTarget.Y := 0; + + Image := TBitmap.Create; + with Image do + try + PixelFormat := pf32Bit; + SetSize(TreeRect.Right - TreeRect.Left, TreeRect.Bottom - TreeRect.Top); + // Erase the entire image with the color key value, for the case not everything + // in the image is covered by the tree image. + Canvas.Brush.Color := FColors.BackGroundColor; + Canvas.FillRect(Rect(0, 0, Width, Height)); + + PaintOptions := [poDrawSelection, poSelectedOnly]; + if FDragImageKind = diMainColumnOnly then + Include(PaintOptions, poMainOnly); + PaintTree(Image.Canvas, PaintRect, PaintTarget, PaintOptions); + + // Once we have got the drag image we can convert all necessary coordinates into screen space. + OffsetRect(TreeRect, -FEffectiveOffsetX, FOffsetY); + HotSpot.X := Width div 2; + HotSpot.Y := Height div 2; + + lDragImage.PrepareDrag(Image, HotSpot, DataObject, FColors.BackGroundColor); + finally + Image.Free; + end; + finally + lDragImage.Free; + end; // try..finally + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.Print(Printer: TPrinter; PrintHeader: Boolean); + +var + SaveTreeFont: TFont; // Remembers the tree's current font. + SaveHeaderFont: TFont; // Remembers the header's current font. + ImgRect, // Describes the dimensions of Image. + TreeRect, // The total VTree dimensions. + DestRect, // Dimensions of PrinterImage. + SrcRect: TRect; // Clip dimensions from Image -> PrinterImage + P: TPoint; // Used by PaintTree. + Options: TVTInternalPaintOptions; // Used by PaintTree. + Image, // Complete Tree is drawn to this image. + PrinterImage: TBitmap; // This is the image that gets printed. + SaveColor: TColor; // Remembers the VTree Color. + pTxtHeight, // Height of font in the TPrinter.Canvas + vTxtHeight, // Height of font in the VTree Canvas + vPageWidth, + vPageHeight, // Printer height in VTree resolution + xPageNum, yPageNum, // # of pages (except the occasional last one) + xPage, yPage: Integer; // Loop counter + Scale: Extended; // Scale factor between Printer Canvas and VTree Canvas + LogFont: TLogFont; + +begin + if Assigned(Printer) then + begin + BeginUpdate; + + // Grid lines are the only parts which are desirable when printing. + Options := [poGridLines]; + + // Remember the tree font. + SaveTreeFont := TFont.Create; + SaveTreeFont.Assign(Font); + // Create a new font for printing which does not use clear type output (but is antialiased, if possible) + // and which has the highest possible quality. + GetObject(Font.Handle, SizeOf(TLogFont), @LogFont); + LogFont.lfQuality := ANTIALIASED_QUALITY; + Font.Handle := CreateFontIndirect(LogFont); + + // Create an image that will hold the complete VTree + Image := TBitmap.Create; + Image.PixelFormat := pf32Bit; + PrinterImage := nil; + try + TreeRect := GetTreeRect; + + Image.Width := TreeRect.Right - TreeRect.Left; + P := Point(0, 0); + if (hoVisible in FHeader.Options) and PrintHeader then + begin + Inc(TreeRect.Bottom, FHeader.Height); + Inc(P.Y, FHeader.Height); + end; + Image.Height := TreeRect.Bottom - TreeRect.Top; + + ImgRect.Left := 0; + ImgRect.Top := 0; + ImgRect.Right := Image.Width; + + // Force the background to white color during the rendering. + SaveColor := FColors.BackGroundColor; + Color := clWhite; + // Print header if it is visible. + if (hoVisible in FHeader.Options) and PrintHeader then + begin + SaveHeaderFont := TFont.Create; + try + SaveHeaderFont.Assign(FHeader.Font); + // Create a new font for printing which does not use clear type output (but is antialiased, if possible) + // and which has the highest possible quality. + GetObject(FHeader.Font.Handle, SizeOf(TLogFont), @LogFont); + LogFont.lfQuality := ANTIALIASED_QUALITY; + FHeader.Font.Handle := CreateFontIndirect(LogFont); + ImgRect.Bottom := FHeader.Height; + FHeader.Columns.PaintHeader(Image.Canvas.Handle, ImgRect, 0); + FHeader.Font := SaveHeaderFont; + finally + SaveHeaderFont.Free; + end; + end; + // The image's height is already adjusted for the header if it is visible. + ImgRect.Bottom := Image.Height; + + PaintTree(Image.Canvas, ImgRect, P, Options, pf32Bit); + Color := SaveColor; + + // Activate the printer + Printer.BeginDoc; + Printer.Canvas.Font := Font; + + // Now we can calculate the scaling : + pTxtHeight := Printer.Canvas.TextHeight('Tj'); + vTxtHeight := Canvas.TextHeight('Tj'); + + Scale := pTxtHeight / vTxtHeight; + + // Create an Image that has the same dimensions as the printer canvas but + // scaled to the VTree resolution: + PrinterImage := TBitmap.Create; + + vPageHeight := Round(Printer.PageHeight / Scale); + vPageWidth := Round(Printer.PageWidth / Scale); + + // We do a minumum of one page. + xPageNum := Trunc(Image.Width / vPageWidth); + yPageNum := Trunc(Image.Height / vPageHeight); + + PrinterImage.SetSize(vPageWidth, vPageHeight); + + // Split vertically: + for yPage := 0 to yPageNum do + begin + DestRect.Left := 0; + DestRect.Top := 0; + DestRect.Right := PrinterImage.Width; + DestRect.Bottom := PrinterImage.Height; + + // Split horizontally: + for xPage := 0 to xPageNum do + begin + SrcRect.Left := vPageWidth * xPage; + SrcRect.Top := vPageHeight * yPage; + SrcRect.Right := vPageWidth * xPage + PrinterImage.Width; + SrcRect.Bottom := SrcRect.Top + vPageHeight; + + // Clear the image + PrinterImage.Canvas.Brush.Color := clWhite; + PrinterImage.Canvas.FillRect(Rect(0, 0, PrinterImage.Width, PrinterImage.Height)); + PrinterImage.Canvas.CopyRect(DestRect, Image.Canvas, SrcRect); + PrtStretchDrawDIB(Printer.Canvas, Rect(0, 0, Printer.PageWidth, Printer.PageHeight - 1), PrinterImage); + if xPage <> xPageNum then + Printer.NewPage; + end; + if yPage <> yPageNum then + Printer.NewPage; + end; + + // Restore tree font. + Font := SaveTreeFont; + SaveTreeFont.Free; + Printer.EndDoc; + finally + PrinterImage.Free; + Image.Free; + EndUpdate; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.ProcessDrop(const DataObject: TVTDragDataObject; TargetNode: PVirtualNode; var Effect: Integer; + Mode: TVTNodeAttachMode): Boolean; + +// Recreates the (sub) tree structure serialized into memory and provided by DataObject. The new nodes are attached to +// the passed node or FRoot if TargetNode is nil. +// Returns True on success, i.e. the CF_VIRTUALTREE format is supported by the data object and the structure could be +// recreated, otherwise False. + +var + Source: TBaseVirtualTree; + +begin + Result := False; + if Mode = amNoWhere then + Effect := DROPEFFECT_NONE + else + begin + BeginUpdate; + // try to get the source tree of the operation + Source := TVTDragManager.GetTreeFromDataObject(DataObject); + if Assigned(Source) then + Source.BeginUpdate; + try + try + // Before adding the new nodes try to optimize the operation if source and target tree reside in + // the same application and operation is a move. + if ((Effect and DROPEFFECT_MOVE) <> 0) and Assigned(Source) then + begin + // If both copy and move are specified then prefer a copy because this is not destructing. + Result := ProcessOLEData(Source, DataObject, TargetNode, Mode, (Effect and DROPEFFECT_COPY) = 0); + // Since we made an optimized move or a copy there's no reason to act further after DoDragging returns. + Effect := DROPEFFECT_NONE; + end + else + // Act only if move or copy operation is requested. + if (Effect and (DROPEFFECT_MOVE or DROPEFFECT_COPY)) <> 0 then + Result := ProcessOLEData(Source, DataObject, TargetNode, Mode, False) + else + Result := False; + except + Effect := DROPEFFECT_NONE; + end; + finally + if Assigned(Source) then + Source.EndUpdate; + EndUpdate; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +type + // needed to handle OLE global memory objects + TOLEMemoryStream = class(TCustomMemoryStream) + public + function Write(const Buffer; Count: Integer): Integer; override; + end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TOLEMemoryStream.Write(const Buffer; Count: Integer): Integer; + +begin + raise EStreamError.CreateRes(PResStringRec(@SCantWriteResourceStreamError)); +end; + +//----------------- TBaseVirtualTree ----------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoDrawHint(Canvas: TCanvas; Node: PVirtualNode; R: + TRect; Column: TColumnIndex); + +begin + if Assigned(FOnDrawHint) then + FOnDrawHint(Self, Canvas, Node, R, Column); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoGetHintSize(Node: PVirtualNode; Column: + TColumnIndex; var R: TRect); + +begin + if Assigned(FOnGetHintSize) then + FOnGetHintSize(Self, Node, Column, R); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.DoGetHintKind(Node: PVirtualNode; Column: + TColumnIndex; var Kind: TVTHintKind); + +begin + if Assigned(FOnGetHintKind) then + FOnGetHintKind(Self, Node, Column, Kind) + else + Kind := DefaultHintKind; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.GetDefaultHintKind: TVTHintKind; + +begin + Result := vhkText; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.ProcessOLEData(Source: TBaseVirtualTree; const DataObject: IDataObject; TargetNode: PVirtualNode; + Mode: TVTNodeAttachMode; Optimized: Boolean): Boolean; + +// Recreates the (sub) tree structure serialized into memory and provided by DataObject. The new nodes are attached to +// the passed node or FRoot if TargetNode is nil according to Mode. Optimized can be set to True if the entire operation +// happens within the same process (i.e. sender and receiver of the OLE operation are located in the same process). +// Optimize = True makes only sense if the operation to carry out is a move hence it is also the indication of the +// operation to be done here. Source is the source of the OLE data and only of use (and usually assigned) when +// an OLE operation takes place in the same application. +// Returns True on success, i.e. the CF_VIRTUALTREE format is supported by the data object and the structure could be +// recreated, otherwise False. + +var + Medium: TStgMedium; + Stream: TStream; + Data: Pointer; + Node: PVirtualNode; + Nodes: TNodeArray; + I: Integer; + Res: HRESULT; + ChangeReason: TChangeReason; + +begin + Nodes := nil; + // Check the data format available by the data object. + with StandardOLEFormat do + begin + // Read best format. + cfFormat := CF_VIRTUALTREE; + end; + Result := DataObject.QueryGetData(StandardOLEFormat) = S_OK; + if Result and not (toReadOnly in FOptions.MiscOptions) then + begin + BeginUpdate; + Result := False; + try + if TargetNode = nil then + TargetNode := FRoot; + if TargetNode = FRoot then + begin + case Mode of + amInsertBefore: + Mode := amAddChildFirst; + amInsertAfter: + Mode := amAddChildLast; + end; + end; + + // Optimized means source is known and in the same process so we can access its pointers, which avoids duplicating + // the data while doing a serialization. Can only be used with cut'n paste and drag'n drop with move effect. + if Optimized then + begin + if tsOLEDragging in Source.FStates then + Nodes := Source.FDragSelection + else + Nodes := Source.GetSortedCutCopySet(True); + + if Mode in [amInsertBefore,amAddChildLast] then + begin + for I := 0 to High(Nodes) do + if not HasAsParent(TargetNode, Nodes[I]) then + Source.MoveTo(Nodes[I], TargetNode, Mode, False); + end + else + begin + for I := High(Nodes) downto 0 do + if not HasAsParent(TargetNode, Nodes[I]) then + Source.MoveTo(Nodes[I], TargetNode, Mode, False); + end; + Result := True; + end + else + begin + if Source = Self then + ChangeReason := crNodeCopied + else + ChangeReason := crNodeAdded; + Res := DataObject.GetData(StandardOLEFormat, Medium); + if Res = S_OK then + begin + case Medium.tymed of + TYMED_ISTREAM, // IStream interface + TYMED_HGLOBAL: // global memory block + begin + Stream := nil; + if Medium.tymed = TYMED_ISTREAM then + Stream := TOLEStream.Create(IUnknown(Medium.stm) as IStream) + else + begin + Data := GlobalLock(Medium.hGlobal); + if Assigned(Data) then + begin + // Get the total size of data to retrieve. + I := PCardinal(Data)^; + Inc(PCardinal(Data)); + Stream := TOLEMemoryStream.Create; + TOLEMemoryStream(Stream).SetPointer(Data, I); + end; + end; + + if Assigned(Stream) then + try + while Stream.Position < Stream.Size do + begin + Node := MakeNewNode; + InternalConnectNode(Node, TargetNode, Self, Mode); + InternalAddFromStream(Stream, VTTreeStreamVersion, Node); + // This seems a bit strange because of the callback for granting to add the node + // which actually comes after the node has been added. The reason is that the node must + // contain valid data otherwise I don't see how the application can make a funded decision. + if not DoNodeCopying(Node, TargetNode) then + begin + DeleteNode(Node); + end + else + begin + DoNodeCopied(Node); + StructureChange(Node, ChangeReason); + // In order to maintain the same node order when restoring nodes in the case of amInsertAfter + // we have to move the reference node continously. Othwise we would end up with reversed node order. + if Mode = amInsertAfter then + TargetNode := Node; + end; + end; + Result := True; + finally + Stream.Free; + if Medium.tymed = TYMED_HGLOBAL then + GlobalUnlock(Medium.hGlobal); + end; + end; + end; + ReleaseStgMedium(Medium); + end; + end; + finally + EndUpdate; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.ReinitChildren(Node: PVirtualNode; Recursive: + Boolean; ForceReinit: Boolean = False); + +// Forces all child nodes of Node to be reinitialized. +// If Recursive is True then also the grandchildren are reinitialized. + +var + Run: PVirtualNode; + +begin + if Assigned(Node) then + begin + InitChildren(Node); + Run := Node.FirstChild; + end + else + begin + InitChildren(FRoot); + Run := FRoot.FirstChild; + end; + + while Assigned(Run) do + begin + ReinitNode(Run, Recursive, ForceReinit); + Run := Run.NextSibling; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.ReinitNode(Node: PVirtualNode; Recursive: Boolean; + ForceReinit: Boolean = False); + +// Reinitializes Node if it has previously been initialized +// If Recursive, initialized children are also re-initialized recursively +// If ForceReinit, Node is always initialized and if Recursive children +// are always re-initialized as well +// InitNode is called with ivsReInit in InitialStates, if the Node has already +// been initialized. + +begin + if Assigned(Node) and (Node <> FRoot) then + begin + // Remove dynamic styles. + Node.States := Node.States - [vsChecking, vsCutOrCopy, vsDeleting, vsHeightMeasured]; + if (vsInitialized in Node.States) or ForceReinit then + InitNode(Node); + end + else if not Assigned(Node) then + Node := FRoot; + + // Prevent previoulsy uninitilaized children from being initialized + // unless ForceReinit is True. Issue #1145 + if Recursive and (ForceReinit or (Node.ChildCount > 0)) then + ReinitChildren(Node, True, ForceReinit); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.RepaintNode(Node: PVirtualNode); + +// Causes an immediate repaint of the given node. + +var + R: Trect; + +begin + if Assigned(Node) and (Node <> FRoot) then + begin + R := GetDisplayRect(Node, NoColumn, False); + RedrawWindow(@R, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE or RDW_VALIDATE or RDW_NOCHILDREN); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.ResetNode(Node: PVirtualNode); + +// Deletes all children of the given node and marks it as being uninitialized. + +begin + DoCancelEdit; + if (Node = nil) or (Node = FRoot) then + Clear + else + begin + DoReset(Node); + DeleteChildren(Node); + // Remove initialized and other dynamic styles, keep persistent styles. + Node.States := Node.States - [vsInitialized, vsChecking, vsCutOrCopy, vsDeleting, vsHasChildren, vsExpanded, + vsHeightMeasured]; + InvalidateNode(Node); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.SaveToFile(const FileName: TFileName); + +// Saves the entire content of the tree into a file (see further notes in SaveToStream). + +var + FileStream: TFileStream; + +begin + FileStream := TFileStream.Create(FileName, fmCreate); + try + SaveToStream(FileStream); + finally + FileStream.Free; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.SaveToStream(Stream: TStream; Node: PVirtualNode = nil); + +// Saves Node and all its children to Stream. If Node is nil then all top level nodes will be stored. +// Note: You should be careful about assuming what is actually saved. The problem here is that we are dealing with +// virtual data. The tree can so not know what it has to save. The only fact we reliably know is the tree's +// structure. To be flexible for future enhancements as well as unknown content (unknown to the tree class which +// is saving/loading the stream) a chunk based approach is used here. Every tree class handles only those +// chunks which are not handled by an anchestor class and are known by the class. +// +// The base tree class saves only the structure of the tree along with application provided data. descendants may +// optionally add their own chunks to store additional information. See: WriteChunks. + +var + Count: Cardinal; + +begin + Stream.Write(MagicID, SizeOf(MagicID)); + if Node = nil then + begin + // Keep number of top level nodes for easy restauration. + Count := FRoot.ChildCount; + Stream.WriteBuffer(Count, SizeOf(Count)); + + // Save entire tree here. + Node := FRoot.FirstChild; + while Assigned(Node) do + begin + WriteNode(Stream, Node); + Node := Node.NextSibling; + end; + end + else + begin + Count := 1; + Stream.WriteBuffer(Count, SizeOf(Count)); + WriteNode(Stream, Node); + end; + if Assigned(FOnSaveTree) then + FOnSaveTree(Self, Stream); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.ScrollIntoView(Node: PVirtualNode; Center: Boolean; Horizontally: Boolean = False): Boolean; + +// Scrolls the tree so that the given node is in the client area and returns True if the tree really has been +// scrolled (e.g. to avoid further updates) else returns False. If extened focus is enabled then the tree will also +// be horizontally scrolled if needed. +// Note: All collapsed parents of the node are expanded. + +var + R: TRect; + Run: PVirtualNode; + UseColumns, + HScrollBarVisible: Boolean; + OldOffsetY: TDimension; + ScrolledVertically, + ScrolledHorizontally: Boolean; + +begin + ScrolledVertically := False; + ScrolledHorizontally := False; + + if Assigned(Node) and (Node <> FRoot) and HandleAllocated then // We don't want to create the handle if it has not yet been created, see issue #897 + begin + // Make sure all parents of the node are expanded. + Run := Node.Parent; + while Run <> FRoot do + begin + if not (vsExpanded in Run.States) then + ToggleNode(Run); + Run := Run.Parent; + end; + UseColumns := FHeader.UseColumns; + if UseColumns and FHeader.Columns.IsValidColumn(FFocusedColumn) then + R := GetDisplayRect(Node, FFocusedColumn, not (toGridExtensions in FOptions.MiscOptions)) + else + R := GetDisplayRect(Node, NoColumn, not (toGridExtensions in FOptions.MiscOptions)); + + // The returned rectangle can never be empty after the expand code above. + // 1) scroll vertically + OldOffsetY := FOffsetY; + if R.Top < 0 then + begin + if Center then + SetOffsetY(FOffsetY - R.Top + Divide(ClientHeight, 2)) + else + SetOffsetY(FOffsetY - R.Top); + end + else + if (R.Bottom > ClientHeight) or Center then + begin + HScrollBarVisible := (ScrollBarOptions.ScrollBars in [System.UITypes.TScrollStyle.ssBoth, System.UITypes.TScrollStyle.ssHorizontal]) and + (ScrollBarOptions.AlwaysVisible or (FRangeX > ClientWidth)); + if Center then + SetOffsetY(FOffsetY - R.Bottom + Divide(ClientHeight, 2)) + else + SetOffsetY(FOffsetY - R.Bottom + ClientHeight); + // When scrolling up and the horizontal scroll appears because of the operation + // then we have to move up the node the horizontal scrollbar's height too + // in order to avoid that the scroll bar hides the node which we wanted to have in view. + if not UseColumns and not HScrollBarVisible and (FRangeX > ClientWidth) then + SetOffsetY(FOffsetY - GetSystemMetrics(SM_CYHSCROLL)); + end; + ScrolledVertically := OldOffsetY <> FOffsetY; + + if Horizontally then + // 2) scroll horizontally + // Center only if there is enough space for the focused column, otherwise left align, see issue #397. + ScrolledHorizontally := ScrollIntoView(FFocusedColumn, Center and (R.Width <= (ClientWidth - Header.Columns.GetVisibleFixedWidth)), Node); + end; + + Result := ScrolledVertically or ScrolledHorizontally; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.ScaledPixels(pPixels: TDimension): TDimension; + + /// Returns the given pixels scaled to the current dpi assuming that we designed at 96dpi (100%) +begin + Result := MulDiv(pPixels, {$if CompilerVersion > 31}Self.FCurrentPPI{$else}Screen.PixelsPerInch{$ifend}, 96); +end; + +function TBaseVirtualTree.ScrollIntoView(Column: TColumnIndex; Center: Boolean; Node: PVirtualNode = nil): Boolean; + +// Scrolls the columns so that the given column is in the client area and returns True if the columns really have been +// scrolled (e.g. to avoid further updates) else returns False. + +var + ColumnLeft, + ColumnRight: TDimension; + NewOffset, + OldOffset: TDimension; + R: TRect; + +begin + Result := False; + + if FHeader.UseColumns and FHeader.Columns.IsValidColumn(Column) then begin + ColumnLeft := Header.Columns.Items[Column].Left; + ColumnRight := ColumnLeft + Header.Columns.Items[Column].Width; + end else if Assigned(Node) and (toCenterScrollIntoView in FOptions.SelectionOptions) then begin + Center := False; + R := GetDisplayRect(Node, NoColumn, not (toGridExtensions in FOptions.MiscOptions)); + ColumnLeft := R.Left; + ColumnRight := R.Right; + end else + Exit; + + OldOffset := FOffsetX; + NewOffset := FEffectiveOffsetX; + if not (FHeader.UseColumns and (coFixed in Header.Columns[Column].Options)) and (not Center) then + begin + if ColumnRight > ClientWidth then + NewOffset := FEffectiveOffsetX + Min(ColumnRight - ClientWidth, + - (Header.Columns.GetVisibleFixedWidth - ColumnLeft)) + else if ColumnLeft < Header.Columns.GetVisibleFixedWidth then + NewOffset := FEffectiveOffsetX - (Header.Columns.GetVisibleFixedWidth - ColumnLeft); + if NewOffset <> FEffectiveOffsetX then + begin + if UseRightToLeftAlignment then + SetOffsetX(-FRangeX + ClientWidth + NewOffset) + else + SetOffsetX(-NewOffset); + end; + end + else if Center then + begin + NewOffset := FEffectiveOffsetX + ColumnLeft - Divide(Header.Columns.GetVisibleFixedWidth, 2) - Divide(ClientWidth, 2) + Divide(ColumnRight - ColumnLeft, 2); + if NewOffset <> FEffectiveOffsetX then + begin + if UseRightToLeftAlignment then + SetOffsetX(-FRangeX + ClientWidth + NewOffset) + else + SetOffsetX(-NewOffset); + end; + end; + Result := OldOffset <> FOffsetX; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.SelectAll(VisibleOnly: Boolean); + +// Select all nodes in the tree. +// If VisibleOnly is True then only visible nodes are selected. + +var + Run: PVirtualNode; + NextFunction: TGetNextNodeProc; +begin + if not FSelectionLocked and (toMultiSelect in FOptions.SelectionOptions) then + begin + ClearTempCache; + if VisibleOnly then + begin + Run := GetFirstVisible(nil, True); + NextFunction := GetNextVisible; + end + else + begin + Run := GetFirst; + NextFunction := GetNext; + end; + BeginUpdate(); // Improve performance, see issue #690 + try + while Assigned(Run) do + begin + if not(vsSelected in Run.States) then + InternalCacheNode(Run); + Run := NextFunction(Run); + end;//while + if FTempNodeCount > 0 then + AddToSelection(FTempNodeCache, FTempNodeCount); + ClearTempCache; + finally + EndUpdate(); + end;//try..finally + Invalidate; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.Sort(Node: PVirtualNode; Column: TColumnIndex; Direction: TSortDirection; DoInit: Boolean = True); + +// Sorts the given node. The application is queried about how to sort via the OnCompareNodes event. +// Column is simply passed to the the compare function so the application can also sort in a particular column. +// In order to free the application from taking care about the sort direction the parameter Direction is used. +// This way the application can always sort in increasing order, while this method reorders nodes according to this flag. + + //--------------- local functions ------------------------------------------- + + function MergeAscending(A, B: PVirtualNode): PVirtualNode; + + // Merges A and B (which both must be sorted via Compare) into one list. + + var + Dummy: TVirtualNode; + CompareResult: Integer; + begin + // This avoids checking for Result = nil in the loops. + Result := @Dummy; + while Assigned(A) and Assigned(B) do + begin + if OperationCanceled then + CompareResult := 0 + else + CompareResult := DoCompare(A, B, Column); + + if CompareResult <= 0 then + begin + Result.SetNextSibling(A); + Result := A; + A := A.NextSibling; + end + else + begin + Result.SetNextSibling(B); + Result := B; + B := B.NextSibling; + end; + end; + + // Just append the list which is not nil (or set end of result list to nil if both lists are nil). + if Assigned(A) then + Result.SetNextSibling(A) + else + Result.SetNextSibling(B); + // return start of the new merged list + Result := Dummy.NextSibling; + end; + + //--------------------------------------------------------------------------- + + function MergeDescending(A, B: PVirtualNode): PVirtualNode; + + // Merges A and B (which both must be sorted via Compare) into one list. + + var + Dummy: TVirtualNode; + CompareResult: Integer; + + begin + // this avoids checking for Result = nil in the loops + Result := @Dummy; + while Assigned(A) and Assigned(B) do + begin + if OperationCanceled then + CompareResult := 0 + else + CompareResult := DoCompare(A, B, Column); + + if CompareResult >= 0 then + begin + Result.SetNextSibling(A); + Result := A; + A := A.NextSibling; + end + else + begin + Result.SetNextSibling(B); + Result := B; + B := B.NextSibling; + end; + end; + + // Just append the list which is not nil (or set end of result list to nil if both lists are nil). + if Assigned(A) then + Result.SetNextSibling(A) + else + Result.SetNextSibling(B); + // Return start of the newly merged list. + Result := Dummy.NextSibling; + end; + + //--------------------------------------------------------------------------- + + function MergeSortAscending(var Node: PVirtualNode; N: Cardinal): PVirtualNode; + + // Sorts the list of nodes given by Node (which must not be nil). + + var + A, B: PVirtualNode; + + begin + if N > 1 then + begin + A := MergeSortAscending(Node, N div 2); + B := MergeSortAscending(Node, (N + 1) div 2); + Result := MergeAscending(A, B); + end + else + begin + Result := Node; + Node := Node.NextSibling; + Result.SetNextSibling(nil); + end; + end; + + //--------------------------------------------------------------------------- + + function MergeSortDescending(var Node: PVirtualNode; N: Cardinal): PVirtualNode; + + // Sorts the list of nodes given by Node (which must not be nil). + + var + A, B: PVirtualNode; + + begin + if N > 1 then + begin + A := MergeSortDescending(Node, N div 2); + B := MergeSortDescending(Node, (N + 1) div 2); + Result := MergeDescending(A, B); + end + else + begin + Result := Node; + Node := Node.NextSibling; + Result.SetNextSibling(nil); + end; + end; + + //--------------- end local functions --------------------------------------- + +var + Run: PVirtualNode; + Index: Cardinal; + +begin + InterruptValidation; + if tsEditPending in FStates then + begin + StopTimer(EditTimer); + DoStateChange([], [tsEditPending]); + end; + + if not (tsEditing in FStates) or DoEndEdit then + begin + if Node = nil then + Node := FRoot; + if vsHasChildren in Node.States then + begin + if (Node.ChildCount = 0) and DoInit then + InitChildren(Node); + // Make sure the children are valid, so they can be sorted at all. + if DoInit and (Node.ChildCount > 0) then + ValidateChildren(Node, False); + // Child count might have changed. + if Node.ChildCount > 1 then + begin + StartOperation(okSortNode); + try + // Sort the linked list, check direction flag only once. + if Direction = sdAscending then + Node.SetFirstChild(MergeSortAscending(Node.FirstChild, Node.ChildCount)) + else + Node.SetFirstChild(MergeSortDescending(Node.FirstChild, Node.ChildCount)); + finally + EndOperation(okSortNode); + end; + // Consolidate the child list finally. + Run := Node.FirstChild; + Run.SetPrevSibling(nil); + Index := 0; + repeat + Run.SetIndex(Index); + System.Inc(Index); + if Run.NextSibling = nil then + Break; + Run.NextSibling.SetPrevSibling(Run); + Run := Run.NextSibling; + until False; + Node.SetLastChild(Run); + + InvalidateCache; + end; + if FUpdateCount = 0 then + begin + ValidateCache; + Invalidate; + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.SortTree(Column: TColumnIndex; Direction: TSortDirection; DoInit: Boolean = True); + + //--------------- local function -------------------------------------------- + + procedure DoSort(Node: PVirtualNode); + + // Recursively sorts Node and its child nodes. + + var + Run: PVirtualNode; + + begin + Sort(Node, Column, Direction, DoInit); + // Recurse to next level + Run := Node.FirstChild; + while Assigned(Run) and not FOperationCanceled do + begin + if DoInit and not (vsInitialized in Run.States) then + InitNode(Run); + if (vsInitialized in Run.States) and (not (toAutoSort in TreeOptions.AutoOptions) or Expanded[Run]) then // There is no need to sort collapsed branches + DoSort(Run); + Run := Run.NextSibling; + end; + end; + + //--------------- end local function ---------------------------------------- + +begin + if RootNode.TotalCount <= 2 then + Exit;//Nothing to do if there are one or zero nodes. RootNode.TotalCount is 1 if there are no nodes in the treee as the root node counts too here. + + if not Assigned(FRoot.FirstChild) then + Exit; // Sorting should not initialize the root nodes + + // Instead of wrapping the sort using BeginUpdate/EndUpdate simply the update counter + // is modified. Otherwise the EndUpdate call will recurse here. + System.Inc(FUpdateCount); + try + if Column > InvalidColumn then + begin + StartOperation(okSortTree); + try + DoSort(FRoot); + finally + EndOperation(okSortTree); + end; + end; + InvalidateCache; + finally + if FUpdateCount > 0 then + System.Dec(FUpdateCount); + if FUpdateCount = 0 then + begin + ValidateCache; + Invalidate; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.ToggleNode(Node: PVirtualNode); + +// Changes a node's expand state to the opposite state. + +var + Child, + FirstVisible: PVirtualNode; + HeightDelta, + StepsR1, + StepsR2: TDimension; + Steps: Integer; + TogglingTree, + ChildrenInView, + NeedFullInvalidate, + NeedUpdate, + NodeInView, + PosHoldable, + TotalFit: Boolean; + ToggleData: TToggleAnimationData; + + //--------------- local function -------------------------------------------- + + procedure PrepareAnimation; + + // Prepares ToggleData. + + var + R: TRect; + S: TDimension; + M: TToggleAnimationMode; + + begin + with ToggleData do + begin + Window := Handle; + DC := TControlCanvas.Create; + DC.Control := Self; + + if (toShowBackground in FOptions.PaintOptions) and Assigned(FBackground.Graphic) then + Self.Brush.Style := bsClear + else + begin + Self.Brush.Style := bsSolid; + Self.Brush.Color := FColors.BackGroundColor; + end; + + Brush := Self.Brush; + + if (Mode1 <> tamNoScroll) and (Mode2 <> tamNoScroll) then + begin + if StepsR1 < StepsR2 then + begin + // As the primary rectangle is always R1 we will get a much smoother + // animation if R1 is the one that will be scrolled more. + R := R2; + R2 := R1; + R1 := R; + + M := Mode2; + Mode2 := Mode1; + Mode1 := M; + + S := StepsR2; + StepsR2 := StepsR1; + StepsR1 := S; + end; + ScaleFactor := StepsR2 / StepsR1; + MissedSteps := 0; + end; + + if Mode1 <> tamNoScroll then + Steps := StepsR1 + else + Steps := StepsR2; + end; + end; + + //--------------- end local function ---------------------------------------- + +begin + Assert(Assigned(Node), 'Node must not be nil.'); + + TogglingTree := tsToggling in FStates; + ChildrenInView := False; + HeightDelta := 0; + NeedFullInvalidate := False; + NeedUpdate := False; + NodeInView := False; + PosHoldable := False; + TotalFit := False; + + // We don't need to switch the expand state if the node is being deleted otherwise some + // updates (e.g. visible node count) are done twice with disasterous results). + if [vsDeleting, vsToggling] * Node.States = [] then + begin + try + DoStateChange([tsToggling]); + Include(Node.States, vsToggling); + + if vsExpanded in Node.States then + begin + if DoCollapsing(Node) then + begin + NeedUpdate := True; + + // Calculate the height delta right now as we need it for toChildrenAbove anyway. + HeightDelta := -Node.TotalHeight + NodeHeight[Node]; + if (FUpdateCount = 0) and (toAnimatedToggle in FOptions.AnimationOptions) and not + (tsCollapsing in FStates) then + begin + if tsHint in Self.FStates then + Application.CancelHint; + UpdateWindow(); + + // animated collapsing + with ToggleData do + begin + // Determine the animation behaviour and rectangle. If toChildrenAbove is set, the behaviour is depending + // on the position of the node to be collapsed. + R1 := GetDisplayRect(Node, NoColumn, False); + Mode2 := tamNoScroll; + if toChildrenAbove in FOptions.PaintOptions then + begin + PosHoldable := (FOffsetY + (Node.TotalHeight - NodeHeight[Node])) <= 0; + NodeInView := R1.Top < ClientHeight; + + StepsR1 := 0; + if NodeInView then + begin + if PosHoldable or not (toAdvancedAnimatedToggle in FOptions.AnimationOptions) then + begin + // Scroll the child nodes down. + Mode1 := tamScrollDown; + R1.Bottom := R1.Top; + R1.Top := 0; + StepsR1 := Min(R1.Bottom - R1.Top + 1, Node.TotalHeight - NodeHeight[Node]); + end + else + begin + // The position cannot be kept. So scroll the node up to its future position. + Mode1 := tamScrollUp; + R1.Top := Max(0, R1.Top + HeightDelta); + R1.Bottom := ClientHeight; + StepsR1 := FOffsetY - HeightDelta; + end; + end; + end + else + begin + if (FRangeY + FOffsetY - R1.Bottom + HeightDelta >= ClientHeight - R1.Bottom) or + (FRangeY <= ClientHeight) or (FOffsetY = 0) or not + (toAdvancedAnimatedToggle in FOptions.AnimationOptions) then + begin + // Do a simple scroll up over the child nodes. + Mode1 := tamScrollUp; + Inc(R1.Top, NodeHeight[Node]); + R1.Bottom := ClientHeight; + StepsR1 := Min(R1.Bottom - R1.Top + 1, -HeightDelta); + end + else + begin + // Scroll the node down to its future position. As FOffsetY will change we need to invalidate the + // whole tree. + Mode1 := tamScrollDown; + StepsR1 := Min(-FOffsetY, ClientHeight - FRangeY -FOffsetY - HeightDelta); + R1.Top := 0; + R1.Bottom := Min(ClientHeight, R1.Bottom + Steps); + NeedFullInvalidate := True; + end; + end; + + // No animation necessary if the node is below the current client height. + if R1.Top < ClientHeight then + begin + PrepareAnimation; + try + Animate(Steps, FAnimationDuration, ToggleCallback, @ToggleData); + finally + DC.Free; + end; + end; + end; + end; + + // collapse the node + AdjustTotalHeight(Node, IfThen(IsEffectivelyFiltered[Node], 0, NodeHeight[Node])); + if FullyVisible[Node] then + System.Dec(FVisibleCount, CountVisibleChildren(Node)); + Exclude(Node.States, vsExpanded); + DoCollapsed(Node); + + // Remove child nodes now, if enabled. + if (toAutoFreeOnCollapse in FOptions.AutoOptions) and (Node.ChildCount > 0) then + begin + DeleteChildren(Node); + Include(Node.States, vsHasChildren); + end; + end; + end + else + if DoExpanding(Node) then + begin + NeedUpdate := True; + // expand the node, need to adjust the height + if not (vsInitialized in Node.States) then + InitNode(Node); + if (vsHasChildren in Node.States) and (Node.ChildCount = 0) then + InitChildren(Node); + + // Avoid setting the vsExpanded style if there are no child nodes. + if Node.ChildCount > 0 then + begin + // Iterate through the child nodes without initializing them. We have to determine the entire height. + Child := Node.FirstChild; + repeat + if vsVisible in Child.States then + begin + // Ensure the item height is measured + MeasureItemHeight(Canvas, Child); + + Inc(HeightDelta, Child.TotalHeight); + end; + Child := Child.NextSibling; + until Child = nil; + + // Getting the display rectangle is already done here as it is needed for toChildrenAbove in any case. + if (toChildrenAbove in FOptions.PaintOptions) or (FUpdateCount = 0) then + begin + with ToggleData do + begin + R1 := GetDisplayRect(Node, NoColumn, False); + Mode2 := tamNoScroll; + TotalFit := HeightDelta + NodeHeight[Node] <= ClientHeight; + + if toChildrenAbove in FOptions.PaintOptions then + begin + // The main goal with toChildrenAbove being set is to keep the nodes visual position so the user does + // not get confused. Therefore we need to scroll the view when the expanding is done. + PosHoldable := TotalFit and (FRangeY - ClientHeight >= 0) ; + ChildrenInView := (R1.Top - HeightDelta) >= 0; + NodeInView := R1.Bottom <= ClientHeight; + end + else + begin + PosHoldable := TotalFit; + ChildrenInView := R1.Bottom + HeightDelta <= ClientHeight; + end; + + R1.Bottom := ClientHeight; + end; + end; + + if FUpdateCount = 0 then + begin + // Do animated expanding if enabled. + if (ToggleData.R1.Top < ClientHeight) and ([tsPainting, tsExpanding] * FStates = []) and + (toAnimatedToggle in FOptions.AnimationOptions)then + begin + if tsHint in Self.FStates then + Application.CancelHint; + UpdateWindow(); + + // animated expanding + with ToggleData do + begin + if toChildrenAbove in FOptions.PaintOptions then + begin + // At first check if we hold the position, which is the most common case. + if not (toAdvancedAnimatedToggle in FOptions.AnimationOptions) or + (PosHoldable and ( (NodeInView and ChildrenInView) or not + (toAutoScrollOnExpand in FOptions.AutoOptions) )) then + begin + Mode1 := tamScrollUp; + R1 := Rect(R1.Left, 0, R1.Right, R1.Top); + StepsR1 := Min(HeightDelta, R1.Bottom); + end + else + begin + // If we will not hold the node's visual position we mostly scroll in both directions. + Mode1 := tamScrollDown; + Mode2 := tamScrollUp; + R2 := Rect(R1.Left, 0, R1.Right, R1.Top); + if not (toAutoScrollOnExpand in FOptions.AutoOptions) then + begin + // If we shall not or cannot scroll to the desired extent we calculate the new position (with + // max FOffsetY applied) and animate it that way. + StepsR1 := -FOffsetY - Max(FRangeY + HeightDelta - ClientHeight, 0) + HeightDelta; + if (FRangeY + HeightDelta - ClientHeight) <= 0 then + Mode2 := tamNoScroll + else + StepsR2 := Min(FRangeY + HeightDelta - ClientHeight, R2.Bottom); + end + else + begin + if TotalFit and NodeInView and (FRangeY + HeightDelta > ClientHeight) then + begin + // If the whole subtree will fit into the client area and the node is currently fully visible, + // the first child will be made the top node if possible. + if HeightDelta >= R1.Top then + StepsR1 := Abs(R1.Top - HeightDelta) + else + StepsR1 := ClientHeight - FRangeY; + end + else + if FRangeY + HeightDelta <= ClientHeight then + begin + // We cannot make the first child the top node as we cannot scroll to that extent, + // so we do a simple scroll down. + Mode2 := tamNoScroll; + StepsR1 := HeightDelta; + end + else + // If the subtree does not fit into the client area at once, the expanded node will + // be made the bottom node. + StepsR1 := ClientHeight - R1.Top - NodeHeight[Node]; + + if Mode2 <> tamNoScroll then + begin + if StepsR1 > 0 then + StepsR2 := Min(R1.Top, HeightDelta - StepsR1) + else + begin + // If the node is already at the bottom scrolling is needed. + Mode1 := tamNoScroll; + StepsR2 := Min(HeightDelta, R1.Bottom); + end; + end; + end; + end; + end + else + begin + // toChildrenAbove is not set. + if (PosHoldable and ChildrenInView) or not (toAutoScrollOnExpand in FOptions.AutoOptions) or not + (toAdvancedAnimatedToggle in FOptions.AnimationOptions) or (R1.Top <= 0) then + begin + // If the node will stay at its visual position, do a simple down-scroll. + Mode1 := tamScrollDown; + Inc(R1.Top, NodeHeight[Node]); + StepsR1 := Min(R1.Bottom - R1.Top, HeightDelta); + end + else + begin + // We will not hold the nodes visual position so perform a double scroll. + Mode1 := tamScrollUp; + Mode2 := tamScrollDown; + + R1.Bottom := R1.Top + NodeHeight[Node] + 1; + R1.Top := 0; + R2 := Rect(R1.Left, R1.Bottom, R1.Right, ClientHeight); + + StepsR1 := Min(HeightDelta - (ClientHeight - R2.Top), R1.Bottom - NodeHeight[Node]); + StepsR2 := ClientHeight - R2.Top; + end; + end; + + if ClientHeight >= R1.Top then + begin + PrepareAnimation; + try + Animate(Steps, FAnimationDuration, ToggleCallback, @ToggleData); + finally + DC.Free; + end; + end; + end; + end; + if toAutoSort in FOptions.AutoOptions then + Sort(Node, FHeader.SortColumn, FHeader.SortDirection, False); + end;// if UpdateCount = 0 + + Include(Node.States, vsExpanded); + AdjustTotalHeight(Node, HeightDelta, True); + if FullyVisible[Node] then + System.Inc(FVisibleCount, CountVisibleChildren(Node)); + + DoExpanded(Node); + end; + end; + + if NeedUpdate then + begin + InvalidateCache; + if FUpdateCount = 0 then + begin + ValidateCache; + if Node.ChildCount > 0 then + begin + UpdateRanges; + UpdateScrollBars(True); + if [tsPainting, tsExpanding] * FStates = [] then + begin + if (vsExpanded in Node.States) and ((toAutoScrollOnExpand in FOptions.AutoOptions) or + (toChildrenAbove in FOptions.PaintOptions)) then + begin + if toChildrenAbove in FOptions.PaintOptions then + begin + NeedFullInvalidate := True; + if (PosHoldable and ChildrenInView and NodeInView) or not + (toAutoScrollOnExpand in FOptions.AutoOptions) then + SetOffsetY(FOffsetY - HeightDelta) + else + if TotalFit and NodeInView then + begin + FirstVisible := GetFirstVisible(Node, True); + if Assigned(FirstVisible) then // otherwise there is no visible child at all + SetOffsetY(FOffsetY - GetDisplayRect(FirstVisible, NoColumn, False).Top); + end + else + BottomNode := Node; + end + else + begin + // Scroll as much child nodes into view as possible if the node has been expanded. + if PosHoldable then + NeedFullInvalidate := ScrollIntoView(GetLastVisible(Node, True), False) + else + begin + TopNode := Node; + NeedFullInvalidate := True; + end; + end; + end + else + begin + // If we have collapsed the node or toAutoScrollOnExpand is not set, we try to keep the nodes + // visual position. + if toChildrenAbove in FOptions.PaintOptions then + SetOffsetY(FOffsetY - HeightDelta); + NeedFullInvalidate := True; + end; + end; + + //UpdateScrollBars(True); Moved up + + // Check for automatically scrolled tree. + if NeedFullInvalidate then + Invalidate + else + InvalidateToBottom(Node); + end + else + InvalidateNode(Node); + end + else + begin + UpdateRanges; + UpdateScrollBars(True); + end; + end; + + finally + Exclude(Node.States, vsToggling); + if not TogglingTree then + DoStateChange([], [tsToggling]); + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.UpdateHorizontalRange; + +begin + if FHeader.UseColumns then + SetRangeX(FHeader.Columns.TotalWidth) + else + SetRangeX(GetMaxRightExtend); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.UpdateHorizontalScrollBar(DoRepaint: Boolean); + +var + ScrollInfo: TScrollInfo; + +begin + UpdateHorizontalRange; + + if IsUpdating or not HandleAllocated then + Exit; + + // Adjust effect scroll offset depending on bidi mode. + if UseRightToLeftAlignment then + FEffectiveOffsetX := FRangeX - ClientWidth + FOffsetX + else + FEffectiveOffsetX := -FOffsetX; + + if FScrollBarOptions.ScrollBars in [System.UITypes.TScrollStyle.ssHorizontal, System.UITypes.TScrollStyle.ssBoth] then + begin + ZeroMemory (@ScrollInfo, SizeOf(ScrollInfo)); + ScrollInfo.cbSize := SizeOf(ScrollInfo); + ScrollInfo.fMask := SIF_ALL; + GetScrollInfo(SB_HORZ, ScrollInfo); + + if (FRangeX > ClientWidth) or FScrollBarOptions.AlwaysVisible then + begin + DoShowScrollBar(SB_HORZ, True); + + ScrollInfo.nMin := 0; + ScrollInfo.nMax := FRangeX; + ScrollInfo.nPos := FEffectiveOffsetX; + ScrollInfo.nPage := Max(0, ClientWidth + 1); + + ScrollInfo.fMask := SIF_ALL or ScrollMasks[FScrollBarOptions.AlwaysVisible]; + SetScrollInfo(SB_HORZ, ScrollInfo, DoRepaint); // 1 app freeze seen here in TreeSize 8.1.0 after ScaleForPpi() + if DoRepaint then + RedrawWindow(nil, 0, RDW_FRAME or RDW_INVALIDATE); // Fixes issue #698 + end + else + begin + ScrollInfo.nMin := 0; + ScrollInfo.nMax := 0; + ScrollInfo.nPos := 0; + ScrollInfo.nPage := 0; + DoShowScrollBar(SB_HORZ, False); + SetScrollInfo(SB_HORZ, ScrollInfo, False); + end; + + // Since the position is automatically changed if it doesn't meet the range + // we better read the current position back to stay synchronized. + FEffectiveOffsetX := GetScrollPos(SB_HORZ); + if UseRightToLeftAlignment then + SetOffsetX(-FRangeX + ClientWidth + FEffectiveOffsetX) + else + SetOffsetX(-FEffectiveOffsetX); + end + else + begin + DoShowScrollBar(SB_HORZ, False); + + // Reset the current horizontal offset to account for window resize etc. + SetOffsetX(FOffsetX); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.UpdateRanges; + +begin + UpdateVerticalRange; + UpdateHorizontalRange; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.UpdateScrollBars(DoRepaint: Boolean); + +// adjusts scrollbars to reflect current size and paint offset of the tree + +begin + if HandleAllocated then + begin + UpdateVerticalScrollBar(DoRepaint); + UpdateHorizontalScrollBar(DoRepaint); + Perform(CM_UPDATE_VCLSTYLE_SCROLLBARS,0,0); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.UpdateStyleElements; +begin + inherited; + UpdateHeaderRect; + FHeader.Columns.PaintHeader(Canvas, FHeaderRect, Point(0,0)); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.UpdateVerticalRange; + +begin + // Total node height includes the height of the invisible root node. + FRangeY := FRoot.TotalHeight - FRoot.NodeHeight + FBottomSpace; +end; + +//---------------------------------------------------------------------------------------------------------------------- + + procedure TBaseVirtualTree.UpdateVerticalScrollBar(DoRepaint: Boolean); + +var + ScrollInfo: TScrollInfo; + +begin + UpdateVerticalRange; + + if (IsUpdating) then + Exit; + Assert(GetCurrentThreadId = MainThreadId, 'UI controls like ' + Classname + ' and its scrollbars should only be manipulated through the main thread.'); + + if FScrollBarOptions.ScrollBars in [TScrollStyle.ssVertical, TScrollStyle.ssBoth] then + begin + ScrollInfo.cbSize := SizeOf(ScrollInfo); + ScrollInfo.fMask := SIF_ALL; + GetScrollInfo(SB_VERT, ScrollInfo); + + if (FRangeY > ClientHeight) or FScrollBarOptions.AlwaysVisible then + begin + DoShowScrollBar(SB_VERT, True); + + ScrollInfo.nMin := 0; + ScrollInfo.nMax := IfThen(FRangeY < MaxInt, FRangeY, MaxInt); // TScrollInfo values are signed 32bit only + ScrollInfo.nPos := -FOffsetY; + ScrollInfo.nPage := Max(0, ClientHeight + 1); + + ScrollInfo.fMask := SIF_ALL or ScrollMasks[FScrollBarOptions.AlwaysVisible]; + SetScrollInfo(SB_VERT, ScrollInfo, DoRepaint); + end + else + begin + ScrollInfo.nMin := 0; + ScrollInfo.nMax := 0; + ScrollInfo.nPos := 0; + ScrollInfo.nPage := 0; + DoShowScrollBar(SB_VERT, False); + SetScrollInfo(SB_VERT, ScrollInfo, False); + end; + + // Since the position is automatically changed if it doesn't meet the range + // we better read the current position back to stay synchronized. + SetOffsetY(-GetScrollPos(SB_VERT)); + end + else + begin + DoShowScrollBar(SB_VERT, False); + + // Reset the current vertical offset to account for window resize etc. + SetOffsetY(FOffsetY); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseVirtualTree.UseRightToLeftReading: Boolean; + +// The tree can handle right-to-left reading also on non-middle-east systems, so we cannot use the same function as +// it is implemented in TControl. + +begin + Result := BiDiMode <> bdLeftToRight; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.ValidateChildren(Node: PVirtualNode; Recursive: Boolean); + +// Ensures that the children of the given node (and all their children, if Recursive is True) are initialized. +// Node must already be initialized + +var + Child: PVirtualNode; + +begin + if Node = nil then + Node := FRoot; + + if (vsHasChildren in Node.States) and (Node.ChildCount = 0) then + InitChildren(Node); + Child := Node.FirstChild; + while Assigned(Child) do + begin + ValidateNode(Child, Recursive); + Child := Child.NextSibling; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseVirtualTree.ValidateNode(Node: PVirtualNode; Recursive: Boolean); + +// Ensures that the given node (and all its children, if Recursive is True) are initialized. + +var + Child: PVirtualNode; + +begin + if Node = nil then + Node := FRoot + else + if not (vsInitialized in Node.States) then + InitNode(Node); + + if Recursive then + begin + if (vsHasChildren in Node.States) and (Node.ChildCount = 0) then + InitChildren(Node); + Child := Node.FirstChild; + while Assigned(Child) do + begin + ValidateNode(Child, Recursive); + Child := Child.NextSibling; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +initialization + +finalization + FinalizeGlobalStructures(); + +end. diff --git a/components/virtualtreeview/Source/VirtualTrees.Classes.pas b/components/virtualtreeview/Source/VirtualTrees.Classes.pas index 444c536ca..856f28c4f 100644 --- a/components/virtualtreeview/Source/VirtualTrees.Classes.pas +++ b/components/virtualtreeview/Source/VirtualTrees.Classes.pas @@ -1,4 +1,4 @@ -unit VirtualTrees.Classes; +unit VirtualTrees.Classes; // 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 @@ -108,8 +108,8 @@ procedure TBufferedRawByteString.Add(const S: RawByteString); FPosition := FStart + LastOffset; FEnd := FStart + NewLen; end; - Move(PAnsiChar(S)^, FPosition^, Len); - Inc(FPosition, Len); + System.Move(PAnsiChar(S)^, FPosition^, Len); + System.Inc(FPosition, Len); end; //---------------------------------------------------------------------------------------------------------------------- @@ -133,9 +133,9 @@ procedure TBufferedRawByteString.AddNewLine; FEnd := FStart + NewLen; end; FPosition^ := #13; - Inc(FPosition); + System.Inc(FPosition); FPosition^ := #10; - Inc(FPosition); + System.Inc(FPosition); end; //----------------- TBufferedString -------------------------------------------------------------------------------- @@ -179,8 +179,8 @@ procedure TBufferedString.Add(const S: string); FPosition := FStart + LastOffset; FEnd := FStart + NewLen; end; - Move(PWideChar(S)^, FPosition^, 2 * Len); - Inc(FPosition, Len); + System.Move(PWideChar(S)^, FPosition^, 2 * Len); + System.Inc(FPosition, Len); end; //---------------------------------------------------------------------------------------------------------------------- @@ -204,9 +204,9 @@ procedure TBufferedString.AddNewLine; FEnd := FStart + NewLen; end; FPosition^ := #13; - Inc(FPosition); + System.Inc(FPosition); FPosition^ := #10; - Inc(FPosition); + System.Inc(FPosition); end; diff --git a/components/virtualtreeview/Source/VirtualTrees.ClipBoard.pas b/components/virtualtreeview/Source/VirtualTrees.ClipBoard.pas index 197eed237..017a73625 100644 --- a/components/virtualtreeview/Source/VirtualTrees.ClipBoard.pas +++ b/components/virtualtreeview/Source/VirtualTrees.ClipBoard.pas @@ -1,407 +1,419 @@ -unit VirtualTrees.ClipBoard; - -// 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/ -// -// Alternatively, you may redistribute this library, use and/or modify it under the terms of the -// GNU Lesser General Public License as published by the Free Software Foundation; -// either version 2.1 of the License, or (at your option) any later version. -// You may obtain a copy of the LGPL at http://www.gnu.org/copyleft/. -// -// 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. -// -// The original code is VirtualTrees.pas, released September 30, 2000. -// -// The initial developer of the original code is digital publishing AG (Munich, Germany, www.digitalpublishing.de), -// written by Mike Lischke (public@soft-gems.net, www.soft-gems.net). -// -// Portions created by digital publishing AG are Copyright -// (C) 1999-2001 digital publishing AG. All Rights Reserved. -//---------------------------------------------------------------------------------------------------------------------- - - -interface - -{$WARN UNSAFE_TYPE OFF} +unit VirtualTrees.ClipBoard; + +// 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/ +// +// Alternatively, you may redistribute this library, use and/or modify it under the terms of the +// GNU Lesser General Public License as published by the Free Software Foundation; +// either version 2.1 of the License, or (at your option) any later version. +// You may obtain a copy of the LGPL at http://www.gnu.org/copyleft/. +// +// 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. +// +// The original code is VirtualTrees.pas, released September 30, 2000. +// +// The initial developer of the original code is digital publishing AG (Munich, Germany, www.digitalpublishing.de), +// written by Mike Lischke (public@soft-gems.net, www.soft-gems.net). +// +// Portions created by digital publishing AG are Copyright +// (C) 1999-2001 digital publishing AG. All Rights Reserved. +//---------------------------------------------------------------------------------------------------------------------- + + +interface + +{$WARN UNSAFE_TYPE OFF} {$WARN UNSAFE_CAST OFF} - -uses - Winapi.Windows, - Winapi.ActiveX, - System.Classes, - VirtualTrees; - -type - TClipboardFormatEntry = record - ID: Word; - Description: string; - end; - -var - ClipboardDescriptions: array [1..CF_MAX - 1] of TClipboardFormatEntry = ( - (ID: CF_TEXT; Description: 'Plain text'), // Do not localize - (ID: CF_BITMAP; Description: 'Windows bitmap'), // Do not localize - (ID: CF_METAFILEPICT; Description: 'Windows metafile'), // Do not localize - (ID: CF_SYLK; Description: 'Symbolic link'), // Do not localize - (ID: CF_DIF; Description: 'Data interchange format'), // Do not localize - (ID: CF_TIFF; Description: 'Tiff image'), // Do not localize - (ID: CF_OEMTEXT; Description: 'OEM text'), // Do not localize - (ID: CF_DIB; Description: 'DIB image'), // Do not localize - (ID: CF_PALETTE; Description: 'Palette data'), // Do not localize - (ID: CF_PENDATA; Description: 'Pen data'), // Do not localize - (ID: CF_RIFF; Description: 'Riff audio data'), // Do not localize - (ID: CF_WAVE; Description: 'Wav audio data'), // Do not localize - (ID: CF_UNICODETEXT; Description: 'Unicode text'), // Do not localize - (ID: CF_ENHMETAFILE; Description: 'Enhanced metafile image'), // Do not localize - (ID: CF_HDROP; Description: 'File name(s)'), // Do not localize - (ID: CF_LOCALE; Description: 'Locale descriptor'), // Do not localize - (ID: CF_DIBV5; Description: 'DIB image V5') // Do not localize - ); - - -// OLE Clipboard and drag'n drop helper -procedure EnumerateVTClipboardFormats(TreeClass: TVirtualTreeClass; const List: TStrings); overload; -procedure EnumerateVTClipboardFormats(TreeClass: TVirtualTreeClass; var Formats: TFormatEtcArray); overload; -function GetVTClipboardFormatDescription(AFormat: Word): string; -procedure RegisterVTClipboardFormat(AFormat: Word; TreeClass: TVirtualTreeClass; Priority: Cardinal); overload; -function RegisterVTClipboardFormat(const Description: string; TreeClass: TVirtualTreeClass; Priority: Cardinal; - tymed: Integer = TYMED_HGLOBAL; ptd: PDVTargetDevice = nil; - dwAspect: Integer = DVASPECT_CONTENT; lindex: Integer = -1): Word; overload; - -//----------------- TClipboardFormats ---------------------------------------------------------------------------------- - -type - TClipboardFormatListEntry = class - public - Description: string; // The string used to register the format with Winapi.Windows. - TreeClass: TVirtualTreeClass; // The tree class which supports rendering this format. - Priority: Cardinal; // Number which determines the order of formats used in IDataObject. - FormatEtc: TFormatEtc; // The definition of the format in the IDataObject. - end; - - TClipboardFormatList = class - strict private - class function GetList(): TList; static; - class property List: TList read GetList; - protected - class procedure Sort; - public - class procedure Add(const FormatString: string; AClass: TVirtualTreeClass; Priority: Cardinal; AFormatEtc: TFormatEtc); - class procedure Clear; - class procedure EnumerateFormats(TreeClass: TVirtualTreeClass; var Formats: TFormatEtcArray; const AllowedFormats: TClipboardFormats = nil); overload; - class procedure EnumerateFormats(TreeClass: TVirtualTreeClass; const Formats: TStrings); overload; - class function FindFormat(const FormatString: string): TClipboardFormatListEntry; overload; - class function FindFormat(const FormatString: string; var Fmt: Word): TVirtualTreeClass; overload; - class function FindFormat(Fmt: Word; var Description: string): TVirtualTreeClass; overload; - end; - - -implementation - -uses - System.SysUtils; - -var - _List: TList = nil; //Note - not using class constructors as they are not supported on C++ Builder. See also issue # - -procedure EnumerateVTClipboardFormats(TreeClass: TVirtualTreeClass; const List: TStrings); - -begin - TClipboardFormatList.EnumerateFormats(TreeClass, List); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure EnumerateVTClipboardFormats(TreeClass: TVirtualTreeClass; var Formats: TFormatEtcArray); - -begin - TClipboardFormatList.EnumerateFormats(TreeClass, Formats); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function GetVTClipboardFormatDescription(AFormat: Word): string; - -begin - if TClipboardFormatList.FindFormat(AFormat, Result) = nil then - Result := ''; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure RegisterVTClipboardFormat(AFormat: Word; TreeClass: TVirtualTreeClass; Priority: Cardinal); - -// Registers the given clipboard format for the given TreeClass. - -var - I: Integer; - Buffer: array[0..2048] of Char; - FormatEtc: TFormatEtc; - -begin - - // Assumes a HGlobal format. - FormatEtc.cfFormat := AFormat; - FormatEtc.ptd := nil; - FormatEtc.dwAspect := DVASPECT_CONTENT; - FormatEtc.lindex := -1; - FormatEtc.tymed := TYMED_HGLOBAL; - - // Determine description string of the given format. For predefined formats we need the lookup table because they - // don't have a description string. For registered formats the description string is the string which was used - // to register them. - if AFormat < CF_MAX then - begin - for I := 1 to High(ClipboardDescriptions) do - if ClipboardDescriptions[I].ID = AFormat then - begin - TClipboardFormatList.Add(ClipboardDescriptions[I].Description, TreeClass, Priority, FormatEtc); - Break; - end; - end - else - begin - GetClipboardFormatName(AFormat, Buffer, Length(Buffer)); - TClipboardFormatList.Add(Buffer, TreeClass, Priority, FormatEtc); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function RegisterVTClipboardFormat(const Description: string; TreeClass: TVirtualTreeClass; Priority: Cardinal; - tymed: Integer = TYMED_HGLOBAL; ptd: PDVTargetDevice = nil; dwAspect: Integer = DVASPECT_CONTENT; - lindex: Integer = -1): Word; - -// Alternative method to register a certain clipboard format for a given tree class. Registration with the -// clipboard is done here too and the assigned ID returned by the function. -// tymed may contain or'ed TYMED constants which allows to register several storage formats for one clipboard format. - -var - FormatEtc: TFormatEtc; - -begin - Result := RegisterClipboardFormat(PChar(Description)); - FormatEtc.cfFormat := Result; - FormatEtc.ptd := ptd; - FormatEtc.dwAspect := dwAspect; - FormatEtc.lindex := lindex; - FormatEtc.tymed := tymed; - TClipboardFormatList.Add(Description, TreeClass, Priority, FormatEtc); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -class procedure TClipboardFormatList.Sort; - -// Sorts all entry for priority (increasing priority value). - - //--------------- local function -------------------------------------------- - procedure QuickSort(L, R: Integer); - - var - I, J: Integer; - P, T: TClipboardFormatListEntry; - - begin - repeat - I := L; - J := R; - P := _List[(L + R) shr 1]; - repeat - while TClipboardFormatListEntry(_List[I]).Priority < P.Priority do - Inc(I); - while TClipboardFormatListEntry(_List[J]).Priority > P.Priority do - Dec(J); - if I <= J then - begin - T := List[I]; - _List[I] := _List[J]; - _List[J] := T; - Inc(I); - Dec(J); - end; - until I > J; - if L < J then - QuickSort(L, J); - L := I; - until I >= R; - end; - //--------------- end local function ---------------------------------------- - -begin - if List.Count > 1 then - QuickSort(0, List.Count - 1); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -class procedure TClipboardFormatList.Add(const FormatString: string; AClass: TVirtualTreeClass; Priority: Cardinal; AFormatEtc: TFormatEtc); - -// Adds the given data to the internal list. The priority value is used to sort formats for importance. Larger priority -// values mean less priority. - -var - Entry: TClipboardFormatListEntry; - -begin - Entry := TClipboardFormatListEntry.Create; - Entry.Description := FormatString; - Entry.TreeClass := AClass; - Entry.Priority := Priority; - Entry.FormatEtc := AFormatEtc; - List.Add(Entry); - - Sort; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -class procedure TClipboardFormatList.Clear; - -var - I: Integer; - -begin - if Assigned(_List) then begin - for I := 0 to _List.Count - 1 do - TClipboardFormatListEntry(List[I]).Free; - _List.Clear; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -class procedure TClipboardFormatList.EnumerateFormats(TreeClass: TVirtualTreeClass; var Formats: TFormatEtcArray; const AllowedFormats: TClipboardFormats = nil); - -// Returns a list of format records for the given class. If assigned the AllowedFormats is used to limit the -// enumerated formats to those described in the list. - -var - I, Count: Integer; - Entry: TClipboardFormatListEntry; - -begin - SetLength(Formats, List.Count); - Count := 0; - for I := 0 to List.Count - 1 do - begin - Entry := List[I]; - // Does the tree class support this clipboard format? - if TreeClass.InheritsFrom(Entry.TreeClass) then - begin - // Is this format allowed to be included? - if (AllowedFormats = nil) or (AllowedFormats.IndexOf(Entry.Description) > -1) then - begin - // The list could change before we use the FormatEtc so it is best not to pass a pointer to the true FormatEtc - // structure. Instead make a copy and send that. - Formats[Count] := Entry.FormatEtc; - Inc(Count); - end; - end; - end; - SetLength(Formats, Count); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -class procedure TClipboardFormatList.EnumerateFormats(TreeClass: TVirtualTreeClass; const Formats: TStrings); - -// Returns a list of format descriptions for the given class. - -var - I: Integer; - Entry: TClipboardFormatListEntry; - -begin - for I := 0 to List.Count - 1 do - begin - Entry := List[I]; - if TreeClass.InheritsFrom(Entry.TreeClass) then - Formats.Add(Entry.Description); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -class function TClipboardFormatList.FindFormat(const FormatString: string): TClipboardFormatListEntry; - -var - I: Integer; - Entry: TClipboardFormatListEntry; - -begin - Result := nil; - for I := List.Count - 1 downto 0 do - begin - Entry := List[I]; - if CompareText(Entry.Description, FormatString) = 0 then - begin - Result := Entry; - Break; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -class function TClipboardFormatList.FindFormat(const FormatString: string; var Fmt: Word): TVirtualTreeClass; - -var - I: Integer; - Entry: TClipboardFormatListEntry; - -begin - Result := nil; - for I := List.Count - 1 downto 0 do - begin - Entry := List[I]; - if CompareText(Entry.Description, FormatString) = 0 then - begin - Result := Entry.TreeClass; - Fmt := Entry.FormatEtc.cfFormat; - Break; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -class function TClipboardFormatList.FindFormat(Fmt: Word; var Description: string): TVirtualTreeClass; - -var - I: Integer; - Entry: TClipboardFormatListEntry; - -begin - Result := nil; - for I := List.Count - 1 downto 0 do - begin - Entry := List[I]; - if Entry.FormatEtc.cfFormat = Fmt then - begin - Result := Entry.TreeClass; - Description := Entry.Description; - Break; - end; - end; -end; - - -class function TClipboardFormatList.GetList: TList; -begin - if not Assigned(_List) then - _List := TList.Create; - Exit(_List); -end; - -initialization - -finalization - - TClipboardFormatList.Clear; - FreeAndNil(_List); - -end. + +uses + Winapi.Windows, + Winapi.ActiveX, + System.Classes, + VirtualTrees.BaseTree; + +type + TClipboardFormatEntry = record + ID: Word; + Description: string; + end; + +var + ClipboardDescriptions: array [1..CF_MAX - 1] of TClipboardFormatEntry = ( + (ID: CF_TEXT; Description: 'Plain text'), // Do not localize + (ID: CF_BITMAP; Description: 'Windows bitmap'), // Do not localize + (ID: CF_METAFILEPICT; Description: 'Windows metafile'), // Do not localize + (ID: CF_SYLK; Description: 'Symbolic link'), // Do not localize + (ID: CF_DIF; Description: 'Data interchange format'), // Do not localize + (ID: CF_TIFF; Description: 'Tiff image'), // Do not localize + (ID: CF_OEMTEXT; Description: 'OEM text'), // Do not localize + (ID: CF_DIB; Description: 'DIB image'), // Do not localize + (ID: CF_PALETTE; Description: 'Palette data'), // Do not localize + (ID: CF_PENDATA; Description: 'Pen data'), // Do not localize + (ID: CF_RIFF; Description: 'Riff audio data'), // Do not localize + (ID: CF_WAVE; Description: 'Wav audio data'), // Do not localize + (ID: CF_UNICODETEXT; Description: 'Unicode text'), // Do not localize + (ID: CF_ENHMETAFILE; Description: 'Enhanced metafile image'), // Do not localize + (ID: CF_HDROP; Description: 'File name(s)'), // Do not localize + (ID: CF_LOCALE; Description: 'Locale descriptor'), // Do not localize + (ID: CF_DIBV5; Description: 'DIB image V5') // Do not localize + ); + + +// OLE Clipboard and drag'n drop helper +procedure EnumerateVTClipboardFormats(TreeClass: TVirtualTreeClass; const List: TStrings); overload; +procedure EnumerateVTClipboardFormats(TreeClass: TVirtualTreeClass; var Formats: TFormatEtcArray); overload; +function GetVTClipboardFormatDescription(AFormat: Word): string; +procedure RegisterVTClipboardFormat(AFormat: Word; TreeClass: TVirtualTreeClass; Priority: Cardinal); overload; +function RegisterVTClipboardFormat(const Description: string; TreeClass: TVirtualTreeClass; Priority: Cardinal; + tymed: Integer = TYMED_HGLOBAL; ptd: PDVTargetDevice = nil; + dwAspect: Integer = DVASPECT_CONTENT; lindex: Integer = -1): Word; overload; + +//----------------- TClipboardFormats ---------------------------------------------------------------------------------- + +type + TClipboardFormatListEntry = class + public + Description: string; // The string used to register the format with Winapi.Windows. + TreeClass: TVirtualTreeClass; // The tree class which supports rendering this format. + Priority: Cardinal; // Number which determines the order of formats used in IDataObject. + FormatEtc: TFormatEtc; // The definition of the format in the IDataObject. + end; + + TClipboardFormatList = class + strict private + class function GetList(): TList; static; + class property List: TList read GetList; + protected + class procedure Sort; + public + class procedure Add(const FormatString: string; AClass: TVirtualTreeClass; Priority: Cardinal; AFormatEtc: TFormatEtc); + class procedure Clear; + class procedure EnumerateFormats(TreeClass: TVirtualTreeClass; var Formats: TFormatEtcArray; const AllowedFormats: TClipboardFormats = nil); overload; + class procedure EnumerateFormats(TreeClass: TVirtualTreeClass; const Formats: TStrings); overload; + class function FindFormat(const FormatString: string): TClipboardFormatListEntry; overload; + class function FindFormat(const FormatString: string; var Fmt: Word): TVirtualTreeClass; overload; + class function FindFormat(Fmt: Word; var Description: string): TVirtualTreeClass; overload; + end; + +var + // Clipboard format IDs used in OLE drag'n drop and clipboard transfers. + CF_VIRTUALTREE, + CF_VTREFERENCE, // Reference to a virtual tree + CF_VTHEADERREFERENCE, // A drag and drop of the column header took place + CF_VRTF, + CF_VRTFNOOBJS, // Unfortunately CF_RTF* is already defined as being + // registration strings so I have to use different identifiers. + CF_HTML, + CF_CSV: Word; + + +implementation + +uses + System.SysUtils; + +var + _List: TList = nil; //Note - not using class constructors as they are not supported on C++ Builder. See also issue # + +procedure EnumerateVTClipboardFormats(TreeClass: TVirtualTreeClass; const List: TStrings); + +begin + TClipboardFormatList.EnumerateFormats(TreeClass, List); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure EnumerateVTClipboardFormats(TreeClass: TVirtualTreeClass; var Formats: TFormatEtcArray); + +begin + TClipboardFormatList.EnumerateFormats(TreeClass, Formats); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function GetVTClipboardFormatDescription(AFormat: Word): string; + +begin + if TClipboardFormatList.FindFormat(AFormat, Result) = nil then + Result := ''; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure RegisterVTClipboardFormat(AFormat: Word; TreeClass: TVirtualTreeClass; Priority: Cardinal); + +// Registers the given clipboard format for the given TreeClass. + +var + I: Integer; + Buffer: array[0..2048] of Char; + FormatEtc: TFormatEtc; + +begin + + // Assumes a HGlobal format. + FormatEtc.cfFormat := AFormat; + FormatEtc.ptd := nil; + FormatEtc.dwAspect := DVASPECT_CONTENT; + FormatEtc.lindex := -1; + FormatEtc.tymed := TYMED_HGLOBAL; + + // Determine description string of the given format. For predefined formats we need the lookup table because they + // don't have a description string. For registered formats the description string is the string which was used + // to register them. + if AFormat < CF_MAX then + begin + for I := 1 to High(ClipboardDescriptions) do + if ClipboardDescriptions[I].ID = AFormat then + begin + TClipboardFormatList.Add(ClipboardDescriptions[I].Description, TreeClass, Priority, FormatEtc); + Break; + end; + end + else + begin + GetClipboardFormatName(AFormat, Buffer, Length(Buffer)); + TClipboardFormatList.Add(Buffer, TreeClass, Priority, FormatEtc); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function RegisterVTClipboardFormat(const Description: string; TreeClass: TVirtualTreeClass; Priority: Cardinal; + tymed: Integer = TYMED_HGLOBAL; ptd: PDVTargetDevice = nil; dwAspect: Integer = DVASPECT_CONTENT; + lindex: Integer = -1): Word; + +// Alternative method to register a certain clipboard format for a given tree class. Registration with the +// clipboard is done here too and the assigned ID returned by the function. +// tymed may contain or'ed TYMED constants which allows to register several storage formats for one clipboard format. + +var + FormatEtc: TFormatEtc; + +begin + Result := RegisterClipboardFormat(PChar(Description)); + FormatEtc.cfFormat := Result; + FormatEtc.ptd := ptd; + FormatEtc.dwAspect := dwAspect; + FormatEtc.lindex := lindex; + FormatEtc.tymed := tymed; + TClipboardFormatList.Add(Description, TreeClass, Priority, FormatEtc); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +class procedure TClipboardFormatList.Sort; + +// Sorts all entry for priority (increasing priority value). + + //--------------- local function -------------------------------------------- + procedure QuickSort(L, R: Integer); + + var + I, J: Integer; + P, T: TClipboardFormatListEntry; + + begin + repeat + I := L; + J := R; + P := _List[(L + R) shr 1]; + repeat + while TClipboardFormatListEntry(_List[I]).Priority < P.Priority do + Inc(I); + while TClipboardFormatListEntry(_List[J]).Priority > P.Priority do + Dec(J); + if I <= J then + begin + T := List[I]; + _List[I] := _List[J]; + _List[J] := T; + Inc(I); + Dec(J); + end; + until I > J; + if L < J then + QuickSort(L, J); + L := I; + until I >= R; + end; + //--------------- end local function ---------------------------------------- + +begin + if List.Count > 1 then + QuickSort(0, List.Count - 1); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +class procedure TClipboardFormatList.Add(const FormatString: string; AClass: TVirtualTreeClass; Priority: Cardinal; AFormatEtc: TFormatEtc); + +// Adds the given data to the internal list. The priority value is used to sort formats for importance. Larger priority +// values mean less priority. + +var + Entry: TClipboardFormatListEntry; + +begin + Entry := TClipboardFormatListEntry.Create; + Entry.Description := FormatString; + Entry.TreeClass := AClass; + Entry.Priority := Priority; + Entry.FormatEtc := AFormatEtc; + List.Add(Entry); + + Sort; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +class procedure TClipboardFormatList.Clear; + +var + I: Integer; + +begin + if Assigned(_List) then begin + for I := 0 to _List.Count - 1 do + TClipboardFormatListEntry(List[I]).Free; + _List.Clear; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +class procedure TClipboardFormatList.EnumerateFormats(TreeClass: TVirtualTreeClass; var Formats: TFormatEtcArray; const AllowedFormats: TClipboardFormats = nil); + +// Returns a list of format records for the given class. If assigned the AllowedFormats is used to limit the +// enumerated formats to those described in the list. + +var + I, Count: Integer; + Entry: TClipboardFormatListEntry; + +begin + SetLength(Formats, List.Count); + Count := 0; + for I := 0 to List.Count - 1 do + begin + Entry := List[I]; + // Does the tree class support this clipboard format? + if TreeClass.InheritsFrom(Entry.TreeClass) then + begin + // Is this format allowed to be included? + if (AllowedFormats = nil) or (AllowedFormats.IndexOf(Entry.Description) > -1) then + begin + // The list could change before we use the FormatEtc so it is best not to pass a pointer to the true FormatEtc + // structure. Instead make a copy and send that. + Formats[Count] := Entry.FormatEtc; + Inc(Count); + end; + end; + end; + SetLength(Formats, Count); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +class procedure TClipboardFormatList.EnumerateFormats(TreeClass: TVirtualTreeClass; const Formats: TStrings); + +// Returns a list of format descriptions for the given class. + +var + I: Integer; + Entry: TClipboardFormatListEntry; + +begin + for I := 0 to List.Count - 1 do + begin + Entry := List[I]; + if TreeClass.InheritsFrom(Entry.TreeClass) then + Formats.Add(Entry.Description); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +class function TClipboardFormatList.FindFormat(const FormatString: string): TClipboardFormatListEntry; + +var + I: Integer; + Entry: TClipboardFormatListEntry; + +begin + Result := nil; + for I := List.Count - 1 downto 0 do + begin + Entry := List[I]; + if CompareText(Entry.Description, FormatString) = 0 then + begin + Result := Entry; + Break; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +class function TClipboardFormatList.FindFormat(const FormatString: string; var Fmt: Word): TVirtualTreeClass; + +var + I: Integer; + Entry: TClipboardFormatListEntry; + +begin + Result := nil; + for I := List.Count - 1 downto 0 do + begin + Entry := List[I]; + if CompareText(Entry.Description, FormatString) = 0 then + begin + Result := Entry.TreeClass; + Fmt := Entry.FormatEtc.cfFormat; + Break; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +class function TClipboardFormatList.FindFormat(Fmt: Word; var Description: string): TVirtualTreeClass; + +var + I: Integer; + Entry: TClipboardFormatListEntry; + +begin + Result := nil; + for I := List.Count - 1 downto 0 do + begin + Entry := List[I]; + if Entry.FormatEtc.cfFormat = Fmt then + begin + Result := Entry.TreeClass; + Description := Entry.Description; + Break; + end; + end; +end; + + +class function TClipboardFormatList.GetList: TList; +begin + if not Assigned(_List) then + _List := TList.Create; + Exit(_List); +end; + +initialization + +finalization + + TClipboardFormatList.Clear; + FreeAndNil(_List); + +end. + diff --git a/components/virtualtreeview/Source/VirtualTrees.Colors.pas b/components/virtualtreeview/Source/VirtualTrees.Colors.pas new file mode 100644 index 000000000..78c1c079e --- /dev/null +++ b/components/virtualtreeview/Source/VirtualTrees.Colors.pas @@ -0,0 +1,274 @@ +unit VirtualTrees.Colors; + +interface + +uses + System.Classes, + Vcl.Graphics, + Vcl.Themes, + Vcl.Controls; + +type + //class to collect all switchable colors into one place + TVTColors = class(TPersistent) + private type + TVTColorEnum = ( + cDisabledColor + , cDropMarkColor + , cDropTargetColor + , cFocusedSelectionColor + , cGridLineColor + , cTreeLineColor + , cUnfocusedSelectionColor + , cBorderColor + , cHotColor + , cFocusedSelectionBorderColor + , cUnfocusedSelectionBorderColor + , cDropTargetBorderColor + , cSelectionRectangleBlendColor + , cSelectionRectangleBorderColor + , cHeaderHotColor + , cSelectionTextColor + , cUnfocusedColor + ); + + //Please make sure that the published Color properties at the corresponding index + //have the same color if you change anything here! + const + cDefaultColors : array [TVTColorEnum] of TColor = ( + clBtnShadow, //DisabledColor + clHighlight, //DropMarkColor + clHighlight, //DropTargetColor + clHighlight, //FocusedSelectionColor + clBtnFace, //GridLineColor + clBtnShadow, //TreeLineColor + clInactiveCaption, //UnfocusedSelectionColor + clBtnFace, //BorderColor + clWindowText, //HotColor + clHighlight, //FocusedSelectionBorderColor + clInactiveCaption, //UnfocusedSelectionBorderColor + clHighlight, //DropTargetBorderColor + clHighlight, //SelectionRectangleBlendColor + clHighlight, //SelectionRectangleBorderColor + clBtnShadow, //HeaderHotColor + clHighlightText, //SelectionTextColor + clInactiveCaptionText //UnfocusedColor [IPK] + ); + private + FOwner : TCustomControl; + FColors : array [TVTColorEnum] of TColor; //[IPK] 15 -> 16 + function GetColor(const Index : TVTColorEnum) : TColor; + procedure SetColor(const Index : TVTColorEnum; const Value : TColor); + function GetBackgroundColor : TColor; + function GetHeaderFontColor : TColor; + function GetNodeFontColor : TColor; + public + constructor Create(AOwner : TCustomControl); + + procedure Assign(Source : TPersistent); override; + function GetSelectedNodeFontColor(Focused : boolean) : TColor; + property BackGroundColor : TColor read GetBackgroundColor; + property HeaderFontColor : TColor read GetHeaderFontColor; + property NodeFontColor : TColor read GetNodeFontColor; + //Mitigator function to use the correct style service for this context (either the style assigned to the control for Delphi > 10.4 or the application style) + function StyleServices(AControl : TControl = nil) : TCustomStyleServices; + published + property BorderColor : TColor index cBorderColor read GetColor write SetColor default clBtnFace; + property DisabledColor : TColor index cDisabledColor read GetColor write SetColor default clBtnShadow; + property DropMarkColor : TColor index cDropMarkColor read GetColor write SetColor default clHighlight; + property DropTargetColor : TColor index cDropTargetColor read GetColor write SetColor default clHighlight; + property DropTargetBorderColor : TColor index cDropTargetBorderColor read GetColor write SetColor default clHighlight; + ///The background color of selected nodes in case the tree has the focus, or the toPopupMode flag is set. + property FocusedSelectionColor : TColor index cFocusedSelectionColor read GetColor write SetColor default clHighlight; + ///The border color of selected nodes when the tree has the focus. + property FocusedSelectionBorderColor : TColor index cFocusedSelectionBorderColor read GetColor write SetColor default clHighlight; + ///The color of the grid lines + property GridLineColor : TColor index cGridLineColor read GetColor write SetColor default clBtnFace; + property HeaderHotColor : TColor index cHeaderHotColor read GetColor write SetColor default clBtnShadow; + property HotColor : TColor index cHotColor read GetColor write SetColor default clWindowText; + property SelectionRectangleBlendColor : TColor index cSelectionRectangleBlendColor read GetColor write SetColor default clHighlight; + property SelectionRectangleBorderColor : TColor index cSelectionRectangleBorderColor read GetColor write SetColor default clHighlight; + ///The text color of selected nodes + property SelectionTextColor : TColor index cSelectionTextColor read GetColor write SetColor default clHighlightText; + property TreeLineColor : TColor index cTreeLineColor read GetColor write SetColor default clBtnShadow; + property UnfocusedColor : TColor index cUnfocusedColor read GetColor write SetColor default clInactiveCaptionText; //[IPK] Added + ///The background color of selected nodes in case the tree does not have the focus and the toPopupMode flag is not set. + property UnfocusedSelectionColor : TColor index cUnfocusedSelectionColor read GetColor write SetColor default clInactiveCaption; + ///The border color of selected nodes in case the tree does not have the focus and the toPopupMode flag is not set. + property UnfocusedSelectionBorderColor : TColor index cUnfocusedSelectionBorderColor read GetColor write SetColor default clInactiveCaption; + end; + +implementation + +uses + WinApi.Windows, + VirtualTrees.Types, + VirtualTrees.Utils, + VirtualTrees.StyleHooks, + VirtualTrees.BaseTree; + +type + TBaseVirtualTreeCracker = class(TBaseVirtualTree); + + TVTColorsHelper = class helper for TVTColors + function TreeView : TBaseVirtualTreeCracker; + end; + + //----------------- TVTColors ------------------------------------------------------------------------------------------ + +constructor TVTColors.Create(AOwner : TCustomControl); +var + CE : TVTColorEnum; +begin + FOwner := AOwner; + for CE := Low(TVTColorEnum) to High(TVTColorEnum) do + FColors[CE] := cDefaultColors[CE]; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTColors.GetBackgroundColor : TColor; +begin + //XE2 VCL Style + if TreeView.VclStyleEnabled and (seClient in FOwner.StyleElements) then + Result := StyleServices.GetStyleColor(scTreeView) + else + Result := TreeView.Color; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTColors.GetColor(const Index : TVTColorEnum) : TColor; +begin + //Only try to fetch the color via StyleServices if theses are enabled + //Return default/user defined color otherwise + if not (csDesigning in TreeView.ComponentState) { see issue #1185 } and TreeView.VclStyleEnabled then + begin + //If the ElementDetails are not defined, fall back to the SystemColor + case Index of + cDisabledColor : + if not StyleServices.GetElementColor(StyleServices.GetElementDetails(ttItemDisabled), ecTextColor, Result) then + Result := StyleServices.GetSystemColor(FColors[Index]); + cTreeLineColor : + if not StyleServices.GetElementColor(StyleServices.GetElementDetails(ttBranch), ecBorderColor, Result) then + Result := StyleServices.GetSystemColor(FColors[Index]); + cBorderColor : + if (seBorder in FOwner.StyleElements) then + Result := StyleServices.GetSystemColor(FColors[Index]) + else + Result := FColors[Index]; + cHotColor : + if not StyleServices.GetElementColor(StyleServices.GetElementDetails(ttItemHot), ecTextColor, Result) then + Result := StyleServices.GetSystemColor(FColors[Index]); + cHeaderHotColor : + if not StyleServices.GetElementColor(StyleServices.GetElementDetails(thHeaderItemHot), ecTextColor, Result) then + Result := StyleServices.GetSystemColor(FColors[Index]); + cSelectionTextColor : + if not StyleServices.GetElementColor(StyleServices.GetElementDetails(ttItemSelected), ecTextColor, Result) then + Result := StyleServices.GetSystemColor(clHighlightText); + cUnfocusedColor : + if not StyleServices.GetElementColor(StyleServices.GetElementDetails(ttItemSelectedNotFocus), ecTextColor, Result) then + Result := StyleServices.GetSystemColor(FColors[Index]); + else + Result := StyleServices.GetSystemColor(FColors[Index]); + end; + end + else + Result := FColors[Index]; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTColors.GetHeaderFontColor : TColor; +begin + //XE2+ VCL Style + if TreeView.VclStyleEnabled and (seFont in FOwner.StyleElements) then + StyleServices.GetElementColor(StyleServices.GetElementDetails(thHeaderItemNormal), ecTextColor, Result) + else + Result := TreeView.Header.Font.Color; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTColors.GetNodeFontColor : TColor; +begin + if TreeView.VclStyleEnabled and (seFont in FOwner.StyleElements) then + StyleServices.GetElementColor(StyleServices.GetElementDetails(ttItemNormal), ecTextColor, Result) + else + Result := TreeView.Font.Color; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTColors.GetSelectedNodeFontColor(Focused : boolean) : TColor; +begin + if Focused then + begin + if (tsUseExplorerTheme in TreeView.TreeStates) and not IsHighContrastEnabled then + begin + Result := NodeFontColor + end + else + Result := SelectionTextColor + end//if Focused + else + Result := UnfocusedColor; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTColors.SetColor(const Index : TVTColorEnum; const Value : TColor); +begin + if FColors[Index] <> Value then + begin + FColors[Index] := Value; + if not (csLoading in FOwner.ComponentState) and FOwner.HandleAllocated then + begin + //Cause helper bitmap rebuild if the button color changed. + case Index of + cTreeLineColor : + begin + TreeView.PrepareBitmaps(True, False); + FOwner.Invalidate; + end; + cBorderColor : + RedrawWindow(FOwner.Handle, nil, 0, RDW_FRAME or RDW_INVALIDATE or RDW_NOERASE or RDW_NOCHILDREN) + else + if not (tsPainting in TreeView.TreeStates) then // See issue #1186 + FOwner.Invalidate; + end;//case + end;// if + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTColors.StyleServices(AControl : TControl) : TCustomStyleServices; +begin + if AControl = nil then + AControl := FOwner; + Result := VTStyleServices(AControl); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTColors.Assign(Source : TPersistent); +begin + if Source is TVTColors then + begin + FColors := TVTColors(Source).FColors; + if TreeView.UpdateCount = 0 then + TreeView.Invalidate; + end + else + inherited; +end; + +{ TVTColorsHelper } + +function TVTColorsHelper.TreeView : TBaseVirtualTreeCracker; +begin + Result := TBaseVirtualTreeCracker(FOwner); +end; + +end. diff --git a/components/virtualtreeview/Source/VirtualTrees.DataObject.pas b/components/virtualtreeview/Source/VirtualTrees.DataObject.pas new file mode 100644 index 000000000..771b149d0 --- /dev/null +++ b/components/virtualtreeview/Source/VirtualTrees.DataObject.pas @@ -0,0 +1,508 @@ +unit VirtualTrees.DataObject; + +interface + +uses + WinApi.ActiveX, + WinApi.Windows, + System.Classes, + Vcl.Controls, + VirtualTrees.Types; + +type + IDataObject = WinApi.ActiveX.IDataObject; + + // IDataObject.SetData support + TInternalStgMedium = packed record + Format : TClipFormat; + Medium : TStgMedium; + end; + + TInternalStgMediumArray = array of TInternalStgMedium; + + // This data object is used in two different places. One is for clipboard operations and the other while dragging. + TVTDataObject = class(TInterfacedObject, IDataObject) + private + FOwner : TCustomControl; // The tree which provides clipboard or drag data. + FHeader : TPersistent; // The tree which provides clipboard or drag data. + FForClipboard : Boolean; // Determines which data to render with GetData. + FFormatEtcArray : TFormatEtcArray; + FInternalStgMediumArray : TInternalStgMediumArray; // The available formats in the DataObject + FAdviseHolder : IDataAdviseHolder; // Reference to an OLE supplied implementation for advising. + protected + function CanonicalIUnknown(const TestUnknown : IUnknown) : IUnknown; + function EqualFormatEtc(FormatEtc1, FormatEtc2 : TFormatEtc) : Boolean; + function FindFormatEtc(TestFormatEtc : TFormatEtc; const FormatEtcArray : TFormatEtcArray) : Integer; + function FindInternalStgMedium(Format : TClipFormat) : PStgMedium; + function HGlobalClone(HGlobal : THandle) : THandle; + function RenderInternalOLEData(const FormatEtcIn : TFormatEtc; var Medium : TStgMedium; var OLEResult : HResult) : Boolean; + function StgMediumIncRef(const InStgMedium : TStgMedium; var OutStgMedium : TStgMedium; CopyInMedium : Boolean; const DataObject : IDataObject) : HResult; + + property ForClipboard : Boolean read FForClipboard; + property FormatEtcArray : TFormatEtcArray read FFormatEtcArray write FFormatEtcArray; + property InternalStgMediumArray : TInternalStgMediumArray read FInternalStgMediumArray write FInternalStgMediumArray; + property Owner : TCustomControl read FOwner; + public + constructor Create(AOwner : TCustomControl; ForClipboard : Boolean); overload; + constructor Create(AHeader : TPersistent; AOwner : TCustomControl); overload; + destructor Destroy; override; + + function DAdvise(const FormatEtc : TFormatEtc; advf : Integer; const advSink : IAdviseSink; out dwConnection : Integer) : HResult; virtual; stdcall; + function DUnadvise(dwConnection : Integer) : HResult; virtual; stdcall; + function EnumDAdvise(out enumAdvise : IEnumStatData) : HResult; virtual; stdcall; + function EnumFormatEtc(Direction : Integer; out EnumFormatEtc : IEnumFormatEtc) : HResult; virtual; stdcall; + function GetCanonicalFormatEtc(const FormatEtc : TFormatEtc; out FormatEtcOut : TFormatEtc) : HResult; virtual; stdcall; + function GetData(const FormatEtcIn : TFormatEtc; out Medium : TStgMedium) : HResult; virtual; stdcall; + function GetDataHere(const FormatEtc : TFormatEtc; out Medium : TStgMedium) : HResult; virtual; stdcall; + function QueryGetData(const FormatEtc : TFormatEtc) : HResult; virtual; stdcall; + function SetData(const FormatEtc : TFormatEtc; var Medium : TStgMedium; DoRelease : BOOL) : HResult; virtual; stdcall; + end; + +implementation + +uses + VirtualTrees.ClipBoard, + VirtualTrees.DragnDrop, + VirtualTrees.BaseTree; + +type + TVTCracker = class(TBaseVirtualTree); + + //----------------- TVTDataObject -------------------------------------------------------------------------------------- + +constructor TVTDataObject.Create(AOwner : TCustomControl; ForClipboard : Boolean); +begin + inherited Create; + + FOwner := AOwner; + FForClipboard := ForClipboard; + if Assigned(FOWner) then + TVTCracker(FOwner).GetNativeClipboardFormats(FFormatEtcArray); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +constructor TVTDataObject.Create(AHeader: TPersistent; AOwner : TCustomControl); +begin + Create(AOwner, False); + FHeader := AHeader; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +destructor TVTDataObject.Destroy; +var + I : Integer; + StgMedium : PStgMedium; +begin + // Cancel a pending clipboard operation if this data object was created for the clipboard and + // is freed because something else is placed there. + if FForClipboard and not (tsClipboardFlushing in TBaseVirtualTree(FOwner).TreeStates) then + TBaseVirtualTree(FOwner).CancelCutOrCopy; + + // Release any internal clipboard formats + for I := 0 to High(FormatEtcArray) do + begin + StgMedium := FindInternalStgMedium(FormatEtcArray[I].cfFormat); + if Assigned(StgMedium) then + ReleaseStgMedium(StgMedium^); + end; + + FormatEtcArray := nil; + inherited; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDataObject.CanonicalIUnknown(const TestUnknown : IUnknown) : IUnknown; +// Uses COM object identity: An explicit call to the IUnknown::QueryInterface method, requesting the IUnknown +// interface, will always return the same pointer. +begin + if Assigned(TestUnknown) then + begin + if TestUnknown.QueryInterface(IUnknown, Result) = 0 then + Result._Release // Don't actually need it just need the pointer value + else + Result := TestUnknown; + end + else + Result := TestUnknown; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDataObject.EqualFormatEtc(FormatEtc1, FormatEtc2 : TFormatEtc) : Boolean; +begin + Result := (FormatEtc1.cfFormat = FormatEtc2.cfFormat) and (FormatEtc1.ptd = FormatEtc2.ptd) and (FormatEtc1.dwAspect = FormatEtc2.dwAspect) and + (FormatEtc1.lindex = FormatEtc2.lindex) and (FormatEtc1.tymed and FormatEtc2.tymed <> 0); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDataObject.FindFormatEtc(TestFormatEtc : TFormatEtc; const FormatEtcArray : TFormatEtcArray) : Integer; +var + I : Integer; +begin + Result := - 1; + for I := 0 to High(FormatEtcArray) do + begin + if EqualFormatEtc(TestFormatEtc, FormatEtcArray[I]) then + begin + Result := I; + Break; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDataObject.FindInternalStgMedium(Format : TClipFormat) : PStgMedium; +var + I : Integer; +begin + Result := nil; + for I := 0 to High(InternalStgMediumArray) do + begin + if Format = InternalStgMediumArray[I].Format then + begin + Result := @InternalStgMediumArray[I].Medium; + Break; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDataObject.HGlobalClone(HGlobal : THandle) : THandle; +// Returns a global memory block that is a copy of the passed memory block. +var + Size : Cardinal; + Data, NewData : PByte; +begin + Size := GlobalSize(HGlobal); + Result := GlobalAlloc(GPTR, Size); + Data := GlobalLock(HGlobal); + try + NewData := GlobalLock(Result); + try + Move(Data^, NewData^, Size); + finally + GlobalUnLock(Result); + end; + finally + GlobalUnLock(HGlobal); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDataObject.RenderInternalOLEData(const FormatEtcIn : TFormatEtc; var Medium : TStgMedium; var OLEResult : HResult) : Boolean; +// Tries to render one of the formats which have been stored via the SetData method. +// Since this data is already there it is just copied or its reference count is increased (depending on storage medium). +var + InternalMedium : PStgMedium; +begin + Result := True; + InternalMedium := FindInternalStgMedium(FormatEtcIn.cfFormat); + if Assigned(InternalMedium) then + OLEResult := StgMediumIncRef(InternalMedium^, Medium, False, Self as IDataObject) + else + Result := False; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDataObject.StgMediumIncRef(const InStgMedium : TStgMedium; var OutStgMedium : TStgMedium; CopyInMedium : Boolean; const DataObject : IDataObject) : HResult; +// InStgMedium is the data that is requested, OutStgMedium is the data that we are to return either a copy of or +// increase the IDataObject's reference and send ourselves back as the data (unkForRelease). The InStgMedium is usually +// the result of a call to find a particular FormatEtc that has been stored locally through a call to SetData. +// If CopyInMedium is not true we already have a local copy of the data when the SetData function was called (during +// that call the CopyInMedium must be true). Then as the caller asks for the data through GetData we do not have to make +// copy of the data for the caller only to have them destroy it then need us to copy it again if necessary. +// This way we increase the reference count to ourselves and pass the STGMEDIUM structure initially stored in SetData. +// This way when the caller frees the structure it sees the unkForRelease is not nil and calls Release on the object +// instead of destroying the actual data. +var + Len : Integer; +begin + Result := S_OK; + + // Simply copy all fields to start with. + OutStgMedium := InStgMedium; + // The data handled here always results from a call of SetData we got. This ensures only one storage format + // is indicated and hence the case statement below is safe (IDataObject.GetData can optionally use several + // storage formats). + case InStgMedium.tymed of + TYMED_HGLOBAL : + begin + if CopyInMedium then + begin + // Generate a unique copy of the data passed + OutStgMedium.HGlobal := HGlobalClone(InStgMedium.HGlobal); + if OutStgMedium.HGlobal = 0 then + Result := E_OUTOFMEMORY; + end + else + // Don't generate a copy just use ourselves and the copy previously saved. + OutStgMedium.unkForRelease := Pointer(DataObject); // Does not increase RefCount. + end; + TYMED_FILE : + begin + Len := lstrLenW(InStgMedium.lpszFileName) + 1; // Don't forget the terminating null character. + OutStgMedium.lpszFileName := CoTaskMemAlloc(2 * Len); + Move(InStgMedium.lpszFileName^, OutStgMedium.lpszFileName^, 2 * Len); + end; + TYMED_ISTREAM : + IUnknown(OutStgMedium.stm)._AddRef; + TYMED_ISTORAGE : + IUnknown(OutStgMedium.stg)._AddRef; + TYMED_GDI : + if not CopyInMedium then + // Don't generate a copy just use ourselves and the previously saved data. + OutStgMedium.unkForRelease := Pointer(DataObject) // Does not increase RefCount. + else + Result := DV_E_TYMED; // Don't know how to copy GDI objects right now. + TYMED_MFPICT : + if not CopyInMedium then + // Don't generate a copy just use ourselves and the previously saved data. + OutStgMedium.unkForRelease := Pointer(DataObject) // Does not increase RefCount. + else + Result := DV_E_TYMED; // Don't know how to copy MetaFile objects right now. + TYMED_ENHMF : + if not CopyInMedium then + // Don't generate a copy just use ourselves and the previously saved data. + OutStgMedium.unkForRelease := Pointer(DataObject) // Does not increase RefCount. + else + Result := DV_E_TYMED; // Don't know how to copy enhanced metafiles objects right now. + else + Result := DV_E_TYMED; + end; + + if (Result = S_OK) and Assigned(OutStgMedium.unkForRelease) then + IUnknown(OutStgMedium.unkForRelease)._AddRef; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDataObject.DAdvise(const FormatEtc : TFormatEtc; advf : Integer; const advSink : IAdviseSink; out dwConnection : Integer) : HResult; +// Advise sink management is greatly simplified by the IDataAdviseHolder interface. +// We use this interface and forward all concerning calls to it. +begin + Result := S_OK; + if FAdviseHolder = nil then + Result := CreateDataAdviseHolder(FAdviseHolder); + if Result = S_OK then + Result := FAdviseHolder.Advise(Self as IDataObject, FormatEtc, advf, advSink, dwConnection); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDataObject.DUnadvise(dwConnection : Integer) : HResult; +begin + if FAdviseHolder = nil then + Result := E_NOTIMPL + else + Result := FAdviseHolder.Unadvise(dwConnection); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDataObject.EnumDAdvise(out enumAdvise : IEnumStatData) : HResult; +begin + if FAdviseHolder = nil then + Result := OLE_E_ADVISENOTSUPPORTED + else + Result := FAdviseHolder.enumAdvise(enumAdvise); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDataObject.EnumFormatEtc(Direction : Integer; out EnumFormatEtc : IEnumFormatEtc) : HResult; +var + NewList : TEnumFormatEtc; +begin + Result := E_FAIL; + if Direction = DATADIR_GET then + begin + NewList := TEnumFormatEtc.Create(FormatEtcArray); + EnumFormatEtc := NewList as IEnumFormatEtc; + Result := S_OK; + end + else + EnumFormatEtc := nil; + if EnumFormatEtc = nil then + Result := OLE_S_USEREG; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDataObject.GetCanonicalFormatEtc(const FormatEtc : TFormatEtc; out FormatEtcOut : TFormatEtc) : HResult; +begin + Result := DATA_S_SAMEFORMATETC; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDataObject.GetData(const FormatEtcIn : TFormatEtc; out Medium : TStgMedium) : HResult; +// Data is requested by clipboard or drop target. This method dispatchs the call +// depending on the data being requested. +var + I : Integer; + Data : PVTReference; +begin + // See if this is a header column drag and drop + if (FormatEtcIn.cfFormat = CF_VTHEADERREFERENCE) and Assigned(FHeader) then + begin + Medium.HGlobal := GlobalAlloc(GHND or GMEM_SHARE, SizeOf(TVTReference)); + Data := GlobalLock(Medium.HGlobal); + Data.Process := GetCurrentProcessID; + Data.Tree := TBaseVirtualTree(FOwner); + GlobalUnLock(Medium.HGlobal); + Medium.tymed := TYMED_HGLOBAL; + Medium.unkForRelease := nil; + Exit(S_OK); + end; // if CF_VTHEADERREFERENCE + + + // The tree reference format is always supported and returned from here. + if (FormatEtcIn.cfFormat = CF_VTREFERENCE) and Assigned(FOWner) then + begin + // Note: this format is not used while flushing the clipboard to avoid a dangling reference + // when the owner tree is destroyed before the clipboard data is replaced with something else. + if tsClipboardFlushing in TBaseVirtualTree(FOwner).TreeStates then + Result := E_FAIL + else + begin + Medium.HGlobal := GlobalAlloc(GHND or GMEM_SHARE, SizeOf(TVTReference)); + Data := GlobalLock(Medium.HGlobal); + Data.Process := GetCurrentProcessID; + Data.Tree := TBaseVirtualTree(FOwner); + GlobalUnLock(Medium.HGlobal); + Medium.tymed := TYMED_HGLOBAL; + Medium.unkForRelease := nil; + Exit(S_OK); + end; + end; // if CF_VTREFERENCE + + try + // See if we accept this type and if not get the correct return value. + Result := QueryGetData(FormatEtcIn); + if Result = S_OK then + begin + for I := 0 to High(FormatEtcArray) do + begin + if EqualFormatEtc(FormatEtcIn, FormatEtcArray[I]) then + begin + if not RenderInternalOLEData(FormatEtcIn, Medium, Result) then + Result := TVTCracker(FOwner).RenderOLEData(FormatEtcIn, Medium, FForClipboard); + Break; + end; + end; + end; + except + ZeroMemory(@Medium, SizeOf(Medium)); + Result := E_FAIL; + end; // try..except +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDataObject.GetDataHere(const FormatEtc : TFormatEtc; out Medium : TStgMedium) : HResult; +begin + Result := E_NOTIMPL; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDataObject.QueryGetData(const FormatEtc : TFormatEtc) : HResult; +var + I : Integer; +begin + Result := DV_E_CLIPFORMAT; + for I := 0 to High(FFormatEtcArray) do + begin + if FormatEtc.cfFormat = FFormatEtcArray[I].cfFormat then + begin + if (FormatEtc.tymed and FFormatEtcArray[I].tymed) <> 0 then + begin + if FormatEtc.dwAspect = FFormatEtcArray[I].dwAspect then + begin + if FormatEtc.lindex = FFormatEtcArray[I].lindex then + begin + Result := S_OK; + Break; + end + else + Result := DV_E_LINDEX; + end + else + Result := DV_E_DVASPECT; + end + else + Result := DV_E_TYMED; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDataObject.SetData(const FormatEtc : TFormatEtc; var Medium : TStgMedium; DoRelease : BOOL) : HResult; +// Allows dynamic adding to the IDataObject during its existance. Most noteably it is used to implement +// IDropSourceHelper and allows to set a special format for optimized moves during a shell transfer. +var + Index : Integer; + LocalStgMedium : PStgMedium; +begin + // See if we already have a format of that type available. + Index := FindFormatEtc(FormatEtc, FormatEtcArray); + if Index > - 1 then + begin + // Just use the TFormatEct in the array after releasing the data. + LocalStgMedium := FindInternalStgMedium(FormatEtcArray[Index].cfFormat); + if Assigned(LocalStgMedium) then + begin + ReleaseStgMedium(LocalStgMedium^); + ZeroMemory(LocalStgMedium, SizeOf(LocalStgMedium^)); + end; + end + else + begin + // It is a new format so create a new TFormatCollectionItem, copy the + // FormatEtc parameter into the new object and and put it in the list. + SetLength(FFormatEtcArray, Length(FormatEtcArray) + 1); + FormatEtcArray[High(FormatEtcArray)] := FormatEtc; + + // Create a new InternalStgMedium and initialize it and associate it with the format. + SetLength(FInternalStgMediumArray, Length(InternalStgMediumArray) + 1); + InternalStgMediumArray[High(InternalStgMediumArray)].Format := FormatEtc.cfFormat; + LocalStgMedium := @InternalStgMediumArray[High(InternalStgMediumArray)].Medium; + ZeroMemory(LocalStgMedium, SizeOf(LocalStgMedium^)); + end; + + if DoRelease then + begin + // We are simply being given the data and we take control of it. + LocalStgMedium^ := Medium; + Result := S_OK; + end + else + begin + // We need to reference count or copy the data and keep our own references to it. + Result := StgMediumIncRef(Medium, LocalStgMedium^, True, Self as IDataObject); + + // Can get a circular reference if the client calls GetData then calls SetData with the same StgMedium. + // Because the unkForRelease for the IDataObject can be marshalled it is necessary to get pointers that + // can be correctly compared. See the IDragSourceHelper article by Raymond Chen at MSDN. + if Assigned(LocalStgMedium.unkForRelease) then + begin + if CanonicalIUnknown(Self) = CanonicalIUnknown(IUnknown(LocalStgMedium.unkForRelease)) then + IUnknown(LocalStgMedium.unkForRelease) := nil; // release the interface + end; + end; + + // Tell all registered advice sinks about the data change. + if Assigned(FAdviseHolder) then + FAdviseHolder.SendOnDataChange(Self as IDataObject, 0, 0); +end; + +end. diff --git a/components/virtualtreeview/Source/VirtualTrees.DragImage.pas b/components/virtualtreeview/Source/VirtualTrees.DragImage.pas new file mode 100644 index 000000000..1aa3b8789 --- /dev/null +++ b/components/virtualtreeview/Source/VirtualTrees.DragImage.pas @@ -0,0 +1,139 @@ +unit VirtualTrees.DragImage; + +interface + +uses + WinApi.Windows, + WinApi.ActiveX, + System.Types, + Vcl.Controls, + Vcl.Graphics; + +{$MINENUMSIZE 1, make enumerations as small as possible} + + +type + // Drag image support for the tree. + TVTTransparency = 0 .. 255; + + // Simple move limitation for the drag image. + TVTDragMoveRestriction = ( + dmrNone, + dmrHorizontalOnly, + dmrVerticalOnly + ); + + TVTDragImageStates = set of ( + disHidden, // Internal drag image is currently hidden (always hidden if drag image helper interfaces are used). + disInDrag, // Drag image class is currently being used. + disPrepared // Drag image class is prepared. + ); + + // Class to manage header and tree drag image during a drag'n drop operation. + TVTDragImage = class + private + FOwner : TCustomControl; + FBackImage, // backup of overwritten screen area + FAlphaImage, // target for alpha blending + FDragImage : TBitmap; // the actual drag image to blend to screen + FRestriction : TVTDragMoveRestriction; // determines in which directions the drag image can be moved + FColorKey : TColor; // color to make fully transparent regardless of any other setting + FStates : TVTDragImageStates; // Determines the states of the drag image class. + public + constructor Create(AOwner : TCustomControl); + destructor Destroy; override; + + procedure EndDrag; + procedure PrepareDrag(DragImage : TBitmap; HotSpot : TPoint; const DataObject: IDataObject; pColorKey: TColor = clWindow); + property MoveRestriction : TVTDragMoveRestriction read FRestriction write FRestriction default dmrNone; + end; + +implementation + +uses + WinApi.ShlObj, + WinApi.Messages, + System.SysUtils, + System.Math, + VirtualTrees.DragnDrop, + VirtualTrees.Types, + VirtualTrees.Utils, + VirtualTrees.BaseTree; + +//----------------- TVTDragImage --------------------------------------------------------------------------------------- + +constructor TVTDragImage.Create(AOwner : TCustomControl); +begin + FOwner := AOwner; + FRestriction := dmrNone; + FColorKey := clNone; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +destructor TVTDragImage.Destroy; +begin + EndDrag; + + inherited; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTDragImage.EndDrag; +begin + FStates := FStates - [disInDrag, disPrepared]; + FBackImage.Free; + FBackImage := nil; + FDragImage.Free; + FDragImage := nil; + FAlphaImage.Free; + FAlphaImage := nil; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTDragImage.PrepareDrag(DragImage : TBitmap; HotSpot : TPoint; const DataObject : IDataObject; pColorKey: TColor = clWindow); +// Creates all necessary structures to do alpha blended dragging using the given image. +// ImagePostion and HotSpot are given in screen coordinates. The first determines where to place the drag image while +// the second is the initial mouse position. +// This method also determines whether the system supports drag images natively. If so then only minimal structures +// are created. + +var + Width, Height : Integer; + DragSourceHelper : IDragSourceHelper; + DragInfo : TSHDragImage; + lDragSourceHelper2 : IDragSourceHelper2; // Needed to get Windows Vista+ style drag hints. + lNullPoint : TPoint; +begin + Width := DragImage.Width; + Height := DragImage.Height; + FColorKey := pColorKey; + + // Determine whether the system supports the drag helper interfaces. + if Assigned(DataObject) and Succeeded(CoCreateInstance(CLSID_DragDropHelper, nil, CLSCTX_INPROC_SERVER, IDragSourceHelper, DragSourceHelper)) then + begin + lNullPoint := Point(0, 0); + if Supports(DragSourceHelper, IDragSourceHelper2, lDragSourceHelper2) then + lDragSourceHelper2.SetFlags(DSH_ALLOWDROPDESCRIPTIONTEXT); // Show description texts + // First let the system try to initialze the DragSourceHelper, this works fine for file system objects (CF_HDROP) + StandardOLEFormat.cfFormat := CF_HDROP; + if not Succeeded(DataObject.QueryGetData(StandardOLEFormat)) or not Succeeded(DragSourceHelper.InitializeFromWindow(0, lNullPoint, DataObject)) then + begin + // Supply the drag source helper with our drag image. + DragInfo.sizeDragImage.cx := Width; + DragInfo.sizeDragImage.cy := Height; + DragInfo.ptOffset := HotSpot; + DragInfo.hbmpDragImage := CopyImage(DragImage.Handle, IMAGE_BITMAP, Width, Height, LR_COPYRETURNORG); + DragInfo.crColorKey := ColorToRGB(FColorKey); + if not Succeeded(DragSourceHelper.InitializeFromBitmap(@DragInfo, DataObject)) then + begin + DeleteObject(DragInfo.hbmpDragImage); + end; + end; + end; +end; + + +end. diff --git a/components/virtualtreeview/Source/VirtualTrees.DragnDrop.pas b/components/virtualtreeview/Source/VirtualTrees.DragnDrop.pas new file mode 100644 index 000000000..4eb54873e --- /dev/null +++ b/components/virtualtreeview/Source/VirtualTrees.DragnDrop.pas @@ -0,0 +1,377 @@ +unit VirtualTrees.DragnDrop; + +interface + +uses + WinApi.Windows, + WinApi.ActiveX, + WinApi.ShlObj, + System.Types, + Vcl.Graphics, + Vcl.Controls, + VirtualTrees.Types, + VirtualTrees.BaseTree, + VirtualTrees.Header; + +type + TEnumFormatEtc = class(TInterfacedObject, IEnumFormatEtc) + private + FFormatEtcArray : TFormatEtcArray; + FCurrentIndex : Integer; + public + constructor Create(const AFormatEtcArray : TFormatEtcArray); + + function Clone(out Enum : IEnumFormatEtc) : HResult; stdcall; + function Next(celt : Integer; out elt; pceltFetched : PLongint) : HResult; stdcall; + function Reset : HResult; stdcall; + function Skip(celt : Integer) : HResult; stdcall; + end; + + // TVTDragManager is a class to manage drag and drop in a Virtual Treeview. + TVTDragManager = class(TInterfacedObject, IVTDragManager, IDropSource, IDropTarget) + private + FOwner, // The tree which is responsible for drag management. + FDragSource : TBaseVirtualTree; // Reference to the source tree if the source was a VT, might be different than the owner tree. + FHeader : TVTHeader; + FIsDropTarget : Boolean; // True if the owner is currently the drop target. + FDataObject : IDataObject; // A reference to the data object passed in by DragEnter (only used when the owner tree is the current drop target). + FDropTargetHelper : IDropTargetHelper; // Win2k > Drag image support + FFullDragging : BOOL; // True, if full dragging is currently enabled in the system. + + function GetDataObject : IDataObject; stdcall; + function GetDragSource : TBaseVirtualTree; stdcall; + function GetIsDropTarget : Boolean; stdcall; + public + constructor Create(AOwner : TBaseVirtualTree); virtual; + destructor Destroy; override; + + function DragEnter(const DataObject : IDataObject; KeyState : Integer; Pt : TPoint; var Effect : Longint) : HResult; stdcall; + function DragLeave : HResult; stdcall; + function DragOver(KeyState : Integer; Pt : TPoint; var Effect : Longint) : HResult; stdcall; + function Drop(const DataObject : IDataObject; KeyState : Integer; Pt : TPoint; var Effect : Integer) : HResult; stdcall; + procedure ForceDragLeave; stdcall; + function GiveFeedback(Effect : Integer) : HResult; stdcall; + function QueryContinueDrag(EscapePressed : BOOL; KeyState : Integer) : HResult; stdcall; + class function GetTreeFromDataObject(const DataObject: TVTDragDataObject): TBaseVirtualTree; + end; + +var + StandardOLEFormat : TFormatEtc = ( + // Format must later be set. + cfFormat : 0; + // No specific target device to render on. + ptd : nil; + // Normal content to render. + dwAspect : DVASPECT_CONTENT; + // No specific page of multipage data (we don't use multipage data by default). + lindex : - 1; + // Acceptable storage formats are IStream and global memory. The first is preferred. + tymed : TYMED_ISTREAM or TYMED_HGLOBAL; + ); + +implementation + +uses + VirtualTrees.Clipboard, + VirtualTrees.DataObject; + +type + TBaseVirtualTreeCracker = class(TBaseVirtualTree); + + TVTDragManagerHelper = class helper for TVTDragManager + function TreeView : TBaseVirtualTreeCracker; + end; + + + //----------------- TEnumFormatEtc ------------------------------------------------------------------------------------- + +constructor TEnumFormatEtc.Create(const AFormatEtcArray : TFormatEtcArray); +var + I : Integer; +begin + inherited Create; + // Make a local copy of the format data. + SetLength(FFormatEtcArray, Length(AFormatEtcArray)); + for I := 0 to High(AFormatEtcArray) do + FFormatEtcArray[I] := AFormatEtcArray[I]; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TEnumFormatEtc.Clone(out Enum : IEnumFormatEtc) : HResult; +var + AClone : TEnumFormatEtc; +begin + Result := S_OK; + try + AClone := TEnumFormatEtc.Create(FFormatEtcArray); + AClone.FCurrentIndex := FCurrentIndex; + Enum := AClone as IEnumFormatEtc; + except + Result := E_FAIL; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TEnumFormatEtc.Next(celt : Integer; out elt; pceltFetched : PLongint) : HResult; +var + CopyCount : Integer; +begin + Result := S_FALSE; + CopyCount := Length(FFormatEtcArray) - FCurrentIndex; + if celt < CopyCount then + CopyCount := celt; + if CopyCount > 0 then + begin + Move(FFormatEtcArray[FCurrentIndex], elt, CopyCount * SizeOf(TFormatEtc)); + Inc(FCurrentIndex, CopyCount); + Result := S_OK; + end; + if Assigned(pceltFetched) then + pceltFetched^ := CopyCount; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TEnumFormatEtc.Reset : HResult; +begin + FCurrentIndex := 0; + Result := S_OK; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TEnumFormatEtc.Skip(celt : Integer) : HResult; +begin + if FCurrentIndex + celt < High(FFormatEtcArray) then + begin + Inc(FCurrentIndex, celt); + Result := S_OK; + end + else + Result := S_FALSE; +end; + + +//---------------------------------------------------------------------------------------------------------------------- + +// OLE drag and drop support classes +// This is quite heavy stuff (compared with the VCL implementation) but is much better suited to fit the needs +// of DD'ing various kinds of virtual data and works also between applications. + + +//----------------- TVTDragManager ------------------------------------------------------------------------------------- + +constructor TVTDragManager.Create(AOwner : TBaseVirtualTree); +begin + inherited Create; + FOwner := AOwner; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +destructor TVTDragManager.Destroy; +begin + // Set the owner's reference to us to nil otherwise it will access an invalid pointer + // after our desctruction is complete. + TreeView.ClearDragManager; + inherited; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDragManager.GetDataObject : IDataObject; +begin + // When the owner tree starts a drag operation then it gets a data object here to pass it to the OLE subsystem. + // In this case there is no local reference to a data object and one is created (but not stored). + // If there is a local reference then the owner tree is currently the drop target and the stored interface is + // that of the drag initiator. + if Assigned(FDataObject) then + Result := FDataObject + else + begin + Result := TreeView.DoCreateDataObject; + if (Result = nil) and not Assigned(TreeView.OnCreateDataObject) then + // Do not create a TVTDataObject if the event handler explicitely decided not to supply one, issue #736. + Result := TVTDataObject.Create(FOwner, False) as IDataObject; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDragManager.GetDragSource : TBaseVirtualTree; +begin + Result := FDragSource; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDragManager.GetIsDropTarget : Boolean; +begin + Result := FIsDropTarget; +end; + +class function TVTDragManager.GetTreeFromDataObject(const DataObject: TVTDragDataObject): TBaseVirtualTree; +// Returns the owner/sender of the given data object by means of a special clipboard format +// or nil if the sender is in another process or no virtual tree at all. + +var + Medium: TStgMedium; + Data: PVTReference; + +begin + Result := nil; + if Assigned(DataObject) then + begin + StandardOLEFormat.cfFormat := CF_VTREFERENCE; + if DataObject.GetData(StandardOLEFormat, Medium) = S_OK then + begin + Data := GlobalLock(Medium.hGlobal); + if Assigned(Data) then + begin + if Data.Process = GetCurrentProcessID then + Result := Data.Tree; + GlobalUnlock(Medium.hGlobal); + end; + ReleaseStgMedium(Medium); + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDragManager.DragEnter(const DataObject : IDataObject; KeyState : Integer; Pt : TPoint; var Effect : Integer) : HResult; +var + Medium: TStgMedium; + HeaderFormatEtc: TFormatEtc; +begin + if not Assigned(FDropTargetHelper) then + CoCreateInstance(CLSID_DragDropHelper, nil, CLSCTX_INPROC_SERVER, IID_IDropTargetHelper, FDropTargetHelper); + + FDataObject := DataObject; + FIsDropTarget := True; + + SystemParametersInfo(SPI_GETDRAGFULLWINDOWS, 0, @FFullDragging, 0); + // If full dragging of window contents is disabled in the system then our tree windows will be locked + // and cannot be updated during a drag operation. With the following call painting is again enabled. + if not FFullDragging then + LockWindowUpdate(0); + if Assigned(FDropTargetHelper) and FFullDragging then + begin + if (toAutoScroll in TreeView.TreeOptions.AutoOptions) and (toAcceptOLEDrop in TreeView.TreeOptions.MiscOptions) then + FDropTargetHelper.DragEnter(FOwner.Handle, DataObject, Pt, Effect) + else + FDropTargetHelper.DragEnter(0, DataObject, Pt, Effect); // Do not pass handle, otherwise the IDropTargetHelper will perform autoscroll. Issue #486 + end; + FDragSource := GetTreeFromDataObject(DataObject); + Result := TreeView.DragEnter(KeyState, Pt, Effect); + HeaderFormatEtc := StandardOLEFormat; + HeaderFormatEtc.cfFormat := CF_VTHEADERREFERENCE; + if (DataObject.GetData(HeaderFormatEtc, Medium) = S_OK) and (FDragSource = FOWner) then + begin + FHeader := FDragSource.Header; + FDRagSource := nil; + end + else + begin + fHeader := nil; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDragManager.DragLeave : HResult; +begin + if Assigned(FDropTargetHelper) and FFullDragging then + FDropTargetHelper.DragLeave; + + if (toAcceptOLEDrop in TreeView.TreeOptions.MiscOptions) then + TreeView.DragLeave; + FIsDropTarget := False; + FDragSource := nil; + FDataObject := nil; + fHeader := nil; + Result := NOERROR; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDragManager.DragOver(KeyState : Integer; Pt : TPoint; var Effect : Integer) : HResult; +begin + if Assigned(FDropTargetHelper) and FFullDragging then + FDropTargetHelper.DragOver(Pt, Effect); + + Result := NOERROR; + if Assigned(fHeader) then + begin + TreeView.Header.DragTo(Pt); + end + else if (toAcceptOLEDrop in TreeView.TreeOptions.MiscOptions) then + Result := TreeView.DragOver(FDragSource, KeyState, dsDragMove, Pt, Effect); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDragManager.Drop(const DataObject : IDataObject; KeyState : Integer; Pt : TPoint; var Effect : Integer) : HResult; +begin + if Assigned(FDropTargetHelper) and FFullDragging then + FDropTargetHelper.Drop(DataObject, Pt, Effect); + + if Assigned(fHeader) then + begin + FHeader.ColumnDropped(Pt); + Result := NO_ERROR; + end + else + Result := TreeView.DragDrop(DataObject, KeyState, Pt, Effect); + FIsDropTarget := False; + FDataObject := nil; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTDragManager.ForceDragLeave; +// Some drop targets, e.g. Internet Explorer leave a drag image on screen instead removing it when they receive +// a drop action. This method calls the drop target helper's DragLeave method to ensure it removes the drag image from +// screen. Unfortunately, sometimes not even this does help (e.g. when dragging text from VT to a text field in IE). +begin + if Assigned(FDropTargetHelper) and FFullDragging then + FDropTargetHelper.DragLeave; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDragManager.GiveFeedback(Effect : Integer) : HResult; +begin + Result := DRAGDROP_S_USEDEFAULTCURSORS; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDragManager.QueryContinueDrag(EscapePressed : BOOL; KeyState : Integer) : HResult; +var + RButton, LButton : Boolean; +begin + LButton := (KeyState and MK_LBUTTON) <> 0; + RButton := (KeyState and MK_RBUTTON) <> 0; + + // Drag'n drop canceled by pressing both mouse buttons or Esc? + if (LButton and RButton) or EscapePressed then + Result := DRAGDROP_S_CANCEL + else + // Drag'n drop finished? + if not (LButton or RButton) then + Result := DRAGDROP_S_DROP + else + Result := S_OK; +end; + +{ TVTDragManagerHelper } + +function TVTDragManagerHelper.TreeView : TBaseVirtualTreeCracker; +begin + Result := TBaseVirtualTreeCracker(FOwner); +end; + +end. diff --git a/components/virtualtreeview/Source/VirtualTrees.DrawTree.pas b/components/virtualtreeview/Source/VirtualTrees.DrawTree.pas new file mode 100644 index 000000000..0fb1e38d4 --- /dev/null +++ b/components/virtualtreeview/Source/VirtualTrees.DrawTree.pas @@ -0,0 +1,354 @@ +unit VirtualTrees.DrawTree; + +interface + +uses + System.Types, + System.Classes, + Vcl.Themes, + VirtualTrees.Types, + VirtualTrees.BaseTree, +{$IFDEF VT_FMX} + VirtualTrees.AncestorFMX, +{$ELSE} + VirtualTrees.AncestorVCL +{$ENDIF} + ; + +type +{$IFDEF VT_FMX} + TVTAncestor = TVTAncestorFMX; +{$ELSE} + TVTAncestor = TVTAncestorVcl; +{$ENDIF} + + // Tree descendant to let an application draw its stuff itself. + TCustomVirtualDrawTree = class(TVTAncestor) + private + FOnDrawNode: TVTDrawNodeEvent; + FOnGetCellContentMargin: TVTGetCellContentMarginEvent; + FOnGetNodeWidth: TVTGetNodeWidthEvent; + protected + function DoGetCellContentMargin(Node: PVirtualNode; Column: TColumnIndex; + CellContentMarginType: TVTCellContentMarginType = ccmtAllSides; Canvas: TCanvas = nil): TPoint; override; + function DoGetNodeWidth(Node: PVirtualNode; Column: TColumnIndex; Canvas: TCanvas = nil): TDimension; override; + procedure DoPaintNode(var PaintInfo: TVTPaintInfo); override; + function GetDefaultHintKind: TVTHintKind; override; + + property OnDrawNode: TVTDrawNodeEvent read FOnDrawNode write FOnDrawNode; + property OnGetCellContentMargin: TVTGetCellContentMarginEvent read FOnGetCellContentMargin write FOnGetCellContentMargin; + property OnGetNodeWidth: TVTGetNodeWidthEvent read FOnGetNodeWidth write FOnGetNodeWidth; + end; + + {$if CompilerVersion >= 33} + [ComponentPlatformsAttribute(pfidWindows)] + {$ifend} + TVirtualDrawTree = class(TCustomVirtualDrawTree) + private + function GetOptions: TVirtualTreeOptions; + procedure SetOptions(const Value: TVirtualTreeOptions); + protected + function GetOptionsClass: TTreeOptionsClass; override; + public + property Canvas; + property LastDragEffect; + property CheckImageKind; // should no more be published to make #622 fix working + published + property Action; + property Align; + property Alignment; + property Anchors; + property AnimationDuration; + property AutoExpandDelay; + property AutoScrollDelay; + property AutoScrollInterval; + property Background; + property BackgroundOffsetX; + property BackgroundOffsetY; + property BiDiMode; + property BevelEdges; + property BevelInner; + property BevelOuter; + property BevelKind; + property BevelWidth; + property BorderStyle; + property BottomSpace; + property ButtonFillMode; + property ButtonStyle; + property BorderWidth; + property ChangeDelay; + property ClipboardFormats; + property Color; + property Colors; + property Constraints; + property Ctl3D; + property CustomCheckImages; + property DefaultNodeHeight; + property DefaultPasteMode; + property DragCursor; + property DragHeight; + property DragKind; + property DragImageKind; + property DragMode; + property DragOperations; + property DragType; + property DragWidth; + property DrawSelectionMode; + property EditDelay; + property Enabled; + property Font; + property Header; + property HintMode; + property HotCursor; + property Images; + property IncrementalSearch; + property IncrementalSearchDirection; + property IncrementalSearchStart; + property IncrementalSearchTimeout; + property Indent; + property LineMode; + property LineStyle; + property Margin; + property NodeAlignment; + property NodeDataSize; + property OperationCanceled; + property ParentBiDiMode; + property ParentColor default False; + property ParentCtl3D; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property RootNodeCount; + property ScrollBarOptions; + property SelectionBlendFactor; + property SelectionCurveRadius; + property ShowHint; + property StateImages; + property TabOrder; + property TabStop default True; + property TextMargin; + property TreeOptions: TVirtualTreeOptions read GetOptions write SetOptions; + property Visible; + property WantTabs; + + property OnAddToSelection; + property OnAdvancedHeaderDraw; + property OnAfterAutoFitColumn; + property OnAfterAutoFitColumns; + property OnAfterCellPaint; + property OnAfterColumnExport; + property OnAfterColumnWidthTracking; + property OnAfterGetMaxColumnWidth; + property OnAfterHeaderExport; + property OnAfterHeaderHeightTracking; + property OnAfterItemErase; + property OnAfterItemPaint; + property OnAfterNodeExport; + property OnAfterPaint; + property OnAfterTreeExport; + property OnBeforeAutoFitColumn; + property OnBeforeAutoFitColumns; + property OnBeforeCellPaint; + property OnBeforeColumnExport; + property OnBeforeColumnWidthTracking; + property OnBeforeDrawTreeLine; + property OnBeforeGetMaxColumnWidth; + property OnBeforeHeaderExport; + property OnBeforeHeaderHeightTracking; + property OnBeforeItemErase; + property OnBeforeItemPaint; + property OnBeforeNodeExport; + property OnBeforePaint; + property OnBeforeTreeExport; + property OnCanSplitterResizeColumn; + property OnCanSplitterResizeHeader; + property OnCanSplitterResizeNode; + property OnChange; + property OnChecked; + property OnChecking; + property OnClick; + property OnCollapsed; + property OnCollapsing; + property OnColumnChecked; + property OnColumnChecking; + property OnColumnClick; + property OnColumnDblClick; + property OnColumnExport; + property OnColumnResize; + property OnColumnVisibilityChanged; + property OnColumnWidthDblClickResize; + property OnColumnWidthTracking; + property OnCompareNodes; + property OnContextPopup; + property OnCreateDataObject; + property OnCreateDragManager; + property OnCreateEditor; + property OnDblClick; + property OnDragAllowed; + property OnDragOver; + property OnDragDrop; + property OnDrawHint; + property OnDrawNode; + property OnEdited; + property OnEditing; + property OnEndDock; + property OnEndDrag; + property OnEndOperation; + property OnEnter; + property OnExit; + property OnExpanded; + property OnExpanding; + property OnFocusChanged; + property OnFocusChanging; + property OnFreeNode; + property OnGetCellIsEmpty; + property OnGetCursor; + property OnGetHeaderCursor; + property OnGetHelpContext; + property OnGetHintKind; + property OnGetHintSize; + property OnGetImageIndex; + property OnGetImageIndexEx; + property OnGetLineStyle; + property OnGetNodeDataSize; + property OnGetNodeWidth; + property OnGetPopupMenu; + property OnGetUserClipboardFormats; + property OnHeaderAddPopupItem; + property OnHeaderClick; + property OnHeaderDblClick; + property OnHeaderDragged; + property OnHeaderDraggedOut; + property OnHeaderDragging; + property OnHeaderDraw; + property OnHeaderDrawQueryElements; + property OnHeaderHeightTracking; + property OnHeaderHeightDblClickResize; + property OnHeaderMouseDown; + property OnHeaderMouseMove; + property OnHeaderMouseUp; + property OnHotChange; + property OnIncrementalSearch; + property OnInitChildren; + property OnInitNode; + property OnKeyAction; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + property OnLoadNode; + property OnLoadTree; + property OnMeasureItem; + property OnMouseDown; + property OnMouseMove; + property OnMouseUp; + property OnMouseWheel; + property OnNodeClick; + property OnNodeCopied; + property OnNodeCopying; + property OnNodeDblClick; + property OnNodeExport; + property OnNodeHeightTracking; + property OnNodeHeightDblClickResize; + property OnNodeMoved; + property OnNodeMoving; + property OnPaintBackground; + property OnPrepareButtonBitmaps; + property OnRemoveFromSelection; + property OnRenderOLEData; + property OnResetNode; + property OnResize; + property OnSaveNode; + property OnSaveTree; + property OnScroll; + property OnShowScrollBar; + property OnStartDock; + property OnStartDrag; + property OnStartOperation; + property OnStateChange; + property OnStructureChange; + property OnUpdating; + property OnCanResize; + property OnGesture; + property Touch; + property StyleElements; + end; + + +implementation + +uses + VirtualTrees.StyleHooks; + +//---------------------------------------------------------------------------------------------------------------------- + +function TCustomVirtualDrawTree.DoGetCellContentMargin(Node: PVirtualNode; Column: TColumnIndex; + CellContentMarginType: TVTCellContentMarginType = ccmtAllSides; Canvas: TCanvas = nil): TPoint; + +begin + Result := Point(0, 0); + if Canvas = nil then + Canvas := Self.Canvas; + + if Assigned(FOnGetCellContentMargin) then + FOnGetCellContentMargin(Self, Canvas, Node, Column, CellContentMarginType, Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TCustomVirtualDrawTree.DoGetNodeWidth(Node: PVirtualNode; Column: TColumnIndex; Canvas: TCanvas = nil): TDimension; + +begin + Result := 2 * TextMargin; + if Canvas = nil then + Canvas := Self.Canvas; + + if Assigned(FOnGetNodeWidth) then + FOnGetNodeWidth(Self, Canvas, Node, Column, Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TCustomVirtualDrawTree.DoPaintNode(var PaintInfo: TVTPaintInfo); + +begin + if Assigned(FOnDrawNode) then + FOnDrawNode(Self, PaintInfo); +end; + +function TCustomVirtualDrawTree.GetDefaultHintKind: TVTHintKind; + +begin + Result := vhkOwnerDraw; +end; + +//----------------- TVirtualDrawTree ----------------------------------------------------------------------------------- + +function TVirtualDrawTree.GetOptions: TVirtualTreeOptions; + +begin + Result := inherited TreeOptions as TVirtualTreeOptions; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualDrawTree.SetOptions(const Value: TVirtualTreeOptions); + +begin + TreeOptions.Assign(Value); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualDrawTree.GetOptionsClass: TTreeOptionsClass; + +begin + Result := TVirtualTreeOptions; +end; + +initialization + TCustomStyleEngine.RegisterStyleHook(TVirtualDrawTree, TVclStyleScrollBarsHook); + +finalization + TCustomStyleEngine.UnRegisterStyleHook(TVirtualDrawTree, TVclStyleScrollBarsHook); + +end. diff --git a/components/virtualtreeview/Source/VirtualTrees.EditLink.pas b/components/virtualtreeview/Source/VirtualTrees.EditLink.pas new file mode 100644 index 000000000..6af02dd35 --- /dev/null +++ b/components/virtualtreeview/Source/VirtualTrees.EditLink.pas @@ -0,0 +1,905 @@ +unit VirtualTrees.EditLink; + +// Base class for inplace node editors implementing IVTEditLink interface +// and default node editor. + +interface + +uses + WinApi.Messages, + System.Types, + System.Classes, + Vcl.Controls, + Vcl.StdCtrls, + VirtualTrees, + VirtualTrees.Types, + VirtualTrees.BaseTree; + +type + //Edit support Classes. + TStringEditLink = class; + + TVTEdit = class(TCustomEdit) + private + procedure CMAutoAdjust(var Message : TMessage); message CM_AUTOADJUST; + procedure CMExit(var Message : TMessage); message CM_EXIT; + procedure CMRelease(var Message : TMessage); message CM_RELEASE; + procedure CNCommand(var Message : TWMCommand); message CN_COMMAND; + procedure WMChar(var Message : TWMChar); message WM_CHAR; + procedure WMDestroy(var Message : TWMDestroy); message WM_DESTROY; + procedure WMGetDlgCode(var Message : TWMGetDlgCode); message WM_GETDLGCODE; + procedure WMKeyDown(var Message : TWMKeyDown); message WM_KEYDOWN; + protected + FRefLink : IVTEditLink; + FLink : TStringEditLink; + procedure AutoAdjustSize; virtual; + function CalcMinHeight : Integer; virtual; + procedure CreateParams(var Params : TCreateParams); override; + function GetTextSize : TSize; virtual; + procedure KeyPress(var Key : Char); override; + public + constructor Create(Link : TStringEditLink); reintroduce; + procedure ClearLink; + procedure ClearRefLink; + procedure Release; virtual; + + property AutoSelect; + property AutoSize; + property BorderStyle; + property CharCase; + property HideSelection; + property MaxLength; + property OEMConvert; + property PasswordChar; + end; + + TBaseEditLink = class; + + TEditLinkEditEvent = procedure (Sender: TBaseEditLink; var Result: Boolean) of object; + TEditLinkPrepareEditEvent = procedure (Sender: TBaseEditLink; var Edit: TControl; var Result: Boolean) of object; + + // Most abstract base class for implementing IVTEditLink. + // Knows almost nothing about associated Edit control and doesn't perform any + // actions on it. Contains some properties that are not used directly but could + // be useful in descendant classes. Follows general extension approach - all + // IVTEditLink methods are virtual and most of them call DoXXX virtual methods + // which in turn call event handlers so these extension options possible: + // - overriding main API methods to run additional actions before, after or + // instead of basic class code. + // (+) Lesser modification of existing classes + // (-) Event handlers are already launched after calling parent method + // (-) It's critical to check Result of parent method and exit immediately + // on False - this value means no action is done. + // (-) Returning Result is necessary + // - overriding DoXXX methods to run additional actions inside basic class code + // (+) No need in returning - lesser boilerplate code + // (-) Should call inherited to launch event handlers (OK if not using them) + // - assign event handlers in end-user code + // (+) Access to external classes with data to copy to EditLink editor. + // (-) Lesser encapsulation + TBaseEditLink = class(TInterfacedObject, IVTEditLink) + strict protected + FEdit: TControl; // One of the property editor classes. + FTree : TCustomVirtualStringTree; //A back reference to the tree calling. + FNode : PVirtualNode; //The node to be edited. + FColumn : TColumnIndex; //The column of the node. + FStopping : Boolean; //Set to True when the edit link requests stopping the edit action. + FAlignment : TAlignment; + FBiDiMode: TBiDiMode; + + // custom event handlers + FOnPrepareEdit: TEditLinkPrepareEditEvent; + FOnBeginEdit, + FOnEndEdit, + FOnCancelEdit: TEditLinkEditEvent; + + procedure SetEdit(const Value : TControl); //Setter for the FEdit member; + public + // IVTEditLink API + function BeginEdit : Boolean; virtual; stdcall; + function CancelEdit : Boolean; virtual; stdcall; + function EndEdit : Boolean; virtual; stdcall; + function GetBounds : TRect; virtual; stdcall; abstract; + function PrepareEdit(Tree : TBaseVirtualTree; Node : PVirtualNode; Column : TColumnIndex) : Boolean; virtual; stdcall; + procedure ProcessMessage(var Message : TMessage); virtual; stdcall; abstract; + procedure SetBounds(R : TRect); virtual; stdcall; abstract; + + // Methods to plug custom actions into main ones. In base class only call event handlers. + // Descendants may modify Result to cancel further flow. + procedure DoBeginEdit(var Result: Boolean); virtual; + procedure DoCancelEdit(var Result: Boolean); virtual; + procedure DoEndEdit(var Result: Boolean); virtual; + procedure DoPrepareEdit(var Result: Boolean); virtual; + + property Alignment : TAlignment read FAlignment; + property BiDiMode: TBiDiMode read FBiDiMode; + property Column : TColumnIndex read FColumn; //[IPK] Make Column(Index) accessible + property Node : PVirtualNode read FNode; //[IPK] Make FNode accessible + property Tree : TCustomVirtualStringTree read FTree; + property Stopping : Boolean read FStopping; + + property OnBeginEdit: TEditLinkEditEvent read FOnBeginEdit write FOnBeginEdit; + property OnCancelEdit: TEditLinkEditEvent read FOnCancelEdit write FOnCancelEdit; + property OnEndEdit: TEditLinkEditEvent read FOnEndEdit write FOnEndEdit; + property OnPrepareEdit: TEditLinkPrepareEditEvent read FOnPrepareEdit write FOnPrepareEdit; + end; + + // Edit link that has TWinControl-based Edit. Performs visibility and focus actions, + // transfers window messages to Edit control. + TWinControlEditLink = class(TBaseEditLink) + protected + function GetEdit: TWinControl; //Getter for the FEdit member; + procedure SetEdit(const Value : TWinControl); //Setter for the FEdit member; + public + destructor Destroy; override; + + function BeginEdit : Boolean; override; stdcall; + function CancelEdit : Boolean; override; stdcall; + function EndEdit : Boolean; override; stdcall; + function GetBounds : TRect; override; stdcall; + procedure ProcessMessage(var Message : TMessage); override; stdcall; + + property Edit : TWinControl read GetEdit write SetEdit; + end; + + // Edit link that implements default node text editor. + TStringEditLink = class(TWinControlEditLink) + protected + FTextBounds : TRect; //Smallest rectangle around the text. + function GetEdit: TVTEdit; //Getter for the FEdit member; + procedure SetEdit(const Value : TVTEdit); //Setter for the FEdit member; + + procedure InitializeSelection; virtual; + public + constructor Create; + + function BeginEdit : Boolean; override; stdcall; + function CancelEdit : Boolean; override; stdcall; + function EndEdit : Boolean; override; stdcall; + function PrepareEdit(Tree : TBaseVirtualTree; Node : PVirtualNode; Column : TColumnIndex) : Boolean; override; stdcall; + procedure SetBounds(R : TRect); override; stdcall; + + property Edit : TVTEdit read GetEdit write SetEdit; + end; + +implementation + +uses + WinApi.Windows, + System.SysUtils, + System.Math, + Vcl.Graphics, + Vcl.Forms; + +type + TCustomVirtualStringTreeCracker = class(TCustomVirtualStringTree); + +//----------------- TVTEdit -------------------------------------------------------------------------------------------- + +//Implementation of a generic node caption editor. + +constructor TVTEdit.Create(Link : TStringEditLink); +begin + inherited Create(nil); + if not Assigned(Link) then + raise EArgumentException.Create('Parameter Link must not be nil.'); + ShowHint := False; + ParentShowHint := False; + //This assignment increases the reference count for the interface. + FRefLink := Link; + //This reference is used to access the link. + FLink := Link; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTEdit.ClearLink; +begin + FLink := nil +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTEdit.ClearRefLink; +begin + FRefLink := nil +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTEdit.CalcMinHeight : Integer; +var + textHeight : Integer; +begin + //Get the actual text height. + textHeight := GetTextSize.cy; + //The minimal height is the actual text height in pixels plus the the non client area. + Result := textHeight + (Height - ClientHeight); + //Also, proportionally to the text size, additional pixel(s) needs to be added for the caret. + Result := Result + Trunc(textHeight * 0.05); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTEdit.CMAutoAdjust(var Message : TMessage); +begin + AutoAdjustSize; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTEdit.CMExit(var Message : TMessage); +begin + if Assigned(FLink) and not FLink.Stopping then + with TCustomVirtualStringTreeCracker(FLink.Tree) do + begin + if (toAutoAcceptEditChange in TreeOptions.StringOptions) then + DoEndEdit + else + DoCancelEdit; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTEdit.CMRelease(var Message : TMessage); +begin + Free; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTEdit.CNCommand(var Message : TWMCommand); +begin + if Assigned(FLink) and Assigned(FLink.Tree) and (Message.NotifyCode = EN_UPDATE) and not (vsMultiline in FLink.Node.States) then + //Instead directly calling AutoAdjustSize it is necessary on Win9x/Me to decouple this notification message + //and eventual resizing. Hence we use a message to accomplish that. + AutoAdjustSize() + else + inherited; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTEdit.WMChar(var Message : TWMChar); +begin + if not (Message.CharCode in [VK_ESCAPE, VK_TAB]) then + inherited; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTEdit.WMDestroy(var Message : TWMDestroy); +begin + //If editing stopped by other means than accept or cancel then we have to do default processing for + //pending changes. + if Assigned(FLink) and not FLink.Stopping and not (csRecreating in Self.ControlState) then + begin + with TCustomVirtualStringTreeCracker(FLink.Tree) do + begin + if (toAutoAcceptEditChange in TreeOptions.StringOptions) and Modified then + Text[FLink.Node, FLink.Column] := FLink.Edit.Text; + end; + FLink := nil; + FRefLink := nil; + end; + + inherited; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTEdit.WMGetDlgCode(var Message : TWMGetDlgCode); +begin + inherited; + + Message.Result := Message.Result or DLGC_WANTALLKEYS or DLGC_WANTTAB or DLGC_WANTARROWS; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTEdit.WMKeyDown(var Message : TWMKeyDown); +//Handles some control keys. + +var + Shift : TShiftState; + EndEdit : Boolean; + Tree : TBaseVirtualTree; + NextNode : PVirtualNode; + ColumnCandidate : Integer; + EditOptions : TVTEditOptions; + Column : TVirtualTreeColumn; +begin + Tree := FLink.Tree; + case Message.CharCode of + VK_ESCAPE : + begin + TCustomVirtualStringTreeCracker(Tree).DoCancelEdit; + end; + VK_RETURN : + begin + EndEdit := not (vsMultiline in FLink.Node.States); + if not EndEdit then + begin + //If a multiline node is being edited the finish editing only if Ctrl+Enter was pressed, + //otherwise allow to insert line breaks into the text. + Shift := KeyDataToShiftState(Message.KeyData); + EndEdit := ssCtrl in Shift; + end; + if EndEdit then + begin + Tree := FLink.Tree; + FLink.Tree.InvalidateNode(FLink.Node); + NextNode := Tree.GetNextVisible(FLink.Node, True); + TCustomVirtualStringTreeCracker(FLink.Tree).DoEndEdit; + + //get edit options for column as priority. If column has toDefaultEdit + //use global edit options for tree + EditOptions := TCustomVirtualStringTreeCracker(Tree).TreeOptions.EditOptions; //default + ColumnCandidate := - 1; + if Tree.Header.Columns.Count > 0 then //are there any columns? + begin + Column := Tree.Header.Columns[Tree.FocusedColumn]; + if Column.EditOptions <> toDefaultEdit then + EditOptions := Column.EditOptions; + + //next column candidate for toVerticalEdit and toHorizontalEdit + if Column.EditNextColumn <> - 1 then + ColumnCandidate := Column.EditNextColumn; + end; + + case EditOptions of + toDefaultEdit : + TCustomVirtualStringTreeCracker(Tree).TrySetFocus; + toVerticalEdit : + if NextNode <> nil then + begin + Tree.FocusedNode := NextNode; + + //for toVerticalEdit ColumnCandidate is also proper, + //select ColumnCandidate column in row below + if ColumnCandidate <> - 1 then + begin + Tree.FocusedColumn := ColumnCandidate; + TCustomVirtualStringTreeCracker(Tree).EditColumn := ColumnCandidate; + end; + + if Tree.CanEdit(Tree.FocusedNode, Tree.FocusedColumn) then + TCustomVirtualStringTreeCracker(Tree).DoEdit; + end; + toHorizontalEdit : + begin + if ColumnCandidate = - 1 then + begin + //for toHorizontalEdit if property EditNextColumn is not used + //try to use just next column + ColumnCandidate := Tree.FocusedColumn + 1; + while (ColumnCandidate < Tree.Header.Columns.Count) and not Tree.CanEdit(Tree.FocusedNode, ColumnCandidate) do + Inc(ColumnCandidate); + end + else if not Tree.CanEdit(Tree.FocusedNode, ColumnCandidate) then + ColumnCandidate := Tree.Header.Columns.Count; //omit "focus/edit column" (see below) + + if ColumnCandidate < Tree.Header.Columns.Count then + begin + Tree.FocusedColumn := ColumnCandidate; + TCustomVirtualStringTreeCracker(Tree).EditColumn := ColumnCandidate; + TCustomVirtualStringTreeCracker(Tree).DoEdit; + end; + end; + end; + end; + end; + VK_UP : + begin + if not (vsMultiline in FLink.Node.States) then + Message.CharCode := VK_LEFT; + inherited; + end; + VK_DOWN : + begin + if not (vsMultiline in FLink.Node.States) then + Message.CharCode := VK_RIGHT; + inherited; + end; + VK_TAB : + begin + if Tree.IsEditing then + begin + Tree.InvalidateNode(FLink.Node); + if ssShift in KeyDataToShiftState(Message.KeyData) then + NextNode := Tree.GetPreviousVisible(FLink.Node, True)//Shift+Tab goes to previous mode + else + NextNode := Tree.GetNextVisible(FLink.Node, True); + Tree.EndEditNode; + //check NextNode, otherwise we got AV + if NextNode <> nil then + begin + //Continue editing next node + Tree.ClearSelection(); + Tree.Selected[NextNode] := True; + if Tree.CanEdit(Tree.FocusedNode, Tree.FocusedColumn) then + TCustomVirtualStringTreeCracker(Tree).DoEdit; + end; + end; + end; + Ord('A') : + begin + if Tree.IsEditing and ([ssCtrl] = KeyboardStateToShiftState) then + begin + Self.SelectAll(); + Message.CharCode := 0; + end; + end; + else + inherited; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTEdit.AutoAdjustSize; +//Changes the size of the edit to accomodate as much as possible of its text within its container window. +//NewChar describes the next character which will be added to the edit's text. + +var + Size : TSize; +begin + if not (vsMultiline in FLink.Node.States) and not (toGridExtensions in TCustomVirtualStringTreeCracker(FLink.Tree).TreeOptions.MiscOptions { see issue #252 } ) then + begin + //avoid flicker + SendMessage(Handle, WM_SETREDRAW, 0, 0); + try + Size := GetTextSize; + Inc(Size.cx, 2 * TCustomVirtualStringTreeCracker(FLink.Tree).TextMargin); + //Repaint associated node if the edit becomes smaller. + if Size.cx < Width then + FLink.Tree.Invalidate(); + + if FLink.Alignment = taRightJustify then + FLink.SetBounds(Rect(Left + Width - Size.cx, Top, Left + Width, Top + Max(Size.cy, Height))) + else + FLink.SetBounds(Rect(Left, Top, Left + Size.cx, Top + Max(Size.cy, Height))); + finally + SendMessage(Handle, WM_SETREDRAW, 1, 0); + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTEdit.CreateParams(var Params : TCreateParams); +begin + inherited; + if not Assigned(FLink.Node) then + exit; //Prevent AV exceptions occasionally seen in code below + + //Only with multiline style we can use the text formatting rectangle. + //This does not harm formatting as single line control, if we don't use word wrapping. + with Params do + begin + Style := Style or ES_MULTILINE; + if vsMultiline in FLink.Node.States then + Style := Style and not (ES_AUTOHSCROLL or WS_HSCROLL) or WS_VSCROLL or ES_AUTOVSCROLL; + if tsUseThemes in FLink.Tree.TreeStates then + begin + Style := Style and not WS_BORDER; + ExStyle := ExStyle or WS_EX_CLIENTEDGE; + end + else + begin + Style := Style or WS_BORDER; + ExStyle := ExStyle and not WS_EX_CLIENTEDGE; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTEdit.GetTextSize : TSize; +var + DC : HDC; + LastFont : THandle; +begin + DC := GetDC(Handle); + LastFont := SelectObject(DC, Font.Handle); + try + //Read needed space for the current text. + GetTextExtentPoint32(DC, PChar(Text + 'yG'), Length(Text) + 2, Result); + finally + SelectObject(DC, LastFont); + ReleaseDC(Handle, DC); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- +procedure TVTEdit.KeyPress(var Key : Char); +begin + if (Key = #13) and Assigned(FLink) and not (vsMultiline in FLink.Node.States) then + Key := #0; //Filter out return keys as they will be added to the text, avoids #895 + inherited; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTEdit.Release; +begin + if HandleAllocated then + PostMessage(Handle, CM_RELEASE, 0, 0); +end; + +//----------------- TBaseEditLink -------------------------------------------------------------------------------------- + +procedure TBaseEditLink.SetEdit(const Value : TControl); +begin + if Assigned(FEdit) then + FEdit.Free; + FEdit := Value; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseEditLink.BeginEdit : Boolean; +//Notifies the edit link that editing can start now. descendants may cancel node edit +//by returning False. + +begin + Result := not FStopping; + if Result then + DoBeginEdit(Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseEditLink.CancelEdit : Boolean; + +// Performs edit cancelling. + +begin + Result := not FStopping; + if Result then + begin + // Let descendants cancel the cancel + DoCancelEdit(Result); + if not Result then + Exit; + FStopping := True; + FTree.CancelEditNode; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseEditLink.EndEdit : Boolean; + +// Performs edit ending. + +begin + Result := not FStopping; + if Result then + begin + // Let descendants cancel the end + DoEndEdit(Result); + if not Result then + Exit; + FStopping := True; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TBaseEditLink.PrepareEdit(Tree : TBaseVirtualTree; Node : PVirtualNode; Column : TColumnIndex) : Boolean; + +// Performs general init: assign Tree, Node, Column, other properties; destroys previous +// edit instance. + +begin + Result := Tree is TCustomVirtualStringTree; + if not Result then Exit; // should not happen + + FTree := Tree as TCustomVirtualStringTree; + FNode := Node; + FColumn := Column; + if Column <= NoColumn then + begin + FBidiMode := FTree.BidiMode; + FAlignment := TCustomVirtualStringTreeCracker(FTree).Alignment; + end + else + begin + FBidiMode := FTree.Header.Columns[Column].BidiMode; + FAlignment := FTree.Header.Columns[Column].Alignment; + end; + SetEdit(nil); // always dispose edit + + DoPrepareEdit(Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseEditLink.DoBeginEdit(var Result: Boolean); +begin + if Assigned(OnBeginEdit) then + OnBeginEdit(Self, Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseEditLink.DoCancelEdit(var Result: Boolean); +begin + if Assigned(OnCancelEdit) then + OnCancelEdit(Self, Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseEditLink.DoEndEdit(var Result: Boolean); +begin + if Assigned(OnEndEdit) then + OnEndEdit(Self, Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TBaseEditLink.DoPrepareEdit(var Result: Boolean); +begin + if Assigned(OnPrepareEdit) then + OnPrepareEdit(Self, FEdit, Result); +end; + +//----------------- TWinControlEditLink ------------------------------------------------------------------------------------ + +destructor TWinControlEditLink.Destroy; +begin + //FEdit.Free; casues issue #357. Fix: + if Assigned(FEdit) and Edit.HandleAllocated then + PostMessage(Edit.Handle, CM_RELEASE, 0, 0); + inherited; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TWinControlEditLink.GetEdit: TWinControl; +begin + Result := TWinControl(FEdit); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TWinControlEditLink.SetEdit(const Value: TWinControl); +begin + inherited SetEdit(Value); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TWinControlEditLink.BeginEdit: Boolean; +begin + Result := inherited; + if Result then + begin + Edit.Show; + Edit.SetFocus; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TWinControlEditLink.CancelEdit: Boolean; +begin + Result := inherited; + if Result then + begin + Edit.Hide; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TWinControlEditLink.GetBounds : TRect; +begin + Result := FEdit.BoundsRect; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TWinControlEditLink.ProcessMessage(var Message : TMessage); +begin + FEdit.WindowProc(Message); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TWinControlEditLink.EndEdit: Boolean; +begin + Result := inherited; + if Result then + begin + Edit.Hide; + end; +end; + +//----------------- TStringEditLink ------------------------------------------------------------------------------------ + +constructor TStringEditLink.Create; +begin + inherited; + FEdit := TVTEdit.Create(Self); + with Edit do + begin + Visible := False; + BorderStyle := bsSingle; + AutoSize := False; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TStringEditLink.GetEdit: TVTEdit; +begin + Result := TVTEdit(FEdit); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TStringEditLink.InitializeSelection; +begin + Edit.SelectAll; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TStringEditLink.SetEdit(const Value : TVTEdit); +begin + inherited SetEdit(Value); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TStringEditLink.BeginEdit : Boolean; +begin + Result := inherited; + if Result then + begin + InitializeSelection; + Edit.AutoAdjustSize; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TStringEditLink.CancelEdit : Boolean; +begin + Result := inherited; + if Result then + begin + Edit.ClearLink; + Edit.ClearRefLink; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TStringEditLink.EndEdit : Boolean; +begin + Result := inherited; + if Result then + try + if Edit.Modified then + FTree.Text[FNode, FColumn] := Edit.Text; + Edit.ClearLink; + Edit.ClearRefLink; + except + FStopping := False; + raise; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TStringEditLink.PrepareEdit(Tree : TBaseVirtualTree; Node : PVirtualNode; Column : TColumnIndex) : Boolean; +var + Text : string; +begin + Result := inherited; + if Result then + begin + Edit := TVTEdit.Create(Self); + Edit.Visible := False; + Edit.BorderStyle := bsSingle; + Edit.AutoSize := True; + Edit.Parent := Tree; + //Initial size, font and text of the node. + FTree.GetTextInfo(Node, Column, Edit.Font, FTextBounds, Text); + Edit.Font.Color := clWindowText; + Edit.RecreateWnd; + Edit.AutoSize := False; + Edit.Text := Text; + Edit.BidiMode := FBidiMode; + if Edit.BidiMode <> bdLeftToRight then + ChangeBidiModeAlignment(FAlignment); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TStringEditLink.SetBounds(R : TRect); +//Sets the outer bounds of the edit control and the actual edit area in the control. + +var + lOffset, tOffset, Height : TDimension; + offsets : TVTOffsets; +begin + if not FStopping then + begin + //Check if the provided rect height is smaller than the edit control height. + Height := R.Bottom - R.Top; + if Height < Edit.ClientHeight then + begin + //If the height is smaller than the minimal height we must correct it, otherwise the caret will be invisible. + tOffset := Edit.CalcMinHeight - Height; + if tOffset > 0 then + Inc(R.Bottom, tOffset); + end; + + //Set the edit's bounds but make sure there's a minimum width and the right border does not + //extend beyond the parent's left/right border. + if R.Left < 0 then + R.Left := 0; + if R.Right - R.Left < 30 then + begin + if FAlignment = taRightJustify then + R.Left := R.Right - 30 + else + R.Right := R.Left + 30; + end; + if R.Right > FTree.ClientWidth then + R.Right := FTree.ClientWidth; + Edit.BoundsRect := R; + + //The selected text shall exclude the text margins and be centered vertically. + //We have to take out the two pixel border of the edit control as well as a one pixel "edit border" the + //control leaves around the (selected) text. + R := Edit.ClientRect; + + //If toGridExtensions are turned on, we can fine tune the left margin (or the right margin if RTL is on) + //of the text to exactly match the text in the tree cell. + if (toGridExtensions in TCustomVirtualStringTreeCracker(FTree).TreeOptions.MiscOptions) and + ((FAlignment = taLeftJustify) and (Edit.BidiMode = bdLeftToRight) or (FAlignment = taRightJustify) and (Edit.BidiMode <> bdLeftToRight)) then + begin + //Calculate needed text area offset. + FTree.GetOffsets(FNode, offsets, ofsText, FColumn); + if FColumn = FTree.Header.MainColumn then + begin + if offsets[ofsToggleButton] < 0 then + lOffset := - (offsets[ofsToggleButton] + 2) + else + lOffset := 0; + end + else + lOffset := offsets[ofsText] - offsets[ofsMargin] + 1; + //Apply the offset. + if Edit.BidiMode = bdLeftToRight then + Inc(R.Left, lOffset) + else + Dec(R.Right, lOffset); + end; + + lOffset := IfThen(vsMultiline in FNode.States, 0, 2); + if tsUseThemes in FTree.TreeStates then + Inc(lOffset); + InflateRect(R, - TCustomVirtualStringTreeCracker(FTree).TextMargin + lOffset, lOffset); + if not (vsMultiline in FNode.States) then + begin + tOffset := FTextBounds.Top - Edit.Top; + //Do not apply a negative offset, the cursor will disappear. + if tOffset > 0 then + OffsetRect(R, 0, tOffset); + end; + R.Top := Max( - 1, R.Top); //A value smaller than -1 will prevent the edit cursor from being shown by Windows, see issue #159 + R.Left := Max( - 1, R.Left); + SendMessage(Edit.Handle, EM_SETRECTNP, 0, LPARAM(@R)); + end; +end; + +end. diff --git a/components/virtualtreeview/Source/VirtualTrees.Export.pas b/components/virtualtreeview/Source/VirtualTrees.Export.pas index 8ae32cd0f..2bfb985c8 100644 --- a/components/virtualtreeview/Source/VirtualTrees.Export.pas +++ b/components/virtualtreeview/Source/VirtualTrees.Export.pas @@ -19,14 +19,18 @@ procedure ContentToCustom(Tree: TCustomVirtualStringTree; Source: TVSTTextSource implementation uses - Vcl.Graphics, - Vcl.Controls, - Vcl.Forms, System.Classes, System.SysUtils, System.StrUtils, System.Generics.Collections, - System.UITypes; + System.UITypes, + Vcl.Graphics, + Vcl.Controls, + Vcl.Forms, + VirtualTrees.Types, + VirtualTrees.ClipBoard, + VirtualTrees.Header, + VirtualTrees.BaseTree; type TCustomVirtualStringTreeCracker = class(TCustomVirtualStringTree) @@ -67,15 +71,15 @@ function ContentToHTML(Tree: TCustomVirtualStringTree; Source: TVSTTextSourceTyp Value := 48 + (Component shr 4); if Value > $39 then - Inc(Value, 7); + System.Inc(Value, 7); Buffer.Add(AnsiChar(Value)); - Inc(I); + System.Inc(I); Value := 48 + (Component and $F); if Value > $39 then - Inc(Value, 7); + System.Inc(Value, 7); Buffer.Add(AnsiChar(Value)); - Inc(I); + System.Inc(I); WinColor := WinColor shr 8; end; @@ -104,9 +108,9 @@ function ContentToHTML(Tree: TCustomVirtualStringTree; Source: TVSTTextSourceTyp else Buffer.Add(Format('font-size: %dpt; ', [Font.Size])); - Buffer.Add(Format('font-style: %s; ', [IfThen(fsItalic in Font.Style, 'italic', 'normal')])); - Buffer.Add(Format('font-weight: %s; ', [IfThen(fsBold in Font.Style, 'bold', 'normal')])); - Buffer.Add(Format('text-decoration: %s; ', [IfThen(fsUnderline in Font.Style, 'underline', 'none')])); + Buffer.Add(Format('font-style: %s; ', [IfThen(TFontStyle.fsItalic in Font.Style, 'italic', 'normal')])); + Buffer.Add(Format('font-weight: %s; ', [IfThen(TFontStyle.fsBold in Font.Style, 'bold', 'normal')])); + Buffer.Add(Format('text-decoration: %s; ', [IfThen(TFontStyle.fsUnderline in Font.Style, 'underline', 'none')])); Buffer.Add('color: '); WriteColorAsHex(Font.Color); @@ -155,7 +159,7 @@ function ContentToHTML(Tree: TCustomVirtualStringTree; Source: TVSTTextSourceTyp // Add title if adviced so by giving a caption. if Length(Caption) > 0 then AddHeader := AddHeader + 'caption="' + Caption + '"'; - if CrackTree.Borderstyle <> bsNone then + if CrackTree.Borderstyle <> TFormBorderStyle.bsNone then AddHeader := AddHeader + Format(' border="%d" frame=box', [CrackTree.BorderWidth + 1]); Buffer.Add(''); @@ -434,7 +438,7 @@ function ContentToHTML(Tree: TCustomVirtualStringTree; Source: TVSTTextSourceTyp if not RenderColumns then Break; - Inc(I); + System.Inc(I); end; if Assigned(CrackTree.OnAfterNodeExport) then CrackTree.OnAfterNodeExport(CrackTree, etHTML, Run); @@ -535,13 +539,13 @@ function ContentToRTF(Tree: TCustomVirtualStringTree; Source: TVSTTextSourceType begin if Length(Text) > 0 then begin - UseUnderline := fsUnderline in Font.Style; + UseUnderline := TFontStyle.fsUnderline in Font.Style; if UseUnderline then Buffer.Add('\ul'); - UseItalic := fsItalic in Font.Style; + UseItalic := TFontStyle.fsItalic in Font.Style; if UseItalic then Buffer.Add('\i'); - UseBold := fsBold in Font.Style; + UseBold := TFontStyle.fsBold in Font.Style; if UseBold then Buffer.Add('\b'); SelectFont(Font.Name); @@ -630,7 +634,7 @@ function ContentToRTF(Tree: TCustomVirtualStringTree; Source: TVSTTextSourceType begin for I := 0 to High(Columns) do begin - Inc(J, Columns[I].Width); + System.Inc(J, Columns[I].Width); // This value must be expressed in twips (1 inch = 1440 twips). Twips := Round(1440 * J / Screen.PixelsPerInch); Buffer.Add('\cellx'); @@ -725,7 +729,7 @@ function ContentToRTF(Tree: TCustomVirtualStringTree; Source: TVSTTextSourceType end; // Call back the application to know about font customization. - CrackTree.Canvas.Font := CrackTree.Font; + CrackTree.Canvas.Font.Assign(CrackTree.Font); CrackTree.FFontChanged := False; CrackTree.DoPaintText(Run, CrackTree.Canvas, Index, ttNormal); @@ -764,7 +768,7 @@ function ContentToRTF(Tree: TCustomVirtualStringTree; Source: TVSTTextSourceType if not RenderColumns then Break; - Inc(I); + System.Inc(I); end; Buffer.Add('\row'); Buffer.AddNewLine; diff --git a/components/virtualtreeview/Source/VirtualTrees.FMX.pas b/components/virtualtreeview/Source/VirtualTrees.FMX.pas new file mode 100644 index 000000000..fa2ad407a --- /dev/null +++ b/components/virtualtreeview/Source/VirtualTrees.FMX.pas @@ -0,0 +1,1781 @@ +unit VirtualTrees.FMX; + +{$SCOPEDENUMS ON} + +{***********************************************************} +{ Project : VirtualTrees } +{ } +{ author : Karol Bieniaszewski } +{ year : 2018 } +{ contibutors : } +{***********************************************************} + +interface +uses + System.Classes + , System.UITypes + , System.Types + , System.ImageList + , System.Math.Vectors + , FMX.ImgList + , FMX.Graphics + , FMX.Controls + , FMX.Types + , FMX.StdCtrls; + +//-------- type aliasing ------------------------------------------------------------------------------------------------------------------- + +type + TRect = System.Types.TRectF; + PRect = System.Types.PRectF; + TPoint = System.Types.TPointF; + PPoint = System.Types.PPointF; + PSize = System.Types.PSizeF; + TSize = System.Types.TSizeF; + TColor = System.UITypes.TAlphaColor; + PAnsiChar = System.MarshaledAString; + UINT = LongWord; + PUINT = ^UINT; + TCustomControl = TControl; //Alias for VCL compatibility as on FMX there is not TCustomControl + +//------- color aliasing ------------------------------------------------------------------------------------------------------------------- + +const + clBtnFace = TAlphaColor($FFF0F0F0); //TAlphaColorRec.Gray; + clBtnText = TAlphaColorRec.Black; + clBtnHighlight = TAlphaColorRec.DkGray; + clBtnShadow = TAlphaColorRec.Darkgray; + clHighlight = TAlphaColorRec.Lightblue; + clWindow = TAlphaColorRec.White; + clWindowText = TAlphaColorRec.Black; + clHighlightText = TAlphaColorRec.White; + clWhite = TAlphaColorRec.White; + clSilver = TAlphaColorRec.Silver; + clGray = TAlphaColorRec.Gray; + clBlack = TAlphaColorRec.Black; + clGreen = TAlphaColorRec.Green; + clBlue = TAlphaColorRec.Blue; + clGrayText = TAlphaColorRec.DkGray; + clInactiveCaption = TAlphaColorRec.Darkblue; //TODO: color + clInactiveCaptionText = TAlphaColorRec.Yellow; //TODO: color + clDkGray = TAlphaColorRec.DkGray; + + +//------- needed for migration ------------------------------------------------------------------------------------------------------------- + +const + { 3D border styles } + BDR_RAISEDOUTER = 1; + BDR_SUNKENOUTER = 2; + BDR_RAISEDINNER = 4; + BDR_SUNKENINNER = 8; + + BDR_OUTER = 3; + BDR_INNER = 12; + BDR_RAISED = 5; + BDR_SUNKEN = 10; + + EDGE_RAISED = (BDR_RAISEDOUTER or BDR_RAISEDINNER); + EDGE_SUNKEN = (BDR_SUNKENOUTER or BDR_SUNKENINNER); + EDGE_ETCHED = (BDR_SUNKENOUTER or BDR_RAISEDINNER); + EDGE_BUMP = (BDR_RAISEDOUTER or BDR_SUNKENINNER); + + ETO_OPAQUE = 2; + ETO_CLIPPED = 4; + ETO_RTLREADING = $80; + + RTLFlag: array[Boolean] of Integer = (0, ETO_RTLREADING); + + { Border flags } + BF_LEFT = 1; + BF_TOP = 2; + BF_RIGHT = 4; + BF_BOTTOM = 8; + + BF_TOPLEFT = (BF_TOP or BF_LEFT); + BF_TOPRIGHT = (BF_TOP or BF_RIGHT); + BF_BOTTOMLEFT = (BF_BOTTOM or BF_LEFT); + BF_BOTTOMRIGHT = (BF_BOTTOM or BF_RIGHT); + BF_RECT = (BF_LEFT or BF_TOP or BF_RIGHT or BF_BOTTOM); + + BF_MIDDLE = $800; { Fill in the middle } + BF_SOFT = $1000; { For softer buttons } + BF_ADJUST = $2000; { Calculate the space left over } + BF_FLAT = $4000; { For flat rather than 3D borders } + BF_MONO = $8000; { For monochrome borders } + + { DrawText() Format Flags } + DT_TOP = 0; + DT_LEFT = 0; + DT_CENTER = 1; + DT_RIGHT = 2; + DT_VCENTER = 4; + DT_BOTTOM = 8; + DT_WORDBREAK = $10; + DT_SINGLELINE = $20; + DT_EXPANDTABS = $40; + DT_TABSTOP = $80; + DT_NOCLIP = $100; + DT_EXTERNALLEADING = $200; + DT_CALCRECT = $400; + DT_NOPREFIX = $800; + DT_INTERNAL = $1000; + + + DT_EDITCONTROL = $2000; + DT_PATH_ELLIPSIS = $4000; + DT_END_ELLIPSIS = $8000; + DT_MODIFYSTRING = $10000; + DT_RTLREADING = $20000; + DT_WORD_ELLIPSIS = $40000; + DT_NOFULLWIDTHCHARBREAK = $0080000; + DT_HIDEPREFIX = $00100000; + DT_PREFIXONLY = $00200000; + + MAXDWORD = DWORD($FFFFFFFF); + WHEEL_DELTA = 120; { Value for rolling one detent } + WHEEL_PAGESCROLL = MAXDWORD; { Scroll one page } + + { WM_SIZE message wParam values } + SIZE_RESTORED = 0; + SIZE_MINIMIZED = 1; + SIZE_MAXIMIZED = 2; + SIZE_MAXSHOW = 3; + SIZE_MAXHIDE = 4; + + { Scroll Bar Constants } + SB_HORZ = 0; + SB_VERT = 1; + SB_CTL = 2; + SB_BOTH = 3; + + SIF_RANGE = 1; + SIF_PAGE = 2; + SIF_POS = 4; + SIF_DISABLENOSCROLL = 8; + SIF_TRACKPOS = $10; + SIF_ALL = (SIF_RANGE or SIF_PAGE or SIF_POS or SIF_TRACKPOS); + + { Scroll Bar Commands } + SB_LINEUP = 0; + SB_LINELEFT = 0; + SB_LINEDOWN = 1; + SB_LINERIGHT = 1; + SB_PAGEUP = 2; + SB_PAGELEFT = 2; + SB_PAGEDOWN = 3; + SB_PAGERIGHT = 3; + SB_THUMBPOSITION = 4; + SB_THUMBTRACK = 5; + SB_TOP = 6; + SB_LEFT = 6; + SB_BOTTOM = 7; + SB_RIGHT = 7; + SB_ENDSCROLL = 8; + + { RedrawWindow() flags } + RDW_INVALIDATE = 1; + RDW_INTERNALPAINT = 2; + RDW_ERASE = 4; + RDW_VALIDATE = 8; + RDW_NOINTERNALPAINT = $10; + RDW_NOERASE = $20; + RDW_NOCHILDREN = $40; + RDW_ALLCHILDREN = $80; + RDW_UPDATENOW = $100; + RDW_ERASENOW = $200; + RDW_FRAME = $400; + RDW_NOFRAME = $800; + + { GetSystemMetrics() codes } + SM_CXVSCROLL = 2; + SM_CYHSCROLL = 3; +var + // Clipboard format IDs used in OLE drag'n drop and clipboard transfers. + CF_VIRTUALTREE, + CF_VTREFERENCE, // A reference to a virtual tree + CF_VTHEADERREFERENCE, // drapg and drop of column headers + CF_VRTF, + CF_VRTFNOOBJS, // Unfortunately CF_RTF* is already defined as being + // registration strings so I have to use different identifiers. + CF_HTML, + CF_CSV: Word; + +type + tagSCROLLINFO = record + cbSize: UINT; + fMask: UINT; + nMin: Single; + nMax: Single; + nPage: Single; + nPos: Single; + nTrackPos: Single; + end; + PScrollInfo = ^TScrollInfo; + TScrollInfo = tagSCROLLINFO; + SCROLLINFO = tagSCROLLINFO; + + TBorderWidth = Single; + TBevelCut = (bvNone, bvLowered, bvRaised, bvSpace); + TBevelEdge = (beLeft, beTop, beRight, beBottom); + TBevelEdges = set of TBevelEdge; + TBevelKind = (bkNone, bkTile, bkSoft, bkFlat); + TBevelWidth = 1..MaxInt; + + TFormBorderStyle = (bsNone, bsSingle, bsSizeable, bsDialog, bsToolWindow, bsSizeToolWin); + TBorderStyle = TFormBorderStyle.bsNone..TFormBorderStyle.bsSingle; + + + + TChangeLink = class(TImageLink) + private + function GetSender: TCustomImageList; inline; + procedure SetSender(const Value: TCustomImageList); inline; + public + constructor Create; override; + property Sender: TCustomImageList read GetSender write SetSender; + end; + + INT_PTR = Integer; //do not change on Int64 //System.IntPtr; // NativeInt; + {$EXTERNALSYM INT_PTR} + UINT_PTR = Cardinal; //do not change on Int64 //System.UIntPtr; // NativeUInt; + + WPARAM = UINT_PTR; + LPARAM = INT_PTR; + LRESULT = INT_PTR; + + TDWordFiller = record + {$IFDEF CPUX64} + Filler: array[1..4] of Byte; // Pad DWORD to make it 8 bytes (4+4) [x64 only] + {$ENDIF} + end; + +//--------- Windows messages simulations --------------------------------------------------------------------------------------------------- + +const + WM_APP = $8000; + WM_MOUSEFIRST = $0200; + WM_MOUSEMOVE = $0200; + WM_LBUTTONDOWN = $0201; + WM_LBUTTONUP = $0202; + WM_LBUTTONDBLCLK = $0203; + WM_RBUTTONDOWN = $0204; + WM_RBUTTONUP = $0205; + WM_RBUTTONDBLCLK = $0206; + WM_MBUTTONDOWN = $0207; + WM_MBUTTONUP = $0208; + WM_MBUTTONDBLCLK = $0209; + WM_MOUSEWHEEL = $020A; + WM_SIZE = $0005; + WM_NCMBUTTONDOWN = $00A7; + WM_NCMBUTTONUP = $00A8; + WM_NCMBUTTONDBLCLK = $00A9; + WM_NCLBUTTONDBLCLK = $00A3; + WM_NCRBUTTONDOWN = $00A4; + WM_NCRBUTTONUP = $00A5; + WM_NCRBUTTONDBLCLK = $00A6; + WM_NCLBUTTONDOWN = $00A1; + WM_NCLBUTTONUP = $00A2; + WM_NCMOUSEMOVE = $00A0; + WM_KEYDOWN = $0100; + WM_KEYUP = $0101; + WM_SETFOCUS = $0007; + WM_KILLFOCUS = $0008; + WM_SETCURSOR = $0020; + WM_HSCROLL = $0114; + WM_VSCROLL = $0115; + WM_CHANGESTATE = WM_APP + 32; + + CM_BASE = $B000; +{$IF DEFINED(CLR)} + CM_CLROFFSET = $100; +{$ELSE} + CM_CLROFFSET = $0; // Only applicable in CLR +{$ENDIF} + CM_ACTIVATE = CM_BASE + 0; + CM_DEACTIVATE = CM_BASE + 1; + CM_GOTFOCUS = CM_BASE + 2; + CM_LOSTFOCUS = CM_BASE + 3; + CM_CANCELMODE = CM_BASE + CM_CLROFFSET + 4; + CM_DIALOGKEY = CM_BASE + 5; + CM_DIALOGCHAR = CM_BASE + 6; +{$IF NOT DEFINED(CLR)} + CM_FOCUSCHANGED = CM_BASE + 7; +{$ENDIF} + CM_PARENTFONTCHANGED = CM_BASE + CM_CLROFFSET + 8; + CM_PARENTCOLORCHANGED = CM_BASE + 9; + CM_BIDIMODECHANGED = CM_BASE + 60; + CM_PARENTBIDIMODECHANGED = CM_BASE + 61; + CM_MOUSEWHEEL = CM_BASE + 67; + + VK_ESCAPE = 27; + +type + PMessage = ^TMessage; + TMessage = record + Msg: Cardinal; //4 + tmp: Integer; //4 + case Integer of + 0: ( + WParam: WPARAM; //4 + LParam: LPARAM; //4 + Result: LRESULT //4 + ); //= 12 + 4 = 16 + 1: ( + WParamLo: Word; //2 + WParamHi: Word; //2 + //WParamFiller: TDWordFiller; + LParamLo: Word; //2 + LParamHi: Word; //2 + //LParamFiller: TDWordFiller; + ResultLo: Word; //2 + ResultHi: Word; //2 + //=12 + 8 = 20 + ); + end; + + TWMMouse = record + Msg: Cardinal; //4 + Keys: Longint; //TShiftState; //4 + //KeysFiller: TDWordFiller; + case Integer of + 0: ( + XPos: Single; //4 + YPos: Single; //4 + Result: LRESULT; //4 + ); + 1: ( + Pos: TPoint; //8 + ResultLo: Word; //2 + ResultHi: Word; //2 + ); //=12 + 8=20 + end; + + TWMMouseMove = TWMMouse; + + TWMNCHitTest = record + Msg: Cardinal; + //MsgFiller: TDWordFiller; + Unused: WPARAM; + case Integer of + 0: ( + XPos: Single; + YPos: Single; + //XYPosFiller: TDWordFiller + ); + 1: ( + Pos: TPoint; + //PosFiller: TDWordFiller; + Result: LRESULT); + end; + + TWMNCHitMessage = record + Msg: Cardinal; //4 + //MsgFiller: TDWordFiller; + HitTest: Longint; //4 + //HitTestFiller: TDWordFiller; + XCursor: Single; //4 + YCursor: Single; //4 + //XYCursorFiller: TDWordFiller; + Result: LRESULT; //4 + end; //=20 + + TWMNCLButtonDblClk = TWMNCHitMessage; + TWMNCLButtonDown = TWMNCHitMessage; + TWMNCLButtonUp = TWMNCHitMessage; + TWMNCMButtonDblClk = TWMNCHitMessage; + TWMNCMButtonDown = TWMNCHitMessage; + TWMNCMButtonUp = TWMNCHitMessage; + TWMNCMouseMove = TWMNCHitMessage; + TWMNCRButtonDblClk = TWMNCHitMessage; + TWMNCRButtonDown = TWMNCHitMessage; + TWMNCRButtonUp = TWMNCHitMessage; + + TWMLButtonDblClk = TWMMouse; + TWMLButtonDown = TWMMouse; + TWMLButtonUp = TWMMouse; + TWMMButtonDblClk = TWMMouse; + TWMMButtonDown = TWMMouse; + TWMMButtonUp = TWMMouse; + + + TWMKey = record + Msg: Cardinal; //4 + tmp: Integer; //4 + CharCode: Word; //4 + //Unused: Word; //2 + KeyData: Longint; //4 + Result: LRESULT; //4 + end; //=20 + + TWMKeyDown = TWMKey; + TWMKeyUp = TWMKey; + + TWMSize = record + Msg: Cardinal; //4 + //MsgFiller: TDWordFiller; + SizeType: WPARAM; { SIZE_MAXIMIZED, SIZE_MINIMIZED, SIZE_RESTORED, //4 + SIZE_MAXHIDE, SIZE_MAXSHOW } + Width: Single; //4 + Height: Single; //4 + //WidthHeightFiller: TDWordFiller; + Result: LRESULT; //4 + end; //=20 + + TWMScroll = record + Msg: Cardinal; //4 + //MsgFiller: TDWordFiller; + ScrollCode: {Smallint}Integer; { SB_xxxx } //4 + Pos: Single; //4 + //ScrollCodePosFiller: TDWordFiller; + ScrollBar: Integer; //4 nBar + Result: LRESULT; //4 + end; //=20 + + TWMHScroll = TWMScroll; + TWMVScroll = TWMScroll; + + TCMMouseWheel = record + Msg: Cardinal; //4 + //MsgFiller: TDWordFiller; + ShiftState: TShiftState; //2 + WheelDelta: SmallInt; //2 + //ShiftStateWheel: TDWordFiller; + case Integer of + 0: ( + XPos: Single; //4 + YPos: Single; //4 + //XYPos: TDWordFiller + ); //=24! + 1: ( + Pos: TPoint; //8 + //PosFiller: TDWordFiller; + Result: LRESULT //4 + ); //=28! + end; + + +procedure FillTWMMouse(Var MM: TWMMouse; Button: TMouseButton; Shift: TShiftState; X: Single; Y: Single; IsNC: Boolean; IsUp: Boolean); + +//--------- Text metrics ------------------------------------------------------------------------------------------------------------------- +type + TTextMetric = record + tmHeight: Single; //The height (ascent + descent) of characters. + tmAscent: Single; //The ascent (units above the base line) of characters. + tmDescent: Single; //The descent (units below the base line) of characters. + tmInternalLeading: Single; //The amount of leading (space) inside the bounds set by the tmHeight member. Accent marks and other diacritical characters may occur in this area. The designer may set this member to zero + tmExternalLeading: Single; //The amount of extra leading (space) that the application adds between rows. Since this area is outside the font, it contains no marks and is not altered by text output calls in either OPAQUE or TRANSPARENT mode. The designer may set this member to zero. + tmAveCharWidth: Single; //The average width of characters in the font (generally defined as the width of the letter x ). This value does not include the overhang required for bold or italic characters. + tmMaxCharWidth: Single; //The width of the widest character in the font. + tmWeight: Single; //The weight of the font. + tmOverhang: Single; + tmDigitizedAspectX: Single; //The horizontal aspect of the device for which the font was designed. + tmDigitizedAspectY: Single; //The vertical aspect of the device for which the font was designed. The ratio of the tmDigitizedAspectX and tmDigitizedAspectY members is the aspect ratio of the device for which the font was designed. + tmFirstChar: WideChar; //The value of the first character defined in the font. + tmLastChar: WideChar; //The value of the last character defined in the font. + tmDefaultChar: WideChar; //The value of the character to be substituted for characters not in the font. + tmBreakChar: WideChar; //The value of the character that will be used to define word breaks for text justification. + tmItalic: Byte; //Specifies an italic font if it is nonzero. + tmUnderlined: Byte; //Specifies an underlined font if it is nonzero. + tmStruckOut: Byte; //A strikeout font if it is nonzero. + tmPitchAndFamily: Byte; //Specifies information about the pitch, the technology, and the family of a physical font. TMPF_FIXED_PITCH, TMPF_VECTOR, TMPF_TRUETYPE, TMPF_DEVICE + tmCharSet: Byte; //The character set of the font. The character set can be one of the following values. ANSI_CHARSET, GREEK_CHARSET.... + end; + procedure GetTextMetrics(ACanvas: TCanvas; var TM: TTextMetric); + +//-------- function aliassing -------------------------------------------------------------------------------------------------------------- + +function Rect(ALeft, ATop, ARight, ABottom: Single): TRect; overload; inline; +function Rect(const ATopLeft, ABottomRight: TPoint): TRect; overload; inline; +function Point(AX, AY: Single): TPoint; overload; inline; + +procedure Inc(Var V: Single; OIle: Single=1.0); overload; +procedure Dec(Var V: Single; OIle: Single=1.0); overload; +function MulDiv(const A, B, C: Single): Single; overload; +procedure FillMemory(Destination: Pointer; Length: NativeUInt; Fill: Byte); +procedure ZeroMemory(Destination: Pointer; Length: NativeUInt); +procedure MoveMemory(Destination: Pointer; Source: Pointer; Length: NativeUInt); +procedure CopyMemory(Destination: Pointer; Source: Pointer; Length: NativeUInt); + +procedure DrawTextW(ACanvas: TCanvas; CaptionText: String; Len: Integer; Var Bounds: TRect; DrawFormat: Cardinal{this is windows format - must be converted to FMX}); +procedure GetTextExtentPoint32W(ACanvas: TCanvas; CaptionText: String; Len: Integer; Var Size: TSize); +procedure DrawEdge(Canvas: TCanvas; R: TRect; edge, grfFlags: Cardinal); + +type + THighQualityBitmap = class(TBitmap) + public + constructor Create; override; + end; + +//fill system images +procedure FillSystemCheckImages(Parent: TFmxObject; List: TImageList); + +type + TCanvasHelper = class helper for TCanvas + private + function GetBrush: TBrush; inline; + function GetPen: TStrokeBrush; inline; + public + property Brush: TBrush read GetBrush; + property Pen: TStrokeBrush read GetPen; + procedure FillRect(const ARect: TRectF); overload; inline; + procedure DrawRect(const ARect: TRectF); overload; inline; + procedure DrawFocusRect(const AFocusRect: TRect); + procedure FrameRect(const AFocusRect: TRect); + procedure RoundRect(X1, Y1, X2, Y2: Single; const XRadius, YRadius: Single); overload; + procedure RoundRect(const Rect: TRect; const XRadius, YRadius: Single); overload; + procedure Polygon(const Points: TPolygon); + procedure Draw(const X, Y: Single; const Bitmap: TBitmap); + end; + + TFontHelper = class helper for TFont + private + function GetOnChange: TNotifyEvent; + procedure SetOnChange(const Value: TNotifyEvent); + public + property OnChange: TNotifyEvent read GetOnChange write SetOnChange; + end; + +{ Draws a solid triangular arrow that can point in any TScrollDirection } + +type + TScrollDirection = (sdLeft, sdRight, sdUp, sdDown); + TArrowType = (atSolid, atArrows); + +procedure DrawArrow(ACanvas: TCanvas; Direction: TScrollDirection; Location: TPoint; Size: Single); + +procedure ChangeBiDiModeAlignment(var Alignment: TAlignment); + +procedure OleUninitialize(); + +function timeGetTime: Int64; + +implementation +uses + System.SysUtils + , FMX.TextLayout + , FMX.MultiResBitmap + , FMX.Objects + , FMX.Effects + , VirtualTrees.Utils + ; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure DrawArrow(ACanvas: TCanvas; Direction: TScrollDirection; Location: TPoint; Size: Single); +begin + //TODO: DrawArrow implementation +end; + +//---------------------------------------------------------------------------------------------------------------------- + +{ TCanvasHelper } + +procedure TCanvasHelper.Draw(const X, Y: Single; const Bitmap: TBitmap); +begin + DrawBitmap(Bitmap + , Rect(0, 0, Bitmap.Width, Bitmap.Height) + , Rect(X, Y, X+Bitmap.Width, Y+ Bitmap.Height) + , 1.0 + ); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TCanvasHelper.DrawFocusRect(const AFocusRect: TRect); +begin + DrawDashRect(AFocusRect, 0, 0, AllCorners, 1.0{?}, $A0909090); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TCanvasHelper.DrawRect(const ARect: TRectF); +begin + DrawRect(ARect, 0, 0, [], 1.0); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TCanvasHelper.FillRect(const ARect: TRectF); +begin + FillRect(ARect, 0, 0, [], 1.0); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TCanvasHelper.FrameRect(const AFocusRect: TRect); +begin + DrawRect(AFocusRect); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TCanvasHelper.GetBrush: TBrush; +begin + Result:= Fill; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TCanvasHelper.GetPen: TStrokeBrush; +begin + Result:= Stroke; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TCanvasHelper.Polygon(const Points: TPolygon); +begin + DrawPolygon(Points, 1.0); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TCanvasHelper.RoundRect(const Rect: TRect; const XRadius, YRadius: Single); +begin + DrawRect(Rect, XRadius, YRadius, allCorners, 1.0); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TCanvasHelper.RoundRect(X1, Y1, X2, Y2: Single; const XRadius, YRadius: Single); +begin + RoundRect(Rect(X1, Y1, X2, Y2), XRadius, YRadius); +end; + + +//---------------------------------------------------------------------------------------------------------------------- + +type + TImageListHelper = class helper for TImageList + function Add(aBitmap: TBitmap): integer; + end; + +function TImageListHelper.Add(aBitmap: TBitmap): integer; +const + SCALE = 1; +var + vSource: TCustomSourceItem; + vBitmapItem: TCustomBitmapItem; + vDest: TCustomDestinationItem; + vLayer: TLayer; +begin + Result := -1; + if (aBitmap.Width = 0) or (aBitmap.Height = 0) then exit; + + // add source bitmap + vSource := Source.Add; + vSource.MultiResBitmap.TransparentColor := TColorRec.Fuchsia; + vSource.MultiResBitmap.SizeKind := TSizeKind.Source; + vSource.MultiResBitmap.Width := Round(aBitmap.Width / SCALE); + vSource.MultiResBitmap.Height := Round(aBitmap.Height / SCALE); + vBitmapItem := vSource.MultiResBitmap.ItemByScale(SCALE, True, True); + if vBitmapItem = nil then + begin + vBitmapItem := vSource.MultiResBitmap.Add; + vBitmapItem.Scale := Scale; + end; + vBitmapItem.Bitmap.Assign(aBitmap); + + vDest := Destination.Add; + vLayer := vDest.Layers.Add; + vLayer.SourceRect.Rect := TRectF.Create(TPoint.Zero, vSource.MultiResBitmap.Width, + vSource.MultiResBitmap.Height); + vLayer.Name := vSource.Name; + Result := vDest.Index; +end; + +//---------------------------------------------------------------------------------------------------------------------- +//https://stackoverflow.com/questions/22813461/is-there-an-equivalent-to-floodfill-in-fmx-for-a-tbitmap +procedure Bitmap_FloodFill(fBitmap: TBitmap; StartX,StartY : Integer; FillColor: TAlphaColor); +var + fBitmapData : TBitmapData; + X, Y : Integer; + ReplaceColor : TAlphaColor; + Stack : Array of System.Types.TPoint; + fHeight : Integer; + fWidth : Integer; + + procedure PutInStack(X, Y: Integer); + begin + SetLength(Stack, Length(Stack)+1); + Stack[Length(Stack)-1] := Point(X, Y); + end; + + procedure GetFromStack(var X, Y: Integer); + begin + X := Stack[Length(Stack)-1].X; + Y := Stack[Length(Stack)-1].Y; + SetLength(Stack, Length(Stack)-1); + end; + +begin + X := StartX; + Y := StartY; + fHeight := fBitmap.Height; + fWidth := fBitmap.Width; + if (X >= fWidth) or (Y >= fHeight) then Exit; + + if fBitmap.Map(TMapAccess.ReadWrite,fBitmapData) then + try + ReplaceColor := fBitmapData.GetPixel(X,Y); + if ReplaceColor <> FillColor then + begin + PutInStack(X,Y); + while Length(Stack) > 0 do + begin + GetFromStack(X,Y); + while (X > 0) and (fBitmapData.GetPixel(X-1, Y) = ReplaceColor) do System.Dec(X); + while (X < fWidth) and (fBitmapData.GetPixel(X , Y) = ReplaceColor) do + begin + if Y > 0 then If fBitmapData.GetPixel(X, Y-1) = ReplaceColor then PutInStack(X, Y-1); + if Y+1 < fHeight then If fBitmapData.GetPixel(X, Y+1) = ReplaceColor then PutInStack(X, Y+1); + fBitmapData.SetPixel(X,Y,FillColor); + System.Inc(X); + end; + end; + end; + finally + fBitmap.Canvas.Bitmap.Unmap(fBitmapData); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +{ + ckEmpty = 0; // an empty image used as place holder + // radio buttons + ckRadioUncheckedNormal = 1; + ckRadioUncheckedHot = 2; + ckRadioUncheckedPressed = 3; + ckRadioUncheckedDisabled = 4; + ckRadioCheckedNormal = 5; + ckRadioCheckedHot = 6; + ckRadioCheckedPressed = 7; + ckRadioCheckedDisabled = 8; + // check boxes + ckCheckUncheckedNormal = 9; + ckCheckUncheckedHot = 10; + ckCheckUncheckedPressed = 11; + ckCheckUncheckedDisabled = 12; + ckCheckCheckedNormal = 13; + ckCheckCheckedHot = 14; + ckCheckCheckedPressed = 15; + ckCheckCheckedDisabled = 16; + ckCheckMixedNormal = 17; + ckCheckMixedHot = 18; + ckCheckMixedPressed = 19; + ckCheckMixedDisabled = 20; + // simple button + ckButtonNormal = 21; //??? + ckButtonHot = 22; //??? + ckButtonPressed = 23; //??? + ckButtonDisabled = 24; //??? +} +procedure FillSystemCheckImages(Parent: TFmxObject; List: TImageList); +Var cb: TCheckBox; + rb: TRadioButton; + BMP: TBitmap; + eff: TInnerGlowEffect; + procedure AddCtrlBmp(c: TControl); + Var tmpBMP: TBitmap; + begin + tmpBMP:= c.MakeScreenshot; + try + BMP.SetSize(tmpBMP.Height, tmpBMP.Height); + BMP.Clear(TAlphaColorRec.Null); //this somehow can sometimes clear BeginSceneCount and must be before BeginScene + if BMP.Canvas.BeginScene() then + begin + try + BMP.Canvas.DrawBitmap( + tmpBMP + , Rect(2, 2, BMP.Width, BMP.Height) + , Rect(0, 0, BMP.Width-2, BMP.Height-2) + , 1.0 + , false + ); + finally + BMP.Canvas.EndScene; + end; + end; + finally + FreeAndNil(tmpBMP); + end; + end; +begin + BMP:= TBitmap.Create; + try + BMP.SetSize(16, 16); + BMP.Clear(TAlphaColorRec.Null); + List.Add(BMP); //ckEmpty + + + rb:= TRadioButton.Create(Parent); + try + rb.Parent:= Parent; + rb.Text:= ' '; + + eff:= TInnerGlowEffect.Create(rb); //auto free + eff.Parent:= rb; + eff.GlowColor:= TAlphaColorRec.Teal; + eff.Softness:= 8; + eff.Opacity:= 0.7; + eff.Enabled:= false; + + //------------------IsUnChecked-------------------------- + + rb.IsChecked:= false; + eff.Enabled:= false; + AddCtrlBmp(rb); + List.Add(BMP); //ckRadioUncheckedNormal + eff.Enabled:= false; + + + AddCtrlBmp(rb); + eff.Enabled:= true; + eff.GlowColor:= TAlphaColorRec.Lightyellow; + List.Add(BMP); //ckRadioUncheckedHot + eff.Enabled:= false; + + + eff.Enabled:= true; + eff.GlowColor:= TAlphaColorRec.Lightblue; + AddCtrlBmp(rb); + List.Add(BMP); //ckRadioUncheckedPressed + eff.Enabled:= false; + + + rb.Enabled:= false; + eff.Enabled:= true; + eff.GlowColor:= TAlphaColorRec.Gray; + AddCtrlBmp(rb); + List.Add(BMP); //ckRadioUncheckedDisabled + eff.Enabled:= false; + + //------------------IsChecked--------------------------- + + rb.IsChecked:= true; + + //rb.IsPressed:= false; + rb.Enabled:= true; + eff.Enabled:= false; + AddCtrlBmp(rb); + List.Add(BMP); //ckRadioCheckedNormal + eff.Enabled:= false; + + + eff.Enabled:= true; + eff.GlowColor:= TAlphaColorRec.Lightyellow; + AddCtrlBmp(rb); + List.Add(BMP); //ckRadioCheckedHot + eff.Enabled:= false; + + + rb.Enabled:= true; + eff.Enabled:= true; + eff.GlowColor:= TAlphaColorRec.Lightblue; + AddCtrlBmp(rb); + List.Add(BMP); //ckRadioCheckedPressed + eff.Enabled:= false; + + + rb.Enabled:= false; + eff.Enabled:= true; + eff.GlowColor:= TAlphaColorRec.Gray; + AddCtrlBmp(rb); + List.Add(BMP); //ckRadioCheckedDisabled + eff.Enabled:= false; + finally + FreeAndNil(rb); + end; + + cb:= TCheckBox.Create(Parent); + try + cb.Parent:= Parent; + cb.Text:= ' '; + + eff:= TInnerGlowEffect.Create(cb); //auto free + eff.Parent:= cb; + eff.GlowColor:= TAlphaColorRec.Teal; + eff.Softness:= 8; + eff.Opacity:= 0.7; + eff.Enabled:= false; + + //------------------IsUnChecked-------------------------- + + cb.IsChecked:= false; + eff.Enabled:= false; + AddCtrlBmp(cb); + List.Add(BMP); //ckCheckUncheckedNormal + eff.Enabled:= false; + + eff.Enabled:= true; + eff.GlowColor:= TAlphaColorRec.Lightyellow; + AddCtrlBmp(cb); + List.Add(BMP); //ckCheckUncheckedHot + eff.Enabled:= false; + + + //cb.IsPressed:= true; + eff.Enabled:= true; + eff.GlowColor:= TAlphaColorRec.Lightblue; + AddCtrlBmp(cb); + List.Add(BMP); //ckCheckUncheckedPressed + eff.Enabled:= false; + + + //cb.IsPressed:= false; + cb.Enabled:= false; + eff.Enabled:= true; + eff.GlowColor:= TAlphaColorRec.Gray; + AddCtrlBmp(cb); + eff.Enabled:= false; + List.Add(BMP); //ckCheckUncheckedDisabled + + //------------------IsChecked--------------------------- + + cb.IsChecked:= true; + + cb.Enabled:= true; + eff.Enabled:= false; + AddCtrlBmp(cb); + List.Add(BMP); //ckCheckCheckedNormal + eff.Enabled:= false; + + + eff.Enabled:= true; + eff.GlowColor:= TAlphaColorRec.Lightyellow; + eff.Opacity:= 0.3; + AddCtrlBmp(cb); + List.Add(BMP); //ckCheckCheckedHot + eff.Opacity:= 0.7; + eff.Enabled:= false; + eff.Enabled:= false; + + + cb.Enabled:= true; + eff.Enabled:= true; + eff.GlowColor:= TAlphaColorRec.Lightblue; + AddCtrlBmp(cb); + List.Add(BMP); //ckCheckCheckedPressed + eff.Enabled:= false; + + + cb.Enabled:= false; + eff.Enabled:= true; + eff.GlowColor:= TAlphaColorRec.Gray; + AddCtrlBmp(cb); + List.Add(BMP); //ckCheckCheckedDisabled + eff.Enabled:= false; + //------------------Mixed--------------------------- + + //how to support mixed style? + //maybe draw unchecked and fill in the center of bitmap??? + //i use ~teal for fill + //changed to InnerGlowEffect + + cb.IsChecked:= true; + eff.Enabled:= true; + eff.GlowColor:= TAlphaColorRec.Green; + AddCtrlBmp(cb); + List.Add(BMP); //ckCheckMixedNormal + eff.Enabled:= false; + + + eff.Enabled:= true; + eff.GlowColor:= TAlphaColorRec.Lightyellow; + AddCtrlBmp(cb); + List.Add(BMP); //ckCheckMixedHot + eff.Enabled:= false; + + + eff.Enabled:= true; + eff.GlowColor:= TAlphaColorRec.Lightblue; + AddCtrlBmp(cb); + List.Add(BMP); //ckCheckMixedPressed + eff.Enabled:= false; + + + cb.Enabled:= false; + eff.Enabled:= true; + eff.GlowColor:= TAlphaColorRec.Gray; + AddCtrlBmp(cb); + List.Add(BMP); //ckCheckMixedDisabled + eff.Enabled:= false; + + finally + FreeAndNil(cb); + end; + eff.Enabled:= false; + eff.Parent:= nil; + + finally + FreeAndNil(BMP); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure FillTWMMouse(Var MM: TWMMouse; Button: TMouseButton; Shift: TShiftState; X: Single; Y: Single; IsNC: Boolean; IsUp: Boolean); +begin + MM.Msg:= 0; + if ssDouble in Shift then + begin + if ssLeft in Shift then + begin + if IsNC then + MM.Msg:= WM_NCLBUTTONDBLCLK else + MM.Msg:= WM_LBUTTONDBLCLK; + end else + if ssRight in Shift then + begin + if IsNC then + MM.Msg:= WM_NCRBUTTONDBLCLK else + MM.Msg:= WM_RBUTTONDBLCLK; + end else + if ssMiddle in Shift then + begin + if IsNC then + MM.Msg:= WM_NCMBUTTONDBLCLK else + MM.Msg:= WM_MBUTTONDBLCLK; + end; + end else + begin + if (ssLeft in Shift) or (Button=TMouseButton.mbLeft) then + begin + if IsUp then + begin + if IsNC then + MM.Msg:= WM_NCLBUTTONUP else + MM.Msg:= WM_LBUTTONUP; + end else + begin + if IsNC then + MM.Msg:= WM_NCLBUTTONDOWN else + MM.Msg:= WM_LBUTTONDOWN; + end; + end else + if (ssRight in Shift) or (Button=TMouseButton.mbRight) then + begin + if IsUp then + begin + if IsNC then + MM.Msg:= WM_NCRBUTTONUP else + MM.Msg:= WM_RBUTTONUP; + end else + begin + if IsNC then + MM.Msg:= WM_NCRBUTTONDOWN else + MM.Msg:= WM_RBUTTONDOWN; + end; + + end else + if (ssMiddle in Shift) or (Button=TMouseButton.mbMiddle) then + begin + if IsUp then + begin + if IsNC then + MM.Msg:= WM_NCMBUTTONUP else + MM.Msg:= WM_MBUTTONUP; + end else + begin + if IsNC then + MM.Msg:= WM_NCMBUTTONDOWN else + MM.Msg:= WM_MBUTTONDOWN; + end; + end; + end; + + MM.XPos:= X; + MM.YPos:= Y; + MM.Keys:= LongInt(Word(Shift)); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure DrawTextW(ACanvas: TCanvas; CaptionText: String; Len: Integer; Var Bounds: TRect; DrawFormat: Cardinal{this is windows format - must be converted to FMX}); +Var + hAlign: TTextAlign; + vAlign: TTextAlign; + Flags: TFillTextFlags; +begin + //TTextLayout. render + //TODO: DrawFormat: Cardinal{this is windows format - must be converted to FMX} + + hAlign:= TTextAlign.Leading; + if DrawFormat and DT_CENTER<>0 then + hAlign:= TTextAlign.Center; + if DrawFormat and DT_RIGHT<>0 then + hAlign:= TTextAlign.Trailing; + + + vAlign:= TTextAlign.Center; + if DrawFormat and DT_VCENTER<>0 then + vAlign:= TTextAlign.Center; + if DrawFormat and DT_BOTTOM<>0 then + vAlign:= TTextAlign.Trailing; + + Flags:= []; + + if DrawFormat and DT_RTLREADING<>0 then + Flags:= Flags + [TFillTextFlag.RightToLeft]; + + ACanvas.FillText(Bounds, CaptionText, false, 1.0, Flags, hAlign, vAlign); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure DrawEdge(Canvas: TCanvas; R: TRect; edge, grfFlags: Cardinal); +Var tmpR: TRect; + IsSoft, IsFlat, IsMono: Boolean; +begin + + if grfFlags and BF_SOFT<>0 then + IsSoft:= true else + IsSoft:= false; + + if grfFlags and BF_FLAT<>0 then + IsFlat:= true else + IsFlat:= false; + + if grfFlags and BF_MONO<>0 then + IsMono:= true else + IsMono:= false; + + if grfFlags and BF_MIDDLE<>0 then + begin + Canvas.Fill.Color:= clBtnFace; + Canvas.FillRect(R, 0, 0, [], 1.0); + end; + tmpR:= R; + if grfFlags and BF_LEFT<>0 then + begin + tmpR:= R; + + if edge and BDR_RAISEDOUTER<>0 then + begin + if isSoft then + begin + Canvas.Stroke.Color:= TColors.White; + Canvas.DrawLine(Point(tmpR.Left, tmpR.Top), Point(tmpR.Left, tmpR.Bottom), 1.0); + end else + if IsFlat then + begin + Canvas.Stroke.Color:= $FFA0A0A0; + Canvas.DrawLine(Point(tmpR.Left, tmpR.Top), Point(tmpR.Left, tmpR.Bottom), 1.0); + end else + if isMono then + begin + Canvas.Stroke.Color:= $FF646464; + Canvas.DrawLine(Point(tmpR.Left, tmpR.Top), Point(tmpR.Left, tmpR.Bottom), 1.0); + end else + begin + Canvas.Stroke.Color:= $FFE3E3E3; + Canvas.DrawLine(Point(tmpR.Left, tmpR.Top), Point(tmpR.Left, tmpR.Bottom), 1.0); + end; + InflateRect(tmpR, -1, -1) + end; + + if edge and BDR_SUNKENOUTER<>0 then + begin + if isSoft then + begin + Canvas.Stroke.Color:= $FF696969; + Canvas.DrawLine(Point(tmpR.Left, tmpR.Top), Point(tmpR.Left, tmpR.Bottom), 1.0); + end else + if IsFlat then + begin + Canvas.Stroke.Color:= $FFA0A0A0; + Canvas.DrawLine(Point(tmpR.Left, tmpR.Top), Point(tmpR.Left, tmpR.Bottom), 1.0); + end else + if isMono then + begin + Canvas.Stroke.Color:= $FF646464; + Canvas.DrawLine(Point(tmpR.Left, tmpR.Top), Point(tmpR.Left, tmpR.Bottom), 1.0); + end else + begin + Canvas.Stroke.Color:= $FFA0A0A0; + Canvas.DrawLine(Point(tmpR.Left, tmpR.Top), Point(tmpR.Left, tmpR.Bottom), 1.0); + end; + InflateRect(tmpR, -1, -1) + end; + + if edge and BDR_RAISEDINNER<>0 then + begin + if isSoft then + begin + Canvas.Stroke.Color:= $FFE3E3E3; + Canvas.DrawLine(Point(tmpR.Left, tmpR.Top), Point(tmpR.Left, tmpR.Bottom), 1.0); + end else + if IsFlat then + begin + Canvas.Stroke.Color:= $FFF0F0F0; + Canvas.DrawLine(Point(tmpR.Left, tmpR.Top), Point(tmpR.Left, tmpR.Bottom), 1.0); + end else + if isMono then + begin + Canvas.Stroke.Color:= TAlphaColorRec.White; + Canvas.DrawLine(Point(tmpR.Left, tmpR.Top), Point(tmpR.Left, tmpR.Bottom), 1.0); + end else + begin + Canvas.Stroke.Color:= TAlphaColorRec.White; + Canvas.DrawLine(Point(tmpR.Left, tmpR.Top), Point(tmpR.Left, tmpR.Bottom), 1.0); + end; + end; + + if edge and BDR_SUNKENINNER<>0 then + begin + if isSoft then + begin + Canvas.Stroke.Color:= $FFA0A0A0; + Canvas.DrawLine(Point(tmpR.Left, tmpR.Top), Point(tmpR.Left, tmpR.Bottom), 1.0); + end else + if IsFlat then + begin + Canvas.Stroke.Color:= $FFF0F0F0; + Canvas.DrawLine(Point(tmpR.Left, tmpR.Top), Point(tmpR.Left, tmpR.Bottom), 1.0); + end else + if isMono then + begin + Canvas.Stroke.Color:= TAlphaColorRec.White; + Canvas.DrawLine(Point(tmpR.Left, tmpR.Top), Point(tmpR.Left, tmpR.Bottom), 1.0); + end else + begin + Canvas.Stroke.Color:= $FF696969; + Canvas.DrawLine(Point(tmpR.Left, tmpR.Top), Point(tmpR.Left, tmpR.Bottom), 1.0); + end; + end; + end; + + if grfFlags and BF_TOP<>0 then + begin + tmpR:= R; + + if edge and BDR_RAISEDOUTER<>0 then + begin + if isSoft then + begin + Canvas.Stroke.Color:= TAlphaColorRec.White; + Canvas.DrawLine(Point(tmpR.Left, tmpR.Top), Point(tmpR.Right, tmpR.Top), 1.0); + end else + if IsFlat then + begin + Canvas.Stroke.Color:= $FFA0A0A0; + Canvas.DrawLine(Point(tmpR.Left, tmpR.Top), Point(tmpR.Right, tmpR.Top), 1.0); + end else + if isMono then + begin + Canvas.Stroke.Color:= $FF646464; + Canvas.DrawLine(Point(tmpR.Left, tmpR.Top), Point(tmpR.Right, tmpR.Top), 1.0); + end else + begin + Canvas.Stroke.Color:= $FFE3E3E3; + Canvas.DrawLine(Point(tmpR.Left, tmpR.Top), Point(tmpR.Right, tmpR.Top), 1.0); + end; + InflateRect(tmpR, -1, -1) + end; + + if edge and BDR_SUNKENOUTER<>0 then + begin + if isSoft then + begin + Canvas.Stroke.Color:= $FF696969; + Canvas.DrawLine(Point(tmpR.Left, tmpR.Top), Point(tmpR.Right, tmpR.Top), 1.0); + end else + if IsFlat then + begin + Canvas.Stroke.Color:= $FFA0A0A0; + Canvas.DrawLine(Point(tmpR.Left, tmpR.Top), Point(tmpR.Right, tmpR.Top), 1.0); + end else + if isMono then + begin + Canvas.Stroke.Color:= $FF646464; + Canvas.DrawLine(Point(tmpR.Left, tmpR.Top), Point(tmpR.Right, tmpR.Top), 1.0); + end else + begin + Canvas.Stroke.Color:= $FFA0A0A0; + Canvas.DrawLine(Point(tmpR.Left, tmpR.Top), Point(tmpR.Right, tmpR.Top), 1.0); + end; + InflateRect(tmpR, -1, -1) + end; + + if edge and BDR_RAISEDINNER<>0 then + begin + if isSoft then + begin + Canvas.Stroke.Color:= $FFE3E3E3; + Canvas.DrawLine(Point(tmpR.Left, tmpR.Top), Point(tmpR.Right, tmpR.Top), 1.0); + end else + if IsFlat then + begin + Canvas.Stroke.Color:= $FFF0F0F0; + Canvas.DrawLine(Point(tmpR.Left, tmpR.Top), Point(tmpR.Right, tmpR.Top), 1.0); + end else + if isMono then + begin + Canvas.Stroke.Color:= TAlphaColorRec.White; + Canvas.DrawLine(Point(tmpR.Left, tmpR.Top), Point(tmpR.Right, tmpR.Top), 1.0); + end else + begin + Canvas.Stroke.Color:= TAlphaColorRec.White; + Canvas.DrawLine(Point(tmpR.Left, tmpR.Top), Point(tmpR.Right, tmpR.Top), 1.0); + end; + end; + + if edge and BDR_SUNKENINNER<>0 then + begin + if isSoft then + begin + Canvas.Stroke.Color:= $FFA0A0A0; + Canvas.DrawLine(Point(tmpR.Left, tmpR.Top), Point(tmpR.Right, tmpR.Top), 1.0); + end else + if IsFlat then + begin + Canvas.Stroke.Color:= $FFF0F0F0; + Canvas.DrawLine(Point(tmpR.Left, tmpR.Top), Point(tmpR.Right, tmpR.Top), 1.0); + end else + if isMono then + begin + Canvas.Stroke.Color:= TAlphaColorRec.White; + Canvas.DrawLine(Point(tmpR.Left, tmpR.Top), Point(tmpR.Right, tmpR.Top), 1.0); + end else + begin + Canvas.Stroke.Color:= $FF696969; + Canvas.DrawLine(Point(tmpR.Left, tmpR.Top), Point(tmpR.Right, tmpR.Top), 1.0); + end; + end; + + + end; + + if grfFlags and BF_RIGHT<>0 then + begin + tmpR:= R; + if edge and BDR_RAISEDOUTER<>0 then + begin + if isSoft then + begin + Canvas.Stroke.Color:= $FF696969; + Canvas.DrawLine(Point(tmpR.Right-1, tmpR.Top), Point(tmpR.Right-1, tmpR.Bottom), 1.0); + end else + if IsFlat then + begin + Canvas.Stroke.Color:= $FFA0A0A0; + Canvas.DrawLine(Point(tmpR.Right-1, tmpR.Top), Point(tmpR.Right-1, tmpR.Bottom), 1.0); + end else + if isMono then + begin + Canvas.Stroke.Color:= $FF646464; + Canvas.DrawLine(Point(tmpR.Right-1, tmpR.Top), Point(tmpR.Right-1, tmpR.Bottom), 1.0); + end else + begin + Canvas.Stroke.Color:= $FF696969; + Canvas.DrawLine(Point(tmpR.Right-1, tmpR.Top), Point(tmpR.Right-1, tmpR.Bottom), 1.0); + end; + InflateRect(tmpR, -1, -1) + end; + + if edge and BDR_SUNKENOUTER<>0 then + begin + if isSoft then + begin + Canvas.Stroke.Color:= TAlphaColorRec.White; + Canvas.DrawLine(Point(tmpR.Right-1, tmpR.Top), Point(tmpR.Right-1, tmpR.Bottom), 1.0); + end else + if IsFlat then + begin + Canvas.Stroke.Color:= $FFA0A0A0; + Canvas.DrawLine(Point(tmpR.Right-1, tmpR.Top), Point(tmpR.Right-1, tmpR.Bottom), 1.0); + end else + if isMono then + begin + Canvas.Stroke.Color:= $FF646464; + Canvas.DrawLine(Point(tmpR.Right-1, tmpR.Top), Point(tmpR.Right-1, tmpR.Bottom), 1.0); + end else + begin + Canvas.Stroke.Color:= TAlphaColorRec.White; + Canvas.DrawLine(Point(tmpR.Right-1, tmpR.Top), Point(tmpR.Right-1, tmpR.Bottom), 1.0); + end; + InflateRect(tmpR, -1, -1) + end; + + Dec(tmpR.Right); + + if edge and BDR_RAISEDINNER<>0 then + begin + if isSoft then + begin + Canvas.Stroke.Color:= $FFA0A0A0; + Canvas.DrawLine(Point(tmpR.Right, tmpR.Top), Point(tmpR.Right, tmpR.Bottom), 1.0); + end else + if IsFlat then + begin + Canvas.Stroke.Color:= $FFF0F0F0; + Canvas.DrawLine(Point(tmpR.Right, tmpR.Top), Point(tmpR.Right, tmpR.Bottom), 1.0); + end else + if isMono then + begin + Canvas.Stroke.Color:= TAlphaColorRec.White; + Canvas.DrawLine(Point(tmpR.Right, tmpR.Top), Point(tmpR.Right, tmpR.Bottom), 1.0); + end else + begin + Canvas.Stroke.Color:= $FFA0A0A0; + Canvas.DrawLine(Point(tmpR.Right, tmpR.Top), Point(tmpR.Right, tmpR.Bottom), 1.0); + end; + end; + + if edge and BDR_SUNKENINNER<>0 then + begin + if isSoft then + begin + Canvas.Stroke.Color:= $FFE3E3E3; + Canvas.DrawLine(Point(tmpR.Right, tmpR.Top), Point(tmpR.Right, tmpR.Bottom), 1.0); + end else + if IsFlat then + begin + Canvas.Stroke.Color:= $FFE3E3E3; + Canvas.DrawLine(Point(tmpR.Right, tmpR.Top), Point(tmpR.Right, tmpR.Bottom), 1.0); + end else + if isMono then + begin + Canvas.Stroke.Color:= TAlphaColorRec.White; + Canvas.DrawLine(Point(tmpR.Right, tmpR.Top), Point(tmpR.Right, tmpR.Bottom), 1.0); + end else + begin + Canvas.Stroke.Color:= $FFE3E3E3; + Canvas.DrawLine(Point(tmpR.Right, tmpR.Top), Point(tmpR.Right, tmpR.Bottom), 1.0); + end; + end; + end; + + if grfFlags and BF_BOTTOM<>0 then + begin + tmpR:= R; + Dec(tmpR.Bottom); + if edge and BDR_RAISEDOUTER<>0 then + begin + if isSoft then + begin + Canvas.Stroke.Color:= $FF696969; + Canvas.DrawLine(Point(tmpR.Left, tmpR.Bottom), Point(tmpR.Right, tmpR.Bottom), 1.0); + end else + if IsFlat then + begin + Canvas.Stroke.Color:= $FFA0A0A0; + Canvas.DrawLine(Point(tmpR.Left, tmpR.Bottom), Point(tmpR.Right, tmpR.Bottom), 1.0); + end else + if isMono then + begin + Canvas.Stroke.Color:= $FF646464; + Canvas.DrawLine(Point(tmpR.Left, tmpR.Bottom), Point(tmpR.Right, tmpR.Bottom), 1.0); + end else + begin + Canvas.Stroke.Color:= $FF696969; + Canvas.DrawLine(Point(tmpR.Left, tmpR.Bottom), Point(tmpR.Right, tmpR.Bottom), 1.0); + end; + InflateRect(tmpR, -1, -1) + end; + + if edge and BDR_SUNKENOUTER<>0 then + begin + if isSoft then + begin + Canvas.Stroke.Color:= TAlphaColorRec.White; + Canvas.DrawLine(Point(tmpR.Left, tmpR.Bottom), Point(tmpR.Right, tmpR.Bottom), 1.0); + end else + if IsFlat then + begin + Canvas.Stroke.Color:= $FFA0A0A0; + Canvas.DrawLine(Point(tmpR.Left, tmpR.Bottom), Point(tmpR.Right, tmpR.Bottom), 1.0); + end else + if isMono then + begin + Canvas.Stroke.Color:= $FF646464; + Canvas.DrawLine(Point(tmpR.Left, tmpR.Bottom), Point(tmpR.Right, tmpR.Bottom), 1.0); + end else + begin + Canvas.Stroke.Color:= TAlphaColorRec.White; + Canvas.DrawLine(Point(tmpR.Left, tmpR.Bottom), Point(tmpR.Right, tmpR.Bottom), 1.0); + end; + InflateRect(tmpR, -1, -1) + end; + + if edge and BDR_RAISEDINNER<>0 then + begin + if isSoft then + begin + Canvas.Stroke.Color:= $FFA0A0A0; + Canvas.DrawLine(Point(tmpR.Left, tmpR.Bottom), Point(tmpR.Right, tmpR.Bottom), 1.0); + end else + if IsFlat then + begin + Canvas.Stroke.Color:= $FFF0F0F0; + Canvas.DrawLine(Point(tmpR.Left, tmpR.Bottom), Point(tmpR.Right, tmpR.Bottom), 1.0); + end else + if isMono then + begin + Canvas.Stroke.Color:= TAlphaColorRec.White; + Canvas.DrawLine(Point(tmpR.Left, tmpR.Bottom), Point(tmpR.Right, tmpR.Bottom), 1.0); + end else + begin + Canvas.Stroke.Color:= $FFA0A0A0; + Canvas.DrawLine(Point(tmpR.Left, tmpR.Bottom), Point(tmpR.Right, tmpR.Bottom), 1.0); + end; + end; + + if edge and BDR_SUNKENINNER<>0 then + begin + if isSoft then + begin + Canvas.Stroke.Color:= $FFE3E3E3; + Canvas.DrawLine(Point(tmpR.Left, tmpR.Bottom), Point(tmpR.Right, tmpR.Bottom), 1.0); + end else + if IsFlat then + begin + Canvas.Stroke.Color:= $FFE3E3E3; + Canvas.DrawLine(Point(tmpR.Left, tmpR.Bottom), Point(tmpR.Right, tmpR.Bottom), 1.0); + end else + if isMono then + begin + Canvas.Stroke.Color:= $FFE3E3E3; + Canvas.DrawLine(Point(tmpR.Left, tmpR.Bottom), Point(tmpR.Right, tmpR.Bottom), 1.0); + end else + begin + Canvas.Stroke.Color:= $FFE3E3E3; + Canvas.DrawLine(Point(tmpR.Left, tmpR.Bottom), Point(tmpR.Right, tmpR.Bottom), 1.0); + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure GetTextExtentPoint32W(ACanvas: TCanvas; CaptionText: String; Len: Integer; Var Size: TSize); +begin + Size.cx:= ACanvas.TextWidth(Copy(CaptionText, 1, Len)); + Size.cy:= ACanvas.TextHeight(Copy(CaptionText, 1, Len)); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure GetTextMetrics(ACanvas: TCanvas; var TM: TTextMetric); +Var P: TPathData; + tx: TTextLayout; + R: TRectF; +begin +{ + tmHeight: Single; //The height (ascent + descent) of characters. + tmAscent: Single; //The ascent (units above the base line) of characters. + tmDescent: Single; //The descent (units below the base line) of characters. + tmInternalLeading: Single; //The amount of leading (space) inside the bounds set by the tmHeight member. Accent marks and other diacritical characters may occur in this area. The designer may set this member to zero + tmExternalLeading: Single; //The amount of extra leading (space) that the application adds between rows. Since this area is outside the font, it contains no marks and is not altered by text output calls in either OPAQUE or TRANSPARENT mode. The designer may set this member to zero. + tmAveCharWidth: Single; //The average width of characters in the font (generally defined as the width of the letter x ). This value does not include the overhang required for bold or italic characters. + tmMaxCharWidth: Single; //The width of the widest character in the font. + tmWeight: Single; //The weight of the font. + tmOverhang: Single; + tmDigitizedAspectX: Single; //The horizontal aspect of the device for which the font was designed. + tmDigitizedAspectY: Single; //The vertical aspect of the device for which the font was designed. The ratio of the tmDigitizedAspectX and tmDigitizedAspectY members is the aspect ratio of the device for which the font was designed. + tmFirstChar: WideChar; //The value of the first character defined in the font. + tmLastChar: WideChar; //The value of the last character defined in the font. + tmDefaultChar: WideChar; //The value of the character to be substituted for characters not in the font. + tmBreakChar: WideChar; //The value of the character that will be used to define word breaks for text justification. + tmItalic: Byte; //Specifies an italic font if it is nonzero. + tmUnderlined: Byte; //Specifies an underlined font if it is nonzero. + tmStruckOut: Byte; //A strikeout font if it is nonzero. + tmPitchAndFamily: Byte; //Specifies information about the pitch, the technology, and the family of a physical font. TMPF_FIXED_PITCH, TMPF_VECTOR, TMPF_TRUETYPE, TMPF_DEVICE + tmCharSet: Byte; //The character set of the font. The character set can be one of the following values. ANSI_CHARSET, GREEK_CHARSET.... +} + TM.tmExternalLeading:= 0; + TM.tmWeight:= 0; //boldness??? + TM.tmOverhang:= 0; + TM.tmDigitizedAspectX:= 0; + TM.tmDigitizedAspectY:= 0; + TM.tmFirstChar:= 'a'; //??? + TM.tmLastChar:= 'z'; //??? + TM.tmDefaultChar:= ' '; + TM.tmBreakChar:= ' '; + TM.tmItalic:= 0; + TM.tmUnderlined:= 0; + TM.tmStruckOut:= 0; + TM.tmPitchAndFamily:= 0; + TM.tmCharSet:= 0; + + tx:= TTextLayoutManager.DefaultTextLayout.Create(ACanvas); + P:= TPathData.Create; + try + tx.Text:= 'W'; + tx.ConvertToPath(p); + R:= P.GetBounds(); + + TM.tmHeight:= R.Height; + TM.tmMaxCharWidth:= R.Width; + + //------------------------------------ + tx.Text:= 'Ó'; + p.Clear; + tx.ConvertToPath(p); + R:= P.GetBounds(); + TM.tmInternalLeading:= R.Height - TM.tmHeight; + + //------------------------------------ + tx.Text:= 'x'; + p.Clear; + tx.ConvertToPath(p); + R:= P.GetBounds(); + TM.tmAscent:= R.Height - TM.tmHeight; + TM.tmAveCharWidth:= R.Width; + + //------------------------------------ + tx.Text:= 'y'; + p.Clear; + tx.ConvertToPath(p); + TM.tmDescent:= P.GetBounds().Height - R.Height; + TM.tmHeight:= TM.tmHeight + TM.tmDescent; + finally + FreeAndNil(P); + FreeAndNil(tx); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function Rect(ALeft, ATop, ARight, ABottom: Single): TRect; +begin + Result:= RectF(ALeft, ATop, ARight, ABottom); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function Rect(const ATopLeft, ABottomRight: TPoint): TRect; +begin + Result:= RectF(ATopLeft.X, ATopLeft.Y, ABottomRight.X, ABottomRight.Y); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function Point(AX, AY: Single): TPoint; +begin + Result.X:= AX; + Result.Y:= AY; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure Inc(Var V: Single; OIle: Single=1.0); +begin + V:= V + OIle; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure Dec(Var V: Single; OIle: Single=1.0); +begin + V:= V - OIle; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function MulDiv(const A, B, C: Single): Single; +begin + Result:= (A * B) / C; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure FillMemory(Destination: Pointer; Length: NativeUInt; Fill: Byte); +begin + FillChar(Destination^, Length, Fill); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure ZeroMemory(Destination: Pointer; Length: NativeUInt); +begin + FillChar(Destination^, Length, 0); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure MoveMemory(Destination: Pointer; Source: Pointer; Length: NativeUInt); +begin + Move(Source^, Destination^, Length); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure CopyMemory(Destination: Pointer; Source: Pointer; Length: NativeUInt); +begin + Move(Source^, Destination^, Length); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure ChangeBiDiModeAlignment(var Alignment: TAlignment); +begin + case Alignment of + taLeftJustify: Alignment := taRightJustify; + taRightJustify: Alignment := taLeftJustify; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure OleUninitialize(); +begin + //nothing +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function timeGetTime: Int64; +begin + Result:= TThread.GetTickCount; +end; + +{ TChangeLink } + +//---------------------------------------------------------------------------------------------------------------------- + +constructor TChangeLink.Create; +begin + inherited; + IgnoreIndex := True; + IgnoreImages := True; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TChangeLink.GetSender: TCustomImageList; +begin + Result := TCustomImageList(Images); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TChangeLink.SetSender(const Value: TCustomImageList); +begin + Images := TBaseImageList(Value); +end; + +{ THighQualityBitmap } + +constructor THighQualityBitmap.Create; +begin + + inherited; + +end; + +{ TFontHelper } + +function TFontHelper.GetOnChange: TNotifyEvent; +begin + Result:= OnChanged; +end; + +procedure TFontHelper.SetOnChange(const Value: TNotifyEvent); +begin + OnChanged:= Value; +end; + +end. diff --git a/components/virtualtreeview/Source/VirtualTrees.Header.pas b/components/virtualtreeview/Source/VirtualTrees.Header.pas new file mode 100644 index 000000000..c0e556443 --- /dev/null +++ b/components/virtualtreeview/Source/VirtualTrees.Header.pas @@ -0,0 +1,5928 @@ +unit VirtualTrees.Header; + +interface + +uses + WinApi.Windows, + WinApi.Messages, + System.Classes, + System.Types, + System.Generics.Collections, + Vcl.Graphics, + Vcl.Menus, + Vcl.ImgList, + Vcl.Controls, + Vcl.Themes, + Vcl.GraphUtil, + System.UITypes, // some types moved from Vcl.* to System.UITypes + VirtualTrees.StyleHooks, + VirtualTrees.Utils, + VirtualTrees.Types, + VirtualTrees.DragImage; + + +{$MINENUMSIZE 1, make enumerations as small as possible} + + +const + DefaultColumnOptions = [coAllowClick, coDraggable, coEnabled, coParentColor, coParentBidiMode, coResizable, + coShowDropMark, coVisible, coAllowFocus, coEditable, coStyleColor]; + +type + TVTHeader = class; + TVirtualTreeColumn = class; + + // This structure carries all important information about header painting and is used in the advanced header painting. + THeaderPaintInfo = record + TargetCanvas : TCanvas; + Column : TVirtualTreeColumn; + PaintRectangle : TRect; + TextRectangle : TRect; + IsHoverIndex, + IsDownIndex, + IsEnabled, + ShowHeaderGlyph, + ShowSortGlyph, + ShowRightBorder : Boolean; + DropMark : TVTDropMarkMode; + GlyphPos, + SortGlyphPos : TPoint; + SortGlyphSize : TSize; + procedure DrawSortArrow(pDirection : TSortDirection); + procedure DrawDropMark(); + end; + + TVirtualTreeColumns = class; + + TVirtualTreeColumn = class(TCollectionItem) + private + const + cDefaultColumnSpacing = 3; + private + FText, + FHint : string; + FWidth : TDimension; + FPosition : TColumnPosition; + FMinWidth : TDimension; + FMaxWidth : TDimension; + FStyle : TVirtualTreeColumnStyle; + FImageIndex : TImageIndex; + FBiDiMode : TBiDiMode; + FLayout : TVTHeaderColumnLayout; + FMargin, + FSpacing : TDimension; + FOptions : TVTColumnOptions; + FEditOptions : TVTEditOptions; + FEditNextColumn : TDimension; + FTag : NativeInt; + FAlignment : TAlignment; + FCaptionAlignment : TAlignment; // Alignment of the caption. + FLastWidth : TDimension; + FColor : TColor; + FBonusPixel : Boolean; + FSpringRest : Single; // Accumulator for width adjustment when auto spring option is enabled. + FCaptionText : string; + FCheckBox : Boolean; + FCheckType : TCheckType; + FCheckState : TCheckState; + FImageRect : TRect; + FHasImage : Boolean; + FDefaultSortDirection : TSortDirection; + function GetCaptionAlignment : TAlignment; + function GetCaptionWidth : TDimension; + function GetLeft : TDimension; + function IsBiDiModeStored : Boolean; + function IsCaptionAlignmentStored : Boolean; + function IsColorStored : Boolean; + procedure SetAlignment(const Value : TAlignment); + procedure SetBiDiMode(Value : TBiDiMode); + procedure SetCaptionAlignment(const Value : TAlignment); + procedure SetCheckBox(Value : Boolean); + procedure SetCheckState(Value : TCheckState); + procedure SetCheckType(Value : TCheckType); + procedure SetColor(const Value : TColor); + procedure SetImageIndex(Value : TImageIndex); + procedure SetLayout(Value : TVTHeaderColumnLayout); + procedure SetMargin(Value : TDimension); + procedure SetMaxWidth(Value : TDimension); + procedure SetMinWidth(Value : TDimension); + procedure SetOptions(Value : TVTColumnOptions); + procedure SetPosition(Value : TColumnPosition); + procedure SetSpacing(Value : TDimension); + procedure SetStyle(Value : TVirtualTreeColumnStyle); + + protected + FLeft : TDimension; + procedure ChangeScale(M, D : TDimension); virtual; + procedure ComputeHeaderLayout(var PaintInfo : THeaderPaintInfo; DrawFormat : Cardinal; CalculateTextRect : Boolean = False); + procedure DefineProperties(Filer : TFiler); override; + procedure GetAbsoluteBounds(var Left, Right : TDimension); + function GetDisplayName : string; override; + function GetText : string; virtual; // [IPK] + procedure SetText(const Value : string); virtual; // [IPK] private to protected & virtual + function GetOwner : TVirtualTreeColumns; reintroduce; + procedure InternalSetWidth(const Value : TDimension); //bypass side effects in SetWidth + procedure ReadHint(Reader : TReader); + procedure ReadText(Reader : TReader); + procedure SetCollection(Value : TCollection); override; + procedure SetWidth(Value : TDimension); + public + constructor Create(Collection : TCollection); override; + destructor Destroy; override; + + procedure Assign(Source : TPersistent); override; + function Equals(OtherColumnObj : TObject) : Boolean; override; + function GetRect : TRect; virtual; + property HasImage : Boolean read FHasImage; + property ImageRect : TRect read FImageRect; + procedure LoadFromStream(const Stream : TStream; Version : Integer); + procedure ParentBiDiModeChanged; + procedure ParentColorChanged; + procedure RestoreLastWidth; + function GetEffectiveColor() : TColor; + procedure SaveToStream(const Stream : TStream); + function UseRightToLeftReading : Boolean; + + property BonusPixel : Boolean read FBonusPixel write FBonusPixel; + property CaptionText : string read FCaptionText; + property LastWidth : TDimension read FLastWidth; + property Left : TDimension read GetLeft; + property Owner : TVirtualTreeColumns read GetOwner; + property SpringRest : Single read FSpringRest write FSpringRest; + published + property Alignment : TAlignment read FAlignment write SetAlignment default taLeftJustify; + property BiDiMode : TBiDiMode read FBiDiMode write SetBiDiMode stored IsBiDiModeStored; + property CaptionAlignment : TAlignment read GetCaptionAlignment write SetCaptionAlignment + stored IsCaptionAlignmentStored default taLeftJustify; + property CaptionWidth : TDimension read GetCaptionWidth; + property CheckType : TCheckType read FCheckType write SetCheckType default ctCheckBox; + property CheckState : TCheckState read FCheckState write SetCheckState default csUncheckedNormal; + property CheckBox : Boolean read FCheckBox write SetCheckBox default False; + property Color : TColor read FColor write SetColor stored IsColorStored; + property DefaultSortDirection : TSortDirection read FDefaultSortDirection write FDefaultSortDirection default sdAscending; + property Hint : string read FHint write FHint; + property ImageIndex : TImageIndex read FImageIndex write SetImageIndex default - 1; + property Layout : TVTHeaderColumnLayout read FLayout write SetLayout default blGlyphLeft; + property Margin : TDimension read FMargin write SetMargin default 4; + property MaxWidth : TDimension read FMaxWidth write SetMaxWidth default 10000; + property MinWidth : TDimension read FMinWidth write SetMinWidth default 10; + property Options : TVTColumnOptions read FOptions write SetOptions default DefaultColumnOptions; + property EditOptions : TVTEditOptions read FEditOptions write FEditOptions default toDefaultEdit; + property EditNextColumn : TDimension read FEditNextColumn write FEditNextColumn default - 1; + property Position : TColumnPosition read FPosition write SetPosition; + property Spacing : TDimension read FSpacing write SetSpacing default cDefaultColumnSpacing; + property Style : TVirtualTreeColumnStyle read FStyle write SetStyle default vsText; + property Tag : NativeInt read FTag write FTag default 0; + property Text : string read GetText write SetText; + property Width : TDimension read FWidth write SetWidth default 50; + end; + + TVirtualTreeColumnClass = class of TVirtualTreeColumn; + + TColumnsArray = array of TVirtualTreeColumn; + TCardinalArray = array of Cardinal; + TIndexArray = array of TColumnIndex; + + TVirtualTreeColumns = class(TCollection) + private + FHeader : TVTHeader; + FHeaderBitmap : TBitmap; // backbuffer for drawing + FHoverIndex, // currently "hot" column + FDownIndex, // Column on which a mouse button is held down. + FTrackIndex : TColumnIndex; // Index of column which is currently being resized. + FClickIndex : TColumnIndex; // Index of the last clicked column. + FCheckBoxHit : Boolean; // True if the last click was on a header checkbox. + FPositionToIndex : TIndexArray; + FDefaultWidth : TDimension; // the width columns are created with + FNeedPositionsFix : Boolean; // True if FixPositions must still be called after DFM loading or Bidi mode change. + FClearing : Boolean; // True if columns are being deleted entirely. + FColumnPopupMenu : TPopupMenu; // Member for storing the TVTHeaderPopupMenu + function GetCount : Integer; + function GetItem(Index : TColumnIndex) : TVirtualTreeColumn; + function GetNewIndex(P : TPoint; var OldIndex : TColumnIndex) : Boolean; + procedure SetDefaultWidth(Value : TDimension); + procedure SetItem(Index : TColumnIndex; Value : TVirtualTreeColumn); + function GetTreeView: TCustomControl; + protected + // drag support + FDragIndex : TColumnIndex; // index of column currently being dragged + FDropTarget : TColumnIndex; // current target column (index) while dragging + FDropBefore : Boolean; // True if drop position is in the left half of a column, False for the right + // side to drop the dragged column to + + procedure AdjustAutoSize(CurrentIndex : TColumnIndex; Force : Boolean = False); + function AdjustDownColumn(P : TPoint) : TColumnIndex; + function AdjustHoverColumn(P : TPoint) : Boolean; + procedure AdjustPosition(Column : TVirtualTreeColumn; Position : Cardinal); + function CanSplitterResize(P : TPoint; Column : TColumnIndex) : Boolean; + procedure DoCanSplitterResize(P : TPoint; Column : TColumnIndex; var Allowed : Boolean); virtual; + procedure DrawButtonText(DC : HDC; Caption : string; Bounds : TRect; Enabled, Hot : Boolean; DrawFormat : Cardinal; + WrapCaption : Boolean); + procedure FixPositions; + function GetColumnAndBounds(P : TPoint; var ColumnLeft, ColumnRight : TDimension; Relative : Boolean = True) : Integer; + function GetOwner : TPersistent; override; + function HandleClick(P : TPoint; Button : TMouseButton; Force, DblClick : Boolean) : Boolean; virtual; + procedure HeaderPopupMenuAddHeaderPopupItem(const Sender : TObject; const Column : TColumnIndex; var Cmd : TAddPopupItemType); + procedure IndexChanged(OldIndex, NewIndex : Integer); + procedure InitializePositionArray; + procedure Notify(Item : TCollectionItem; Action : System.Classes.TCollectionNotification); override; + procedure ReorderColumns(RTL : Boolean); + procedure SetHoverIndex(Index : TColumnIndex); + procedure Update(Item : TCollectionItem); override; + procedure UpdatePositions(Force : Boolean = False); + + property HeaderBitmap : TBitmap read FHeaderBitmap; + property PositionToIndex : TIndexArray read FPositionToIndex; + property HoverIndex : TColumnIndex read FHoverIndex write FHoverIndex; + property DownIndex : TColumnIndex read FDownIndex write FDownIndex; + property CheckBoxHit : Boolean read FCheckBoxHit write FCheckBoxHit; + // Mitigator function to use the correct style service for this context (either the style assigned to the control for Delphi > 10.4 or the application style) + function StyleServices(AControl : TControl = nil) : TCustomStyleServices; + public + constructor Create(AOwner : TVTHeader); virtual; + destructor Destroy; override; + + function Add : TVirtualTreeColumn; virtual; + procedure AnimatedResize(Column : TColumnIndex; NewWidth : TDimension); + procedure Assign(Source : TPersistent); override; + procedure Clear; virtual; + function ColumnFromPosition(P : TPoint; Relative : Boolean = True) : TColumnIndex; overload; virtual; + function ColumnFromPosition(PositionIndex : TColumnPosition) : TColumnIndex; overload; virtual; + function Equals(OtherColumnsObj : TObject) : Boolean; override; + procedure GetColumnBounds(Column : TColumnIndex; var Left, Right : TDimension); + function GetFirstVisibleColumn(ConsiderAllowFocus : Boolean = False) : TColumnIndex; + function GetLastVisibleColumn(ConsiderAllowFocus : Boolean = False) : TColumnIndex; + function GetFirstColumn : TColumnIndex; + function GetNextColumn(Column : TColumnIndex) : TColumnIndex; + function GetNextVisibleColumn(Column : TColumnIndex; ConsiderAllowFocus : Boolean = False) : TColumnIndex; + function GetPreviousColumn(Column : TColumnIndex) : TColumnIndex; + function GetPreviousVisibleColumn(Column : TColumnIndex; ConsiderAllowFocus : Boolean = False) : TColumnIndex; + function GetScrollWidth : TDimension; + function GetVisibleColumns : TColumnsArray; + function GetVisibleFixedWidth : TDimension; + function IsValidColumn(Column : TColumnIndex) : Boolean; + procedure LoadFromStream(const Stream : TStream; Version : Integer); + procedure PaintHeader(DC : HDC; R : TRect; HOffset : TDimension); overload; virtual; + procedure PaintHeader(TargetCanvas : TCanvas; R : TRect; const Target : TPoint; + RTLOffset : TDimension = 0); overload; virtual; + procedure SaveToStream(const Stream : TStream); + procedure EndUpdate(); override; + function TotalWidth : TDimension; + + property Count : Integer read GetCount; + property ClickIndex : TColumnIndex read FClickIndex write FClickIndex; + property DefaultWidth : TDimension read FDefaultWidth write SetDefaultWidth; + property DragIndex : TColumnIndex read FDragIndex write FDragIndex; + property DropBefore : Boolean read FDropBefore write FDropBefore; + property DropTarget : TColumnIndex read FDropTarget write FDropTarget; + property Items[Index : TColumnIndex] : TVirtualTreeColumn read GetItem write SetItem; default; + property Header: TVTHeader read FHeader; + property TrackIndex : TColumnIndex read FTrackIndex write FTrackIndex; + property TreeView : TCustomControl read GetTreeView; + property UpdateCount; + end; + + TVirtualTreeColumnsClass = class of TVirtualTreeColumns; + + TVTConstraintPercent = 0 .. 100; + + TVTFixedAreaConstraints = class(TPersistent) + private + FHeader : TVTHeader; + FMaxHeightPercent, FMaxWidthPercent, FMinHeightPercent, FMinWidthPercent : TVTConstraintPercent; + FOnChange : TNotifyEvent; + procedure SetConstraints(Index : Integer; Value : TVTConstraintPercent); + protected + procedure Change; + property Header : TVTHeader read FHeader; + public + constructor Create(AOwner : TVTHeader); + + procedure Assign(Source : TPersistent); override; + property OnChange : TNotifyEvent read FOnChange write FOnChange; + published + property MaxHeightPercent : TVTConstraintPercent index 0 read FMaxHeightPercent write SetConstraints default 0; + property MaxWidthPercent : TVTConstraintPercent index 1 read FMaxWidthPercent write SetConstraints default 95; + property MinHeightPercent : TVTConstraintPercent index 2 read FMinHeightPercent write SetConstraints default 0; + property MinWidthPercent : TVTConstraintPercent index 3 read FMinWidthPercent write SetConstraints default 0; + end; + + TVTHeader = class(TPersistent) + private + FOwner : TCustomControl; + FColumns : TVirtualTreeColumns; + FHeight : TDimension; + FFont : TFont; + FParentFont : Boolean; + FOptions : TVTHeaderOptions; + FStyle : TVTHeaderStyle; //button style + FBackgroundColor : TColor; + FAutoSizeIndex : TColumnIndex; + FPopupMenu : TPopupMenu; + FMainColumn : TColumnIndex; //the column which holds the tree + FMaxHeight : TDimension; + FMinHeight : TDimension; + FDefaultHeight : TDimension; + FFixedAreaConstraints : TVTFixedAreaConstraints; //Percentages for the fixed area (header, fixed columns). + FImages : TCustomImageList; + FImageChangeLink : TChangeLink; //connections to the image list to get notified about changes + fSplitterHitTolerance : TDimension; //For property SplitterHitTolerance + FSortColumn : TColumnIndex; + FSortDirection : TSortDirection; + FDragImage : TVTDragImage; //drag image management during header drag + FLastWidth : TDimension; //Used to adjust spring columns. This is the width of all visible columns, not the header rectangle. + FRestoreSelectionColumnIndex : Integer; //The column that is used to implement the coRestoreSelection option + FWasDoubleClick : Boolean; // The previous mouse message was for a double click, that allows us to process mouse-up-messages differently + function GetMainColumn : TColumnIndex; + function GetUseColumns : Boolean; + function IsFontStored : Boolean; + procedure SetAutoSizeIndex(Value : TColumnIndex); + procedure SetBackground(Value : TColor); + procedure SetColumns(Value : TVirtualTreeColumns); + procedure SetDefaultHeight(Value : TDimension); + procedure SetFont(const Value : TFont); + procedure SetHeight(Value : TDimension); + procedure SetImages(const Value : TCustomImageList); + procedure SetMainColumn(Value : TColumnIndex); + procedure SetMaxHeight(Value : TDimension); + procedure SetMinHeight(Value : TDimension); + procedure SetOptions(Value : TVTHeaderOptions); + procedure SetParentFont(Value : Boolean); + procedure SetSortColumn(Value : TColumnIndex); + procedure SetSortDirection(const Value : TSortDirection); + procedure SetStyle(Value : TVTHeaderStyle); + function GetRestoreSelectionColumnIndex : Integer; + function AreColumnsStored: Boolean; + protected + FStates : THeaderStates; //Used to keep track of internal states the header can enter. + FDragStart : TPoint; //initial mouse drag position + FTrackStart : TPoint; //client coordinates of the tracking start point + FTrackPoint : TPoint; //Client coordinate where the tracking started. + FDoingAutoFitColumns : Boolean; //Flag to avoid using the stored width for Main column + + procedure FontChanged(Sender : TObject); virtual; + procedure AutoScale(); virtual; + function CanSplitterResize(P : TPoint) : Boolean; + function CanWriteColumns : Boolean; virtual; + procedure ChangeScale(M, D : TDimension); virtual; + function DetermineSplitterIndex(P : TPoint) : Boolean; virtual; + procedure DoAfterAutoFitColumn(Column : TColumnIndex); virtual; + procedure DoAfterColumnWidthTracking(Column : TColumnIndex); virtual; + procedure DoAfterHeightTracking; virtual; + function DoBeforeAutoFitColumn(Column : TColumnIndex; SmartAutoFitType : TSmartAutoFitType) : Boolean; virtual; + procedure DoBeforeColumnWidthTracking(Column : TColumnIndex; Shift : TShiftState); virtual; + procedure DoBeforeHeightTracking(Shift : TShiftState); virtual; + procedure DoCanSplitterResize(P : TPoint; var Allowed : Boolean); virtual; + function DoColumnWidthDblClickResize(Column : TColumnIndex; P : TPoint; Shift : TShiftState) : Boolean; virtual; + function DoColumnWidthTracking(Column : TColumnIndex; Shift : TShiftState; var TrackPoint : TPoint; P : TPoint) : Boolean; virtual; + function DoGetPopupMenu(Column : TColumnIndex; Position : TPoint) : TPopupMenu; virtual; + function DoHeightTracking(var P : TPoint; Shift : TShiftState) : Boolean; virtual; + function DoHeightDblClickResize(var P : TPoint; Shift : TShiftState) : Boolean; virtual; + procedure DoSetSortColumn(Value : TColumnIndex; pSortDirection : TSortDirection); virtual; + procedure FixedAreaConstraintsChanged(Sender : TObject); + function GetColumnsClass : TVirtualTreeColumnsClass; virtual; + function GetOwner : TPersistent; override; + function GetShiftState : TShiftState; + function HandleHeaderMouseMove(var Message : TWMMouseMove) : Boolean; + function HandleMessage(var Message : TMessage) : Boolean; virtual; + procedure ImageListChange(Sender : TObject); + procedure PrepareDrag(P, Start : TPoint); + procedure ReadColumns(Reader : TReader); + procedure RecalculateHeader; virtual; + procedure RescaleHeader; + procedure UpdateMainColumn; + procedure UpdateSpringColumns; + procedure WriteColumns(Writer : TWriter); + procedure InternalSetMainColumn(const Index : TColumnIndex); + procedure InternalSetAutoSizeIndex(const Index : TColumnIndex); + procedure InternalSetSortColumn(const Index : TColumnIndex); + public + constructor Create(AOwner : TCustomControl); virtual; + destructor Destroy; override; + + function AllowFocus(ColumnIndex : TColumnIndex) : Boolean; + procedure Assign(Source : TPersistent); override; + procedure AutoFitColumns(); overload; + procedure AutoFitColumns(Animated : Boolean; SmartAutoFitType : TSmartAutoFitType = smaUseColumnOption; RangeStartCol : Integer = NoColumn; RangeEndCol : Integer = NoColumn); overload; virtual; + procedure ColumnDropped(const P: TPoint); + procedure DragTo(P : TPoint); + function InHeader(P : TPoint) : Boolean; virtual; + function InHeaderSplitterArea(P : TPoint) : Boolean; virtual; + procedure Invalidate(Column : TVirtualTreeColumn; ExpandToBorder : Boolean = False; UpdateNowFlag : Boolean = False); + procedure LoadFromStream(const Stream : TStream); virtual; + function ResizeColumns(ChangeBy : TDimension; RangeStartCol : TColumnIndex; RangeEndCol : TColumnIndex; Options : TVTColumnOptions = [coVisible]) : TDimension; + procedure RestoreColumns; + procedure SaveToStream(const Stream : TStream); virtual; + procedure StyleChanged(); virtual; + procedure ToggleSortDirection(); + + property DragImage : TVTDragImage read FDragImage; + property RestoreSelectionColumnIndex : Integer read GetRestoreSelectionColumnIndex write FRestoreSelectionColumnIndex default NoColumn; + property States : THeaderStates read FStates; + property Treeview : TCustomControl read FOwner; + property UseColumns : Boolean read GetUseColumns; + property doingAutoFitColumns : Boolean read FDoingAutoFitColumns; + published + property AutoSizeIndex : TColumnIndex read FAutoSizeIndex write SetAutoSizeIndex; + property Background : TColor read FBackgroundColor write SetBackground default clBtnFace; + property Columns : TVirtualTreeColumns read FColumns write SetColumns stored AreColumnsStored; + property DefaultHeight : TDimension read FDefaultHeight write SetDefaultHeight default 19; + property Font : TFont read FFont write SetFont stored IsFontStored; + property FixedAreaConstraints : TVTFixedAreaConstraints read FFixedAreaConstraints write FFixedAreaConstraints; + property Height : TDimension read FHeight write SetHeight default 19; + property Images : TCustomImageList read FImages write SetImages; + property MainColumn : TColumnIndex read GetMainColumn write SetMainColumn default 0; + property MaxHeight : TDimension read FMaxHeight write SetMaxHeight default 10000; + property MinHeight : TDimension read FMinHeight write SetMinHeight default 10; + property Options : TVTHeaderOptions read FOptions write SetOptions default [hoColumnResize, hoDrag, hoShowSortGlyphs]; + property ParentFont : Boolean read FParentFont write SetParentFont default True; + property PopupMenu : TPopupMenu read FPopupMenu write FPopupMenu; + property SortColumn : TColumnIndex read FSortColumn write SetSortColumn default NoColumn; + property SortDirection : TSortDirection read FSortDirection write SetSortDirection default sdAscending; + property SplitterHitTolerance : TDimension read fSplitterHitTolerance write fSplitterHitTolerance default 8; + //The area in pixels around a spliter which is sensitive for resizing + property Style : TVTHeaderStyle read FStyle write SetStyle default hsThickButtons; + end; + + TVTHeaderClass = class of TVTHeader; + +implementation + +uses + WinApi.ShlObj, + WinApi.ActiveX, + WinApi.UxTheme, + System.Math, + System.SysUtils, + System.Generics.Defaults, + Vcl.Forms, + VirtualTrees.HeaderPopup, + VirtualTrees.BaseTree, + VirtualTrees.BaseAncestorVcl, // to eliminate H2443 about inline expanding + VirtualTrees.DataObject; + +type + TVirtualTreeColumnsCracker = class(TVirtualTreeColumns); + TVirtualTreeColumnCracker = class(TVirtualTreeColumn); + TBaseVirtualTreeCracker = class(TBaseVirtualTree); + + TVTHeaderHelper = class helper for TVTHeader + public + function Tree : TBaseVirtualTreeCracker; + end; + + TVirtualTreeColumnHelper = class helper for TVirtualTreeColumn + function TreeViewControl : TBaseVirtualTreeCracker; + function Header : TVTHeader; + end; + + TVirtualTreeColumnsHelper = class helper for TVirtualTreeColumns + function TreeViewControl : TBaseVirtualTreeCracker; + end; + +const + cMargin = 2; // the margin between text and the header rectangle + cDownOffset = 1; // the offset of the column header text whit mouse button down + + + //----------------- TVTFixedAreaConstraints ---------------------------------------------------------------------------- + +constructor TVTFixedAreaConstraints.Create(AOwner : TVTHeader); + +begin + inherited Create; + FMaxWidthPercent := 95; + FHeader := AOwner; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTFixedAreaConstraints.SetConstraints(Index : Integer; Value : TVTConstraintPercent); + +begin + case Index of + 0 : + if Value <> FMaxHeightPercent then + begin + FMaxHeightPercent := Value; + if (Value > 0) and (Value < FMinHeightPercent) then + FMinHeightPercent := Value; + Change; + end; + 1 : + if Value <> FMaxWidthPercent then + begin + FMaxWidthPercent := Value; + if (Value > 0) and (Value < FMinWidthPercent) then + FMinWidthPercent := Value; + Change; + end; + 2 : + if Value <> FMinHeightPercent then + begin + FMinHeightPercent := Value; + if (FMaxHeightPercent > 0) and (Value > FMaxHeightPercent) then + FMaxHeightPercent := Value; + Change; + end; + 3 : + if Value <> FMinWidthPercent then + begin + FMinWidthPercent := Value; + if (FMaxWidthPercent > 0) and (Value > FMaxWidthPercent) then + FMaxWidthPercent := Value; + Change; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTFixedAreaConstraints.Change; + +begin + if Assigned(FOnChange) then + FOnChange(Self); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTFixedAreaConstraints.Assign(Source : TPersistent); + +begin + if Source is TVTFixedAreaConstraints then + begin + FMaxHeightPercent := TVTFixedAreaConstraints(Source).FMaxHeightPercent; + FMaxWidthPercent := TVTFixedAreaConstraints(Source).FMaxWidthPercent; + FMinHeightPercent := TVTFixedAreaConstraints(Source).FMinHeightPercent; + FMinWidthPercent := TVTFixedAreaConstraints(Source).FMinWidthPercent; + Change; + end + else + inherited; +end; + +//----------------- TVTHeader ----------------------------------------------------------------------------------------- + +constructor TVTHeader.Create(AOwner : TCustomControl); + +begin + inherited Create; + FOwner := AOwner; + FColumns := GetColumnsClass.Create(Self); + FHeight := 19; + FDefaultHeight := FHeight; + FMinHeight := 10; + FMaxHeight := 10000; + FFont := TFont.Create; + FFont.OnChange := FontChanged; + FParentFont := True; + FBackgroundColor := clBtnFace; + FOptions := [hoColumnResize, hoDrag, hoShowSortGlyphs]; + + FImageChangeLink := TChangeLink.Create; + FImageChangeLink.OnChange := ImageListChange; + + FSortColumn := NoColumn; + FSortDirection := sdAscending; + FMainColumn := NoColumn; + + FDragImage := TVTDragImage.Create(AOwner); + fSplitterHitTolerance := 8; + FFixedAreaConstraints := TVTFixedAreaConstraints.Create(Self); + FFixedAreaConstraints.OnChange := FixedAreaConstraintsChanged; + + FDoingAutoFitColumns := False; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +destructor TVTHeader.Destroy; + +begin + FDragImage.Free; + FFixedAreaConstraints.Free; + FImageChangeLink.Free; + FFont.Free; + FColumns.Clear; //TCollection's Clear method is not virtual, so we have to call our own Clear method manually. + FColumns.Free; + inherited; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.FontChanged(Sender : TObject); +begin + inherited; + AutoScale(); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.AutoScale(); +var + I : Integer; + lMaxHeight : TDimension; +begin + if (toAutoChangeScale in TBaseVirtualTreeCracker(Tree).TreeOptions.AutoOptions) then + begin + //Ensure a minimum header size based on the font, so that all text is visible. + //First find the largest Columns[].Spacing + lMaxHeight := 0; + for I := 0 to Self.Columns.Count - 1 do + lMaxHeight := Max(lMaxHeight, Columns[I].Spacing); + //Calculate the required height based on the font, this is important as the user might just have increased the size of the system icon font. + with TBitmap.Create do + try + Canvas.Font.Assign(FFont); + lMaxHeight := lMaxHeight { top spacing } + Divide(lMaxHeight, 2) { minimum bottom spacing } + Canvas.TextHeight('Q'); + finally + Free; + end; + //Set the calculated size + Self.SetHeight(lMaxHeight); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTHeader.GetMainColumn : TColumnIndex; +begin + if FColumns.Count > 0 then + Result := FMainColumn + else + Result := NoColumn; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTHeader.GetUseColumns : Boolean; +begin + Result := FColumns.Count > 0; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTHeader.IsFontStored : Boolean; +begin + Result := not ParentFont; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.SetAutoSizeIndex(Value : TColumnIndex); +begin + if FAutoSizeIndex <> Value then + begin + FAutoSizeIndex := Value; + if hoAutoResize in FOptions then + TVirtualTreeColumnsCracker(Columns).AdjustAutoSize(InvalidColumn); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.SetBackground(Value : TColor); +begin + if FBackgroundColor <> Value then + begin + FBackgroundColor := Value; + Invalidate(nil); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.SetColumns(Value : TVirtualTreeColumns); + +begin + FColumns.Assign(Value); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.SetDefaultHeight(Value : TDimension); +begin + if Value < FMinHeight then + Value := FMinHeight; + if Value > FMaxHeight then + Value := FMaxHeight; + + if FHeight = FDefaultHeight then + SetHeight(Value); + FDefaultHeight := Value; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.SetFont(const Value : TFont); +begin + FFont.Assign(Value); + FParentFont := False; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.SetHeight(Value : TDimension); + +var + RelativeMaxHeight, RelativeMinHeight, EffectiveMaxHeight, EffectiveMinHeight : TDimension; +begin + if not Tree.HandleAllocated then + begin + FHeight := Value; + Include(FStates, hsNeedScaling); + end + else + begin + with FFixedAreaConstraints do + begin + RelativeMaxHeight := Divide((Tree.ClientHeight + FHeight) * FMaxHeightPercent, 100); + RelativeMinHeight := Divide((Tree.ClientHeight + FHeight) * FMinHeightPercent, 100); + + EffectiveMinHeight := IfThen(FMaxHeightPercent > 0, Min(RelativeMaxHeight, FMinHeight), FMinHeight); + EffectiveMaxHeight := IfThen(FMinHeightPercent > 0, Max(RelativeMinHeight, FMaxHeight), FMaxHeight); + + Value := Min(Max(Value, EffectiveMinHeight), EffectiveMaxHeight); + if FMinHeightPercent > 0 then + Value := Max(RelativeMinHeight, Value); + if FMaxHeightPercent > 0 then + Value := Min(RelativeMaxHeight, Value); + end; + + if FHeight <> Value then + begin + FHeight := Value; + if not (csLoading in Tree.ComponentState) and not (hsScaling in FStates) then + RecalculateHeader; + Tree.Invalidate; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.SetImages(const Value : TCustomImageList); + +begin + if FImages <> Value then + begin + if Assigned(FImages) then + begin + FImages.UnRegisterChanges(FImageChangeLink); + FImages.RemoveFreeNotification(FOwner); + end; + FImages := Value; + if Assigned(FImages) then + begin + FImages.RegisterChanges(FImageChangeLink); + FImages.FreeNotification(FOwner); + end; + if not (csLoading in Tree.ComponentState) then + Invalidate(nil); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.SetMainColumn(Value : TColumnIndex); + +begin + if (csLoading in Tree.ComponentState) or (csDestroying in Tree.ComponentState) then + FMainColumn := Value + else + begin + if Value < 0 then + Value := 0; + if Value > FColumns.Count - 1 then + Value := FColumns.Count - 1; + if Value <> FMainColumn then + begin + FMainColumn := Value; + Tree.MainColumnChanged; + if not (toExtendedFocus in Tree.TreeOptions.SelectionOptions) then + Tree.FocusedColumn := FMainColumn; + Tree.Invalidate; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.SetMaxHeight(Value : TDimension); + +begin + if Value < FMinHeight then + Value := FMinHeight; + FMaxHeight := Value; + SetHeight(FHeight); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.SetMinHeight(Value : TDimension); + +begin + if Value < 0 then + Value := 0; + if Value > FMaxHeight then + Value := FMaxHeight; + FMinHeight := Value; + SetHeight(FHeight); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.SetOptions(Value : TVTHeaderOptions); + +var + ToBeSet, ToBeCleared : TVTHeaderOptions; + +begin + ToBeSet := Value - FOptions; + ToBeCleared := FOptions - Value; + FOptions := Value; + + if (hoAutoResize in (ToBeSet + ToBeCleared)) and (FColumns.Count > 0) then + begin + TVirtualTreeColumnsCracker(FColumns).AdjustAutoSize(InvalidColumn); + if Tree.HandleAllocated then + begin + Tree.UpdateHorizontalScrollBar(False); + if hoAutoResize in ToBeSet then + Tree.Invalidate; + end; + end; + + if not (csLoading in Tree.ComponentState) and Tree.HandleAllocated then + begin + if hoVisible in (ToBeSet + ToBeCleared) then + RecalculateHeader; + Invalidate(nil); + Tree.Invalidate; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.SetParentFont(Value : Boolean); + +begin + if FParentFont <> Value then + begin + FParentFont := Value; + if FParentFont then + FFont.Assign(TBaseVirtualTree(FOwner).Font); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.SetSortColumn(Value : TColumnIndex); + +begin + if csLoading in Tree.ComponentState then + FSortColumn := Value + else + DoSetSortColumn(Value, FSortDirection); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.SetSortDirection(const Value : TSortDirection); + +begin + if Value <> FSortDirection then + begin + FSortDirection := Value; + Invalidate(nil); + if ((toAutoSort in Tree.TreeOptions.AutoOptions) or (hoHeaderClickAutoSort in Options)) and (Tree.UpdateCount = 0) then + Tree.SortTree(FSortColumn, FSortDirection, True); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTHeader.CanSplitterResize(P : TPoint) : Boolean; + +begin + Result := hoHeightResize in FOptions; + DoCanSplitterResize(P, Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.SetStyle(Value : TVTHeaderStyle); + +begin + if FStyle <> Value then + begin + FStyle := Value; + if not (csLoading in Tree.ComponentState) then + Invalidate(nil); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.StyleChanged(); +begin + AutoScale(); //Elements may have changed in size +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTHeader.CanWriteColumns : Boolean; + +//descendants may override this to optionally prevent column writing (e.g. if they are build dynamically). + +begin + Result := True; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.ChangeScale(M, D : TDimension); +var + I : Integer; +begin + //This method is only executed if toAutoChangeScale is set + FMinHeight := MulDiv(FMinHeight, M, D); + FMaxHeight := MulDiv(FMaxHeight, M, D); + Self.Height := MulDiv(FHeight, M, D); + //Scale the columns widths too + for I := 0 to FColumns.Count - 1 do + TVirtualTreeColumnCracker(Self.FColumns[I]).ChangeScale(M, D); + if not ParentFont then + Font.Height := MulDiv(Font.Height, M, D); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTHeader.DetermineSplitterIndex(P : TPoint) : Boolean; + +//Tries to find the index of that column whose right border corresponds to P. +//Result is True if column border was hit (with -3..+5 pixels tolerance). +//For continuous resizing the current track index and the column's left/right border are set. +//Note: The hit test is checking from right to left (or left to right in RTL mode) to make enlarging of zero-sized +//columns possible. + +var + VisibleFixedWidth : TDimension; + SplitPoint : TDimension; + + //--------------- local function -------------------------------------------- + + function IsNearBy(IsFixedCol : Boolean; LeftTolerance, RightTolerance : TDimension) : Boolean; + + begin + if IsFixedCol then + Result := (P.X < SplitPoint + Tree.EffectiveOffsetX + RightTolerance) and (P.X > SplitPoint + Tree.EffectiveOffsetX - LeftTolerance) + else + Result := (P.X > VisibleFixedWidth) and (P.X < SplitPoint + RightTolerance) and (P.X > SplitPoint - LeftTolerance); + end; + +//--------------- end local function ---------------------------------------- + +var + I : Integer; + LeftTolerance : TDimension; //The area left of the column divider which allows column resizing +begin + Result := False; + + if FColumns.Count > 0 then + begin + FColumns.TrackIndex := NoColumn; + VisibleFixedWidth := FColumns.GetVisibleFixedWidth; + LeftTolerance := Round(SplitterHitTolerance * 0.6); + if Tree.UseRightToLeftAlignment then + begin + SplitPoint := - Tree.EffectiveOffsetX; + if FColumns.TotalWidth < Tree.ClientWidth then + Inc(SplitPoint, Tree.ClientWidth - FColumns.TotalWidth); + + for I := 0 to FColumns.Count - 1 do + with TVirtualTreeColumnsCracker(FColumns), Items[PositionToIndex[I]] do + if coVisible in Options then + begin + if IsNearBy(coFixed in Options, LeftTolerance, SplitterHitTolerance - LeftTolerance) then + begin + if CanSplitterResize(P, PositionToIndex[I]) then + begin + Result := True; + TrackIndex := PositionToIndex[I]; + + //Keep the right border of this column. This and the current mouse position + //directly determine the current column width. + FTrackPoint.X := SplitPoint + IfThen(coFixed in Options, Tree.EffectiveOffsetX) + Width; + FTrackPoint.Y := P.Y; + Break; + end; + end; + Inc(SplitPoint, Width); + end; + end + else + begin + SplitPoint := - Tree.EffectiveOffsetX + FColumns.TotalWidth; + + for I := FColumns.Count - 1 downto 0 do + with TVirtualTreeColumnsCracker(FColumns), Items[PositionToIndex[I]] do + if coVisible in Options then + begin + if IsNearBy(coFixed in Options, SplitterHitTolerance - LeftTolerance, LeftTolerance) then + begin + if CanSplitterResize(P, PositionToIndex[I]) then + begin + Result := True; + TrackIndex := PositionToIndex[I]; + + //Keep the left border of this column. This and the current mouse position + //directly determine the current column width. + FTrackPoint.X := SplitPoint + IfThen(coFixed in Options, Tree.EffectiveOffsetX) - Width; + FTrackPoint.Y := P.Y; + Break; + end; + end; + Dec(SplitPoint, Width); + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.DoAfterAutoFitColumn(Column : TColumnIndex); + +begin + if Assigned(Tree.OnAfterAutoFitColumn) then + Tree.OnAfterAutoFitColumn(Self, Column); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.DoAfterColumnWidthTracking(Column : TColumnIndex); + +//Tell the application that a column width tracking operation has been finished. + +begin + if Assigned(Tree.OnAfterColumnWidthTracking) then + Tree.OnAfterColumnWidthTracking(Self, Column); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.DoAfterHeightTracking; + +//Tell the application that a height tracking operation has been finished. + +begin + if Assigned(Tree.OnAfterHeaderHeightTracking) then + Tree.OnAfterHeaderHeightTracking(Self); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTHeader.DoBeforeAutoFitColumn(Column : TColumnIndex; SmartAutoFitType : TSmartAutoFitType) : Boolean; + +//Query the application if we may autofit a column. + +begin + Result := True; + if Assigned(Tree.OnBeforeAutoFitColumn) then + Tree.OnBeforeAutoFitColumn(Self, Column, SmartAutoFitType, Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.DoBeforeColumnWidthTracking(Column : TColumnIndex; Shift : TShiftState); + +//Tell the a application that a column width tracking operation may begin. + +begin + if Assigned(Tree.OnBeforeColumnWidthTracking) then + Tree.OnBeforeColumnWidthTracking(Self, Column, Shift); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.DoBeforeHeightTracking(Shift : TShiftState); + +//Tell the application that a height tracking operation may begin. + +begin + if Assigned(Tree.OnBeforeHeaderHeightTracking) then + Tree.OnBeforeHeaderHeightTracking(Self, Shift); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.DoCanSplitterResize(P : TPoint; var Allowed : Boolean); +begin + if Assigned(Tree.OnCanSplitterResizeHeader) then + Tree.OnCanSplitterResizeHeader(Self, P, Allowed); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTHeader.DoColumnWidthDblClickResize(Column : TColumnIndex; P : TPoint; Shift : TShiftState) : Boolean; + +//Queries the application whether a double click on the column splitter should resize the column. + +begin + Result := True; + if Assigned(Tree.OnColumnWidthDblClickResize) then + Tree.OnColumnWidthDblClickResize(Self, Column, Shift, P, Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTHeader.DoColumnWidthTracking(Column : TColumnIndex; Shift : TShiftState; var TrackPoint : TPoint; P : TPoint) : Boolean; + +begin + Result := True; + if Assigned(Tree.OnColumnWidthTracking) then + Tree.OnColumnWidthTracking(Self, Column, Shift, TrackPoint, P, Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTHeader.DoGetPopupMenu(Column : TColumnIndex; Position : TPoint) : TPopupMenu; + +//Queries the application whether there is a column specific header popup menu. + +var + AskParent : Boolean; + +begin + Result := PopupMenu; + if Assigned(Tree.OnGetPopupMenu) then + Tree.OnGetPopupMenu(TBaseVirtualTree(FOwner), nil, Column, Position, AskParent, Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTHeader.DoHeightTracking(var P : TPoint; Shift : TShiftState) : Boolean; + +begin + Result := True; + if Assigned(Tree.OnHeaderHeightTracking) then + Tree.OnHeaderHeightTracking(Self, P, Shift, Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTHeader.DoHeightDblClickResize(var P : TPoint; Shift : TShiftState) : Boolean; + +begin + Result := True; + if Assigned(Tree.OnHeaderHeightDblClickResize) then + Tree.OnHeaderHeightDblClickResize(Self, P, Shift, Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.DoSetSortColumn(Value : TColumnIndex; pSortDirection : TSortDirection); + +begin + if Value < NoColumn then + Value := NoColumn; + if Value > Columns.Count - 1 then + Value := Columns.Count - 1; + if FSortColumn <> Value then + begin + if FSortColumn > NoColumn then + Invalidate(Columns[FSortColumn]); + FSortColumn := Value; + FSortDirection := pSortDirection; + if FSortColumn > NoColumn then + Invalidate(Columns[FSortColumn]); + if ((toAutoSort in Tree.TreeOptions.AutoOptions) or (hoHeaderClickAutoSort in Options)) and (Tree.UpdateCount = 0) then + Tree.SortTree(FSortColumn, FSortDirection, True); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.DragTo(P : TPoint); + +//Moves the drag image to a new position, which is determined from the passed point P and the previous +//mouse position. + +var + I, NewTarget : Integer; + //optimized drag image move support + ClientP : TPoint; + Left, Right : TDimension; + NeedRepaint : Boolean; //True if the screen needs an update (changed drop target or drop side) + +begin + //Determine new drop target and which side of it is prefered. + ClientP := Tree.ScreenToClient(P); + //Make coordinates relative to (0, 0) of the non-client area. + Inc(ClientP.Y, FHeight); + NewTarget := FColumns.ColumnFromPosition(ClientP); + NeedRepaint := (NewTarget <> InvalidColumn) and (NewTarget <> FColumns.DropTarget); + if NewTarget >= 0 then + begin + FColumns.GetColumnBounds(NewTarget, Left, Right); + if (ClientP.X < Divide((Left + Right), 2)) <> FColumns.DropBefore then + begin + NeedRepaint := True; + FColumns.DropBefore := not FColumns.DropBefore; + end; + end; + + if NeedRepaint then + begin + //Invalidate columns which need a repaint. + if FColumns.DropTarget > NoColumn then + begin + I := FColumns.DropTarget; + FColumns.DropTarget := NoColumn; + Invalidate(FColumns.Items[I]); + end; + if (NewTarget > NoColumn) and (NewTarget <> FColumns.DropTarget) then + begin + Invalidate(FColumns.Items[NewTarget]); + FColumns.DropTarget := NewTarget; + end; + end; + + //Fix for various problems mentioned in issue 248. + if NeedRepaint then + TBaseVirtualTreeCracker(FOwner).UpdateWindow(); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.FixedAreaConstraintsChanged(Sender : TObject); + +//This method gets called when FFixedAreaConstraints is changed. + +begin + if Tree.HandleAllocated then + RescaleHeader + else + Include(FStates, hsNeedScaling); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTHeader.GetColumnsClass : TVirtualTreeColumnsClass; + +//Returns the class to be used for the actual column implementation. descendants may optionally override this and +//return their own class. + +begin + Result := TVirtualTreeColumns; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTHeader.GetOwner : TPersistent; + +begin + Result := FOwner; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTHeader.GetRestoreSelectionColumnIndex : Integer; +begin + if FRestoreSelectionColumnIndex >= 0 then + Result := FRestoreSelectionColumnIndex + else + Result := MainColumn; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTHeader.GetShiftState : TShiftState; + +begin + Result := []; + if GetKeyState(VK_SHIFT) < 0 then + Include(Result, ssShift); + if GetKeyState(VK_CONTROL) < 0 then + Include(Result, ssCtrl); + if GetKeyState(VK_MENU) < 0 then + Include(Result, ssAlt); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTHeader.HandleHeaderMouseMove(var Message : TWMMouseMove) : Boolean; + +var + P : TPoint; + NextColumn, I : TColumnIndex; + NewWidth : TDimension; + iOffsetX : TDimension; + +begin + Result := False; + with Message do + begin + P := Point(XPos, YPos); + if hsColumnWidthTrackPending in FStates then + begin + Tree.StopTimer(HeaderTimer); + FStates := FStates - [hsColumnWidthTrackPending] + [hsColumnWidthTracking]; + HandleHeaderMouseMove := True; + Result := 0; + end + else if hsHeightTrackPending in FStates then + begin + Tree.StopTimer(HeaderTimer); + FStates := FStates - [hsHeightTrackPending] + [hsHeightTracking]; + HandleHeaderMouseMove := True; + Result := 0; + end + else if hsColumnWidthTracking in FStates then + begin + if DoColumnWidthTracking(FColumns.TrackIndex, GetShiftState, FTrackPoint, P) then + begin + if Tree.UseRightToLeftAlignment then + begin + NewWidth := FTrackPoint.X - XPos; + NextColumn := FColumns.GetPreviousVisibleColumn(FColumns.TrackIndex); + end + else + begin + NewWidth := XPos - FTrackPoint.X; + NextColumn := FColumns.GetNextVisibleColumn(FColumns.TrackIndex); + end; + + iOffsetX := Tree.EffectiveOffsetX; + + // The autosized column cannot be resized using the mouse normally. Instead we resize the next + // visible column, so it look as we directly resize the autosized column. + if (hoAutoResize in FOptions) and (FColumns.TrackIndex = FAutoSizeIndex) and + (NextColumn > NoColumn) and (coResizable in FColumns[NextColumn].Options) and + (FColumns[FColumns.TrackIndex].MinWidth < NewWidth) and + (FColumns[FColumns.TrackIndex].MaxWidth > NewWidth) then + FColumns[NextColumn].Width := FColumns[NextColumn].Width - NewWidth + + FColumns[FColumns.TrackIndex].Width + else + FColumns[FColumns.TrackIndex].Width := NewWidth; // 1 EListError seen here (List index out of bounds (-1)) since 10/2013 + + if (iOffsetX > 0) and (iOffsetX <> Tree.EffectiveOffsetX) then + FTrackPoint.X := FTrackPoint.X + iOffsetX - Tree.EffectiveOffsetX; + end; + HandleHeaderMouseMove := True; + Result := 0; + end + else if hsHeightTracking in FStates then + begin + if DoHeightTracking(P, GetShiftState) then + SetHeight(FHeight + P.Y); + HandleHeaderMouseMove := True; + Result := 0; + end + else + begin + if hsDragPending in FStates then + begin + P := Tree.ClientToScreen(P); + //start actual dragging if allowed + if (hoDrag in FOptions) and Tree.DoHeaderDragging(TVirtualTreeColumnsCracker(FColumns).DownIndex) then + begin + if ((Abs(FDragStart.X - P.X) > Mouse.DragThreshold) or (Abs(FDragStart.Y - P.Y) > Mouse.DragThreshold)) then + begin + Tree.StopTimer(HeaderTimer); + with TVirtualTreeColumnsCracker(FColumns) do + begin + I := DownIndex; + DownIndex := NoColumn; + HoverIndex := NoColumn; + if I > NoColumn then + Invalidate(FColumns[I]); + end; + FStates := FStates - [hsDragPending] + [hsDragging]; + PrepareDrag(P, FDragStart); + HandleHeaderMouseMove := True; + Result := 0; + end; + end; + end + else if hsDragging in FStates then + begin + DragTo(Tree.ClientToScreen(Point(XPos, YPos))); + HandleHeaderMouseMove := True; + Result := 0; + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTHeader.HandleMessage(var Message : TMessage) : Boolean; + +//The header gets here the opportunity to handle certain messages before they reach the tree. This is important +//because the tree needs to handle various non-client area messages for the header as well as some dragging/tracking +//events. +//By returning True the message will not be handled further, otherwise the message is then dispatched +//to the proper message handlers. + +var + P : TPoint; + I : TColumnIndex; + HitIndex : TColumnIndex; + NewCursor : TVTCursor; + Button : TMouseButton; + IsInHeader, IsHSplitterHit, IsVSplitterHit : Boolean; + + //--------------- local function -------------------------------------------- + + function HSplitterHit : Boolean; + begin + Result := (hoColumnResize in FOptions) and DetermineSplitterIndex(P); + if Result and not InHeader(P) then + begin + // Code commented due to issue #1067. What was the orginal inention of this code? It does not make much sense unless you allow column resize outside the header. + //NextCol := FColumns.GetNextVisibleColumn(FColumns.TrackIndex); + //if not (coFixed in FColumns[FColumns.TrackIndex].Options) or (NextCol <= NoColumn) or + // (coFixed in FColumns[NextCol].Options) or (P.Y > Tree.RangeY) then + Result := False; + end; + end; + +//--------------- end local function ---------------------------------------- + +begin + Result := False; + case Message.Msg of + WM_SIZE : + begin + if not (tsWindowCreating in TBaseVirtualTreeCracker(FOwner).TreeStates) then + if (hoAutoResize in FOptions) and not (hsAutoSizing in FStates) then + begin + TVirtualTreeColumnsCracker(FColumns).AdjustAutoSize(InvalidColumn); + Invalidate(nil); + end + else if not (hsScaling in FStates) then + begin + RescaleHeader; + Invalidate(nil); + end; + end; + CM_PARENTFONTCHANGED : + if FParentFont then + FFont.Assign(TBaseVirtualTreeCracker(FOwner).Font); + CM_BIDIMODECHANGED : + for I := 0 to FColumns.Count - 1 do + if coParentBiDiMode in FColumns[I].Options then + FColumns[I].ParentBiDiModeChanged; + WM_NCMBUTTONDOWN : + begin + with TWMNCMButtonDown(Message) do + P := Tree.ScreenToClient(Point(XCursor, YCursor)); + if InHeader(P) then + TBaseVirtualTreeCracker(FOwner).DoHeaderMouseDown(mbMiddle, GetShiftState, P.X, P.Y + FHeight); + end; + WM_NCMBUTTONUP : + begin + with TWMNCMButtonUp(Message) do + P := FOwner.ScreenToClient(Point(XCursor, YCursor)); + if InHeader(P) then + begin + with TVirtualTreeColumnsCracker(FColumns) do + begin + HandleClick(P, mbMiddle, True, False); + TBaseVirtualTreeCracker(FOwner).DoHeaderMouseUp(TmouseButton.mbMiddle, GetShiftState, P.X, P.Y + Self.FHeight); + DownIndex := NoColumn; + CheckBoxHit := False; + end; + end; + fWasDoubleClick := False; + end; + WM_LBUTTONDBLCLK, WM_NCLBUTTONDBLCLK, WM_NCMBUTTONDBLCLK, WM_NCRBUTTONDBLCLK : + begin + fWasDoubleClick := True; + if Message.Msg <> WM_LBUTTONDBLCLK then + with TWMNCLButtonDblClk(Message) do + P := FOwner.ScreenToClient(Point(XCursor, YCursor)) + else + with TWMLButtonDblClk(Message) do + P := Point(XPos, YPos); + + if (hoHeightDblClickResize in FOptions) and InHeaderSplitterArea(P) and (FDefaultHeight > 0) then + begin + if DoHeightDblClickResize(P, GetShiftState) and (FDefaultHeight > 0) then + SetHeight(FMinHeight); + Result := True; + end + else if HSplitterHit and ((Message.Msg = WM_NCLBUTTONDBLCLK) or (Message.Msg = WM_LBUTTONDBLCLK)) and (hoDblClickResize in FOptions) and (FColumns.TrackIndex > NoColumn) + then + begin + //If the click was on a splitter then resize column to smallest width. + if DoColumnWidthDblClickResize(FColumns.TrackIndex, P, GetShiftState) then + AutoFitColumns(True, smaUseColumnOption, FColumns[FColumns.TrackIndex].Position, FColumns[FColumns.TrackIndex].Position); + Message.Result := 0; + Result := True; + end + else if InHeader(P) and (Message.Msg <> WM_LBUTTONDBLCLK) then + begin + case Message.Msg of + WM_NCMBUTTONDBLCLK : + Button := TMouseButton.mbMiddle; + WM_NCRBUTTONDBLCLK : + Button := TMouseButton.mbRight; + else + //WM_NCLBUTTONDBLCLK + Button := TMouseButton.mbLeft; + end; + if Button = TMouseButton.mbLeft then + TVirtualTreeColumnsCracker(FColumns).AdjustDownColumn(P); + TVirtualTreeColumnsCracker(FColumns).HandleClick(P, Button, True, True); + end; + end; + //The "hot" area of the headers horizontal splitter is partly within the client area of the the tree, so we need + //to handle WM_LBUTTONDOWN here, too. + WM_LBUTTONDOWN, WM_NCLBUTTONDOWN : + begin + + Application.CancelHint; + + if not (csDesigning in Tree.ComponentState) then + begin + with Tree do + begin + //make sure no auto scrolling is active... + StopTimer(ScrollTimer); + DoStateChange([], [tsScrollPending, tsScrolling]); + //... pending editing is cancelled (actual editing remains active) + StopTimer(EditTimer); + DoStateChange([], [tsEditPending]); + end; + end; + + if Message.Msg = WM_LBUTTONDOWN then + //Coordinates are already client area based. + with TWMLButtonDown(Message) do + begin + P := Point(XPos, YPos); + //#909 + FDragStart := Tree.ClientToScreen(P); + end + else + with TWMNCLButtonDown(Message) do + begin + //want the drag start point in screen coordinates + FDragStart := Point(XCursor, YCursor); + P := Tree.ScreenToClient(FDragStart); + end; + + IsInHeader := InHeader(P); + //in design-time header columns are always resizable + if (csDesigning in Tree.ComponentState) then + IsVSplitterHit := InHeaderSplitterArea(P) + else + IsVSplitterHit := InHeaderSplitterArea(P) and CanSplitterResize(P); + IsHSplitterHit := HSplitterHit; + + if IsVSplitterHit or IsHSplitterHit then + begin + FTrackStart := P; + TVirtualTreeColumnsCracker(FColumns).HoverIndex := NoColumn; + if IsVSplitterHit then + begin + if not (csDesigning in Tree.ComponentState) then + DoBeforeHeightTracking(GetShiftState); + Include(FStates, hsHeightTrackPending); + end + else + begin + if not (csDesigning in Tree.ComponentState) then + DoBeforeColumnWidthTracking(FColumns.TrackIndex, GetShiftState); + Include(FStates, hsColumnWidthTrackPending); + end; + + SetCapture(Tree.Handle); + Result := True; + Message.Result := 0; + end + else if IsInHeader then + begin + HitIndex := TVirtualTreeColumnsCracker(FColumns).AdjustDownColumn(P); + //in design-time header columns are always draggable + if ((csDesigning in Tree.ComponentState) and (HitIndex > NoColumn)) or ((hoDrag in FOptions) and (HitIndex > NoColumn) and (coDraggable in FColumns[HitIndex].Options)) + then + begin + //Show potential drag operation. + //Disabled columns do not start a drag operation because they can't be clicked. + Include(FStates, hsDragPending); + SetCapture(Tree.Handle); + Result := True; + Message.Result := 0; + end; + end; + + //This is a good opportunity to notify the application. + if not (csDesigning in Tree.ComponentState) and IsInHeader then + TBaseVirtualTreeCracker(FOwner).DoHeaderMouseDown(TMouseButton.mbLeft, GetShiftState, P.X, P.Y + FHeight); + end; + WM_NCRBUTTONDOWN : + begin + with TWMNCRButtonDown(Message) do + P := FOwner.ScreenToClient(Point(XCursor, YCursor)); + if InHeader(P) then + TBaseVirtualTreeCracker(FOwner).DoHeaderMouseDown(TMouseButton.mbRight, GetShiftState, P.X, P.Y + FHeight); + end; + WM_NCRBUTTONUP : + if not (csDesigning in FOwner.ComponentState) then + with TWMNCRButtonUp(Message) do + begin + Application.CancelHint; + P := FOwner.ScreenToClient(Point(XCursor, YCursor)); + if InHeader(P) then + begin + HandleMessage := TVirtualTreeColumnsCracker(FColumns).HandleClick(P, TMouseButton.mbRight, True, False); + TBaseVirtualTreeCracker(FOwner).DoHeaderMouseUp(TMouseButton.mbRight, GetShiftState, P.X, P.Y + FHeight); + end; + fWasDoubleClick := False; + end; + //When the tree window has an active mouse capture then we only get "client-area" messages. + WM_LBUTTONUP, WM_NCLBUTTONUP : + begin + Application.CancelHint; + + if FStates <> [] then + begin + ReleaseCapture; + if hsDragging in FStates then + begin + //successfull dragging moves columns + with TWMLButtonUp(Message) do + P := Tree.ClientToScreen(Point(XPos, YPos)); + ColumnDropped(P); + end; + Result := True; + Message.Result := 0; + fWasDoubleClick := False; + end; + + case Message.Msg of + WM_LBUTTONUP : + with TWMLButtonUp(Message) do + begin + with TVirtualTreeColumnsCracker(FColumns) do + begin + if DownIndex > NoColumn then + HandleClick(Point(XPos, YPos), TMouseButton.mbLeft, False, False); + end; + if FStates <> [] then + TBaseVirtualTreeCracker(FOwner).DoHeaderMouseUp(TMouseButton.mbLeft, KeysToShiftState(Keys), XPos, YPos); + fWasDoubleClick := False; + end; + WM_NCLBUTTONUP : + begin + with TWMNCLButtonUp(Message) do + P := FOwner.ScreenToClient(Point(XCursor, YCursor)); + if not fWasDoubleClick then + TVirtualTreeColumnsCracker(FColumns).HandleClick(P, TMouseButton.mbLeft, True, False); + TBaseVirtualTreeCracker(FOwner).DoHeaderMouseUp(TMouseButton.mbLeft, GetShiftState, P.X, P.Y + FHeight); + Result := True; + fWasDoubleClick := False; + end; + end; + + if FColumns.TrackIndex > NoColumn then + begin + if hsColumnWidthTracking in FStates then + DoAfterColumnWidthTracking(FColumns.TrackIndex); + Invalidate(Columns[FColumns.TrackIndex]); + FColumns.TrackIndex := NoColumn; + end; + with TVirtualTreeColumnsCracker(FColumns) do + begin + if DownIndex > NoColumn then + begin + Invalidate(FColumns[DownIndex]); + DownIndex := NoColumn; + end; + end; + if hsHeightTracking in FStates then + DoAfterHeightTracking; + + FStates := FStates - [hsDragging, hsDragPending, hsColumnWidthTracking, hsColumnWidthTrackPending, hsHeightTracking, hsHeightTrackPending]; + end; //WM_NCLBUTTONUP + //hovering, mouse leave detection + WM_NCMOUSEMOVE : + with TWMNCMouseMove(Message), TVirtualTreeColumnsCracker(FColumns) do + begin + P := Tree.ScreenToClient(Point(XCursor, YCursor)); + Tree.DoHeaderMouseMove(GetShiftState, P.X, P.Y + FHeight); + if InHeader(P) and ((AdjustHoverColumn(P)) or ((DownIndex >= 0) and (HoverIndex <> DownIndex))) then + begin + //We need a mouse leave detection from here for the non client area. + //TODO: The best solution available would be the TrackMouseEvent API. + //With the drop of the support of Win95 totally and WinNT4 we should replace the timer. + Tree.StopTimer(HeaderTimer); + SetTimer(Tree.Handle, HeaderTimer, 50, nil); + //use Delphi's internal hint handling for header hints too + if hoShowHint in FOptions then + begin + //client coordinates! + XCursor := P.X; + YCursor := P.Y + FHeight; + Application.HintMouseMessage(FOwner, Message); + end; + end; + end; + WM_TIMER : + if TWMTimer(Message).TimerID = HeaderTimer then + begin + //determine current mouse position to check if it left the window + GetCursorPos(P); + P := Tree.ScreenToClient(P); + with TVirtualTreeColumnsCracker(FColumns) do + begin + if not InHeader(P) or ((DownIndex > NoColumn) and (HoverIndex <> DownIndex)) then + begin + Tree.StopTimer(HeaderTimer); + HoverIndex := NoColumn; + ClickIndex := NoColumn; + DownIndex := NoColumn; + CheckBoxHit := False; + Result := True; + Message.Result := 0; + Invalidate(nil); + end; + end; + end; + WM_MOUSEMOVE : //mouse capture and general message redirection + Result := HandleHeaderMouseMove(TWMMouseMove(Message)); + WM_SETCURSOR : + //Feature: design-time header + if (FStates = []) then + begin + //Retrieve last cursor position (GetMessagePos does not work here, I don't know why). + GetCursorPos(P); + + //Is the mouse in the header rectangle and near the splitters? + P := Tree.ScreenToClient(P); + IsHSplitterHit := HSplitterHit; + //in design-time header columns are always resizable + if (csDesigning in Tree.ComponentState) then + IsVSplitterHit := InHeaderSplitterArea(P) + else + IsVSplitterHit := InHeaderSplitterArea(P) and CanSplitterResize(P); + + if IsVSplitterHit or IsHSplitterHit then + begin + NewCursor := Screen.Cursors[Tree.Cursor]; + if IsVSplitterHit and ((hoHeightResize in FOptions) or (csDesigning in Tree.ComponentState)) then + NewCursor := Screen.Cursors[crVSplit] + else if IsHSplitterHit then + NewCursor := Screen.Cursors[crHSplit]; + + if not (csDesigning in Tree.ComponentState) then + Tree.DoGetHeaderCursor(NewCursor); + Result := NewCursor <> Screen.Cursors[crDefault]; + if Result then + begin + WinApi.Windows.SetCursor(NewCursor); + Message.Result := 1; + end; + end; + end + else + begin + Message.Result := 1; + Result := True; + end; + WM_KEYDOWN, WM_KILLFOCUS : + if (Message.Msg = WM_KILLFOCUS) or (TWMKeyDown(Message).CharCode = VK_ESCAPE) then + begin + if hsDragging in FStates then + begin + ReleaseCapture; + FDragImage.EndDrag; + Exclude(FStates, hsDragging); + FColumns.DropTarget := NoColumn; + Invalidate(nil); + Result := True; + Message.Result := 0; + end + else + begin + if [hsColumnWidthTracking, hsHeightTracking] * FStates <> [] then + begin + ReleaseCapture; + if hsColumnWidthTracking in FStates then + DoAfterColumnWidthTracking(FColumns.TrackIndex); + if hsHeightTracking in FStates then + DoAfterHeightTracking; + Result := True; + Message.Result := 0; + end; + + FStates := FStates - [hsColumnWidthTracking, hsColumnWidthTrackPending, hsHeightTracking, hsHeightTrackPending]; + end; + end; + end; +end; + +procedure TVTHeader.ColumnDropped(const P: TPoint); +var + R: TRect; + OldPosition: Integer; +begin + GetWindowRect(Tree.Handle, R); + with FColumns do + begin + FDragImage.EndDrag; + + //Problem fixed: + //Column Header does not paint correctly after a drop in certain conditions + // ** The conditions are, drag is across header, mouse is not moved after + //the drop and the graphics hardware is slow in certain operations (encountered + //on Windows 10). + //Fix for the problem on certain systems where the dropped column header + //does not appear in the new position if the mouse is not moved after + //the drop. The reason is that the restore backup image operation (BitBlt) + //in the above EndDrag is slower than the header repaint in the code below + //and overlaps the new changed header with the older image. + //This happens because BitBlt seems to operate in its own thread in the + //graphics hardware and finishes later than the following code. + // + //To solve this problem, we introduce a small delay here so that the + //changed header in the following code is correctly repainted after + //the delayed BitBlt above has finished operation to restore the old + //backup image. + sleep(50); + + if (DropTarget > - 1) and (DropTarget <> DragIndex) and PtInRect(R, P) then + begin + OldPosition := FColumns[DragIndex].Position; + if FColumns.DropBefore then + begin + if FColumns[DragIndex].Position < FColumns[DropTarget].Position then + FColumns[DragIndex].Position := Max(0, FColumns[DropTarget].Position - 1) + else + FColumns[DragIndex].Position := FColumns[DropTarget].Position; + end + else + begin + if FColumns[DragIndex].Position < FColumns[DropTarget].Position then + FColumns[DragIndex].Position := FColumns[DropTarget].Position + else + FColumns[DragIndex].Position := FColumns[DropTarget].Position + 1; + end; + Tree.DoHeaderDragged(DragIndex, OldPosition); + end + else + Tree.DoHeaderDraggedOut(DragIndex, P); + DropTarget := NoColumn; + FStates := FStates - [hsDragging, hsDragPending]; + end; + Invalidate(nil); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.ImageListChange(Sender : TObject); + +begin + if not (csDestroying in Tree.ComponentState) then + Invalidate(nil); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.PrepareDrag(P, Start : TPoint); + +//Initializes dragging of the header, P is the current mouse postion and Start the initial mouse position. + +var + Image : TBitmap; + HotSpot : TPoint; + DragColumn : TVirtualTreeColumn; + RTLOffset : TDimension; + lDataObject: IDataObject; + lDragEffect: DWord; // The last executed drag effect, not needed here + +begin + //Determine initial position of drag image (screen coordinates). + FColumns.DropTarget := NoColumn; + Start := Tree.ScreenToClient(Start); + Inc(Start.Y, FHeight); + FColumns.DragIndex := FColumns.ColumnFromPosition(Start); + DragColumn := FColumns[FColumns.DragIndex]; + + Image := TBitmap.Create; + with Image do + try + PixelFormat := pf32Bit; + SetSize(DragColumn.Width, FHeight); + + //Erase the entire image with the color key value, for the case not everything + //in the image is covered by the header image. + Canvas.Brush.Color := clBtnFace; + Canvas.FillRect(Rect(0, 0, Width, Height)); + + if Tree.UseRightToLeftAlignment then + RTLOffset := Tree.ComputeRTLOffset + else + RTLOffset := 0; + with DragColumn do + FColumns.PaintHeader(Canvas, Rect(Left, 0, Left + Width, Height), Point( - RTLOffset, 0), RTLOffset); + + //Column rectangles are given in local window coordinates not client coordinates. + HotSpot := Tree.ScreenToClient(P); + HotSpot.X := HotSpot.X - DragColumn.Left - cMargin; + HotSpot.Y := HotSpot.Y + Height - cMargin; // header is in the non-client area and so the coordinates are negative + + if hoRestrictDrag in FOptions then + FDragImage.MoveRestriction := dmrHorizontalOnly + else + FDragImage.MoveRestriction := dmrNone; + + lDataObject := TVTDataObject.Create(Self, TreeView); + FDragImage.PrepareDrag(Image, HotSpot, lDataObject); + SHDoDragDrop(fOwner.Handle, lDataObject, nil, DROPEFFECT_MOVE, lDragEffect); // SHDoDragDrop() supports drag hints and drag images on Windows Vista and later + finally + Image.Free; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.ReadColumns(Reader : TReader); + +begin + Include(FStates, hsLoading); + Columns.Clear; + Reader.ReadValue; + Reader.ReadCollection(Columns); + Exclude(FStates, hsLoading); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.RecalculateHeader; + +//Initiate a recalculation of the non-client area of the owner tree. + +begin + if Tree.HandleAllocated then + begin + Tree.UpdateHeaderRect; + SetWindowPos(Tree.Handle, 0, 0, 0, 0, 0, SWP_FRAMECHANGED or SWP_NOMOVE or SWP_NOACTIVATE or SWP_NOOWNERZORDER or SWP_NOSENDCHANGING or SWP_NOSIZE or SWP_NOZORDER); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.RescaleHeader; + +//Rescale the fixed elements (fixed columns, header itself) to FixedAreaConstraints. + +var + FixedWidth, MaxFixedWidth, MinFixedWidth : TDimension; + + //--------------- local function -------------------------------------------- + + procedure ComputeConstraints; + + var + I : TColumnIndex; + + begin + with FColumns do + begin + I := GetFirstVisibleColumn; + while I > NoColumn do + begin + if (coFixed in FColumns[I].Options) and (FColumns[I].Width < FColumns[I].MinWidth) then + TVirtualTreeColumnCracker(FColumns[I]).InternalSetWidth(FColumns[I].MinWidth); //SetWidth has side effects and this bypasses them + I := GetNextVisibleColumn(I); + end; + FixedWidth := GetVisibleFixedWidth; + end; + + with FFixedAreaConstraints do + begin + MinFixedWidth := Divide(Tree.ClientWidth * FMinWidthPercent, 100); + MaxFixedWidth := Divide(Tree.ClientWidth * FMaxWidthPercent, 100); + end; + end; + +//----------- end local function -------------------------------------------- + +begin + if ([csLoading, csReading, csWriting, csDestroying] * Tree.ComponentState = []) and not (hsLoading in FStates) and Tree.HandleAllocated then + begin + Include(FStates, hsScaling); + + SetHeight(FHeight); + RecalculateHeader; + + with FFixedAreaConstraints do + if (FMaxWidthPercent > 0) or (FMinWidthPercent > 0) or (FMinHeightPercent > 0) or (FMaxHeightPercent > 0) then + begin + ComputeConstraints; + + with FColumns do + if (FMaxWidthPercent > 0) and (FixedWidth > MaxFixedWidth) then + ResizeColumns(MaxFixedWidth - FixedWidth, 0, Count - 1, [coVisible, coFixed]) + else if (FMinWidthPercent > 0) and (FixedWidth < MinFixedWidth) then + ResizeColumns(MinFixedWidth - FixedWidth, 0, Count - 1, [coVisible, coFixed]); + + TVirtualTreeColumnsCracker(FColumns).UpdatePositions; + end; + + Exclude(FStates, hsScaling); + Exclude(FStates, hsNeedScaling); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.UpdateMainColumn(); + +//Called once the load process of the owner tree is done. + +begin + if FMainColumn < 0 then + MainColumn := 0; + if FMainColumn > FColumns.Count - 1 then + MainColumn := FColumns.Count - 1; + if (FMainColumn >= 0) and not (coVisible in Self.Columns[FMainColumn].Options) then + begin + //Issue #946: Choose new MainColumn if current one ist not visible + MainColumn := Self.Columns.GetFirstVisibleColumn(); + end +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.UpdateSpringColumns; + +var + I : TColumnIndex; + SpringCount : Integer; + Sign : Integer; + ChangeBy : Single; + Difference : Single; + NewAccumulator : Single; + +begin + with Tree do + ChangeBy := HeaderRect.Right - HeaderRect.Left - FLastWidth; + if (hoAutoSpring in FOptions) and (FLastWidth <> 0) and (ChangeBy <> 0) then + begin + //Stay positive if downsizing the control. + if ChangeBy < 0 then + Sign := - 1 + else + Sign := 1; + ChangeBy := Abs(ChangeBy); + //Count how many columns have spring enabled. + SpringCount := 0; + for I := 0 to FColumns.Count - 1 do + if [coVisible, coAutoSpring] * FColumns[I].Options = [coVisible, coAutoSpring] then + System.Inc(SpringCount); + if SpringCount > 0 then + begin + //Calculate the size to add/sub to each columns. + Difference := ChangeBy / SpringCount; + //Adjust the column's size accumulators and resize if the result is >= 1. + for I := 0 to FColumns.Count - 1 do + if [coVisible, coAutoSpring] * FColumns[I].Options = [coVisible, coAutoSpring] then + begin + //Sum up rest changes from previous runs and the amount from this one and store it in the + //column. If there is at least one pixel difference then do a resize and reset the accumulator. + NewAccumulator := FColumns[I].SpringRest + Difference; + //Set new width if at least one pixel size difference is reached. + if NewAccumulator >= 1 then + TVirtualTreeColumnCracker(FColumns[I]).SetWidth(FColumns[I].Width + (Trunc(NewAccumulator) * Sign)); + FColumns[I].SpringRest := Frac(NewAccumulator); + + //Keep track of the size count. + ChangeBy := ChangeBy - Difference; + //Exit loop if resize count drops below freezing point. + if ChangeBy < 0 then + Break; + end; + end; + end; + with Tree do + FLastWidth := HeaderRect.Right - HeaderRect.Left; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +type + //--- HACK WARNING! + //This type cast is a partial rewrite of the private section of TWriter. The purpose is to have access to + //the FPropPath member, which is otherwise not accessible. The reason why this access is needed is that + //with nested components this member contains unneeded property path information. These information prevent + //successful load of the stored properties later. + //In System.Classes.pas you can see that FPropPath is reset several times to '' to prevent this case for certain properies. + //Unfortunately, there is no clean way for us here to do the same. +{$HINTS off} + TWriterHack = class(TFiler) + private + FRootAncestor : TComponent; + FPropPath : string; + end; +{$HINTS on} + + +procedure TVTHeader.WriteColumns(Writer : TWriter); + +//Write out the columns but take care for the case VT is a nested component. + +var + LastPropPath : string; + +begin + //Save last property path for restoration. + LastPropPath := TWriterHack(Writer).FPropPath; + try + //If VT is a nested component then this path contains the name of the parent component at this time + //(otherwise it is already empty). This path is then combined with the property name under which the tree + //is defined in the parent component. Unfortunately, the load code in System.Classes.pas does not consider this case + //is then unable to load this property. + TWriterHack(Writer).FPropPath := ''; + Writer.WriteCollection(Columns); + finally + TWriterHack(Writer).FPropPath := LastPropPath; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTHeader.AllowFocus(ColumnIndex : TColumnIndex) : Boolean; +begin + Result := False; + if not FColumns.IsValidColumn(ColumnIndex) then + Exit; //Just in case. + + Result := (coAllowFocus in FColumns[ColumnIndex].Options); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTHeader.AreColumnsStored: Boolean; +begin + // The columns are stored by the owner tree to support Visual Form Inheritance + // GnutGetText skips non-stored properties, so retur Stored True at runtime + Result := not (csDesigning in Self.Treeview.ComponentState); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.Assign(Source : TPersistent); + +begin + if Source is TVTHeader then + begin + AutoSizeIndex := TVTHeader(Source).AutoSizeIndex; + Background := TVTHeader(Source).Background; + Columns := TVTHeader(Source).Columns; + Font := TVTHeader(Source).Font; + FixedAreaConstraints.Assign(TVTHeader(Source).FixedAreaConstraints); + Height := TVTHeader(Source).Height; + Images := TVTHeader(Source).Images; + MainColumn := TVTHeader(Source).MainColumn; + Options := TVTHeader(Source).Options; + ParentFont := TVTHeader(Source).ParentFont; + PopupMenu := TVTHeader(Source).PopupMenu; + SortColumn := TVTHeader(Source).SortColumn; + SortDirection := TVTHeader(Source).SortDirection; + Style := TVTHeader(Source).Style; + + RescaleHeader; + end + else + inherited; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.AutoFitColumns(); +begin + AutoFitColumns(not Tree.IsUpdating); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.AutoFitColumns(Animated : Boolean; SmartAutoFitType : TSmartAutoFitType = smaUseColumnOption; RangeStartCol : Integer = NoColumn; + RangeEndCol : Integer = NoColumn); + +//--------------- local functions ------------------------------------------- + + function GetUseSmartColumnWidth(ColumnIndex : TColumnIndex) : Boolean; + + begin + case SmartAutoFitType of + smaAllColumns : + Result := True; + smaUseColumnOption : + Result := coSmartResize in FColumns.Items[ColumnIndex].Options; + else + Result := False; + end; + end; + +//---------------------------------------------------------------------------- + + procedure DoAutoFitColumn(Column : TColumnIndex); + + begin + with TVirtualTreeColumnsCracker(FColumns) do + if ([coResizable, coVisible] * Items[PositionToIndex[Column]].Options = [coResizable, coVisible]) and DoBeforeAutoFitColumn(PositionToIndex[Column], SmartAutoFitType) and + not Tree.OperationCanceled then + begin + if Animated then + AnimatedResize(PositionToIndex[Column], Tree.GetMaxColumnWidth(PositionToIndex[Column], GetUseSmartColumnWidth(PositionToIndex[Column]))) + else + FColumns[PositionToIndex[Column]].Width := Tree.GetMaxColumnWidth(PositionToIndex[Column], GetUseSmartColumnWidth(PositionToIndex[Column])); + + DoAfterAutoFitColumn(PositionToIndex[Column]); + end; + end; + +//--------------- end local functions ---------------------------------------- + +var + I : Integer; + StartCol, EndCol : Integer; + +begin + StartCol := Max(NoColumn + 1, RangeStartCol); + + if RangeEndCol <= NoColumn then + EndCol := FColumns.Count - 1 + else + EndCol := Min(RangeEndCol, FColumns.Count - 1); + + if StartCol > EndCol then + Exit; //nothing to do + + Tree.StartOperation(okAutoFitColumns); + FDoingAutoFitColumns := True; + try + if Assigned(Tree.OnBeforeAutoFitColumns) then + Tree.OnBeforeAutoFitColumns(Self, SmartAutoFitType); + + for I := StartCol to EndCol do + DoAutoFitColumn(I); + + if Assigned(Tree.OnAfterAutoFitColumns) then + Tree.OnAfterAutoFitColumns(Self); + + finally + Tree.EndOperation(okAutoFitColumns); + Tree.Invalidate(); + FDoingAutoFitColumns := False; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTHeader.InHeader(P : TPoint) : Boolean; + +//Determines whether the given point (client coordinates!) is within the header rectangle (non-client coordinates). + +var + R, RW : TRect; + +begin + R := Tree.HeaderRect; + + //Current position of the owner in screen coordinates. + GetWindowRect(Tree.Handle, RW); + + //Convert to client coordinates. + MapWindowPoints(0, Tree.Handle, RW, 2); + + //Consider the header within this rectangle. + OffsetRect(R, RW.Left, RW.Top); + Result := PtInRect(R, P); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTHeader.InHeaderSplitterArea(P : TPoint) : Boolean; + +//Determines whether the given point (client coordinates!) hits the horizontal splitter area of the header. + +var + R, RW : TRect; + +begin + if (P.Y > 2) or (P.Y < - 2) or not (hoVisible in FOptions) then + Result := False + else + begin + R := Tree.HeaderRect; + Inc(R.Bottom, 2); + + //Current position of the owner in screen coordinates. + GetWindowRect(Tree.Handle, RW); + + //Convert to client coordinates. + MapWindowPoints(0, Tree.Handle, RW, 2); + + //Consider the header within this rectangle. + OffsetRect(R, RW.Left, RW.Top); + Result := PtInRect(R, P); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.InternalSetAutoSizeIndex(const Index : TColumnIndex); +begin + FAutoSizeIndex := index; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.InternalSetMainColumn(const Index : TColumnIndex); +begin + FMainColumn := index; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.InternalSetSortColumn(const Index : TColumnIndex); +begin + FSortColumn := index; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.Invalidate(Column : TVirtualTreeColumn; ExpandToBorder : Boolean = False; UpdateNowFlag : Boolean = False); + +//Because the header is in the non-client area of the tree it needs some special handling in order to initiate its +//repainting. +//If ExpandToBorder is True then not only the given column but everything or (depending on hoFullRepaintOnResize) just +//everything to its right (or left, in RTL mode) will be invalidated (useful for resizing). This makes only sense when +//a column is given. + +var + R, RW : TRect; + Flags : Cardinal; + +begin + if (hoVisible in FOptions) and Tree.HandleAllocated then + with Tree do + begin + if Column = nil then + R := HeaderRect + else + begin + R := Column.GetRect; + if not (coFixed in Column.Options) then + OffsetRect(R, - EffectiveOffsetX, 0); + if UseRightToLeftAlignment then + OffsetRect(R, ComputeRTLOffset, 0); + if ExpandToBorder then + begin + if (hoFullRepaintOnResize in Header.Options) then + begin + R.Left := HeaderRect.Left; + R.Right := HeaderRect.Right; + end + else + begin + if UseRightToLeftAlignment then + R.Left := HeaderRect.Left + else + R.Right := HeaderRect.Right; + end; + end; + end; + R.Bottom := Tree.ClientHeight; //We want to repaint the entire column to bottom, not just the header + + //Current position of the owner in screen coordinates. + GetWindowRect(Handle, RW); + + //Consider the header within this rectangle. + OffsetRect(R, RW.Left, RW.Top); + + //Expressed in client coordinates (because RedrawWindow wants them so, they will actually become negative). + MapWindowPoints(0, Handle, R, 2); + Flags := RDW_FRAME or RDW_INVALIDATE or RDW_VALIDATE or RDW_NOINTERNALPAINT or RDW_NOERASE or RDW_NOCHILDREN; + if UpdateNowFlag then + Flags := Flags or RDW_UPDATENOW; + RedrawWindow(@R, 0, Flags); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.LoadFromStream(const Stream : TStream); + +//restore the state of the header from the given stream + +var + Dummy, Version : Integer; + S : AnsiString; + OldOptions : TVTHeaderOptions; + +begin + Include(FStates, hsLoading); + with Stream do + try + //Switch off all options which could influence loading the columns (they will be later set again). + OldOptions := FOptions; + FOptions := []; + + //Determine whether the stream contains data without a version number. + ReadBuffer(Dummy, SizeOf(Dummy)); + if Dummy > - 1 then + begin + //Seek back to undo the read operation if this is an old stream format. + Seek( - SizeOf(Dummy), soFromCurrent); + Version := - 1; + end + else //Read version number if this is a "versionized" format. + ReadBuffer(Version, SizeOf(Version)); + Columns.LoadFromStream(Stream, Version); + + ReadBuffer(Dummy, SizeOf(Dummy)); + AutoSizeIndex := Dummy; + ReadBuffer(Dummy, SizeOf(Dummy)); + Background := Dummy; + ReadBuffer(Dummy, SizeOf(Dummy)); + Height := Dummy; + ReadBuffer(Dummy, SizeOf(Dummy)); + FOptions := OldOptions; + Options := TVTHeaderOptions(Dummy); + //PopupMenu is neither saved nor restored + ReadBuffer(Dummy, SizeOf(Dummy)); + Style := TVTHeaderStyle(Dummy); + //TFont has no own save routine so we do it manually + with Font do + begin + ReadBuffer(Dummy, SizeOf(Dummy)); + Color := Dummy; + ReadBuffer(Dummy, SizeOf(Dummy)); + Height := Dummy; + ReadBuffer(Dummy, SizeOf(Dummy)); + SetLength(S, Dummy); + ReadBuffer(PAnsiChar(S)^, Dummy); + Name := UTF8ToString(S); + ReadBuffer(Dummy, SizeOf(Dummy)); + Pitch := TFontPitch(Dummy); + ReadBuffer(Dummy, SizeOf(Dummy)); + Style := TFontStyles(Byte(Dummy)); + end; + + //Read data introduced by stream version 1+. + if Version > 0 then + begin + ReadBuffer(Dummy, SizeOf(Dummy)); + MainColumn := Dummy; + ReadBuffer(Dummy, SizeOf(Dummy)); + SortColumn := Dummy; + ReadBuffer(Dummy, SizeOf(Dummy)); + SortDirection := TSortDirection(Byte(Dummy)); + end; + + //Read data introduced by stream version 5+. + if Version > 4 then + begin + ReadBuffer(Dummy, SizeOf(Dummy)); + ParentFont := Boolean(Dummy); + ReadBuffer(Dummy, SizeOf(Dummy)); + FMaxHeight := Integer(Dummy); + ReadBuffer(Dummy, SizeOf(Dummy)); + FMinHeight := Integer(Dummy); + ReadBuffer(Dummy, SizeOf(Dummy)); + FDefaultHeight := Integer(Dummy); + with FFixedAreaConstraints do + begin + ReadBuffer(Dummy, SizeOf(Dummy)); + FMaxHeightPercent := TVTConstraintPercent(Dummy); + ReadBuffer(Dummy, SizeOf(Dummy)); + FMaxWidthPercent := TVTConstraintPercent(Dummy); + ReadBuffer(Dummy, SizeOf(Dummy)); + FMinHeightPercent := TVTConstraintPercent(Dummy); + ReadBuffer(Dummy, SizeOf(Dummy)); + FMinWidthPercent := TVTConstraintPercent(Dummy); + end; + end; + finally + Exclude(FStates, hsLoading); + RecalculateHeader(); + Tree.DoColumnResize(NoColumn); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTHeader.ResizeColumns(ChangeBy : TDimension; RangeStartCol : TColumnIndex; RangeEndCol : TColumnIndex; Options : TVTColumnOptions = [coVisible]) : TDimension; + +//Distribute the given width change to a range of columns. A 'fair' way is used to distribute ChangeBy to the columns, +//while ensuring that everything that can be distributed will be distributed. + +var + Start, I : TColumnIndex; + ColCount, + Sign: Integer; + ToGo, MaxDelta, Difference, Rest: TDimension; + Constraints, Widths : array of TDimension; + BonusPixel : Boolean; + + //--------------- local functions ------------------------------------------- + + function IsResizable(Column : TColumnIndex) : Boolean; + + begin + if BonusPixel then + Result := Widths[Column - RangeStartCol] < Constraints[Column - RangeStartCol] + else + Result := Widths[Column - RangeStartCol] > Constraints[Column - RangeStartCol]; + end; + +//--------------------------------------------------------------------------- + + procedure IncDelta(Column : TColumnIndex); + + begin + if BonusPixel then + Inc(MaxDelta, FColumns[Column].MaxWidth - Widths[Column - RangeStartCol]) + else + Inc(MaxDelta, Widths[Column - RangeStartCol] - Constraints[Column - RangeStartCol]); + end; + +//--------------------------------------------------------------------------- + + function ChangeWidth(Column : TColumnIndex; Delta : TDimension) : TDimension; + + begin + if Delta > 0 then + Delta := Min(Delta, Constraints[Column - RangeStartCol] - Widths[Column - RangeStartCol]) + else + Delta := Max(Delta, Constraints[Column - RangeStartCol] - Widths[Column - RangeStartCol]); + + Inc(Widths[Column - RangeStartCol], Delta); + Dec(ToGo, Abs(Delta)); + Result := Abs(Delta); + end; + +//--------------------------------------------------------------------------- + + function ReduceConstraints : Boolean; + + var + MaxWidth: TDimension; + MaxReserveCol, Column : TColumnIndex; + + begin + Result := True; + if not (hsScaling in FStates) or BonusPixel then + Exit; + + MaxWidth := 0; + MaxReserveCol := NoColumn; + for Column := RangeStartCol to RangeEndCol do + if (Options * FColumns[Column].Options = Options) and (FColumns[Column].Width > MaxWidth) then + begin + MaxWidth := Widths[Column - RangeStartCol]; + MaxReserveCol := Column; + end; + + if (MaxReserveCol <= NoColumn) or (Constraints[MaxReserveCol - RangeStartCol] <= 10) then + Result := False + else + Dec(Constraints[MaxReserveCol - RangeStartCol], Divide(Constraints[MaxReserveCol - RangeStartCol], 10)); + end; + +//----------- end local functions ------------------------------------------- + +begin + Result := 0; + if (ChangeBy <> 0) and (RangeEndCol >= 0) then // RangeEndCol == -1 means no columns, so nothing to do + begin + //Do some initialization here + BonusPixel := ChangeBy > 0; + Sign := IfThen(BonusPixel, 1, - 1); + Start := IfThen(BonusPixel, RangeStartCol, RangeEndCol); + ToGo := Abs(ChangeBy); + SetLength(Widths, RangeEndCol - RangeStartCol + 1); + SetLength(Constraints, RangeEndCol - RangeStartCol + 1); + for I := RangeStartCol to RangeEndCol do + begin + Widths[I - RangeStartCol] := FColumns[I].Width; + Constraints[I - RangeStartCol] := IfThen(BonusPixel, FColumns[I].MaxWidth, FColumns[I].MinWidth); + end; + + repeat + repeat + MaxDelta := 0; + ColCount := 0; + for I := RangeStartCol to RangeEndCol do + if (Options * FColumns[I].Options = Options) and IsResizable(I) then + begin + System.Inc(ColCount); + IncDelta(I); + end; + if MaxDelta < Abs(ChangeBy) then + if not ReduceConstraints then + Break; + until (MaxDelta >= Abs(ChangeBy)) or not (hsScaling in FStates); + + if ColCount = 0 then + Break; + + ToGo := Min(ToGo, MaxDelta); + Difference := ToGo div ColCount; + Rest := ToGo mod ColCount; + + if Difference > 0 then + for I := RangeStartCol to RangeEndCol do + if (Options * FColumns[I].Options = Options) and IsResizable(I) then + ChangeWidth(I, Difference * Sign); + + //Now distribute Rest. + I := Start; + while Rest > 0 do + begin + if (Options * FColumns[I].Options = Options) and IsResizable(I) then + if FColumns[I].BonusPixel <> BonusPixel then + begin + Dec(Rest, ChangeWidth(I, Sign)); + FColumns[I].BonusPixel := BonusPixel; + end; + System.Inc(I, Sign); + if (BonusPixel and (I > RangeEndCol)) or (not BonusPixel and (I < RangeStartCol)) then + begin + for I := RangeStartCol to RangeEndCol do + if Options * FColumns[I].Options = Options then + FColumns[I].BonusPixel := not FColumns[I].BonusPixel; + I := Start; + end; + end; + until ToGo <= 0; + + //Now set the computed widths. We also compute the result here. + Include(FStates, hsResizing); + for I := RangeStartCol to RangeEndCol do + if (Options * FColumns[I].Options = Options) then + begin + Inc(Result, Widths[I - RangeStartCol] - FColumns[I].Width); + TVirtualTreeColumnCracker(FColumns[I]).SetWidth(Widths[I - RangeStartCol]); + end; + Exclude(FStates, hsResizing); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.RestoreColumns; + +//Restores all columns to their width which they had before they have been auto fitted. + +var + I : TColumnIndex; + +begin + with TVirtualTreeColumnsCracker(FColumns) do + for I := Count - 1 downto 0 do + if [coResizable, coVisible] * Items[PositionToIndex[I]].Options = [coResizable, coVisible] then + Items[I].RestoreLastWidth; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.ToggleSortDirection; +// Toggles the current sorting direction +begin + if SortDirection = sdDescending then + SortDirection := sdAscending + else + SortDirection := sdDescending; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.SaveToStream(const Stream : TStream); + +//Saves the complete state of the header into the provided stream. + +var + Dummy : Integer; + DummyDimension: TDimension; + Tmp : AnsiString; + +begin + with Stream do + begin + //In previous version of VT was no header stream version defined. + //For feature enhancements it is necessary, however, to know which stream + //format we are trying to load. + //In order to distict from non-version streams an indicator is inserted. + Dummy := - 1; + WriteBuffer(Dummy, SizeOf(Dummy)); + //Write current stream version number, nothing more is required at the time being. + Dummy := VTHeaderStreamVersion; + WriteBuffer(Dummy, SizeOf(Dummy)); + + //Save columns in case they depend on certain options (like auto size). + Columns.SaveToStream(Stream); + + Dummy := FAutoSizeIndex; + WriteBuffer(Dummy, SizeOf(Dummy)); + Dummy := FBackgroundColor; + WriteBuffer(Dummy, SizeOf(Dummy)); + DummyDimension:= FHeight; + WriteBuffer(DummyDimension, SizeOf(DummyDimension)); + Dummy := Integer(FOptions); + WriteBuffer(Dummy, SizeOf(Dummy)); + //PopupMenu is neither saved nor restored + Dummy := Ord(FStyle); + WriteBuffer(Dummy, SizeOf(Dummy)); + //TFont has no own save routine so we do it manually + with Font do + begin + Dummy := Color; + WriteBuffer(Dummy, SizeOf(Dummy)); + + //Need only to write one: size or height, I decided to write height. + DummyDimension := Height; + WriteBuffer(DummyDimension, SizeOf(DummyDimension)); + Tmp := UTF8Encode(Name); + Dummy := Length(Tmp); + WriteBuffer(Dummy, SizeOf(Dummy)); + WriteBuffer(PAnsiChar(Tmp)^, Dummy); + Dummy := Ord(Pitch); + WriteBuffer(Dummy, SizeOf(Dummy)); + Dummy := Byte(Style); + WriteBuffer(Dummy, SizeOf(Dummy)); + end; + + //Data introduced by stream version 1. + Dummy := FMainColumn; + WriteBuffer(Dummy, SizeOf(Dummy)); + Dummy := FSortColumn; + WriteBuffer(Dummy, SizeOf(Dummy)); + Dummy := Byte(FSortDirection); + WriteBuffer(Dummy, SizeOf(Dummy)); + + //Data introduced by stream version 5. + Dummy := Integer(ParentFont); + WriteBuffer(Dummy, SizeOf(Dummy)); + DummyDimension := FMaxHeight; + WriteBuffer(DummyDimension, SizeOf(DummyDimension)); + DummyDimension := FMinHeight; + WriteBuffer(DummyDimension, SizeOf(DummyDimension)); + DummyDimension := FDefaultHeight; + WriteBuffer(DummyDimension, SizeOf(DummyDimension)); + + with FFixedAreaConstraints do + begin + Dummy := Integer(FMaxHeightPercent); + WriteBuffer(Dummy, SizeOf(Dummy)); + Dummy := Integer(FMaxWidthPercent); + WriteBuffer(Dummy, SizeOf(Dummy)); + Dummy := Integer(FMinHeightPercent); + WriteBuffer(Dummy, SizeOf(Dummy)); + Dummy := Integer(FMinWidthPercent); + WriteBuffer(Dummy, SizeOf(Dummy)); + end; + end; +end; + +{ TVTHeaderHelper } + +function TVTHeaderHelper.Tree : TBaseVirtualTreeCracker; +begin + Result := TBaseVirtualTreeCracker(Self.FOwner); +end; + + +//----------------- TVirtualTreeColumn --------------------------------------------------------------------------------- + +constructor TVirtualTreeColumn.Create(Collection : TCollection); + +begin + FMinWidth := 10; + FMaxWidth := 10000; + FImageIndex := - 1; + FMargin := 4; + FSpacing := cDefaultColumnSpacing; + FText := ''; + FOptions := DefaultColumnOptions; + FAlignment := taLeftJustify; + FBiDiMode := bdLeftToRight; + FColor := clWindow; + FLayout := blGlyphLeft; + FBonusPixel := False; + FCaptionAlignment := taLeftJustify; + FCheckType := ctCheckBox; + FCheckState := csUncheckedNormal; + FCheckBox := False; + FHasImage := False; + FDefaultSortDirection := sdAscending; + FEditNextColumn := - 1; + + inherited Create(Collection); + + if Assigned(Owner) then + begin + FWidth := Owner.DefaultWidth; + FLastWidth := Owner.DefaultWidth; + FPosition := Owner.Count - 1; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.SetCollection(Value : TCollection); +begin + inherited; + // Read parent bidi mode and color values as default values. + ParentBiDiModeChanged; + ParentColorChanged; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +destructor TVirtualTreeColumn.Destroy; + +var + I : Integer; + ai : TColumnIndex; + sc : TColumnIndex; + + //--------------- local function --------------------------------------------- + + procedure AdjustColumnIndex(var ColumnIndex : TColumnIndex); + + begin + if Index = ColumnIndex then + ColumnIndex := NoColumn + else + if Index < ColumnIndex then + System.Dec(ColumnIndex); + end; + + //--------------- end local function ----------------------------------------- + +begin + // Check if this column is somehow referenced by its collection parent or the header. + with Owner do + begin + // If the columns collection object is currently deleting all columns + // then we don't need to check the various cached indices individually. + if not FClearing then + begin + TreeViewControl.CancelEditNode; + IndexChanged(Index, - 1); + + AdjustColumnIndex(FHoverIndex); + AdjustColumnIndex(FDownIndex); + AdjustColumnIndex(FTrackIndex); + AdjustColumnIndex(FClickIndex); + + with Header do + begin + ai := AutoSizeIndex; + AdjustColumnIndex(ai); + InternalSetAutoSizeIndex(ai); + if Index = MainColumn then + begin + // If the current main column is about to be destroyed then we have to find a new main column. + InternalSetMainColumn(NoColumn); //SetColumn has side effects we want to avoid here. + for I := 0 to Count - 1 do + if I <> Index then + begin + InternalSetMainColumn(I); + Break; + end; + end; + sc := SortColumn; + AdjustColumnIndex(sc); + InternalSetSortColumn(sc); + end; + end; + end; + + inherited; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumn.GetCaptionAlignment : TAlignment; + +begin + if coUseCaptionAlignment in FOptions then + Result := FCaptionAlignment + else + Result := FAlignment; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumn.GetCaptionWidth : TDimension; +var + Theme : HTHEME; + AdvancedOwnerDraw : Boolean; + PaintInfo : THeaderPaintInfo; + RequestedElements : THeaderPaintElements; + + TextSize : TSize; + HeaderGlyphSize : TPoint; + UseText : Boolean; + R : TRect; +begin + AdvancedOwnerDraw := (hoOwnerDraw in Header.Options) and Assigned(TreeViewControl.OnAdvancedHeaderDraw) and Assigned(TreeViewControl.OnHeaderDrawQueryElements) and + not (csDesigning in TreeViewControl.ComponentState); + + PaintInfo.Column := Self; + PaintInfo.TargetCanvas := Owner.HeaderBitmap.Canvas; + PaintInfo.TargetCanvas.Font := Header.Font; + + with PaintInfo, Column do + begin + ShowHeaderGlyph := (hoShowImages in Header.Options) and ((Assigned(Header.Images) and (FImageIndex > - 1)) or FCheckBox); + ShowSortGlyph := ((Header.SortColumn > - 1) and (Self = Owner.Items[Header.SortColumn])) and (hoShowSortGlyphs in Header.Options); + + // This path for text columns or advanced owner draw. + // See if the application wants to draw part of the header itself. + RequestedElements := []; + if AdvancedOwnerDraw then + begin + PaintInfo.Column := Self; + TreeViewControl.DoHeaderDrawQueryElements(PaintInfo, RequestedElements); + end; + end; + + UseText := Length(FText) > 0; + // If nothing is to show then don't waste time with useless preparation. + if not (UseText or PaintInfo.ShowHeaderGlyph or PaintInfo.ShowSortGlyph) then + Exit(0); + + // Calculate sizes of the involved items. + with Header do + begin + if PaintInfo.ShowHeaderGlyph then + if not FCheckBox then + begin + if Assigned(Images) then + HeaderGlyphSize := Point(Images.Width, Images.Height); + end + else + with Self.TreeViewControl do + begin + if Assigned(CheckImages) then + HeaderGlyphSize := Point(CheckImages.Width, CheckImages.Height); + end + else + HeaderGlyphSize := Point(0, 0); + if PaintInfo.ShowSortGlyph then + begin + if tsUseExplorerTheme in Self.TreeViewControl.TreeStates then + begin + R := Rect(0, 0, 100, 100); + Theme := OpenThemeData(Self.TreeViewControl.Handle, 'HEADER'); + GetThemePartSize(Theme, PaintInfo.TargetCanvas.Handle, HP_HEADERSORTARROW, HSAS_SORTEDUP, @R, TS_TRUE, PaintInfo.SortGlyphSize); + CloseThemeData(Theme); + end + else + begin + PaintInfo.SortGlyphSize.cx := Self.TreeViewControl.ScaledPixels(16); + PaintInfo.SortGlyphSize.cy := Self.TreeViewControl.ScaledPixels(4); + end; + end + else + begin + PaintInfo.SortGlyphSize.cx := 0; + PaintInfo.SortGlyphSize.cy := 0; + end; + end; + + if UseText then + begin + GetTextExtentPoint32W(PaintInfo.TargetCanvas.Handle, PWideChar(FText), Length(FText), TextSize); + Inc(TextSize.cx, 2); + end + else + begin + TextSize.cx := 0; + TextSize.cy := 0; + end; + + // if CalculateTextRect then + Result := TextSize.cx; + if PaintInfo.ShowHeaderGlyph then + if Layout in [blGlyphLeft, blGlyphRight] then + Inc(Result, HeaderGlyphSize.X + FSpacing) + else // if Layout in [ blGlyphTop, blGlyphBottom] then + Result := Max(Result, HeaderGlyphSize.X); + if PaintInfo.ShowSortGlyph then + Inc(Result, PaintInfo.SortGlyphSize.cx + FSpacing + 2); // without this +2, there is a slight movement of the sort glyph when expanding the column + +end; +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumn.GetLeft : TDimension; + +begin + Result := FLeft; + if [coVisible, coFixed] * FOptions <> [coVisible, coFixed] then + Dec(Result, TreeViewControl.EffectiveOffsetX); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumn.IsBiDiModeStored : Boolean; + +begin + Result := not (coParentBidiMode in FOptions); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumn.IsCaptionAlignmentStored : Boolean; + +begin + Result := coUseCaptionAlignment in FOptions; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumn.IsColorStored : Boolean; + +begin + Result := not (coParentColor in FOptions); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.SetAlignment(const Value : TAlignment); + +begin + if FAlignment <> Value then + begin + FAlignment := Value; + Changed(False); + // Setting the alignment affects also the tree, hence invalidate it too. + TreeViewControl.Invalidate; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.SetBiDiMode(Value : TBiDiMode); + +begin + if Value <> FBiDiMode then + begin + FBiDiMode := Value; + Exclude(FOptions, coParentBidiMode); + Changed(False); + // Setting the alignment affects also the tree, hence invalidate it too. + TreeViewControl.Invalidate; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.SetCaptionAlignment(const Value : TAlignment); + +begin + if not (coUseCaptionAlignment in FOptions) or (FCaptionAlignment <> Value) then + begin + FCaptionAlignment := Value; + Include(FOptions, coUseCaptionAlignment); + // Setting the alignment affects also the tree, hence invalidate it too. + Header.Invalidate(Self); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.SetColor(const Value : TColor); + +begin + if FColor <> Value then + begin + FColor := Value; + Exclude(FOptions, coParentColor); + Exclude(FOptions, coStyleColor); // Issue #919 + Changed(False); + TreeViewControl.Invalidate; + end; +end; + +function TVirtualTreeColumn.GetEffectiveColor() : TColor; +// Returns the color that should effectively be used as background color for this +// column considering all flags in the TVirtualTreeColumn.Options property +begin + if (coParentColor in Options) or ((coStyleColor in Options) and TreeViewControl.VclStyleEnabled) then + Result := TreeViewControl.Colors.BackGroundColor + else + Result := Self.Color; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.SetCheckBox(Value : Boolean); + +begin + if Value <> FCheckBox then + begin + FCheckBox := Value; + if Value and (csDesigning in TreeViewControl.ComponentState) then + Header.Options := Header.Options + [hoShowImages]; + Changed(False); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.SetCheckState(Value : TCheckState); + +begin + if Value <> FCheckState then + begin + FCheckState := Value; + Changed(False); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.SetCheckType(Value : TCheckType); + +begin + if Value <> FCheckType then + begin + FCheckType := Value; + Changed(False); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.SetImageIndex(Value : TImageIndex); + +begin + if Value <> FImageIndex then + begin + FImageIndex := Value; + Changed(False); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.SetLayout(Value : TVTHeaderColumnLayout); + +begin + if FLayout <> Value then + begin + FLayout := Value; + Changed(False); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.SetMargin(Value : TDimension); + +begin + // Compatibility setting for -1. + if Value < 0 then + Value := 4; + if FMargin <> Value then + begin + FMargin := Value; + Changed(False); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.SetMaxWidth(Value : TDimension); + +begin + if Value < FMinWidth then + Value := FMinWidth; + FMaxWidth := Value; + SetWidth(FWidth); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.SetMinWidth(Value : TDimension); + +begin + if Value < 0 then + Value := 0; + if Value > FMaxWidth then + Value := FMaxWidth; + FMinWidth := Value; + SetWidth(FWidth); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.SetOptions(Value : TVTColumnOptions); + +var + ToBeSet, + ToBeCleared : TVTColumnOptions; + VisibleChanged, + lParentColorSet : Boolean; +begin + if FOptions <> Value then + begin + ToBeCleared := FOptions - Value; + ToBeSet := Value - FOptions; + + FOptions := Value; + if coFixed in ToBeSet then + FOptions := FOptions - [coDraggable]; // issue #1314 + + VisibleChanged := coVisible in (ToBeSet + ToBeCleared); + lParentColorSet := coParentColor in ToBeSet; + + if coParentBidiMode in ToBeSet then + ParentBiDiModeChanged; + if lParentColorSet then + begin + Include(FOptions, coStyleColor); // Issue #919 + ParentColorChanged(); + end; + + if coAutoSpring in ToBeSet then + FSpringRest := 0; + + if coVisible in ToBeCleared then + Header.UpdateMainColumn(); // Fixes issue #946 + + if ((coFixed in ToBeSet) or (coFixed in ToBeCleared)) and (coVisible in FOptions) then + Header.RescaleHeader; + + Changed(False); + // Need to repaint and adjust the owner tree too. + if not (csLoading in TreeViewControl.ComponentState) and (VisibleChanged or lParentColorSet) and (Owner.UpdateCount = 0) and TreeViewControl.HandleAllocated then + begin + TreeViewControl.Invalidate(); + if VisibleChanged then + begin + TreeViewControl.DoColumnVisibilityChanged(Self.Index, coVisible in ToBeSet); + TreeViewControl.UpdateHorizontalScrollBar(False); + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.SetPosition(Value : TColumnPosition); + +var + Temp : TColumnIndex; + +begin + if (csLoading in TreeViewControl.ComponentState) or (Owner.UpdateCount > 0) then + // Only cache the position for final fixup when loading from DFM. + FPosition := Value + else + begin + if Value >= TColumnPosition(Collection.Count) then + Value := Collection.Count - 1; + if FPosition <> Value then + begin + with Owner do + begin + InitializePositionArray; + TreeViewControl.CancelEditNode; + AdjustPosition(Self, Value); + Self.Changed(False); + + // Need to repaint. + with Self.Header do + begin + if (UpdateCount = 0) and TreeViewControl.HandleAllocated then + begin + Invalidate(Self); + TreeViewControl.Invalidate; + end; + end; + end; + + // If the moved column is now within the fixed columns then we make it fixed as well. If it's not + // we clear the fixed state (in case that fixed column is moved outside fixed area). + if (coFixed in FOptions) and (FPosition > 0) then + Temp := Owner.ColumnFromPosition(FPosition - 1) + else + Temp := Owner.ColumnFromPosition(FPosition + 1); + + if Temp <> NoColumn then + begin + if coFixed in Owner[Temp].Options then + Options := Options + [coFixed] + else + Options := Options - [coFixed]; + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.SetSpacing(Value : TDimension); + +begin + if FSpacing <> Value then + begin + FSpacing := Value; + Changed(False); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.SetStyle(Value : TVirtualTreeColumnStyle); + +begin + if FStyle <> Value then + begin + FStyle := Value; + Changed(False); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.SetText(const Value : string); + +begin + if FText <> Value then + begin + FText := Value; + FCaptionText := ''; + Changed(False); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.SetWidth(Value : TDimension); + +var + EffectiveMaxWidth, + EffectiveMinWidth, + TotalFixedMaxWidth, + TotalFixedMinWidth : TDimension; + I : TColumnIndex; + +begin + if not (hsScaling in Header.States) then + if ([coVisible, coFixed] * FOptions = [coVisible, coFixed]) then + begin + with Header, FixedAreaConstraints, TreeViewControl do + begin + TotalFixedMinWidth := 0; + TotalFixedMaxWidth := 0; + for I := 0 to Columns.Count - 1 do + if ([coVisible, coFixed] * Columns[I].Options = [coVisible, coFixed]) then + begin + Inc(TotalFixedMaxWidth, Columns[I].MaxWidth); + Inc(TotalFixedMinWidth, Columns[I].MinWidth); + end; + + if HandleAllocated then // Prevent premature creation of window handle, see issue #1073 + begin + // The percentage values have precedence over the pixel values. + If MaxWidthPercent > 0 then + TotalFixedMinWidth := Min(Divide(ClientWidth * MaxWidthPercent, 100), TotalFixedMinWidth); + If MinWidthPercent > 0 then + TotalFixedMaxWidth := Max(Divide(ClientWidth * MinWidthPercent, 100), TotalFixedMaxWidth); + + EffectiveMaxWidth := Min(TotalFixedMaxWidth - (Columns.GetVisibleFixedWidth - Self.FWidth), FMaxWidth); + EffectiveMinWidth := Max(TotalFixedMinWidth - (Columns.GetVisibleFixedWidth - Self.FWidth), FMinWidth); + Value := Min(Max(Value, EffectiveMinWidth), EffectiveMaxWidth); + + if MinWidthPercent > 0 then + Value := Max(Divide(ClientWidth * MinWidthPercent, 100) - Columns.GetVisibleFixedWidth + Self.FWidth, Value); + if MaxWidthPercent > 0 then + Value := Min(Divide(ClientWidth * MaxWidthPercent, 100) - Columns.GetVisibleFixedWidth + Self.FWidth, Value); + end;// if HandleAllocated + end; + end + else + Value := Min(Max(Value, FMinWidth), FMaxWidth); + + if FWidth <> Value then + begin + FLastWidth := FWidth; + if not (hsResizing in Header.States) then + FBonusPixel := False; + if not (hoAutoResize in Header.Options) or (Index <> Header.AutoSizeIndex) then + begin + FWidth := Value; + Owner.UpdatePositions; + end; + if not (csLoading in TreeViewControl.ComponentState) and (TreeViewControl.UpdateCount = 0) then + begin + if hoAutoResize in Header.Options then + Owner.AdjustAutoSize(Index); + TreeViewControl.DoColumnResize(Index); + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.ChangeScale(M, D : TDimension); +begin + FMinWidth := MulDiv(FMinWidth, M, D); + FMaxWidth := MulDiv(FMaxWidth, M, D); + FSpacing := MulDiv(FSpacing, M, D); + Self.Width := MulDiv(Self.Width, M, D); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.ComputeHeaderLayout(var PaintInfo : THeaderPaintInfo; DrawFormat : Cardinal; CalculateTextRect : Boolean = False); + +// The layout of a column header is determined by a lot of factors. This method takes them all into account and +// determines all necessary positions and bounds: +// - for the header text +// - the header glyph +// - the sort glyph + +var + TextSize : TSize; + TextPos, + ClientSize, + HeaderGlyphSize : TPoint; + CurrentAlignment : TAlignment; + MinLeft, + MaxRight, + TextSpacing : TDimension; + UseText : Boolean; + R : TRect; + Theme : HTHEME; + +begin + UseText := Length(FText) > 0; + // If nothing is to show then don't waste time with useless preparation. + if not (UseText or PaintInfo.ShowHeaderGlyph or PaintInfo.ShowSortGlyph) then + Exit; + + CurrentAlignment := CaptionAlignment; + if FBiDiMode <> bdLeftToRight then + ChangeBiDiModeAlignment(CurrentAlignment); + + // Calculate sizes of the involved items. + ClientSize := Point(PaintInfo.PaintRectangle.Right - PaintInfo.PaintRectangle.Left, PaintInfo.PaintRectangle.Bottom - PaintInfo.PaintRectangle.Top); + with Owner, Header do + begin + if PaintInfo.ShowHeaderGlyph then + if not FCheckBox then + HeaderGlyphSize := Point(Images.Width, Images.Height) + else + with Self.TreeViewControl do + begin + if Assigned(CheckImages) then + HeaderGlyphSize := Point(CheckImages.Width, CheckImages.Height); + end + else + HeaderGlyphSize := Point(0, 0); + if PaintInfo.ShowSortGlyph then + begin + if tsUseExplorerTheme in Self.TreeViewControl.TreeStates then + begin + R := Rect(0, 0, 100, 100); + Theme := OpenThemeData(TreeViewControl.Handle, 'HEADER'); + GetThemePartSize(Theme, PaintInfo.TargetCanvas.Handle, HP_HEADERSORTARROW, HSAS_SORTEDUP, @R, TS_TRUE, PaintInfo.SortGlyphSize); + CloseThemeData(Theme); + end + else + begin + PaintInfo.SortGlyphSize.cx := Self.TreeViewControl.ScaledPixels(16); + PaintInfo.SortGlyphSize.cy := Self.TreeViewControl.ScaledPixels(4); + end; + + // In any case, the sort glyph is vertically centered. + PaintInfo.SortGlyphPos.Y := Divide(ClientSize.Y - PaintInfo.SortGlyphSize.cy, 2); + end + else + begin + PaintInfo.SortGlyphSize.cx := 0; + PaintInfo.SortGlyphSize.cy := 0; + end; + end; + + if UseText then + begin + if not (coWrapCaption in FOptions) then + begin + FCaptionText := FText; + GetTextExtentPoint32W(PaintInfo.TargetCanvas.Handle, PWideChar(FText), Length(FText), TextSize); + Inc(TextSize.cx, 2); + PaintInfo.TextRectangle := Rect(0, 0, TextSize.cx, TextSize.cy); + end + else + begin + R := PaintInfo.PaintRectangle; + if FCaptionText = '' then + FCaptionText := WrapString(PaintInfo.TargetCanvas.Handle, FText, R, DT_RTLREADING and DrawFormat <> 0, DrawFormat); + + GetStringDrawRect(PaintInfo.TargetCanvas.Handle, FCaptionText, R, DrawFormat); + TextSize.cx := PaintInfo.PaintRectangle.Right - PaintInfo.PaintRectangle.Left; + TextSize.cy := R.Bottom - R.Top; + PaintInfo.TextRectangle := Rect(0, 0, TextSize.cx, TextSize.cy); + end; + TextSpacing := FSpacing; + end + else + begin + TextSpacing := 0; + TextSize.cx := 0; + TextSize.cy := 0; + end; + + // Check first for the special case where nothing is shown except the sort glyph. + if PaintInfo.ShowSortGlyph and not (UseText or PaintInfo.ShowHeaderGlyph) then + begin + // Center the sort glyph in the available area if nothing else is there. + PaintInfo.SortGlyphPos := Point(Divide(ClientSize.X - PaintInfo.SortGlyphSize.cx, 2), Divide(ClientSize.Y - PaintInfo.SortGlyphSize.cy, 2)); + end + else + begin + // Determine extents of text and glyph and calculate positions which are clear from the layout. + if (Layout in [blGlyphLeft, blGlyphRight]) or not PaintInfo.ShowHeaderGlyph then + begin + PaintInfo.GlyphPos.Y := Divide(ClientSize.Y - HeaderGlyphSize.Y, 2); + // If the text is taller than the given height, perform no vertical centration as this + // would make the text even less readable. + //Using Max() fixes badly positioned text if Extra Large fonts have been activated in the Windows display options + TextPos.Y := Max( - 5, Divide(ClientSize.Y - TextSize.cy, 2)); + end + else + begin + if Layout = blGlyphTop then + begin + PaintInfo.GlyphPos.Y := Divide(ClientSize.Y - HeaderGlyphSize.Y - TextSize.cy - TextSpacing, 2); + TextPos.Y := PaintInfo.GlyphPos.Y + HeaderGlyphSize.Y + TextSpacing; + end + else + begin + TextPos.Y := Divide(ClientSize.Y - HeaderGlyphSize.Y - TextSize.cy - TextSpacing, 2); + PaintInfo.GlyphPos.Y := TextPos.Y + TextSize.cy + TextSpacing; + end; + end; + + // Each alignment needs special consideration. + case CurrentAlignment of + taLeftJustify : + begin + MinLeft := FMargin; + if PaintInfo.ShowSortGlyph and (FBiDiMode <> bdLeftToRight) then + begin + // In RTL context is the sort glyph placed on the left hand side. + PaintInfo.SortGlyphPos.X := MinLeft; + Inc(MinLeft, PaintInfo.SortGlyphSize.cx + FSpacing); + end; + if Layout in [blGlyphTop, blGlyphBottom] then + begin + // Header glyph is above or below text, so both must be considered when calculating + // the left positition of the sort glyph (if it is on the right hand side). + TextPos.X := MinLeft; + if PaintInfo.ShowHeaderGlyph then + begin + PaintInfo.GlyphPos.X := Divide(ClientSize.X - HeaderGlyphSize.X, 2); + if PaintInfo.GlyphPos.X < MinLeft then + PaintInfo.GlyphPos.X := MinLeft; + MinLeft := Max(TextPos.X + TextSize.cx + TextSpacing, PaintInfo.GlyphPos.X + HeaderGlyphSize.X + FSpacing); + end + else + MinLeft := TextPos.X + TextSize.cx + TextSpacing; + end + else + begin + // Everything is lined up. TextSpacing might be 0 if there is no text. + // This simplifies the calculation because no extra tests are necessary. + if PaintInfo.ShowHeaderGlyph and (Layout = blGlyphLeft) then + begin + PaintInfo.GlyphPos.X := MinLeft; + Inc(MinLeft, HeaderGlyphSize.X + FSpacing); + end; + TextPos.X := MinLeft; + Inc(MinLeft, TextSize.cx + TextSpacing); + if PaintInfo.ShowHeaderGlyph and (Layout = blGlyphRight) then + begin + PaintInfo.GlyphPos.X := MinLeft; + Inc(MinLeft, HeaderGlyphSize.X + FSpacing); + end; + end; + if PaintInfo.ShowSortGlyph and (FBiDiMode = bdLeftToRight) then + PaintInfo.SortGlyphPos.X := MinLeft; + end; + taCenter : + begin + if Layout in [blGlyphTop, blGlyphBottom] then + begin + PaintInfo.GlyphPos.X := Divide(ClientSize.X - HeaderGlyphSize.X, 2); + TextPos.X := Divide(ClientSize.X - TextSize.cx, 2); + if PaintInfo.ShowSortGlyph then + Dec(TextPos.X, Divide(PaintInfo.SortGlyphSize.cx, 2)); + end + else + begin + MinLeft := Divide(ClientSize.X - HeaderGlyphSize.X - TextSpacing - TextSize.cx, 2); + if PaintInfo.ShowHeaderGlyph and (Layout = blGlyphLeft) then + begin + PaintInfo.GlyphPos.X := MinLeft; + Inc(MinLeft, HeaderGlyphSize.X + TextSpacing); + end; + TextPos.X := MinLeft; + Inc(MinLeft, TextSize.cx + TextSpacing); + if PaintInfo.ShowHeaderGlyph and (Layout = blGlyphRight) then + PaintInfo.GlyphPos.X := MinLeft; + end; + if PaintInfo.ShowHeaderGlyph then + begin + MinLeft := Min(PaintInfo.GlyphPos.X, TextPos.X); + MaxRight := Max(PaintInfo.GlyphPos.X + HeaderGlyphSize.X, TextPos.X + TextSize.cx); + end + else + begin + MinLeft := TextPos.X; + MaxRight := TextPos.X + TextSize.cx; + end; + // Place the sort glyph directly to the left or right of the larger item. + if PaintInfo.ShowSortGlyph then + if FBiDiMode = bdLeftToRight then + begin + // Sort glyph on the right hand side. + PaintInfo.SortGlyphPos.X := MaxRight + FSpacing; + end + else + begin + // Sort glyph on the left hand side. + PaintInfo.SortGlyphPos.X := MinLeft - FSpacing - PaintInfo.SortGlyphSize.cx; + end; + end; + else + // taRightJustify + MaxRight := ClientSize.X - FMargin; + if PaintInfo.ShowSortGlyph and (FBiDiMode = bdLeftToRight) then + begin + // In LTR context is the sort glyph placed on the right hand side. + Dec(MaxRight, PaintInfo.SortGlyphSize.cx); + PaintInfo.SortGlyphPos.X := MaxRight; + Dec(MaxRight, FSpacing); + end; + if Layout in [blGlyphTop, blGlyphBottom] then + begin + TextPos.X := MaxRight - TextSize.cx; + if PaintInfo.ShowHeaderGlyph then + begin + PaintInfo.GlyphPos.X := Divide(ClientSize.X - HeaderGlyphSize.X, 2); + if PaintInfo.GlyphPos.X + HeaderGlyphSize.X + FSpacing > MaxRight then + PaintInfo.GlyphPos.X := MaxRight - HeaderGlyphSize.X - FSpacing; + MaxRight := Min(TextPos.X - TextSpacing, PaintInfo.GlyphPos.X - FSpacing); + end + else + MaxRight := TextPos.X - TextSpacing; + end + else + begin + // Everything is lined up. TextSpacing might be 0 if there is no text. + // This simplifies the calculation because no extra tests are necessary. + if PaintInfo.ShowHeaderGlyph and (Layout = blGlyphRight) then + begin + PaintInfo.GlyphPos.X := MaxRight - HeaderGlyphSize.X; + MaxRight := PaintInfo.GlyphPos.X - FSpacing; + end; + TextPos.X := MaxRight - TextSize.cx; + MaxRight := TextPos.X - TextSpacing; + if PaintInfo.ShowHeaderGlyph and (Layout = blGlyphLeft) then + begin + PaintInfo.GlyphPos.X := MaxRight - HeaderGlyphSize.X; + MaxRight := PaintInfo.GlyphPos.X - FSpacing; + end; + end; + if PaintInfo.ShowSortGlyph and (FBiDiMode <> bdLeftToRight) then + PaintInfo.SortGlyphPos.X := MaxRight - PaintInfo.SortGlyphSize.cx; + end; + end; + + // Once the position of each element is determined there remains only one but important step. + // The horizontal positions of every element must be adjusted so that it always fits into the + // given header area. This is accomplished by shorten the text appropriately. + + // These are the maximum bounds. Nothing goes beyond them. + MinLeft := FMargin; + MaxRight := ClientSize.X - FMargin; + if PaintInfo.ShowSortGlyph then + begin + if FBiDiMode = bdLeftToRight then + begin + // Sort glyph on the right hand side. + if PaintInfo.SortGlyphPos.X + PaintInfo.SortGlyphSize.cx > MaxRight then + PaintInfo.SortGlyphPos.X := MaxRight - PaintInfo.SortGlyphSize.cx; + MaxRight := PaintInfo.SortGlyphPos.X - FSpacing; + end; + + // Consider also the left side of the sort glyph regardless of the bidi mode. + if PaintInfo.SortGlyphPos.X < MinLeft then + PaintInfo.SortGlyphPos.X := MinLeft; + // Left border needs only adjustment if the sort glyph marks the left border. + if FBiDiMode <> bdLeftToRight then + MinLeft := PaintInfo.SortGlyphPos.X + PaintInfo.SortGlyphSize.cx + FSpacing; + + // Finally transform sort glyph to its actual position. + Inc(PaintInfo.SortGlyphPos.X, PaintInfo.PaintRectangle.Left); + Inc(PaintInfo.SortGlyphPos.Y, PaintInfo.PaintRectangle.Top); + end; + if PaintInfo.ShowHeaderGlyph then + begin + if PaintInfo.GlyphPos.X + HeaderGlyphSize.X > MaxRight then + PaintInfo.GlyphPos.X := MaxRight - HeaderGlyphSize.X; + if Layout = blGlyphRight then + MaxRight := PaintInfo.GlyphPos.X - FSpacing; + if PaintInfo.GlyphPos.X < MinLeft then + PaintInfo.GlyphPos.X := MinLeft; + if Layout = blGlyphLeft then + MinLeft := PaintInfo.GlyphPos.X + HeaderGlyphSize.X + FSpacing; + if FCheckBox and (Header.MainColumn = Self.Index) then + Dec(PaintInfo.GlyphPos.X, 2) + else + if Header.MainColumn <> Self.Index then + Dec(PaintInfo.GlyphPos.X, 2); + + // Finally transform header glyph to its actual position. + Inc(PaintInfo.GlyphPos.X, PaintInfo.PaintRectangle.Left); + Inc(PaintInfo.GlyphPos.Y, PaintInfo.PaintRectangle.Top); + end; + if UseText then + begin + if TextPos.X < MinLeft then + TextPos.X := MinLeft; + OffsetRect(PaintInfo.TextRectangle, TextPos.X, TextPos.Y); + if PaintInfo.TextRectangle.Right > MaxRight then + PaintInfo.TextRectangle.Right := MaxRight; + OffsetRect(PaintInfo.TextRectangle, PaintInfo.PaintRectangle.Left, PaintInfo.PaintRectangle.Top); + + if coWrapCaption in FOptions then + begin + // Wrap the column caption if necessary. + R := PaintInfo.TextRectangle; + FCaptionText := WrapString(PaintInfo.TargetCanvas.Handle, FText, R, DT_RTLREADING and DrawFormat <> 0, DrawFormat); + GetStringDrawRect(PaintInfo.TargetCanvas.Handle, FCaptionText, R, DrawFormat); + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.DefineProperties(Filer : TFiler); + +begin + inherited; + + // These properites are remains from non-Unicode Delphi versions, readers remain for backward compatibility. + Filer.DefineProperty('WideText', ReadText, nil, False); + Filer.DefineProperty('WideHint', ReadHint, nil, False); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.GetAbsoluteBounds(var Left, Right : TDimension); + +// Returns the column's left and right bounds in header coordinates, that is, independant of the scrolling position. + +begin + Left := FLeft; + Right := FLeft + FWidth; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumn.GetDisplayName : string; +begin + Result := FText; // Use column header caption as display name +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumn.GetOwner : TVirtualTreeColumns; + +begin + Result := Collection as TVirtualTreeColumns; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.InternalSetWidth(const Value : TDimension); +begin + FWidth := Value; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.ReadText(Reader : TReader); + +begin + SetText(Reader.ReadString); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.ReadHint(Reader : TReader); + +begin + FHint := Reader.ReadString; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.Assign(Source : TPersistent); + +var + OldOptions : TVTColumnOptions; + +begin + if Source is TVirtualTreeColumn then + begin + OldOptions := FOptions; + FOptions := []; + + BiDiMode := TVirtualTreeColumn(Source).BiDiMode; + ImageIndex := TVirtualTreeColumn(Source).ImageIndex; + Layout := TVirtualTreeColumn(Source).Layout; + Margin := TVirtualTreeColumn(Source).Margin; + MaxWidth := TVirtualTreeColumn(Source).MaxWidth; + MinWidth := TVirtualTreeColumn(Source).MinWidth; + Position := TVirtualTreeColumn(Source).Position; + Spacing := TVirtualTreeColumn(Source).Spacing; + Style := TVirtualTreeColumn(Source).Style; + Text := TVirtualTreeColumn(Source).Text; + Hint := TVirtualTreeColumn(Source).Hint; + Width := TVirtualTreeColumn(Source).Width; + Alignment := TVirtualTreeColumn(Source).Alignment; + CaptionAlignment := TVirtualTreeColumn(Source).CaptionAlignment; + Color := TVirtualTreeColumn(Source).Color; + Tag := TVirtualTreeColumn(Source).Tag; + EditOptions := TVirtualTreeColumn(Source).EditOptions; + EditNextColumn := TVirtualTreeColumn(Source).EditNextColumn; + + // Order is important. Assign options last. + FOptions := OldOptions; + Options := TVirtualTreeColumn(Source).Options; + + Changed(False); + end + else + inherited Assign(Source); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumn.Equals(OtherColumnObj : TObject) : Boolean; +var + OtherColumn : TVirtualTreeColumn; +begin + if OtherColumnObj is TVirtualTreeColumn then + begin + OtherColumn := TVirtualTreeColumn(OtherColumnObj); + Result := (BiDiMode = OtherColumn.BiDiMode) and + (ImageIndex = OtherColumn.ImageIndex) and + (Layout = OtherColumn.Layout) and + (Margin = OtherColumn.Margin) and + (MaxWidth = OtherColumn.MaxWidth) and + (MinWidth = OtherColumn.MinWidth) and + (Position = OtherColumn.Position) and + (Spacing = OtherColumn.Spacing) and + (Style = OtherColumn.Style) and + (Text = OtherColumn.Text) and + (Hint = OtherColumn.Hint) and + (Width = OtherColumn.Width) and + (Alignment = OtherColumn.Alignment) and + (CaptionAlignment = OtherColumn.CaptionAlignment) and + (Color = OtherColumn.Color) and + (Tag = OtherColumn.Tag) and + (Options = OtherColumn.Options); + end + else + Result := False; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumn.GetRect : TRect; + +// Returns the rectangle this column occupies in the header (relative to (0, 0) of the non-client area). + +begin + with TVirtualTreeColumns(GetOwner).FHeader do + Result := TreeViewControl.HeaderRect; + Inc(Result.Left, FLeft); + Result.Right := Result.Left + FWidth; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +// [IPK] +function TVirtualTreeColumn.GetText : string; + +begin + Result := FText; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.LoadFromStream(const Stream : TStream; Version : Integer); +var + Dummy : Integer; + S : string; + +begin + with Stream do + begin + ReadBuffer(Dummy, SizeOf(Dummy)); + SetLength(S, Dummy); + ReadBuffer(PWideChar(S)^, 2 * Dummy); + Text := S; + ReadBuffer(Dummy, SizeOf(Dummy)); + SetLength(FHint, Dummy); + ReadBuffer(PWideChar(FHint)^, 2 * Dummy); + ReadBuffer(Dummy, SizeOf(Dummy)); + Width := Dummy; + ReadBuffer(Dummy, SizeOf(Dummy)); + MinWidth := Dummy; + ReadBuffer(Dummy, SizeOf(Dummy)); + MaxWidth := Dummy; + ReadBuffer(Dummy, SizeOf(Dummy)); + Style := TVirtualTreeColumnStyle(Dummy); + ReadBuffer(Dummy, SizeOf(Dummy)); + ImageIndex := Dummy; + ReadBuffer(Dummy, SizeOf(Dummy)); + Layout := TVTHeaderColumnLayout(Dummy); + ReadBuffer(Dummy, SizeOf(Dummy)); + Margin := Dummy; + ReadBuffer(Dummy, SizeOf(Dummy)); + Spacing := Dummy; + ReadBuffer(Dummy, SizeOf(Dummy)); + BiDiMode := TBiDiMode(Dummy); + + ReadBuffer(Dummy, SizeOf(Dummy)); + if Version >= 3 then + Options := TVTColumnOptions(Dummy); + + if Version > 0 then + begin + // Parts which have been introduced/changed with header stream version 1+. + ReadBuffer(Dummy, SizeOf(Dummy)); + Tag := Dummy; + ReadBuffer(Dummy, SizeOf(Dummy)); + Alignment := TAlignment(Dummy); + + if Version > 1 then + begin + ReadBuffer(Dummy, SizeOf(Dummy)); + Color := TColor(Dummy); + end; + + if Version > 5 then + begin + if coUseCaptionAlignment in FOptions then + begin + ReadBuffer(Dummy, SizeOf(Dummy)); + CaptionAlignment := TAlignment(Dummy); + end; + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.ParentBiDiModeChanged; + +var + Columns : TVirtualTreeColumns; + +begin + if coParentBidiMode in FOptions then + begin + Columns := GetOwner as TVirtualTreeColumns; + if Assigned(Columns) and (FBiDiMode <> TreeViewControl.BiDiMode) then + begin + FBiDiMode := TreeViewControl.BiDiMode; + Changed(False); + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.ParentColorChanged; + +var + Columns : TVirtualTreeColumns; + +begin + if coParentColor in FOptions then + begin + Columns := GetOwner as TVirtualTreeColumns; + if Assigned(Columns) and (FColor <> TreeViewControl.Color) then + begin + FColor := TreeViewControl.Color; + Changed(False); + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.RestoreLastWidth; + +begin + TVirtualTreeColumns(GetOwner).AnimatedResize(Index, FLastWidth); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.SaveToStream(const Stream : TStream); + +var + Dummy : Integer; + +begin + with Stream do + begin + Dummy := Length(FText); + WriteBuffer(Dummy, SizeOf(Dummy)); + WriteBuffer(PWideChar(FText)^, 2 * Dummy); + Dummy := Length(FHint); + WriteBuffer(Dummy, SizeOf(Dummy)); + WriteBuffer(PWideChar(FHint)^, 2 * Dummy); + WriteBuffer(FWidth, SizeOf(FWidth)); + WriteBuffer(FMinWidth, SizeOf(FMinWidth)); + WriteBuffer(FMaxWidth, SizeOf(FMaxWidth)); + Dummy := Ord(FStyle); + WriteBuffer(Dummy, SizeOf(Dummy)); + Dummy := FImageIndex; + WriteBuffer(Dummy, SizeOf(Dummy)); + Dummy := Ord(FLayout); + WriteBuffer(Dummy, SizeOf(Dummy)); + WriteBuffer(FMargin, SizeOf(FMargin)); + WriteBuffer(FSpacing, SizeOf(FSpacing)); + Dummy := Ord(FBiDiMode); + WriteBuffer(Dummy, SizeOf(Dummy)); + Dummy := Integer(FOptions); + WriteBuffer(Dummy, SizeOf(Dummy)); + + // parts introduced with stream version 1 + WriteBuffer(FTag, SizeOf(Dummy)); + Dummy := Cardinal(FAlignment); + WriteBuffer(Dummy, SizeOf(Dummy)); + + // parts introduced with stream version 2 + Dummy := Integer(FColor); + WriteBuffer(Dummy, SizeOf(Dummy)); + + // parts introduced with stream version 6 + if coUseCaptionAlignment in FOptions then + begin + Dummy := Cardinal(FCaptionAlignment); + WriteBuffer(Dummy, SizeOf(Dummy)); + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumn.UseRightToLeftReading : Boolean; + +begin + Result := FBiDiMode <> bdLeftToRight; +end; + +//----------------- TVirtualTreeColumns -------------------------------------------------------------------------------- + +constructor TVirtualTreeColumns.Create(AOwner : TVTHeader); + +var + ColumnClass : TVirtualTreeColumnClass; + +begin + FHeader := AOwner; + + // Determine column class to be used in the header. + ColumnClass := Self.TreeViewControl.GetColumnClass; + // The owner tree always returns the default tree column class if not changed by application/descendants. + inherited Create(ColumnClass); + + FHeaderBitmap := TBitmap.Create; + FHeaderBitmap.PixelFormat := pf32Bit; + + FHoverIndex := NoColumn; + FDownIndex := NoColumn; + FClickIndex := NoColumn; + FDropTarget := NoColumn; + FTrackIndex := NoColumn; + FDefaultWidth := 50; + Self.FColumnPopupMenu := nil; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +destructor TVirtualTreeColumns.Destroy; + +begin + FreeAndNil(FColumnPopupMenu); + FreeAndNil(FHeaderBitmap); + inherited; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumns.GetCount : Integer; + +begin + Result := inherited Count; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumns.GetItem(Index : TColumnIndex) : TVirtualTreeColumn; + +begin + Result := TVirtualTreeColumn(inherited GetItem(Index)); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumns.GetNewIndex(P : TPoint; var OldIndex : TColumnIndex) : Boolean; + +var + NewIndex : Integer; + +begin + Result := False; + // convert to local coordinates + Inc(P.Y, Header.Height); + NewIndex := ColumnFromPosition(P); + if NewIndex <> OldIndex then + begin + if OldIndex > NoColumn then + Header.Invalidate(Items[OldIndex], False, True); + OldIndex := NewIndex; + if OldIndex > NoColumn then + Header.Invalidate(Items[OldIndex], False, True); + Result := True; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumns.SetDefaultWidth(Value : TDimension); + +begin + FDefaultWidth := Value; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumns.SetItem(Index : TColumnIndex; Value : TVirtualTreeColumn); + +begin + inherited SetItem(Index, Value); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumns.StyleServices(AControl : TControl) : TCustomStyleServices; +begin + if AControl = nil then + AControl := TreeView; + Result := VTStyleServices(AControl); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumns.AdjustAutoSize(CurrentIndex : TColumnIndex; Force : Boolean = False); + +// Called only if the header is in auto-size mode which means a column needs to be so large +// that it fills all the horizontal space not occupied by the other columns. +// CurrentIndex (if not InvalidColumn) describes which column has just been resized. + +var + AutoIndex, + Index: Integer; + NewValue, RestWidth : TDimension; + WasUpdating : Boolean; +begin + if Count > 0 then + begin + // Determine index to be used for auto resizing. This is usually given by the owner's AutoSizeIndex, but + // could be different if the column whose resize caused the invokation here is either the auto column itself + // or visually to the right of the auto size column. + AutoIndex := Header.AutoSizeIndex; + if (AutoIndex < 0) or (AutoIndex >= Count) then + AutoIndex := Count - 1; + + if AutoIndex >= 0 then + begin + with TreeViewControl do + begin + if HandleAllocated then + RestWidth := ClientWidth + else + RestWidth := Width; + end; + + // Go through all columns and calculate the rest space remaining. + for Index := 0 to Count - 1 do + if (Index <> AutoIndex) and (coVisible in Items[Index].Options) then + Dec(RestWidth, Items[Index].Width); + + with Items[AutoIndex] do + begin + NewValue := Max(MinWidth, Min(MaxWidth, RestWidth)); + if Force or (FWidth <> NewValue) then + begin + FWidth := NewValue; + UpdatePositions; + WasUpdating := csUpdating in TreeViewControl.ComponentState; + if not WasUpdating then + TreeViewControl.Updating(); // Fixes #398 + try + TreeViewControl.DoColumnResize(AutoIndex); + finally + if not WasUpdating then + TreeViewControl.Updated(); + end; + end; + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumns.AdjustDownColumn(P : TPoint) : TColumnIndex; + +// Determines the column from the given position and returns it. If this column is allowed to be clicked then +// it is also kept for later use. + +begin + // Convert to local coordinates. + Inc(P.Y, Header.Height); + Result := ColumnFromPosition(P); + if (Result > NoColumn) and (Result <> FDownIndex) and (coAllowClick in Items[Result].Options) and + (coEnabled in Items[Result].Options) then + begin + if FDownIndex > NoColumn then + Header.Invalidate(Items[FDownIndex]); + FDownIndex := Result; + FCheckBoxHit := Items[Result].HasImage and PtInRect(Items[Result].ImageRect, P) and Items[Result].CheckBox; + Header.Invalidate(Items[FDownIndex]); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumns.AdjustHoverColumn(P : TPoint) : Boolean; + +// Determines the new hover column index and returns True if the index actually changed else False. + +begin + Result := GetNewIndex(P, FHoverIndex); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumns.AdjustPosition(Column : TVirtualTreeColumn; Position : Cardinal); + +// Reorders the column position array so that the given column gets the given position. + +var + OldPosition : Cardinal; + +begin + OldPosition := Column.Position; + if OldPosition <> Position then + begin + if OldPosition < Position then + begin + // column will be moved up so move down other entries + Move(FPositionToIndex[OldPosition + 1], FPositionToIndex[OldPosition], (Position - OldPosition) * SizeOf(Cardinal)); + end + else + begin + // column will be moved down so move up other entries + Move(FPositionToIndex[Position], FPositionToIndex[Position + 1], (OldPosition - Position) * SizeOf(Cardinal)); + end; + FPositionToIndex[Position] := Column.Index; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumns.CanSplitterResize(P : TPoint; Column : TColumnIndex) : Boolean; + +begin + Result := (Column > NoColumn) and ([coResizable, coVisible] * Items[Column].Options = [coResizable, coVisible]); + DoCanSplitterResize(P, Column, Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumns.DoCanSplitterResize(P : TPoint; Column : TColumnIndex; var Allowed : Boolean); + +begin + if Assigned(TreeViewControl.OnCanSplitterResizeColumn) then + TreeViewControl.OnCanSplitterResizeColumn(Header, P, Column, Allowed); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumns.DrawButtonText(DC : HDC; Caption : string; Bounds : TRect; Enabled, Hot : Boolean; + DrawFormat : Cardinal; WrapCaption : Boolean); + +var + TextSpace : TDimension; + Size : TSize; + +begin + if not WrapCaption then + begin + // Do we need to shorten the caption due to limited space? + GetTextExtentPoint32W(DC, PWideChar(Caption), Length(Caption), Size); + TextSpace := Bounds.Right - Bounds.Left; + if TextSpace < Size.cx then + Caption := ShortenString(DC, Caption, TextSpace); + end; + + SetBkMode(DC, TRANSPARENT); + if not Enabled then + if TreeViewControl.VclStyleEnabled then + begin + SetTextColor(DC, ColorToRGB(TreeViewControl.Colors.HeaderFontColor)); + WinApi.Windows.DrawTextW(DC, PWideChar(Caption), Length(Caption), Bounds, DrawFormat); + end + else + begin + OffsetRect(Bounds, 1, 1); + SetTextColor(DC, ColorToRGB(clBtnHighlight)); + WinApi.Windows.DrawTextW(DC, PWideChar(Caption), Length(Caption), Bounds, DrawFormat); + OffsetRect(Bounds, - 1, - 1); + SetTextColor(DC, ColorToRGB(clBtnShadow)); + WinApi.Windows.DrawTextW(DC, PWideChar(Caption), Length(Caption), Bounds, DrawFormat); + end + else + begin + if Hot then + SetTextColor(DC, ColorToRGB(TreeViewControl.Colors.HeaderHotColor)) + else + SetTextColor(DC, ColorToRGB(TreeViewControl.Colors.HeaderFontColor)); + WinApi.Windows.DrawTextW(DC, PWideChar(Caption), Length(Caption), Bounds, DrawFormat); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumns.FixPositions; +// Fixes column positions after loading from DFM or Bidi mode change. +var + LColumnsByPos: TList; + I: Integer; +begin + LColumnsByPos := TList.Create; + try + LColumnsByPos.Capacity := Self.Count; + for I := 0 to Self.Count-1 do + LColumnsByPos.Add(Items[I]); + + LColumnsByPos.Sort( + TComparer.Construct( + function(const A, B: TVirtualTreeColumn): Integer + begin + Result := CompareValue(A.Position, B.Position); + if Result = 0 then + Result := CompareValue(A.Index, B.Index); + end) + ); + + for I := 0 to LColumnsByPos.Count-1 do + begin + LColumnsByPos[I].FPosition := I; + Self.FPositionToIndex[I] := LColumnsByPos[I].Index; + end; + + finally + LColumnsByPos.Free; + end; + + FNeedPositionsFix := False; + UpdatePositions(True); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumns.GetColumnAndBounds(P : TPoint; var ColumnLeft, ColumnRight : TDimension; + Relative : Boolean = True) : Integer; + +// Returns the column where the mouse is currently in as well as the left and right bound of +// this column (Left and Right are undetermined if no column is involved). + +var + I : Integer; + +begin + Result := InvalidColumn; + if Relative and (P.X >= Header.Columns.GetVisibleFixedWidth) then + ColumnLeft := - TreeViewControl.EffectiveOffsetX + else + ColumnLeft := 0; + + if TreeViewControl.UseRightToLeftAlignment then + Inc(ColumnLeft, TreeViewControl.ComputeRTLOffset(True)); + + for I := 0 to Count - 1 do + with Items[FPositionToIndex[I]] do + if coVisible in FOptions then + begin + ColumnRight := ColumnLeft + FWidth; + + //fix: in right to left alignment, X can be in the + //area on the left of first column which is OUT. + if (P.X < ColumnLeft) and (I = 0) then + begin + Result := InvalidColumn; + Exit; + end; + if P.X < ColumnRight then + begin + Result := FPositionToIndex[I]; + Exit; + end; + ColumnLeft := ColumnRight; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumns.GetOwner : TPersistent; + +begin + Result := FHeader; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumns.HandleClick(P : TPoint; Button : TMouseButton; Force, DblClick : Boolean) : Boolean; + +// Generates a click event if the mouse button has been released over the same column it was pressed first. +// Alternatively, Force might be set to True to indicate that the down index does not matter (right, middle and +// double click). +// Returns true if the click was handled, False otherwise. + +var + HitInfo : TVTHeaderHitInfo; + NewClickIndex : Integer; + Menu : TPopupMenu; +begin + Result := False; + if (csDesigning in TreeViewControl.ComponentState) then + Exit; + // Convert vertical position to local coordinates. + Inc(P.Y, Header.Height); + NewClickIndex := ColumnFromPosition(P); + with HitInfo do + begin + X := P.X; + Y := P.Y; + Shift := Header.GetShiftState; + if DblClick then + Shift := Shift + [ssDouble]; + end; + HitInfo.Button := Button; + + if (NewClickIndex > NoColumn) and (coAllowClick in Items[NewClickIndex].Options) and + ((NewClickIndex = FDownIndex) or Force) then + begin + FClickIndex := NewClickIndex; + HitInfo.Column := NewClickIndex; + HitInfo.HitPosition := [hhiOnColumn]; + + if Items[NewClickIndex].HasImage and PtInRect(Items[NewClickIndex].ImageRect, P) then + begin + Include(HitInfo.HitPosition, hhiOnIcon); + if Items[NewClickIndex].CheckBox then + begin + if Button = TMouseButton.mbLeft then + TreeViewControl.UpdateColumnCheckState(Items[NewClickIndex]); + Include(HitInfo.HitPosition, hhiOnCheckbox); + end; + end; + end + else + begin + FClickIndex := NoColumn; + HitInfo.Column := NoColumn; + HitInfo.HitPosition := [hhiNoWhere]; + end; + + if DblClick then + TreeViewControl.DoHeaderDblClick(HitInfo) + else begin + if (hoHeaderClickAutoSort in Header.Options) and (HitInfo.Button = TMouseButton.mbLeft) and not (hhiOnCheckbox in HitInfo.HitPosition) and (HitInfo.Column >= 0) then + begin + // handle automatic setting of SortColumn and toggling of the sort order + if HitInfo.Column <> Header.SortColumn then + begin + // set sort column + Header.DoSetSortColumn(HitInfo.Column, Self[HitInfo.Column].DefaultSortDirection); + end//if + else + begin + // toggle sort direction + if Header.SortDirection = sdDescending then + Header.SortDirection := sdAscending + else + Header.SortDirection := sdDescending; + end; //else + Result := True; + end; //if + + if (Button = TMouseButton.mbRight) then + begin + Dec(P.Y, Header.Height); // popup menus at actual clicked point + FreeAndNil(FColumnPopupMenu); // Attention: Do not free the TVTHeaderPopupMenu at the end of this method, otherwise the clikc events of the menu item will not be fired. + Self.FDownIndex := NoColumn; + Self.FTrackIndex := NoColumn; + Self.FCheckBoxHit := False; + Menu := Header.DoGetPopupMenu(Self.ColumnFromPosition(Point(P.X, P.Y + TreeViewControl.Height)), P); + if Assigned(Menu) then + begin + TreeViewControl.StopTimer(ScrollTimer); + TreeViewControl.StopTimer(HeaderTimer); + Header.Columns.SetHoverIndex(NoColumn); + TreeViewControl.DoStateChange([], [tsScrollPending, tsScrolling]); + + Menu.PopupComponent := TreeViewControl; + With TreeViewControl.ClientToScreen(P) do + Menu.Popup(X, Y); + Result := True; + end + else if (hoAutoColumnPopupMenu in Header.Options) then + begin + FColumnPopupMenu := TVTHeaderPopupMenu.Create(TreeViewControl); + TVTHeaderPopupMenu(FColumnPopupMenu).OnAddHeaderPopupItem := HeaderPopupMenuAddHeaderPopupItem; + FColumnPopupMenu.PopupComponent := TreeViewControl; + if (hoDblClickResize in Header.Options) and ((TreeViewControl.ChildCount[nil] > 0) or (hoAutoResizeInclCaption in Header.Options)) then + TVTHeaderPopupMenu(FColumnPopupMenu).Options := TVTHeaderPopupMenu(FColumnPopupMenu).Options + [poResizeToFitItem] + else + TVTHeaderPopupMenu(FColumnPopupMenu).Options := TVTHeaderPopupMenu(FColumnPopupMenu).Options - [poResizeToFitItem]; + With TreeViewControl.ClientToScreen(P) do + FColumnPopupMenu.Popup(X, Y); + Result := True; + end; // if hoAutoColumnPopupMenu + end; //if mbRight + TreeViewControl.DoHeaderClick(HitInfo); + end; //else (not DblClick) + + if not (hhiNoWhere in HitInfo.HitPosition) then + Header.Invalidate(Items[NewClickIndex]); + if (FClickIndex > NoColumn) and (FClickIndex <> NewClickIndex) then + Header.Invalidate(Items[FClickIndex]); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumns.HeaderPopupMenuAddHeaderPopupItem(const Sender : TObject; const Column : TColumnIndex; var Cmd : TAddPopupItemType); +begin + TBaseVirtualTreeCracker(Sender).DoHeaderAddPopupItem(Column, Cmd); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumns.IndexChanged(OldIndex, NewIndex : Integer); + +// Called by a column when its index in the collection changes. If NewIndex is -1 then the column is +// about to be removed, otherwise it is moved to a new index. +// The method will then update the position array to reflect the change. + +var + I : Integer; + Increment : Integer; + Lower, + Upper : Integer; + +begin + if NewIndex = - 1 then + begin + // Find position in the array with the old index. + Upper := High(FPositionToIndex); + for I := 0 to Upper do + begin + if FPositionToIndex[I] = OldIndex then + begin + // Index found. Move all higher entries one step down and remove the last entry. + if I < Upper then + System.Move(FPositionToIndex[I + 1], FPositionToIndex[I], (Upper - I) * SizeOf(TColumnIndex)); + end; + // Decrease all indices, which are greater than the index to be deleted. + if FPositionToIndex[I] > OldIndex then + System.Dec(FPositionToIndex[I]); + end; + SetLength(FPositionToIndex, High(FPositionToIndex)); + end + else + begin + if OldIndex < NewIndex then + Increment := - 1 + else + Increment := 1; + + Lower := Min(OldIndex, NewIndex); + Upper := Max(OldIndex, NewIndex); + for I := 0 to High(FPositionToIndex) do + begin + if (FPositionToIndex[I] >= Lower) and (FPositionToIndex[I] < Upper) then + System.Inc(FPositionToIndex[I], Increment) + else + if FPositionToIndex[I] = OldIndex then + FPositionToIndex[I] := NewIndex; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumns.InitializePositionArray; + +// Ensures that the column position array contains as many entries as columns are defined. +// The array is resized and initialized with default values if needed. + +var + I, OldSize : Integer; + Changed : Boolean; + +begin + if Count <> Length(FPositionToIndex) then + begin + OldSize := Length(FPositionToIndex); + SetLength(FPositionToIndex, Count); + if Count > OldSize then + begin + // New items have been added, just set their position to the same as their index. + for I := OldSize to Count - 1 do + FPositionToIndex[I] := I; + end + else + begin + // Items have been deleted, so reindex remaining entries by decrementing values larger than the highest + // possible index until no entry is higher than this limit. + repeat + Changed := False; + for I := 0 to Count - 1 do + if FPositionToIndex[I] >= Count then + begin + System.Dec(FPositionToIndex[I]); + Changed := True; + end; + until not Changed; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumns.Notify(Item : TCollectionItem; Action : System.Classes.TCollectionNotification); +var + I : Integer; + lRemovedPosition: TColumnPosition; +begin + if Action in [cnDeleting] then + begin + lRemovedPosition := TVirtualTreeColumn(Item).Position; + // Adjust all positions larger than the deleted column's position. Fixes #959, #1049 + for I := Count - 1 downto 0 do + begin + if Items[I].Position > lRemovedPosition then + Items[I].Position := Items[I].Position - 1; + end; //for I + + with TreeViewControl do + if not (csLoading in ComponentState) and (FocusedColumn = Item.Index) then + InternalSetFocusedColumn(NoColumn); //bypass side effects in SetFocusedColumn + end; // if cnDeleting +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumns.ReorderColumns(RTL : Boolean); + +var + I : Integer; + +begin + if RTL then + begin + for I := 0 to Count - 1 do + FPositionToIndex[I] := Count - I - 1; + end + else + begin + for I := 0 to Count - 1 do + FPositionToIndex[I] := I; + end; + + UpdatePositions(True); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumns.SetHoverIndex(Index : TColumnIndex); +begin + FHoverIndex := index; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumns.EndUpdate; +begin + InitializePositionArray(); + FixPositions(); // Accept the cuurent order. See issue #753 + inherited; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumns.Update(Item : TCollectionItem); + +begin + // This is the only place which gets notified when a new column has been added or removed + // and we need this event to adjust the column position array. + InitializePositionArray; + if csLoading in TreeViewControl.ComponentState then + FNeedPositionsFix := True + else + UpdatePositions; + + // The first column which is created is by definition also the main column. + if (Count > 0) and (Header.MainColumn < 0) then + Header.MainColumn := 0; + + if not (csLoading in TreeViewControl.ComponentState) and not (hsLoading in Header.States) then + begin + with Header do + begin + if hoAutoResize in Options then + AdjustAutoSize(InvalidColumn); + if Assigned(Item) then + Invalidate(Item as TVirtualTreeColumn) + else + if Self.TreeViewControl.HandleAllocated then + begin + Self.TreeViewControl.UpdateHorizontalScrollBar(False); + Invalidate(nil); + TreeViewControl.Invalidate; + end; + + if not (Self.TreeViewControl.IsUpdating) then + // This is mainly to let the designer know when a change occurs at design time which + // doesn't involve the object inspector (like column resizing with the mouse). + // This does NOT include design time code as the communication is done via an interface. + Self.TreeViewControl.UpdateDesigner; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumns.UpdatePositions(Force : Boolean = False); + +// Recalculates the left border of every column and updates their position property according to the +// PostionToIndex array which primarily determines where each column is placed visually. + +var + I: Integer; + RunningPos: TDimension; +begin + if not (csDestroying in TreeViewControl.ComponentState) and not FNeedPositionsFix and (Force or (UpdateCount = 0)) then + begin + RunningPos := 0; + for I := 0 to High(FPositionToIndex) do + with Items[FPositionToIndex[I]] do + begin + FPosition := I; + FLeft := RunningPos; + if coVisible in FOptions then + Inc(RunningPos, FWidth); + end; + TreeViewControl.UpdateHorizontalScrollBar(False); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumns.Add : TVirtualTreeColumn; + +begin + Assert(GetCurrentThreadId = MainThreadId, 'UI controls may only be changed in UI thread.'); + Result := TVirtualTreeColumn(inherited Add); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumns.AnimatedResize(Column : TColumnIndex; NewWidth : TDimension); + +// Resizes the given column animated by scrolling the window DC. + +var + OldWidth : TDimension; + DC : TCanvas; + I, Steps : Integer; + DX : TDimension; + HeaderScrollRect, + ScrollRect, + R : TRect; + +begin + if not IsValidColumn(Column) then + Exit; // Just in case. + + // Make sure the width constrains are considered. + if NewWidth < Items[Column].MinWidth then + NewWidth := Items[Column].MinWidth; + if NewWidth > Items[Column].MaxWidth then + NewWidth := Items[Column].MaxWidth; + + OldWidth := Items[Column].Width; + // Nothing to do if the width is the same. + if OldWidth <> NewWidth then + begin + if not ((hoDisableAnimatedResize in Header.Options) or + (coDisableAnimatedResize in Items[Column].Options)) then + begin + DC := TCanvas.Create; + DC.Handle := GetWindowDC(TreeViewControl.Handle); + with TreeViewControl do + try + Steps := 32; + DX := Divide(NewWidth - OldWidth, Steps); + + // Determination of the scroll rectangle is a bit complicated since we neither want + // to scroll the scrollbars nor the border of the treeview window. + HeaderScrollRect := HeaderRect; + ScrollRect := HeaderScrollRect; + // Exclude the header itself from scrolling. + ScrollRect.Top := ScrollRect.Bottom; + ScrollRect.Bottom := ScrollRect.Top + ClientHeight; + ScrollRect.Right := ScrollRect.Left + ClientWidth; + with Items[Column] do + Inc(ScrollRect.Left, FLeft + FWidth); + HeaderScrollRect.Left := ScrollRect.Left; + HeaderScrollRect.Right := ScrollRect.Right; + + // When the new width is larger then avoid artefacts on the left hand side + // by deleting a small stripe + if NewWidth > OldWidth then + begin + R := ScrollRect; +// NewBrush := CreateSolidBrush(ColorToRGB(Color)); +// LastBrush := SelectObject(DC, NewBrush); + R.Right := R.Left + DX; +// FillRect(DC, R, NewBrush); +// SelectObject(DC, LastBrush); +// DeleteObject(NewBrush); + DC.Brush.Color := Color; + DC.FillRect(R); + end + else + begin + Inc(HeaderScrollRect.Left, DX); + Inc(ScrollRect.Left, DX); + end; + + for I := 0 to Steps - 1 do + begin + ScrollDC(DC.Handle, DX, 0, HeaderScrollRect, HeaderScrollRect, 0, nil); + Inc(HeaderScrollRect.Left, DX); + ScrollDC(DC.Handle, DX, 0, ScrollRect, ScrollRect, 0, nil); + Inc(ScrollRect.Left, DX); + Sleep(1); + end; + finally + ReleaseDC(Handle, DC.Handle); + DC.Free; + end; + end; + Items[Column].Width := NewWidth; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumns.Assign(Source : TPersistent); + +begin + // Let the collection class assign the items. + inherited; + + if Source is TVirtualTreeColumns then + begin + // Copying the position array is the only needed task here. + FPositionToIndex := Copy(TVirtualTreeColumns(Source).FPositionToIndex, 0, MaxInt); + + // Make sure the left edges are correct after assignment. + FNeedPositionsFix := False; + UpdatePositions(True); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumns.Clear; + +begin + FClearing := True; + try + TreeViewControl.CancelEditNode; + + // Since we're freeing all columns, the following have to be true when we're done. + FHoverIndex := NoColumn; + FDownIndex := NoColumn; + FTrackIndex := NoColumn; + FClickIndex := NoColumn; + FCheckBoxHit := False; + + with Header do + if not (hsLoading in States) then + begin + InternalSetAutoSizeIndex(NoColumn); //bypass side effects in SetAutoSizeColumn + MainColumn := NoColumn; + InternalSetSortColumn(NoColumn); //bypass side effects in SetSortColumn + end; + + with TreeViewControl do + if not (csLoading in ComponentState) then + InternalSetFocusedColumn(NoColumn); //bypass side effects in SetFocusedColumn + + inherited Clear; + finally + FClearing := False; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumns.ColumnFromPosition(P : TPoint; Relative : Boolean = True) : TColumnIndex; + +// Determines the current column based on the position passed in P. + +var + I: Integer; + Sum: TDimension; +begin + Result := InvalidColumn; + + // The position must be within the header area, but we extend the vertical bounds to the entire treeview area. + if (P.X >= 0) and (P.Y >= 0) and (P.Y <= TreeViewControl.Height) then + with FHeader, TreeViewControl do + begin + if Relative and (P.X >= GetVisibleFixedWidth) then + Sum := - EffectiveOffsetX + else + Sum := 0; + + if UseRightToLeftAlignment then + Inc(Sum, ComputeRTLOffset(True)); + + for I := 0 to Count - 1 do + if coVisible in Items[FPositionToIndex[I]].Options then + begin + Inc(Sum, Items[FPositionToIndex[I]].Width); + if P.X < Sum then + begin + Result := FPositionToIndex[I]; + Break; + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumns.ColumnFromPosition(PositionIndex : TColumnPosition) : TColumnIndex; + +// Returns the index of the column at the given position. + +begin + if Integer(PositionIndex) < Length(FPositionToIndex) then + Result := FPositionToIndex[PositionIndex] + else + Result := NoColumn; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumns.Equals(OtherColumnsObj : TObject) : Boolean; + +// Compares itself with the given set of columns and returns True if all published properties are the same +// (including column order), otherwise False is returned. + +var + I : Integer; + OtherColumns : TVirtualTreeColumns; + +begin + if not (OtherColumnsObj is TVirtualTreeColumns) then + begin + Result := False; + Exit; + end; + + OtherColumns := TVirtualTreeColumns(OtherColumnsObj); + + // Same number of columns? + Result := OtherColumns.Count = Count; + if Result then + begin + // Same order of columns? + Result := CompareMem(Pointer(FPositionToIndex), Pointer(OtherColumns.FPositionToIndex), + Length(FPositionToIndex) * SizeOf(TColumnIndex)); + if Result then + begin + for I := 0 to Count - 1 do + if not Items[I].Equals(OtherColumns[I]) then + begin + Result := False; + Break; + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumns.GetColumnBounds(Column : TColumnIndex; var Left, Right : TDimension); + +// Returns the left and right bound of the given column. If Column is NoColumn then the entire client width is returned. + +begin + if Column <= NoColumn then + begin + Left := 0; + Right := TreeViewControl.ClientWidth; + end + else + begin + Left := Items[Column].Left; + Right := Left + Items[Column].Width; + if TreeViewControl.UseRightToLeftAlignment then + begin + Inc(Left, TreeViewControl.ComputeRTLOffset(True)); + Inc(Right, TreeViewControl.ComputeRTLOffset(True)); + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumns.GetScrollWidth : TDimension; + +// Returns the average width of all visible, non-fixed columns. If there is no such column the indent is returned. + +var + I : Integer; + ScrollColumnCount : Integer; + +begin + + Result := 0; + + ScrollColumnCount := 0; + for I := 0 to Header.Columns.Count - 1 do + begin + if ([coVisible, coFixed] * Header.Columns[I].Options = [coVisible]) then + begin + Inc(Result, Header.Columns[I].Width); + System.Inc(ScrollColumnCount); + end; + end; + + if ScrollColumnCount > 0 then // use average width + Result := Round(Result / ScrollColumnCount) + else // use indent + Result := TreeViewControl.Indent; + +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumns.GetTreeView: TCustomControl; +begin + Result := TBaseVirtualTreeCracker(Header.GetOwner); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumns.GetFirstVisibleColumn(ConsiderAllowFocus : Boolean = False) : TColumnIndex; + +// Returns the index of the first visible column or "InvalidColumn" if either no columns are defined or +// all columns are hidden. +// If ConsiderAllowFocus is True then the column has not only to be visible but also focus has to be allowed. + +var + I : Integer; + +begin + Result := InvalidColumn; + if (UpdateCount > 0) or (csLoading in TreeViewControl.ComponentState) then + Exit; // See issue #760 + for I := 0 to Count - 1 do + if (coVisible in Items[FPositionToIndex[I]].Options) and + ((not ConsiderAllowFocus) or + (coAllowFocus in Items[FPositionToIndex[I]].Options) + ) then + begin + Result := FPositionToIndex[I]; + Break; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumns.GetLastVisibleColumn(ConsiderAllowFocus : Boolean = False) : TColumnIndex; + +// Returns the index of the last visible column or "InvalidColumn" if either no columns are defined or +// all columns are hidden. +// If ConsiderAllowFocus is True then the column has not only to be visible but also focus has to be allowed. + +var + I : Integer; + +begin + Result := InvalidColumn; + if (UpdateCount > 0) or (csLoading in TreeViewControl.ComponentState) then + Exit; // See issue #760 + for I := Count - 1 downto 0 do + if (coVisible in Items[FPositionToIndex[I]].Options) and + ((not ConsiderAllowFocus) or + (coAllowFocus in Items[FPositionToIndex[I]].Options) + ) then + begin + Result := FPositionToIndex[I]; + Break; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumns.GetFirstColumn : TColumnIndex; + +// Returns the first column in display order. + +begin + if Count = 0 then + Result := InvalidColumn + else + Result := FPositionToIndex[0]; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumns.GetNextColumn(Column : TColumnIndex) : TColumnIndex; + +// Returns the next column in display order. Column is the index of an item in the collection (a column). + +var + Position : Integer; + +begin + if Column < 0 then + Result := InvalidColumn + else + begin + Position := Items[Column].Position; + if Position < Count - 1 then + Result := FPositionToIndex[Position + 1] + else + Result := InvalidColumn; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumns.GetNextVisibleColumn(Column : TColumnIndex; ConsiderAllowFocus : Boolean = False) : TColumnIndex; + +// Returns the next visible column in display order, Column is an index into the columns list. +// If ConsiderAllowFocus is True then the column has not only to be visible but also focus has to be allowed. + +begin + Result := Column; + repeat + Result := GetNextColumn(Result); + until (Result = InvalidColumn) or + ((coVisible in Items[Result].Options) and + ((not ConsiderAllowFocus) or + (coAllowFocus in Items[Result].Options) + ) + ); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumns.GetPreviousColumn(Column : TColumnIndex) : TColumnIndex; + +// Returns the previous column in display order, Column is an index into the columns list. + +var + Position : Integer; + +begin + if Column < 0 then + Result := InvalidColumn + else + begin + Position := Items[Column].Position; + if Position > 0 then + Result := FPositionToIndex[Position - 1] + else + Result := InvalidColumn; + Assert(Column <> Result, 'The previous column must not have the same position as the given column.'); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumns.GetPreviousVisibleColumn(Column : TColumnIndex; ConsiderAllowFocus : Boolean = False) : TColumnIndex; + +// Returns the previous visible column in display order, Column is an index into the columns list. +// If ConsiderAllowFocus is True then the column has not only to be visible but also focus has to be allowed. + +begin + Result := Column; + repeat + Result := GetPreviousColumn(Result); + until (Result = InvalidColumn) or + ((coVisible in Items[Result].Options) and + ((not ConsiderAllowFocus) or + (coAllowFocus in Items[Result].Options) + ) + ); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumns.GetVisibleColumns : TColumnsArray; + +// Returns a list of all currently visible columns in actual order. + +var + I, Counter : Integer; + +begin + SetLength(Result, Count); + Counter := 0; + + for I := 0 to Count - 1 do + if coVisible in Items[FPositionToIndex[I]].Options then + begin + Result[Counter] := Items[FPositionToIndex[I]]; + System.Inc(Counter); + end; + // Set result length to actual visible count. + SetLength(Result, Counter); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumns.GetVisibleFixedWidth : TDimension; + +// Determines the horizontal space all visible and fixed columns occupy. + +var + I : Integer; + +begin + Result := 0; + for I := 0 to Count - 1 do + begin + if Items[I].Options * [coVisible, coFixed] = [coVisible, coFixed] then + Inc(Result, Items[I].Width); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumns.IsValidColumn(Column : TColumnIndex) : Boolean; + +// Determines whether the given column is valid or not, that is, whether it is one of the current columns. + +begin + Result := (Column > NoColumn) and (Column < Count); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumns.LoadFromStream(const Stream : TStream; Version : Integer); + +var + I, + ItemCount : Integer; + +begin + Clear; + Stream.ReadBuffer(ItemCount, SizeOf(ItemCount)); + // number of columns + if ItemCount > 0 then + begin + BeginUpdate; + try + for I := 0 to ItemCount - 1 do + Add.LoadFromStream(Stream, Version); + SetLength(FPositionToIndex, ItemCount); + Stream.ReadBuffer(FPositionToIndex[0], ItemCount * SizeOf(TColumnIndex)); + UpdatePositions(True); + finally + EndUpdate; + end; + end; + + // Data introduced with header stream version 5 + if Version > 4 then + Stream.ReadBuffer(FDefaultWidth, SizeOf(FDefaultWidth)); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumns.PaintHeader(DC : HDC; R : TRect; HOffset : TDimension); + +// Backward compatible header paint method. This method takes care of visually moving floating columns + +var + VisibleFixedWidth : TDimension; + RTLOffset : TDimension; + + procedure PaintFixedArea; + + begin + if VisibleFixedWidth > 0 then + PaintHeader(FHeaderBitmap.Canvas, + Rect(0, 0, Min(R.Right, VisibleFixedWidth), R.Bottom - R.Top), + Point(R.Left, R.Top), RTLOffset); + end; + +begin + // Adjust size of the header bitmap + FHeaderBitmap.SetSize(Max(TreeViewControl.HeaderRect.Right, R.Right - R.Left), TreeViewControl.HeaderRect.Bottom); + + VisibleFixedWidth := GetVisibleFixedWidth; + + // Consider right-to-left directionality. + if TreeViewControl.UseRightToLeftAlignment then + RTLOffset := TreeViewControl.ComputeRTLOffset + else + RTLOffset := 0; + + if RTLOffset = 0 then + PaintFixedArea; + + // Paint the floating part of the header. + PaintHeader(FHeaderBitmap.Canvas, + Rect(VisibleFixedWidth - HOffset, 0, R.Right + VisibleFixedWidth - HOffset, R.Bottom - R.Top), + Point(R.Left + VisibleFixedWidth, R.Top), RTLOffset); + + // In case of right-to-left directionality we paint the fixed part last. + if RTLOffset <> 0 then + PaintFixedArea; + + // Blit the result to target. + BitBlt(DC, R.Left, R.Top, R.Right - R.Left, R.Bottom - R.Top, FHeaderBitmap.Canvas.Handle, R.Left, R.Top, SRCCOPY); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumns.PaintHeader(TargetCanvas : TCanvas; R : TRect; const Target : TPoint; + RTLOffset : TDimension = 0); + +// Main paint method to draw the header. +// This procedure will paint the a slice (given in R) out of HeaderRect into TargetCanvas starting at position Target. +// This function does not offer the option to visually move floating columns due to scrolling. To accomplish this you +// need to call this method twice. + +var + Run : TColumnIndex; + RightBorderFlag, + NormalButtonStyle, + NormalButtonFlags, + PressedButtonStyle, + PressedButtonFlags, + RaisedButtonStyle, + RaisedButtonFlags : Cardinal; + Images : TCustomImageList; + OwnerDraw, + AdvancedOwnerDraw : Boolean; + PaintInfo : THeaderPaintInfo; + RequestedElements, + ActualElements : THeaderPaintElements; + + //--------------- local functions ------------------------------------------- + + procedure PrepareButtonStyles; + + // Prepare the button styles and flags for later usage. + + begin + RaisedButtonStyle := 0; + RaisedButtonFlags := 0; + case Header.Style of + hsThickButtons : + begin + NormalButtonStyle := BDR_RAISEDINNER or BDR_RAISEDOUTER; + NormalButtonFlags := BF_LEFT or BF_TOP or BF_BOTTOM or BF_MIDDLE or BF_SOFT or BF_ADJUST; + PressedButtonStyle := BDR_RAISEDINNER or BDR_RAISEDOUTER; + PressedButtonFlags := NormalButtonFlags or BF_RIGHT or BF_FLAT or BF_ADJUST; + end; + hsFlatButtons : + begin + NormalButtonStyle := BDR_RAISEDINNER; + NormalButtonFlags := BF_LEFT or BF_TOP or BF_BOTTOM or BF_MIDDLE or BF_ADJUST; + PressedButtonStyle := BDR_SUNKENOUTER; + PressedButtonFlags := BF_RECT or BF_MIDDLE or BF_ADJUST; + end; + else + // hsPlates or hsXPStyle, values are not used in the latter case + begin + NormalButtonStyle := BDR_RAISEDINNER; + NormalButtonFlags := BF_RECT or BF_MIDDLE or BF_SOFT or BF_ADJUST; + PressedButtonStyle := BDR_SUNKENOUTER; + PressedButtonFlags := BF_RECT or BF_MIDDLE or BF_ADJUST; + RaisedButtonStyle := BDR_RAISEDINNER; + RaisedButtonFlags := BF_LEFT or BF_TOP or BF_BOTTOM or BF_MIDDLE or BF_ADJUST; + end; + end; + end; + + //--------------------------------------------------------------------------- + + procedure DrawBackground; + + // Draw the header background. + + var + BackgroundRect : TRect; + Details : TThemedElementDetails; + Theme : HTHEME; + begin + BackgroundRect := Rect(Target.X, Target.Y, Target.X + R.Right - R.Left, Target.Y + Header.Height); + + with TargetCanvas do + begin + if hpeBackground in RequestedElements then + begin + PaintInfo.PaintRectangle := BackgroundRect; + TreeViewControl.DoAdvancedHeaderDraw(PaintInfo, [hpeBackground]); + end + else + begin + if (TreeViewControl.VclStyleEnabled and (seClient in TreeViewControl.StyleElements)) then + begin + Details := StyleServices.GetElementDetails(thHeaderItemRightNormal); + StyleServices.DrawElement(Handle, Details, BackgroundRect, @BackgroundRect {$IF CompilerVersion >= 34}, TreeViewControl.FCurrentPPI{$IFEND}); + end + else + if tsUseThemes in TreeViewControl.TreeStates then + begin + Theme := OpenThemeData(TreeViewControl.Handle, 'HEADER'); + DrawThemeBackground(Theme, Handle, HP_HEADERITEM, HIS_NORMAL, BackgroundRect, nil); + CloseThemeData(Theme); + end + else + begin + Brush.Color := Header.Background; + FillRect(BackgroundRect); + end; + end; + end; + end; + + //--------------------------------------------------------------------------- + + procedure PaintColumnHeader(AColumn : TColumnIndex; ATargetRect : TRect); + + // Draw a single column to TargetRect. The clipping rect needs to be set before + // this procedure is called. + + var + SavedDC : Integer; + ColCaptionText : string; + ColImageInfo : TVTImageInfo; + Glyph : TThemedHeader; + Details : TThemedElementDetails; + WrapCaption : Boolean; + DrawFormat : Cardinal; + Pos : TRect; + DrawHot : Boolean; + ImageWidth : Integer; + begin + ColImageInfo.Ghosted := False; + PaintInfo.Column := Items[AColumn]; + with PaintInfo, Column do + begin + IsHoverIndex := (AColumn = FHoverIndex) and (hoHotTrack in Header.Options) and (coEnabled in Options); + IsDownIndex := (AColumn = FDownIndex) and not FCheckBoxHit; + + if (coShowDropMark in FOptions) and (AColumn = FDropTarget) and (AColumn <> FDragIndex) then + begin + if FDropBefore then + DropMark := dmmLeft + else + DropMark := dmmRight; + end + else + DropMark := dmmNone; + + //Fix for issue 643 + //Do not show the left drop mark if the position to drop is just preceding the target which means + //the dragged column will stay where it is + if (DropMark = dmmLeft) and (Items[FDragIndex].Position = TColumnPosition(Max(Integer(Items[FDropTarget].Position) - 1, 0))) + then + DropMark := dmmNone + else + //Do not show the right drop mark if the position to drop is just following the target which means + //the dragged column will stay where it is + if (DropMark = dmmRight) and (Items[FDragIndex].Position = Items[FDropTarget].Position + 1) + then + DropMark := dmmNone; + + IsEnabled := (coEnabled in FOptions) and (TreeViewControl.Enabled); + ShowHeaderGlyph := (hoShowImages in Header.Options) and ((Assigned(Images) and (FImageIndex > - 1)) or FCheckBox); + ShowSortGlyph := (AColumn = Header.SortColumn) and (hoShowSortGlyphs in Header.Options); + WrapCaption := coWrapCaption in FOptions; + + PaintRectangle := ATargetRect; + + // This path for text columns or advanced owner draw. + if (Style = vsText) or not OwnerDraw or AdvancedOwnerDraw then + begin + // See if the application wants to draw part of the header itself. + RequestedElements := []; + if AdvancedOwnerDraw then + begin + PaintInfo.Column := Items[AColumn]; + TreeViewControl.DoHeaderDrawQueryElements(PaintInfo, RequestedElements); + end; + + if ShowRightBorder or (AColumn < Count - 1) then + RightBorderFlag := BF_RIGHT + else + RightBorderFlag := 0; + + if hpeBackground in RequestedElements then + TreeViewControl.DoAdvancedHeaderDraw(PaintInfo, [hpeBackground]) + else + begin + if (tsUseThemes in TreeViewControl.TreeStates) or (TreeViewControl.VclStyleEnabled and (seClient in TreeViewControl.StyleElements)) then + begin + if IsDownIndex then + Details := StyleServices.GetElementDetails(thHeaderItemPressed) + else + if IsHoverIndex then + Details := StyleServices.GetElementDetails(thHeaderItemHot) + else + Details := StyleServices.GetElementDetails(thHeaderItemNormal); + StyleServices.DrawElement(TargetCanvas.Handle, Details, PaintRectangle, @PaintRectangle{$IF CompilerVersion >= 34}, TreeViewControl.CurrentPPI{$IFEND}); + {$IF CompilerVersion >= 34} + if TreeViewControl.CurrentPPI >= 144 then // Fixes issue #1172 + begin + PaintRectangle.Right := PaintRectangle.Right - 1; // For screens with scaled at 150% or more use a splitter with two pixels width + StyleServices.DrawElement(TargetCanvas.Handle, Details, PaintRectangle, @PaintRectangle, TreeViewControl.CurrentPPI); + end; + {$IFEND} + end + else + begin // Windows classic mode + if IsDownIndex then + DrawEdge(TargetCanvas.Handle, PaintRectangle, PressedButtonStyle, PressedButtonFlags) + else + // Plates have the special case of raising on mouse over. + if (Header.Style = hsPlates) and IsHoverIndex and + (coAllowClick in FOptions) and (coEnabled in FOptions) then + DrawEdge(TargetCanvas.Handle, PaintRectangle, RaisedButtonStyle, + RaisedButtonFlags or RightBorderFlag) + else + DrawEdge(TargetCanvas.Handle, PaintRectangle, NormalButtonStyle, + NormalButtonFlags or RightBorderFlag); + end; + end; + + PaintRectangle := ATargetRect; + + // calculate text and glyph position + InflateRect(PaintRectangle, - cMargin, - cMargin); + DrawFormat := DT_TOP or DT_NOPREFIX; + case CaptionAlignment of + taLeftJustify : + DrawFormat := DrawFormat or DT_LEFT; + taRightJustify : + DrawFormat := DrawFormat or DT_RIGHT; + taCenter : + DrawFormat := DrawFormat or DT_CENTER; + end; + if UseRightToLeftReading then + DrawFormat := DrawFormat + DT_RTLREADING; + ComputeHeaderLayout(PaintInfo, DrawFormat); + + // Move glyph and text one pixel to the right and down to simulate a pressed button. + if IsDownIndex then + begin + OffsetRect(TextRectangle, cDownOffset, cDownOffset); + Inc(GlyphPos.X); + Inc(GlyphPos.Y); + Inc(SortGlyphPos.X); + Inc(SortGlyphPos.Y); + end; + + // Advanced owner draw allows to paint elements, which would normally not be painted (because of space + // limitations, empty captions etc.). + ActualElements := RequestedElements * [hpeHeaderGlyph, hpeSortGlyph, hpeDropMark, hpeText, hpeOverlay]; + + // main glyph + FHasImage := False; + if Assigned(Images) then + ImageWidth := Images.Width + else + ImageWidth := 0; + + if not (hpeHeaderGlyph in ActualElements) and ShowHeaderGlyph and + (not ShowSortGlyph or (FBiDiMode <> bdLeftToRight) or (GlyphPos.X + ImageWidth <= SortGlyphPos.X)) then + begin + if not FCheckBox then + begin + ColImageInfo.Images := Images; + Images.Draw(TargetCanvas, GlyphPos.X, GlyphPos.Y, FImageIndex, IsEnabled); + end + else + begin + with TreeViewControl do + begin + ColImageInfo.Images := CheckImages; + ColImageInfo.Index := GetCheckImage(nil, FCheckType, FCheckState, IsEnabled); + ColImageInfo.XPos := GlyphPos.X; + ColImageInfo.YPos := GlyphPos.Y; + PaintCheckImage(TargetCanvas, ColImageInfo, False); + end; + end; + + FHasImage := True; + FImageRect.Left := GlyphPos.X; + FImageRect.Top := GlyphPos.Y; + FImageRect.Right := FImageRect.Left + ColImageInfo.Images.Width; + FImageRect.Bottom := FImageRect.Top + ColImageInfo.Images.Height; + end; + + // caption + if WrapCaption then + ColCaptionText := FCaptionText + else + ColCaptionText := Text; + if IsHoverIndex and TreeViewControl.VclStyleEnabled then + DrawHot := True + else + DrawHot := (IsHoverIndex and (hoHotTrack in Header.Options) and not (tsUseThemes in TreeViewControl.TreeStates)); + if not (hpeText in ActualElements) and (Length(Text) > 0) then + DrawButtonText(TargetCanvas.Handle, ColCaptionText, TextRectangle, IsEnabled, DrawHot, DrawFormat, WrapCaption); + + // sort glyph + if not (hpeSortGlyph in ActualElements) and ShowSortGlyph then + begin + if tsUseExplorerTheme in TreeViewControl.TreeStates then + begin + Pos.TopLeft := SortGlyphPos; + Pos.Right := Pos.Left + SortGlyphSize.cx; + Pos.Bottom := Pos.Top + SortGlyphSize.cy; + if Header.SortDirection = sdAscending then + Glyph := thHeaderSortArrowSortedUp + else + Glyph := thHeaderSortArrowSortedDown; + Details := StyleServices.GetElementDetails(Glyph); + if not StyleServices.DrawElement(TargetCanvas.Handle, Details, Pos, @Pos {$IF CompilerVersion >= 34}, TreeViewControl.CurrentPPI {$IFEND}) then + PaintInfo.DrawSortArrow(Header.SortDirection); + end + else + begin + PaintInfo.DrawSortArrow(Header.SortDirection); + end; + end; + + // Show an indication if this column is the current drop target in a header drag operation. + if not (hpeDropMark in ActualElements) and (DropMark <> dmmNone) then + begin + PaintInfo.DrawDropMark(); + end; + + if ActualElements <> [] then + begin + SavedDC := SaveDC(TargetCanvas.Handle); + TreeViewControl.DoAdvancedHeaderDraw(PaintInfo, ActualElements); + RestoreDC(TargetCanvas.Handle, SavedDC); + end; + end + else // Let application draw the header. + TreeViewControl.DoHeaderDraw(TargetCanvas, Items[AColumn], PaintRectangle, IsHoverIndex, IsDownIndex, + DropMark); + end; + end; + + //--------------- end local functions --------------------------------------- + +var + TargetRect : TRect; + MaxX : TDimension; + Count: Integer; + EndCol: TColumnIndex; +begin + if IsRectEmpty(R) then + Exit; + + // If both draw posibillities are specified then prefer the advanced way. + AdvancedOwnerDraw := (hoOwnerDraw in Header.Options) and Assigned(TreeViewControl.OnAdvancedHeaderDraw) and + Assigned(TreeViewControl.OnHeaderDrawQueryElements) and not (csDesigning in TreeViewControl.ComponentState); + OwnerDraw := (hoOwnerDraw in Header.Options) and Assigned(TreeViewControl.OnHeaderDraw) and + not (csDesigning in TreeViewControl.ComponentState) and not AdvancedOwnerDraw; + + ZeroMemory(@PaintInfo, SizeOf(PaintInfo)); + PaintInfo.TargetCanvas := TargetCanvas; + + with PaintInfo, TargetCanvas do + begin + // Use shortcuts for the images and the font. + Images := Header.Images; + Font := Header.Font; + + PrepareButtonStyles; + + // At first, query the application which parts of the header it wants to draw on its own. + RequestedElements := []; + if AdvancedOwnerDraw then + begin + PaintRectangle := R; + Column := nil; + TreeViewControl.DoHeaderDrawQueryElements(PaintInfo, RequestedElements); + end; + + // Draw the background. + DrawBackground; + + // Now that we have drawn the background, we apply the header's dimensions to R. + R := Rect(Max(R.Left, 0), Max(R.Top, 0), Min(R.Right, TotalWidth), Min(R.Bottom, Header.Height)); + + // Determine where to stop. + MaxX := Target.X + R.Right - R.Left + //Fixes issues #544, #427 -- MaxX should also shift on BidiMode bdRightToLeft + + RTLOffset; //added for fix + + // Determine the start column. + Run := ColumnFromPosition(Point(R.Left + RTLOffset, 0), False); + if Run <= NoColumn then + Exit; + + TargetRect.Top := Target.Y; + TargetRect.Bottom := Target.Y + R.Bottom - R.Top; + TargetRect.Left := Target.X - R.Left + Items[Run].FLeft + RTLOffset; + // TargetRect.Right will be set in the loop + + ShowRightBorder := (Header.Style = hsThickButtons) or not (hoAutoResize in Header.Options) or (TreeViewControl.BevelKind = TBevelKind.bkNone); + + // Now go for each button. + while (Run > NoColumn) and (TargetRect.Left < MaxX) do + begin + + //let application decide how many columns can be spanned + Count:= 1; + TreeViewControl.DoColumnHeaderSpanning(Run, Count); + + if Count > FHeader.Columns.Count then Count := FHeader.Columns.Count; + if Count < 1 then Count := 1; + + EndCol:= Run; + TargetRect.Right := TargetRect.Left; + repeat + Inc(TargetRect.Right, Items[EndCol].Width); + Dec(Count); + EndCol := GetNextVisibleColumn(EndCol); + until (Count = 0) or (EndCol <= NoColumn); + + // create a clipping rect to limit painting to button area + ClipCanvas(TargetCanvas, Rect(Max(TargetRect.Left, Target.X), Target.Y + R.Top, + Min(TargetRect.Right, MaxX), TargetRect.Bottom)); + + PaintColumnHeader(Run, TargetRect); + + SelectClipRgn(Handle, 0); + + TargetRect.Left := TargetRect.Right; + + Run := EndCol; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumns.SaveToStream(const Stream : TStream); + +var + I : Integer; + +begin + I := Count; + Stream.WriteBuffer(I, SizeOf(I)); + if I > 0 then + begin + for I := 0 to Count - 1 do + TVirtualTreeColumn(Items[I]).SaveToStream(Stream); + + Stream.WriteBuffer(FPositionToIndex[0], Count * SizeOf(TColumnIndex)); + end; + + // Data introduced with header stream version 5. + Stream.WriteBuffer(DefaultWidth, SizeOf(DefaultWidth)); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumns.TotalWidth : TDimension; + +var + LastColumn : TColumnIndex; + +begin + Result := 0; + if (Count > 0) and (Length(FPositionToIndex) > 0) then + begin + LastColumn := FPositionToIndex[Count - 1]; + if not (coVisible in Items[LastColumn].Options) then + LastColumn := GetPreviousVisibleColumn(LastColumn); + if LastColumn > NoColumn then + with Items[LastColumn] do + Result := FLeft + FWidth; + end; +end; + +{ THeaderPaintInfo } + +procedure THeaderPaintInfo.DrawDropMark(); +var + Y : TDimension; + lArrowWidth : TDimension; +begin + lArrowWidth := TBaseVirtualTreeCracker(Self.Column.TreeViewControl).ScaledPixels(5); + Y := Divide(PaintRectangle.Top + PaintRectangle.Bottom - 3 * lArrowWidth, 2); + if DropMark = dmmLeft then + DrawArrow(TargetCanvas, TScrollDirection.sdLeft, Point(PaintRectangle.Left, Y), lArrowWidth) + else + DrawArrow(TargetCanvas, TScrollDirection.sdRight, Point(PaintRectangle.Right - lArrowWidth - Divide(lArrowWidth, 2) {spacing}, Y), lArrowWidth); +end; + +procedure THeaderPaintInfo.DrawSortArrow(pDirection : TSortDirection); +const + cDirection : array [TSortDirection] of TScrollDirection = (TScrollDirection.sdUp, TScrollDirection.sdDown); +var + lOldColor : TColor; +begin + lOldColor := TargetCanvas.Pen.Color; + TargetCanvas.Pen.Color := clDkGray; + DrawArrow(TargetCanvas, cDirection[pDirection], Point(SortGlyphPos.X, SortGlyphPos.Y), SortGlyphSize.cy); + TargetCanvas.Pen.Color := lOldColor; +end; + +{ TVirtualTreeColumnHelper } + +function TVirtualTreeColumnHelper.Header : TVTHeader; +begin + Result := Owner.Header; +end; + +function TVirtualTreeColumnHelper.TreeViewControl : TBaseVirtualTreeCracker; +begin + Result := TBaseVirtualTreeCracker(Owner.Header.GetOwner); +end; + +{ TVirtualTreeColumnsHelper } + +function TVirtualTreeColumnsHelper.TreeViewControl : TBaseVirtualTreeCracker; +begin + Result := TBaseVirtualTreeCracker(Header.GetOwner); +end; + + +end. diff --git a/components/virtualtreeview/Source/VirtualTrees.HeaderPopup.dtx b/components/virtualtreeview/Source/VirtualTrees.HeaderPopup.dtx index b198cb9a4..edadce6d9 100644 --- a/components/virtualtreeview/Source/VirtualTrees.HeaderPopup.dtx +++ b/components/virtualtreeview/Source/VirtualTrees.HeaderPopup.dtx @@ -1,54 +1,54 @@ - -@@TVirtualTreeCast -Necessary to make the header accessible. - - -@@TVTHeaderPopupOption.poAllowHideAll -Allows to hide all columns, including the last one. - -@@TVTHeaderPopupOption.poOriginalOrder -Show menu items in original column order as they were added to the tree. - -@@VTHeaderPopup.pas -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/ - -Alternatively, you may redistribute this library, use and/or modify it under the terms of the -GNU Lesser General Public License as published by the Free Software Foundation; -either version 2.1 of the License, or (at your option) any later version. -You may obtain a copy of the LGPL at http://www.gnu.org/copyleft/. - -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. - -The Original Code is VTHeaderPopup.pas. - -The Initial Developer of the Original Code is Ralf Junker . All Rights Reserved. - -Modified 14 Sep 2003 by Mike Lischke . - - Renamed event type name to be consistent with other event types (e.g. used in VT). - - Added event for hiding/showing columns. - - DoXXX method are now virtual. - - Conditional code rearrangement to get back Ctrl+Shift+Up/Down navigation back. -Modified 31 Mar 2003 by Mike Lischke . - Added a check for the PopupComponent property before casting it hardly to a Virtual Treeview. People might - (accidentally) misuse the header popup. - -Modified 20 Oct 2002 by Borut Maricic . - Added the possibility to use Troy Wolbrink's Unicode aware popup menu. Define the compiler symbol TNT to enable it. - You can get Troy's Unicode controls collection from http://home.ccci.org/wolbrink/tnt/delphi_unicode_controls.htm). - -Modified 24 Feb 2002 by Ralf Junker . - Fixed a bug where the OnAddHeaderPopupItem would interfere with poAllowHideAll options. - All column indexes now consistently use TColumnIndex (instead of Integer). - -Modified 23 Feb 2002 by Ralf Junker . - Added option to show menu items in the same order as the columns or in original order. - Added option to prevent the user to hide all columns. - -Modified 17 Feb 2002 by Jim Kueneman . - Added the event to filter the items as they are added to the menu. + +@@TVirtualTreeCast +Necessary to make the header accessible. + + +@@TVTHeaderPopupOption.poAllowHideAll +Allows to hide all columns, including the last one. + +@@TVTHeaderPopupOption.poOriginalOrder +Show menu items in original column order as they were added to the tree. + +@@VTHeaderPopup.pas +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/ + +Alternatively, you may redistribute this library, use and/or modify it under the terms of the +GNU Lesser General Public License as published by the Free Software Foundation; +either version 2.1 of the License, or (at your option) any later version. +You may obtain a copy of the LGPL at http://www.gnu.org/copyleft/. + +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. + +The Original Code is VTHeaderPopup.pas. + +The Initial Developer of the Original Code is Ralf Junker . All Rights Reserved. + +Modified 14 Sep 2003 by Mike Lischke . + - Renamed event type name to be consistent with other event types (e.g. used in VT). + - Added event for hiding/showing columns. + - DoXXX method are now virtual. + - Conditional code rearrangement to get back Ctrl+Shift+Up/Down navigation back. +Modified 31 Mar 2003 by Mike Lischke . + Added a check for the PopupComponent property before casting it hardly to a Virtual Treeview. People might + (accidentally) misuse the header popup. + +Modified 20 Oct 2002 by Borut Maricic . + Added the possibility to use Troy Wolbrink's Unicode aware popup menu. Define the compiler symbol TNT to enable it. + You can get Troy's Unicode controls collection from http://home.ccci.org/wolbrink/tnt/delphi_unicode_controls.htm). + +Modified 24 Feb 2002 by Ralf Junker . + Fixed a bug where the OnAddHeaderPopupItem would interfere with poAllowHideAll options. + All column indexes now consistently use TColumnIndex (instead of Integer). + +Modified 23 Feb 2002 by Ralf Junker . + Added option to show menu items in the same order as the columns or in original order. + Added option to prevent the user to hide all columns. + +Modified 17 Feb 2002 by Jim Kueneman . + Added the event to filter the items as they are added to the menu. diff --git a/components/virtualtreeview/Source/VirtualTrees.HeaderPopup.pas b/components/virtualtreeview/Source/VirtualTrees.HeaderPopup.pas index e63357b92..351cbcec8 100644 --- a/components/virtualtreeview/Source/VirtualTrees.HeaderPopup.pas +++ b/components/virtualtreeview/Source/VirtualTrees.HeaderPopup.pas @@ -1,272 +1,275 @@ -unit VirtualTrees.HeaderPopup; - -//---------------------------------------------------------------------------------------------------------------------- -// -// Version 4.7.0 -// -// 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/ -// -// Alternatively, you may redistribute this library, use and/or modify it under the terms of the -// GNU Lesser General Public License as published by the Free Software Foundation; -// either version 2.1 of the License, or (at your option) any later version. -// You may obtain a copy of the LGPL at http://www.gnu.org/copyleft/. -// -// 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. -// -// The Original Code is VTHeaderPopup.pas. -// -// The Initial Developer of the Original Code is Ralf Junker . All Rights Reserved. -// -// September 2004: -// - Bug fix: TVTHeaderPopupMenu.OnMenuItemClick used the wrong Tag member for the event. -// -// Modified 12 Dec 2003 by Ralf Junker . -// - Added missing default storage specifier for Options property. -// - To avoid mixing up image lists of different trees sharing the same header -// popup, set the popup's image list to nil if hoShowImages is not in the -// tree's header options. -// - Added an additional check for the PopupComponent property before casting -// it hardly to a Virtual Treeview in OnMenuItemClick. See entry 31 Mar 2003. -// -// Modified 14 Sep 2003 by Mike Lischke . -// - Renamed event type name to be consistent with other event types (e.g. used in VT). -// - Added event for hiding/showing columns. -// - DoXXX method are now virtual. -// - Conditional code rearrangement to get back Ctrl+Shift+Up/Down navigation. -// -// Modified 31 Mar 2003 by Mike Lischke . -// - Added a check for the PopupComponent property before casting it hardly to -// a Virtual Treeview. People might (accidentally) misuse the header popup. -// -// Modified 20 Oct 2002 by Borut Maricic . -// - Added the possibility to use Troy Wolbrink's Unicode aware popup menu. -// Define the compiler symbol TNT to enable it. You can get Troy's Unicode -// controls collection from http://home.ccci.org/wolbrink/tnt/delphi_unicode_controls.htm. -// -// Modified 24 Feb 2002 by Ralf Junker . -// - Fixed a bug where the OnAddHeaderPopupItem would interfere with -// poAllowHideAll options. -// - All column indexes now consistently use TColumnIndex (instead of Integer). -// -// Modified 23 Feb 2002 by Ralf Junker . -// - Added option to show menu items in the same order as the columns or in -// original order. -// - Added option to prevent the user to hide all columns. -// -// Modified 17 Feb 2002 by Jim Kueneman . -// - Added the event to filter the items as they are added to the menu. -//---------------------------------------------------------------------------------------------------------------------- - -interface - -uses - System.Classes, - Vcl.Menus, - VirtualTrees; - -type - TVTHeaderPopupOption = ( - poOriginalOrder, // Show menu items in original column order as they were added to the tree. - poAllowHideAll, // Allows to hide all columns, including the last one. - poResizeToFitItem // Adds an item which, if clicks, resizes all columns to fit by callung TVTHeader.AutoFitColumns - ); - TVTHeaderPopupOptions = set of TVTHeaderPopupOption; - - TColumnChangeEvent = procedure(const Sender: TBaseVirtualTree; const Column: TColumnIndex; Visible: Boolean) of object; - - TVTHeaderPopupMenu = class(TPopupMenu) - strict private - FOptions: TVTHeaderPopupOptions; - - FOnHeaderAddPopupItem: TVTHeaderAddPopupItemEvent; - FOnColumnChange: TColumnChangeEvent; - procedure ResizeColumnToFit(Sender: TObject); - procedure ResizeToFit(Sender: TObject); - strict protected - procedure DoAddHeaderPopupItem(const Column: TColumnIndex; out Cmd: TAddPopupItemType); virtual; - procedure DoColumnChange(Column: TColumnIndex; Visible: Boolean); virtual; - procedure OnMenuItemClick(Sender: TObject); - public - constructor Create(AOwner: TComponent); override; - procedure Popup(x, y: Integer); override; - published - property Options: TVTHeaderPopupOptions read FOptions write FOptions default [poResizeToFitItem]; - - property OnAddHeaderPopupItem: TVTHeaderAddPopupItemEvent read FOnHeaderAddPopupItem write FOnHeaderAddPopupItem; - property OnColumnChange: TColumnChangeEvent read FOnColumnChange write FOnColumnChange; - end; - -//---------------------------------------------------------------------------------------------------------------------- - -implementation - -uses - Winapi.Windows, System.Types; - -resourcestring - sResizeColumnToFit = 'Size &Column to Fit'; - sResizeToFit = 'Size &All Columns to Fit'; - -type - TVTMenuItem = class(TMenuItem) - public - constructor Create(AOwner: TComponent; const ACaption: string; AClickHandler: TNotifyEvent = nil); reintroduce; - end; - -//----------------- TVTHeaderPopupMenu --------------------------------------------------------------------------------- - -constructor TVTHeaderPopupMenu.Create(AOwner: TComponent); -begin - inherited; - FOptions := [poResizeToFitItem]; -end; - -procedure TVTHeaderPopupMenu.DoAddHeaderPopupItem(const Column: TColumnIndex; out Cmd: TAddPopupItemType); - -begin - Cmd := apNormal; - if Assigned(FOnHeaderAddPopupItem) then - FOnHeaderAddPopupItem((PopupComponent as TBaseVirtualTree), Column, Cmd); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeaderPopupMenu.DoColumnChange(Column: TColumnIndex; Visible: Boolean); - -begin - if Assigned(FOnColumnChange) then - FOnColumnChange((PopupComponent as TBaseVirtualTree), Column, Visible); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeaderPopupMenu.OnMenuItemClick(Sender: TObject); - -begin - if Assigned(PopupComponent) and (PopupComponent is TBaseVirtualTree) then begin - with TBaseVirtualTree(PopupComponent).Header.Columns.Items[TVTMenuItem(Sender).Tag] do - begin - if TVTMenuItem(Sender).Checked then - Options := Options - [coVisible] - else - Options := Options + [coVisible]; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeaderPopupMenu.Popup(x, y: Integer); -var - ColPos: TColumnPosition; - ColIdx: TColumnIndex; - - NewMenuItem: TVTMenuItem; - Cmd: TAddPopupItemType; - - VisibleCounter: Cardinal; - VisibleItem: TVTMenuItem; - - i: Integer; - -begin - if Assigned(PopupComponent) and (PopupComponent is TBaseVirtualTree) then - begin - // Delete existing menu items. - for i := Items.Count -1 downto 0 do begin - if Items[i] is TVTMenuItem then - Items[i].Free; - end;//for i - - if poResizeToFitItem in Self.Options then - begin - Items.Add(TVTMenuItem.Create(Self, sResizeColumnToFit, ResizeColumnToFit)); - Items.Add(TVTMenuItem.Create(Self, sResizeToFit, ResizeToFit)); - Items.Add(TVTMenuItem.Create(Self, cLineCaption)); - end;//poResizeToFitItem - - // Add column menu items. - with (PopupComponent as TBaseVirtualTree).Header do - begin - if hoShowImages in Options then - Self.Images := Images - else - // Remove a possible reference to image list of another tree previously assigned. - Self.Images := nil; - VisibleItem := nil; - VisibleCounter := 0; - for ColPos := 0 to Columns.Count - 1 do - begin - if poOriginalOrder in FOptions then - ColIdx := ColPos - else - ColIdx := Columns.ColumnFromPosition(ColPos); - - with Columns[ColIdx] do - begin - if coVisible in Options then - Inc(VisibleCounter); - DoAddHeaderPopupItem(ColIdx, Cmd); - if Cmd <> apHidden then - begin - NewMenuItem := TVTMenuItem.Create(Self, Text, OnMenuItemClick); - NewMenuItem.Tag := ColIdx; - NewMenuItem.Caption := Text; - NewMenuItem.Hint := Hint; - NewMenuItem.ImageIndex := ImageIndex; - NewMenuItem.Checked := coVisible in Options; - if Cmd = apDisabled then - NewMenuItem.Enabled := False - else - if coVisible in Options then - VisibleItem := NewMenuItem; - Items.Add(NewMenuItem); - end; - end; - end; - - // Conditionally disable menu item of last enabled column. - if (VisibleCounter = 1) and (VisibleItem <> nil) and not (poAllowHideAll in FOptions) then - VisibleItem.Enabled := False; - end; - end; - - inherited; -end; - -procedure TVTHeaderPopupMenu.ResizeColumnToFit(Sender: TObject); -var - P: TPoint; - Column: TColumnIndex; -begin - P := Point(PopupPoint.X, PopupPoint.Y + TBaseVirtualTree(PopupComponent).Header.Height); - P := TBaseVirtualTree(PopupComponent).ScreenToClient(P); - Column := TBaseVirtualTree(PopupComponent).Header.Columns.ColumnFromPosition(P); - if Column <> InvalidColumn then - TBaseVirtualTree(PopupComponent).Header.AutoFitColumns(True, smaUseColumnOption, Column, Column); -end; - -procedure TVTHeaderPopupMenu.ResizeToFit(Sender: TObject); -begin - TBaseVirtualTree(PopupComponent).Header.AutoFitColumns(); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -{ TVTMenuItem } - -constructor TVTMenuItem.Create(AOwner: TComponent; const ACaption: string; AClickHandler: TNotifyEvent); -begin - Inherited Create(AOwner); - Caption := ACaption; - OnClick := AClickHandler; -end; - -end. - +unit VirtualTrees.HeaderPopup; + +//---------------------------------------------------------------------------------------------------------------------- +// +// Version 4.7.0 +// +// 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/ +// +// Alternatively, you may redistribute this library, use and/or modify it under the terms of the +// GNU Lesser General Public License as published by the Free Software Foundation; +// either version 2.1 of the License, or (at your option) any later version. +// You may obtain a copy of the LGPL at http://www.gnu.org/copyleft/. +// +// 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. +// +// The Original Code is VTHeaderPopup.pas. +// +// The Initial Developer of the Original Code is Ralf Junker . All Rights Reserved. +// +// September 2004: +// - Bug fix: TVTHeaderPopupMenu.OnMenuItemClick used the wrong Tag member for the event. +// +// Modified 12 Dec 2003 by Ralf Junker . +// - Added missing default storage specifier for Options property. +// - To avoid mixing up image lists of different trees sharing the same header +// popup, set the popup's image list to nil if hoShowImages is not in the +// tree's header options. +// - Added an additional check for the PopupComponent property before casting +// it hardly to a Virtual Treeview in OnMenuItemClick. See entry 31 Mar 2003. +// +// Modified 14 Sep 2003 by Mike Lischke . +// - Renamed event type name to be consistent with other event types (e.g. used in VT). +// - Added event for hiding/showing columns. +// - DoXXX method are now virtual. +// - Conditional code rearrangement to get back Ctrl+Shift+Up/Down navigation. +// +// Modified 31 Mar 2003 by Mike Lischke . +// - Added a check for the PopupComponent property before casting it hardly to +// a Virtual Treeview. People might (accidentally) misuse the header popup. +// +// Modified 20 Oct 2002 by Borut Maricic . +// - Added the possibility to use Troy Wolbrink's Unicode aware popup menu. +// Define the compiler symbol TNT to enable it. You can get Troy's Unicode +// controls collection from http://home.ccci.org/wolbrink/tnt/delphi_unicode_controls.htm. +// +// Modified 24 Feb 2002 by Ralf Junker . +// - Fixed a bug where the OnAddHeaderPopupItem would interfere with +// poAllowHideAll options. +// - All column indexes now consistently use TColumnIndex (instead of Integer). +// +// Modified 23 Feb 2002 by Ralf Junker . +// - Added option to show menu items in the same order as the columns or in +// original order. +// - Added option to prevent the user to hide all columns. +// +// Modified 17 Feb 2002 by Jim Kueneman . +// - Added the event to filter the items as they are added to the menu. +//---------------------------------------------------------------------------------------------------------------------- + +interface + +uses + System.Classes, + Vcl.Menus, + VirtualTrees.Types, + VirtualTrees.BaseTree; + +type + TVTHeaderPopupOption = ( + poOriginalOrder, // Show menu items in original column order as they were added to the tree. + poAllowHideAll, // Allows to hide all columns, including the last one. + poResizeToFitItem // Adds an item which, if clicks, resizes all columns to fit by callung TVTHeader.AutoFitColumns + ); + TVTHeaderPopupOptions = set of TVTHeaderPopupOption; + + TColumnChangeEvent = procedure(const Sender: TObject; const Column: TColumnIndex; Visible: Boolean) of object; + + TVTHeaderPopupMenu = class(TPopupMenu) + strict private + FOptions: TVTHeaderPopupOptions; + + FOnHeaderAddPopupItem: TVTHeaderAddPopupItemEvent; + FOnColumnChange: TColumnChangeEvent; + procedure ResizeColumnToFit(Sender: TObject); + procedure ResizeToFit(Sender: TObject); + strict protected + procedure DoAddHeaderPopupItem(const Column: TColumnIndex; out Cmd: TAddPopupItemType); virtual; + procedure DoColumnChange(Column: TColumnIndex; Visible: Boolean); virtual; + procedure OnMenuItemClick(Sender: TObject); virtual; + public + constructor Create(AOwner: TComponent); override; + procedure Popup(x, y: TDimension); override; + published + property Options: TVTHeaderPopupOptions read FOptions write FOptions default [poResizeToFitItem]; + + property OnAddHeaderPopupItem: TVTHeaderAddPopupItemEvent read FOnHeaderAddPopupItem write FOnHeaderAddPopupItem; + property OnColumnChange: TColumnChangeEvent read FOnColumnChange write FOnColumnChange; + end; + +//---------------------------------------------------------------------------------------------------------------------- + +implementation + +uses + Winapi.Windows, + System.Types, + VirtualTrees.Header; + +resourcestring + sResizeColumnToFit = 'Size &Column to Fit'; + sResizeToFit = 'Size &All Columns to Fit'; + +type + TVTMenuItem = class(TMenuItem) + public + constructor Create(AOwner: TComponent; const ACaption: string; AClickHandler: TNotifyEvent = nil); reintroduce; + end; + +//----------------- TVTHeaderPopupMenu --------------------------------------------------------------------------------- + +constructor TVTHeaderPopupMenu.Create(AOwner: TComponent); +begin + inherited; + FOptions := [poResizeToFitItem]; +end; + +procedure TVTHeaderPopupMenu.DoAddHeaderPopupItem(const Column: TColumnIndex; out Cmd: TAddPopupItemType); + +begin + Cmd := apNormal; + if Assigned(FOnHeaderAddPopupItem) then + FOnHeaderAddPopupItem((PopupComponent as TBaseVirtualTree), Column, Cmd); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeaderPopupMenu.DoColumnChange(Column: TColumnIndex; Visible: Boolean); + +begin + if Assigned(FOnColumnChange) then + FOnColumnChange((PopupComponent as TBaseVirtualTree), Column, Visible); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeaderPopupMenu.OnMenuItemClick(Sender: TObject); + +begin + if Assigned(PopupComponent) and (PopupComponent is TBaseVirtualTree) then begin + with TBaseVirtualTree(PopupComponent).Header.Columns.Items[TVTMenuItem(Sender).Tag] do + begin + if TVTMenuItem(Sender).Checked then + Options := Options - [coVisible] + else + Options := Options + [coVisible]; + DoColumnChange(TVTMenuItem(Sender).Tag, coVisible in Options); + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeaderPopupMenu.Popup(x, y: TDimension); +var + ColPos: TColumnPosition; + ColIdx: TColumnIndex; + + NewMenuItem: TVTMenuItem; + Cmd: TAddPopupItemType; + + VisibleCounter: Cardinal; + VisibleItem: TVTMenuItem; + + i: Integer; + +begin + if Assigned(PopupComponent) and (PopupComponent is TBaseVirtualTree) then + begin + // Delete existing menu items. + for i := Items.Count -1 downto 0 do begin + if Items[i] is TVTMenuItem then + Items[i].Free; + end;//for i + + if poResizeToFitItem in Self.Options then + begin + Items.Add(TVTMenuItem.Create(Self, sResizeColumnToFit, ResizeColumnToFit)); + Items.Add(TVTMenuItem.Create(Self, sResizeToFit, ResizeToFit)); + Items.Add(TVTMenuItem.Create(Self, cLineCaption)); + end;//poResizeToFitItem + + // Add column menu items. + with (PopupComponent as TBaseVirtualTree).Header do + begin + if hoShowImages in Options then + Self.Images := Images + else + // Remove a possible reference to image list of another tree previously assigned. + Self.Images := nil; + VisibleItem := nil; + VisibleCounter := 0; + for ColPos := 0 to Columns.Count - 1 do + begin + if poOriginalOrder in FOptions then + ColIdx := ColPos + else + ColIdx := Columns.ColumnFromPosition(ColPos); + + with Columns[ColIdx] do + begin + if coVisible in Options then + System.Inc(VisibleCounter); + DoAddHeaderPopupItem(ColIdx, Cmd); + if Cmd <> apHidden then + begin + NewMenuItem := TVTMenuItem.Create(Self, Text, OnMenuItemClick); + NewMenuItem.Tag := ColIdx; + NewMenuItem.Caption := Text; + NewMenuItem.Hint := Hint; + NewMenuItem.ImageIndex := ImageIndex; + NewMenuItem.Checked := coVisible in Options; + if Cmd = apDisabled then + NewMenuItem.Enabled := False + else + if coVisible in Options then + VisibleItem := NewMenuItem; + Items.Add(NewMenuItem); + end; + end; + end; + + // Conditionally disable menu item of last enabled column. + if (VisibleCounter = 1) and (VisibleItem <> nil) and not (poAllowHideAll in FOptions) then + VisibleItem.Enabled := False; + end; + end; + + inherited; +end; + +procedure TVTHeaderPopupMenu.ResizeColumnToFit(Sender: TObject); +var + P: TPoint; + Column: TColumnIndex; +begin + P := Point(PopupPoint.X, PopupPoint.Y + TBaseVirtualTree(PopupComponent).Header.Height); + P := TBaseVirtualTree(PopupComponent).ScreenToClient(P); + Column := TBaseVirtualTree(PopupComponent).Header.Columns.ColumnFromPosition(P); + if Column <> InvalidColumn then + TBaseVirtualTree(PopupComponent).Header.AutoFitColumns(True, smaUseColumnOption, Column, Column); +end; + +procedure TVTHeaderPopupMenu.ResizeToFit(Sender: TObject); +begin + TBaseVirtualTree(PopupComponent).Header.AutoFitColumns(); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +{ TVTMenuItem } + +constructor TVTMenuItem.Create(AOwner: TComponent; const ACaption: string; AClickHandler: TNotifyEvent); +begin + Inherited Create(AOwner); + Caption := ACaption; + OnClick := AClickHandler; +end; + +end. diff --git a/components/virtualtreeview/Source/VirtualTrees.StyleHooks.pas b/components/virtualtreeview/Source/VirtualTrees.StyleHooks.pas index 41b727e82..0f9bbd52e 100644 --- a/components/virtualtreeview/Source/VirtualTrees.StyleHooks.pas +++ b/components/virtualtreeview/Source/VirtualTrees.StyleHooks.pas @@ -1,937 +1,1092 @@ -unit VirtualTrees.StyleHooks; - -// 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/ -// -// Alternatively, you may redistribute this library, use and/or modify it under the terms of the -// GNU Lesser General Public License as published by the Free Software Foundation; -// either version 2.1 of the License, or (at your option) any later version. -// You may obtain a copy of the LGPL at http://www.gnu.org/copyleft/. -// -// 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. -// -// The original code is VirtualTrees.pas, released September 30, 2000. -// -// The initial developer of the original code is digital publishing AG (Munich, Germany, www.digitalpublishing.de), -// written by Mike Lischke (public@soft-gems.net, www.soft-gems.net). -// -// Portions created by digital publishing AG are Copyright -// (C) 1999-2001 digital publishing AG. All Rights Reserved. -//---------------------------------------------------------------------------------------------------------------------- - - -interface - -{$WARN UNSAFE_TYPE OFF} -{$WARN UNSAFE_CAST OFF} -{$WARN UNSAFE_CODE OFF} - -uses - Winapi.Windows, - Winapi.Messages, - Winapi.UxTheme, - - System.Classes, - Vcl.Themes, - Vcl.Forms, - Vcl.Controls; - -const - CM_UPDATE_VCLSTYLE_SCROLLBARS = CM_BASE + 2050; - -type - // XE2+ VCL Style - TVclStyleScrollBarsHook = class(TScrollingStyleHook) - strict private type - {$REGION 'TVclStyleScrollBarWindow'} - TScrollWindow = class(TWinControl) - strict private - FStyleHook: TVclStyleScrollBarsHook; - FVertical: Boolean; - procedure WMNCHitTest(var Msg: TWMNCHitTest); message WM_NCHITTEST; - procedure WMEraseBkgnd(var Msg: TMessage); message WM_ERASEBKGND; - procedure WMPaint(var Msg: TWMPaint); message WM_PAINT; - public - constructor Create(AOwner: TComponent); override; - property StyleHook: TVclStyleScrollBarsHook read FStyleHook write FStyleHook; - property Vertical: Boolean read FVertical write FVertical; - end; - {$ENDREGION} - private - FHorzScrollWnd: TScrollWindow; - FLeftMouseButtonDown: Boolean; - FVertScrollWnd: TScrollWindow; - - function NCMousePosToClient(const P: TPoint): TPoint; - - procedure CMUpdateVclStyleScrollbars(var Msg: TMessage); message CM_UPDATE_VCLSTYLE_SCROLLBARS; - procedure WMEraseBkgnd(var Msg: TWMEraseBkgnd); message WM_ERASEBKGND; - procedure WMKeyDown(var Msg: TMessage); message WM_KEYDOWN; - procedure WMKeyUp(var Msg: TMessage); message WM_KEYUP; - procedure WMLButtonDown(var Msg: TWMMouse); message WM_LBUTTONDOWN; - procedure WMLButtonUp(var Msg: TWMMouse); message WM_LBUTTONUP; - procedure WMNCLButtonDown(var Msg: TWMMouse); message WM_NCLBUTTONDOWN; - procedure WMNCMouseMove(var Msg: TWMMouse); message WM_NCMOUSEMOVE; - procedure WMNCLButtonUp(var Msg: TWMMouse); message WM_NCLBUTTONUP; - procedure WMNCPaint(var Msg: TMessage); message WM_NCPAINT; - procedure WMMouseMove(var Msg: TWMMouse); message WM_MOUSEMOVE; - procedure WMMouseWheel(var Msg: TMessage); message WM_MOUSEWHEEL; - procedure WMVScroll(var Msg: TWMVScroll); message WM_VSCROLL; - procedure WMHScroll(var Msg: TWMHScroll); message WM_HSCROLL; - procedure WMCaptureChanged(var Msg: TMessage); message WM_CAPTURECHANGED; - procedure WMNCLButtonDblClk(var Msg: TWMMouse); message WM_NCLBUTTONDBLCLK; - procedure WMSize(var Msg: TMessage); message WM_SIZE; - procedure WMMove(var Msg: TMessage); message WM_MOVE; - procedure WMPosChanged(var Msg: TMessage); message WM_WINDOWPOSCHANGED; - protected - procedure CalcScrollBarsRect; virtual; - procedure DrawHorzScrollBar(DC: HDC); virtual; - procedure DrawVertScrollBar(DC: HDC); virtual; - procedure MouseLeave; override; - procedure PaintScroll; override; - function PointInTreeHeader(const P: TPoint): Boolean; - procedure UpdateScroll;{$if CompilerVersion >= 34}override;{$ifend} - public - constructor Create(AControl: TWinControl); override; - destructor Destroy; override; - property HorzScrollRect; - property VertScrollRect; - end; - -implementation - -uses - System.SysUtils, - System.Math, - System.Types, - Vcl.Graphics, - VirtualTrees; - -type - TBaseVirtualTreeCracker = class(TBaseVirtualTree) - end; - - -// XE2+ VCL Style -{ TVclStyleScrollBarsHook } - -procedure TVclStyleScrollBarsHook.CalcScrollBarsRect; - - procedure CalcVerticalRects; - var - BarInfo: TScrollBarInfo; - Ret: BOOL; - begin - BarInfo.cbSize := SizeOf(BarInfo); - Ret := GetScrollBarInfo(Handle, Integer(OBJID_VSCROLL), BarInfo); - FVertScrollWnd.Visible := (seBorder in Control.StyleElements) and Ret and (not (STATE_SYSTEM_INVISIBLE and BarInfo.rgstate[0] <> 0)); - FVertScrollWnd.Enabled := FVertScrollWnd.Visible and (not (STATE_SYSTEM_UNAVAILABLE and BarInfo.rgstate[0] <> 0)); - end; - - procedure CalcHorizontalRects; - var - BarInfo: TScrollBarInfo; - Ret: BOOL; - begin - BarInfo.cbSize := SizeOf(BarInfo); - Ret := GetScrollBarInfo(Handle, Integer(OBJID_HSCROLL), BarInfo); - FHorzScrollWnd.Visible := (seBorder in Control.StyleElements) and Ret and (not (STATE_SYSTEM_INVISIBLE and BarInfo.rgstate[0] <> 0)); - FHorzScrollWnd.Enabled := FHorzScrollWnd.Visible and (not (STATE_SYSTEM_UNAVAILABLE and BarInfo.rgstate[0] <> 0)); - end; - -begin - CalcVerticalRects; - CalcHorizontalRects; -end; - -constructor TVclStyleScrollBarsHook.Create(AControl: TWinControl); -begin - inherited; - FVertScrollWnd := TScrollWindow.CreateParented(GetParent(Control.Handle)); - FVertScrollWnd.StyleHook := Self; - FVertScrollWnd.Vertical := True; - - FHorzScrollWnd := TScrollWindow.CreateParented(GetParent(Control.Handle)); - FHorzScrollWnd.StyleHook := Self; - - VertSliderState := tsThumbBtnVertNormal; - VertUpState := tsArrowBtnUpNormal; - VertDownState := tsArrowBtnDownNormal; - HorzSliderState := tsThumbBtnHorzNormal; - HorzUpState := tsArrowBtnLeftNormal; - HorzDownState := tsArrowBtnRightNormal; -end; - -destructor TVclStyleScrollBarsHook.Destroy; -begin - FVertScrollWnd.StyleHook := nil; - FreeAndNil(FVertScrollWnd); - FHorzScrollWnd.StyleHook := nil; - FreeAndNil(FHorzScrollWnd); - inherited; -end; - -procedure TVclStyleScrollBarsHook.DrawHorzScrollBar(DC: HDC); -var - B: TBitmap; - Details: TThemedElementDetails; - R: TRect; -begin - if ((Handle = 0) or (DC = 0)) then - Exit; - - if FHorzScrollWnd.Visible and StyleServices.Available and (seBorder in Control.StyleElements) then - begin - B := TBitmap.Create; - try - R := HorzScrollRect; - B.Width := R.Width; - B.Height := R.Height; - MoveWindowOrg(B.Canvas.Handle, -R.Left, -R.Top); - - R.Left := HorzUpButtonRect.Right; - R.Right := HorzDownButtonRect.Left; - Details := StyleServices.GetElementDetails(tsUpperTrackHorzNormal); - StyleServices.DrawElement(B.Canvas.Handle, Details, R); - - if FHorzScrollWnd.Enabled then - Details := StyleServices.GetElementDetails(HorzSliderState); - StyleServices.DrawElement(B.Canvas.Handle, Details, HorzSliderRect); - - if FHorzScrollWnd.Enabled then - Details := StyleServices.GetElementDetails(HorzUpState) - else - Details := StyleServices.GetElementDetails(tsArrowBtnLeftDisabled); - StyleServices.DrawElement(B.Canvas.Handle, Details, HorzUpButtonRect); - - if FHorzScrollWnd.Enabled then - Details := StyleServices.GetElementDetails(HorzDownState) - else - Details := StyleServices.GetElementDetails(tsArrowBtnRightDisabled); - StyleServices.DrawElement(B.Canvas.Handle, Details, HorzDownButtonRect); - - R := HorzScrollRect; - MoveWindowOrg(B.Canvas.Handle, R.Left, R.Top); - BitBlt(DC, R.Left, R.Top, B.Width, B.Height, B.Canvas.Handle, 0, 0, SRCCOPY); - finally - B.Free; - end; - end; -end; - -procedure TVclStyleScrollBarsHook.DrawVertScrollBar(DC: HDC); -var - B: TBitmap; - Details: TThemedElementDetails; - R: TRect; -begin - if ((Handle = 0) or (DC = 0)) then - Exit; - - if FVertScrollWnd.Visible and StyleServices.Available and (seBorder in Control.StyleElements) then - begin - B := TBitmap.Create; - try - R := VertScrollRect; - B.Width := R.Width; - B.Height := FVertScrollWnd.Height; // <> R.Height - MoveWindowOrg(B.Canvas.Handle, -R.Left, -R.Top); - - R.Bottom := B.Height + R.Top; - Details := StyleServices.GetElementDetails(tsUpperTrackVertNormal); - StyleServices.DrawElement(B.Canvas.Handle, Details, R); - - R.Top := VertUpButtonRect.Bottom; - R.Bottom := VertDownButtonRect.Top; - Details := StyleServices.GetElementDetails(tsUpperTrackVertNormal); - StyleServices.DrawElement(B.Canvas.Handle, Details, R); - - if FVertScrollWnd.Enabled then - Details := StyleServices.GetElementDetails(VertSliderState); - StyleServices.DrawElement(B.Canvas.Handle, Details, VertSliderRect); - - if FVertScrollWnd.Enabled then - Details := StyleServices.GetElementDetails(VertUpState) - else - Details := StyleServices.GetElementDetails(tsArrowBtnUpDisabled); - StyleServices.DrawElement(B.Canvas.Handle, Details, VertUpButtonRect); - - if FVertScrollWnd.Enabled then - Details := StyleServices.GetElementDetails(VertDownState) - else - Details := StyleServices.GetElementDetails(tsArrowBtnDownDisabled); - StyleServices.DrawElement(B.Canvas.Handle, Details, VertDownButtonRect); - - R := VertScrollRect; - MoveWindowOrg(B.Canvas.Handle, R.Left, R.Top); - BitBlt(DC, R.Left, R.Top, B.Width, B.Height, B.Canvas.Handle, 0, 0, SRCCOPY); - finally - B.Free; - end; - end; -end; - -procedure TVclStyleScrollBarsHook.MouseLeave; -begin - inherited; - if VertSliderState = tsThumbBtnVertHot then - VertSliderState := tsThumbBtnVertNormal; - - if HorzSliderState = tsThumbBtnHorzHot then - HorzSliderState := tsThumbBtnHorzNormal; - - if VertUpState = tsArrowBtnUpHot then - VertUpState := tsArrowBtnUpNormal; - - if VertDownState = tsArrowBtnDownHot then - VertDownState := tsArrowBtnDownNormal; - - if HorzUpState = tsArrowBtnLeftHot then - HorzUpState := tsArrowBtnLeftNormal; - - if HorzDownState = tsArrowBtnRightHot then - HorzDownState := tsArrowBtnRightNormal; - - PaintScroll; -end; - -function TVclStyleScrollBarsHook.NCMousePosToClient(const P: TPoint): TPoint; -begin - Result := P; - ScreenToClient(Handle, Result); - if HasBorder then - begin - if HasClientEdge then - Result.Offset(2, 2) - else - Result.Offset(1, 1); - end; -end; - -procedure TVclStyleScrollBarsHook.PaintScroll; -begin - if FVertScrollWnd.HandleAllocated then - begin - FVertScrollWnd.Repaint; - RedrawWindow(FVertScrollWnd.Handle, nil, 0, RDW_FRAME or RDW_INVALIDATE); // Fixes issue #698 - end; - if FHorzScrollWnd.HandleAllocated then - begin - FHorzScrollWnd.Repaint; - RedrawWindow(FHorzScrollWnd.Handle, nil, 0, RDW_FRAME or RDW_INVALIDATE); // Fixes issue #698 - end; -end; - -function TVclStyleScrollBarsHook.PointInTreeHeader(const P: TPoint): Boolean; -begin - Result := TBaseVirtualTree(Control).Header.InHeader(P); -end; - -procedure TVclStyleScrollBarsHook.UpdateScroll; -var - R: TRect; - HeaderHeight: Integer; - PaddingSize: Integer; - BorderSize: Integer; -begin - // ScrollBarWindow Visible/Enabled Control - CalcScrollBarsRect; - - HeaderHeight := 0; - if (hoVisible in TBaseVirtualTree(Control).Header.Options) then - Inc(HeaderHeight, TBaseVirtualTree(Control).Header.Height); - - PaddingSize := TBaseVirtualTreeCracker(Control).BorderWidth; - if TBaseVirtualTreeCracker(Control).BevelKind <> bkNone then - begin - if TBaseVirtualTreeCracker(Control).BevelInner <> bvNone then - Inc(PaddingSize, TBaseVirtualTreeCracker(Control).BevelWidth); - if TBaseVirtualTreeCracker(Control).BevelOuter <> bvNone then - Inc(PaddingSize, TBaseVirtualTreeCracker(Control).BevelWidth); - end; - - BorderSize := 0; - if HasBorder then - Inc(BorderSize, GetSystemMetrics(SM_CYEDGE)); - - // VertScrollBarWindow - if FVertScrollWnd.Visible then - begin - R := VertScrollRect; - if Control.UseRightToLeftScrollBar then - OffsetRect(R, -R.Left + BorderSize, 0); - - ShowWindow(FVertScrollWnd.Handle, SW_SHOW); - SetWindowPos(FVertScrollWnd.Handle, HWND_TOP, - Control.Left + R.Left + PaddingSize, - Control.Top + R.Top + HeaderHeight + PaddingSize, - R.Width, - Control.Height - HeaderHeight - ((PaddingSize + BorderSize) * 2), // <> R.Height - SWP_SHOWWINDOW); - end else - ShowWindow(FVertScrollWnd.Handle, SW_HIDE); - - // HorzScrollBarWindow - if FHorzScrollWnd.Visible then - begin - R := HorzScrollRect; - if Control.UseRightToLeftScrollBar then - OffsetRect(R, VertScrollRect.Width, 0); - - ShowWindow(FHorzScrollWnd.Handle, SW_SHOW); - SetWindowPos(FHorzScrollWnd.Handle, HWND_TOP, - Control.Left + R.Left + PaddingSize, - Control.Top + R.Top + HeaderHeight + PaddingSize, - R.Width, R.Height, SWP_SHOWWINDOW); - end else - ShowWindow(FHorzScrollWnd.Handle, SW_HIDE); -end; - -procedure TVclStyleScrollBarsHook.WMCaptureChanged(var Msg: TMessage); -begin - if FVertScrollWnd.Visible and FVertScrollWnd.Enabled then - begin - if VertUpState = tsArrowBtnUpPressed then - begin - VertUpState := tsArrowBtnUpNormal; - PaintScroll; - end; - - if VertDownState = tsArrowBtnDownPressed then - begin - VertDownState := tsArrowBtnDownNormal; - PaintScroll; - end; - end; - - if FHorzScrollWnd.Visible and FHorzScrollWnd.Enabled then - begin - if HorzUpState = tsArrowBtnLeftPressed then - begin - HorzUpState := tsArrowBtnLeftNormal; - PaintScroll; - end; - - if HorzDownState = tsArrowBtnRightPressed then - begin - HorzDownState := tsArrowBtnRightNormal; - PaintScroll; - end; - end; - - CallDefaultProc(TMessage(Msg)); - Handled := True; -end; - -procedure TVclStyleScrollBarsHook.WMEraseBkgnd(var Msg: TWMEraseBkgnd); -begin - Handled := True; -end; - -procedure TVclStyleScrollBarsHook.WMHScroll(var Msg: TWMHScroll); -begin - CallDefaultProc(TMessage(Msg)); - if not (Msg.ScrollCode in [SB_THUMBTRACK, SB_THUMBPOSITION]) then - UpdateScroll - else - PaintScroll; - Handled := True; -end; - -procedure TVclStyleScrollBarsHook.CMUpdateVclStyleScrollbars(var Msg: TMessage); -begin - CalcScrollBarsRect; - PaintScroll; -end; - -procedure TVclStyleScrollBarsHook.WMKeyDown(var Msg: TMessage); -begin - CallDefaultProc(TMessage(Msg)); - UpdateScroll; - Handled := True; -end; - -procedure TVclStyleScrollBarsHook.WMKeyUp(var Msg: TMessage); -begin - CallDefaultProc(TMessage(Msg)); - PaintScroll; - Handled := True; -end; - -procedure TVclStyleScrollBarsHook.WMLButtonDown(var Msg: TWMMouse); -begin - CallDefaultProc(TMessage(Msg)); - UpdateScroll; - Handled := True; -end; - -procedure TVclStyleScrollBarsHook.WMLButtonUp(var Msg: TWMMouse); -var - P: TPoint; -begin - P := Point(Msg.XPos, Msg.YPos); - ScreenToClient(Handle, P); - if not PointInTreeHeader(P) then - begin - if FVertScrollWnd.Visible then - begin - if VertSliderState = tsThumbBtnVertPressed then - begin - PostMessage(Handle, WM_VSCROLL, Integer(SmallPoint(SB_ENDSCROLL, 0)), 0); - FLeftMouseButtonDown := False; - VertSliderState := tsThumbBtnVertNormal; - PaintScroll; - Handled := True; - Mouse.Capture := 0; - Exit; - end else - if VertUpState = tsArrowBtnUpPressed then - VertUpState := tsArrowBtnUpNormal - else if VertDownState = tsArrowBtnDownPressed then - VertDownState := tsArrowBtnDownNormal; - end; - - if FHorzScrollWnd.Visible then - begin - if HorzSliderState = tsThumbBtnHorzPressed then - begin - PostMessage(Handle, WM_HSCROLL, Integer(SmallPoint(SB_ENDSCROLL, 0)), 0); - FLeftMouseButtonDown := False; - HorzSliderState := tsThumbBtnHorzNormal; - PaintScroll; - Handled := True; - Mouse.Capture := 0; - Exit; - end else - if HorzUpState = tsArrowBtnLeftPressed then - HorzUpState := tsArrowBtnLeftNormal - else if HorzDownState = tsArrowBtnRightPressed then - HorzDownState := tsArrowBtnRightNormal; - end; - PaintScroll; - end; - FLeftMouseButtonDown := False; -end; - -procedure TVclStyleScrollBarsHook.WMMouseMove(var Msg: TWMMouse); -var - SF: TScrollInfo; - OverrideMax: Integer; -begin - if VertSliderState = tsThumbBtnVertPressed then - begin - SF.fMask := SIF_ALL; - SF.cbSize := SizeOf(SF); - GetScrollInfo(Handle, SB_VERT, SF); - - OverrideMax := SF.nMax; - if 0 < SF.nPage then - OverrideMax := SF.nMax - Integer(SF.nPage) + 1; - ScrollPos := System.Math.EnsureRange(ListPos + (OverrideMax - SF.nMin) * ((Mouse.CursorPos.Y - PrevScrollPos) / (VertTrackRect.Height - VertSliderRect.Height)), - SF.nMin, OverrideMax); - SF.fMask := SIF_POS; - SF.nPos := Round(ScrollPos); - SetScrollInfo(Handle, SB_VERT, SF, False); - PostMessage(Handle, WM_VSCROLL, Integer(SmallPoint(SB_THUMBPOSITION, Min(SF.nPos, High(SmallInt)))), 0); - - PaintScroll; - Handled := True; - Exit; - end else - if VertSliderState = tsThumbBtnVertHot then - begin - VertSliderState := tsThumbBtnVertNormal; - PaintScroll; - end; - - if HorzSliderState = tsThumbBtnHorzPressed then - begin - SF.fMask := SIF_ALL; - SF.cbSize := SizeOf(SF); - GetScrollInfo(Handle, SB_HORZ, SF); - - OverrideMax := SF.nMax; - if 0 < SF.nPage then - OverrideMax := SF.nMax - Integer(SF.nPage) + 1; - ScrollPos := System.Math.EnsureRange(ListPos + (OverrideMax - SF.nMin) * ((Mouse.CursorPos.X - PrevScrollPos) / (HorzTrackRect.Width - HorzSliderRect.Width)), - SF.nMin, OverrideMax); - SF.fMask := SIF_POS; - SF.nPos := Round(ScrollPos); - SetScrollInfo(Handle, SB_HORZ, SF, False); - PostMessage(Handle, WM_HSCROLL, Integer(SmallPoint(SB_THUMBPOSITION, Min(SF.nPos, High(SmallInt)))), 0); - - PaintScroll; - Handled := True; - Exit; - end else - if HorzSliderState = tsThumbBtnHorzHot then - begin - HorzSliderState := tsThumbBtnHorzNormal; - PaintScroll; - end; - - if (HorzUpState <> tsArrowBtnLeftPressed) and (HorzUpState = tsArrowBtnLeftHot) then - begin - HorzUpState := tsArrowBtnLeftNormal; - PaintScroll; - end; - - if (HorzDownState <> tsArrowBtnRightPressed) and (HorzDownState = tsArrowBtnRightHot) then - begin - HorzDownState := tsArrowBtnRightNormal; - PaintScroll; - end; - - if (VertUpState <> tsArrowBtnUpPressed) and (VertUpState = tsArrowBtnUpHot) then - begin - VertUpState := tsArrowBtnUpNormal; - PaintScroll; - end; - - if (VertDownState <> tsArrowBtnDownPressed) and (VertDownState = tsArrowBtnDownHot) then - begin - VertDownState := tsArrowBtnDownNormal; - PaintScroll; - end; - - CallDefaultProc(TMessage(Msg)); - if FLeftMouseButtonDown then - PaintScroll; - Handled := True; -end; - -procedure TVclStyleScrollBarsHook.WMMouseWheel(var Msg: TMessage); -begin - CallDefaultProc(TMessage(Msg)); - CalcScrollBarsRect; - PaintScroll; - Handled := True; -end; - -procedure TVclStyleScrollBarsHook.WMNCLButtonDblClk(var Msg: TWMMouse); -begin - WMNCLButtonDown(Msg); -end; - -procedure TVclStyleScrollBarsHook.WMNCLButtonDown(var Msg: TWMMouse); -var - P: TPoint; - SF: TScrollInfo; -begin - P := NCMousePosToClient(Point(Msg.XPos, Msg.YPos)); - if not PointInTreeHeader(P) then - begin - if FVertScrollWnd.Visible and FVertScrollWnd.Enabled then - begin - if PtInRect(VertSliderRect, P) then - begin - FLeftMouseButtonDown := True; - SF.fMask := SIF_ALL; - SF.cbSize := SizeOf(SF); - GetScrollInfo(Handle, SB_VERT, SF); - ListPos := SF.nPos; - ScrollPos := SF.nPos; - PrevScrollPos := Mouse.CursorPos.Y; - VertSliderState := tsThumbBtnVertPressed; - PaintScroll; - Mouse.Capture := Handle; - Handled := True; - Exit; - end else - if PtInRect(VertDownButtonRect, P) then - VertDownState := tsArrowBtnDownPressed - else if PtInRect(VertUpButtonRect, P) then - VertUpState := tsArrowBtnUpPressed; - end; - - if FHorzScrollWnd.Visible and FHorzScrollWnd.Enabled then - begin - if PtInRect(HorzSliderRect, P) then - begin - FLeftMouseButtonDown := True; - SF.fMask := SIF_ALL; - SF.cbSize := SizeOf(SF); - GetScrollInfo(Handle, SB_HORZ, SF); - ListPos := SF.nPos; - ScrollPos := SF.nPos; - PrevScrollPos := Mouse.CursorPos.X; - HorzSliderState := tsThumbBtnHorzPressed; - PaintScroll; - Mouse.Capture := Handle; - Handled := True; - Exit; - end else - if PtInRect(HorzDownButtonRect, P) then - HorzDownState := tsArrowBtnRightPressed - else if PtInRect(HorzUpButtonRect, P) then - HorzUpState := tsArrowBtnLeftPressed; - end; - FLeftMouseButtonDown := True; - PaintScroll; - end; -end; - -procedure TVclStyleScrollBarsHook.WMNCLButtonUp(var Msg: TWMMouse); -var - P: TPoint; -begin - P := NCMousePosToClient(Point(Msg.XPos, Msg.YPos)); - if not PointInTreeHeader(P) then - begin - if FVertScrollWnd.Visible and FVertScrollWnd.Enabled then - begin - if VertSliderState = tsThumbBtnVertPressed then - begin - FLeftMouseButtonDown := False; - VertSliderState := tsThumbBtnVertNormal; - PaintScroll; - Handled := True; - Exit; - end; - - if PtInRect(VertDownButtonRect, P) then - VertDownState := tsArrowBtnDownHot - else - VertDownState := tsArrowBtnDownNormal; - - if PtInRect(VertUpButtonRect, P) then - VertUpState := tsArrowBtnUpHot - else - VertUpState := tsArrowBtnUpNormal; - end; - - if FHorzScrollWnd.Visible and FHorzScrollWnd.Enabled then - begin - if HorzSliderState = tsThumbBtnHorzPressed then - begin - FLeftMouseButtonDown := False; - HorzSliderState := tsThumbBtnHorzNormal; - PaintScroll; - Handled := True; - Exit; - end; - - if PtInRect(HorzDownButtonRect, P) then - HorzDownState := tsArrowBtnRightHot - else - HorzDownState := tsArrowBtnRightNormal; - - if PtInRect(HorzUpButtonRect, P) then - HorzUpState := tsArrowBtnLeftHot - else - HorzUpState := tsArrowBtnLeftNormal; - end; - - CallDefaultProc(TMessage(Msg)); - if (FHorzScrollWnd.Visible) or (FVertScrollWnd.Visible) then - PaintScroll; - end; - - Handled := True; -end; - -procedure TVclStyleScrollBarsHook.WMNCMouseMove(var Msg: TWMMouse); -var - P: TPoint; - MustUpdateScroll: Boolean; - B: Boolean; -begin - inherited; - P := NCMousePosToClient(Point(Msg.XPos, Msg.YPos)); - if PointInTreeHeader(P) then - begin - CallDefaultProc(TMessage(Msg)); - PaintScroll; - Handled := True; - Exit; - end; - - MustUpdateScroll := False; - if FVertScrollWnd.Visible and FVertScrollWnd.Enabled then - begin - B := PtInRect(VertSliderRect, P); - if B and (VertSliderState = tsThumbBtnVertNormal) then - begin - VertSliderState := tsThumbBtnVertHot; - MustUpdateScroll := True; - end else - if not B and (VertSliderState = tsThumbBtnVertHot) then - begin - VertSliderState := tsThumbBtnVertNormal; - MustUpdateScroll := True; - end; - - B := PtInRect(VertDownButtonRect, P); - if B and (VertDownState = tsArrowBtnDownNormal) then - begin - VertDownState := tsArrowBtnDownHot; - MustUpdateScroll := True; - end else - if not B and (VertDownState = tsArrowBtnDownHot) then - begin - VertDownState := tsArrowBtnDownNormal; - MustUpdateScroll := True; - end; - - B := PtInRect(VertUpButtonRect, P); - if B and (VertUpState = tsArrowBtnUpNormal) then - begin - VertUpState := tsArrowBtnUpHot; - MustUpdateScroll := True; - end else - if not B and (VertUpState = tsArrowBtnUpHot) then - begin - VertUpState := tsArrowBtnUpNormal; - MustUpdateScroll := True; - end; - end; - - if FHorzScrollWnd.Visible and FHorzScrollWnd.Enabled then - begin - B := PtInRect(HorzSliderRect, P); - if B and (HorzSliderState = tsThumbBtnHorzNormal) then - begin - HorzSliderState := tsThumbBtnHorzHot; - MustUpdateScroll := True; - end else - if not B and (HorzSliderState = tsThumbBtnHorzHot) then - begin - HorzSliderState := tsThumbBtnHorzNormal; - MustUpdateScroll := True; - end; - - B := PtInRect(HorzDownButtonRect, P); - if B and (HorzDownState = tsArrowBtnRightNormal) then - begin - HorzDownState := tsArrowBtnRightHot; - MustUpdateScroll := True; - end else - if not B and (HorzDownState = tsArrowBtnRightHot) then - begin - HorzDownState := tsArrowBtnRightNormal; - MustUpdateScroll := True; - end; - - B := PtInRect(HorzUpButtonRect, P); - if B and (HorzUpState = tsArrowBtnLeftNormal) then - begin - HorzUpState := tsArrowBtnLeftHot; - MustUpdateScroll := True; - end else - if not B and (HorzUpState = tsArrowBtnLeftHot) then - begin - HorzUpState := tsArrowBtnLeftNormal; - MustUpdateScroll := True; - end; - end; - - if MustUpdateScroll then - PaintScroll; -end; - -procedure TVclStyleScrollBarsHook.WMNCPaint(var Msg: TMessage); -begin - //if (tsWindowCreating in TBaseVirtualTree(Control).TreeStates) then - // UpdateScrollBarWindow; - //inherited; -end; - -procedure TVclStyleScrollBarsHook.WMSize(var Msg: TMessage); -begin - CallDefaultProc(TMessage(Msg)); - UpdateScroll; - PaintScroll; - Handled := True; -end; - -procedure TVclStyleScrollBarsHook.WMMove(var Msg: TMessage); -begin - CallDefaultProc(TMessage(Msg)); - if not(tsWindowCreating in TBaseVirtualTree(Control).TreeStates) then - begin - UpdateScroll; - PaintScroll; - end; - Handled := True; -end; - -procedure TVclStyleScrollBarsHook.WMPosChanged(var Msg: TMessage); -begin - WMMove(Msg); -end; - -procedure TVclStyleScrollBarsHook.WMVScroll(var Msg: TWMVScroll); -begin - CallDefaultProc(TMessage(Msg)); - if not (Msg.ScrollCode in [SB_THUMBTRACK, SB_THUMBPOSITION]) then - UpdateScroll - else - PaintScroll; - Handled := True; -end; - -{ TVclStyleScrollBarsHook.TVclStyleScrollBarWindow } - -constructor TVclStyleScrollBarsHook.TScrollWindow.Create(AOwner: TComponent); -begin - inherited; - ControlStyle := ControlStyle + [csOverrideStylePaint]; - FStyleHook := nil; - FVertical := False; -end; - -procedure TVclStyleScrollBarsHook.TScrollWindow.WMEraseBkgnd(var Msg: TMessage); -begin - Msg.Result := 1; -end; - -procedure TVclStyleScrollBarsHook.TScrollWindow.WMNCHitTest(var Msg: TWMNCHitTest); -begin - Msg.Result := HTTRANSPARENT; -end; - -procedure TVclStyleScrollBarsHook.TScrollWindow.WMPaint(var Msg: TWMPaint); -var - PS: TPaintStruct; - DC: HDC; - R: TRect; -begin - BeginPaint(Handle, PS); - try - if FStyleHook <> nil then - begin - DC := GetWindowDC(Handle); - try - if FVertical then - begin - R := FStyleHook.VertScrollRect; - MoveWindowOrg(DC, -R.Left, -R.Top); - FStyleHook.DrawVertScrollBar(DC); - end else - begin - R := FStyleHook.HorzScrollRect; - MoveWindowOrg(DC, -R.Left, -R.Top); - FStyleHook.DrawHorzScrollBar(DC); - end; - finally - ReleaseDC(Handle, DC); - end; - end; - finally - EndPaint(Handle, PS); - end; -end; - -initialization - TCustomStyleEngine.RegisterStyleHook(TVirtualStringTree, TVclStyleScrollBarsHook); - TCustomStyleEngine.RegisterStyleHook(TVirtualDrawTree, TVclStyleScrollBarsHook); - -finalization - TCustomStyleEngine.UnRegisterStyleHook(TVirtualStringTree, TVclStyleScrollBarsHook); - TCustomStyleEngine.UnRegisterStyleHook(TVirtualDrawTree, TVclStyleScrollBarsHook); - -end. - +unit VirtualTrees.StyleHooks; + +// 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/ +// +// Alternatively, you may redistribute this library, use and/or modify it under the terms of the +// GNU Lesser General Public License as published by the Free Software Foundation; +// either version 2.1 of the License, or (at your option) any later version. +// You may obtain a copy of the LGPL at http://www.gnu.org/copyleft/. +// +// 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. +// +// The original code is VirtualTrees.pas, released September 30, 2000. +// +// The initial developer of the original code is digital publishing AG (Munich, Germany, www.digitalpublishing.de), +// written by Mike Lischke (public@soft-gems.net, www.soft-gems.net). +// +// Portions created by digital publishing AG are Copyright +// (C) 1999-2001 digital publishing AG. All Rights Reserved. +//---------------------------------------------------------------------------------------------------------------------- + + +interface + +{$WARN UNSAFE_TYPE OFF} +{$WARN UNSAFE_CAST OFF} +{$WARN UNSAFE_CODE OFF} +{$if CompilerVersion < 34} + {$DEFINE NOT_USE_VCL_STYLEHOOK} // Do not use inherited style hook but own code in this class. Needed for older Delphi versions 10.3 and below +{$ifend} + +uses + Winapi.Windows, + Winapi.Messages, + Winapi.UxTheme, + System.Classes, + System.UITypes, + Vcl.Graphics, + Vcl.Themes, + Vcl.Forms, + Vcl.Controls; + +const + CM_UPDATE_VCLSTYLE_SCROLLBARS = CM_BASE + 2050; + +type + // XE2+ VCL Style + TVclStyleScrollBarsHook = class(TScrollingStyleHook) + {$ifdef NOT_USE_VCL_STYLEHOOK} + strict private type + {$REGION 'TVclStyleScrollBarWindow'} + TScrollWindow = class(TWinControl) + strict private + FStyleHook: TVclStyleScrollBarsHook; + FVertical: Boolean; + procedure WMNCHitTest(var Msg: TWMNCHitTest); message WM_NCHITTEST; + procedure WMEraseBkgnd(var Msg: TMessage); message WM_ERASEBKGND; + procedure WMPaint(var Msg: TWMPaint); message WM_PAINT; + public + constructor Create(AOwner: TComponent); override; + property StyleHook: TVclStyleScrollBarsHook read FStyleHook write FStyleHook; + property Vertical: Boolean read FVertical write FVertical; + end; + {$ENDREGION} + private + FHorzScrollWnd: TScrollWindow; + FLeftButtonDown: Boolean; + FVertScrollWnd: TScrollWindow; + + procedure WMEraseBkgnd(var Msg: TWMEraseBkgnd); message WM_ERASEBKGND; + procedure WMKeyDown(var Msg: TMessage); message WM_KEYDOWN; + procedure WMKeyUp(var Msg: TMessage); message WM_KEYUP; + procedure WMLButtonDown(var Msg: TWMMouse); message WM_LBUTTONDOWN; + procedure WMLButtonUp(var Msg: TWMMouse); message WM_LBUTTONUP; + procedure WMNCLButtonDown(var Msg: TWMMouse); message WM_NCLBUTTONDOWN; + procedure WMNCLButtonDblClk(var Msg: TWMMouse); message WM_NCLBUTTONDBLCLK; + procedure WMNCLButtonUp(var Msg: TWMMouse); message WM_NCLBUTTONUP; + procedure WMNCPaint(var Msg: TMessage); message WM_NCPAINT; + procedure WMVScroll(var Msg: TWMVScroll); message WM_VSCROLL; + procedure WMHScroll(var Msg: TWMHScroll); message WM_HSCROLL; + procedure WMSize(var Msg: TMessage); message WM_SIZE; + procedure WMMove(var Msg: TMessage); message WM_MOVE; + procedure WMPosChanged(var Msg: TMessage); message WM_WINDOWPOSCHANGED; + procedure WMMouseWheel(var Msg: TMessage); message WM_MOUSEWHEEL; + procedure WMCaptureChanged(var Msg: TMessage); message WM_CAPTURECHANGED; + procedure InitScrollBars; + procedure WMNCMouseMove(var Msg: TWMMouse); message WM_NCMOUSEMOVE; + procedure WMMouseMove(var Msg: TWMMouse); message WM_MOUSEMOVE; + function NCMousePosToClient(const P: TPoint): TPoint; + function PointInTreeHeader(const P: TPoint): Boolean; + {$endif} + private + procedure CMUpdateVclStyleScrollbars(var Msg: TMessage); message CM_UPDATE_VCLSTYLE_SCROLLBARS; + protected + procedure CalcScrollBarsRect; virtual; + procedure UpdateScroll;{$if CompilerVersion >= 34}override;{$ifend} + {$ifdef NOT_USE_VCL_STYLEHOOK} + procedure MouseLeave; override; + procedure DrawHorzScrollBar(DC: HDC); virtual; + procedure DrawVertScrollBar(DC: HDC); virtual; + procedure PaintScroll; override; + property HorzScrollWnd: TScrollWindow read FHorzScrollWnd; + property VertScrollWnd: TScrollWindow read FVertScrollWnd; + property LeftButtonDown: Boolean read FLeftButtonDown; + {$ifend} + public + constructor Create(AControl: TWinControl); override; + {$ifdef NOT_USE_VCL_STYLEHOOK} + destructor Destroy; override; + {$ifend} + /// Draws an expand arrow like used in the RAD Studio IDE. + /// The code is not yet dpi-aware. + class procedure DrawExpandArrow(pBitmap: TBitmap; pExpanded: Boolean; pColor: TColor = clNone); + property HorzScrollRect; + property VertScrollRect; + end; + +type + /// prototype for the global callback VTStyleServicesFunc. + TVTStyleServicesFunc = function (AControl: TControl = nil): TCustomStyleServices; + + +var + /// Callback that can be used to assign an alternative function to supply style services. + /// Needed for IDE plugins. See pull request #1011 + VTStyleServicesFunc: TVTStyleServicesFunc = nil; + + +/// Wrapper function for styles services that handles differences between RAD Studio 10.4 and older versions, +/// as well as the case if these controls are used inside the IDE. +function VTStyleServices(AControl: TControl = nil): TCustomStyleServices; + + +implementation + +uses + System.SysUtils, + System.Math, + System.Types, + VirtualTrees.Header, + VirtualTrees.Types, + VirtualTrees.BaseTree; + +function VTStyleServices(AControl: TControl = nil): TCustomStyleServices; +begin + if Assigned(VTStyleServicesFunc) then + Result := VTStyleServicesFunc(AControl) + else + Result := Vcl.Themes.StyleServices{$if CompilerVersion >= 34}(AControl){$ifend}; +end; + +//---------------------------------------------------------------------------------------------------------------------- + + +type + TBaseVirtualTreeCracker = class(TBaseVirtualTree) + end; + + +// XE2+ VCL Style +{ TVclStyleScrollBarsHook } + +procedure TVclStyleScrollBarsHook.CalcScrollBarsRect(); + + procedure CalcVerticalRects; + var + BarInfo: TScrollBarInfo; + Ret: BOOL; + begin + if not Assigned(VertScrollWnd) then // Might happen, when FInitingScrollBars is set, so InitScrollBars did not yet initialize the members + Exit; + + BarInfo.cbSize := SizeOf(BarInfo); + Ret := GetScrollBarInfo(Handle, Integer(OBJID_VSCROLL), BarInfo); + VertScrollWnd.Visible := (seBorder in Control.StyleElements) and Ret and (not (STATE_SYSTEM_INVISIBLE and BarInfo.rgstate[0] <> 0)); + VertScrollWnd.Enabled := VertScrollWnd.Visible and (not (STATE_SYSTEM_UNAVAILABLE and BarInfo.rgstate[0] <> 0)); + end; + + procedure CalcHorizontalRects; + var + BarInfo: TScrollBarInfo; + Ret: BOOL; + begin + if not Assigned(HorzScrollWnd) then // Might happen, when FInitingScrollBars is set, so InitScrollBars did not yet initialize the members + Exit; + + BarInfo.cbSize := SizeOf(BarInfo); + Ret := GetScrollBarInfo(Handle, Integer(OBJID_HSCROLL), BarInfo); + HorzScrollWnd.Visible := (seBorder in Control.StyleElements) and Ret and (not (STATE_SYSTEM_INVISIBLE and BarInfo.rgstate[0] <> 0)); + HorzScrollWnd.Enabled := HorzScrollWnd.Visible and (not (STATE_SYSTEM_UNAVAILABLE and BarInfo.rgstate[0] <> 0)); + end; + +begin + CalcVerticalRects; + CalcHorizontalRects; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +constructor TVclStyleScrollBarsHook.Create(AControl: TWinControl); +begin + inherited; + {$ifdef NOT_USE_VCL_STYLEHOOK} + VertSliderState := tsThumbBtnVertNormal; + VertUpState := tsArrowBtnUpNormal; + VertDownState := tsArrowBtnDownNormal; + HorzSliderState := tsThumbBtnHorzNormal; + HorzUpState := tsArrowBtnLeftNormal; + HorzDownState := tsArrowBtnRightNormal; + {$ifend} +end; + +//---------------------------------------------------------------------------------------------------------------------- + +class procedure TVclStyleScrollBarsHook.DrawExpandArrow(pBitmap: TBitmap; pExpanded: Boolean; pColor: TColor); +const + Size: TRect = (Left: 0; Top: 0; Right: 12; Bottom: 12); + ArrowPoints: array[Boolean, 0..5] of TPoint = ( + ((X:3; Y:1), (X:8; Y:6), (X:3; Y:11), (X:4; Y:11), (X:9; Y:6), (X:3; Y:0)), + ((X:1; Y:3), (X:6; Y:8), (X:11; Y:3), (X:11; Y:4), (X:6; Y:9), (X:0; Y:3)) + ); +var + canvas: TCanvas; +begin + pBitmap.SetSize(Size.Width, Size.Height); + canvas := pBitmap.Canvas; + canvas.FillRect(Size); + if pColor = clNone then + begin + if Assigned(VTStyleServicesFunc) then + canvas.Pen.Color := VTStyleServicesFunc.GetSystemColor(clGrayText) + else + canvas.Pen.Color := Vcl.Themes.StyleServices.GetSystemColor(clGrayText) + end + else + canvas.Pen.Color := pColor; + canvas.Pen.Width := 1; + canvas.Polyline(ArrowPoints[pExpanded]); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVclStyleScrollBarsHook.UpdateScroll; +var + R: TRect; + HeaderHeight: Integer; + PaddingSize: Integer; + BorderSize: Integer; +begin + if VertScrollWnd = nil then + InitScrollBars(); + + HeaderHeight := 0; + if (hoVisible in TBaseVirtualTree(Control).Header.Options) then + Inc(HeaderHeight, TBaseVirtualTree(Control).Header.Height); + + PaddingSize := TBaseVirtualTreeCracker(Control).BorderWidth; + if TBaseVirtualTreeCracker(Control).BevelKind <> bkNone then + begin + if TBaseVirtualTreeCracker(Control).BevelInner <> bvNone then + Inc(PaddingSize, TBaseVirtualTreeCracker(Control).BevelWidth); + if TBaseVirtualTreeCracker(Control).BevelOuter <> bvNone then + Inc(PaddingSize, TBaseVirtualTreeCracker(Control).BevelWidth); + end; + + BorderSize := 0; + if HasBorder then + Inc(BorderSize, GetSystemMetrics(SM_CYEDGE)); + + if ((VertScrollWnd <> nil) and not VertScrollWnd.HandleAllocated) or + ((HorzScrollWnd <> nil) and not HorzScrollWnd.HandleAllocated) then + begin // Fixes issue #390 + if VertScrollWnd <> nil then + FreeAndNil({$ifdef NOT_USE_VCL_STYLEHOOK}FVertScrollWnd{$else}VertScrollWnd{$ifend}); + if HorzScrollWnd <> nil then + FreeAndNil({$ifdef NOT_USE_VCL_STYLEHOOK}FHorzScrollWnd{$else}HorzScrollWnd{$ifend}); + + InitScrollBars; + end; + + // VertScrollBarWindow + if Control.HandleAllocated then + begin + if VertScrollWnd.Visible then + begin + R := VertScrollRect; + if Control.UseRightToLeftScrollBar then + OffsetRect(R, -R.Left + BorderSize, 0); + + ShowWindow(VertScrollWnd.Handle, SW_SHOW); + SetWindowPos(VertScrollWnd.Handle, HWND_TOP, + Control.Left + R.Left + PaddingSize, + Control.Top + R.Top + HeaderHeight + PaddingSize, + R.Width, + Control.Height - HeaderHeight - ((PaddingSize + BorderSize) * 2), // <> R.Height + SWP_SHOWWINDOW); + end else + ShowWindow(VertScrollWnd.Handle, SW_HIDE); + end;// if FVertScrollWnd + + // HorzScrollBarWindow + if Control.HandleAllocated then + begin + if HorzScrollWnd.Visible then + begin + R := HorzScrollRect; + if Control.UseRightToLeftScrollBar then + OffsetRect(R, VertScrollRect.Width, 0); + + ShowWindow(HorzScrollWnd.Handle, SW_SHOW); + SetWindowPos(HorzScrollWnd.Handle, HWND_TOP, + Control.Left + R.Left + PaddingSize, + Control.Top + R.Top + HeaderHeight + PaddingSize, + R.Width, R.Height, SWP_SHOWWINDOW); + end else + ShowWindow(HorzScrollWnd.Handle, SW_HIDE); + end;// if FHorzScrollWnd + // ScrollBarWindow Visible/Enabled Control + CalcScrollBarsRect; + +end; + +procedure TVclStyleScrollBarsHook.CMUpdateVclStyleScrollbars(var Msg: TMessage); +begin + CalcScrollBarsRect; + PaintScroll; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +{$ifdef NOT_USE_VCL_STYLEHOOK} + +function TVclStyleScrollBarsHook.NCMousePosToClient(const P: TPoint): TPoint; +begin + Result := P; + ScreenToClient(Handle, Result); + if HasBorder then + begin + if HasClientEdge then + Result.Offset(2, 2) + else + Result.Offset(1, 1); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVclStyleScrollBarsHook.PointInTreeHeader(const P: TPoint): Boolean; +begin + Result := TBaseVirtualTree(Control).Header.InHeader(P); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVclStyleScrollBarsHook.DrawHorzScrollBar(DC: HDC); +var + B: TBitmap; + Details: TThemedElementDetails; + R: TRect; +begin + if ((Handle = 0) or (DC = 0)) then + Exit; + + if HorzScrollWnd.Visible and StyleServices.Available and (seBorder in Control.StyleElements) then + begin + B := TBitmap.Create; + try + R := HorzScrollRect; + B.Width := R.Width; + B.Height := R.Height; + MoveWindowOrg(B.Canvas.Handle, -R.Left, -R.Top); + + R.Left := HorzUpButtonRect.Right; + R.Right := HorzDownButtonRect.Left; + Details := StyleServices.GetElementDetails(tsUpperTrackHorzNormal); + StyleServices.DrawElement(B.Canvas.Handle, Details, R{$IF CompilerVersion >= 34}, nil, VertScrollWnd.CurrentPPI{$IFEND}); + + if HorzScrollWnd.Enabled then + Details := StyleServices.GetElementDetails(HorzSliderState); + StyleServices.DrawElement(B.Canvas.Handle, Details, HorzSliderRect{$IF CompilerVersion >= 34}, nil, VertScrollWnd.CurrentPPI{$IFEND}); + + if HorzScrollWnd.Enabled then + Details := StyleServices.GetElementDetails(HorzUpState) + else + Details := StyleServices.GetElementDetails(tsArrowBtnLeftDisabled); + StyleServices.DrawElement(B.Canvas.Handle, Details, HorzUpButtonRect{$IF CompilerVersion >= 34}, nil, VertScrollWnd.CurrentPPI{$IFEND}); + + if HorzScrollWnd.Enabled then + Details := StyleServices.GetElementDetails(HorzDownState) + else + Details := StyleServices.GetElementDetails(tsArrowBtnRightDisabled); + StyleServices.DrawElement(B.Canvas.Handle, Details, HorzDownButtonRect{$IF CompilerVersion >= 34}, nil, VertScrollWnd.CurrentPPI{$IFEND}); + + R := HorzScrollRect; + MoveWindowOrg(B.Canvas.Handle, R.Left, R.Top); + BitBlt(DC, R.Left, R.Top, B.Width, B.Height, B.Canvas.Handle, 0, 0, SRCCOPY); + finally + B.Free; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVclStyleScrollBarsHook.DrawVertScrollBar(DC: HDC); +var + B: TBitmap; + Details: TThemedElementDetails; + R: TRect; +begin + if ((Handle = 0) or (DC = 0)) then + Exit; + + if VertScrollWnd.Visible and StyleServices.Available and (seBorder in Control.StyleElements) then + begin + B := TBitmap.Create; + try + R := VertScrollRect; + B.Width := R.Width; + B.Height := VertScrollWnd.Height; // <> R.Height + MoveWindowOrg(B.Canvas.Handle, -R.Left, -R.Top); + + R.Bottom := B.Height + R.Top; + Details := StyleServices.GetElementDetails(tsUpperTrackVertNormal); + StyleServices.DrawElement(B.Canvas.Handle, Details, R {$IF CompilerVersion >= 34}, nil, VertScrollWnd.CurrentPPI{$IFEND}); + + R.Top := VertUpButtonRect.Bottom; + R.Bottom := VertDownButtonRect.Top; + Details := StyleServices.GetElementDetails(tsUpperTrackVertNormal); + StyleServices.DrawElement(B.Canvas.Handle, Details, R{$IF CompilerVersion >= 34}, nil, VertScrollWnd.CurrentPPI{$IFEND}); + + if VertScrollWnd.Enabled then + Details := StyleServices.GetElementDetails(VertSliderState); + StyleServices.DrawElement(B.Canvas.Handle, Details, VertSliderRect{$IF CompilerVersion >= 34}, nil, VertScrollWnd.CurrentPPI{$IFEND}); + + if VertScrollWnd.Enabled then + Details := StyleServices.GetElementDetails(VertUpState) + else + Details := StyleServices.GetElementDetails(tsArrowBtnUpDisabled); + StyleServices.DrawElement(B.Canvas.Handle, Details, VertUpButtonRect{$IF CompilerVersion >= 34}, nil, VertScrollWnd.CurrentPPI{$IFEND}); + + if VertScrollWnd.Enabled then + Details := StyleServices.GetElementDetails(VertDownState) + else + Details := StyleServices.GetElementDetails(tsArrowBtnDownDisabled); + StyleServices.DrawElement(B.Canvas.Handle, Details, VertDownButtonRect{$IF CompilerVersion >= 34}, nil, VertScrollWnd.CurrentPPI{$IFEND}); + + R := VertScrollRect; + MoveWindowOrg(B.Canvas.Handle, R.Left, R.Top); + BitBlt(DC, R.Left, R.Top, B.Width, B.Height, B.Canvas.Handle, 0, 0, SRCCOPY); + finally + B.Free; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVclStyleScrollBarsHook.MouseLeave; +begin + inherited; + if VertSliderState = tsThumbBtnVertHot then + VertSliderState := tsThumbBtnVertNormal; + + if HorzSliderState = tsThumbBtnHorzHot then + HorzSliderState := tsThumbBtnHorzNormal; + + if VertUpState = tsArrowBtnUpHot then + VertUpState := tsArrowBtnUpNormal; + + if VertDownState = tsArrowBtnDownHot then + VertDownState := tsArrowBtnDownNormal; + + if HorzUpState = tsArrowBtnLeftHot then + HorzUpState := tsArrowBtnLeftNormal; + + if HorzDownState = tsArrowBtnRightHot then + HorzDownState := tsArrowBtnRightNormal; + + PaintScroll; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVclStyleScrollBarsHook.WMCaptureChanged(var Msg: TMessage); +begin + if VertScrollWnd.Visible and VertScrollWnd.Enabled then + begin + if VertUpState = tsArrowBtnUpPressed then + begin + VertUpState := tsArrowBtnUpNormal; + PaintScroll; + end; + + if VertDownState = tsArrowBtnDownPressed then + begin + VertDownState := tsArrowBtnDownNormal; + PaintScroll; + end; + end; + + if HorzScrollWnd.Visible and HorzScrollWnd.Enabled then + begin + if HorzUpState = tsArrowBtnLeftPressed then + begin + HorzUpState := tsArrowBtnLeftNormal; + PaintScroll; + end; + + if HorzDownState = tsArrowBtnRightPressed then + begin + HorzDownState := tsArrowBtnRightNormal; + PaintScroll; + end; + end; + + CallDefaultProc(TMessage(Msg)); + Handled := True; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +destructor TVclStyleScrollBarsHook.Destroy; +begin + FVertScrollWnd.StyleHook := nil; + FreeAndNil(FVertScrollWnd); + FHorzScrollWnd.StyleHook := nil; + FreeAndNil(FHorzScrollWnd); + inherited; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVclStyleScrollBarsHook.WMEraseBkgnd(var Msg: TWMEraseBkgnd); +begin + Handled := True; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVclStyleScrollBarsHook.PaintScroll; +begin + if FVertScrollWnd.HandleAllocated then + begin + FVertScrollWnd.Repaint; + RedrawWindow(FVertScrollWnd.Handle, nil, 0, RDW_FRAME or RDW_INVALIDATE); // Fixes issue #698 + end; + if FHorzScrollWnd.HandleAllocated then + begin + FHorzScrollWnd.Repaint; + RedrawWindow(FHorzScrollWnd.Handle, nil, 0, RDW_FRAME or RDW_INVALIDATE); // Fixes issue #698 + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVclStyleScrollBarsHook.WMKeyDown(var Msg: TMessage); +begin + CallDefaultProc(TMessage(Msg)); + PaintScroll; + Handled := True; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVclStyleScrollBarsHook.WMKeyUp(var Msg: TMessage); +begin + CallDefaultProc(TMessage(Msg)); + PaintScroll; + Handled := True; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVclStyleScrollBarsHook.WMLButtonDown(var Msg: TWMMouse); +begin + CallDefaultProc(TMessage(Msg)); + UpdateScroll; + Handled := True; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVclStyleScrollBarsHook.InitScrollBars; +begin + FVertScrollWnd := TScrollWindow.CreateParented(GetParent(Control.Handle)); + FVertScrollWnd.StyleHook := Self; + FVertScrollWnd.Vertical := True; + + FHorzScrollWnd := TScrollWindow.CreateParented(GetParent(Control.Handle)); + FHorzScrollWnd.StyleHook := Self; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVclStyleScrollBarsHook.WMLButtonUp(var Msg: TWMMouse); +var + P: TPoint; +begin + P := Point(Msg.XPos, Msg.YPos); + ScreenToClient(Handle, P); + if not PointInTreeHeader(P) then + begin + if VertScrollWnd.Visible then + begin + if VertSliderState = tsThumbBtnVertPressed then + begin + PostMessage(Handle, WM_VSCROLL, WPARAM(UInt32(SmallPoint(SB_ENDSCROLL, 0))), 0); + FLeftButtonDown := False; + VertSliderState := tsThumbBtnVertNormal; + PaintScroll; + Handled := True; + Mouse.Capture := 0; + Exit; + end else + if VertUpState = tsArrowBtnUpPressed then + VertUpState := tsArrowBtnUpNormal + else if VertDownState = tsArrowBtnDownPressed then + VertDownState := tsArrowBtnDownNormal; + end; + + if FHorzScrollWnd.Visible then + begin + if HorzSliderState = tsThumbBtnHorzPressed then + begin + PostMessage(Handle, WM_HSCROLL, WPARAM(UInt32(SmallPoint(SB_ENDSCROLL, 0))), 0); + FLeftButtonDown := False; + HorzSliderState := tsThumbBtnHorzNormal; + PaintScroll; + Handled := True; + Mouse.Capture := 0; + Exit; + end else + if HorzUpState = tsArrowBtnLeftPressed then + HorzUpState := tsArrowBtnLeftNormal + else if HorzDownState = tsArrowBtnRightPressed then + HorzDownState := tsArrowBtnRightNormal; + end; + PaintScroll; + end; + FLeftButtonDown := False; +end; + +//---------------------------------------------------------------------------------------------------------------------- +procedure TVclStyleScrollBarsHook.WMNCLButtonDown(var Msg: TWMMouse); +var + P: TPoint; + SF: TScrollInfo; +begin + P := NCMousePosToClient(Point(Msg.XPos, Msg.YPos)); + if not PointInTreeHeader(P) then + begin + if VertScrollWnd.Visible and VertScrollWnd.Enabled then + begin + if PtInRect(VertSliderRect, P) then + begin + FLeftButtonDown := True; + SF.fMask := SIF_ALL; + SF.cbSize := SizeOf(SF); + GetScrollInfo(Handle, SB_VERT, SF); + ListPos := SF.nPos; + ScrollPos := SF.nPos; + PrevScrollPos := Mouse.CursorPos.Y; + VertSliderState := tsThumbBtnVertPressed; + PaintScroll; + Mouse.Capture := Handle; + Handled := True; + Exit; + end else + if PtInRect(VertDownButtonRect, P) then + VertDownState := tsArrowBtnDownPressed + else if PtInRect(VertUpButtonRect, P) then + VertUpState := tsArrowBtnUpPressed; + end; + + if FHorzScrollWnd.Visible and FHorzScrollWnd.Enabled then + begin + if PtInRect(HorzSliderRect, P) then + begin + FLeftButtonDown := True; + SF.fMask := SIF_ALL; + SF.cbSize := SizeOf(SF); + GetScrollInfo(Handle, SB_HORZ, SF); + ListPos := SF.nPos; + ScrollPos := SF.nPos; + PrevScrollPos := Mouse.CursorPos.X; + HorzSliderState := tsThumbBtnHorzPressed; + PaintScroll; + Mouse.Capture := Handle; + Handled := True; + Exit; + end else + if PtInRect(HorzDownButtonRect, P) then + HorzDownState := tsArrowBtnRightPressed + else if PtInRect(HorzUpButtonRect, P) then + HorzUpState := tsArrowBtnLeftPressed; + end; + FLeftButtonDown := True; + PaintScroll; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVclStyleScrollBarsHook.WMNCLButtonUp(var Msg: TWMMouse); +var + P: TPoint; +begin + P := NCMousePosToClient(Point(Msg.XPos, Msg.YPos)); + if not PointInTreeHeader(P) then + begin + if VertScrollWnd.Visible and VertScrollWnd.Enabled then + begin + if VertSliderState = tsThumbBtnVertPressed then + begin + FLeftButtonDown := False; + VertSliderState := tsThumbBtnVertNormal; + PaintScroll; + Handled := True; + Exit; + end; + + if PtInRect(VertDownButtonRect, P) then + VertDownState := tsArrowBtnDownHot + else + VertDownState := tsArrowBtnDownNormal; + + if PtInRect(VertUpButtonRect, P) then + VertUpState := tsArrowBtnUpHot + else + VertUpState := tsArrowBtnUpNormal; + end; + + if FHorzScrollWnd.Visible and FHorzScrollWnd.Enabled then + begin + if HorzSliderState = tsThumbBtnHorzPressed then + begin + FLeftButtonDown := False; + HorzSliderState := tsThumbBtnHorzNormal; + PaintScroll; + Handled := True; + Exit; + end; + + if PtInRect(HorzDownButtonRect, P) then + HorzDownState := tsArrowBtnRightHot + else + HorzDownState := tsArrowBtnRightNormal; + + if PtInRect(HorzUpButtonRect, P) then + HorzUpState := tsArrowBtnLeftHot + else + HorzUpState := tsArrowBtnLeftNormal; + end; + + CallDefaultProc(TMessage(Msg)); + if (FHorzScrollWnd.Visible) or (FVertScrollWnd.Visible) then + PaintScroll; + end; + + Handled := True; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVclStyleScrollBarsHook.WMNCLButtonDblClk(var Msg: TWMMouse); +begin + WMNCLButtonDown(Msg); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVclStyleScrollBarsHook.WMNCPaint(var Msg: TMessage); +begin + //if (tsWindowCreating in TBaseVirtualTree(Control).TreeStates) then + // UpdateScrollBarWindow; + //inherited; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVclStyleScrollBarsHook.WMHScroll(var Msg: TWMHScroll); +begin + CallDefaultProc(TMessage(Msg)); + PaintScroll; + Handled := True; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVclStyleScrollBarsHook.WMMouseWheel(var Msg: TMessage); +begin + CallDefaultProc(TMessage(Msg)); + CalcScrollBarsRect; + PaintScroll; + Handled := True; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVclStyleScrollBarsHook.WMMouseMove(var Msg: TWMMouse); +var + SF: TScrollInfo; + OverrideMax: Integer; +begin + if VertSliderState = tsThumbBtnVertPressed then + begin + SF.fMask := SIF_ALL; + SF.cbSize := SizeOf(SF); + GetScrollInfo(Handle, SB_VERT, SF); + + OverrideMax := SF.nMax; + if 0 < SF.nPage then + OverrideMax := SF.nMax - Integer(SF.nPage) + 1; + ScrollPos := System.Math.EnsureRange(ListPos + (OverrideMax - SF.nMin) * ((Mouse.CursorPos.Y - PrevScrollPos) / (VertTrackRect.Height - VertSliderRect.Height)), + SF.nMin, OverrideMax); + SF.fMask := SIF_POS; + SF.nPos := Round(ScrollPos); + SetScrollInfo(Handle, SB_VERT, SF, False); + PostMessage(Handle, WM_VSCROLL, WPARAM(UInt32(SmallPoint(SB_THUMBPOSITION, Min(SF.nPos, High(SmallInt))))), 0); + + PaintScroll; + Handled := True; + Exit; + end else + if VertSliderState = tsThumbBtnVertHot then + begin + VertSliderState := tsThumbBtnVertNormal; + PaintScroll; + end; + + if HorzSliderState = tsThumbBtnHorzPressed then + begin + SF.fMask := SIF_ALL; + SF.cbSize := SizeOf(SF); + GetScrollInfo(Handle, SB_HORZ, SF); + + OverrideMax := SF.nMax; + if 0 < SF.nPage then + OverrideMax := SF.nMax - Integer(SF.nPage) + 1; + ScrollPos := System.Math.EnsureRange(ListPos + (OverrideMax - SF.nMin) * ((Mouse.CursorPos.X - PrevScrollPos) / (HorzTrackRect.Width - HorzSliderRect.Width)), + SF.nMin, OverrideMax); + SF.fMask := SIF_POS; + SF.nPos := Round(ScrollPos); + SetScrollInfo(Handle, SB_HORZ, SF, False); + PostMessage(Handle, WM_HSCROLL, WPARAM(UInt32(SmallPoint(SB_THUMBPOSITION, Min(SF.nPos, High(SmallInt))))), 0); + + PaintScroll; + Handled := True; + Exit; + end else + if HorzSliderState = tsThumbBtnHorzHot then + begin + HorzSliderState := tsThumbBtnHorzNormal; + PaintScroll; + end; + + if (HorzUpState <> tsArrowBtnLeftPressed) and (HorzUpState = tsArrowBtnLeftHot) then + begin + HorzUpState := tsArrowBtnLeftNormal; + PaintScroll; + end; + + if (HorzDownState <> tsArrowBtnRightPressed) and (HorzDownState = tsArrowBtnRightHot) then + begin + HorzDownState := tsArrowBtnRightNormal; + PaintScroll; + end; + + if (VertUpState <> tsArrowBtnUpPressed) and (VertUpState = tsArrowBtnUpHot) then + begin + VertUpState := tsArrowBtnUpNormal; + PaintScroll; + end; + + if (VertDownState <> tsArrowBtnDownPressed) and (VertDownState = tsArrowBtnDownHot) then + begin + VertDownState := tsArrowBtnDownNormal; + PaintScroll; + end; + + CallDefaultProc(TMessage(Msg)); + if LeftButtonDown then + PaintScroll; + Handled := True; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVclStyleScrollBarsHook.WMNCMouseMove(var Msg: TWMMouse); +var + P: TPoint; + MustUpdateScroll: Boolean; + B: Boolean; +begin + inherited; + P := NCMousePosToClient(Point(Msg.XPos, Msg.YPos)); + if PointInTreeHeader(P) then + begin + CallDefaultProc(TMessage(Msg)); + PaintScroll; + Handled := True; + Exit; + end; + + MustUpdateScroll := False; + if VertScrollWnd.Visible and VertScrollWnd.Enabled then + begin + B := PtInRect(VertSliderRect, P); + if B and (VertSliderState = tsThumbBtnVertNormal) then + begin + VertSliderState := tsThumbBtnVertHot; + MustUpdateScroll := True; + end else + if not B and (VertSliderState = tsThumbBtnVertHot) then + begin + VertSliderState := tsThumbBtnVertNormal; + MustUpdateScroll := True; + end; + + B := PtInRect(VertDownButtonRect, P); + if B and (VertDownState = tsArrowBtnDownNormal) then + begin + VertDownState := tsArrowBtnDownHot; + MustUpdateScroll := True; + end else + if not B and (VertDownState = tsArrowBtnDownHot) then + begin + VertDownState := tsArrowBtnDownNormal; + MustUpdateScroll := True; + end; + + B := PtInRect(VertUpButtonRect, P); + if B and (VertUpState = tsArrowBtnUpNormal) then + begin + VertUpState := tsArrowBtnUpHot; + MustUpdateScroll := True; + end else + if not B and (VertUpState = tsArrowBtnUpHot) then + begin + VertUpState := tsArrowBtnUpNormal; + MustUpdateScroll := True; + end; + end; + + if HorzScrollWnd.Visible and HorzScrollWnd.Enabled then + begin + B := PtInRect(HorzSliderRect, P); + if B and (HorzSliderState = tsThumbBtnHorzNormal) then + begin + HorzSliderState := tsThumbBtnHorzHot; + MustUpdateScroll := True; + end else + if not B and (HorzSliderState = tsThumbBtnHorzHot) then + begin + HorzSliderState := tsThumbBtnHorzNormal; + MustUpdateScroll := True; + end; + + B := PtInRect(HorzDownButtonRect, P); + if B and (HorzDownState = tsArrowBtnRightNormal) then + begin + HorzDownState := tsArrowBtnRightHot; + MustUpdateScroll := True; + end else + if not B and (HorzDownState = tsArrowBtnRightHot) then + begin + HorzDownState := tsArrowBtnRightNormal; + MustUpdateScroll := True; + end; + + B := PtInRect(HorzUpButtonRect, P); + if B and (HorzUpState = tsArrowBtnLeftNormal) then + begin + HorzUpState := tsArrowBtnLeftHot; + MustUpdateScroll := True; + end else + if not B and (HorzUpState = tsArrowBtnLeftHot) then + begin + HorzUpState := tsArrowBtnLeftNormal; + MustUpdateScroll := True; + end; + end; + + if MustUpdateScroll then + PaintScroll; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVclStyleScrollBarsHook.WMSize(var Msg: TMessage); +begin + CallDefaultProc(TMessage(Msg)); + UpdateScroll; + PaintScroll; + Handled := True; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVclStyleScrollBarsHook.WMMove(var Msg: TMessage); +begin + CallDefaultProc(TMessage(Msg)); + if not(tsWindowCreating in TBaseVirtualTree(Control).TreeStates) then + begin + UpdateScroll; + PaintScroll; + end; + Handled := True; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVclStyleScrollBarsHook.WMPosChanged(var Msg: TMessage); +begin + WMMove(Msg); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVclStyleScrollBarsHook.WMVScroll(var Msg: TWMVScroll); +begin + CallDefaultProc(TMessage(Msg)); + PaintScroll; + Handled := True; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +{ TVclStyleScrollBarsHook.TVclStyleScrollBarWindow } + +constructor TVclStyleScrollBarsHook.TScrollWindow.Create(AOwner: TComponent); +begin + inherited; + ControlStyle := ControlStyle + [csOverrideStylePaint]; + FStyleHook := nil; + FVertical := False; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVclStyleScrollBarsHook.TScrollWindow.WMEraseBkgnd(var Msg: TMessage); +begin + Msg.Result := 1; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVclStyleScrollBarsHook.TScrollWindow.WMNCHitTest(var Msg: TWMNCHitTest); +begin + Msg.Result := HTTRANSPARENT; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVclStyleScrollBarsHook.TScrollWindow.WMPaint(var Msg: TWMPaint); +var + PS: TPaintStruct; + DC: HDC; + R: TRect; +begin + BeginPaint(Handle, PS); + try + if FStyleHook <> nil then + begin + DC := GetWindowDC(Handle); + try + if FVertical then + begin + R := FStyleHook.VertScrollRect; + MoveWindowOrg(DC, -R.Left, -R.Top); + FStyleHook.DrawVertScrollBar(DC); + end else + begin + R := FStyleHook.HorzScrollRect; + MoveWindowOrg(DC, -R.Left, -R.Top); + FStyleHook.DrawHorzScrollBar(DC); + end; + finally + ReleaseDC(Handle, DC); + end; + end; + finally + EndPaint(Handle, PS); + end; +end; +{$ifend} + +end. diff --git a/components/virtualtreeview/Source/VirtualTrees.Types.pas b/components/virtualtreeview/Source/VirtualTrees.Types.pas new file mode 100644 index 000000000..103d7b55f --- /dev/null +++ b/components/virtualtreeview/Source/VirtualTrees.Types.pas @@ -0,0 +1,1722 @@ +unit VirtualTrees.Types; + +interface + +uses + WinApi.ActiveX, + Winapi.Windows, + Winapi.Messages, + System.Types, + System.Classes, + System.SysUtils, + Vcl.Controls, + Vcl.GraphUtil, + Vcl.Themes, + Vcl.Graphics, + Vcl.ImgList, + System.UITypes; // some types moved from Vcl.* to System.UITypes + +{$MINENUMSIZE 1, make enumerations as small as possible} + +const + VTTreeStreamVersion = 3; + VTHeaderStreamVersion = 6; // The header needs an own stream version to indicate changes only relevant to the header. + + CacheThreshold = 2000; // Number of nodes a tree must at least have to start caching and at the same + // time the maximum number of nodes between two cache entries. + FadeAnimationStepCount = 255; // Number of animation steps for hint fading (0..255). + ShadowSize = 5; // Size in pixels of the hint shadow. This value has no influence on Win2K and XP systems + // as those OSes have native shadow support. + cDefaultTextMargin = 4; // The default margin of text + cInitialDefaultNodeHeight= 18; // the default value of the DefualtNodeHeight property + + // Special identifiers for columns. + NoColumn = - 1; + InvalidColumn = - 2; + + // General constants for imagelists + NoImage = -1; // No image is avalable + EmptyImage = -2; // an empty image used as place holder + + // Indices for check state images in the imagelist used for displaying check-marks. + ckEmpty = 0; // an empty image used as place holder + // radio buttons + ckRadioUncheckedNormal = 1; + ckRadioUncheckedHot = 2; + ckRadioUncheckedPressed = 3; + ckRadioUncheckedDisabled = 4; + ckRadioCheckedNormal = 5; + ckRadioCheckedHot = 6; + ckRadioCheckedPressed = 7; + ckRadioCheckedDisabled = 8; + // check boxes + ckCheckUncheckedNormal = 9; + ckCheckUncheckedHot = 10; + ckCheckUncheckedPressed = 11; + ckCheckUncheckedDisabled = 12; + ckCheckCheckedNormal = 13; + ckCheckCheckedHot = 14; + ckCheckCheckedPressed = 15; + ckCheckCheckedDisabled = 16; + ckCheckMixedNormal = 17; + ckCheckMixedHot = 18; + ckCheckMixedPressed = 19; + ckCheckMixedDisabled = 20; + // simple button + ckButtonNormal = 21; + ckButtonHot = 22; + ckButtonPressed = 23; + ckButtonDisabled = 24; + + // Instead using a TTimer class for each of the various events I use Windows timers with messages + // as this is more economical. + ExpandTimer = 1; + EditTimer = 2; + HeaderTimer = 3; + ScrollTimer = 4; + ChangeTimer = 5; + StructureChangeTimer = 6; + SearchTimer = 7; + ThemeChangedTimer = 8; + + ThemeChangedTimerDelay = 500; + + // Virtual Treeview does not need to be subclassed by an eventual Theme Manager instance as it handles + // Windows XP theme painting itself. Hence the special message is used to prevent subclassing. + CM_DENYSUBCLASSING = CM_BASE + 2000; + + // Decoupling message for auto-adjusting the internal edit window. + CM_AUTOADJUST = CM_BASE + 2005; + + // Drag image helpers for Windows 2000 and up. + IID_IDropTargetHelper : TGUID = (D1 : $4657278B; D2 : $411B; D3 : $11D2; D4 : ($83, $9A, $00, $C0, $4F, $D9, $18, $D0)); + IID_IDragSourceHelper : TGUID = (D1 : $DE5BF786; D2 : $477A; D3 : $11D2; D4 : ($83, $9D, $00, $C0, $4F, $D9, $18, $D0)); + IID_IDropTarget : TGUID = (D1 : $00000122; D2 : $0000; D3 : $0000; D4 : ($C0, $00, $00, $00, $00, $00, $00, $46)); + + // VT's own clipboard formats, + // Note: The reference format is used internally to allow to link to a tree reference + // to implement optimized moves and other back references. + CFSTR_VIRTUALTREE = 'Virtual Tree Data'; + CFSTR_VTREFERENCE = 'Virtual Tree Reference'; + CFSTR_VTHEADERREFERENCE = 'Virtual Tree Header Reference'; + CFSTR_HTML = 'HTML Format'; + CFSTR_RTF = 'Rich Text Format'; + CFSTR_RTFNOOBJS = 'Rich Text Format Without Objects'; + CFSTR_CSV = 'CSV'; + + // Help identifiers for exceptions. Application developers are responsible to link them with actual help topics. + hcTFEditLinkIsNil = 2000; + hcTFWrongMoveError = 2001; + hcTFWrongStreamFormat = 2002; + hcTFWrongStreamVersion = 2003; + hcTFStreamTooSmall = 2004; + hcTFCorruptStream1 = 2005; + hcTFCorruptStream2 = 2006; + hcTFClipboardFailed = 2007; + hcTFCannotSetUserData = 2008; + + // Header standard split cursor. + crHeaderSplit = crHSplit deprecated 'Use vrHSplit instead'; + + // Height changing cursor. + crVertSplit = crVSplit deprecated 'Use vrVSplit instead'; + + // chunk IDs + NodeChunk = 1; + BaseChunk = 2; // chunk containing node state, check state, child node count etc. + // this chunk is immediately followed by all child nodes + CaptionChunk = 3; // used by the string tree to store a node's caption + UserChunk = 4; // used for data supplied by the application + +type +{$IFDEF VT_FMX} + TDimension = Single; + PDimension = ^Single; + TNodeHeight = Single; + TVTCursor = TCursor; + TVTDragDataObject = TDragObject; + TVTBackground = TBitmap; + TVTPaintContext = TCanvas; + TVTBrush = TBrush; +{$ELSE} + TDimension = Integer; // Introduced for Firemonkey support, see #841 + PDimension = ^Integer; + TNodeHeight = NativeInt; + TVTCursor = HCURSOR; + TVTDragDataObject = WinApi.ActiveX.IDataObject; + TVTBackground = TPicture; + TVTPaintContext = HDC; + TVTBrush = HBRUSH; +{$ENDIF} + TColumnIndex = {$if CompilerVersion < 36} type {$endif} Integer; // See issue #1276 + TColumnPosition = type Cardinal; + PCardinal = ^Cardinal; + + // The exception used by the trees. + EVirtualTreeError = class(Exception); + + // Limits the speed interval which can be used for auto scrolling (milliseconds). + TAutoScrollInterval = 1 .. 1000; + + TVTScrollIncrement = 1 .. 10000; + + // OLE drag'n drop support + TFormatEtcArray = array of TFormatEtc; + TFormatArray = array of Word; + + // See issue #1270. + // Taken from: https://learn.microsoft.com/en-us/windows/win32/menurc/about-cursors + // To be used with: LoadCursor(0, MAKEINTRESOURCE(TPanningCursor.MoveAll)) + TPanningCursor = ( + MoveAll = 32654, + MoveNS = 32652, + MoveEW = 32653, + MoveN = 32655, + MoveNE = 32660, + MoveE = 32658, + MoveSE = 32662, + MoveS = 32656, + MoveSW = 32661, + MoveW = 32657, + MoveNW = 32659 + ); + + TSmartAutoFitType = ( + smaAllColumns, // consider nodes in view only for all columns + smaNoColumn, // consider nodes in view only for no column + smaUseColumnOption // use coSmartResize of the corresponding column + ); // describes the used column resize behaviour for AutoFitColumns + + TAddPopupItemType = ( + apNormal, + apDisabled, + apHidden + ); + + TCheckType = ( + ctNone, + ctTriStateCheckBox, + ctCheckBox, + ctRadioButton, + ctButton + ); + + // The check states include both, transient and fluent (temporary) states. The only temporary state defined so + // far is the pressed state. + TCheckState = ( + csUncheckedNormal, // unchecked and not pressed + csUncheckedPressed, // unchecked and pressed + csCheckedNormal, // checked and not pressed + csCheckedPressed, // checked and pressed + csMixedNormal, // 3-state check box and not pressed + csMixedPressed, // 3-state check box and pressed + csUncheckedDisabled, // disabled checkbox, not checkable + csCheckedDisabled, // disabled checkbox, not uncheckable + csMixedDisabled // disabled 3-state checkbox + ); + + /// Adds some convenience methods to type TCheckState + TCheckStateHelper = record helper for TCheckState + strict private + const + // Lookup to quickly convert a specific check state into its pressed counterpart and vice versa. + cPressedState : array [TCheckState] of TCheckState = ( + csUncheckedPressed, csUncheckedPressed, csCheckedPressed, csCheckedPressed, csMixedPressed, csMixedPressed, csUncheckedDisabled, csCheckedDisabled, csMixedDisabled); + cUnpressedState : array [TCheckState] of TCheckState = ( + csUncheckedNormal, csUncheckedNormal, csCheckedNormal, csCheckedNormal, csMixedNormal, csMixedNormal, csUncheckedDisabled, csCheckedDisabled, csMixedDisabled); + cEnabledState : array [TCheckState] of TCheckState = ( + csUncheckedNormal, csUncheckedPressed, csCheckedNormal, csCheckedPressed, csMixedNormal, csMixedPressed, csUncheckedNormal, csCheckedNormal, csMixedNormal); + cToggledState : array [TCheckState] of TCheckState = ( + csCheckedNormal, csCheckedPressed, csUncheckedNormal, csUncheckedPressed, csCheckedNormal, csCheckedPressed, csUncheckedDisabled, csCheckedDisabled, csMixedDisabled); + public + function GetPressed() : TCheckState; inline; + function GetUnpressed() : TCheckState; inline; + function GetEnabled() : TCheckState; inline; + function GetToggled() : TCheckState; inline; + function IsDisabled() : Boolean; inline; + function IsChecked() : Boolean; inline; + function IsUnChecked() : Boolean; inline; + function IsMixed() : Boolean; inline; + end; + +type + // Options per column. + TVTColumnOption = ( + coAllowClick, // Column can be clicked (must be enabled too). + coDraggable, // Column can be dragged. + coEnabled, // Column is enabled. + coParentBidiMode, // Column uses the parent's bidi mode. + coParentColor, // Column uses the parent's background color. + coResizable, // Column can be resized. + coShowDropMark, // Column shows the drop mark if it is currently the drop target. + coVisible, // Column is shown. + coAutoSpring, // Column takes part in the auto spring feature of the header (must be resizable too). + coFixed, // Column is fixed and can not be selected or scrolled etc. + coSmartResize, // Column is resized to its largest entry which is in view (instead of its largest + // visible entry). + coAllowFocus, // Column can be focused. + coDisableAnimatedResize, // Column resizing is not animated. + coWrapCaption, // Caption could be wrapped across several header lines to fit columns width. + coUseCaptionAlignment, // Column's caption has its own aligment. + coEditable, // Column can be edited + coStyleColor // Prefer background color of VCL style over TVirtualTreeColumn.Color + ); + TVTColumnOptions = set of TVTColumnOption; + + TVirtualTreeColumnStyle = ( + vsText, + vsOwnerDraw + ); + + TSortDirection = ( + sdAscending, + sdDescending + ); + + TSortDirectionHelper = record helper for VirtualTrees.Types.TSortDirection + strict private + const + cSortDirectionToInt : Array [TSortDirection] of Integer = (1, - 1); + public + /// Returns +1 for ascending and -1 for descending sort order. + function ToInt() : Integer; inline; + end; + +// Used during owner draw of the header to indicate which drop mark for the column must be drawn. + TVTDropMarkMode = ( + dmmNone, + dmmLeft, + dmmRight + ); + + // auto scroll directions + TScrollDirections = set of TScrollDirection; +// sdLeft, +// sdUp, +// sdRight, +// sdDown +// ); + + + + // There is a heap of switchable behavior in the tree. Since published properties may never exceed 4 bytes, + // which limits sets to at most 32 members, and because for better overview tree options are splitted + // in various sub-options and are held in a commom options class. + // + // Options to customize tree appearance: + TVTPaintOption = ( + toHideFocusRect, // Avoid drawing the dotted rectangle around the currently focused node. + toHideSelection, // Selected nodes are drawn as unselected nodes if the tree is unfocused. + toHotTrack, // Track which node is under the mouse cursor. + toPopupMode, // Paint tree as would it always have the focus (useful for tree combo boxes etc.) + toShowBackground, // Use the background image if there's one. + toShowButtons, // Display collapse/expand buttons left to a node. + toShowDropmark, // Show the dropmark during drag'n drop operations. + toShowHorzGridLines, // Display horizontal lines to simulate a grid. + toShowRoot, // Show lines also at top level (does not show the hidden/internal root node). + toShowTreeLines, // Display tree lines to show hierarchy of nodes. + toShowVertGridLines, // Display vertical lines (depending on columns) to simulate a grid. + toThemeAware, // Draw UI elements (header, tree buttons etc.) according to the current theme if enabled (Windows XP+ only, application must be themed). + toUseBlendedImages, // Enable alpha blending for ghosted nodes or those which are being cut/copied. + toGhostedIfUnfocused, // Ghosted images are still shown as ghosted if unfocused (otherwise the become non-ghosted images). + toFullVertGridLines, // Display vertical lines over the full client area, not only the space occupied by nodes. + // This option only has an effect if toShowVertGridLines is enabled too. + toAlwaysHideSelection, // Do not draw node selection, regardless of focused state. + toUseBlendedSelection, // Enable alpha blending for node selections. + toStaticBackground, // Show simple static background instead of a tiled one. + toChildrenAbove, // Display child nodes above their parent. + toFixedIndent, // Draw the tree with a fixed indent. + toUseExplorerTheme, // Use the explorer theme if run under Windows Vista (or above). + toHideTreeLinesIfThemed, // Do not show tree lines if theming is used. + toShowFilteredNodes // Draw nodes even if they are filtered out. + ); + TVTPaintOptions = set of TVTPaintOption; + + { Options to toggle animation support: + **Do not use toAnimatedToggle when a background image is used for the tree. + The animation does not look good as the image splits and moves with it. + } + TVTAnimationOption = ( + toAnimatedToggle, // Expanding and collapsing a node is animated (quick window scroll). + // **See note above. + toAdvancedAnimatedToggle // Do some advanced animation effects when toggling a node. + ); + TVTAnimationOptions = set of TVTAnimationOption; + + // Options which toggle automatic handling of certain situations: + TVTAutoOption = ( + toAutoDropExpand, // Expand node if it is the drop target for more than a certain time. + toAutoExpand, // Nodes are expanded (collapsed) when getting (losing) the focus. + toAutoScroll, // Scroll if mouse is near the border while dragging or selecting. + toAutoScrollOnExpand, // Scroll as many child nodes in view as possible after expanding a node. + toAutoSort, // Sort tree when Header.SortColumn or Header.SortDirection change or sort node if + // child nodes are added. Sorting will take place also if SortColum is NoColumn (-1). + + toAutoSpanColumns, // Large entries continue into next column(s) if there's no text in them (no clipping). + toAutoTristateTracking, // Checkstates are automatically propagated for tri state check boxes. + toAutoHideButtons, // Node buttons are hidden when there are child nodes, but all are invisible. + toAutoDeleteMovedNodes, // Delete nodes which where moved in a drag operation (if not directed otherwise). + toDisableAutoscrollOnFocus, // Disable scrolling a node or column into view if it gets focused. + toAutoChangeScale, // Change default node height and header height automatically according to the height of the used font. + toAutoFreeOnCollapse, // Frees any child node after a node has been collapsed (HasChildren flag stays there). + toDisableAutoscrollOnEdit, // Do not center a node horizontally when it is edited. + toAutoBidiColumnOrdering // When set then columns (if any exist) will be reordered from lowest index to highest index + // and vice versa when the tree's bidi mode is changed. + ); + TVTAutoOptions = set of TVTAutoOption; + + // Options which determine the tree's behavior when selecting nodes: + TVTSelectionOption = ( + toDisableDrawSelection, // Prevent user from selecting with the selection rectangle in multiselect mode. + toExtendedFocus, // Entries other than in the main column can be selected, edited etc. + toFullRowSelect, // Hit test as well as selection highlight are not constrained to the text of a node. + toLevelSelectConstraint, // Constrain selection to the same level as the selection anchor. + toMiddleClickSelect, // Allow selection, dragging etc. with the middle mouse button. This and toWheelPanning + // are mutual exclusive. + toMultiSelect, // Allow more than one node to be selected. + toRightClickSelect, // Allow selection, dragging etc. with the right mouse button. + toSiblingSelectConstraint, // Constrain selection to nodes with same parent. + toCenterScrollIntoView, // Center nodes vertically in the client area when scrolling into view. + toSimpleDrawSelection, // Simplifies draw selection, so a node's caption does not need to intersect with the + // selection rectangle. + toAlwaysSelectNode, // If this flag is set to true, the tree view tries to always have a node selected. + // This behavior is closer to the Windows TreeView and useful in Windows Explorer style applications. + toRestoreSelection, // Set to true if upon refill the previously selected nodes should be selected again. + // The nodes will be identified by its caption (text in MainColumn) + // You may use TVTHeader.RestoreSelectiuonColumnIndex to define an other column that should be used for indentification. + toSyncCheckboxesWithSelection, // If checkboxes are shown, they follow the change in selections. When checkboxes are + // changed, the selections follow them and vice-versa. + // **Only supported for ctCheckBox type checkboxes. + toSelectNextNodeOnRemoval // If the selected node gets deleted, automatically select the next node. + ); + TVTSelectionOptions = set of TVTSelectionOption; + + TVTEditOptions = ( + toDefaultEdit, // Standard behaviour for end of editing (after VK_RETURN stay on edited cell). + toVerticalEdit, // After VK_RETURN switch to next column. + toHorizontalEdit // After VK_RETURN switch to next row. + ); + + // Options which do not fit into any of the other groups: + TVTMiscOption = ( + toAcceptOLEDrop, // Register tree as OLE accepting drop target + toCheckSupport, // Show checkboxes/radio buttons. + toEditable, // Node captions can be edited. + toFullRepaintOnResize, // Fully invalidate the tree when its window is resized (CS_HREDRAW/CS_VREDRAW). + toGridExtensions, // Use some special enhancements to simulate and support grid behavior. + toInitOnSave, // Initialize nodes when saving a tree to a stream. + toReportMode, // Tree behaves like TListView in report mode. + toToggleOnDblClick, // Toggle node expansion state when it is double clicked. + toWheelPanning, // Support for mouse panning (wheel mice only). This option and toMiddleClickSelect are + // mutal exclusive, where panning has precedence. + toReadOnly, // The tree does not allow to be modified in any way. No action is executed and + // node editing is not possible. + toVariableNodeHeight, // When set then GetNodeHeight will trigger OnMeasureItem to allow variable node heights. + toFullRowDrag, // Start node dragging by clicking anywhere in it instead only on the caption or image. + // Must be used together with toDisableDrawSelection. + toNodeHeightResize, // Allows changing a node's height via mouse. + toNodeHeightDblClickResize, // Allows to reset a node's height to FDefaultNodeHeight via a double click. + toEditOnClick, // Editing mode can be entered with a single click + toEditOnDblClick, // Editing mode can be entered with a double click + toReverseFullExpandHotKey // Used to define Ctrl+'+' instead of Ctrl+Shift+'+' for full expand (and similar for collapsing) + ); + TVTMiscOptions = set of TVTMiscOption; + + // Options to control data export + TVTExportMode = ( + emAll, // export all records (regardless checked state) + emChecked, // export checked records only + emUnchecked, // export unchecked records only + emVisibleDueToExpansion, // Do not export nodes that are not visible because their parent is not expanded + emSelected // export selected nodes only + ); + + // Describes the type of text to return in the text and draw info retrival events. + TVSTTextType = ( + ttNormal, // normal label of the node, this is also the text which can be edited + ttStatic // static (non-editable) text after the normal text + ); + + // Options regarding strings (useful only for the string tree and descendants): + TVTStringOption = ( + toSaveCaptions, // If set then the caption is automatically saved with the tree node, regardless of what is + // saved in the user data. + toShowStaticText, // Show static text in a caption which can be differently formatted than the caption + // but cannot be edited. + toAutoAcceptEditChange // Automatically accept changes during edit if the user finishes editing other then + // VK_RETURN or ESC. If not set then changes are cancelled. + ); + TVTStringOptions = set of TVTStringOption; + + // Be careful when adding new states as this might change the size of the type which in turn + // changes the alignment in the node record as well as the stream chunks. + // Do not reorder the states and always add new states at the end of this enumeration in order to avoid + // breaking existing code. + TVirtualNodeState = ( + vsInitialized, // Set after the node has been initialized. + vsChecking, // Node's check state is changing, avoid propagation. + vsCutOrCopy, // Node is selected as cut or copy and paste source. + vsDisabled, // Set if node is disabled. + vsDeleting, // Set when the node is about to be freed. + vsExpanded, // Set if the node is expanded. + vsHasChildren, // Indicates the presence of child nodes without actually setting them. + vsVisible, // Indicate whether the node is visible or not (independant of the expand states of its parents). + vsSelected, // Set if the node is in the current selection. + vsOnFreeNodeCallRequired, // Set if user data has been set which requires OnFreeNode. + vsAllChildrenHidden, // Set if vsHasChildren is set and no child node has the vsVisible flag set. + vsReleaseCallOnUserDataRequired, // Indicates that the user data is a reference to an interface which should be released. + vsMultiline, // Node text is wrapped at the cell boundaries instead of being shorted. + vsHeightMeasured, // Node height has been determined and does not need a recalculation. + vsToggling, // Set when a node is expanded/collapsed to prevent recursive calls. + vsFiltered, // Indicates that the node should not be painted (without effecting its children). + vsInitializing // Set when the node is being initialized + ); + TVirtualNodeStates = set of TVirtualNodeState; + + // States used in InitNode to indicate states a node shall initially have. + TVirtualNodeInitState = ( + ivsDisabled, + ivsExpanded, + ivsHasChildren, + ivsMultiline, + ivsSelected, + ivsFiltered, + ivsReInit + ); + TVirtualNodeInitStates = set of TVirtualNodeInitState; + + // Various events must be handled at different places than they were initiated or need + // a persistent storage until they are reset. + TVirtualTreeStates = set of ( + tsChangePending, // A selection change is pending. + tsCheckPropagation, // Set during automatic check state propagation. + tsCollapsing, // A full collapse operation is in progress. + tsToggleFocusedSelection, // Node selection was modifed using Ctrl-click. Change selection state on next mouse up. + tsClearPending, // Need to clear the current selection on next mouse move. + tsClearOnNewSelection, // Need to clear the current selection before selecting a new node + tsClipboardFlushing, // Set during flushing the clipboard to avoid freeing the content. + tsCopyPending, // Indicates a pending copy operation which needs to be finished. + tsCutPending, // Indicates a pending cut operation which needs to be finished. + tsDrawSelPending, // Multiselection only. User held down the left mouse button on a free + // area and might want to start draw selection. + tsDrawSelecting, // Multiselection only. Draw selection has actually started. + tsEditing, // Indicates that an edit operation is currently in progress. + tsEditPending, // An mouse up start edit if dragging has not started. + tsExpanding, // A full expand operation is in progress. + tsNodeHeightTracking, // A node height changing operation is in progress. + tsNodeHeightTrackPending, // left button is down, user might want to start changing a node's height. + tsHint, // Set when our hint is visible or soon will be. + tsInAnimation, // Set if the tree is currently in an animation loop. + tsIncrementalSearching, // Set when the user starts incremental search. + tsIncrementalSearchPending, // Set in WM_KEYDOWN to tell to use the char in WM_CHAR for incremental search. + tsIterating, // Set when IterateSubtree is currently in progress. + tsLeftButtonDown, // Set when the left mouse button is down. + tsLeftDblClick, // Set when the left mouse button was doubly clicked. + tsMiddleButtonDown, // Set when the middle mouse button is down. + tsMiddleDblClick, // Set when the middle mouse button was doubly clicked. + tsNeedRootCountUpdate, // Set if while loading a root node count is set. + tsOLEDragging, // OLE dragging in progress. + tsOLEDragPending, // User has requested to start delayed dragging. + tsPainting, // The tree is currently painting itself. + tsRightButtonDown, // Set when the right mouse button is down. + tsRightDblClick, // Set when the right mouse button was doubly clicked. + tsPopupMenuShown, // The user clicked the right mouse button, which might cause a popup menu to appear. + tsScrolling, // Set when autoscrolling is active. + tsScrollPending, // Set when waiting for the scroll delay time to elapse. + tsSizing, // Set when the tree window is being resized. This is used to prevent recursive calls + // due to setting the scrollbars when sizing. + tsStopValidation, // Cache validation can be stopped (usually because a change has occured meanwhile). + tsStructureChangePending, // The structure of the tree has been changed while the update was locked. + tsSynchMode, // Set when the tree is in synch mode, where no timer events are triggered. + tsThumbTracking, // Stop updating the horizontal scroll bar while dragging the vertical thumb and vice versa. + tsToggling, // A toggle operation (for some node) is in progress. + tsUpdateHiddenChildrenNeeded, // Pending update for the hidden children flag after massive visibility changes. + tsUseCache, // The tree's node caches are validated and non-empty. + tsUserDragObject, // Signals that the application created an own drag object in OnStartDrag. + tsUseThemes, // The tree runs under WinXP+, is theme aware and themes are enabled. + tsValidating, // The tree's node caches are currently validated. + tsPreviouslySelectedLocked,// The member FPreviouslySelected should not be changed + tsValidationNeeded, // Something in the structure of the tree has changed. The cache needs validation. + tsVCLDragging, // VCL drag'n drop in progress. + tsVCLDragPending, // One-shot flag to avoid clearing the current selection on implicit mouse up for VCL drag. + tsVCLDragFinished, // Flag to avoid triggering the OnColumnClick event twice + tsPanning, // Mouse panning is active. + tsWindowCreating, // Set during window handle creation to avoid frequent unnecessary updates. + tsUseExplorerTheme // The tree runs under WinVista+ and is using the explorer theme + ); + + + TCheckImageKind = ( + ckCustom, // application defined check images + ckSystemDefault // Uses the system check images, theme aware. + ); + + // mode to describe a move action + TVTNodeAttachMode = ( + amNoWhere, // just for simplified tests, means to ignore the Add/Insert command + amInsertBefore, // insert node just before destination (as sibling of destination) + amInsertAfter, // insert node just after destionation (as sibling of destination) + amAddChildFirst, // add node as first child of destination + amAddChildLast // add node as last child of destination + ); + + // modes to determine drop position further + TDropMode = ( + dmNowhere, + dmAbove, + dmOnNode, + dmBelow + ); + + // operations basically allowed during drag'n drop + TDragOperation = ( + doCopy, + doMove, + doLink + ); + TDragOperations = set of TDragOperation; + + TVTImageKind = ( + ikNormal, + ikSelected, + ikState, + ikOverlay + ); + + { + Fine points: Observed when fixing issue #623 + -- hmHint allows multiline hints automatically if provided through OnGetHint event. + This is irresptive of whether node itself is multi-line or not. + + -- hmToolTip shows a hint only when node text is not fully shown. It's meant to + fully show node text when not visible. It will show multi-line hint only if + the node itself is multi-line. If you provide a custom multi-line hint then + you must force linebreak style to hlbForceMultiLine in the OnGetHint event + in order to show the complete hint. + } + TVTHintMode = ( + hmDefault, // show the hint of the control + hmHint, // show node specific hint string returned by the application + hmHintAndDefault, // same as hmHint but show the control's hint if no node is concerned + hmTooltip // show the text of the node if it isn't already fully shown + ); + + // Indicates how to format a tooltip. + TVTTooltipLineBreakStyle = ( + hlbDefault, // Use multi-line style of the node. + hlbForceSingleLine, // Use single line hint. + hlbForceMultiLine // Use multi line hint. + ); + + TMouseButtons = set of TMouseButton; + + // Used to describe the action to do when using the OnBeforeItemErase event. + TItemEraseAction = ( + eaColor, // Use the provided color to erase the background instead the one of the tree. + eaDefault, // The tree should erase the item's background (bitmap or solid). + eaNone // Do nothing. Let the application paint the background. + ); + + + // Kinds of operations + TVTOperationKind = ( + okAutoFitColumns, + okGetMaxColumnWidth, + okSortNode, + okSortTree, + okExport, + okExpand + ); + TVTOperationKinds = set of TVTOperationKind; + + // Indicates in the OnUpdating event what state the tree is currently in. + TVTUpdateState = ( + usBegin, // The tree just entered the update state (BeginUpdate call for the first time). + usBeginSynch, // The tree just entered the synch update state (BeginSynch call for the first time). + usSynch, // Begin/EndSynch has been called but the tree did not change the update state. + usUpdate, // Begin/EndUpdate has been called but the tree did not change the update state. + usEnd, // The tree just left the update state (EndUpdate called for the last level). + usEndSynch // The tree just left the synch update state (EndSynch called for the last level). + ); + + // These elements are used both to query the application, which of them it wants to draw itself and to tell it during + // painting, which elements must be drawn during the advanced custom draw events. + THeaderPaintElements = set of ( + hpeBackground, + hpeDropMark, + hpeHeaderGlyph, + hpeSortGlyph, + hpeText, + // New in 7.0: Use this in FOnHeaderDrawQueryElements and OnAdvancedHeaderDraw + // for additional custom header drawing while keeping the default drawing + hpeOverlay + ); + + // determines whether and how the drag image is to show + TVTDragImageKind = ( + diComplete, // show a complete drag image with all columns, only visible columns are shown + diMainColumnOnly, // show only the main column (the tree column) + diNoImage // don't show a drag image at all + ); + + // Switch for OLE and VCL drag'n drop. Because it is not possible to have both simultanously. + TVTDragType = ( + dtOLE, + dtVCL + ); + + // Determines the look of a tree's lines that show the hierarchy + TVTLineStyle = ( + lsCustomStyle, // application provides a line pattern + lsDotted, // usual dotted lines (default) + lsSolid // simple solid lines + ); + + // TVTLineType is used during painting a tree for its tree lines that show the hierarchy + TVTLineType = ( + ltNone, // no line at all + ltBottomRight, // a line from bottom to the center and from there to the right + ltTopDown, // a line from top to bottom + ltTopDownRight, // a line from top to bottom and from center to the right + ltRight, // a line from center to the right + ltTopRight, // a line from bottom to center and from there to the right + // special styles for alternative drawings of tree lines + ltLeft, // a line from top to bottom at the left + ltLeftBottom // a combination of ltLeft and a line at the bottom from left to right + ); + + // Determines how to draw tree lines. + TVTLineMode = ( + lmNormal, // usual tree lines (as in TTreeview) + lmBands // looks similar to a Nassi-Schneidermann diagram + ); + + // A collection of line type IDs which is used while painting a node. + TLineImage = array of TVTLineType; + + + // Export type + TVTExportType = ( + etNone, // No export, normal displaying on the screen + etRTF, // contentToRTF + etHTML, // contentToHTML + etText, // contentToText + etExcel, // supported by external tools + etWord, // supported by external tools + etPDF, // supported by external tools + etPrinter,// supported by external tools + etCSV, // supported by external tools + etCustom // supported by external tools + ); + + // Options which are used when modifying the scroll offsets. + TScrollUpdateOptions = set of ( + suoRepaintHeader, // if suoUpdateNCArea is also set then invalidate the header + suoRepaintScrollBars, // if suoUpdateNCArea is also set then repaint both scrollbars after updating them + suoScrollClientArea, // scroll and invalidate the proper part of the client area + suoUpdateNCArea // update non-client area (scrollbars, header) + ); + + // Determines the look of a tree's buttons. + TVTButtonStyle = ( + bsRectangle, // traditional Windows look (plus/minus buttons) + bsTriangle // traditional Macintosh look + ); + + // TButtonFillMode is only used when the button style is bsRectangle and determines how to fill the interior. + TVTButtonFillMode = ( + fmTreeColor, // solid color, uses the tree's background color + fmWindowColor, // solid color, uses clWindow + fmShaded, // no longer supported, use toThemeAware for Windows XP and later instead + fmTransparent // transparent color, use the item's background color + ); + + // Method called by the Animate routine for each animation step. + TVTAnimationCallback = function(Step, StepSize: Integer; Data: Pointer): Boolean of object; + + TVTIncrementalSearch = ( + isAll, // search every node in tree, initialize if necessary + isNone, // disable incremental search + isInitializedOnly, // search only initialized nodes, skip others + isVisibleOnly // search only visible nodes, initialize if necessary + ); + + // Determines which direction to use when advancing nodes during an incremental search. + TVTSearchDirection = ( + sdForward, + sdBackward + ); + + // Determines where to start incremental searching for each key press. + TVTSearchStart = ( + ssAlwaysStartOver, // always use the first/last node (depending on direction) to search from + ssLastHit, // use the last found node + ssFocusedNode // use the currently focused node + ); + + // Determines how to use the align member of a node. + TVTNodeAlignment = ( + naFromBottom, // the align member specifies amount of units (usually pixels) from top border of the node + naFromTop, // align is to be measured from bottom + naProportional // align is to be measure in percent of the entire node height and relative to top + ); + + // Determines how to draw the selection rectangle used for draw selection. + TVTDrawSelectionMode = ( + smDottedRectangle, // same as DrawFocusRect + smBlendedRectangle // alpha blending, uses special colors (see TVTColors) + ); + + // Determines for which purpose the cell paint event is called. + TVTCellPaintMode = ( + cpmPaint, // painting the cell + cpmGetContentMargin // getting cell content margin + ); + + // Determines which sides of the cell content margin should be considered. + TVTCellContentMarginType = ( + ccmtAllSides, // consider all sides + ccmtTopLeftOnly, // consider top margin and left margin only + ccmtBottomRightOnly // consider bottom margin and right margin only + ); + + TChangeReason = ( + crIgnore, // used as placeholder + crAccumulated, // used for delayed changes + crChildAdded, // one or more child nodes have been added + crChildDeleted, // one or more child nodes have been deleted + crNodeAdded, // a node has been added + crNodeCopied, // a node has been duplicated + crNodeMoved // a node has been moved to a new place + ); // desribes what made a structure change event happen + + TChunkHeader = record + ChunkType, + ChunkSize: Integer; // contains the size of the chunk excluding the header + end; + +const + DefaultPaintOptions = [toShowButtons, toShowDropmark, toShowTreeLines, toShowRoot, toThemeAware, toUseBlendedImages, toFullVertGridLines]; + DefaultAnimationOptions = []; + DefaultAutoOptions = [toAutoDropExpand, toAutoTristateTracking, toAutoScrollOnExpand, toAutoDeleteMovedNodes, toAutoChangeScale, toAutoSort, toAutoHideButtons]; + DefaultSelectionOptions = [toSelectNextNodeOnRemoval]; + DefaultMiscOptions = [toAcceptOLEDrop, toFullRepaintOnResize, toInitOnSave, toToggleOnDblClick, toWheelPanning, toEditOnClick]; + + DefaultStringOptions = [toSaveCaptions, toAutoAcceptEditChange]; + +type + TCustomVirtualTreeOptions = class(TPersistent) + private + FOwner : TCustomControl; + FPaintOptions : TVTPaintOptions; + FAnimationOptions : TVTAnimationOptions; + FAutoOptions : TVTAutoOptions; + FSelectionOptions : TVTSelectionOptions; + FMiscOptions : TVTMiscOptions; + FExportMode : TVTExportMode; + FEditOptions : TVTEditOptions; + procedure SetAnimationOptions(const Value : TVTAnimationOptions); + procedure SetAutoOptions(const Value : TVTAutoOptions); + procedure SetMiscOptions(const Value : TVTMiscOptions); + procedure SetPaintOptions(const Value : TVTPaintOptions); + procedure SetSelectionOptions(const Value : TVTSelectionOptions); + protected + // Mitigator function to use the correct style service for this context (either the style assigned to the control for Delphi > 10.4 or the application style) + function StyleServices(AControl : TControl = nil) : TCustomStyleServices; + public + constructor Create(AOwner : TCustomControl); virtual; + //these bypass the side effects in the regular setters. + procedure InternalSetMiscOptions(const Value : TVTMiscOptions); + + procedure AssignTo(Dest : TPersistent); override; + property AnimationOptions : TVTAnimationOptions read FAnimationOptions write SetAnimationOptions default DefaultAnimationOptions; + property AutoOptions : TVTAutoOptions read FAutoOptions write SetAutoOptions default DefaultAutoOptions; + property ExportMode : TVTExportMode read FExportMode write FExportMode default emAll; + property MiscOptions : TVTMiscOptions read FMiscOptions write SetMiscOptions default DefaultMiscOptions; + property PaintOptions : TVTPaintOptions read FPaintOptions write SetPaintOptions default DefaultPaintOptions; + property SelectionOptions : TVTSelectionOptions read FSelectionOptions write SetSelectionOptions default DefaultSelectionOptions; + property EditOptions : TVTEditOptions read FEditOptions write FEditOptions default toDefaultEdit; + + property Owner: TCustomControl read FOwner; + end; + + TTreeOptionsClass = class of TCustomVirtualTreeOptions; + + TVirtualTreeOptions = class(TCustomVirtualTreeOptions) + published + property AnimationOptions; + property AutoOptions; + property ExportMode; + property MiscOptions; + property PaintOptions; + property SelectionOptions; + end; + + TCustomStringTreeOptions = class(TCustomVirtualTreeOptions) + private + FStringOptions : TVTStringOptions; + procedure SetStringOptions(const Value : TVTStringOptions); + protected + public + constructor Create(AOwner : TCustomControl); override; + procedure AssignTo(Dest : TPersistent); override; + property StringOptions : TVTStringOptions read FStringOptions write SetStringOptions default DefaultStringOptions; + end; + + TStringTreeOptions = class(TCustomStringTreeOptions) + published + property AnimationOptions; + property AutoOptions; + property ExportMode; + property MiscOptions; + property PaintOptions; + property SelectionOptions; + property StringOptions; + property EditOptions; + end; + + TScrollBarStyle = ( + sbmRegular, + sbm3D + ); + + // A class to manage scroll bar aspects. + TScrollBarOptions = class(TPersistent) + private + FAlwaysVisible : Boolean; + FOwner : TCustomControl; + FScrollBars : TScrollStyle; // used to hide or show vertical and/or horizontal scrollbar + FScrollBarStyle : TScrollBarStyle; // kind of scrollbars to use + FIncrementX, FIncrementY : TVTScrollIncrement; // number of pixels to scroll in one step (when auto scrolling) + procedure SetAlwaysVisible(Value : Boolean); + procedure SetScrollBars(Value : TScrollStyle); + procedure SetScrollBarStyle(Value : TScrollBarStyle); + protected + function GetOwner : TPersistent; override; + public + constructor Create(AOwner : TCustomControl); + + procedure Assign(Source : TPersistent); override; + published + property AlwaysVisible : Boolean read FAlwaysVisible write SetAlwaysVisible default False; + property HorizontalIncrement : TVTScrollIncrement read FIncrementX write FIncrementX default 20; + property ScrollBars : TScrollStyle read FScrollBars write SetScrollBars default TScrollStyle.ssBoth; + property ScrollBarStyle : TScrollBarStyle read FScrollBarStyle write SetScrollBarStyle default sbmRegular; + property VerticalIncrement : TVTScrollIncrement read FIncrementY write FIncrementY default 20; + end; + + PVirtualNode = ^TVirtualNode; + + TVirtualNode = packed record + private + fIndex: Cardinal; // index of node with regard to its parent + fChildCount: Cardinal; // number of child nodes + fNodeHeight: TNodeHeight; // height in pixels + public + States: TVirtualNodeStates; // states describing various properties of the node (expanded, initialized etc.) + Align: Byte; // line/button alignment + CheckState: TCheckState; // indicates the current check state (e.g. checked, pressed etc.) + CheckType: TCheckType; // indicates which check type shall be used for this node + Dummy: Byte; // dummy value to fill DWORD boundary + TotalCount: Cardinal; // sum of this node, all of its child nodes and their child nodes etc. + TotalHeight: TNodeHeight;// height in pixels this node covers on screen including the height of all of its children. + _Filler: TDWordFiller; // Ensure 8 Byte alignment of following pointers for 64bit builds. Issue #1136 + // Note: Some copy routines require that all pointers (as well as the data area) in a node are + // located at the end of the node! Hence if you want to add new member fields (except pointers to internal + // data) then put them before field Parent. + private + fParent: PVirtualNode; // reference to the node's parent (for the root this contains the treeview) + fPrevSibling: PVirtualNode; // link to the node's previous sibling or nil if it is the first node + fNextSibling: PVirtualNode; // link to the node's next sibling or nil if it is the last node + public // still public as it is used as var parameter in MergeSortAscending() + FirstChild: PVirtualNode; // link to the node's first child... + private + fLastChild: PVirtualNode; // link to the node's last child... + public + procedure SetParent(const pParent: PVirtualNode); inline; //internal method, do not call directly but use Parent[Node] := x on tree control. + procedure SetPrevSibling(const pPrevSibling: PVirtualNode); inline; //internal method, do not call directly + procedure SetNextSibling(const pNextSibling: PVirtualNode); inline; //internal method, do not call directly + procedure SetFirstChild(const pFirstChild: PVirtualNode); inline; //internal method, do not call directly + procedure SetLastChild(const pLastChild: PVirtualNode); inline; //internal method, do not call directly + procedure SetIndex(const pIndex: Cardinal); inline; //internal method, do not call directly. + procedure SetChildCount(const pCount: Cardinal); inline; //internal method, do not call directly. + procedure SetNodeHeight(const pNodeHeight: TNodeHeight); inline; //internal method, do not call directly. + property Index: Cardinal read fIndex; + property ChildCount: Cardinal read fChildCount; + property Parent: PVirtualNode read fParent; + property PrevSibling: PVirtualNode read fPrevSibling; + property NextSibling: PVirtualNode read fNextSibling; + property LastChild: PVirtualNode read fLastChild; + property NodeHeight: TNodeHeight read fNodeHeight; + private + Data: record end; // this is a placeholder, each node gets extra data determined by NodeDataSize + public + function IsAssigned(): Boolean; inline; + function GetData(): Pointer; overload; inline; + function GetData(): T; overload; inline; + procedure SetData(pUserData: Pointer); overload; + procedure SetData(pUserData: T); overload; + procedure SetData(const pUserData: IInterface); overload; + end; + + + TVTHeaderColumnLayout = ( + blGlyphLeft, + blGlyphRight, + blGlyphTop, + blGlyphBottom + ); + + // These flags are used to indicate where a click in the header happened. + TVTHeaderHitPosition = ( + hhiNoWhere, // No column is involved (possible only if the tree is smaller than the client area). + hhiOnColumn, // On a column. + hhiOnIcon, // On the bitmap associated with a column. + hhiOnCheckbox // On the checkbox if enabled. + ); + TVTHeaderHitPositions = set of TVTHeaderHitPosition; + + // These flags are returned by the hit test method. + THitPosition = ( + hiAbove, // above the client area (if relative) or the absolute tree area + hiBelow, // below the client area (if relative) or the absolute tree area + hiNowhere, // no node is involved (possible only if the tree is not as tall as the client area) + hiOnItem, // on the bitmaps/buttons or label associated with an item + hiOnItemButton, // on the button associated with an item + hiOnItemButtonExact, // exactly on the button associated with an item + hiOnItemCheckbox, // on the checkbox if enabled + hiOnItemIndent, // in the indentation area in front of a node + hiOnItemLabel, // on the normal text area associated with an item + hiOnItemLeft, // in the area to the left of a node's text area (e.g. when right aligned or centered) + hiOnItemRight, // in the area to the right of a node's text area (e.g. if left aligned or centered) + hiOnNormalIcon, // on the "normal" image + hiOnStateIcon, // on the state image + hiToLeft, // to the left of the client area (if relative) or the absolute tree area + hiToRight, // to the right of the client area (if relative) or the absolute tree area + hiUpperSplitter, // in the upper splitter area of a node + hiLowerSplitter // in the lower splitter area of a node + ); + THitPositions = set of THitPosition; + + // Structure used when info about a certain position in the header is needed. + TVTHeaderHitInfo = record + X, + Y: TDimension; + Button: TMouseButton; + Shift: TShiftState; + Column: TColumnIndex; + HitPosition: TVTHeaderHitPositions; + end; + + // Structure used when info about a certain position in the tree is needed. + THitInfo = record + HitNode: PVirtualNode; + HitPositions: THitPositions; + HitColumn: TColumnIndex; + HitPoint: TPoint; + ShiftState: TShiftState; + end; + + TVTHeaderStyle = ( + hsThickButtons, //TButton look and feel + hsFlatButtons, //flatter look than hsThickButton, like an always raised flat TToolButton + hsPlates //flat TToolButton look and feel (raise on hover etc.) + ); + + TVTHeaderOption = ( + hoAutoResize, //Adjust a column so that the header never exceeds the client width of the owner control. + hoColumnResize, //Resizing columns with the mouse is allowed. + hoDblClickResize, //Allows a column to resize itself to its largest entry. + hoDrag, //Dragging columns is allowed. + hoHotTrack, //Header captions are highlighted when mouse is over a particular column. + hoOwnerDraw, //Header items with the owner draw style can be drawn by the application via event. + hoRestrictDrag, //Header can only be dragged horizontally. + hoShowHint, //Show application defined header hint. + hoShowImages, //Show header images. + hoShowSortGlyphs, //Allow visible sort glyphs. + hoVisible, //Header is visible. + hoAutoSpring, //Distribute size changes of the header to all columns, which are sizable and have the coAutoSpring option enabled. + hoFullRepaintOnResize, //Fully invalidate the header (instead of subsequent columns only) when a column is resized. + hoDisableAnimatedResize, //Disable animated resize for all columns. + hoHeightResize, //Allow resizing header height via mouse. + hoHeightDblClickResize, //Allow the header to resize itself to its default height. + hoHeaderClickAutoSort, //Clicks on the header will make the clicked column the SortColumn or toggle sort direction if it already was the sort column + hoAutoColumnPopupMenu, //Show a context menu for activating and deactivating columns on right click + hoAutoResizeInclCaption //Includes the header caption for the auto resizing + ); + TVTHeaderOptions = set of TVTHeaderOption; + + THeaderState = ( + hsAutoSizing, //auto size chain is in progess, do not trigger again on WM_SIZE + hsDragging, //header dragging is in progress (only if enabled) + hsDragPending, //left button is down, user might want to start dragging a column + hsLoading, //The header currently loads from stream, so updates are not necessary. + hsColumnWidthTracking, //column resizing is in progress + hsColumnWidthTrackPending, //left button is down, user might want to start resize a column + hsHeightTracking, //height resizing is in progress + hsHeightTrackPending, //left button is down, user might want to start changing height + hsResizing, //multi column resizing in progress + hsScaling, //the header is scaled after a change of FixedAreaConstraints or client size + hsNeedScaling //the header needs to be scaled + ); + THeaderStates = set of THeaderState; + + // content elements of the control from left to right, used when calculatin left margins. + TVTElement = ( + ofsMargin, // right of the margin + ofsToggleButton, // the exact x-postition of the toggle button + ofsCheckBox, + ofsStateImage, + ofsImage, + ofsLabel, // where drawing a selection begins + ofsText, // includes TextMargin + ofsRightOfText, // Includes NodeWidth and ExtraNodeWidth + ofsEndOfClientArea // The end of the paint area + ); + + /// An array that can be used to calculate the offsets ofthe elements in the tree. + TVTOffsets = array [TVTElement] of TDimension; + + // For painting a node and its columns/cells a lot of information must be passed frequently around. + TVTImageInfo = record + Index: TImageIndex; // Index in the associated image list. + XPos, // Horizontal position in the current target canvas. + YPos: TDimension; // Vertical position in the current target canvas. + Ghosted: Boolean; // Flag to indicate that the image must be drawn slightly lighter. + Images: TCustomImageList; // The image list to be used for painting. + function Equals(const pImageInfo2: TVTImageInfo): Boolean; + end; + + TVTImageInfoIndex = ( + iiNormal, + iiState, + iiCheck, + iiOverlay + ); + + // options which determine what to draw in PaintTree + TVTInternalPaintOption = ( + poBackground, // draw background image if there is any and it is enabled + poColumnColor, // erase node's background with the column's color + poDrawFocusRect, // draw focus rectangle around the focused node + poDrawSelection, // draw selected nodes with the normal selection color + poDrawDropMark, // draw drop mark if a node is currently the drop target + poGridLines, // draw grid lines if enabled + poMainOnly, // draw only the main column + poSelectedOnly, // draw only selected nodes + poUnbuffered // draw directly onto the target canvas; especially useful when printing + ); + TVTInternalPaintOptions = set of TVTInternalPaintOption; + + TVTPaintInfo = record + Canvas: TCanvas; // the canvas to paint on + PaintOptions: TVTInternalPaintOptions; // a copy of the paint options passed to PaintTree + Node: PVirtualNode; // the node to paint + Column: TColumnIndex; // the node's column index to paint + Position: TColumnPosition; // the column position of the node + CellRect: TRect; // the node cell + ContentRect: TRect; // the area of the cell used for the node's content + NodeWidth: TDimension; // the actual node width + Alignment: TAlignment; // how to align within the node rectangle + CaptionAlignment: TAlignment; // how to align text within the caption rectangle + BidiMode: TBidiMode; // directionality to be used for painting + BrushOrigin: TPoint; // the alignment for the brush used to draw dotted lines + ImageInfo: array[TVTImageInfoIndex] of TVTImageInfo; // info about each possible node image + Offsets: TVTOffsets; // The offsets of the various elements of a tree node + VAlign: TDimension; + procedure AdjustImageCoordinates(); + end; + + TNodeArray = array of PVirtualNode; + +implementation + +uses + System.TypInfo, + VirtualTrees.StyleHooks, + VirtualTrees.BaseTree, + VirtualTrees.BaseAncestorVcl{to eliminate H2443 about inline expanding} + ; + +type + TVTCracker = class(TBaseVirtualTree); + + +{ TVirtualNode } + +function TVirtualNode.GetData(): Pointer; + +// Returns the associated data converted to the class given in the generic part of the function. + +begin + Result := @Self.Data; + Include(States, vsOnFreeNodeCallRequired); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualNode.GetData: T; + +// Returns the associated data converted to the class given in the generic part of the function. + +begin + Result := T(Pointer((PByte(@(Self.Data))))^); + Include(States, vsOnFreeNodeCallRequired); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualNode.IsAssigned: Boolean; + +// Returns False if this node is nil, True otherwise + +begin + Exit(@Self <> nil); +end; + +procedure TVirtualNode.SetNodeHeight(const pNodeHeight: TNodeHeight); +begin + fNodeHeight := pNodeHeight; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualNode.SetData(pUserData: Pointer); + + + // Can be used to set user data of a PVirtualNode with the size of a pointer, useful for setting + // A pointer to a record or a reference to a class instance. +var + NodeData: PPointer; +begin + NodeData := PPointer(@Self.Data); + NodeData^ := pUserData; + Include(Self.States, vsOnFreeNodeCallRequired); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualNode.SetChildCount(const pCount: Cardinal); +begin + fChildCount := pCount; +end; + +procedure TVirtualNode.SetData(const pUserData: IInterface); + + + // Can be used to set user data of a PVirtualNode to a class instance, + // will take care about reference counting. + +begin + pUserData._AddRef(); + SetData(Pointer(pUserData)); + Include(Self.States, vsReleaseCallOnUserDataRequired); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualNode.SetData(pUserData: T); + +begin + T(Pointer((PByte(@(Self.Data))))^) := pUserData; + if PTypeInfo(TypeInfo(T)).Kind = tkInterface then + Include(Self.States, vsReleaseCallOnUserDataRequired); + Include(Self.States, vsOnFreeNodeCallRequired); +end; + +procedure TVirtualNode.SetFirstChild(const pFirstChild: PVirtualNode); +begin + FirstChild := pFirstChild; +end; + +procedure TVirtualNode.SetLastChild(const pLastChild: PVirtualNode); +begin + fLastChild := pLastChild; +end; + +procedure TVirtualNode.SetIndex(const pIndex: Cardinal); +begin + fIndex := pIndex; +end; + +procedure TVirtualNode.SetParent(const pParent: PVirtualNode); +begin + fParent := pParent; +end; + +procedure TVirtualNode.SetPrevSibling(const pPrevSibling: PVirtualNode); +begin + fPrevSibling := pPrevSibling; +end; + +procedure TVirtualNode.SetNextSibling(const pNextSibling: PVirtualNode); +begin + fNextSibling := pNextSibling; +end; + +//---------------------------------------------------------------------------------------------------------------------- + + +{ TVTImageInfo } + +function TVTImageInfo.Equals(const pImageInfo2: TVTImageInfo): Boolean; + + // Returns true if both images are the same, does not regard Ghosted and position. + +begin + Result := (Self.Index = pImageInfo2.Index) and (Self.Images = pImageInfo2.Images); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +{ TVTPaintInfo } + +procedure TVTPaintInfo.AdjustImageCoordinates(); +// During painting of the main column some coordinates must be adjusted due to the tree lines. +begin + ContentRect := CellRect; + if BidiMode = bdLeftToRight then + begin + ContentRect.Left := CellRect.Left + Offsets[TVTElement.ofsLabel]; + ImageInfo[iiNormal].XPos := CellRect.Left + Offsets[TVTElement.ofsImage]; + ImageInfo[iiState].XPos := CellRect.Left + Offsets[TVTElement.ofsStateImage]; + ImageInfo[iiCheck].XPos := CellRect.Left + Offsets[TVTElement.ofsCheckBox]; + end + else + begin + /// Since images are still drawn from left to right, we need to substract the image sze as well. + ImageInfo[iiNormal].XPos := CellRect.Right - Offsets[TVTElement.ofsImage] - (Offsets[TVTElement.ofsLabel] - Offsets[TVTElement.ofsImage]); + ImageInfo[iiState].XPos := CellRect.Right - Offsets[TVTElement.ofsStateImage] - (Offsets[TVTElement.ofsImage] - Offsets[TVTElement.ofsStateImage]); + ImageInfo[iiCheck].XPos := CellRect.Right - Offsets[TVTElement.ofsCheckBox] - (Offsets[TVTElement.ofsStateImage] - Offsets[TVTElement.ofsCheckBox]); + ContentRect.Right := CellRect.Right - Offsets[TVTElement.ofsLabel]; + end; + if ImageInfo[iiNormal].Index > -1 then + ImageInfo[iiNormal].YPos := CellRect.Top + VAlign - ImageInfo[iiNormal].Images.Height div 2; + if ImageInfo[iiState].Index > -1 then + ImageInfo[iiState].YPos := CellRect.Top + VAlign - ImageInfo[iiState].Images.Height div 2; + if ImageInfo[iiCheck].Index > -1 then + ImageInfo[iiCheck].YPos := CellRect.Top + VAlign - ImageInfo[iiCheck].Images.Height div 2; +end; + + +//----------------- TCustomVirtualTreeOptions -------------------------------------------------------------------------- + +constructor TCustomVirtualTreeOptions.Create(AOwner : TCustomControl); +begin + FOwner := AOwner; + + FPaintOptions := DefaultPaintOptions; + FAnimationOptions := DefaultAnimationOptions; + FAutoOptions := DefaultAutoOptions; + FSelectionOptions := DefaultSelectionOptions; + FMiscOptions := DefaultMiscOptions; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TCustomVirtualTreeOptions.SetAnimationOptions(const Value : TVTAnimationOptions); +begin + FAnimationOptions := Value; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TCustomVirtualTreeOptions.SetAutoOptions(const Value : TVTAutoOptions); +var + ChangedOptions : TVTAutoOptions; +begin + if FAutoOptions <> Value then + begin + // Exclusive ORing to get all entries wich are in either set but not in both. + ChangedOptions := FAutoOptions + Value - (FAutoOptions * Value); + FAutoOptions := Value; + with FOwner do + if (toAutoSpanColumns in ChangedOptions) and not (csLoading in ComponentState) and HandleAllocated then + Invalidate; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TCustomVirtualTreeOptions.InternalSetMiscOptions(const Value : TVTMiscOptions); +begin + FMiscOptions := Value; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TCustomVirtualTreeOptions.SetMiscOptions(const Value : TVTMiscOptions); +var + ToBeSet, ToBeCleared : TVTMiscOptions; +begin + if FMiscOptions <> Value then + begin + ToBeSet := Value - FMiscOptions; + ToBeCleared := FMiscOptions - Value; + FMiscOptions := Value; + + with TVTCracker(FOwner) do + if not (csLoading in ComponentState) and HandleAllocated then + begin + if toCheckSupport in ToBeSet + ToBeCleared then + Invalidate; + if toEditOnDblClick in ToBeSet then + FMiscOptions := FMiscOptions - [toToggleOnDblClick]; + // In order for toEditOnDblClick to take effect, we need to remove toToggleOnDblClick which is handled with priority. See issue #747 + + if not (csDesigning in ComponentState) then + begin + if toFullRepaintOnResize in ToBeSet + ToBeCleared then + RecreateWnd; + if toVariableNodeHeight in ToBeSet then + begin + BeginUpdate(); + try + ReInitNode(nil, True); + finally + EndUpdate(); + end; //try..finally + end; //if toVariableNodeHeight + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TCustomVirtualTreeOptions.SetPaintOptions(const Value : TVTPaintOptions); +var + ToBeSet, ToBeCleared : TVTPaintOptions; + Run : PVirtualNode; + HandleWasAllocated : Boolean; +begin + if FPaintOptions <> Value then + begin + ToBeSet := Value - FPaintOptions; + ToBeCleared := FPaintOptions - Value; + FPaintOptions := Value; + if (toFixedIndent in ToBeSet) then + begin + // Fixes issue #388 + Include(FPaintOptions, toShowRoot); + Include(ToBeSet, toShowRoot); + end; //if + with TVTCracker(FOwner) do + begin + HandleWasAllocated := HandleAllocated; + + if not (csLoading in ComponentState) and (toShowFilteredNodes in ToBeSet + ToBeCleared) then + begin + if HandleWasAllocated then + BeginUpdate; + InterruptValidation; + Run := GetFirstNoInit; + while Assigned(Run) do + begin + if (vsFiltered in Run.States) then + begin + if FullyVisible[Run] then + begin + if toShowFilteredNodes in ToBeSet then + IncVisibleCount + else + DecVisibleCount; + end; + if toShowFilteredNodes in ToBeSet then + AdjustTotalHeight(Run, Run.NodeHeight, True) + else + AdjustTotalHeight(Run, - Run.NodeHeight, True); + end; + Run := GetNextNoInit(Run); + end; + if HandleWasAllocated then + EndUpdate; + end; + + if HandleAllocated then + begin + if ((tsUseThemes in TreeStates) or ((toThemeAware in ToBeSet) and StyleServices.Enabled)) and (toUseExplorerTheme in (ToBeSet + ToBeCleared)) and + not VclStyleEnabled then + begin + if (toUseExplorerTheme in ToBeSet) then + begin + SetWindowTheme('explorer'); + DoStateChange([tsUseExplorerTheme]); + end + else if toUseExplorerTheme in ToBeCleared then + begin + SetWindowTheme(''); + DoStateChange([], [tsUseExplorerTheme]); + end; + end; + + if not (csLoading in ComponentState) then + begin + if ((toThemeAware in ToBeSet + ToBeCleared) or (toUseExplorerTheme in ToBeSet + ToBeCleared) or VclStyleEnabled) then + begin + if ((toThemeAware in ToBeSet) and StyleServices.Enabled) then + DoStateChange([tsUseThemes]) + else if (toThemeAware in ToBeCleared) then + DoStateChange([], [tsUseThemes]); + + PrepareBitmaps(True, False); + RedrawWindow(nil, 0, RDW_INVALIDATE or RDW_VALIDATE or RDW_FRAME); + end; + + if toChildrenAbove in ToBeSet + ToBeCleared then + begin + InvalidateCache; + if UpdateCount = 0 then + begin + ValidateCache; + Invalidate; + end; + end; + + Invalidate; + end; + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TCustomVirtualTreeOptions.SetSelectionOptions(const Value : TVTSelectionOptions); +var + ToBeSet, ToBeCleared : TVTSelectionOptions; +begin + if FSelectionOptions <> Value then + begin + ToBeSet := Value - FSelectionOptions; + ToBeCleared := FSelectionOptions - Value; + FSelectionOptions := Value; + + with TVTCracker(FOwner) do + begin + if (toMultiSelect in (ToBeCleared + ToBeSet)) or ([toLevelSelectConstraint, toSiblingSelectConstraint] * ToBeSet <> []) then + ClearSelection; + + if (toExtendedFocus in ToBeCleared) and (FocusedColumn > 0) and HandleAllocated then + begin + FocusedColumn := Header.MainColumn; + Invalidate; + end; + + if not (toExtendedFocus in FSelectionOptions) then + FocusedColumn := Header.MainColumn; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TCustomVirtualTreeOptions.StyleServices(AControl : TControl) : TCustomStyleServices; +begin + Result := VTStyleServices(FOwner); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TCustomVirtualTreeOptions.AssignTo(Dest : TPersistent); +begin + if Dest is TCustomVirtualTreeOptions then + begin + with Dest as TCustomVirtualTreeOptions do + begin + PaintOptions := Self.PaintOptions; + AnimationOptions := Self.AnimationOptions; + AutoOptions := Self.AutoOptions; + SelectionOptions := Self.SelectionOptions; + MiscOptions := Self.MiscOptions; + end; + end + else + inherited; +end; + +//----------------- TCustomStringTreeOptions --------------------------------------------------------------------------- + +constructor TCustomStringTreeOptions.Create(AOwner : TCustomControl); +begin + inherited; + FStringOptions := DefaultStringOptions; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TCustomStringTreeOptions.SetStringOptions(const Value : TVTStringOptions); +var + ChangedOptions : TVTStringOptions; +begin + if FStringOptions <> Value then + begin + // Exclusive ORing to get all entries wich are in either set but not in both. + ChangedOptions := FStringOptions + Value - (FStringOptions * Value); + FStringOptions := Value; + with FOwner do + if (toShowStaticText in ChangedOptions) and not (csLoading in ComponentState) and HandleAllocated then + Invalidate; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TCustomStringTreeOptions.AssignTo(Dest : TPersistent); +begin + if Dest is TCustomStringTreeOptions then + begin + with Dest as TCustomStringTreeOptions do + begin + StringOptions := Self.StringOptions; + EditOptions := Self.EditOptions; + end; + end; + + // Let ancestors assign their options to the destination class. + inherited; +end; + +//----------------- TScrollBarOptions ---------------------------------------------------------------------------------- + +constructor TScrollBarOptions.Create(AOwner : TCustomControl); +begin + inherited Create; + + FOwner := AOwner; + FAlwaysVisible := False; + FScrollBarStyle := sbmRegular; + FScrollBars := TScrollStyle.ssBoth; + FIncrementX := 20; + FIncrementY := 20; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TScrollBarOptions.SetAlwaysVisible(Value : Boolean); +begin + if FAlwaysVisible <> Value then + begin + FAlwaysVisible := Value; + if not (csLoading in FOwner.ComponentState) and FOwner.HandleAllocated then + TVTCracker(FOwner).RecreateWnd; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TScrollBarOptions.SetScrollBars(Value : TScrollStyle); +begin + if FScrollBars <> Value then + begin + FScrollBars := Value; + if not (csLoading in FOwner.ComponentState) and FOwner.HandleAllocated then + TVTCracker(FOwner).RecreateWnd; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TScrollBarOptions.SetScrollBarStyle(Value : TScrollBarStyle); + +begin + if FScrollBarStyle <> Value then + begin + FScrollBarStyle := Value; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TScrollBarOptions.GetOwner : TPersistent; + +begin + Result := FOwner; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TScrollBarOptions.Assign(Source : TPersistent); + +begin + if Source is TScrollBarOptions then + begin + AlwaysVisible := TScrollBarOptions(Source).AlwaysVisible; + HorizontalIncrement := TScrollBarOptions(Source).HorizontalIncrement; + ScrollBars := TScrollBarOptions(Source).ScrollBars; + ScrollBarStyle := TScrollBarOptions(Source).ScrollBarStyle; + VerticalIncrement := TScrollBarOptions(Source).VerticalIncrement; + end + else + inherited; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +{ TCheckStateHelper } + +function TCheckStateHelper.IsDisabled: Boolean; +begin + Result := Self >= TCheckState.csUncheckedDisabled; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TCheckStateHelper.IsChecked: Boolean; +begin + Result := Self in [csCheckedNormal, csCheckedPressed, csCheckedDisabled]; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TCheckStateHelper.IsUnChecked: Boolean; +begin + Result := Self in [csUncheckedNormal, csUncheckedPressed, csUncheckedDisabled]; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TCheckStateHelper.IsMixed: Boolean; +begin + Result := Self in [csMixedNormal, csMixedPressed, csMixedDisabled]; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TCheckStateHelper.GetEnabled: TCheckState; +begin + Result := cEnabledState[Self]; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TCheckStateHelper.GetPressed(): TCheckState; +begin + Result := cPressedState[Self]; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TCheckStateHelper.GetUnpressed(): TCheckState; +begin + Result := cUnpressedState[Self]; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TCheckStateHelper.GetToggled(): TCheckState; +begin + Result := cToggledState[Self]; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +{ TSortDirectionHelper } + +function TSortDirectionHelper.ToInt() : Integer; +begin + Result := cSortDirectionToInt[Self]; +end; + + +end. diff --git a/components/virtualtreeview/Source/VirtualTrees.Utils.pas b/components/virtualtreeview/Source/VirtualTrees.Utils.pas index a03902bfc..f93f2fe03 100644 --- a/components/virtualtreeview/Source/VirtualTrees.Utils.pas +++ b/components/virtualtreeview/Source/VirtualTrees.Utils.pas @@ -1,4 +1,4 @@ -unit VirtualTrees.Utils; +unit VirtualTrees.Utils; // 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 @@ -34,11 +34,14 @@ interface System.Types, Vcl.Graphics, Vcl.ImgList, - Vcl.Controls; + Vcl.Controls, + VirtualTrees.Types; type - // Describes the mode how to blend pixels. + /// + /// Describes the mode how to blend pixels. + /// TBlendMode = ( bmConstantAlpha, // apply given constant alpha bmPerPixelAlpha, // use alpha value of the source pixel @@ -55,45 +58,89 @@ procedure SetBrushOrigin(Canvas: TCanvas; X, Y: Integer); inline; procedure SetCanvasOrigin(Canvas: TCanvas; X, Y: Integer); inline; -// Clip a given canvas to ClipRect while transforming the given rect to device coordinates. +/// +/// Clip a given canvas to ClipRect while transforming the given rect to device coordinates. +/// procedure ClipCanvas(Canvas: TCanvas; ClipRect: TRect; VisibleRegion: HRGN = 0); procedure DrawImage(ImageList: TCustomImageList; Index: Integer; Canvas: TCanvas; X, Y: Integer; Style: Cardinal; Enabled: Boolean); - -// Adjusts the given string S so that it fits into the given width. EllipsisWidth gives the width of -// the three points to be added to the shorted string. If this value is 0 then it will be determined implicitely. -// For higher speed (and multiple entries to be shorted) specify this value explicitely. -function ShortenString(DC: HDC; const S: string; Width: Integer; EllipsisWidth: Integer = 0): string; - -// Wrap the given string S so that it fits into a space of given width. -// RTL determines if right-to-left reading is active. +/// +/// Adjusts the given string S so that it fits into the given width. EllipsisWidth gives the width of +/// the three points to be added to the shorted string. If this value is 0 then it will be determined implicitely. +/// For higher speed (and multiple entries to be shorted) specify this value explicitely. +/// +function ShortenString(DC: HDC; const S: string; Width: TDimension; EllipsisWidth: TDimension = 0): string; overload; + +//-------------------------- +// ShortenString similar to VTV's version, except: +// -- Does not assume using three dots or any particular character for ellipsis +// -- Does not add ellipsis to string, so could be added anywhere +// -- Requires EllipsisWidth, and zero does nothing special +// Returns: +// ShortenedString as var param +// True if shortened (ie: add ellipsis somewhere), otherwise false +function ShortenString(TargetCanvasDC: HDC; const StrIn: string; const AllowedWidth_px: Integer; const EllipsisWidth_px: Integer; var ShortenedString: string): boolean; overload; + +/// +/// Wrap the given string S so that it fits into a space of given width. +/// RTL determines if right-to-left reading is active. +/// function WrapString(DC: HDC; const S: string; const Bounds: TRect; RTL: Boolean; DrawFormat: Cardinal): string; -// Calculates bounds of a drawing rectangle for the given string +/// +/// Calculates bounds of a drawing rectangle for the given string +/// procedure GetStringDrawRect(DC: HDC; const S: string; var Bounds: TRect; DrawFormat: Cardinal); -// Converts the incoming rectangle so that left and top are always less than or equal to right and bottom. +/// +/// Converts the incoming rectangle so that left and top are always less than or equal to right and bottom. +/// function OrderRect(const R: TRect): TRect; -// Fills the given rectangles with values which can be used while dragging around an image -// (used in DragMove of the drag manager and DragTo of the header columns). +/// +/// Fills the given rectangles with values which can be used while dragging around an image +/// +/// +/// (used in DragMove of the drag manager and DragTo of the header columns). +/// procedure FillDragRectangles(DragWidth, DragHeight, DeltaX, DeltaY: Integer; var RClip, RScroll, RSamp1, RSamp2, RDraw1, RDraw2: TRect); -// Attaches a bitmap as drag image to an IDataObject, see issue #405 -// Usage: Set property DragImageKind to diNoImage, in your event handler OnCreateDataObject -// call VirtualTrees.Utils.ApplyDragImage() with your `IDataObject` and your bitmap. +/// +/// Attaches a bitmap as drag image to an IDataObject, see issue #405 +/// +/// Usage: Set property DragImageKind to diNoImage, in your event handler OnCreateDataObject +/// call VirtualTrees.Utils.ApplyDragImage() with your `IDataObject` and your bitmap. +/// +/// procedure ApplyDragImage(const pDataObject: IDataObject; pBitmap: TBitmap); +/// /// Returns True if the mouse cursor is currently visible and False in case it is suppressed. /// Useful when doing hot-tracking on touchscreens, see issue #766 +/// function IsMouseCursorVisible(): Boolean; procedure ScaleImageList(const ImgList: TImageList; M, D: Integer); +/// /// Returns True if the high contrast theme is anabled in the system settings, False otherwise. +/// function IsHighContrastEnabled(): Boolean; +/// +/// Divide depend of parameter type uses different division operator: +/// Integer uses div +/// Single uses / +/// +function Divide(const Dimension: Integer; const DivideBy: Integer): Integer; overload; inline; + +/// +/// Divide depend of parameter type uses different division operator: +/// Integer uses div +/// Single uses / +/// +function Divide(const Dimension: Single; const DivideBy: Integer): Single; overload; inline; implementation @@ -233,13 +280,14 @@ procedure GetStringDrawRect(DC: HDC; const S: string; var Bounds: TRect; DrawFor //---------------------------------------------------------------------------------------------------------------------- -function ShortenString(DC: HDC; const S: string; Width: Integer; EllipsisWidth: Integer = 0): string; +function ShortenString(DC: HDC; const S: string; Width: TDimension; EllipsisWidth: TDimension = 0): string; var Size: TSize; Len: Integer; - L, H, N, W: Integer; - + L, H, N: Integer; + W: TDimension; + begin Len := Length(S); if (Len = 0) or (Width <= 0) then @@ -281,8 +329,75 @@ function ShortenString(DC: HDC; const S: string; Width: Integer; EllipsisWidth: end; end; + +//-------------------------- +function ShortenString(TargetCanvasDC: HDC; const StrIn: string; const AllowedWidth_px: Integer; const EllipsisWidth_px: Integer; var ShortenedString: string): boolean; +//-------------------------- +var + Size_px_x_px: TSize; // cx, cy + StrInLen: Integer; + LoLen, HiLen, TestLen, TestWidth_px: Integer; + +begin + StrInLen := Length(StrIn); + if (StrInLen = 0) then + Begin + ShortenedString := ''; + Result := False; // No ellipsis needed since original was empty + End else + if (AllowedWidth_px <= 0) then + Begin + ShortenedString := ''; + Result := True; // Ellipsis needed, since non-empty string replaced. + // But likely will get clipped if AllowedWidth is really zero + End else + begin + // Do a binary search for the optimal string length which fits into the given width. + LoLen := 0; + TestLen := 0; + TestWidth_px := AllowedWidth_px; + HiLen := StrInLen; + + while LoLen < HiLen do + begin + TestLen := (LoLen + HiLen + 1) shr 1; // Test average of Lo and Hi + + GetTextExtentPoint32W(TargetCanvasDC, PWideChar(StrIn), TestLen, Size_px_x_px); + TestWidth_px := Size_px_x_px.cx + EllipsisWidth_px; + + if TestWidth_px <= AllowedWidth_px then + Begin + LoLen := TestLen // Low bound must be at least as much as TestLen + End else + Begin + HiLen := TestLen - 1; // Continue until Hi bound string produces width below AllowedWidth_px + End; + end; + + if TestWidth_px <= AllowedWidth_px then + Begin + LoLen := TestLen; + End; + if LoLen >= StrInLen then + Begin + ShortenedString := StrIn; + Result := False; + End else if AllowedWidth_px <= EllipsisWidth_px then + Begin + ShortenedString := ''; + Result := True; // Even though Ellipsis won't fit in AllowedWidth, + // let clipping decide how much of ellipsis to show + End else + Begin + ShortenedString := Copy(StrIn, 1, LoLen); + Result := True; + End; + end; +end; + //---------------------------------------------------------------------------------------------------------------------- + function WrapString(DC: HDC; const S: string; const Bounds: TRect; RTL: Boolean; DrawFormat: Cardinal): string; var @@ -1264,30 +1379,8 @@ procedure FillDragRectangles(DragWidth, DragHeight, DeltaX, DeltaY: Integer; var TCustomImageListCast = class(TCustomImageList); procedure DrawImage(ImageList: TCustomImageList; Index: Integer; Canvas: TCanvas; X, Y: Integer; Style: Cardinal; Enabled: Boolean); - - procedure DrawDisabledImage(ImageList: TCustomImageList; Canvas: TCanvas; X, Y, Index: Integer); - var - Params: TImageListDrawParams; - begin - FillChar(Params, SizeOf(Params), 0); - Params.cbSize := SizeOf(Params); - Params.himl := ImageList.Handle; - Params.i := Index; - Params.hdcDst := Canvas.Handle; - Params.x := X; - Params.y := Y; - Params.fState := ILS_SATURATE; - ImageList_DrawIndirect(@Params); - end; - begin - if Enabled then - // HeidiSQL fix for #1045, required until Embarcadero fixes TVirtualImageList.DoDraw: - //TCustomImageListCast(ImageList).DoDraw(Index, Canvas, X, Y, Style, Enabled) - ImageList_DrawEx(ImageList.Handle, Index, Canvas.Handle, X, Y, 0, 0, - GetRGBColor(ImageList.BkColor), GetRGBColor(ImageList.BlendColor), Style) - else - DrawDisabledImage(ImageList, Canvas, X, Y, Index); + TCustomImageListCast(ImageList).DoDraw(Index, Canvas, X, Y, Style, Enabled) end; //---------------------------------------------------------------------------------------------------------------------- @@ -1370,6 +1463,8 @@ procedure ScaleImageList(const ImgList: TImageList; M, D: Integer); end; end; +//---------------------------------------------------------------------------------------------------------------------- + function IsHighContrastEnabled(): Boolean; var l: HIGHCONTRAST; @@ -1378,5 +1473,17 @@ function IsHighContrastEnabled(): Boolean; Result := SystemParametersInfo(SPI_GETHIGHCONTRAST, 0, @l, 0) and ((l.dwFlags and HCF_HIGHCONTRASTON) <> 0); end; +//---------------------------------------------------------------------------------------------------------------------- +function Divide(const Dimension: Single; const DivideBy: Integer): Single; +begin + Result:= Dimension / DivideBy; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function Divide(const Dimension: Integer; const DivideBy: Integer): Integer; +begin + Result:= Dimension div DivideBy; +end; end. diff --git a/components/virtualtreeview/Source/VirtualTrees.WorkerThread.pas b/components/virtualtreeview/Source/VirtualTrees.WorkerThread.pas index 0359da533..4e74d70ce 100644 --- a/components/virtualtreeview/Source/VirtualTrees.WorkerThread.pas +++ b/components/virtualtreeview/Source/VirtualTrees.WorkerThread.pas @@ -1,10 +1,11 @@ -unit VirtualTrees.WorkerThread; +unit VirtualTrees.WorkerThread; interface uses System.Classes, - VirtualTrees; + VirtualTrees.Types, + VirtualTrees.BaseTree; type // internal worker thread @@ -13,6 +14,7 @@ TWorkerThread = class(TThread) FCurrentTree: TBaseVirtualTree; FWaiterList: TThreadList; FRefCount: Integer; + FWorkEvent: THandle; class procedure EnsureCreated(); class procedure Dispose(CanBlock: Boolean); procedure WaitForValidationTermination(Tree: TBaseVirtualTree); @@ -27,9 +29,7 @@ TWorkerThread = class(TThread) class procedure ReleaseThreadReference(ACanBlock: Boolean = False); class procedure AddTree(Tree: TBaseVirtualTree); - class procedure RemoveTree(Tree: TBaseVirtualTree); - - property CurrentTree: TBaseVirtualTree read FCurrentTree; + class procedure RemoveTree(pTree: TBaseVirtualTree; pWaitForValidationTermination: Boolean); end; @@ -49,37 +49,32 @@ TBaseVirtualTreeCracker = class(TBaseVirtualTree) var WorkerThread: TWorkerThread = nil; - WorkEvent: THandle; + //----------------- TWorkerThread -------------------------------------------------------------------------------------- class procedure TWorkerThread.EnsureCreated(); begin if not Assigned(WorkerThread) then - begin - // Create an event used to trigger our worker thread when something is to do. - WorkEvent := CreateEvent(nil, False, False, nil); - if WorkEvent = 0 then - RaiseLastOSError; - // Create worker thread, initialize it and send it to its wait loop. WorkerThread := TWorkerThread.Create(); - end; end; -class procedure TWorkerThread.Dispose; +//---------------------------------------------------------------------------------------------------------------------- + +class procedure TWorkerThread.Dispose(CanBlock: Boolean); var LRef: TThread; begin WorkerThread.FreeOnTerminate := not CanBlock; WorkerThread.Terminate(); - SetEvent(WorkEvent); + SetEvent(WorkerThread.FWorkEvent); LRef := WorkerThread; - WorkerThread := nil; //Will be freed usinf TThreaf.FreeOnTerminate - CloseHandle(WorkEvent); + WorkerThread := nil; //Will be freed usinf TThread.FreeOnTerminate if CanBlock then LRef.Free; end; +//---------------------------------------------------------------------------------------------------------------------- class procedure TWorkerThread.AddThreadReference; begin @@ -105,9 +100,13 @@ class procedure TWorkerThread.ReleaseThreadReference(ACanBlock: Boolean); constructor TWorkerThread.Create(); begin + FWaiterList := TThreadList.Create; + // Create an event used to trigger our worker thread when something is to do. + FWorkEvent := CreateEvent(nil, False, False, nil); + if FWorkEvent = 0 then + RaiseLastOSError; inherited Create(False); FreeOnTerminate := True; - FWaiterList := TThreadList.Create; end; //---------------------------------------------------------------------------------------------------------------------- @@ -117,6 +116,7 @@ destructor TWorkerThread.Destroy; begin // First let the ancestor stop the thread before freeing our resources. inherited; + CloseHandle(FWorkEvent); FWaiterList.Free; end; @@ -127,9 +127,8 @@ procedure TWorkerThread.WaitForValidationTermination(Tree: TBaseVirtualTree); // Wait for any references to this tree to be released. while FCurrentTree = Tree do begin - Sleep(1); - if (toVariableNodeHeight in TBaseVirtualTreeCracker(Tree).TreeOptions.MiscOptions) then - CheckSynchronize(); // We need to call CheckSynchronize here because we are using TThread.Synchronize in TBaseVirtualTree.MeasureItemHeight() + Sleep(1); // Don't do busy waiting, let the OS scheduler give other threads a time slice + CheckSynchronize(); // We need to call CheckSynchronize here because we are using TThread.Synchronize in TBaseVirtualTree.MeasureItemHeight() and ChangeTreeStatesAsync() end; end; @@ -141,13 +140,14 @@ procedure TWorkerThread.Execute(); var EnterStates: TVirtualTreeStates; + lExceptAddr: Pointer; + lException: TObject; lCurrentTree: TBaseVirtualTree; - begin TThread.NameThreadForDebugging('VirtualTrees.TWorkerThread'); while not Terminated do - begin - WaitForSingleObject(WorkEvent, INFINITE); + try + WaitForSingleObject(FWorkEvent, INFINITE); if Terminated then exit; @@ -161,7 +161,7 @@ procedure TWorkerThread.Execute(); Delete(0); // If there is yet another tree to work on then set the work event to keep looping. if Count > 0 then - SetEvent(WorkEvent); + SetEvent(FWorkEvent); end else lCurrentTree := nil; @@ -178,13 +178,22 @@ procedure TWorkerThread.Execute(); EnterStates := []; if not (tsStopValidation in FCurrentTree.TreeStates) and TBaseVirtualTreeCracker(FCurrentTree).DoValidateCache then EnterStates := [tsUseCache]; - finally - FCurrentTree := nil; //Clear variable to prevent deadlock in CancelValidation. See #434 + FCurrentTree := nil; // Important: Clear variable before calling ChangeTreeStatesAsync() to prevent deadlock in WaitForValidationTermination(). See issue #1001 TBaseVirtualTreeCracker(lCurrentTree).ChangeTreeStatesAsync(EnterStates, [tsValidating, tsStopValidation]); - Queue(TBaseVirtualTreeCracker(lCurrentTree).UpdateEditBounds); end; end; + except + on Exception do + begin + lExceptAddr := ExceptAddr; + lException := AcquireExceptionObject; + TThread.Synchronize(nil, procedure + begin + raise lException at lExceptAddr; + end); + Continue; //the thread should continue to run + end; end;//while end; @@ -206,25 +215,25 @@ class procedure TWorkerThread.AddTree(Tree: TBaseVirtualTree); WorkerThread.FWaiterList.UnlockList; end; - SetEvent(WorkEvent); + SetEvent(WorkerThread.FWorkEvent); end; //---------------------------------------------------------------------------------------------------------------------- -class procedure TWorkerThread.RemoveTree(Tree: TBaseVirtualTree); - +class procedure TWorkerThread.RemoveTree(pTree: TBaseVirtualTree; pWaitForValidationTermination: Boolean); begin if not Assigned(WorkerThread) then exit; - Assert(Assigned(Tree), 'Tree must not be nil.'); + Assert(Assigned(pTree), 'pTree must not be nil.'); with WorkerThread.FWaiterList.LockList do try - Remove(Tree); + Remove(pTree); finally WorkerThread.FWaiterList.UnlockList; // Seen several AVs in this line, was called from TWorkerThrea.Destroy. Joachim Marder. end; - WorkerThread.WaitForValidationTermination(Tree); + if pWaitForValidationTermination then + WorkerThread.WaitForValidationTermination(pTree); end; diff --git a/components/virtualtreeview/Source/VirtualTrees.dtx b/components/virtualtreeview/Source/VirtualTrees.dtx index acc249d9c..d014da365 100644 --- a/components/virtualtreeview/Source/VirtualTrees.dtx +++ b/components/virtualtreeview/Source/VirtualTrees.dtx @@ -105,13 +105,13 @@ If Reverse is True then a right-to-left column is being drawn, hence horizontal X and Y describe the left upper corner of the line image rectangle, while H denotes its height (and width). @@TBaseVirtualTree.FAlignment - + @@TBaseVirtualTree.FAnimationDuration - + @@TBaseVirtualTree.FAnimationType - + @@TBaseVirtualTree.FAutoExpandDelay amount of milliseconds to wait until a node is expanded if it is the @@ -821,7 +821,7 @@ true size of the font @@TEnumFormatEtc - + @@ -908,7 +908,7 @@ Do nothing. Let the application paint the background. @@TScrollBarOptions - + @@TScrollBarOptions.FScrollBars used to hide or show vertical and/or horizontal scrollbar @@ -1129,7 +1129,7 @@ Description If this column is allowed to be clicked then it is also kept for later use. Summary -Determines the column from the given position and returns it. +Determines the column from the given position and returns it. @@TVirtualTreeColumns.AdjustHoverColumn@TPoint Summary @@ -2055,13 +2055,13 @@ Version 4.0.0 For full document history see help file. Credits for their valuable assistance and code donations go to: - Freddy Ertl, Marian Aldenhvel, Thomas Bogenrieder, Jim Kuenemann, Werner Lehmann, Jens Treichler, - Paul Gallagher (IBO tree), Ondrej Kelle, Ronaldo Melo Ferraz, Heri Bender, Roland Bedrftig (BCB) + Freddy Ertl, Marian Aldenh�vel, Thomas Bogenrieder, Jim Kuenemann, Werner Lehmann, Jens Treichler, + Paul Gallagher (IBO tree), Ondrej Kelle, Ronaldo Melo Ferraz, Heri Bender, Roland Bed�rftig (BCB) Anthony Mills, Alexander Egorushkin (BCB), Mathias Torell (BCB), Frank van den Bergh, Vadim Sedulin, Peter Evans, Milan Vandrovec (BCB), Steve Moss (system check images), Joe White, David Clark (local node memory manager), Anders Thomsen, Igor Afanasyev, Eugene Programmer Beta testers: - Freddy Ertl, Hans-Jrgen Schnorrenberg, Werner Lehmann, Jim Kueneman, Vadim Sedulin, Moritz Franckenstein, + Freddy Ertl, Hans-J�rgen Schnorrenberg, Werner Lehmann, Jim Kueneman, Vadim Sedulin, Moritz Franckenstein, Wim van der Vegt, Franc v/d Westelaken Indirect contribution (via publicly accessible work of those persons): Alex Denissov, Hiroyuki Hori (MMXAsm expert) @@ -2084,7 +2084,7 @@ Version 4.0.0 @@Check button image indices - + @@ckButtonHot @@ -4712,7 +4712,7 @@ written again and silently disappear. Another task of this method is to work around the problem that TCollection is not streamed correctly when using Visual -Form Inheritance (VFI). +Form Inheritance (VFI). @@TBaseVirtualTree.Destroy Summary @@ -5687,7 +5687,7 @@ Occasionally you may want to shorten the node text at a different position, for and not the last folder or filename should be cut off but rather some mid level folders if possible. In the handler S must be processed (shortened) and returned in Result. If Done is set to true (default value is false) -the tree view takes over the shortening. This is useful if not all nodes or columns need +the tree view takes over the shortening. This is useful if not all nodes or columns need @@TCustomVirtualStringTree.AdjustPaintCellRect@TVTPaintInfo@TColumnIndex Summary @@ -5732,7 +5732,7 @@ Summary Options related to automatic actions. Description -These options can be used to switch certain actions in a tree which happen automatically under certain circumstances. +These options can be used to switch certain actions in a tree which happen automatically under certain circumstances. @@TCustomVirtualTreeOptions.MiscOptions Summary @@ -5753,7 +5753,7 @@ Summary Options related to painting. Description -These options can be used to switch visual aspects of a tree. +These options can be used to switch visual aspects of a tree. @@TCustomVirtualTreeOptions.SelectionOptions Summary @@ -6456,14 +6456,15 @@ a method resolution clause to avoid a name clash. The clause can look similar to procedure EditLinkSetBounds(R: TRect); stdcall; procedure IVTEditLink.SetBounds = EditLinkSetBounds; - + @@TCheckImageKind.ckSystemDefault System defined check images. - @@THeaderState.hsResizing + +@@THeaderState.hsResizing multi column resizing in progress - + @@THeaderState.hsColumnWidthTrackPending left button is down, user might want to start resize a column - + @@THeaderState.hsColumnWidthTracking column resizing is in progress diff --git a/components/virtualtreeview/Source/VirtualTrees.pas b/components/virtualtreeview/Source/VirtualTrees.pas index 3acdb5e77..7a658f64e 100644 --- a/components/virtualtreeview/Source/VirtualTrees.pas +++ b/components/virtualtreeview/Source/VirtualTrees.pas @@ -1,4 +1,4 @@ -unit VirtualTrees; +unit VirtualTrees; // 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 @@ -22,15 +22,13 @@ // (C) 1999-2001 digital publishing AG. All Rights Reserved. //---------------------------------------------------------------------------------------------------------------------- // -// For a list of recent changes please see file CHANGES.TXT -// // Credits for their valuable assistance and code donations go to: // Freddy Ertl, Marian Aldenhoevel, Thomas Bogenrieder, Jim Kuenemann, Werner Lehmann, Jens Treichler, // Paul Gallagher (IBO tree), Ondrej Kelle, Ronaldo Melo Ferraz, Heri Bender, Roland Beduerftig (BCB) // Anthony Mills, Alexander Egorushkin (BCB), Mathias Torell (BCB), Frank van den Bergh, Vadim Sedulin, Peter Evans, // Milan Vandrovec (BCB), Steve Moss, Joe White, David Clark, Anders Thomsen, Igor Afanasyev, Eugene Programmer, // Corbin Dunn, Richard Pringle, Uli Gerhardt, Azza, Igor Savkic, Daniel Bauten, Timo Tegtmeier, Dmitry Zegebart, -// Andreas Hausladen, Joachim Marder, Roman Kassebaum, Vincent Parret, Dietmar Roesler, Sanjay Kanade, +// Andreas Hausladen, Joachim Marder, Roman Kassebaum, Vincent Parrett, Dietmar Roesler, Sanjay Kanade, // and everyone that sent pull requests: https://github.com/Virtual-TreeView/Virtual-TreeView/pulls?q= // Beta testers: // Freddy Ertl, Hans-Juergen Schnorrenberg, Werner Lehmann, Jim Kueneman, Vadim Sedulin, Moritz Franckenstein, @@ -62,3529 +60,377 @@ interface {$LEGACYIFEND ON} {$WARN UNSUPPORTED_CONSTRUCT OFF} -{$HPPEMIT '#include '} -{$HPPEMIT '#include '} -{$HPPEMIT '#include '} -{$ifdef BCB} - {$HPPEMIT '#pragma comment(lib, "VirtualTreesCR")'} -{$else} - {$HPPEMIT '#pragma comment(lib, "VirtualTreesR")'} -{$endif} -{$HPPEMIT '#pragma comment(lib, "Shell32")'} -{$HPPEMIT '#pragma link "VirtualTrees.Accessibility"'} - uses - Winapi.Windows, Winapi.oleacc, Winapi.Messages, System.SysUtils, Vcl.Graphics, - Vcl.Controls, Vcl.Forms, Vcl.ImgList, Winapi.ActiveX, Vcl.StdCtrls, System.Classes, - Vcl.Menus, Vcl.Printers, System.Types, Winapi.CommCtrl, Vcl.Themes, Winapi.UxTheme, - Winapi.ShlObj, System.UITypes, System.Generics.Collections; -type + Winapi.Windows, Winapi.Messages, Winapi.ActiveX, + System.Classes, System.SysUtils, + Vcl.Graphics, Vcl.Controls, Vcl.ImgList, Vcl.Menus, Vcl.Themes, + VirtualTrees.Types, + VirtualTrees.Header, + VirtualTrees.BaseTree, {$IFDEF VT_FMX} - TDimension = Single; + VirtualTrees.AncestorFMX, {$ELSE} - TDimension = Integer; // For Firemonkey support, see #841 + VirtualTrees.AncestorVCL {$ENDIF} - -const - VTVersion = '7.4.0' deprecated 'This const is going to be removed in a future version'; - -const - VTTreeStreamVersion = 3; - VTHeaderStreamVersion = 6; // The header needs an own stream version to indicate changes only relevant to the header. - - CacheThreshold = 2000; // Number of nodes a tree must at least have to start caching and at the same - // time the maximum number of nodes between two cache entries. - FadeAnimationStepCount = 255; // Number of animation steps for hint fading (0..255). - ShadowSize = 5; // Size in pixels of the hint shadow. This value has no influence on Win2K and XP systems - // as those OSes have native shadow support. - - // Special identifiers for columns. - NoColumn = -1; - InvalidColumn = -2; - - // Indices for check state images used for checking. - ckEmpty = 0; // an empty image used as place holder - // radio buttons - ckRadioUncheckedNormal = 1; - ckRadioUncheckedHot = 2; - ckRadioUncheckedPressed = 3; - ckRadioUncheckedDisabled = 4; - ckRadioCheckedNormal = 5; - ckRadioCheckedHot = 6; - ckRadioCheckedPressed = 7; - ckRadioCheckedDisabled = 8; - // check boxes - ckCheckUncheckedNormal = 9; - ckCheckUncheckedHot = 10; - ckCheckUncheckedPressed = 11; - ckCheckUncheckedDisabled = 12; - ckCheckCheckedNormal = 13; - ckCheckCheckedHot = 14; - ckCheckCheckedPressed = 15; - ckCheckCheckedDisabled = 16; - ckCheckMixedNormal = 17; - ckCheckMixedHot = 18; - ckCheckMixedPressed = 19; - ckCheckMixedDisabled = 20; - // simple button - ckButtonNormal = 21; - ckButtonHot = 22; - ckButtonPressed = 23; - ckButtonDisabled = 24; - - // Instead using a TTimer class for each of the various events I use Windows timers with messages - // as this is more economical. - ExpandTimer = 1; - EditTimer = 2; - HeaderTimer = 3; - ScrollTimer = 4; - ChangeTimer = 5; - StructureChangeTimer = 6; - SearchTimer = 7; - ThemeChangedTimer = 8; - - ThemeChangedTimerDelay = 500; - - // Virtual Treeview does not need to be subclassed by an eventual Theme Manager instance as it handles - // Windows XP theme painting itself. Hence the special message is used to prevent subclassing. - CM_DENYSUBCLASSING = CM_BASE + 2000; - - // Decoupling message for auto-adjusting the internal edit window. - CM_AUTOADJUST = CM_BASE + 2005; - - // VT's own clipboard formats, - // Note: The reference format is used internally to allow to link to a tree reference - // to implement optimized moves and other back references. - CFSTR_VIRTUALTREE = 'Virtual Tree Data'; - CFSTR_VTREFERENCE = 'Virtual Tree Reference'; - CFSTR_HTML = 'HTML Format'; - CFSTR_RTF = 'Rich Text Format'; - CFSTR_RTFNOOBJS = 'Rich Text Format Without Objects'; - CFSTR_CSV = 'CSV'; - - // Drag image helpers for Windows 2000 and up. - IID_IDropTargetHelper: TGUID = (D1: $4657278B; D2: $411B; D3: $11D2; D4: ($83, $9A, $00, $C0, $4F, $D9, $18, $D0)); - IID_IDragSourceHelper: TGUID = (D1: $DE5BF786; D2: $477A; D3: $11D2; D4: ($83, $9D, $00, $C0, $4F, $D9, $18, $D0)); - IID_IDropTarget: TGUID = (D1: $00000122; D2: $0000; D3: $0000; D4: ($C0, $00, $00, $00, $00, $00, $00, $46)); - - // Help identifiers for exceptions. Application developers are responsible to link them with actual help topics. - hcTFEditLinkIsNil = 2000; - hcTFWrongMoveError = 2001; - hcTFWrongStreamFormat = 2002; - hcTFWrongStreamVersion = 2003; - hcTFStreamTooSmall = 2004; - hcTFCorruptStream1 = 2005; - hcTFCorruptStream2 = 2006; - hcTFClipboardFailed = 2007; - hcTFCannotSetUserData = 2008; - - // Header standard split cursor. - crHeaderSplit = TCursor(63); - - // Height changing cursor. - crVertSplit = TCursor(62); - -var // Clipboard format IDs used in OLE drag'n drop and clipboard transfers. - CF_VIRTUALTREE, - CF_VTREFERENCE, - CF_VRTF, - CF_VRTFNOOBJS, // Unfortunately CF_RTF* is already defined as being - // registration strings so I have to use different identifiers. - CF_HTML, - CF_CSV: Word; - - IsWinVistaOrAbove: Boolean; + ; + {$MinEnumSize 1, make enumerations as small as possible} - - type - // Alias defintions for convenience - TImageIndex = System.UITypes.TImageIndex; - TCanvas = Vcl.Graphics.TCanvas; - - - // The exception used by the trees. - EVirtualTreeError = class(Exception); - - PCardinal = ^Cardinal; - - // Limits the speed interval which can be used for auto scrolling (milliseconds). - TAutoScrollInterval = 1..1000; - - // Be careful when adding new states as this might change the size of the type which in turn - // changes the alignment in the node record as well as the stream chunks. - // Do not reorder the states and always add new states at the end of this enumeration in order to avoid - // breaking existing code. - TVirtualNodeState = ( - vsInitialized, // Set after the node has been initialized. - vsChecking, // Node's check state is changing, avoid propagation. - vsCutOrCopy, // Node is selected as cut or copy and paste source. - vsDisabled, // Set if node is disabled. - vsDeleting, // Set when the node is about to be freed. - vsExpanded, // Set if the node is expanded. - vsHasChildren, // Indicates the presence of child nodes without actually setting them. - vsVisible, // Indicate whether the node is visible or not (independant of the expand states of its parents). - vsSelected, // Set if the node is in the current selection. - vsOnFreeNodeCallRequired, // Set if user data has been set which requires OnFreeNode. - vsAllChildrenHidden, // Set if vsHasChildren is set and no child node has the vsVisible flag set. - vsReleaseCallOnUserDataRequired, // Indicates that the user data is a reference to an interface which should be released. - vsMultiline, // Node text is wrapped at the cell boundaries instead of being shorted. - vsHeightMeasured, // Node height has been determined and does not need a recalculation. - vsToggling, // Set when a node is expanded/collapsed to prevent recursive calls. - vsFiltered, // Indicates that the node should not be painted (without effecting its children). - vsInitializing // Set when the node is being initialized - ); - TVirtualNodeStates = set of TVirtualNodeState; - - // States used in InitNode to indicate states a node shall initially have. - TVirtualNodeInitState = ( - ivsDisabled, - ivsExpanded, - ivsHasChildren, - ivsMultiline, - ivsSelected, - ivsFiltered, - ivsReInit - ); - TVirtualNodeInitStates = set of TVirtualNodeInitState; - - TScrollBarStyle = ( - sbmRegular, - sbm3D - ); - - // Options per column. - TVTColumnOption = ( - coAllowClick, // Column can be clicked (must be enabled too). - coDraggable, // Column can be dragged. - coEnabled, // Column is enabled. - coParentBidiMode, // Column uses the parent's bidi mode. - coParentColor, // Column uses the parent's background color. - coResizable, // Column can be resized. - coShowDropMark, // Column shows the drop mark if it is currently the drop target. - coVisible, // Column is shown. - coAutoSpring, // Column takes part in the auto spring feature of the header (must be resizable too). - coFixed, // Column is fixed and can not be selected or scrolled etc. - coSmartResize, // Column is resized to its largest entry which is in view (instead of its largest - // visible entry). - coAllowFocus, // Column can be focused. - coDisableAnimatedResize, // Column resizing is not animated. - coWrapCaption, // Caption could be wrapped across several header lines to fit columns width. - coUseCaptionAlignment, // Column's caption has its own aligment. - coEditable, // Column can be edited - coStyleColor // Prefer background color of VCL style over TVirtualTreeColumn.Color - ); - TVTColumnOptions = set of TVTColumnOption; - - // These flags are used to indicate where a click in the header happened. - TVTHeaderHitPosition = ( - hhiNoWhere, // No column is involved (possible only if the tree is smaller than the client area). - hhiOnColumn, // On a column. - hhiOnIcon, // On the bitmap associated with a column. - hhiOnCheckbox // On the checkbox if enabled. - ); - TVTHeaderHitPositions = set of TVTHeaderHitPosition; - - // These flags are returned by the hit test method. - THitPosition = ( - hiAbove, // above the client area (if relative) or the absolute tree area - hiBelow, // below the client area (if relative) or the absolute tree area - hiNowhere, // no node is involved (possible only if the tree is not as tall as the client area) - hiOnItem, // on the bitmaps/buttons or label associated with an item - hiOnItemButton, // on the button associated with an item - hiOnItemButtonExact, // exactly on the button associated with an item - hiOnItemCheckbox, // on the checkbox if enabled - hiOnItemIndent, // in the indentation area in front of a node - hiOnItemLabel, // on the normal text area associated with an item - hiOnItemLeft, // in the area to the left of a node's text area (e.g. when right aligned or centered) - hiOnItemRight, // in the area to the right of a node's text area (e.g. if left aligned or centered) - hiOnNormalIcon, // on the "normal" image - hiOnStateIcon, // on the state image - hiToLeft, // to the left of the client area (if relative) or the absolute tree area - hiToRight, // to the right of the client area (if relative) or the absolute tree area - hiUpperSplitter, // in the upper splitter area of a node - hiLowerSplitter // in the lower splitter area of a node - ); - THitPositions = set of THitPosition; - - TCheckType = ( - ctNone, - ctTriStateCheckBox, - ctCheckBox, - ctRadioButton, - ctButton - ); - - // The check states include both, transient and fluent (temporary) states. The only temporary state defined so - // far is the pressed state. - TCheckState = ( - csUncheckedNormal, // unchecked and not pressed - csUncheckedPressed, // unchecked and pressed - csCheckedNormal, // checked and not pressed - csCheckedPressed, // checked and pressed - csMixedNormal, // 3-state check box and not pressed - csMixedPressed, // 3-state check box and pressed - csUncheckedDisabled,// disabled checkbox, not checkable - csCheckedDisabled, // disabled checkbox, not uncheckable - csMixedDisabled // disabled 3-state checkbox - ); - - /// Adds some convenience methods to type TCheckState - TCheckStateHelper = record helper for TCheckState - strict private - const - // Lookup to quickly convert a specific check state into its pressed counterpart and vice versa. - cPressedState: array[TCheckState] of TCheckState = ( - csUncheckedPressed, csUncheckedPressed, csCheckedPressed, csCheckedPressed, csMixedPressed, csMixedPressed, csUncheckedDisabled, csCheckedDisabled, csMixedDisabled); - cUnpressedState: array[TCheckState] of TCheckState = ( - csUncheckedNormal, csUncheckedNormal, csCheckedNormal, csCheckedNormal, csMixedNormal, csMixedNormal, csUncheckedDisabled, csCheckedDisabled, csMixedDisabled); - cEnabledState: array[TCheckState] of TCheckState = ( - csUncheckedNormal, csUncheckedPressed, csCheckedNormal, csCheckedPressed, csMixedNormal, csMixedPressed, csUncheckedNormal, csCheckedNormal, csMixedNormal); - cToggledState: array[TCheckState] of TCheckState = ( - csCheckedNormal, csCheckedPressed, csUnCheckedNormal, csUnCheckedPressed, csCheckedNormal, csCheckedPressed, csUncheckedDisabled, csCheckedDisabled, csMixedDisabled); - public - function GetPressed(): TCheckState; inline; - function GetUnpressed(): TCheckState; inline; - function GetEnabled(): TCheckState; inline; - function GetToggled(): TCheckState; inline; - function IsDisabled(): Boolean; inline; - function IsChecked(): Boolean; inline; - function IsUnChecked(): Boolean; inline; - function IsMixed(): Boolean; inline; - end; - - TCheckImageKind = ( - ckCustom, // application defined check images - ckSystemDefault // Uses the system check images, theme aware. - ); - - // mode to describe a move action - TVTNodeAttachMode = ( - amNoWhere, // just for simplified tests, means to ignore the Add/Insert command - amInsertBefore, // insert node just before destination (as sibling of destination) - amInsertAfter, // insert node just after destionation (as sibling of destination) - amAddChildFirst, // add node as first child of destination - amAddChildLast // add node as last child of destination - ); - - // modes to determine drop position further - TDropMode = ( - dmNowhere, - dmAbove, - dmOnNode, - dmBelow - ); - - // operations basically allowed during drag'n drop - TDragOperation = ( - doCopy, - doMove, - doLink - ); - TDragOperations = set of TDragOperation; - - TVTImageKind = ( - ikNormal, - ikSelected, - ikState, - ikOverlay - ); - - { - Fine points: Observed when fixing issue #623 - -- hmHint allows multiline hints automatically if provided through OnGetHint event. - This is irresptive of whether node itself is multi-line or not. - - -- hmToolTip shows a hint only when node text is not fully shown. It's meant to - fully show node text when not visible. It will show multi-line hint only if - the node itself is multi-line. If you provide a custom multi-line hint then - you must force linebreak style to hlbForceMultiLine in the OnGetHint event - in order to show the complete hint. - } - TVTHintMode = ( - hmDefault, // show the hint of the control - hmHint, // show node specific hint string returned by the application - hmHintAndDefault, // same as hmHint but show the control's hint if no node is concerned - hmTooltip // show the text of the node if it isn't already fully shown - ); - - // Indicates how to format a tooltip. - TVTTooltipLineBreakStyle = ( - hlbDefault, // Use multi-line style of the node. - hlbForceSingleLine, // Use single line hint. - hlbForceMultiLine // Use multi line hint. - ); - - TMouseButtons = set of TMouseButton; - - // Used to describe the action to do when using the OnBeforeItemErase event. - TItemEraseAction = ( - eaColor, // Use the provided color to erase the background instead the one of the tree. - eaDefault, // The tree should erase the item's background (bitmap or solid). - eaNone // Do nothing. Let the application paint the background. - ); - - - // There is a heap of switchable behavior in the tree. Since published properties may never exceed 4 bytes, - // which limits sets to at most 32 members, and because for better overview tree options are splitted - // in various sub-options and are held in a commom options class. - // - // Options to customize tree appearance: - TVTPaintOption = ( - toHideFocusRect, // Avoid drawing the dotted rectangle around the currently focused node. - toHideSelection, // Selected nodes are drawn as unselected nodes if the tree is unfocused. - toHotTrack, // Track which node is under the mouse cursor. - toPopupMode, // Paint tree as would it always have the focus (useful for tree combo boxes etc.) - toShowBackground, // Use the background image if there's one. - toShowButtons, // Display collapse/expand buttons left to a node. - toShowDropmark, // Show the dropmark during drag'n drop operations. - toShowHorzGridLines, // Display horizontal lines to simulate a grid. - toShowRoot, // Show lines also at top level (does not show the hidden/internal root node). - toShowTreeLines, // Display tree lines to show hierarchy of nodes. - toShowVertGridLines, // Display vertical lines (depending on columns) to simulate a grid. - toThemeAware, // Draw UI elements (header, tree buttons etc.) according to the current theme if - // enabled (Windows XP+ only, application must be themed). - toUseBlendedImages, // Enable alpha blending for ghosted nodes or those which are being cut/copied. - toGhostedIfUnfocused, // Ghosted images are still shown as ghosted if unfocused (otherwise the become non-ghosted - // images). - toFullVertGridLines, // Display vertical lines over the full client area, not only the space occupied by nodes. - // This option only has an effect if toShowVertGridLines is enabled too. - toAlwaysHideSelection, // Do not draw node selection, regardless of focused state. - toUseBlendedSelection, // Enable alpha blending for node selections. - toStaticBackground, // Show simple static background instead of a tiled one. - toChildrenAbove, // Display child nodes above their parent. - toFixedIndent, // Draw the tree with a fixed indent. - toUseExplorerTheme, // Use the explorer theme if run under Windows Vista (or above). - toHideTreeLinesIfThemed, // Do not show tree lines if theming is used. - toShowFilteredNodes // Draw nodes even if they are filtered out. - ); - TVTPaintOptions = set of TVTPaintOption; - - { Options to toggle animation support: - **Do not use toAnimatedToggle when a background image is used for the tree. - The animation does not look good as the image splits and moves with it. - } - TVTAnimationOption = ( - toAnimatedToggle, // Expanding and collapsing a node is animated (quick window scroll). - // **See note above. - toAdvancedAnimatedToggle // Do some advanced animation effects when toggling a node. - ); - TVTAnimationOptions = set of TVTAnimationOption; - - // Options which toggle automatic handling of certain situations: - TVTAutoOption = ( - toAutoDropExpand, // Expand node if it is the drop target for more than a certain time. - toAutoExpand, // Nodes are expanded (collapsed) when getting (losing) the focus. - toAutoScroll, // Scroll if mouse is near the border while dragging or selecting. - toAutoScrollOnExpand, // Scroll as many child nodes in view as possible after expanding a node. - toAutoSort, // Sort tree when Header.SortColumn or Header.SortDirection change or sort node if - // child nodes are added. Sorting will take place also if SortColum is NoColumn (-1). - toAutoSpanColumns, // Large entries continue into next column(s) if there's no text in them (no clipping). - toAutoTristateTracking, // Checkstates are automatically propagated for tri state check boxes. - toAutoHideButtons, // Node buttons are hidden when there are child nodes, but all are invisible. - toAutoDeleteMovedNodes, // Delete nodes which where moved in a drag operation (if not directed otherwise). - toDisableAutoscrollOnFocus, // Disable scrolling a node or column into view if it gets focused. - toAutoChangeScale, // Change default node height automatically if the system's font scale is set to big fonts. - toAutoFreeOnCollapse, // Frees any child node after a node has been collapsed (HasChildren flag stays there). - toDisableAutoscrollOnEdit, // Do not center a node horizontally when it is edited. - toAutoBidiColumnOrdering // When set then columns (if any exist) will be reordered from lowest index to highest index - // and vice versa when the tree's bidi mode is changed. - ); - TVTAutoOptions = set of TVTAutoOption; - - // Options which determine the tree's behavior when selecting nodes: - TVTSelectionOption = ( - toDisableDrawSelection, // Prevent user from selecting with the selection rectangle in multiselect mode. - toExtendedFocus, // Entries other than in the main column can be selected, edited etc. - toFullRowSelect, // Hit test as well as selection highlight are not constrained to the text of a node. - toLevelSelectConstraint, // Constrain selection to the same level as the selection anchor. - toMiddleClickSelect, // Allow selection, dragging etc. with the middle mouse button. This and toWheelPanning - // are mutual exclusive. - toMultiSelect, // Allow more than one node to be selected. - toRightClickSelect, // Allow selection, dragging etc. with the right mouse button. - toSiblingSelectConstraint, // Constrain selection to nodes with same parent. - toCenterScrollIntoView, // Center nodes vertically in the client area when scrolling into view. - toSimpleDrawSelection, // Simplifies draw selection, so a node's caption does not need to intersect with the - // selection rectangle. - toAlwaysSelectNode, // If this flag is set to true, the tree view tries to always have a node selected. - // This behavior is closer to the Windows TreeView and useful in Windows Explorer style applications. - toRestoreSelection, // Set to true if upon refill the previously selected nodes should be selected again. - // The nodes will be identified by its caption only. - toSyncCheckboxesWithSelection // If checkboxes are shown, they follow the change in selections. When checkboxes are - // changed, the selections follow them and vice-versa. - // **Only supported for ctCheckBox type checkboxes. - ); - TVTSelectionOptions = set of TVTSelectionOption; - - TVTEditOptions = ( - toDefaultEdit, // Standard behaviour for end of editing (after VK_RETURN stay on edited cell). - toVerticalEdit, // After VK_RETURN switch to next column. - toHorizontalEdit // After VK_RETURN switch to next row. - ); - - // Options which do not fit into any of the other groups: - TVTMiscOption = ( - toAcceptOLEDrop, // Register tree as OLE accepting drop target - toCheckSupport, // Show checkboxes/radio buttons. - toEditable, // Node captions can be edited. - toFullRepaintOnResize, // Fully invalidate the tree when its window is resized (CS_HREDRAW/CS_VREDRAW). - toGridExtensions, // Use some special enhancements to simulate and support grid behavior. - toInitOnSave, // Initialize nodes when saving a tree to a stream. - toReportMode, // Tree behaves like TListView in report mode. - toToggleOnDblClick, // Toggle node expansion state when it is double clicked. - toWheelPanning, // Support for mouse panning (wheel mice only). This option and toMiddleClickSelect are - // mutal exclusive, where panning has precedence. - toReadOnly, // The tree does not allow to be modified in any way. No action is executed and - // node editing is not possible. - toVariableNodeHeight, // When set then GetNodeHeight will trigger OnMeasureItem to allow variable node heights. - toFullRowDrag, // Start node dragging by clicking anywhere in it instead only on the caption or image. - // Must be used together with toDisableDrawSelection. - toNodeHeightResize, // Allows changing a node's height via mouse. - toNodeHeightDblClickResize, // Allows to reset a node's height to FDefaultNodeHeight via a double click. - toEditOnClick, // Editing mode can be entered with a single click - toEditOnDblClick, // Editing mode can be entered with a double click - toReverseFullExpandHotKey // Used to define Ctrl+'+' instead of Ctrl+Shift+'+' for full expand (and similar for collapsing) - ); - TVTMiscOptions = set of TVTMiscOption; - - // Options to control data export - TVTExportMode = ( - emAll, // export all records (regardless checked state) - emChecked, // export checked records only - emUnchecked, // export unchecked records only - emVisibleDueToExpansion, //Do not export nodes that are not visible because their parent is not expanded - emSelected // export selected nodes only - ); - - // Kinds of operations - TVTOperationKind = ( - okAutoFitColumns, - okGetMaxColumnWidth, - okSortNode, - okSortTree, - okExport, - okExpand - ); - TVTOperationKinds = set of TVTOperationKind; - - // content elements of the control from left to right, used when calculatin left margins. - TVTElement = ( - ofsMargin, // right of the margin - ofsToggleButton, // the exact x-postition of the toggle button - ofsCheckBox, - ofsStateImage, - ofsImage, - ofsLabel, // where drawing a selection begins - ofsText, // includes TextMargin - ofsRightOfText, // Includes NodeWidth and ExtraNodeWidth - ofsEndOfClientArea // The end of the paint area - ); - - /// An array that can be used to calculate the offsets ofthe elements in the tree. - TVTOffsets = array [TVTElement] of TDimension; - - TAddPopupItemType = ( - apNormal, - apDisabled, - apHidden - ); + // Some aliases for backward compatiblity + PVirtualNode = VirtualTrees.Types.PVirtualNode; + TVirtualNode = VirtualTrees.Types.TVirtualNode; + TVTHeaderColumnLayout = VirtualTrees.Types.TVTHeaderColumnLayout; + TSmartAutoFitType = VirtualTrees.Types.TSmartAutoFitType; + TVirtualTreeStates = VirtualTrees.Types.TVirtualTreeStates; + TCheckState = VirtualTrees.Types.TCheckState; + TCheckType = VirtualTrees.Types.TCheckType; + TSortDirection = VirtualTrees.Types.TSortDirection; + TColumnIndex = VirtualTrees.Types.TColumnIndex; + TVTColumnOption = VirtualTrees.Types.TVTColumnOption; + TVTHeaderHitInfo = VirtualTrees.Types.TVTHeaderHitInfo; + TVTHeaderHitPosition = VirtualTrees.Types.TVTHeaderHitPosition; + TVTHeaderHitPositions = VirtualTrees.Types.TVTHeaderHitPositions; + THeaderState = VirtualTrees.Types.THeaderState; + THeaderStates = VirtualTrees.Types.THeaderStates; + TDropMode = VirtualTrees.Types.TDropMode; + TFormatArray = VirtualTrees.Types.TFormatArray; + TVTHeaderOption = VirtualTrees.Types.TVTHeaderOption; + TVTHeaderOptions = VirtualTrees.Types.TVTHeaderOptions; + TVTHeaderStyle = VirtualTrees.Types.TVTHeaderStyle; + TVTExportType = VirtualTrees.Types.TVTExportType; + TVTImageKind = VirtualTrees.Types.TVTImageKind; + TVTExportMode = VirtualTrees.Types.TVTExportMode; + TVTOperationKind = VirtualTrees.Types.TVTOperationKind; + TVTUpdateState = VirtualTrees.Types.TVTUpdateState; + TVTCellPaintMode = VirtualTrees.Types.TVTCellPaintMode; + TVirtualNodeState = VirtualTrees.Types.TVirtualNodeState; + TVirtualNodeInitState = VirtualTrees.Types.TVirtualNodeInitState; + TVirtualNodeInitStates = VirtualTrees.Types.TVirtualNodeInitStates; + TVTTooltipLineBreakStyle = VirtualTrees.Types.TVTTooltipLineBreakStyle; + TVTNodeAttachMode = VirtualTrees.Types.TVTNodeAttachMode; + TNodeArray = VirtualTrees.Types.TNodeArray; + THitInfo = VirtualTrees.Types.THitInfo; + THitPosition = VirtualTrees.Types.THitPosition; + TVTPaintOption = VirtualTrees.Types.TVTPaintOption; + TVTAutoOption = VirtualTrees.Types.TVTAutoOption; + TVTAutoOptions = VirtualTrees.Types.TVTAutoOptions; + TVTSelectionOption = VirtualTrees.Types.TVTSelectionOption; + TVSTTextType = VirtualTrees.Types.TVSTTextType; + TVTHintMode = VirtualTrees.Types.TVTHintMode; + TBaseVirtualTree = VirtualTrees.BaseTree.TBaseVirtualTree; + IVTEditLink = VirtualTrees.BaseTree.IVTEditLink; + TVTHeaderNotifyEvent = VirtualTrees.BaseTree.TVTHeaderNotifyEvent; + TVTCompareEvent = VirtualTrees.BaseTree.TVTCompareEvent; + TVirtualTreeColumn = VirtualTrees.Header.TVirtualTreeColumn; + TVirtualTreeColumns = VirtualTrees.Header.TVirtualTreeColumns; + TVTHeader = VirtualTrees.Header.TVTHeader; + TVTHeaderClass = VirtualTrees.Header.TVTHeaderClass; + THeaderPaintInfo = VirtualTrees.Header.THeaderPaintInfo; + TVTConstraintPercent = VirtualTrees.Header.TVTConstraintPercent; + TVTFixedAreaConstraints = VirtualTrees.Header.TVTFixedAreaConstraints; + TColumnsArray = VirtualTrees.Header.TColumnsArray; + TCanvas = Vcl.Graphics.TCanvas; const - DefaultPaintOptions = [toShowButtons, toShowDropmark, toShowTreeLines, toShowRoot, toThemeAware, toUseBlendedImages]; - DefaultAnimationOptions = []; - DefaultAutoOptions = [toAutoDropExpand, toAutoTristateTracking, toAutoScrollOnExpand, toAutoDeleteMovedNodes, toAutoChangeScale, toAutoSort]; - DefaultSelectionOptions = []; - DefaultMiscOptions = [toAcceptOLEDrop, toFullRepaintOnResize, toInitOnSave, toToggleOnDblClick, toWheelPanning, - toEditOnClick]; - DefaultColumnOptions = [coAllowClick, coDraggable, coEnabled, coParentColor, coParentBidiMode, coResizable, - coShowDropmark, coVisible, coAllowFocus, coEditable, coStyleColor]; + // Aliases for increased compatibility with V7, feel free to extend by pull requests + NoColumn = VirtualTrees.Types.NoColumn; + InvalidColumn = VirtualTrees.Types.InvalidColumn; + sdAscending = VirtualTrees.Types.TSortDirection.sdAscending; + sdDescending = VirtualTrees.Types.TSortDirection.sdDescending; + toAutoSort = VirtualTrees.Types.TVTAutoOption.toAutoSort; + toCheckSupport = VirtualTrees.Types.TVTMiscOption.toCheckSupport; + toEditable = VirtualTrees.Types.TVTMiscOption.toEditable; + toShowRoot = VirtualTrees.Types.TVTPaintOption.toShowRoot; + ctNone = VirtualTrees.Types.TCheckType.ctNone; + ctTriStateCheckBox = VirtualTrees.Types.TCheckType.ctTriStateCheckBox; + ctCheckBox = VirtualTrees.Types.TCheckType.ctCheckBox; + ctRadioButton = VirtualTrees.Types.TCheckType.ctRadioButton; + ctButton = VirtualTrees.Types.TCheckType.ctButton; + + csUncheckedNormal = VirtualTrees.Types.TCheckState.csUncheckedNormal; + csUncheckedPressed = VirtualTrees.Types.TCheckState.csUncheckedPressed; + csCheckedNormal = VirtualTrees.Types.TCheckState.csCheckedNormal; + csCheckedPressed = VirtualTrees.Types.TCheckState.csCheckedPressed; + csMixedNormal = VirtualTrees.Types.TCheckState.csMixedNormal; + csMixedPressed = VirtualTrees.Types.TCheckState.csMixedPressed; + csUncheckedDisabled = VirtualTrees.Types.TCheckState.csUncheckedDisabled; + csCheckedDisabled = VirtualTrees.Types.TCheckState.csCheckedDisabled; + csMixedDisable = VirtualTrees.Types.TCheckState.csMixedDisabled; + + coVisible = VirtualTrees.Types.TVTColumnOption.coVisible; + vsDisabled = VirtualTrees.Types.TVirtualNodeState.vsDisabled; + etHTML = VirtualTrees.Types.TVTExportType.etHTML; + hiOnItemButton = VirtualTrees.Types.THitPosition.hiOnItemButton; + dmOnNode = VirtualTrees.Types.TDropMode.dmOnNode; + hlbForceMultiLine = VirtualTrees.Types.TVTTooltipLineBreakStyle.hlbForceMultiLine; + hmHintAndDefault = VirtualTrees.Types.TVTHintMode.hmHintAndDefault; + hmTooltip = VirtualTrees.Types.TVTHintMode.hmTooltip; type - TBaseVirtualTree = class; - TVirtualTreeClass = class of TBaseVirtualTree; - - PVirtualNode = ^TVirtualNode; - - TColumnIndex = type Integer; - TColumnPosition = type Cardinal; - - // This record must already be defined here and not later because otherwise BCB users will not be able - // to compile (conversion done by BCB is wrong). - TCacheEntry = record - Node: PVirtualNode; - AbsoluteTop: Cardinal; - end; - - TCache = array of TCacheEntry; - TNodeArray = array of PVirtualNode; - - TCustomVirtualTreeOptions = class(TPersistent) - private - FOwner: TBaseVirtualTree; - FPaintOptions: TVTPaintOptions; - FAnimationOptions: TVTAnimationOptions; - FAutoOptions: TVTAutoOptions; - FSelectionOptions: TVTSelectionOptions; - FMiscOptions: TVTMiscOptions; - FExportMode: TVTExportMode; - FEditOptions: TVTEditOptions; - procedure SetAnimationOptions(const Value: TVTAnimationOptions); - procedure SetAutoOptions(const Value: TVTAutoOptions); - procedure SetMiscOptions(const Value: TVTMiscOptions); - procedure SetPaintOptions(const Value: TVTPaintOptions); - procedure SetSelectionOptions(const Value: TVTSelectionOptions); - protected - public - constructor Create(AOwner: TBaseVirtualTree); virtual; - procedure AssignTo(Dest: TPersistent); override; - property AnimationOptions: TVTAnimationOptions read FAnimationOptions write SetAnimationOptions default DefaultAnimationOptions; - property AutoOptions: TVTAutoOptions read FAutoOptions write SetAutoOptions default DefaultAutoOptions; - property ExportMode: TVTExportMode read FExportMode write FExportMode default emAll; - property MiscOptions: TVTMiscOptions read FMiscOptions write SetMiscOptions default DefaultMiscOptions; - property PaintOptions: TVTPaintOptions read FPaintOptions write SetPaintOptions default DefaultPaintOptions; - property SelectionOptions: TVTSelectionOptions read FSelectionOptions write SetSelectionOptions default DefaultSelectionOptions; - property EditOptions: TVTEditOptions read FEditOptions write FEditOptions default toDefaultEdit; - - property Owner: TBaseVirtualTree read FOwner; - end; - - TTreeOptionsClass = class of TCustomVirtualTreeOptions; - - TVirtualTreeOptions = class(TCustomVirtualTreeOptions) - published - property AnimationOptions; - property AutoOptions; - property ExportMode; - property MiscOptions; - property PaintOptions; - property SelectionOptions; - end; - - // Used in the CF_VTREFERENCE clipboard format. - PVTReference = ^TVTReference; - TVTReference = record - Process: Cardinal; - Tree: TBaseVirtualTree; - end; - - TVirtualNode = packed record - Index, // index of node with regard to its parent - ChildCount: Cardinal; // number of child nodes - NodeHeight: Word; // height in pixels - States: TVirtualNodeStates; // states describing various properties of the node (expanded, initialized etc.) - Align: Byte; // line/button alignment - CheckState: TCheckState; // indicates the current check state (e.g. checked, pressed etc.) - CheckType: TCheckType; // indicates which check type shall be used for this node - Dummy: Byte; // dummy value to fill DWORD boundary TODO: Is this still necessary? - TotalCount, // sum of this node, all of its child nodes and their child nodes etc. - TotalHeight: Cardinal; // height in pixels this node covers on screen including the height of all of its - // children - // Note: Some copy routines require that all pointers (as well as the data area) in a node are - // located at the end of the node! Hence if you want to add new member fields (except pointers to internal - // data) then put them before field Parent. - Parent, // reference to the node's parent (for the root this contains the treeview) - PrevSibling, // link to the node's previous sibling or nil if it is the first node - NextSibling, // link to the node's next sibling or nil if it is the last node - FirstChild, // link to the node's first child... - LastChild: PVirtualNode; // link to the node's last child... - private - Data: record end; // this is a placeholder, each node gets extra data determined by NodeDataSize - public - function IsAssigned(): Boolean; inline; - function GetData(): Pointer; overload; inline; - function GetData(): T; overload; inline; - procedure SetData(pUserData: Pointer); overload; - procedure SetData(pUserData: T); overload; - procedure SetData(const pUserData: IInterface); overload; - end; - - - // Structure used when info about a certain position in the header is needed. - TVTHeaderHitInfo = record - X, - Y: TDimension; - Button: TMouseButton; - Shift: TShiftState; - Column: TColumnIndex; - HitPosition: TVTHeaderHitPositions; - end; + TCustomVirtualStringTree = class; - // Structure used when info about a certain position in the tree is needed. - THitInfo = record - HitNode: PVirtualNode; - HitPositions: THitPositions; - HitColumn: TColumnIndex; - HitPoint: TPoint; - end; +{$IFDEF VT_FMX} + TVTAncestor = TVTAncestorFMX; +{$ELSE} + TVTAncestor = TVTAncestorVcl; +{$ENDIF} - // auto scroll directions - TScrollDirections = set of ( - sdLeft, - sdUp, - sdRight, - sdDown + // Describes the source to use when converting a string tree into a string for clipboard etc. + TVSTTextSourceType = ( + tstAll, // All nodes are rendered. Initialization is done on the fly. + tstInitialized, // Only initialized nodes are rendered. + tstSelected, // Only selected nodes are rendered. + tstCutCopySet, // Only nodes currently marked as being in the cut/copy clipboard set are rendered. + tstVisible, // Only visible nodes are rendered. + tstChecked // Only checked nodes are rendered ); - // OLE drag'n drop support - TFormatEtcArray = array of TFormatEtc; - TFormatArray = array of Word; - - // IDataObject.SetData support - TInternalStgMedium = packed record - Format: TClipFormat; - Medium: TStgMedium; - end; - TInternalStgMediumArray = array of TInternalStgMedium; - - TEnumFormatEtc = class(TInterfacedObject, IEnumFormatEtc) - private - FTree: TBaseVirtualTree; - FFormatEtcArray: TFormatEtcArray; - FCurrentIndex: Integer; - public - constructor Create(Tree: TBaseVirtualTree; const AFormatEtcArray: TFormatEtcArray); - - function Clone(out Enum: IEnumFormatEtc): HResult; stdcall; - function Next(celt: Integer; out elt; pceltFetched: PLongint): HResult; stdcall; - function Reset: HResult; stdcall; - function Skip(celt: Integer): HResult; stdcall; - end; - - // ----- OLE drag'n drop handling - - IVTDragManager = interface(IUnknown) - ['{C4B25559-14DA-446B-8901-0C879000EB16}'] - procedure ForceDragLeave; stdcall; - function GetDataObject: IDataObject; stdcall; - function GetDragSource: TBaseVirtualTree; stdcall; - function GetDropTargetHelperSupported: Boolean; stdcall; - function GetIsDropTarget: Boolean; stdcall; - - property DataObject: IDataObject read GetDataObject; - property DragSource: TBaseVirtualTree read GetDragSource; - property DropTargetHelperSupported: Boolean read GetDropTargetHelperSupported; - property IsDropTarget: Boolean read GetIsDropTarget; - end; - - // This data object is used in two different places. One is for clipboard operations and the other while dragging. - TVTDataObject = class(TInterfacedObject, IDataObject) - private - FOwner: TBaseVirtualTree; // The tree which provides clipboard or drag data. - FForClipboard: Boolean; // Determines which data to render with GetData. - FFormatEtcArray: TFormatEtcArray; - FInternalStgMediumArray: TInternalStgMediumArray; // The available formats in the DataObject - FAdviseHolder: IDataAdviseHolder; // Reference to an OLE supplied implementation for advising. - protected - function CanonicalIUnknown(const TestUnknown: IUnknown): IUnknown; - function EqualFormatEtc(FormatEtc1, FormatEtc2: TFormatEtc): Boolean; - function FindFormatEtc(TestFormatEtc: TFormatEtc; const FormatEtcArray: TFormatEtcArray): integer; - function FindInternalStgMedium(Format: TClipFormat): PStgMedium; - function HGlobalClone(HGlobal: THandle): THandle; - function RenderInternalOLEData(const FormatEtcIn: TFormatEtc; var Medium: TStgMedium; var OLEResult: HResult): Boolean; - function StgMediumIncRef(const InStgMedium: TStgMedium; var OutStgMedium: TStgMedium; - CopyInMedium: Boolean; const DataObject: IDataObject): HRESULT; - - property ForClipboard: Boolean read FForClipboard; - property FormatEtcArray: TFormatEtcArray read FFormatEtcArray write FFormatEtcArray; - property InternalStgMediumArray: TInternalStgMediumArray read FInternalStgMediumArray write FInternalStgMediumArray; - property Owner: TBaseVirtualTree read FOwner; - public - constructor Create(AOwner: TBaseVirtualTree; ForClipboard: Boolean); virtual; - destructor Destroy; override; - - function DAdvise(const FormatEtc: TFormatEtc; advf: Integer; const advSink: IAdviseSink; out dwConnection: Integer): - HResult; virtual; stdcall; - function DUnadvise(dwConnection: Integer): HResult; virtual; stdcall; - function EnumDAdvise(out enumAdvise: IEnumStatData): HResult; virtual; stdcall; - function EnumFormatEtc(Direction: Integer; out EnumFormatEtc: IEnumFormatEtc): HResult; virtual; stdcall; - function GetCanonicalFormatEtc(const FormatEtc: TFormatEtc; out FormatEtcOut: TFormatEtc): HResult; virtual; stdcall; - function GetData(const FormatEtcIn: TFormatEtc; out Medium: TStgMedium): HResult; virtual; stdcall; - function GetDataHere(const FormatEtc: TFormatEtc; out Medium: TStgMedium): HResult; virtual; stdcall; - function QueryGetData(const FormatEtc: TFormatEtc): HResult; virtual; stdcall; - function SetData(const FormatEtc: TFormatEtc; var Medium: TStgMedium; DoRelease: BOOL): HResult; virtual; stdcall; - end; - - // TVTDragManager is a class to manage drag and drop in a Virtual Treeview. - TVTDragManager = class(TInterfacedObject, IVTDragManager, IDropSource, IDropTarget) - private - FOwner, // The tree which is responsible for drag management. - FDragSource: TBaseVirtualTree; // Reference to the source tree if the source was a VT, might be different than - // the owner tree. - FIsDropTarget: Boolean; // True if the owner is currently the drop target. - FDataObject: IDataObject; // A reference to the data object passed in by DragEnter (only used when the owner - // tree is the current drop target). - FDropTargetHelper: IDropTargetHelper; // Win2k > Drag image support - FFullDragging: BOOL; // True, if full dragging is currently enabled in the system. - - function GetDataObject: IDataObject; stdcall; - function GetDragSource: TBaseVirtualTree; stdcall; - function GetDropTargetHelperSupported: Boolean; stdcall; - function GetIsDropTarget: Boolean; stdcall; - public - constructor Create(AOwner: TBaseVirtualTree); virtual; - destructor Destroy; override; - - function DragEnter(const DataObject: IDataObject; KeyState: Integer; Pt: TPoint; - var Effect: Longint): HResult; stdcall; - function DragLeave: HResult; stdcall; - function DragOver(KeyState: Integer; Pt: TPoint; var Effect: LongInt): HResult; stdcall; - function Drop(const DataObject: IDataObject; KeyState: Integer; Pt: TPoint; var Effect: Integer): HResult; stdcall; - procedure ForceDragLeave; stdcall; - function GiveFeedback(Effect: Integer): HResult; stdcall; - function QueryContinueDrag(EscapePressed: BOOL; KeyState: Integer): HResult; stdcall; - end; + TVSTGetTextEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; + TextType: TVSTTextType; var CellText: string) of object; + TVSTGetHintEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; + var LineBreakStyle: TVTTooltipLineBreakStyle; var HintText: string) of object; + // New text can only be set for variable caption. + TVSTNewTextEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; + NewText: string) of object; + /// String tree event for custom handling of string abbreviations. + /// The instance that fired the event. + /// Teh canvas on that the sending control will paint. + /// The Node that is going to be painted. + /// The column index that is going to be painted. + /// Var parameter that contains the caption or string that should be used. + /// Boolean var paramter: Assign True if a string is passed in the Result parameter. Leave the default value False if no shorting is need or the control shuld do it. + /// + /// If the text of a node does not fit into its cell (in grid mode) or is too wide for the width of the tree view it is being abbreviated with an ellipsis (...). By default the ellipsis is added to the end of the node text. + /// Occasionally you may want to shorten the node text at a different position, for example if the node text is a path string and not the last folder or filename should be cut off but rather some mid level folders if possible. + /// + TVSTShortenStringEvent = procedure(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode; + Column: TColumnIndex; const S: string; TextSpace: TDimension; var Result: string; + var Done: Boolean) of object; + TVTMeasureTextEvent = procedure(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode; + Column: TColumnIndex; const Text: string; var Extent: TDimension) of object; + TVTDrawTextEvent = procedure(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode; + Column: TColumnIndex; const Text: string; const CellRect: TRect; var DefaultDraw: Boolean) of object; - PVTHintData = ^TVTHintData; - TVTHintData = record - Tree: TBaseVirtualTree; + /// Event arguments of the OnGetCellText event + TVSTGetCellTextEventArgs = record Node: PVirtualNode; Column: TColumnIndex; - HintRect: TRect; // used for draw trees only, string trees get the size from the hint string - HintText: string; // set when size of the hint window is calculated - BidiMode: TBidiMode; - Alignment: TAlignment; - LineBreakStyle: TVTToolTipLineBreakStyle; - end; - - // The trees need an own hint window class because of Unicode output and adjusted font. - TVirtualTreeHintWindow = class(THintWindow) - strict private - FHintData: TVTHintData; - FTextHeight: TDimension; - procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED; - procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND; - strict protected - procedure CreateParams(var Params: TCreateParams); override; - procedure Paint; override; - public - function CalcHintRect(MaxWidth: TDimension; const AHint: string; AData: Pointer): TRect; override; - function IsHintMsg(var Msg: TMsg): Boolean; override; + CellText: string; + StaticText: string; + StaticTextAlignment: TAlignment; + ExportType: TVTExportType; + constructor Create(pNode: PVirtualNode; pColumn: TColumnIndex; pExportType: TVTExportType = TVTExportType.etNone); end; - // Drag image support for the tree. - TVTTransparency = 0..255; - TVTBias = -128..127; - - // Simple move limitation for the drag image. - TVTDragMoveRestriction = ( - dmrNone, - dmrHorizontalOnly, - dmrVerticalOnly - ); - - TVTDragImageStates = set of ( - disHidden, // Internal drag image is currently hidden (always hidden if drag image helper interfaces are used). - disInDrag, // Drag image class is currently being used. - disPrepared, // Drag image class is prepared. - disSystemSupport // Running on Windows 2000 or higher. System supports drag images natively. - ); + /// Event signature which is called when text is painted on the canvas or needed for the export. + TVSTGetCellTextEvent = procedure(Sender: TCustomVirtualStringTree; var E: TVSTGetCellTextEventArgs) of object; - // Class to manage header and tree drag image during a drag'n drop operation. - TVTDragImage = class + TCustomVirtualStringTree = class(TVTAncestor) private - FOwner: TBaseVirtualTree; - FBackImage, // backup of overwritten screen area - FAlphaImage, // target for alpha blending - FDragImage: TBitmap; // the actual drag image to blend to screen - FImagePosition, // position of image (upper left corner) in screen coordinates - FLastPosition: TPoint; // last mouse position in screen coordinates - FTransparency: TVTTransparency; // alpha value of the drag image (0 - fully transparent, 255 - fully opaque) - FPreBlendBias, // value to darken or lighten the drag image before it is blended - FPostBlendBias: TVTBias; // value to darken or lighten the alpha blend result - FFade: Boolean; // determines whether to fade the drag image from center to borders or not - FRestriction: TVTDragMoveRestriction; // determines in which directions the drag image can be moved - FColorKey: TColor; // color to make fully transparent regardless of any other setting - FStates: TVTDragImageStates; // Determines the states of the drag image class. - function GetVisible: Boolean; // True if the drag image is currently hidden (used only when dragging) - procedure InternalShowDragImage(ScreenDC: HDC); - procedure MakeAlphaChannel(Source, Target: TBitmap); - procedure RecaptureBackground(Tree: TBaseVirtualTree; R: TRect; VisibleRegion: HRGN; CaptureNCArea, - ReshowDragImage: Boolean); - function WillMove(P: TPoint): Boolean; - property Visible: Boolean read GetVisible; - property PreBlendBias: TVTBias read FPreBlendBias write FPreBlendBias default 0; - property Transparency: TVTTransparency read FTransparency write FTransparency default 128; - property ColorKey: TColor read FColorKey write FColorKey default clWindow; - property Fade: Boolean read FFade write FFade default False; - public - constructor Create(AOwner: TBaseVirtualTree); - destructor Destroy; override; - - function DragTo(P: TPoint; ForceRepaint: Boolean): Boolean; - procedure EndDrag; - function GetDragImageRect: TRect; - procedure HideDragImage; - procedure PrepareDrag(DragImage: TBitmap; ImagePosition, HotSpot: TPoint; const DataObject: IDataObject); - procedure ShowDragImage; - - property MoveRestriction: TVTDragMoveRestriction read FRestriction write FRestriction default dmrNone; - end; - - // tree columns implementation - TVirtualTreeColumns = class; - TVTHeader = class; - - TVirtualTreeColumnStyle = ( - vsText, - vsOwnerDraw - ); + FInternalDataOffset: Cardinal; // offset to the internal data of the string tree + FDefaultText: string; // text to show if there's no OnGetText event handler (e.g. at design time) + FTextHeight: Integer; // true size of the font + FEllipsisWidth: Integer; // width of '...' for the current font - TVTHeaderColumnLayout = ( - blGlyphLeft, - blGlyphRight, - blGlyphTop, - blGlyphBottom - ); + FOnGetText: TVSTGetTextEvent; // used to retrieve the string to be displayed for a specific node + fOnGetCellText: TVSTGetCellTextEvent; // used to retrieve the normal and static text of a tree node + FOnGetHint: TVSTGetHintEvent; // used to retrieve the hint to be displayed for a specific node + FOnNewText: TVSTNewTextEvent; // used to notify the application about an edited node caption + FOnShortenString: TVSTShortenStringEvent; // used to allow the application a customized string shortage + FOnMeasureTextWidth: TVTMeasureTextEvent; // used to adjust the width of the cells + FOnMeasureTextHeight: TVTMeasureTextEvent; + FOnDrawText: TVTDrawTextEvent; // used to custom draw the node text + /// Returns True if the property DefaultText has a value that differs from the default value, False otherwise. + function IsDefaultTextStored(): Boolean; + function GetImageText(Node: PVirtualNode; Kind: TVTImageKind; + Column: TColumnIndex): string; + function GetOptions: TCustomStringTreeOptions; + function GetStaticText(Node: PVirtualNode; Column: TColumnIndex): string; + function GetText(Node: PVirtualNode; Column: TColumnIndex): string; + procedure ReadText(Reader: TReader); + procedure WriteText(Writer: TWriter); + procedure ResetInternalData(Node: PVirtualNode; Recursive: Boolean); + procedure SetDefaultText(const Value: string); + procedure SetOptions(const Value: TCustomStringTreeOptions); + procedure SetText(Node: PVirtualNode; Column: TColumnIndex; const Value: string); + procedure WMSetFont(var Msg: TWMSetFont); message WM_SETFONT; + procedure GetDataFromGrid(const AStrings : TStringList; const IncludeHeading : Boolean = True); + protected + /// Contains the name of the string that should be restored as selection + /// + FPreviouslySelected: TStringList; + procedure InitializeTextProperties(var PaintInfo: TVTPaintInfo); + procedure PaintNormalText(var PaintInfo: TVTPaintInfo; TextOutFlags: Integer; Text: string); virtual; + procedure PaintStaticText(const PaintInfo: TVTPaintInfo; pStaticTextAlignment: TAlignment; const Text: string); virtual; // [IPK] - private to protected + procedure AdjustPaintCellRect(var PaintInfo: TVTPaintInfo; var NextNonEmpty: TColumnIndex); override; + function CanExportNode(Node: PVirtualNode): Boolean; + function CalculateStaticTextWidth(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; const Text: string): TDimension; virtual; + function CalculateTextWidth(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; const Text: string): TDimension; virtual; + function ColumnIsEmpty(Node: PVirtualNode; Column: TColumnIndex): Boolean; override; + procedure DefineProperties(Filer: TFiler); override; + function DoCreateEditor(Node: PVirtualNode; Column: TColumnIndex): IVTEditLink; override; + procedure DoAddToSelection(Node: PVirtualNode); override; + function DoGetNodeHint(Node: PVirtualNode; Column: TColumnIndex; var LineBreakStyle: TVTTooltipLineBreakStyle): string; override; + function DoGetNodeTooltip(Node: PVirtualNode; Column: TColumnIndex; var LineBreakStyle: TVTTooltipLineBreakStyle): string; override; + function DoGetNodeExtraWidth(Node: PVirtualNode; Column: TColumnIndex; Canvas: TCanvas = nil): TDimension; override; + function DoGetNodeWidth(Node: PVirtualNode; Column: TColumnIndex; Canvas: TCanvas = nil): TDimension; override; + procedure DoGetText(var pEventArgs: TVSTGetCellTextEventArgs); virtual; + function DoIncrementalSearch(Node: PVirtualNode; const Text: string): Integer; override; + procedure DoNewText(Node: PVirtualNode; Column: TColumnIndex; const Text: string); virtual; + procedure DoPaintNode(var PaintInfo: TVTPaintInfo); override; + function DoShortenString(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; const S: string; Width: TDimension; + EllipsisWidth: TDimension = 0): string; virtual; + procedure DoTextDrawing(var PaintInfo: TVTPaintInfo; const Text: string; CellRect: TRect; DrawFormat: Cardinal); virtual; + function DoTextMeasuring(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; const Text: string): TSize; virtual; + function GetOptionsClass: TTreeOptionsClass; override; + procedure GetRenderStartValues(Source: TVSTTextSourceType; var Node: PVirtualNode; + var NextNodeProc: TGetNextNodeProc); + function InternalData(Node: PVirtualNode): Pointer; + procedure MainColumnChanged; override; + function ReadChunk(Stream: TStream; Version: Integer; Node: PVirtualNode; ChunkType, + ChunkSize: Integer): Boolean; override; + procedure ReadOldStringOptions(Reader: TReader); + function RenderOLEData(const FormatEtcIn: TFormatEtc; out Medium: TStgMedium; ForClipboard: Boolean): HResult; override; + procedure SetChildCount(Node: PVirtualNode; NewChildCount: Cardinal); override; + procedure WriteChunks(Stream: TStream; Node: PVirtualNode); override; - TSortDirection = ( - sdAscending, - sdDescending - ); + property DefaultText: string read FDefaultText write SetDefaultText stored False;// Stored via own writer + property EllipsisWidth: Integer read FEllipsisWidth; + property TreeOptions: TCustomStringTreeOptions read GetOptions write SetOptions; - TSortDirectionHelper = record helper for VirtualTrees.TSortDirection - strict private - const cSortDirectionToInt: Array [TSortDirection] of Integer = (1, -1); + property OnGetHint: TVSTGetHintEvent read FOnGetHint write FOnGetHint; + property OnGetText: TVSTGetTextEvent read FOnGetText write FOnGetText; + property OnGetCellText: TVSTGetCellTextEvent read fOnGetCellText write fOnGetCellText; + property OnNewText: TVSTNewTextEvent read FOnNewText write FOnNewText; + property OnShortenString: TVSTShortenStringEvent read FOnShortenString write FOnShortenString; + property OnMeasureTextWidth: TVTMeasureTextEvent read FOnMeasureTextWidth write FOnMeasureTextWidth; + property OnMeasureTextHeight: TVTMeasureTextEvent read FOnMeasureTextHeight write FOnMeasureTextHeight; + property OnDrawText: TVTDrawTextEvent read FOnDrawText write FOnDrawText; public - /// Returns +1 for ascending and -1 for descending sort order. - function ToInt(): Integer; inline; - end; - - // Used during owner draw of the header to indicate which drop mark for the column must be drawn. - TVTDropMarkMode = ( - dmmNone, - dmmLeft, - dmmRight - ); - - TVirtualTreeColumn = class; - - // This structure carries all important information about header painting and is used in the advanced header painting. - THeaderPaintInfo = record - TargetCanvas: TCanvas; - Column: TVirtualTreeColumn; - PaintRectangle: TRect; - TextRectangle: TRect; - IsHoverIndex, - IsDownIndex, - IsEnabled, - ShowHeaderGlyph, - ShowSortGlyph, - ShowRightBorder: Boolean; - DropMark: TVTDropMarkMode; - GlyphPos, - SortGlyphPos: TPoint; - SortGlyphSize: TSize; - procedure DrawSortArrow(pDirection: TSortDirection); - procedure DrawDropMark(); + constructor Create(AOwner: TComponent); override; + destructor Destroy(); override; + function AddChild(Parent: PVirtualNode; UserData: Pointer = nil): PVirtualNode; override; + function ComputeNodeHeight(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; S: string = ''): TDimension; virtual; + function ContentToClipboard(Format: Word; Source: TVSTTextSourceType): HGLOBAL; + procedure ContentToCustom(Source: TVSTTextSourceType); + function ContentToHTML(Source: TVSTTextSourceType; const Caption: string = ''): String; + function ContentToRTF(Source: TVSTTextSourceType): RawByteString; + function ContentToText(Source: TVSTTextSourceType; Separator: Char): String; overload; + function ContentToUnicode(Source: TVSTTextSourceType; Separator: WideChar): string; overload; deprecated 'Use ContentToText instead'; + function ContentToText(Source: TVSTTextSourceType; const Separator: string): string; overload; + procedure GetTextInfo(Node: PVirtualNode; Column: TColumnIndex; const AFont: TFont; var R: TRect; + var Text: string); override; + function InvalidateNode(Node: PVirtualNode): TRect; override; + function Path(Node: PVirtualNode; Column: TColumnIndex; Delimiter: Char): string; + procedure ReinitNode(Node: PVirtualNode; Recursive: Boolean; ForceReinit: + Boolean = False); override; + procedure RemoveFromSelection(Node: PVirtualNode); override; + function SaveToCSVFile(const FileNameWithPath : TFileName; const IncludeHeading : Boolean) : Boolean; + /// Alternate text for images used in Accessibility. + property ImageText[Node: PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex]: string read GetImageText; + property StaticText[Node: PVirtualNode; Column: TColumnIndex]: string read GetStaticText; + property Text[Node: PVirtualNode; Column: TColumnIndex]: string read GetText write SetText; end; - - TVirtualTreeColumn = class(TCollectionItem) - private - const cDefaultColumnSpacing = 3; + {$if CompilerVersion >= 33} + [ComponentPlatformsAttribute(pfidWindows)] + {$ifend} + TVirtualStringTree = class(TCustomVirtualStringTree) private - FText, - FHint: string; - FWidth: TDimension; - FPosition: TColumnPosition; - FMinWidth: TDimension; - FMaxWidth: TDimension; - FStyle: TVirtualTreeColumnStyle; - FImageIndex: TImageIndex; - FBiDiMode: TBiDiMode; - FLayout: TVTHeaderColumnLayout; - FMargin, - FSpacing: TDimension; - FOptions: TVTColumnOptions; - FEditOptions: TVTEditOptions; - FEditNextColumn: TDimension; - FTag: NativeInt; - FAlignment: TAlignment; - FCaptionAlignment: TAlignment; // Alignment of the caption. - FLastWidth: TDimension; - FColor: TColor; - FBonusPixel: Boolean; - FSpringRest: Single; // Accumulator for width adjustment when auto spring option is enabled. - FCaptionText: string; - FCheckBox: Boolean; - FCheckType: TCheckType; - FCheckState: TCheckState; - FImageRect: TRect; - FHasImage: Boolean; - FDefaultSortDirection: TSortDirection; - function GetCaptionAlignment: TAlignment; - function GetCaptionWidth: TDimension; - function GetLeft: TDimension; - function IsBiDiModeStored: Boolean; - function IsCaptionAlignmentStored: Boolean; - function IsColorStored: Boolean; - procedure SetAlignment(const Value: TAlignment); - procedure SetBiDiMode(Value: TBiDiMode); - procedure SetCaptionAlignment(const Value: TAlignment); - procedure SetCheckBox(Value: Boolean); - procedure SetCheckState(Value: TCheckState); - procedure SetCheckType(Value: TCheckType); - procedure SetColor(const Value: TColor); - procedure SetImageIndex(Value: TImageIndex); - procedure SetLayout(Value: TVTHeaderColumnLayout); - procedure SetMargin(Value: TDimension); - procedure SetMaxWidth(Value: TDimension); - procedure SetMinWidth(Value: TDimension); - procedure SetOptions(Value: TVTColumnOptions); - procedure SetPosition(Value: TColumnPosition); - procedure SetSpacing(Value: TDimension); - procedure SetStyle(Value: TVirtualTreeColumnStyle); - procedure SetWidth(Value: TDimension); + function GetOptions: TStringTreeOptions; + procedure SetOptions(const Value: TStringTreeOptions); protected - FLeft: TDimension; - procedure ComputeHeaderLayout(var PaintInfo: THeaderPaintInfo; DrawFormat: Cardinal; CalculateTextRect: Boolean = False); - procedure DefineProperties(Filer: TFiler); override; - procedure GetAbsoluteBounds(var Left, Right: TDimension); - function GetDisplayName: string; override; - function GetText: string; virtual; // [IPK] - procedure SetText(const Value: string); virtual; // [IPK] private to protected & virtual - function GetOwner: TVirtualTreeColumns; reintroduce; - procedure ReadHint(Reader: TReader); - procedure ReadText(Reader: TReader); - procedure SetCollection(Value: TCollection); override; - property HasImage: Boolean read FHasImage; - property ImageRect: TRect read FImageRect; + function GetOptionsClass: TTreeOptionsClass; override; public - constructor Create(Collection: TCollection); override; - destructor Destroy; override; - - procedure Assign(Source: TPersistent); override; - function Equals(OtherColumnObj: TObject): Boolean; override; - function GetRect: TRect; virtual; - procedure LoadFromStream(const Stream: TStream; Version: Integer); - procedure ParentBiDiModeChanged; - procedure ParentColorChanged; - procedure RestoreLastWidth; - function GetEffectiveColor(): TColor; - procedure SaveToStream(const Stream: TStream); - function UseRightToLeftReading: Boolean; - - property CaptionText: string read FCaptionText; - property Left: TDimension read GetLeft; - property Owner: TVirtualTreeColumns read GetOwner; + property Canvas; + property RangeX; + property LastDragEffect; + property CheckImageKind; // should no more be published to make #622 fix working published - property Alignment: TAlignment read FAlignment write SetAlignment default taLeftJustify; - property BiDiMode: TBiDiMode read FBiDiMode write SetBiDiMode stored IsBiDiModeStored; - property CaptionAlignment: TAlignment read GetCaptionAlignment write SetCaptionAlignment - stored IsCaptionAlignmentStored default taLeftJustify; - property CaptionWidth: TDimension read GetCaptionWidth; - property CheckType: TCheckType read FCheckType write SetCheckType default ctCheckBox; - property CheckState: TCheckState read FCheckState write SetCheckState default csUncheckedNormal; - property CheckBox: Boolean read FCheckBox write SetCheckBox default False; - property Color: TColor read FColor write SetColor stored IsColorStored; - property DefaultSortDirection: TSortDirection read FDefaultSortDirection write FDefaultSortDirection default sdAscending; - property Hint: string read FHint write FHint; - property ImageIndex: TImageIndex read FImageIndex write SetImageIndex default -1; - property Layout: TVTHeaderColumnLayout read FLayout write SetLayout default blGlyphLeft; - property Margin: TDimension read FMargin write SetMargin default 4; - property MaxWidth: TDimension read FMaxWidth write SetMaxWidth default 10000; - property MinWidth: TDimension read FMinWidth write SetMinWidth default 10; - property Options: TVTColumnOptions read FOptions write SetOptions default DefaultColumnOptions; - property EditOptions: TVTEditOptions read FEditOptions write FEditOptions default toDefaultEdit; - property EditNextColumn: TDimension read FEditNextColumn write FEditNextColumn default -1; - property Position: TColumnPosition read FPosition write SetPosition; - property Spacing: TDimension read FSpacing write SetSpacing default cDefaultColumnSpacing; - property Style: TVirtualTreeColumnStyle read FStyle write SetStyle default vsText; - property Tag: NativeInt read FTag write FTag default 0; - property Text: string read GetText write SetText; - property Width: TDimension read FWidth write SetWidth default 50; - end; - - TVirtualTreeColumnClass = class of TVirtualTreeColumn; - - TColumnsArray = array of TVirtualTreeColumn; - TCardinalArray = array of Cardinal; - TIndexArray = array of TColumnIndex; - - TVirtualTreeColumns = class(TCollection) - private - FHeader: TVTHeader; - FHeaderBitmap: TBitmap; // backbuffer for drawing - FHoverIndex, // currently "hot" column - FDownIndex, // Column on which a mouse button is held down. - FTrackIndex: TColumnIndex; // Index of column which is currently being resized. - FClickIndex: TColumnIndex; // Index of the last clicked column. - FCheckBoxHit: Boolean; // True if the last click was on a header checkbox. - FPositionToIndex: TIndexArray; - FDefaultWidth: TDimension; // the width columns are created with - FNeedPositionsFix: Boolean; // True if FixPositions must still be called after DFM loading or Bidi mode change. - FClearing: Boolean; // True if columns are being deleted entirely. - FColumnPopupMenu: TPopupMenu; // Member for storing the TVTHeaderPopupMenu - - function GetCount: TDimension; - function GetItem(Index: TColumnIndex): TVirtualTreeColumn; - function GetNewIndex(P: TPoint; var OldIndex: TColumnIndex): Boolean; - procedure SetDefaultWidth(Value: TDimension); - procedure SetItem(Index: TColumnIndex; Value: TVirtualTreeColumn); - protected - // drag support - FDragIndex: TColumnIndex; // index of column currently being dragged - FDropTarget: TColumnIndex; // current target column (index) while dragging - FDropBefore: Boolean; // True if drop position is in the left half of a column, False for the right - // side to drop the dragged column to - - procedure AdjustAutoSize(CurrentIndex: TColumnIndex; Force: Boolean = False); - function AdjustDownColumn(P: TPoint): TColumnIndex; - function AdjustHoverColumn(P: TPoint): Boolean; - procedure AdjustPosition(Column: TVirtualTreeColumn; Position: Cardinal); - function CanSplitterResize(P: TPoint; Column: TColumnIndex): Boolean; - procedure DoCanSplitterResize(P: TPoint; Column: TColumnIndex; var Allowed: Boolean); virtual; - procedure DrawButtonText(DC: HDC; Caption: string; Bounds: TRect; Enabled, Hot: Boolean; DrawFormat: Cardinal; - WrapCaption: Boolean); - procedure FixPositions; - function GetColumnAndBounds(P: TPoint; var ColumnLeft, ColumnRight: TDimension; Relative: Boolean = True): Integer; - function GetOwner: TPersistent; override; - function HandleClick(P: TPoint; Button: TMouseButton; Force, DblClick: Boolean): Boolean; virtual; - procedure HeaderPopupMenuAddHeaderPopupItem(const Sender: TBaseVirtualTree; const Column: TColumnIndex; - var Cmd: TAddPopupItemType); - procedure HeaderPopupMenuColumnChange(const Sender: TBaseVirtualTree; const Column: TColumnIndex; Visible: Boolean); - procedure IndexChanged(OldIndex, NewIndex: Integer); - procedure InitializePositionArray; - procedure Notify(Item: TCollectionItem; Action: System.Classes.TCollectionNotification); override; - procedure ReorderColumns(RTL: Boolean); - procedure Update(Item: TCollectionItem); override; - procedure UpdatePositions(Force: Boolean = False); - - property HeaderBitmap: TBitmap read FHeaderBitmap; - property PositionToIndex: TIndexArray read FPositionToIndex; - property HoverIndex: TColumnIndex read FHoverIndex; - property DownIndex: TColumnIndex read FDownIndex; - property CheckBoxHit: Boolean read FCheckBoxHit; - public - constructor Create(AOwner: TVTHeader); virtual; - destructor Destroy; override; - - function Add: TVirtualTreeColumn; virtual; - procedure AnimatedResize(Column: TColumnIndex; NewWidth: TDimension); - procedure Assign(Source: TPersistent); override; - procedure Clear; virtual; - function ColumnFromPosition(P: TPoint; Relative: Boolean = True): TColumnIndex; overload; virtual; - function ColumnFromPosition(PositionIndex: TColumnPosition): TColumnIndex; overload; virtual; - function Equals(OtherColumnsObj: TObject): Boolean; override; - procedure GetColumnBounds(Column: TColumnIndex; var Left, Right: TDimension); - function GetFirstVisibleColumn(ConsiderAllowFocus: Boolean = False): TColumnIndex; - function GetLastVisibleColumn(ConsiderAllowFocus: Boolean = False): TColumnIndex; - function GetFirstColumn: TColumnIndex; - function GetNextColumn(Column: TColumnIndex): TColumnIndex; - function GetNextVisibleColumn(Column: TColumnIndex; ConsiderAllowFocus: Boolean = False): TColumnIndex; - function GetPreviousColumn(Column: TColumnIndex): TColumnIndex; - function GetPreviousVisibleColumn(Column: TColumnIndex; ConsiderAllowFocus: Boolean = False): TColumnIndex; - function GetScrollWidth: TDimension; - function GetVisibleColumns: TColumnsArray; - function GetVisibleFixedWidth: TDimension; - function IsValidColumn(Column: TColumnIndex): Boolean; - procedure LoadFromStream(const Stream: TStream; Version: Integer); - procedure PaintHeader(DC: HDC; R: TRect; HOffset: TDimension); overload; virtual; - procedure PaintHeader(TargetCanvas: TCanvas; R: TRect; const Target: TPoint; - RTLOffset: TDimension = 0); overload; virtual; - procedure SaveToStream(const Stream: TStream); - procedure EndUpdate(); override; - function TotalWidth: TDimension; - - property Count: Integer read GetCount; - property ClickIndex: TColumnIndex read FClickIndex; - property DefaultWidth: TDimension read FDefaultWidth write SetDefaultWidth; - property Items[Index: TColumnIndex]: TVirtualTreeColumn read GetItem write SetItem; default; - property Header: TVTHeader read FHeader; - property TrackIndex: TColumnIndex read FTrackIndex; - end; - - TVirtualTreeColumnsClass = class of TVirtualTreeColumns; - - TVTConstraintPercent = 0..100; - TVTFixedAreaConstraints = class(TPersistent) - private - FHeader: TVTHeader; - FMaxHeightPercent, - FMaxWidthPercent, - FMinHeightPercent, - FMinWidthPercent: TVTConstraintPercent; - FOnChange: TNotifyEvent; - procedure SetConstraints(Index: Integer; Value: TVTConstraintPercent); - protected - procedure Change; - property Header: TVTHeader read FHeader; - public - constructor Create(AOwner: TVTHeader); - - procedure Assign(Source: TPersistent); override; - property OnChange: TNotifyEvent read FOnChange write FOnChange; - published - property MaxHeightPercent: TVTConstraintPercent index 0 read FMaxHeightPercent write SetConstraints default 0; - property MaxWidthPercent: TVTConstraintPercent index 1 read FMaxWidthPercent write SetConstraints default 0; - property MinHeightPercent: TVTConstraintPercent index 2 read FMinHeightPercent write SetConstraints default 0; - property MinWidthPercent: TVTConstraintPercent index 3 read FMinWidthPercent write SetConstraints default 0; - end; - - TVTHeaderStyle = ( - hsThickButtons, // TButton look and feel - hsFlatButtons, // flatter look than hsThickButton, like an always raised flat TToolButton - hsPlates // flat TToolButton look and feel (raise on hover etc.) - ); - - TVTHeaderOption = ( - hoAutoResize, // Adjust a column so that the header never exceeds the client width of the owner control. - hoColumnResize, // Resizing columns with the mouse is allowed. - hoDblClickResize, // Allows a column to resize itself to its largest entry. - hoDrag, // Dragging columns is allowed. - hoHotTrack, // Header captions are highlighted when mouse is over a particular column. - hoOwnerDraw, // Header items with the owner draw style can be drawn by the application via event. - hoRestrictDrag, // Header can only be dragged horizontally. - hoShowHint, // Show application defined header hint. - hoShowImages, // Show header images. - hoShowSortGlyphs, // Allow visible sort glyphs. - hoVisible, // Header is visible. - hoAutoSpring, // Distribute size changes of the header to all columns, which are sizable and have the - // coAutoSpring option enabled. - hoFullRepaintOnResize, // Fully invalidate the header (instead of subsequent columns only) when a column is resized. - hoDisableAnimatedResize, // Disable animated resize for all columns. - hoHeightResize, // Allow resizing header height via mouse. - hoHeightDblClickResize, // Allow the header to resize itself to its default height. - hoHeaderClickAutoSort, // Clicks on the header will make the clicked column the SortColumn or toggle sort direction if - // it already was the sort column - hoAutoColumnPopupMenu, // Show a context menu for activating and deactivating columns on right click - hoAutoResizeInclCaption // Includes the header caption for the auto resizing - ); - TVTHeaderOptions = set of TVTHeaderOption; - - THeaderState = ( - hsAutoSizing, // auto size chain is in progess, do not trigger again on WM_SIZE - hsDragging, // header dragging is in progress (only if enabled) - hsDragPending, // left button is down, user might want to start dragging a column - hsLoading, // The header currently loads from stream, so updates are not necessary. - hsColumnWidthTracking, // column resizing is in progress - hsColumnWidthTrackPending, // left button is down, user might want to start resize a column - hsHeightTracking, // height resizing is in progress - hsHeightTrackPending, // left button is down, user might want to start changing height - hsResizing, // multi column resizing in progress - hsScaling, // the header is scaled after a change of FixedAreaConstraints or client size - hsNeedScaling // the header needs to be scaled - ); - THeaderStates = set of THeaderState; - - - TSmartAutoFitType = ( - smaAllColumns, // consider nodes in view only for all columns - smaNoColumn, // consider nodes in view only for no column - smaUseColumnOption // use coSmartResize of the corresponding column - ); // describes the used column resize behaviour for AutoFitColumns - - - TChangeReason = ( - crIgnore, // used as placeholder - crAccumulated, // used for delayed changes - crChildAdded, // one or more child nodes have been added - crChildDeleted, // one or more child nodes have been deleted - crNodeAdded, // a node has been added - crNodeCopied, // a node has been duplicated - crNodeMoved // a node has been moved to a new place - ); // desribes what made a structure change event happen - - TVTHeader = class(TPersistent) - private - FOwner: TBaseVirtualTree; - FColumns: TVirtualTreeColumns; - FHeight: TDimension; - FFont: TFont; - FParentFont: Boolean; - FOptions: TVTHeaderOptions; - FStyle: TVTHeaderStyle; // button style - FBackgroundColor: TColor; - FAutoSizeIndex: TColumnIndex; - FPopupMenu: TPopupMenu; - FMainColumn: TColumnIndex; // the column which holds the tree - FMaxHeight: TDimension; - FMinHeight: TDimension; - FDefaultHeight: TDimension; - FFixedAreaConstraints: TVTFixedAreaConstraints; // Percentages for the fixed area (header, fixed columns). - FImages: TCustomImageList; - FImageChangeLink: TChangeLink; // connections to the image list to get notified about changes - fSplitterHitTolerance: TDimension; // For property SplitterHitTolerance - FSortColumn: TColumnIndex; - FSortDirection: TSortDirection; - FDragImage: TVTDragImage; // drag image management during header drag - FLastWidth: TDimension; // Used to adjust spring columns. This is the width of all visible columns, - // not the header rectangle. - function GetMainColumn: TColumnIndex; - function GetUseColumns: Boolean; - function IsFontStored: Boolean; - procedure SetAutoSizeIndex(Value: TColumnIndex); - procedure SetBackground(Value: TColor); - procedure SetColumns(Value: TVirtualTreeColumns); - procedure SetDefaultHeight(Value: TDimension); - procedure SetFont(const Value: TFont); - procedure SetHeight(Value: TDimension); - procedure SetImages(const Value: TCustomImageList); - procedure SetMainColumn(Value: TColumnIndex); - procedure SetMaxHeight(Value: TDimension); - procedure SetMinHeight(Value: TDimension); - procedure SetOptions(Value: TVTHeaderOptions); - procedure SetParentFont(Value: Boolean); - procedure SetSortColumn(Value: TColumnIndex); - procedure SetSortDirection(const Value: TSortDirection); - procedure SetStyle(Value: TVTHeaderStyle); - protected - FStates: THeaderStates; // Used to keep track of internal states the header can enter. - FDragStart: TPoint; // initial mouse drag position - FTrackStart: TPoint; // client coordinates of the tracking start point - FTrackPoint: TPoint; // Client coordinate where the tracking started. - FDoingAutoFitColumns: boolean; // Flag to avoid using the stored width for Main column - - procedure FontChanged(Sender: TObject); virtual; - procedure AutoScale(); virtual; - function CanSplitterResize(P: TPoint): Boolean; - function CanWriteColumns: Boolean; virtual; - procedure ChangeScale(M, D: TDimension); virtual; - function DetermineSplitterIndex(P: TPoint): Boolean; virtual; - procedure DoAfterAutoFitColumn(Column: TColumnIndex); virtual; - procedure DoAfterColumnWidthTracking(Column: TColumnIndex); virtual; - procedure DoAfterHeightTracking; virtual; - function DoBeforeAutoFitColumn(Column: TColumnIndex; SmartAutoFitType: TSmartAutoFitType): Boolean; virtual; - procedure DoBeforeColumnWidthTracking(Column: TColumnIndex; Shift: TShiftState); virtual; - procedure DoBeforeHeightTracking(Shift: TShiftState); virtual; - procedure DoCanSplitterResize(P: TPoint; var Allowed: Boolean); virtual; - function DoColumnWidthDblClickResize(Column: TColumnIndex; P: TPoint; Shift: TShiftState): Boolean; virtual; - function DoColumnWidthTracking(Column: TColumnIndex; Shift: TShiftState; var TrackPoint: TPoint; P: TPoint): Boolean; virtual; - function DoGetPopupMenu(Column: TColumnIndex; Position: TPoint): TPopupMenu; virtual; - function DoHeightTracking(var P: TPoint; Shift: TShiftState): Boolean; virtual; - function DoHeightDblClickResize(var P: TPoint; Shift: TShiftState): Boolean; virtual; - procedure DoSetSortColumn(Value: TColumnIndex; pSortDirection: TSortDirection); virtual; - procedure DragTo(P: TPoint); virtual; - procedure FixedAreaConstraintsChanged(Sender: TObject); - function GetColumnsClass: TVirtualTreeColumnsClass; virtual; - function GetOwner: TPersistent; override; - function GetShiftState: TShiftState; - function HandleHeaderMouseMove(var Message: TWMMouseMove): Boolean; - function HandleMessage(var Message: TMessage): Boolean; virtual; - procedure ImageListChange(Sender: TObject); - procedure PrepareDrag(P, Start: TPoint); - procedure ReadColumns(Reader: TReader); - procedure RecalculateHeader; virtual; - procedure RescaleHeader; - procedure UpdateMainColumn; - procedure UpdateSpringColumns; - procedure WriteColumns(Writer: TWriter); - public - constructor Create(AOwner: TBaseVirtualTree); virtual; - destructor Destroy; override; - - function AllowFocus(ColumnIndex: TColumnIndex): Boolean; - procedure Assign(Source: TPersistent); override; - procedure AutoFitColumns(Animated: Boolean = True; SmartAutoFitType: TSmartAutoFitType = smaUseColumnOption; - RangeStartCol: Integer = NoColumn; RangeEndCol: Integer = NoColumn); virtual; - function InHeader(P: TPoint): Boolean; virtual; - function InHeaderSplitterArea(P: TPoint): Boolean; virtual; - procedure Invalidate(Column: TVirtualTreeColumn; ExpandToBorder: Boolean = False; UpdateNowFlag : Boolean = False); - procedure LoadFromStream(const Stream: TStream); virtual; - function ResizeColumns(ChangeBy: TDimension; RangeStartCol: TColumnIndex; RangeEndCol: TColumnIndex; - Options: TVTColumnOptions = [coVisible]): TDimension; - procedure RestoreColumns; - procedure SaveToStream(const Stream: TStream); virtual; - - property DragImage: TVTDragImage read FDragImage; - property States: THeaderStates read FStates; - property Treeview: TBaseVirtualTree read FOwner; - property UseColumns: Boolean read GetUseColumns; - property doingAutoFitColumns: boolean read FDoingAutoFitColumns; - published - property AutoSizeIndex: TColumnIndex read FAutoSizeIndex write SetAutoSizeIndex; - property Background: TColor read FBackgroundColor write SetBackground default clBtnFace; - property Columns: TVirtualTreeColumns read FColumns write SetColumns stored False; // Stored by the owner tree to support VFI. - property DefaultHeight: Integer read FDefaultHeight write SetDefaultHeight default 19; - property Font: TFont read FFont write SetFont stored IsFontStored; - property FixedAreaConstraints: TVTFixedAreaConstraints read FFixedAreaConstraints write FFixedAreaConstraints; - property Height: Integer read FHeight write SetHeight default 19; - property Images: TCustomImageList read FImages write SetImages; - property MainColumn: TColumnIndex read GetMainColumn write SetMainColumn default 0; - property MaxHeight: Integer read FMaxHeight write SetMaxHeight default 10000; - property MinHeight: Integer read FMinHeight write SetMinHeight default 10; - property Options: TVTHeaderOptions read FOptions write SetOptions default [hoColumnResize, hoDrag, hoShowSortGlyphs]; - property ParentFont: Boolean read FParentFont write SetParentFont default True; - property PopupMenu: TPopupMenu read FPopupMenu write FPopupMenu; - property SortColumn: TColumnIndex read FSortColumn write SetSortColumn default NoColumn; - property SortDirection: TSortDirection read FSortDirection write SetSortDirection default sdAscending; - property SplitterHitTolerance: Integer read fSplitterHitTolerance write fSplitterHitTolerance default 8; // The area in pixels around a spliter which is sensitive for resizing - property Style: TVTHeaderStyle read FStyle write SetStyle default hsThickButtons; - end; - - TVTHeaderClass = class of TVTHeader; - - // Communication interface between a tree editor and the tree itself (declared as using stdcall in case it - // is implemented in a (C/C++) DLL). The GUID is not nessecary in Delphi but important for BCB users - // to allow QueryInterface and _uuidof calls. - IVTEditLink = interface - ['{2BE3EAFA-5ACB-45B4-9D9A-B58BCC496E17}'] - function BeginEdit: Boolean; stdcall; // Called when editing actually starts. - function CancelEdit: Boolean; stdcall; // Called when editing has been cancelled by the tree. - function EndEdit: Boolean; stdcall; // Called when editing has been finished by the tree. Returns True if successful, False if edit mode is still active. - function PrepareEdit(Tree: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex): Boolean; stdcall; - // Called after creation to allow a setup. - procedure ProcessMessage(var Message: TMessage); stdcall; - // Used to forward messages to the edit window(s)- - procedure SetBounds(R: TRect); stdcall; // Called to place the editor. - end; - - // Indicates in the OnUpdating event what state the tree is currently in. - TVTUpdateState = ( - usBegin, // The tree just entered the update state (BeginUpdate call for the first time). - usBeginSynch, // The tree just entered the synch update state (BeginSynch call for the first time). - usSynch, // Begin/EndSynch has been called but the tree did not change the update state. - usUpdate, // Begin/EndUpdate has been called but the tree did not change the update state. - usEnd, // The tree just left the update state (EndUpdate called for the last level). - usEndSynch // The tree just left the synch update state (EndSynch called for the last level). - ); - - // These elements are used both to query the application, which of them it wants to draw itself and to tell it during - // painting, which elements must be drawn during the advanced custom draw events. - THeaderPaintElements = set of ( - hpeBackground, - hpeDropMark, - hpeHeaderGlyph, - hpeSortGlyph, - hpeText, - // New in 7.0: Use this in FOnHeaderDrawQueryElements and OnAdvancedHeaderDraw - // for additional custom header drawing while keeping the default drawing - hpeOverlay - ); - - // Various events must be handled at different places than they were initiated or need - // a persistent storage until they are reset. - TVirtualTreeStates = set of ( - tsChangePending, // A selection change is pending. - tsCheckPropagation, // Set during automatic check state propagation. - tsCollapsing, // A full collapse operation is in progress. - tsToggleFocusedSelection, // Node selection was modifed using Ctrl-click. Change selection state on next mouse up. - tsClearPending, // Need to clear the current selection on next mouse move. - tsClearOnNewSelection, // Need to clear the current selection before selecting a new node - tsClipboardFlushing, // Set during flushing the clipboard to avoid freeing the content. - tsCopyPending, // Indicates a pending copy operation which needs to be finished. - tsCutPending, // Indicates a pending cut operation which needs to be finished. - tsDrawSelPending, // Multiselection only. User held down the left mouse button on a free - // area and might want to start draw selection. - tsDrawSelecting, // Multiselection only. Draw selection has actually started. - tsEditing, // Indicates that an edit operation is currently in progress. - tsEditPending, // An mouse up start edit if dragging has not started. - tsExpanding, // A full expand operation is in progress. - tsNodeHeightTracking, // A node height changing operation is in progress. - tsNodeHeightTrackPending, // left button is down, user might want to start changing a node's height. - tsHint, // Set when our hint is visible or soon will be. - tsInAnimation, // Set if the tree is currently in an animation loop. - tsIncrementalSearching, // Set when the user starts incremental search. - tsIncrementalSearchPending, // Set in WM_KEYDOWN to tell to use the char in WM_CHAR for incremental search. - tsIterating, // Set when IterateSubtree is currently in progress. - tsLeftButtonDown, // Set when the left mouse button is down. - tsLeftDblClick, // Set when the left mouse button was doubly clicked. - tsMiddleButtonDown, // Set when the middle mouse button is down. - tsMiddleDblClick, // Set when the middle mouse button was doubly clicked. - tsNeedRootCountUpdate, // Set if while loading a root node count is set. - tsOLEDragging, // OLE dragging in progress. - tsOLEDragPending, // User has requested to start delayed dragging. - tsPainting, // The tree is currently painting itself. - tsRightButtonDown, // Set when the right mouse button is down. - tsRightDblClick, // Set when the right mouse button was doubly clicked. - tsPopupMenuShown, // The user clicked the right mouse button, which might cause a popup menu to appear. - tsScrolling, // Set when autoscrolling is active. - tsScrollPending, // Set when waiting for the scroll delay time to elapse. - tsSizing, // Set when the tree window is being resized. This is used to prevent recursive calls - // due to setting the scrollbars when sizing. - tsStopValidation, // Cache validation can be stopped (usually because a change has occured meanwhile). - tsStructureChangePending, // The structure of the tree has been changed while the update was locked. - tsSynchMode, // Set when the tree is in synch mode, where no timer events are triggered. - tsThumbTracking, // Stop updating the horizontal scroll bar while dragging the vertical thumb and vice versa. - tsToggling, // A toggle operation (for some node) is in progress. - tsUpdateHiddenChildrenNeeded, // Pending update for the hidden children flag after massive visibility changes. - tsUpdating, // The tree does currently not update its window because a BeginUpdate has not yet ended. - tsUseCache, // The tree's node caches are validated and non-empty. - tsUserDragObject, // Signals that the application created an own drag object in OnStartDrag. - tsUseThemes, // The tree runs under WinXP+, is theme aware and themes are enabled. - tsValidating, // The tree's node caches are currently validated. - tsPreviouslySelectedLocked,// The member FPreviouslySelected should not be changed - tsValidationNeeded, // Something in the structure of the tree has changed. The cache needs validation. - tsVCLDragging, // VCL drag'n drop in progress. - tsVCLDragPending, // One-shot flag to avoid clearing the current selection on implicit mouse up for VCL drag. - tsVCLDragFinished, // Flag to avoid triggering the OnColumnClick event twice - tsWheelPanning, // Wheel mouse panning is active or soon will be. - tsWheelScrolling, // Wheel mouse scrolling is active or soon will be. - tsWindowCreating, // Set during window handle creation to avoid frequent unnecessary updates. - tsUseExplorerTheme // The tree runs under WinVista+ and is using the explorer theme - ); - - // determines whether and how the drag image is to show - TVTDragImageKind = ( - diComplete, // show a complete drag image with all columns, only visible columns are shown - diMainColumnOnly, // show only the main column (the tree column) - diNoImage // don't show a drag image at all - ); - - // Switch for OLE and VCL drag'n drop. Because it is not possible to have both simultanously. - TVTDragType = ( - dtOLE, - dtVCL - ); - - // options which determine what to draw in PaintTree - TVTInternalPaintOption = ( - poBackground, // draw background image if there is any and it is enabled - poColumnColor, // erase node's background with the column's color - poDrawFocusRect, // draw focus rectangle around the focused node - poDrawSelection, // draw selected nodes with the normal selection color - poDrawDropMark, // draw drop mark if a node is currently the drop target - poGridLines, // draw grid lines if enabled - poMainOnly, // draw only the main column - poSelectedOnly, // draw only selected nodes - poUnbuffered // draw directly onto the target canvas; especially useful when printing - ); - TVTInternalPaintOptions = set of TVTInternalPaintOption; - - // Determines the look of a tree's lines. - TVTLineStyle = ( - lsCustomStyle, // application provides a line pattern - lsDotted, // usual dotted lines (default) - lsSolid // simple solid lines - ); - - // TVTLineType is used during painting a tree - TVTLineType = ( - ltNone, // no line at all - ltBottomRight, // a line from bottom to the center and from there to the right - ltTopDown, // a line from top to bottom - ltTopDownRight, // a line from top to bottom and from center to the right - ltRight, // a line from center to the right - ltTopRight, // a line from bottom to center and from there to the right - // special styles for alternative drawings of tree lines - ltLeft, // a line from top to bottom at the left - ltLeftBottom // a combination of ltLeft and a line at the bottom from left to right - ); - - // Determines how to draw tree lines. - TVTLineMode = ( - lmNormal, // usual tree lines (as in TTreeview) - lmBands // looks similar to a Nassi-Schneidermann diagram - ); - - // A collection of line type IDs which is used while painting a node. - TLineImage = array of TVTLineType; - - TVTScrollIncrement = 1..10000; - - // Export type - TVTExportType = ( - etNone, // No export, normal displaying on the screen - etRTF, // contentToRTF - etHTML, // contentToHTML - etText, // contentToText - etExcel, // supported by external tools - etWord, // supported by external tools - etPDF, // supported by external tools - etPrinter,// supported by external tools - etCSV, // supported by external tools - etCustom // supported by external tools - ); - - TVTNodeExportEvent = procedure (Sender: TBaseVirtualTree; aExportType: TVTExportType; Node: PVirtualNode) of object; - TVTColumnExportEvent = procedure (Sender: TBaseVirtualTree; aExportType: TVTExportType; Column: TVirtualTreeColumn) of object; - TVTTreeExportEvent = procedure(Sender: TBaseVirtualTree; aExportType: TVTExportType) of object; - - // A class to manage scroll bar aspects. - TScrollBarOptions = class(TPersistent) - private - FAlwaysVisible: Boolean; - FOwner: TBaseVirtualTree; - FScrollBars: TScrollStyle; // used to hide or show vertical and/or horizontal scrollbar - FScrollBarStyle: TScrollBarStyle; // kind of scrollbars to use - FIncrementX, - FIncrementY: TVTScrollIncrement; // number of pixels to scroll in one step (when auto scrolling) - procedure SetAlwaysVisible(Value: Boolean); - procedure SetScrollBars(Value: TScrollStyle); - procedure SetScrollBarStyle(Value: TScrollBarStyle); - protected - function GetOwner: TPersistent; override; - public - constructor Create(AOwner: TBaseVirtualTree); - - procedure Assign(Source: TPersistent); override; - published - property AlwaysVisible: Boolean read FAlwaysVisible write SetAlwaysVisible default False; - property HorizontalIncrement: TVTScrollIncrement read FIncrementX write FIncrementX default 20; - property ScrollBars: TScrollStyle read FScrollBars write SetScrollBars default ssBoth; - property ScrollBarStyle: TScrollBarStyle read FScrollBarStyle write SetScrollBarStyle default sbmRegular; - property VerticalIncrement: TVTScrollIncrement read FIncrementY write FIncrementY default 20; - end; - - // class to collect all switchable colors into one place - TVTColors = class(TPersistent) - private - type - TVTColorEnum =(cDisabledColor, cDropMarkColor, cDropTargetColor, cFocusedSelectionColor, - cGridLineColor, cTreeLineColor, cUnfocusedSelectionColor, cBorderColor, cHotColor, - cFocusedSelectionBorderColor, cUnfocusedSelectionBorderColor, cDropTargetBorderColor, - cSelectionRectangleBlendColor, cSelectionRectangleBorderColor, cHeaderHotColor, - cSelectionTextColor, cUnfocusedColor); - - // Please make sure that the published Color properties at the corresponding index - // have the same color if you change anything here! - const cDefaultColors : array[TVTColorEnum] of TColor = ( - clBtnShadow, // DisabledColor - clHighlight, // DropMarkColor - clHighLight, // DropTargetColor - clHighLight, // FocusedSelectionColor - clBtnFace, // GridLineColor - clBtnShadow, // TreeLineColor - clInactiveCaption, // UnfocusedSelectionColor - clBtnFace, // BorderColor - clWindowText, // HotColor - clHighLight, // FocusedSelectionBorderColor - clInactiveCaption, // UnfocusedSelectionBorderColor - clHighlight, // DropTargetBorderColor - clHighlight, // SelectionRectangleBlendColor - clHighlight, // SelectionRectangleBorderColor - clBtnShadow, // HeaderHotColor - clHighlightText, // SelectionTextColor - clInactiveCaptionText); // UnfocusedColor [IPK] - - private - FOwner: TBaseVirtualTree; - FColors: array[TVTColorEnum] of TColor; // [IPK] 15 -> 16 - function GetColor(const Index: TVTColorEnum): TColor; - procedure SetColor(const Index: TVTColorEnum; const Value: TColor); - function GetBackgroundColor: TColor; - function GetHeaderFontColor: TColor; - function GetNodeFontColor: TColor; - function GetSelectedNodeFontColor(Focused:boolean): TColor; - public - constructor Create(AOwner: TBaseVirtualTree); - - procedure Assign(Source: TPersistent); override; - property BackGroundColor: TColor read GetBackgroundColor; - property HeaderFontColor: TColor read GetHeaderFontColor; - property NodeFontColor: TColor read GetNodeFontColor; - published - property BorderColor: TColor index cBorderColor read GetColor write SetColor default clBtnFace; - property DisabledColor: TColor index cDisabledColor read GetColor write SetColor default clBtnShadow; - property DropMarkColor: TColor index cDropMarkColor read GetColor write SetColor default clHighlight; - property DropTargetColor: TColor index cDropTargetColor read GetColor write SetColor default clHighLight; - property DropTargetBorderColor: TColor index cDropTargetBorderColor read GetColor write SetColor default clHighLight; - /// The background color of selected nodes in case the tree has the focus, or the toPopupMode flag is set. - property FocusedSelectionColor: TColor index cFocusedSelectionColor read GetColor write SetColor default clHighLight; - /// The border color of selected nodes when the tree has the focus. - property FocusedSelectionBorderColor: TColor index cFocusedSelectionBorderColor read GetColor write SetColor default clHighLight; - property GridLineColor: TColor index cGridLineColor read GetColor write SetColor default clBtnFace; - property HeaderHotColor: TColor index cHeaderHotColor read GetColor write SetColor default clBtnShadow; - property HotColor: TColor index cHotColor read GetColor write SetColor default clWindowText; - property SelectionRectangleBlendColor: TColor index cSelectionRectangleBlendColor read GetColor write SetColor default clHighlight; - property SelectionRectangleBorderColor: TColor index cSelectionRectangleBorderColor read GetColor write SetColor default clHighlight; - /// The text color of selected nodes - property SelectionTextColor: TColor index cSelectionTextColor read GetColor write SetColor default clHighlightText; - property TreeLineColor: TColor index cTreeLineColor read GetColor write SetColor default clBtnShadow; - property UnfocusedColor: TColor index cUnfocusedColor read GetColor write SetColor default clInactiveCaptionText; // [IPK] Added - /// The background color of selected nodes in case the tree does not have the focus and the toPopupMode flag is not set. - property UnfocusedSelectionColor: TColor index cUnfocusedSelectionColor read GetColor write SetColor default clInactiveCaption; - /// The border color of selected nodes in case the tree does not have the focus and the toPopupMode flag is not set. - property UnfocusedSelectionBorderColor: TColor index cUnfocusedSelectionBorderColor read GetColor write SetColor default clInactiveCaption; - end; - - // For painting a node and its columns/cells a lot of information must be passed frequently around. - TVTImageInfo = record - Index: TImageIndex; // Index in the associated image list. - XPos, // Horizontal position in the current target canvas. - YPos: TDimension; // Vertical position in the current target canvas. - Ghosted: Boolean; // Flag to indicate that the image must be drawn slightly lighter. - Images: TCustomImageList; // The image list to be used for painting. - function Equals(const pImageInfo2: TVTImageInfo): Boolean; - end; - - TVTImageInfoIndex = ( - iiNormal, - iiState, - iiCheck, - iiOverlay - ); - - // Options which are used when modifying the scroll offsets. - TScrollUpdateOptions = set of ( - suoRepaintHeader, // if suoUpdateNCArea is also set then invalidate the header - suoRepaintScrollBars, // if suoUpdateNCArea is also set then repaint both scrollbars after updating them - suoScrollClientArea, // scroll and invalidate the proper part of the client area - suoUpdateNCArea // update non-client area (scrollbars, header) - ); - - // Determines the look of a tree's buttons. - TVTButtonStyle = ( - bsRectangle, // traditional Windows look (plus/minus buttons) - bsTriangle // traditional Macintosh look - ); - - // TButtonFillMode is only used when the button style is bsRectangle and determines how to fill the interior. - TVTButtonFillMode = ( - fmTreeColor, // solid color, uses the tree's background color - fmWindowColor, // solid color, uses clWindow - fmShaded, // color gradient, Windows XP style (legacy code, use toThemeAware on Windows XP instead) - fmTransparent // transparent color, use the item's background color - ); - - TVTPaintInfo = record - Canvas: TCanvas; // the canvas to paint on - PaintOptions: TVTInternalPaintOptions; // a copy of the paint options passed to PaintTree - Node: PVirtualNode; // the node to paint - Column: TColumnIndex; // the node's column index to paint - Position: TColumnPosition; // the column position of the node - CellRect: TRect; // the node cell - ContentRect: TRect; // the area of the cell used for the node's content - NodeWidth: TDimension; // the actual node width - Alignment: TAlignment; // how to align within the node rectangle - CaptionAlignment: TAlignment; // how to align text within the caption rectangle - BidiMode: TBidiMode; // directionality to be used for painting - BrushOrigin: TPoint; // the alignment for the brush used to draw dotted lines - ImageInfo: array[TVTImageInfoIndex] of TVTImageInfo; // info about each possible node image - Offsets: TVTOffsets; // The offsets of the various elements of a tree node - VAlign: TDimension; - procedure AdjustImageCoordinates(); - end; - - // Method called by the Animate routine for each animation step. - TVTAnimationCallback = function(Step, StepSize: Integer; Data: Pointer): Boolean of object; - - TVTIncrementalSearch = ( - isAll, // search every node in tree, initialize if necessary - isNone, // disable incremental search - isInitializedOnly, // search only initialized nodes, skip others - isVisibleOnly // search only visible nodes, initialize if necessary - ); - - // Determines which direction to use when advancing nodes during an incremental search. - TVTSearchDirection = ( - sdForward, - sdBackward - ); - - // Determines where to start incremental searching for each key press. - TVTSearchStart = ( - ssAlwaysStartOver, // always use the first/last node (depending on direction) to search from - ssLastHit, // use the last found node - ssFocusedNode // use the currently focused node - ); - - // Determines how to use the align member of a node. - TVTNodeAlignment = ( - naFromBottom, // the align member specifies amount of units (usually pixels) from top border of the node - naFromTop, // align is to be measured from bottom - naProportional // align is to be measure in percent of the entire node height and relative to top - ); - - // Determines how to draw the selection rectangle used for draw selection. - TVTDrawSelectionMode = ( - smDottedRectangle, // same as DrawFocusRect - smBlendedRectangle // alpha blending, uses special colors (see TVTColors) - ); - - // Determines for which purpose the cell paint event is called. - TVTCellPaintMode = ( - cpmPaint, // painting the cell - cpmGetContentMargin // getting cell content margin - ); - - // Determines which sides of the cell content margin should be considered. - TVTCellContentMarginType = ( - ccmtAllSides, // consider all sides - ccmtTopLeftOnly, // consider top margin and left margin only - ccmtBottomRightOnly // consider bottom margin and right margin only - ); - - TClipboardFormats = class(TStringList) - private - FOwner: TBaseVirtualTree; - public - constructor Create(AOwner: TBaseVirtualTree); virtual; - - function Add(const S: string): Integer; override; - procedure Insert(Index: Integer; const S: string); override; - property Owner: TBaseVirtualTree read FOwner; - end; - - // ----- Event prototypes: - - // node enumeration - TVTGetNodeProc = reference to procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Data: Pointer; var Abort: Boolean); - // node events - TVTChangingEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; var Allowed: Boolean) of object; - TVTCheckChangingEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; var NewState: TCheckState; - var Allowed: Boolean) of object; - TVTChangeEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode) of object; - TVTStructureChangeEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Reason: TChangeReason) of object; - TVTEditCancelEvent = procedure(Sender: TBaseVirtualTree; Column: TColumnIndex) of object; - TVTEditChangingEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; - var Allowed: Boolean) of object; - TVTEditChangeEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex) of object; - TVTFreeNodeEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode) of object; - TVTFocusChangingEvent = procedure(Sender: TBaseVirtualTree; OldNode, NewNode: PVirtualNode; OldColumn, - NewColumn: TColumnIndex; var Allowed: Boolean) of object; - TVTFocusChangeEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex) of object; - TVTAddToSelectionEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode) of object; - TVTRemoveFromSelectionEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode) of object; - TVTGetImageEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex; - var Ghosted: Boolean; var ImageIndex: TImageIndex) of object; - TVTGetImageExEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex; - var Ghosted: Boolean; var ImageIndex: TImageIndex; var ImageList: TCustomImageList) of object; - TVTGetImageTextEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex; - var ImageText: string) of object; - TVTHotNodeChangeEvent = procedure(Sender: TBaseVirtualTree; OldNode, NewNode: PVirtualNode) of object; - TVTInitChildrenEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; var ChildCount: Cardinal) of object; - TVTInitNodeEvent = procedure(Sender: TBaseVirtualTree; ParentNode, Node: PVirtualNode; - var InitialStates: TVirtualNodeInitStates) of object; - TVTPopupEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; const P: TPoint; - var AskParent: Boolean; var PopupMenu: TPopupMenu) of object; - TVTHelpContextEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; - var HelpContext: Integer) of object; - TVTCreateEditorEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; - out EditLink: IVTEditLink) of object; - TVTSaveTreeEvent = procedure(Sender: TBaseVirtualTree; Stream: TStream) of object; - TVTSaveNodeEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Stream: TStream) of object; - TVTBeforeGetCheckStateEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode) of object; - - // header/column events - TVTHeaderAddPopupItemEvent = procedure(const Sender: TBaseVirtualTree; const Column: TColumnIndex; - var Cmd: TAddPopupItemType) of object; - TVTHeaderClickEvent = procedure(Sender: TVTHeader; HitInfo: TVTHeaderHitInfo) of object; - TVTHeaderMouseEvent = procedure(Sender: TVTHeader; Button: TMouseButton; Shift: TShiftState; X, Y: Integer) of object; - TVTHeaderMouseMoveEvent = procedure(Sender: TVTHeader; Shift: TShiftState; X, Y: Integer) of object; - TVTBeforeHeaderHeightTrackingEvent = procedure(Sender: TVTHeader; Shift: TShiftState) of object; - TVTAfterHeaderHeightTrackingEvent = procedure(Sender: TVTHeader) of object; - TVTHeaderHeightTrackingEvent = procedure(Sender: TVTHeader; var P: TPoint; Shift: TShiftState; var Allowed: Boolean) of object; - TVTHeaderHeightDblClickResizeEvent = procedure(Sender: TVTHeader; var P: TPoint; Shift: TShiftState; var Allowed: Boolean) of object; - TVTHeaderNotifyEvent = procedure(Sender: TVTHeader; Column: TColumnIndex) of object; - TVTHeaderDraggingEvent = procedure(Sender: TVTHeader; Column: TColumnIndex; var Allowed: Boolean) of object; - TVTHeaderDraggedEvent = procedure(Sender: TVTHeader; Column: TColumnIndex; OldPosition: Integer) of object; - TVTHeaderDraggedOutEvent = procedure(Sender: TVTHeader; Column: TColumnIndex; DropPosition: TPoint) of object; - TVTHeaderPaintEvent = procedure(Sender: TVTHeader; HeaderCanvas: TCanvas; Column: TVirtualTreeColumn; R: TRect; Hover, - Pressed: Boolean; DropMark: TVTDropMarkMode) of object; - TVTHeaderPaintQueryElementsEvent = procedure(Sender: TVTHeader; var PaintInfo: THeaderPaintInfo; - var Elements: THeaderPaintElements) of object; - TVTAdvancedHeaderPaintEvent = procedure(Sender: TVTHeader; var PaintInfo: THeaderPaintInfo; - const Elements: THeaderPaintElements) of object; - TVTBeforeAutoFitColumnsEvent = procedure(Sender: TVTHeader; var SmartAutoFitType: TSmartAutoFitType) of object; - TVTBeforeAutoFitColumnEvent = procedure(Sender: TVTHeader; Column: TColumnIndex; var SmartAutoFitType: TSmartAutoFitType; - var Allowed: Boolean) of object; - TVTAfterAutoFitColumnEvent = procedure(Sender: TVTHeader; Column: TColumnIndex) of object; - TVTAfterAutoFitColumnsEvent = procedure(Sender: TVTHeader) of object; - TVTColumnClickEvent = procedure (Sender: TBaseVirtualTree; Column: TColumnIndex; Shift: TShiftState) of object; - TVTColumnDblClickEvent = procedure (Sender: TBaseVirtualTree; Column: TColumnIndex; Shift: TShiftState) of object; - TColumnChangeEvent = procedure(const Sender: TBaseVirtualTree; const Column: TColumnIndex; Visible: Boolean) of object; - TVTColumnWidthDblClickResizeEvent = procedure(Sender: TVTHeader; Column: TColumnIndex; Shift: TShiftState; P: TPoint; - var Allowed: Boolean) of object; - TVTBeforeColumnWidthTrackingEvent = procedure(Sender: TVTHeader; Column: TColumnIndex; Shift: TShiftState) of object; - TVTAfterColumnWidthTrackingEvent = procedure(Sender: TVTHeader; Column: TColumnIndex) of object; - TVTColumnWidthTrackingEvent = procedure(Sender: TVTHeader; Column: TColumnIndex; Shift: TShiftState; var TrackPoint: TPoint; P: TPoint; - var Allowed: Boolean) of object; - TVTGetHeaderCursorEvent = procedure(Sender: TVTHeader; var Cursor: HCURSOR) of object; - TVTBeforeGetMaxColumnWidthEvent = procedure(Sender: TVTHeader; Column: TColumnIndex; var UseSmartColumnWidth: Boolean) of object; - TVTAfterGetMaxColumnWidthEvent = procedure(Sender: TVTHeader; Column: TColumnIndex; var MaxWidth: Integer) of object; - TVTCanSplitterResizeColumnEvent = procedure(Sender: TVTHeader; P: TPoint; Column: TColumnIndex; var Allowed: Boolean) of object; - TVTCanSplitterResizeHeaderEvent = procedure(Sender: TVTHeader; P: TPoint; var Allowed: Boolean) of object; - - // move, copy and node tracking events - TVTNodeMovedEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode) of object; - TVTNodeMovingEvent = procedure(Sender: TBaseVirtualTree; Node, Target: PVirtualNode; - var Allowed: Boolean) of object; - TVTNodeCopiedEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode) of object; - TVTNodeCopyingEvent = procedure(Sender: TBaseVirtualTree; Node, Target: PVirtualNode; - var Allowed: Boolean) of object; - TVTNodeClickEvent = procedure(Sender: TBaseVirtualTree; const HitInfo: THitInfo) of object; - TVTNodeHeightTrackingEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; Shift: TShiftState; - var TrackPoint: TPoint; P: TPoint; var Allowed: Boolean) of object; - TVTNodeHeightDblClickResizeEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; - Shift: TShiftState; P: TPoint; var Allowed: Boolean) of object; - TVTCanSplitterResizeNodeEvent = procedure(Sender: TBaseVirtualTree; P: TPoint; Node: PVirtualNode; - Column: TColumnIndex; var Allowed: Boolean) of object; - - // drag'n drop/OLE events - TVTCreateDragManagerEvent = procedure(Sender: TBaseVirtualTree; out DragManager: IVTDragManager) of object; - TVTCreateDataObjectEvent = procedure(Sender: TBaseVirtualTree; out IDataObject: IDataObject) of object; - TVTDragAllowedEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; - var Allowed: Boolean) of object; - TVTDragOverEvent = procedure(Sender: TBaseVirtualTree; Source: TObject; Shift: TShiftState; State: TDragState; - Pt: TPoint; Mode: TDropMode; var Effect: Integer; var Accept: Boolean) of object; - TVTDragDropEvent = procedure(Sender: TBaseVirtualTree; Source: TObject; DataObject: IDataObject; - Formats: TFormatArray; Shift: TShiftState; Pt: TPoint; var Effect: Integer; Mode: TDropMode) of object; - TVTRenderOLEDataEvent = procedure(Sender: TBaseVirtualTree; const FormatEtcIn: TFormatEtc; out Medium: TStgMedium; - ForClipboard: Boolean; var Result: HRESULT) of object; - TVTGetUserClipboardFormatsEvent = procedure(Sender: TBaseVirtualTree; var Formats: TFormatEtcArray) of object; - - // paint events - TVTBeforeItemEraseEvent = procedure(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode; ItemRect: TRect; - var ItemColor: TColor; var EraseAction: TItemEraseAction) of object; - TVTAfterItemEraseEvent = procedure(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode; - ItemRect: TRect) of object; - TVTBeforeItemPaintEvent = procedure(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode; - ItemRect: TRect; var CustomDraw: Boolean) of object; - TVTAfterItemPaintEvent = procedure(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode; - ItemRect: TRect) of object; - TVTBeforeCellPaintEvent = procedure(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode; - Column: TColumnIndex; CellPaintMode: TVTCellPaintMode; CellRect: TRect; var ContentRect: TRect) of object; - TVTAfterCellPaintEvent = procedure(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode; - Column: TColumnIndex; CellRect: TRect) of object; - TVTPaintEvent = procedure(Sender: TBaseVirtualTree; TargetCanvas: TCanvas) of object; - TVTBackgroundPaintEvent = procedure(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; R: TRect; - var Handled: Boolean) of object; - TVTGetLineStyleEvent = procedure(Sender: TBaseVirtualTree; var Bits: Pointer) of object; - TVTMeasureItemEvent = procedure(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode; - var NodeHeight: Integer) of object; - - TVTPrepareButtonImagesEvent = procedure(Sender: TBaseVirtualTree; const APlusBM : TBitmap; const APlusHotBM :TBitmap; - const APlusSelectedHotBM :TBitmap; const AMinusBM : TBitmap; const AMinusHotBM : TBitmap; - const AMinusSelectedHotBM :TBitmap; var ASize : TSize) of object; - - // search, sort - TVTCompareEvent = procedure(Sender: TBaseVirtualTree; Node1, Node2: PVirtualNode; Column: TColumnIndex; - var Result: Integer) of object; - TVTIncrementalSearchEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; const SearchText: string; - var Result: Integer) of object; - - // operations - TVTOperationEvent = procedure(Sender: TBaseVirtualTree; OperationKind: TVTOperationKind) of object; - - TVTHintKind = (vhkText, vhkOwnerDraw); - TVTHintKindEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; var Kind: TVTHintKind) of object; - TVTDrawHintEvent = procedure(Sender: TBaseVirtualTree; HintCanvas: TCanvas; Node: PVirtualNode; R: TRect; Column: TColumnIndex) of object; - TVTGetHintSizeEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; var R: TRect) of object; - - // miscellaneous - TVTBeforeDrawLineImageEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Level: Integer; var PosX: Integer) of object; - TVTGetNodeDataSizeEvent = procedure(Sender: TBaseVirtualTree; var NodeDataSize: Integer) of object; - TVTKeyActionEvent = procedure(Sender: TBaseVirtualTree; var CharCode: Word; var Shift: TShiftState; - var DoDefault: Boolean) of object; - TVTScrollEvent = procedure(Sender: TBaseVirtualTree; DeltaX, DeltaY: Integer) of object; - TVTUpdatingEvent = procedure(Sender: TBaseVirtualTree; State: TVTUpdateState) of object; - TVTGetCursorEvent = procedure(Sender: TBaseVirtualTree; var Cursor: TCursor) of object; - TVTStateChangeEvent = procedure(Sender: TBaseVirtualTree; Enter, Leave: TVirtualTreeStates) of object; - TVTGetCellIsEmptyEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; - var IsEmpty: Boolean) of object; - TVTScrollBarShowEvent = procedure(Sender: TBaseVirtualTree; Bar: Integer; Show: Boolean) of object; - - // Helper types for node iterations. - TGetFirstNodeProc = function: PVirtualNode of object; - TGetNextNodeProc = function(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode of object; - - TVZVirtualNodeEnumerationMode = ( - vneAll, - vneChecked, - vneChild, - vneCutCopy, - vneInitialized, - vneLeaf, - vneLevel, - vneNoInit, - vneSelected, - vneVisible, - vneVisibleChild, - vneVisibleNoInitChild, - vneVisibleNoInit - ); - - PVTVirtualNodeEnumeration = ^TVTVirtualNodeEnumeration; - - TVTVirtualNodeEnumerator = record - private - FNode: PVirtualNode; - FCanMoveNext: Boolean; - FEnumeration: PVTVirtualNodeEnumeration; - function GetCurrent: PVirtualNode; inline; - public - function MoveNext: Boolean; inline; - property Current: PVirtualNode read GetCurrent; - end; - - TVTVirtualNodeEnumeration = record - private - FMode: TVZVirtualNodeEnumerationMode; - FTree: TBaseVirtualTree; - // GetNextXxx parameters: - FConsiderChildrenAbove: Boolean; - FNode: PVirtualNode; - FNodeLevel: Cardinal; - FState: TCheckState; - FIncludeFiltered: Boolean; - public - function GetEnumerator: TVTVirtualNodeEnumerator; - private - function GetNext(Node: PVirtualNode): PVirtualNode; - end; - - - // ----- TBaseVirtualTree - TBaseVirtualTree = class(TCustomControl) - private - FTotalInternalDataSize: Cardinal; // Cache of the sum of the necessary internal data size for all tree - FBorderStyle: TBorderStyle; - FHeader: TVTHeader; - FRoot: PVirtualNode; - FDefaultNodeHeight, - FIndent: Cardinal; - FOptions: TCustomVirtualTreeOptions; - FUpdateCount: Cardinal; // update stopper, updates of the tree control are only done if = 0 - FSynchUpdateCount: Cardinal; // synchronizer, causes all events which are usually done via timers - // to happen immediately, regardless of the normal update state - FNodeDataSize: Integer; // number of bytes to allocate with each node (in addition to its base - // structure and the internal data), if -1 then do callback - FStates: TVirtualTreeStates; // various active/pending states the tree needs to consider - FLastSelected, - FFocusedNode: PVirtualNode; - FEditColumn, // column to be edited (focused node) - FFocusedColumn: TColumnIndex; // NoColumn if no columns are active otherwise the last hit column of - // the currently focused node - FHeightTrackPoint: TPoint; // Starting point of a node's height changing operation. - FHeightTrackNode: PVirtualNode; // Node which height is being changed. - FHeightTrackColumn: TColumnIndex; // Initial column where the height changing operation takes place. - FScrollDirections: TScrollDirections; // directions to scroll client area into depending on mouse position - FLastStructureChangeReason: TChangeReason; // Used for delayed structure change event. - FLastStructureChangeNode, // dito - FLastChangedNode, // used for delayed change event - FCurrentHotNode: PVirtualNode; // Node over which the mouse is hovering. - FCurrentHotColumn: TColumnIndex; // Column over which the mouse is hovering. - FHotNodeButtonHit: Boolean; // Indicates wether the mouse is hovering over the hot node's button. - FLastSelRect, - FNewSelRect: TRect; // used while doing draw selection - FHotCursor: TCursor; // can be set to additionally indicate the current hot node - FLastHitInfo: THitInfo; // The THitInfo of the last mouse-down event. - // in Win98 (slide) and Windows 2000 (fade)) - FHintMode: TVTHintMode; // determines the kind of the hint window - FHintData: TVTHintData; // used while preparing the hint window - FChangeDelay: Cardinal; // used to delay OnChange event - FEditDelay: Cardinal; // determines time to elapse before a node goes into edit mode - FPositionCache: TCache; // array which stores node references ordered by vertical positions - // (see also DoValidateCache for more information) - FVisibleCount: Cardinal; // number of currently visible nodes - FStartIndex: Cardinal; // index to start validating cache from - FSelection: TNodeArray; // list of currently selected nodes - FSelectionCount: Integer; // number of currently selected nodes (size of FSelection might differ) - FSelectionLocked: Boolean; // prevents the tree from changing the selection - FRangeAnchor: PVirtualNode; // anchor node for selection with the keyboard, determines start of a - // selection range - FCheckPropagationCount: Cardinal; // nesting level of check propagation (WL, 05.02.2004) - FLastSelectionLevel: Integer; // keeps the last node level for constrained multiselection - FDrawSelShiftState: TShiftState; // keeps the initial shift state when the user starts selection with - // the mouse - FEditLink: IVTEditLink; // used to comunicate with an application defined editor - FTempNodeCache: TNodeArray; // used at various places to hold temporarily a bunch of node refs. - FTempNodeCount: Cardinal; // number of nodes in FTempNodeCache - FBackground: TPicture; // A background image loadable at design and runtime. - FBackgroundImageTransparent: Boolean; // By default, this is off. When switched on, will try to draw the image - // transparent by using the color of the component as transparent color - - FMargin: Integer; // horizontal distance to border and columns - FTextMargin: Integer; // space between the node's text and its horizontal bounds - FBackgroundOffsetX, - FBackgroundOffsetY: Integer; // used to fine tune the position of the background image - FAnimationDuration: Cardinal; // specifies how long an animation shall take (expanding, hint) - FWantTabs: Boolean; // If True then the tree also consumes the tab key. - FNodeAlignment: TVTNodeAlignment; // determines how to interpret the align member of a node - FHeaderRect: TRect; // Space which the header currently uses in the control (window coords). - FLastHintRect: TRect; // Area which the mouse must leave to reshow a hint. - FUpdateRect: TRect; - FEmptyListMessage: string; // Optional message that will be displayed if no nodes exist in the control. - - // paint support and images - FPlusBM, - FMinusBM, // small bitmaps used for tree buttons - FHotPlusBM, - FHotMinusBM, - FSelectedHotPlusBM, - FSelectedHotMinusBM: TBitmap; // small bitmaps used for hot tree buttons - FImages, // normal images in the tree - FStateImages, // state images in the tree - FCustomCheckImages: TCustomImageList; // application defined check images - FCheckImageKind: TCheckImageKind; // light or dark, cross marks or tick marks - FCheckImages: TCustomImageList; // Reference to global image list to be used for the check images. - //TODO: Use this margin for other images as well - FImagesMargin: Integer; // The margin used left and right of the checkboxes. - FImageChangeLink, - FStateChangeLink, - FCustomCheckChangeLink: TChangeLink; // connections to the image lists - FOldFontChange: TNotifyEvent; // helper method pointer for tracking font changes in the off screen buffer - FColors: TVTColors; // class comprising all customizable colors in the tree - FButtonStyle: TVTButtonStyle; // style of the tree buttons - FButtonFillMode: TVTButtonFillMode; // for rectangular tree buttons only: how to fill them - FLineStyle: TVTLineStyle; // style of the tree lines - FLineMode: TVTLineMode; // tree lines or bands etc. - FDottedBrush: HBRUSH; // used to paint dotted lines without special pens - FSelectionCurveRadius: Cardinal; // radius for rounded selection rectangles - FSelectionBlendFactor: Byte; // Determines the factor by which the selection rectangle is to be - // faded if enabled. - FDrawSelectionMode: TVTDrawSelectionMode; // determines the paint mode for draw selection - - // alignment and directionality support - FAlignment: TAlignment; // default alignment of the tree if no columns are shown - - // drag'n drop and clipboard support - FDragImageKind: TVTDragImageKind; // determines whether or not and what to show in the drag image - FDragOperations: TDragOperations; // determines which operations are allowed during drag'n drop - FDragThreshold: Integer; // used to determine when to actually start a drag'n drop operation - FDragManager: IVTDragManager; // drag'n drop, cut'n paste - FDropTargetNode: PVirtualNode; // node currently selected as drop target - FLastDropMode: TDropMode; // set while dragging and used to track changes - FDragSelection: TNodeArray; // temporary copy of FSelection used during drag'n drop - FLastDragEffect: Integer; // The last executed drag effect - FDragType: TVTDragType; // used to switch between OLE and VCL drag'n drop - FDragImage: TVTDragImage; // drag image management - FDragWidth, - FDragHeight: Integer; // size of the drag image, the larger the more CPU power is needed - FClipboardFormats: TClipboardFormats; // a list of clipboard format descriptions enabled for this tree - FLastVCLDragTarget: PVirtualNode; // A node cache for VCL drag'n drop (keywords: DragLeave on DragDrop). - FVCLDragEffect: Integer; // A cache for VCL drag'n drop to keep the current drop effect. - - // scroll support - FScrollBarOptions: TScrollBarOptions; // common properties of horizontal and vertical scrollbar - FAutoScrollInterval: TAutoScrollInterval; // determines speed of auto scrolling - FAutoScrollDelay: Cardinal; // amount of milliseconds to wait until autoscrolling becomes active - FAutoExpandDelay: Cardinal; // amount of milliseconds to wait until a node is expanded if it is the - // drop target - FOffsetX: Integer; - FOffsetY: Integer; // Determines left and top scroll offset. - FEffectiveOffsetX: Integer; // Actual position of the horizontal scroll bar (varies depending on bidi mode). - FRangeX, - FRangeY: Cardinal; // current virtual width and height of the tree - FBottomSpace: Cardinal; // Extra space below the last node. - - FDefaultPasteMode: TVTNodeAttachMode; // Used to determine where to add pasted nodes to. - FDragScrollStart: Cardinal; // Contains the start time when a tree does auto scrolling as drop target. - - // search - FIncrementalSearch: TVTIncrementalSearch; // Used to determine whether and how incremental search is to be used. - FSearchTimeout: Cardinal; // Number of milliseconds after which to stop incremental searching. - FSearchBuffer: string; // Collects a sequence of keypresses used to do incremental searching. - FLastSearchNode: PVirtualNode; // Reference to node which was last found as search fit. - FSearchDirection: TVTSearchDirection; // Direction to incrementally search the tree. - FSearchStart: TVTSearchStart; // Where to start iteration on each key press. - - // miscellanous - FPanningWindow: HWND; // Helper window for wheel panning - FPanningCursor: HCURSOR; // Current wheel panning cursor. - FPanningImage: TBitmap; // A little 32x32 bitmap to indicate the panning reference point. - FLastClickPos: TPoint; // Used for retained drag start and wheel mouse scrolling. - FOperationCount: Cardinal; // Counts how many nested long-running operations are in progress. - FOperationCanceled: Boolean; // Used to indicate that a long-running operation should be canceled. - FChangingTheme: Boolean; // Used to indicate that a theme change is goi ng on - FNextNodeToSelect: PVirtualNode; // Next tree node that we would like to select if the current one gets deleted or looses selection for other reasons. - - // MSAA support - FAccessible: IAccessible; // The IAccessible interface to the window itself. - FAccessibleItem: IAccessible; // The IAccessible to the item that currently has focus. - FAccessibleName: string; // The name the window is given for screen readers. - - // export - FOnBeforeNodeExport: TVTNodeExportEvent; // called before exporting a node - FOnNodeExport: TVTNodeExportEvent; - FOnAfterNodeExport: TVTNodeExportEvent; // called after exporting a node - FOnBeforeColumnExport: TVTColumnExportEvent; // called before exporting a column - FOnColumnExport: TVTColumnExportEvent; - FOnAfterColumnExport: TVTColumnExportEvent; // called after exporting a column - FOnBeforeTreeExport: TVTTreeExportEvent; // called before starting the export - FOnAfterTreeExport: TVTTreeExportEvent; // called after finishing the export - FOnBeforeHeaderExport: TVTTreeExportEvent; // called before exporting the header - FOnAfterHeaderExport: TVTTreeExportEvent; // called after exporting the header - - // common events - FOnChange: TVTChangeEvent; // selection change - FOnStructureChange: TVTStructureChangeEvent; // structural change like adding nodes etc. - FOnInitChildren: TVTInitChildrenEvent; // called when a node's children are needed (expanding etc.) - FOnInitNode: TVTInitNodeEvent; // called when a node needs to be initialized (child count etc.) - FOnFreeNode: TVTFreeNodeEvent; // called when a node is about to be destroyed, user data can and should - // be freed in this event - FOnGetImage: TVTGetImageEvent; // Used to retrieve the image index of a given node. - FOnGetImageEx: TVTGetImageExEvent; // Used to retrieve the image index of a given node along with a custom - // image list. - FOnGetImageText: TVTGetImageTextEvent; // Used to retrieve the image alternative text of a given node. - // Used by the accessibility interface to provide useful text for status images. - FOnHotChange: TVTHotNodeChangeEvent; // called when the current "hot" node (that is, the node under the mouse) - // changes and hot tracking is enabled - FOnExpanding, // called just before a node is expanded - FOnCollapsing: TVTChangingEvent; // called just before a node is collapsed - FOnChecking: TVTCheckChangingEvent; // called just before a node's check state is changed - FOnExpanded, // called after a node has been expanded - FOnCollapsed, // called after a node has been collapsed - FOnChecked: TVTChangeEvent; // called after a node's check state has been changed - FOnResetNode: TVTChangeEvent; // called when a node is set to be uninitialized - FOnNodeMoving: TVTNodeMovingEvent; // called just before a node is moved from one parent node to another - // (this can be cancelled) - FOnNodeMoved: TVTNodeMovedEvent; // called after a node and its children have been moved to another - // parent node (probably another tree, but within the same application) - FOnNodeCopying: TVTNodeCopyingEvent; // called when a node is copied to another parent node (probably in - // another tree, but within the same application, can be cancelled) - FOnNodeClick: TVTNodeClickEvent; // called when the user clicks on a node - FOnNodeDblClick: TVTNodeClickEvent; // called when the user double clicks on a node - FOnCanSplitterResizeNode: TVTCanSplitterResizeNodeEvent; // called to query the application wether resizing a node is allowed - FOnNodeHeightTracking: TVTNodeHeightTrackingEvent; // called when a node's height is being changed via mouse - FOnNodeHeightDblClickResize: TVTNodeHeightDblClickResizeEvent; // called when a node's vertical splitter is double clicked - FOnNodeCopied: TVTNodeCopiedEvent; // call after a node has been copied - FOnEditing: TVTEditChangingEvent; // called just before a node goes into edit mode - FOnEditCancelled: TVTEditCancelEvent; // called when editing has been cancelled - FOnEdited: TVTEditChangeEvent; // called when editing has successfully been finished - FOnFocusChanging: TVTFocusChangingEvent; // called when the focus is about to go to a new node and/or column - // (can be cancelled) - FOnFocusChanged: TVTFocusChangeEvent; // called when the focus goes to a new node and/or column - FOnAddToSelection: TVTAddToSelectionEvent; // called when a node is added to the selection - FOnRemoveFromSelection: TVTRemoveFromSelectionEvent; // called when a node is removed from the selection - FOnGetPopupMenu: TVTPopupEvent; // called when the popup for a node or the header needs to be shown - FOnGetHelpContext: TVTHelpContextEvent; // called when a node specific help theme should be called - FOnCreateEditor: TVTCreateEditorEvent; // called when a node goes into edit mode, this allows applications - // to supply their own editor - FOnLoadNode, // called after a node has been loaded from a stream (file, clipboard, - // OLE drag'n drop) to allow an application to load their own data - // saved in OnSaveNode - FOnSaveNode: TVTSaveNodeEvent; // called when a node needs to be serialized into a stream - // (see OnLoadNode) to give the application the opportunity to save - // their node specific, persistent data (note: never save memory - // references) - FOnLoadTree, // called after the tree has been loaded from a stream to allow an - // application to load their own data saved in OnSaveTree - FOnSaveTree: TVTSaveTreeEvent; // called after the tree has been saved to a stream to allow an - // application to save its own data - - // header/column mouse events - FOnAfterAutoFitColumn: TVTAfterAutoFitColumnEvent; - FOnAfterAutoFitColumns: TVTAfterAutoFitColumnsEvent; - FOnBeforeAutoFitColumns: TVTBeforeAutoFitColumnsEvent; - FOnBeforeAutoFitColumn: TVTBeforeAutoFitColumnEvent; - FOnHeaderAddPopupItem: TVTHeaderAddPopupItemEvent; - FOnHeaderClick: TVTHeaderClickEvent; - FOnHeaderDblClick: TVTHeaderClickEvent; - FOnAfterHeaderHeightTracking: TVTAfterHeaderHeightTrackingEvent; - FOnBeforeHeaderHeightTracking: TVTBeforeHeaderHeightTrackingEvent; - FOnHeaderHeightTracking: TVTHeaderHeightTrackingEvent; - FOnHeaderHeightDblClickResize: TVTHeaderHeightDblClickResizeEvent; - FOnHeaderMouseDown, - FOnHeaderMouseUp: TVTHeaderMouseEvent; - FOnHeaderMouseMove: TVTHeaderMouseMoveEvent; - FOnAfterGetMaxColumnWidth: TVTAfterGetMaxColumnWidthEvent; - FOnBeforeGetMaxColumnWidth: TVTBeforeGetMaxColumnWidthEvent; - FOnColumnClick: TVTColumnClickEvent; - FOnColumnDblClick: TVTColumnDblClickEvent; - FOnColumnResize: TVTHeaderNotifyEvent; - fOnColumnVisibilityChanged: TColumnChangeEvent; - FOnColumnWidthDblClickResize: TVTColumnWidthDblClickResizeEvent; - FOnAfterColumnWidthTracking: TVTAfterColumnWidthTrackingEvent; - FOnBeforeColumnWidthTracking: TVTBeforeColumnWidthTrackingEvent; - FOnColumnWidthTracking: TVTColumnWidthTrackingEvent; - FOnGetHeaderCursor: TVTGetHeaderCursorEvent; // triggered to allow the app. to use customized cursors for the header - FOnCanSplitterResizeColumn: TVTCanSplitterResizeColumnEvent; - FOnCanSplitterResizeHeader: TVTCanSplitterResizeHeaderEvent; - - // paint events - FOnAfterPaint, // triggered when the tree has entirely been painted - FOnBeforePaint: TVTPaintEvent; // triggered when the tree is about to be painted - FOnAfterItemPaint: TVTAfterItemPaintEvent; // triggered after an item has been painted - FOnBeforeItemPaint: TVTBeforeItemPaintEvent; // triggered when an item is about to be painted - FOnBeforeItemErase: TVTBeforeItemEraseEvent; // triggered when an item's background is about to be erased - FOnAfterItemErase: TVTAfterItemEraseEvent; // triggered after an item's background has been erased - FOnAfterCellPaint: TVTAfterCellPaintEvent; // triggered after a column of an item has been painted - FOnBeforeCellPaint: TVTBeforeCellPaintEvent; // triggered when a column of an item is about to be painted - FOnHeaderDraw: TVTHeaderPaintEvent; // Used when owner draw is enabled for the header and a column is set - // to owner draw mode. - FOnPrepareButtonImages : TVTPrepareButtonImagesEvent; //allow use to customise plus/minus bitmap images - FOnHeaderDrawQueryElements: TVTHeaderPaintQueryElementsEvent; // Used for advanced header painting to query the - // application for the elements, which are drawn by it and which should - // be drawn by the tree. - FOnAdvancedHeaderDraw: TVTAdvancedHeaderPaintEvent; // Used when owner draw is enabled for the header and a column - // is set to owner draw mode. But only if OnHeaderDrawQueryElements - // returns at least one element to be drawn by the application. - // In this case OnHeaderDraw is not used. - FOnGetLineStyle: TVTGetLineStyleEvent; // triggered when a custom line style is used and the pattern brush - // needs to be build - FOnPaintBackground: TVTBackgroundPaintEvent; // triggered if a part of the tree's background must be erased which is - // not covered by any node - FOnMeasureItem: TVTMeasureItemEvent; // Triggered when a node is about to be drawn and its height was not yet - // determined by the application. - - // drag'n drop events - FOnCreateDragManager: TVTCreateDragManagerEvent; // called to allow for app./descendant defined drag managers - FOnCreateDataObject: TVTCreateDataObjectEvent; // called to allow for app./descendant defined data objects - FOnDragAllowed: TVTDragAllowedEvent; // used to get permission for manual drag in mouse down - FOnDragOver: TVTDragOverEvent; // called for every mouse move - FOnDragDrop: TVTDragDropEvent; // called on release of mouse button (if drop was allowed) - FOnHeaderDragged: TVTHeaderDraggedEvent; // header (column) drag'n drop - FOnHeaderDraggedOut: TVTHeaderDraggedOutEvent; // header (column) drag'n drop, which did not result in a valid drop. - FOnHeaderDragging: TVTHeaderDraggingEvent; // header (column) drag'n drop - FOnRenderOLEData: TVTRenderOLEDataEvent; // application/descendant defined clipboard formats - FOnGetUserClipboardFormats: TVTGetUserClipboardFormatsEvent; // gives application/descendants the opportunity to - // add own clipboard formats on the fly - - // miscellanous events - FOnGetNodeDataSize: TVTGetNodeDataSizeEvent; // Called if NodeDataSize is -1. - FOnBeforeDrawLineImage: TVTBeforeDrawLineImageEvent; // Called to allow adjusting the indention of treelines. - FOnKeyAction: TVTKeyActionEvent; // Used to selectively prevent key actions (full expand on Ctrl+'+' etc.). - FOnScroll: TVTScrollEvent; // Called when one or both paint offsets changed. - FOnUpdating: TVTUpdatingEvent; // Called from BeginUpdate, EndUpdate, BeginSynch and EndSynch. - FOnGetCursor: TVTGetCursorEvent; // Called to allow the app. to set individual cursors. - FOnStateChange: TVTStateChangeEvent; // Called whenever a state in the tree changes. - FOnGetCellIsEmpty: TVTGetCellIsEmptyEvent; // Called when the tree needs to know if a cell is empty. - FOnShowScrollBar: TVTScrollBarShowEvent; // Called when a scrollbar is changed in its visibility. - FOnBeforeGetCheckState: TVTBeforeGetCheckStateEvent; // Called before a CheckState for a Node is obtained. - // Gives the application a chance to do special processing - // when a check state is actually required for the first time. - - // search, sort - FOnCompareNodes: TVTCompareEvent; // used during sort - FOnDrawHint: TVTDrawHintEvent; - FOnGetHintSize: TVTGetHintSizeEvent; - FOnGetHintKind: TVTHintKindEvent; - FOnIncrementalSearch: TVTIncrementalSearchEvent; // triggered on every key press (not key down) - FOnMouseEnter: TNotifyEvent; - FOnMouseLeave: TNotifyEvent; - - // operations - FOnStartOperation: TVTOperationEvent; // Called when an operation starts - FOnEndOperation: TVTOperationEvent; // Called when an operation ends - - FVclStyleEnabled: Boolean; - - procedure CMStyleChanged(var Message: TMessage); message CM_STYLECHANGED; - procedure CMParentDoubleBufferedChange(var Message: TMessage); message CM_PARENTDOUBLEBUFFEREDCHANGED; - - procedure AdjustTotalCount(Node: PVirtualNode; Value: Integer; relative: Boolean = False); - procedure AdjustTotalHeight(Node: PVirtualNode; Value: Integer; relative: Boolean = False); - function CalculateCacheEntryCount: Integer; - procedure CalculateVerticalAlignments(var PaintInfo: TVTPaintInfo; var VButtonAlign: Integer); - function ChangeCheckState(Node: PVirtualNode; Value: TCheckState): Boolean; - function CollectSelectedNodesLTR(MainColumn, NodeLeft, NodeRight: Integer; Alignment: TAlignment; OldRect, - NewRect: TRect): Boolean; - function CollectSelectedNodesRTL(MainColumn, NodeLeft, NodeRight: Integer; Alignment: TAlignment; OldRect, - NewRect: TRect): Boolean; - procedure ClearNodeBackground(const PaintInfo: TVTPaintInfo; UseBackground, Floating: Boolean; R: TRect); - function CompareNodePositions(Node1, Node2: PVirtualNode; ConsiderChildrenAbove: Boolean = False): Integer; - procedure DrawLineImage(const PaintInfo: TVTPaintInfo; X, Y, H, VAlign: Integer; Style: TVTLineType; Reverse: Boolean); - function FindInPositionCache(Node: PVirtualNode; var CurrentPos: Cardinal): PVirtualNode; overload; - function FindInPositionCache(Position: Cardinal; var CurrentPos: Cardinal): PVirtualNode; overload; - procedure FixupTotalCount(Node: PVirtualNode); - procedure FixupTotalHeight(Node: PVirtualNode); - function GetBottomNode: PVirtualNode; - function GetCheckState(Node: PVirtualNode): TCheckState; - function GetCheckType(Node: PVirtualNode): TCheckType; - function GetChildCount(Node: PVirtualNode): Cardinal; - function GetChildrenInitialized(Node: PVirtualNode): Boolean; inline; - function GetCutCopyCount: Integer; - function GetDisabled(Node: PVirtualNode): Boolean; - function GetSyncCheckstateWithSelection(Node: PVirtualNode): Boolean; - function GetDragManager: IVTDragManager; - function GetExpanded(Node: PVirtualNode): Boolean; - function GetFiltered(Node: PVirtualNode): Boolean; - function GetFullyVisible(Node: PVirtualNode): Boolean; - function GetHasChildren(Node: PVirtualNode): Boolean; - function GetMultiline(Node: PVirtualNode): Boolean; - function GetNodeHeight(Node: PVirtualNode): Cardinal; - function GetNodeParent(Node: PVirtualNode): PVirtualNode; - function GetOffsetXY: TPoint; - function GetRootNodeCount: Cardinal; - function GetSelected(Node: PVirtualNode): Boolean; - function GetTopNode: PVirtualNode; - function GetTotalCount: Cardinal; - function GetVerticalAlignment(Node: PVirtualNode): Byte; - function GetVisible(Node: PVirtualNode): Boolean; - function GetVisiblePath(Node: PVirtualNode): Boolean; - function HandleDrawSelection(X, Y: Integer): Boolean; - function HasVisibleNextSibling(Node: PVirtualNode): Boolean; - function HasVisiblePreviousSibling(Node: PVirtualNode): Boolean; - procedure ImageListChange(Sender: TObject); - procedure InitializeFirstColumnValues(var PaintInfo: TVTPaintInfo); - procedure InitRootNode(OldSize: Cardinal = 0); - function IsFirstVisibleChild(Parent, Node: PVirtualNode): Boolean; - function IsLastVisibleChild(Parent, Node: PVirtualNode): Boolean; - function MakeNewNode: PVirtualNode; - function PackArray({*}const TheArray: TNodeArray; Count: Integer): Integer; - procedure PrepareBitmaps(NeedButtons, NeedLines: Boolean); - procedure FakeReadIdent(Reader: TReader); - procedure SetAlignment(const Value: TAlignment); - procedure SetAnimationDuration(const Value: Cardinal); - procedure SetBackground(const Value: TPicture); - procedure SetBackGroundImageTransparent(const Value: Boolean); - procedure SetBackgroundOffset(const Index, Value: Integer); - procedure SetBorderStyle(Value: TBorderStyle); - procedure SetBottomNode(Node: PVirtualNode); - procedure SetBottomSpace(const Value: Cardinal); - procedure SetButtonFillMode(const Value: TVTButtonFillMode); - procedure SetButtonStyle(const Value: TVTButtonStyle); - procedure SetCheckImageKind(Value: TCheckImageKind); - procedure SetCheckState(Node: PVirtualNode; Value: TCheckState); - procedure SetCheckType(Node: PVirtualNode; Value: TCheckType); - procedure SetClipboardFormats(const Value: TClipboardFormats); - procedure SetColors(const Value: TVTColors); - procedure SetCustomCheckImages(const Value: TCustomImageList); - procedure SetDefaultNodeHeight(Value: Cardinal); - procedure SetDisabled(Node: PVirtualNode; Value: Boolean); - procedure SetEmptyListMessage(const Value: string); - procedure SetExpanded(Node: PVirtualNode; Value: Boolean); - procedure SetFocusedColumn(Value: TColumnIndex); - procedure SetFocusedNode(Value: PVirtualNode); - procedure SetFullyVisible(Node: PVirtualNode; Value: Boolean); - procedure SetHasChildren(Node: PVirtualNode; Value: Boolean); - procedure SetHeader(const Value: TVTHeader); - procedure SetHotNode(Value: PVirtualNode); - procedure SetFiltered(Node: PVirtualNode; Value: Boolean); - procedure SetImages(const Value: TCustomImageList); - procedure SetIndent(Value: Cardinal); - procedure SetLineMode(const Value: TVTLineMode); - procedure SetLineStyle(const Value: TVTLineStyle); - procedure SetMargin(Value: Integer); - procedure SetMultiline(Node: PVirtualNode; const Value: Boolean); - procedure SetNodeAlignment(const Value: TVTNodeAlignment); - procedure SetNodeDataSize(Value: Integer); - procedure SetNodeHeight(Node: PVirtualNode; Value: Cardinal); - procedure SetNodeParent(Node: PVirtualNode; const Value: PVirtualNode); - procedure SetOffsetX(const Value: Integer); - procedure SetOffsetXY(const Value: TPoint); - procedure SetOffsetY(const Value: Integer); - procedure SetOptions(const Value: TCustomVirtualTreeOptions); - procedure SetRootNodeCount(Value: Cardinal); - procedure SetScrollBarOptions(Value: TScrollBarOptions); - procedure SetSearchOption(const Value: TVTIncrementalSearch); - procedure SetSelected(Node: PVirtualNode; Value: Boolean); - procedure SetSelectionCurveRadius(const Value: Cardinal); - procedure SetStateImages(const Value: TCustomImageList); - procedure SetTextMargin(Value: Integer); - procedure SetTopNode(Node: PVirtualNode); - procedure SetUpdateState(Updating: Boolean); - procedure SetVerticalAlignment(Node: PVirtualNode; Value: Byte); - procedure SetVisible(Node: PVirtualNode; Value: Boolean); - procedure SetVisiblePath(Node: PVirtualNode; Value: Boolean); - procedure PrepareBackGroundPicture(Source: TPicture; DrawBitmap: TBitmap; DrawBitmapWidth: Integer; DrawBitMapHeight: Integer; ABkgcolor: TColor); - procedure StaticBackground(Source: TPicture; Target: TCanvas; OffsetPosition: TPoint; R: TRect; aBkgColor: TColor); - procedure StopTimer(ID: Integer); - procedure SetWindowTheme(const Theme: string); - procedure TileBackground(Source: TPicture; Target: TCanvas; Offset: TPoint; R: TRect; aBkgColor: TColor); - function ToggleCallback(Step, StepSize: Integer; Data: Pointer): Boolean; - - procedure CMColorChange(var Message: TMessage); message CM_COLORCHANGED; - procedure CMCtl3DChanged(var Message: TMessage); message CM_CTL3DCHANGED; - procedure CMBiDiModeChanged(var Message: TMessage); message CM_BIDIMODECHANGED; - procedure CMBorderChanged(var Message: TMessage); message CM_BORDERCHANGED; - procedure CMDenySubclassing(var Message: TMessage); message CM_DENYSUBCLASSING; - procedure CMDrag(var Message: TCMDrag); message CM_DRAG; - procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED; - procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED; - procedure CMHintShow(var Message: TCMHintShow); message CM_HINTSHOW; - procedure CMHintShowPause(var Message: TCMHintShowPause); message CM_HINTSHOWPAUSE; - procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER; - procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE; - procedure CMMouseWheel(var Message: TCMMouseWheel); message CM_MOUSEWHEEL; - procedure CMSysColorChange(var Message: TMessage); message CM_SYSCOLORCHANGE; - procedure TVMGetItem(var Message: TMessage); message TVM_GETITEM; - procedure TVMGetItemRect(var Message: TMessage); message TVM_GETITEMRECT; - procedure TVMGetNextItem(var Message: TMessage); message TVM_GETNEXTITEM; - procedure WMCancelMode(var Message: TWMCancelMode); message WM_CANCELMODE; - procedure WMChar(var Message: TWMChar); message WM_CHAR; - procedure WMContextMenu(var Message: TWMContextMenu); message WM_CONTEXTMENU; - procedure WMCopy(var Message: TWMCopy); message WM_COPY; - procedure WMCut(var Message: TWMCut); message WM_CUT; - procedure WMEnable(var Message: TWMEnable); message WM_ENABLE; - procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND; - procedure WMGetDlgCode(var Message: TWMGetDlgCode); message WM_GETDLGCODE; - procedure WMGetObject(var Message: TMessage); message WM_GETOBJECT; - procedure WMHScroll(var Message: TWMHScroll); message WM_HSCROLL; - procedure WMKeyDown(var Message: TWMKeyDown); message WM_KEYDOWN; - procedure WMKeyUp(var Message: TWMKeyUp); message WM_KEYUP; - procedure WMKillFocus(var Msg: TWMKillFocus); message WM_KILLFOCUS; - procedure WMLButtonDblClk(var Message: TWMLButtonDblClk); message WM_LBUTTONDBLCLK; - procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN; - procedure WMLButtonUp(var Message: TWMLButtonUp); message WM_LBUTTONUP; - procedure WMMButtonDblClk(var Message: TWMMButtonDblClk); message WM_MBUTTONDBLCLK; - procedure WMMButtonDown(var Message: TWMMButtonDown); message WM_MBUTTONDOWN; - procedure WMMButtonUp(var Message: TWMMButtonUp); message WM_MBUTTONUP; - procedure WMNCCalcSize(var Message: TWMNCCalcSize); message WM_NCCALCSIZE; - procedure WMNCDestroy(var Message: TWMNCDestroy); message WM_NCDESTROY; - procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST; - procedure WMNCPaint(var Message: TWMNCPaint); message WM_NCPAINT; - procedure WMPaint(var Message: TWMPaint); message WM_PAINT; - procedure WMPaste(var Message: TWMPaste); message WM_PASTE; - procedure WMPrint(var Message: TWMPrint); message WM_PRINT; - procedure WMPrintClient(var Message: TWMPrintClient); message WM_PRINTCLIENT; - procedure WMRButtonDblClk(var Message: TWMRButtonDblClk); message WM_RBUTTONDBLCLK; - procedure WMRButtonDown(var Message: TWMRButtonDown); message WM_RBUTTONDOWN; - procedure WMRButtonUp(var Message: TWMRButtonUp); message WM_RBUTTONUP; - procedure WMSetCursor(var Message: TWMSetCursor); message WM_SETCURSOR; - procedure WMSetFocus(var Msg: TWMSetFocus); message WM_SETFOCUS; - procedure WMSize(var Message: TWMSize); message WM_SIZE; - procedure WMTimer(var Message: TWMTimer); message WM_TIMER; - procedure WMThemeChanged(var Message: TMessage); message WM_THEMECHANGED; - procedure WMVScroll(var Message: TWMVScroll); message WM_VSCROLL; - function GetRangeX: Cardinal; - function GetDoubleBuffered: Boolean; - procedure SetDoubleBuffered(const Value: Boolean); - - protected - FFontChanged: Boolean; // flag for keeping informed about font changes in the off screen buffer // [IPK] - private to protected - procedure AutoScale(isDpiChange: Boolean); virtual; - procedure AddToSelection(Node: PVirtualNode; NotifySynced: Boolean); overload; virtual; - procedure AddToSelection(const NewItems: TNodeArray; NewLength: Integer; ForceInsert: Boolean = False); overload; virtual; - procedure AdjustPaintCellRect(var PaintInfo: TVTPaintInfo; var NextNonEmpty: TColumnIndex); virtual; - procedure AdjustPanningCursor(X, Y: Integer); virtual; - procedure AdviseChangeEvent(StructureChange: Boolean; Node: PVirtualNode; Reason: TChangeReason); virtual; - function AllocateInternalDataArea(Size: Cardinal): Cardinal; virtual; - procedure Animate(Steps, Duration: Cardinal; Callback: TVTAnimationCallback; Data: Pointer); virtual; - function CalculateSelectionRect(X, Y: Integer): Boolean; virtual; - function CanAutoScroll: Boolean; virtual; - function CanShowDragImage: Boolean; virtual; - function CanSplitterResizeNode(P: TPoint; Node: PVirtualNode; Column: TColumnIndex): Boolean; - procedure Change(Node: PVirtualNode); virtual; - procedure ChangeTreeStatesAsync(EnterStates, LeaveStates: TVirtualTreeStates); - procedure ChangeScale(M, D: Integer{$if CompilerVersion >= 31}; isDpiChange: Boolean{$ifend}); override; - function CheckParentCheckState(Node: PVirtualNode; NewCheckState: TCheckState): Boolean; virtual; - procedure ClearSelection(pFireChangeEvent: Boolean); overload; virtual; - procedure ClearTempCache; virtual; - function ColumnIsEmpty(Node: PVirtualNode; Column: TColumnIndex): Boolean; virtual; - function ComputeRTLOffset(ExcludeScrollBar: Boolean = False): Integer; virtual; - function CountLevelDifference(Node1, Node2: PVirtualNode): Integer; virtual; - function CountVisibleChildren(Node: PVirtualNode): Cardinal; virtual; - procedure CreateParams(var Params: TCreateParams); override; - procedure CreateWnd; override; - procedure DefineProperties(Filer: TFiler); override; - procedure DeleteNode(Node: PVirtualNode; Reindex: Boolean; ParentClearing: Boolean); overload; - function DetermineDropMode(const P: TPoint; var HitInfo: THitInfo; var NodeRect: TRect): TDropMode; virtual; - procedure DetermineHiddenChildrenFlag(Node: PVirtualNode); virtual; - procedure DetermineHiddenChildrenFlagAllNodes; virtual; - procedure DetermineHitPositionLTR(var HitInfo: THitInfo; Offset, Right: Integer; Alignment: TAlignment); virtual; - procedure DetermineHitPositionRTL(var HitInfo: THitInfo; Offset, Right: Integer; Alignment: TAlignment); virtual; - function DetermineLineImageAndSelectLevel(Node: PVirtualNode; var LineImage: TLineImage): Integer; virtual; - function DetermineNextCheckState(CheckType: TCheckType; CheckState: TCheckState): TCheckState; virtual; - function DetermineScrollDirections(X, Y: Integer): TScrollDirections; virtual; - procedure DoAdvancedHeaderDraw(var PaintInfo: THeaderPaintInfo; const Elements: THeaderPaintElements); virtual; - procedure DoAfterCellPaint(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; CellRect: TRect); virtual; - procedure DoAfterItemErase(Canvas: TCanvas; Node: PVirtualNode; ItemRect: TRect); virtual; - procedure DoAfterItemPaint(Canvas: TCanvas; Node: PVirtualNode; ItemRect: TRect); virtual; - procedure DoAfterPaint(Canvas: TCanvas); virtual; - procedure DoAutoScroll(X, Y: Integer); virtual; - function DoBeforeDrag(Node: PVirtualNode; Column: TColumnIndex): Boolean; virtual; - procedure DoBeforeCellPaint(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; - CellPaintMode: TVTCellPaintMode; CellRect: TRect; var ContentRect: TRect); virtual; - procedure DoBeforeItemErase(Canvas: TCanvas; Node: PVirtualNode; ItemRect: TRect; var Color: TColor; - var EraseAction: TItemEraseAction); virtual; - function DoBeforeItemPaint(Canvas: TCanvas; Node: PVirtualNode; ItemRect: TRect): Boolean; virtual; - procedure DoBeforePaint(Canvas: TCanvas); virtual; - function DoCancelEdit: Boolean; virtual; - procedure DoCanEdit(Node: PVirtualNode; Column: TColumnIndex; var Allowed: Boolean); virtual; - procedure DoCanSplitterResizeNode(P: TPoint; Node: PVirtualNode; Column: TColumnIndex; - var Allowed: Boolean); virtual; - procedure DoChange(Node: PVirtualNode); virtual; - procedure DoCheckClick(Node: PVirtualNode; NewCheckState: TCheckState); virtual; - procedure DoChecked(Node: PVirtualNode); virtual; - function DoChecking(Node: PVirtualNode; var NewCheckState: TCheckState): Boolean; virtual; - procedure DoCollapsed(Node: PVirtualNode); virtual; - function DoCollapsing(Node: PVirtualNode): Boolean; virtual; - procedure DoColumnClick(Column: TColumnIndex; Shift: TShiftState); virtual; - procedure DoColumnDblClick(Column: TColumnIndex; Shift: TShiftState); virtual; - procedure DoColumnResize(Column: TColumnIndex); virtual; - procedure DoColumnVisibilityChanged(const Column: TColumnIndex; Visible: Boolean); virtual; - function DoCompare(Node1, Node2: PVirtualNode; Column: TColumnIndex): Integer; virtual; - function DoCreateDataObject: IDataObject; virtual; - function DoCreateDragManager: IVTDragManager; virtual; - function DoCreateEditor(Node: PVirtualNode; Column: TColumnIndex): IVTEditLink; virtual; - procedure DoDragging(P: TPoint); virtual; - procedure DoDragExpand; virtual; - procedure DoBeforeDrawLineImage(Node: PVirtualNode; Level: Integer; var XPos: Integer); virtual; - function DoDragOver(Source: TObject; Shift: TShiftState; State: TDragState; Pt: TPoint; Mode: TDropMode; - var Effect: Integer): Boolean; virtual; - procedure DoDragDrop(Source: TObject; const DataObject: IDataObject; const Formats: TFormatArray; Shift: TShiftState; Pt: TPoint; - var Effect: Integer; Mode: TDropMode); virtual; - procedure DoDrawHint(Canvas: TCanvas; Node: PVirtualNode; R: TRect; Column: - TColumnIndex); - procedure DoEdit; virtual; - procedure DoEndDrag(Target: TObject; X, Y: Integer); override; - function DoEndEdit: Boolean; virtual; - procedure DoEndOperation(OperationKind: TVTOperationKind); virtual; - procedure DoEnter(); override; - procedure DoExpanded(Node: PVirtualNode); virtual; - function DoExpanding(Node: PVirtualNode): Boolean; virtual; - procedure DoFocusChange(Node: PVirtualNode; Column: TColumnIndex); virtual; - function DoFocusChanging(OldNode, NewNode: PVirtualNode; OldColumn, NewColumn: TColumnIndex): Boolean; virtual; - procedure DoFocusNode(Node: PVirtualNode; Ask: Boolean); virtual; - procedure DoFreeNode(Node: PVirtualNode); virtual; - function DoGetCellContentMargin(Node: PVirtualNode; Column: TColumnIndex; - CellContentMarginType: TVTCellContentMarginType = ccmtAllSides; Canvas: TCanvas = nil): TPoint; virtual; - procedure DoGetCursor(var Cursor: TCursor); virtual; - procedure DoGetHeaderCursor(var Cursor: HCURSOR); virtual; - procedure DoGetHintSize(Node: PVirtualNode; Column: TColumnIndex; var R: - TRect); virtual; - procedure DoGetHintKind(Node: PVirtualNode; Column: TColumnIndex; var Kind: - TVTHintKind); - function DoGetImageIndex(Node: PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex; - var Ghosted: Boolean; var Index: TImageIndex): TCustomImageList; virtual; - procedure DoGetImageText(Node: PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex; var ImageText: string); virtual; - procedure DoGetLineStyle(var Bits: Pointer); virtual; - function DoGetNodeHint(Node: PVirtualNode; Column: TColumnIndex; var LineBreakStyle: TVTTooltipLineBreakStyle): string; virtual; - function DoGetNodeTooltip(Node: PVirtualNode; Column: TColumnIndex; var LineBreakStyle: TVTTooltipLineBreakStyle): string; virtual; - function DoGetNodeExtraWidth(Node: PVirtualNode; Column: TColumnIndex; Canvas: TCanvas = nil): Integer; virtual; - function DoGetNodeWidth(Node: PVirtualNode; Column: TColumnIndex; Canvas: TCanvas = nil): Integer; virtual; - function DoGetPopupMenu(Node: PVirtualNode; Column: TColumnIndex; Position: TPoint): TPopupMenu; virtual; - procedure DoGetUserClipboardFormats(var Formats: TFormatEtcArray); virtual; - procedure DoHeaderAddPopupItem(const Column: TColumnIndex; var Cmd: TAddPopupItemType); - procedure DoHeaderClick(const HitInfo: TVTHeaderHitInfo); virtual; - procedure DoHeaderDblClick(const HitInfo: TVTHeaderHitInfo); virtual; - procedure DoHeaderDragged(Column: TColumnIndex; OldPosition: TColumnPosition); virtual; - procedure DoHeaderDraggedOut(Column: TColumnIndex; DropPosition: TPoint); virtual; - function DoHeaderDragging(Column: TColumnIndex): Boolean; virtual; - procedure DoHeaderDraw(Canvas: TCanvas; Column: TVirtualTreeColumn; R: TRect; Hover, Pressed: Boolean; - DropMark: TVTDropMarkMode); virtual; - procedure DoHeaderDrawQueryElements(var PaintInfo: THeaderPaintInfo; var Elements: THeaderPaintElements); virtual; - procedure DoHeaderMouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); virtual; - procedure DoHeaderMouseMove(Shift: TShiftState; X, Y: Integer); virtual; - procedure DoHeaderMouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); virtual; - procedure DoHotChange(Old, New: PVirtualNode); virtual; - function DoIncrementalSearch(Node: PVirtualNode; const Text: string): Integer; virtual; - function DoInitChildren(Node: PVirtualNode; var ChildCount: Cardinal): Boolean; virtual; - procedure DoInitNode(Parent, Node: PVirtualNode; var InitStates: TVirtualNodeInitStates); virtual; - function DoKeyAction(var CharCode: Word; var Shift: TShiftState): Boolean; virtual; - procedure DoLoadUserData(Node: PVirtualNode; Stream: TStream); virtual; - procedure DoMeasureItem(TargetCanvas: TCanvas; Node: PVirtualNode; var NodeHeight: Integer); virtual; - procedure DoMouseEnter(); virtual; - procedure DoMouseLeave(); virtual; - procedure DoNodeCopied(Node: PVirtualNode); virtual; - function DoNodeCopying(Node, NewParent: PVirtualNode): Boolean; virtual; - procedure DoNodeClick(const HitInfo: THitInfo); virtual; - procedure DoNodeDblClick(const HitInfo: THitInfo); virtual; - function DoNodeHeightDblClickResize(Node: PVirtualNode; Column: TColumnIndex; Shift: TShiftState; - P: TPoint): Boolean; virtual; - function DoNodeHeightTracking(Node: PVirtualNode; Column: TColumnIndex; Shift: TShiftState; - var TrackPoint: TPoint; P: TPoint): Boolean; virtual; - procedure DoNodeMoved(Node: PVirtualNode); virtual; - function DoNodeMoving(Node, NewParent: PVirtualNode): Boolean; virtual; - function DoPaintBackground(Canvas: TCanvas; R: TRect): Boolean; virtual; - procedure DoPaintDropMark(Canvas: TCanvas; Node: PVirtualNode; R: TRect); virtual; - procedure DoPaintNode(var PaintInfo: TVTPaintInfo); virtual; - procedure DoPopupMenu(Node: PVirtualNode; Column: TColumnIndex; Position: TPoint); virtual; - procedure DoRemoveFromSelection(Node: PVirtualNode); virtual; - function DoRenderOLEData(const FormatEtcIn: TFormatEtc; out Medium: TStgMedium; - ForClipboard: Boolean): HRESULT; virtual; - procedure DoReset(Node: PVirtualNode); virtual; - procedure DoSaveUserData(Node: PVirtualNode; Stream: TStream); virtual; - procedure DoScroll(DeltaX, DeltaY: Integer); virtual; - function DoSetOffsetXY(Value: TPoint; Options: TScrollUpdateOptions; ClipRect: PRect = nil): Boolean; virtual; - procedure DoShowScrollBar(Bar: Integer; Show: Boolean); virtual; - procedure DoStartDrag(var DragObject: TDragObject); override; - procedure DoStartOperation(OperationKind: TVTOperationKind); virtual; - procedure DoStateChange(Enter: TVirtualTreeStates; Leave: TVirtualTreeStates = []); virtual; - procedure DoStructureChange(Node: PVirtualNode; Reason: TChangeReason); virtual; - procedure DoTimerScroll; virtual; - procedure DoUpdating(State: TVTUpdateState); virtual; - function DoValidateCache: Boolean; virtual; - procedure DragAndDrop(AllowedEffects: DWord; const DataObject: IDataObject; var DragEffect: Integer); virtual; - procedure DragCanceled; override; - function DragDrop(const DataObject: IDataObject; KeyState: Integer; Pt: TPoint; - var Effect: Integer): HResult; reintroduce; virtual; - function DragEnter(KeyState: Integer; Pt: TPoint; var Effect: Integer): HResult; virtual; - procedure DragFinished; virtual; - procedure DragLeave; virtual; - function DragOver(Source: TObject; KeyState: Integer; DragState: TDragState; Pt: TPoint; - var Effect: Integer): HResult; reintroduce; virtual; - procedure DrawDottedHLine(const PaintInfo: TVTPaintInfo; Left, Right, Top: Integer); virtual; - procedure DrawDottedVLine(const PaintInfo: TVTPaintInfo; Top, Bottom, Left: Integer; UseSelectedBkColor: Boolean = False); virtual; - procedure EndOperation(OperationKind: TVTOperationKind); - procedure EnsureNodeFocused(); virtual; - function FindNodeInSelection(P: PVirtualNode; var Index: Integer; LowBound, HighBound: Integer): Boolean; virtual; - procedure FinishChunkHeader(Stream: TStream; StartPos, EndPos: Integer); virtual; - procedure FontChanged(AFont: TObject); virtual; - function GetBorderDimensions: TSize; virtual; - function GetCheckedCount: Integer; - function GetCheckImage(Node: PVirtualNode; ImgCheckType: TCheckType = ctNone; - ImgCheckState: TCheckState = csUncheckedNormal; ImgEnabled: Boolean = True): Integer; virtual; - function GetColumnClass: TVirtualTreeColumnClass; virtual; - function GetDefaultHintKind: TVTHintKind; virtual; - function GetHeaderClass: TVTHeaderClass; virtual; - function GetHintWindowClass: THintWindowClass; virtual; - procedure GetImageIndex(var Info: TVTPaintInfo; Kind: TVTImageKind; InfoIndex: TVTImageInfoIndex); virtual; - function GetImageSize(Node: PVirtualNode; Kind: TVTImageKind = TVTImageKind.ikNormal; Column: TColumnIndex = 0; IncludePadding: Boolean = True): TSize; virtual; - function GetNodeImageSize(Node: PVirtualNode): TSize; virtual; deprecated 'Use GetImageSize instead'; - function GetMaxRightExtend: Cardinal; virtual; - procedure GetNativeClipboardFormats(var Formats: TFormatEtcArray); virtual; - function GetOperationCanceled: Boolean; - function GetOptionsClass: TTreeOptionsClass; virtual; - function GetTreeFromDataObject(const DataObject: IDataObject): TBaseVirtualTree; virtual; - procedure HandleHotTrack(X, Y: Integer); virtual; - procedure HandleIncrementalSearch(CharCode: Word); virtual; - procedure HandleMouseDblClick(var Message: TWMMouse; const HitInfo: THitInfo); virtual; - procedure HandleMouseDown(var Message: TWMMouse; var HitInfo: THitInfo); virtual; - procedure HandleMouseUp(var Message: TWMMouse; const HitInfo: THitInfo); virtual; - procedure HandleClickSelection(LastFocused, NewNode: PVirtualNode; Shift: TShiftState; DragPending: Boolean); - function HasImage(Node: PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex): Boolean; virtual; deprecated 'Use GetImageSize instead'; - function HasPopupMenu(Node: PVirtualNode; Column: TColumnIndex; Pos: TPoint): Boolean; virtual; - procedure InitChildren(Node: PVirtualNode); virtual; - procedure InitNode(Node: PVirtualNode); virtual; - procedure InternalAddFromStream(Stream: TStream; Version: Integer; Node: PVirtualNode); virtual; - function InternalAddToSelection(Node: PVirtualNode; ForceInsert: Boolean): Boolean; overload; - function InternalAddToSelection(const NewItems: TNodeArray; NewLength: Integer; - ForceInsert: Boolean): Boolean; overload; - procedure InternalCacheNode(Node: PVirtualNode); virtual; - procedure InternalClearSelection; virtual; - procedure InternalConnectNode(Node, Destination: PVirtualNode; Target: TBaseVirtualTree; Mode: TVTNodeAttachMode); virtual; - function InternalData(Node: PVirtualNode): Pointer; - procedure InternalDisconnectNode(Node: PVirtualNode; KeepFocus: Boolean; Reindex: Boolean = True; ParentClearing: Boolean = False); virtual; - procedure InternalRemoveFromSelection(Node: PVirtualNode); virtual; - procedure InterruptValidation; - procedure InvalidateCache; - procedure Loaded; override; - procedure MainColumnChanged; virtual; - procedure MarkCutCopyNodes; virtual; - procedure MouseMove(Shift: TShiftState; X, Y: Integer); override; - procedure Notification(AComponent: TComponent; Operation: TOperation); override; - procedure OriginalWMNCPaint(DC: HDC); virtual; - procedure Paint; override; - procedure PaintCheckImage(Canvas: TCanvas; const ImageInfo: TVTImageInfo; Selected: Boolean); virtual; - procedure PaintImage(var PaintInfo: TVTPaintInfo; ImageInfoIndex: TVTImageInfoIndex; DoOverlay: Boolean); virtual; - procedure PaintNodeButton(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; const R: TRect; ButtonX, - ButtonY: Integer; BidiMode: TBiDiMode); virtual; - procedure PaintTreeLines(const PaintInfo: TVTPaintInfo; IndentSize: Integer; const LineImage: TLineImage); virtual; - procedure PaintSelectionRectangle(Target: TCanvas; WindowOrgX: Integer; const SelectionRect: TRect; - TargetRect: TRect); virtual; - procedure PanningWindowProc(var Message: TMessage); virtual; - procedure PrepareCell(var PaintInfo: TVTPaintInfo; WindowOrgX, MaxWidth: Integer); virtual; - function ReadChunk(Stream: TStream; Version: Integer; Node: PVirtualNode; ChunkType, - ChunkSize: Integer): Boolean; virtual; - procedure ReadNode(Stream: TStream; Version: Integer; Node: PVirtualNode); virtual; - procedure RedirectFontChangeEvent(Canvas: TCanvas); virtual; - procedure RemoveFromSelection(Node: PVirtualNode); virtual; - procedure UpdateNextNodeToSelect(Node: PVirtualNode); virtual; - function RenderOLEData(const FormatEtcIn: TFormatEtc; out Medium: TStgMedium; ForClipboard: Boolean): HResult; virtual; - procedure ResetRangeAnchor; virtual; - procedure RestoreFontChangeEvent(Canvas: TCanvas); virtual; - procedure SelectNodes(StartNode, EndNode: PVirtualNode; AddOnly: Boolean); virtual; - procedure SetChildCount(Node: PVirtualNode; NewChildCount: Cardinal); virtual; - procedure SetFocusedNodeAndColumn(Node: PVirtualNode; Column: TColumnIndex); virtual; - procedure SetRangeX(value: Cardinal); - procedure SkipNode(Stream: TStream); virtual; - procedure StartOperation(OperationKind: TVTOperationKind); - procedure StartWheelPanning(Position: TPoint); virtual; - procedure StopWheelPanning; virtual; - procedure StructureChange(Node: PVirtualNode; Reason: TChangeReason); virtual; - function SuggestDropEffect(Source: TObject; Shift: TShiftState; Pt: TPoint; AllowedEffects: Integer): Integer; virtual; - procedure ToggleSelection(StartNode, EndNode: PVirtualNode); virtual; - procedure UnselectNodes(StartNode, EndNode: PVirtualNode); virtual; - procedure UpdateColumnCheckState(Col: TVirtualTreeColumn); - procedure UpdateDesigner; virtual; - procedure UpdateEditBounds; virtual; - procedure UpdateHeaderRect; virtual; - procedure UpdateStyleElements; override; - procedure UpdateWindowAndDragImage(const Tree: TBaseVirtualTree; TreeRect: TRect; UpdateNCArea, - ReshowDragImage: Boolean); virtual; - procedure ValidateCache; virtual; - procedure ValidateNodeDataSize(var Size: Integer); virtual; - procedure WndProc(var Message: TMessage); override; - procedure WriteChunks(Stream: TStream; Node: PVirtualNode); virtual; - procedure WriteNode(Stream: TStream; Node: PVirtualNode); virtual; - - procedure VclStyleChanged; virtual; - property VclStyleEnabled: Boolean read FVclStyleEnabled; - property TotalInternalDataSize: Cardinal read FTotalInternalDataSize; - - property Alignment: TAlignment read FAlignment write SetAlignment default taLeftJustify; - property AnimationDuration: Cardinal read FAnimationDuration write SetAnimationDuration default 200; - property AutoExpandDelay: Cardinal read FAutoExpandDelay write FAutoExpandDelay default 1000; - property AutoScrollDelay: Cardinal read FAutoScrollDelay write FAutoScrollDelay default 1000; - property AutoScrollInterval: TAutoScrollInterval read FAutoScrollInterval write FAutoScrollInterval default 1; - property Background: TPicture read FBackground write SetBackground; - property BackGroundImageTransparent: Boolean read FBackGroundImageTransparent write SetBackGroundImageTransparent default False; - property BackgroundOffsetX: Integer index 0 read FBackgroundOffsetX write SetBackgroundOffset default 0; - property BackgroundOffsetY: Integer index 1 read FBackgroundOffsetY write SetBackgroundOffset default 0; - property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle; - property BottomSpace: Cardinal read FBottomSpace write SetBottomSpace default 0; - property ButtonFillMode: TVTButtonFillMode read FButtonFillMode write SetButtonFillMode default fmTreeColor; - property ButtonStyle: TVTButtonStyle read FButtonStyle write SetButtonStyle default bsRectangle; - property ChangeDelay: Cardinal read FChangeDelay write FChangeDelay default 0; - property CheckImageKind: TCheckImageKind read FCheckImageKind write SetCheckImageKind stored False default ckSystemDefault; // deprecated, see issue #622 - property ClipboardFormats: TClipboardFormats read FClipboardFormats write SetClipboardFormats; - property Colors: TVTColors read FColors write SetColors; - property CustomCheckImages: TCustomImageList read FCustomCheckImages write SetCustomCheckImages; - property DefaultHintKind: TVTHintKind read GetDefaultHintKind; - property DefaultNodeHeight: Cardinal read FDefaultNodeHeight write SetDefaultNodeHeight default 18; - property DefaultPasteMode: TVTNodeAttachMode read FDefaultPasteMode write FDefaultPasteMode default amAddChildLast; - property DragHeight: Integer read FDragHeight write FDragHeight default 350; - property DragImageKind: TVTDragImageKind read FDragImageKind write FDragImageKind default diComplete; - property DragOperations: TDragOperations read FDragOperations write FDragOperations default [doCopy, doMove]; - property DragSelection: TNodeArray read FDragSelection; - property LastDragEffect: Integer read FLastDragEffect; - property DragType: TVTDragType read FDragType write FDragType default dtOLE; - property DragWidth: Integer read FDragWidth write FDragWidth default 200; - property DrawSelectionMode: TVTDrawSelectionMode read FDrawSelectionMode write FDrawSelectionMode - default smDottedRectangle; - property EditColumn: TColumnIndex read FEditColumn write FEditColumn; - property EditDelay: Cardinal read FEditDelay write FEditDelay default 1000; - property EffectiveOffsetX: Integer read FEffectiveOffsetX; - property HeaderRect: TRect read FHeaderRect; - property HintMode: TVTHintMode read FHintMode write FHintMode default hmDefault; - property HintData: TVTHintData read FHintData write FHintData; - property HotCursor: TCursor read FHotCursor write FHotCursor default crDefault; - property Images: TCustomImageList read FImages write SetImages; - property IncrementalSearch: TVTIncrementalSearch read FIncrementalSearch write SetSearchOption default isNone; - property IncrementalSearchDirection: TVTSearchDirection read FSearchDirection write FSearchDirection default sdForward; - property IncrementalSearchStart: TVTSearchStart read FSearchStart write FSearchStart default ssFocusedNode; - property IncrementalSearchTimeout: Cardinal read FSearchTimeout write FSearchTimeout default 1000; - property Indent: Cardinal read FIndent write SetIndent default 18; - property LastClickPos: TPoint read FLastClickPos write FLastClickPos; - property LastDropMode: TDropMode read FLastDropMode write FLastDropMode; - property LastHintRect: TRect read FLastHintRect write FLastHintRect; - property LineMode: TVTLineMode read FLineMode write SetLineMode default lmNormal; - property LineStyle: TVTLineStyle read FLineStyle write SetLineStyle default lsDotted; - property Margin: Integer read FMargin write SetMargin default 4; - property NextNodeToSelect: PVirtualNode read FNextNodeToSelect; // Next tree node that we would like to select if the current one gets deleted - property NodeAlignment: TVTNodeAlignment read FNodeAlignment write SetNodeAlignment default naProportional; - property NodeDataSize: Integer read FNodeDataSize write SetNodeDataSize default -1; - property OperationCanceled: Boolean read GetOperationCanceled; - property HotMinusBM: TBitmap read FHotMinusBM; - property HotPlusBM: TBitmap read FHotPlusBM; - property MinusBM: TBitmap read FMinusBM; - property PlusBM: TBitmap read FPlusBM; - property RangeX: Cardinal read GetRangeX;// Returns the width of the virtual tree in pixels, (not ClientWidth). If there are columns it returns the total width of all of them; otherwise it returns the maximum of the all the line's data widths. - property RangeY: Cardinal read FRangeY; - property RootNodeCount: Cardinal read GetRootNodeCount write SetRootNodeCount default 0; - property ScrollBarOptions: TScrollBarOptions read FScrollBarOptions write SetScrollBarOptions; - property SelectionBlendFactor: Byte read FSelectionBlendFactor write FSelectionBlendFactor default 128; - property SelectionCurveRadius: Cardinal read FSelectionCurveRadius write SetSelectionCurveRadius default 0; - property StateImages: TCustomImageList read FStateImages write SetStateImages; - property TextMargin: Integer read FTextMargin write SetTextMargin default 4; - property TreeOptions: TCustomVirtualTreeOptions read FOptions write SetOptions; - property WantTabs: Boolean read FWantTabs write FWantTabs default False; - property SyncCheckstateWithSelection[Node: PVirtualNode]: Boolean read GetSyncCheckstateWithSelection; - - property OnAddToSelection: TVTAddToSelectionEvent read FOnAddToSelection write FOnAddToSelection; - property OnAdvancedHeaderDraw: TVTAdvancedHeaderPaintEvent read FOnAdvancedHeaderDraw write FOnAdvancedHeaderDraw; - property OnAfterAutoFitColumn: TVTAfterAutoFitColumnEvent read FOnAfterAutoFitColumn write FOnAfterAutoFitColumn; - property OnAfterAutoFitColumns: TVTAfterAutoFitColumnsEvent read FOnAfterAutoFitColumns write FOnAfterAutoFitColumns; - property OnAfterCellPaint: TVTAfterCellPaintEvent read FOnAfterCellPaint write FOnAfterCellPaint; - property OnAfterColumnExport : TVTColumnExportEvent read FOnAfterColumnExport write FOnAfterColumnExport; - property OnAfterColumnWidthTracking: TVTAfterColumnWidthTrackingEvent read FOnAfterColumnWidthTracking write FOnAfterColumnWidthTracking; - property OnAfterGetMaxColumnWidth: TVTAfterGetMaxColumnWidthEvent read FOnAfterGetMaxColumnWidth write FOnAfterGetMaxColumnWidth; - property OnAfterHeaderExport: TVTTreeExportEvent read FOnAfterHeaderExport write FOnAfterHeaderExport; - property OnAfterHeaderHeightTracking: TVTAfterHeaderHeightTrackingEvent read FOnAfterHeaderHeightTracking - write FOnAfterHeaderHeightTracking; - property OnAfterItemErase: TVTAfterItemEraseEvent read FOnAfterItemErase write FOnAfterItemErase; - property OnAfterItemPaint: TVTAfterItemPaintEvent read FOnAfterItemPaint write FOnAfterItemPaint; - property OnAfterNodeExport: TVTNodeExportEvent read FOnAfterNodeExport write FOnAfterNodeExport; - property OnAfterPaint: TVTPaintEvent read FOnAfterPaint write FOnAfterPaint; - property OnAfterTreeExport: TVTTreeExportEvent read FOnAfterTreeExport write FOnAfterTreeExport; - property OnBeforeAutoFitColumn: TVTBeforeAutoFitColumnEvent read FOnBeforeAutoFitColumn write FOnBeforeAutoFitColumn; - property OnBeforeAutoFitColumns: TVTBeforeAutoFitColumnsEvent read FOnBeforeAutoFitColumns write FOnBeforeAutoFitColumns; - property OnBeforeCellPaint: TVTBeforeCellPaintEvent read FOnBeforeCellPaint write FOnBeforeCellPaint; - property OnBeforeColumnExport: TVTColumnExportEvent read FOnBeforeColumnExport write FOnBeforeColumnExport; - property OnBeforeColumnWidthTracking: TVTBeforeColumnWidthTrackingEvent read FOnBeforeColumnWidthTracking - write FOnBeforeColumnWidthTracking; - property OnBeforeDrawTreeLine: TVTBeforeDrawLineImageEvent read FOnBeforeDrawLineImage write FOnBeforeDrawLineImage; - property OnBeforeGetMaxColumnWidth: TVTBeforeGetMaxColumnWidthEvent read FOnBeforeGetMaxColumnWidth write FOnBeforeGetMaxColumnWidth; - property OnBeforeHeaderExport: TVTTreeExportEvent read FOnBeforeHeaderExport write FOnBeforeHeaderExport; - property OnBeforeHeaderHeightTracking: TVTBeforeHeaderHeightTrackingEvent read FOnBeforeHeaderHeightTracking - write FOnBeforeHeaderHeightTracking; - property OnBeforeItemErase: TVTBeforeItemEraseEvent read FOnBeforeItemErase write FOnBeforeItemErase; - property OnBeforeItemPaint: TVTBeforeItemPaintEvent read FOnBeforeItemPaint write FOnBeforeItemPaint; - property OnBeforeNodeExport: TVTNodeExportEvent read FOnBeforeNodeExport write FOnBeforeNodeExport; - property OnBeforePaint: TVTPaintEvent read FOnBeforePaint write FOnBeforePaint; - property OnBeforeTreeExport: TVTTreeExportEvent read FOnBeforeTreeExport write FOnBeforeTreeExport; - property OnCanSplitterResizeColumn: TVTCanSplitterResizeColumnEvent read FOnCanSplitterResizeColumn write FOnCanSplitterResizeColumn; - property OnCanSplitterResizeHeader: TVTCanSplitterResizeHeaderEvent read FOnCanSplitterResizeHeader write FOnCanSplitterResizeHeader; - property OnCanSplitterResizeNode: TVTCanSplitterResizeNodeEvent read FOnCanSplitterResizeNode write FOnCanSplitterResizeNode; - property OnChange: TVTChangeEvent read FOnChange write FOnChange; - property OnChecked: TVTChangeEvent read FOnChecked write FOnChecked; - property OnChecking: TVTCheckChangingEvent read FOnChecking write FOnChecking; - property OnCollapsed: TVTChangeEvent read FOnCollapsed write FOnCollapsed; - property OnCollapsing: TVTChangingEvent read FOnCollapsing write FOnCollapsing; - property OnColumnClick: TVTColumnClickEvent read FOnColumnClick write FOnColumnClick; - property OnColumnDblClick: TVTColumnDblClickEvent read FOnColumnDblClick write FOnColumnDblClick; - property OnColumnExport : TVTColumnExportEvent read FOnColumnExport write FOnColumnExport; - property OnColumnResize: TVTHeaderNotifyEvent read FOnColumnResize write FOnColumnResize; - property OnColumnVisibilityChanged: TColumnChangeEvent read fOnColumnVisibilityChanged write fOnColumnVisibilityChanged; - property OnColumnWidthDblClickResize: TVTColumnWidthDblClickResizeEvent read FOnColumnWidthDblClickResize - write FOnColumnWidthDblClickResize; - property OnColumnWidthTracking: TVTColumnWidthTrackingEvent read FOnColumnWidthTracking write FOnColumnWidthTracking; - property OnCompareNodes: TVTCompareEvent read FOnCompareNodes write FOnCompareNodes; - property OnCreateDataObject: TVTCreateDataObjectEvent read FOnCreateDataObject write FOnCreateDataObject; - property OnCreateDragManager: TVTCreateDragManagerEvent read FOnCreateDragManager write FOnCreateDragManager; - property OnCreateEditor: TVTCreateEditorEvent read FOnCreateEditor write FOnCreateEditor; - property OnDragAllowed: TVTDragAllowedEvent read FOnDragAllowed write FOnDragAllowed; - property OnDragOver: TVTDragOverEvent read FOnDragOver write FOnDragOver; - property OnDragDrop: TVTDragDropEvent read FOnDragDrop write FOnDragDrop; - property OnDrawHint: TVTDrawHintEvent read FOnDrawHint write FOnDrawHint; - property OnEditCancelled: TVTEditCancelEvent read FOnEditCancelled write FOnEditCancelled; - property OnEditing: TVTEditChangingEvent read FOnEditing write FOnEditing; - property OnEdited: TVTEditChangeEvent read FOnEdited write FOnEdited; - property OnEndOperation: TVTOperationEvent read FOnEndOperation write FOnEndOperation; - property OnExpanded: TVTChangeEvent read FOnExpanded write FOnExpanded; - property OnExpanding: TVTChangingEvent read FOnExpanding write FOnExpanding; - property OnFocusChanged: TVTFocusChangeEvent read FOnFocusChanged write FOnFocusChanged; - property OnFocusChanging: TVTFocusChangingEvent read FOnFocusChanging write FOnFocusChanging; - property OnFreeNode: TVTFreeNodeEvent read FOnFreeNode write FOnFreeNode; - property OnGetCellIsEmpty: TVTGetCellIsEmptyEvent read FOnGetCellIsEmpty write FOnGetCellIsEmpty; - property OnGetCursor: TVTGetCursorEvent read FOnGetCursor write FOnGetCursor; - property OnGetHeaderCursor: TVTGetHeaderCursorEvent read FOnGetHeaderCursor write FOnGetHeaderCursor; - property OnGetHelpContext: TVTHelpContextEvent read FOnGetHelpContext write FOnGetHelpContext; - property OnGetHintSize: TVTGetHintSizeEvent read FOnGetHintSize write - FOnGetHintSize; - property OnGetHintKind: TVTHintKindEvent read FOnGetHintKind write - FOnGetHintKind; - property OnGetImageIndex: TVTGetImageEvent read FOnGetImage write FOnGetImage; - property OnGetImageIndexEx: TVTGetImageExEvent read FOnGetImageEx write FOnGetImageEx; - property OnGetImageText: TVTGetImageTextEvent read FOnGetImageText write FOnGetImageText; - property OnGetLineStyle: TVTGetLineStyleEvent read FOnGetLineStyle write FOnGetLineStyle; - property OnGetNodeDataSize: TVTGetNodeDataSizeEvent read FOnGetNodeDataSize write FOnGetNodeDataSize; - property OnGetPopupMenu: TVTPopupEvent read FOnGetPopupMenu write FOnGetPopupMenu; - property OnGetUserClipboardFormats: TVTGetUserClipboardFormatsEvent read FOnGetUserClipboardFormats - write FOnGetUserClipboardFormats; - property OnHeaderAddPopupItem: TVTHeaderAddPopupItemEvent read FOnHeaderAddPopupItem write FOnHeaderAddPopupItem; - property OnHeaderClick: TVTHeaderClickEvent read FOnHeaderClick write FOnHeaderClick; - property OnHeaderDblClick: TVTHeaderClickEvent read FOnHeaderDblClick write FOnHeaderDblClick; - property OnHeaderDragged: TVTHeaderDraggedEvent read FOnHeaderDragged write FOnHeaderDragged; - property OnHeaderDraggedOut: TVTHeaderDraggedOutEvent read FOnHeaderDraggedOut write FOnHeaderDraggedOut; - property OnHeaderDragging: TVTHeaderDraggingEvent read FOnHeaderDragging write FOnHeaderDragging; - property OnHeaderDraw: TVTHeaderPaintEvent read FOnHeaderDraw write FOnHeaderDraw; - property OnHeaderDrawQueryElements: TVTHeaderPaintQueryElementsEvent read FOnHeaderDrawQueryElements - write FOnHeaderDrawQueryElements; - property OnHeaderHeightTracking: TVTHeaderHeightTrackingEvent read FOnHeaderHeightTracking - write FOnHeaderHeightTracking; - property OnHeaderHeightDblClickResize: TVTHeaderHeightDblClickResizeEvent read FOnHeaderHeightDblClickResize - write FOnHeaderHeightDblClickResize; - property OnHeaderMouseDown: TVTHeaderMouseEvent read FOnHeaderMouseDown write FOnHeaderMouseDown; - property OnHeaderMouseMove: TVTHeaderMouseMoveEvent read FOnHeaderMouseMove write FOnHeaderMouseMove; - property OnHeaderMouseUp: TVTHeaderMouseEvent read FOnHeaderMouseUp write FOnHeaderMouseUp; - property OnHotChange: TVTHotNodeChangeEvent read FOnHotChange write FOnHotChange; - property OnIncrementalSearch: TVTIncrementalSearchEvent read FOnIncrementalSearch write FOnIncrementalSearch; - property OnInitChildren: TVTInitChildrenEvent read FOnInitChildren write FOnInitChildren; - property OnInitNode: TVTInitNodeEvent read FOnInitNode write FOnInitNode; - property OnKeyAction: TVTKeyActionEvent read FOnKeyAction write FOnKeyAction; - property OnLoadNode: TVTSaveNodeEvent read FOnLoadNode write FOnLoadNode; - property OnLoadTree: TVTSaveTreeEvent read FOnLoadTree write FOnLoadTree; - property OnMeasureItem: TVTMeasureItemEvent read FOnMeasureItem write FOnMeasureItem; - property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter; - property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave; - property OnNodeClick: TVTNodeClickEvent read FOnNodeClick write FOnNodeClick; - property OnNodeCopied: TVTNodeCopiedEvent read FOnNodeCopied write FOnNodeCopied; - property OnNodeCopying: TVTNodeCopyingEvent read FOnNodeCopying write FOnNodeCopying; - property OnNodeDblClick: TVTNodeClickEvent read FOnNodeDblClick write FOnNodeDblClick; - property OnNodeExport: TVTNodeExportEvent read FOnNodeExport write FOnNodeExport; - property OnNodeHeightTracking: TVTNodeHeightTrackingEvent read FOnNodeHeightTracking write FOnNodeHeightTracking; - property OnNodeHeightDblClickResize: TVTNodeHeightDblClickResizeEvent read FOnNodeHeightDblClickResize - write FOnNodeHeightDblClickResize; - property OnNodeMoved: TVTNodeMovedEvent read FOnNodeMoved write FOnNodeMoved; - property OnNodeMoving: TVTNodeMovingEvent read FOnNodeMoving write FOnNodeMoving; - property OnPaintBackground: TVTBackgroundPaintEvent read FOnPaintBackground write FOnPaintBackground; - property OnPrepareButtonBitmaps : TVTPrepareButtonImagesEvent read FOnPrepareButtonImages write FOnPrepareButtonImages; - property OnRemoveFromSelection: TVTRemoveFromSelectionEvent read FOnRemoveFromSelection write FOnRemoveFromSelection; - property OnRenderOLEData: TVTRenderOLEDataEvent read FOnRenderOLEData write FOnRenderOLEData; - property OnResetNode: TVTChangeEvent read FOnResetNode write FOnResetNode; - property OnSaveNode: TVTSaveNodeEvent read FOnSaveNode write FOnSaveNode; - property OnSaveTree: TVTSaveTreeEvent read FOnSaveTree write FOnSaveTree; - property OnScroll: TVTScrollEvent read FOnScroll write FOnScroll; - property OnShowScrollBar: TVTScrollBarShowEvent read FOnShowScrollBar write FOnShowScrollBar; - property OnBeforeGetCheckState: TVTBeforeGetCheckStateEvent read FOnBeforeGetCheckState write FOnBeforeGetCheckState; - property OnStartOperation: TVTOperationEvent read FOnStartOperation write FOnStartOperation; - property OnStateChange: TVTStateChangeEvent read FOnStateChange write FOnStateChange; - property OnStructureChange: TVTStructureChangeEvent read FOnStructureChange write FOnStructureChange; - property OnUpdating: TVTUpdatingEvent read FOnUpdating write FOnUpdating; - public - constructor Create(AOwner: TComponent); override; - destructor Destroy; override; - function AbsoluteIndex(Node: PVirtualNode): Cardinal; - function AddChild(Parent: PVirtualNode; UserData: Pointer = nil): PVirtualNode; overload; virtual; - function AddChild(Parent: PVirtualNode; const UserData: IInterface): PVirtualNode; overload; - function AddChild(Parent: PVirtualNode; const UserData: TObject): PVirtualNode; overload; - procedure AddFromStream(Stream: TStream; TargetNode: PVirtualNode); - procedure AfterConstruction; override; - procedure Assign(Source: TPersistent); override; - procedure BeginDrag(Immediate: Boolean; Threshold: Integer = -1); - procedure BeginSynch; - procedure BeginUpdate; virtual; - procedure CancelCutOrCopy; - function CancelEditNode: Boolean; - procedure CancelOperation; - function CanEdit(Node: PVirtualNode; Column: TColumnIndex): Boolean; virtual; - function CanFocus: Boolean; override; - procedure Clear; virtual; - procedure ClearChecked; - procedure ClearSelection(); overload; inline; - function CopyTo(Source: PVirtualNode; Tree: TBaseVirtualTree; Mode: TVTNodeAttachMode; - ChildrenOnly: Boolean): PVirtualNode; overload; - function CopyTo(Source, Target: PVirtualNode; Mode: TVTNodeAttachMode; - ChildrenOnly: Boolean): PVirtualNode; overload; - procedure CopyToClipboard; virtual; - procedure CutToClipboard; virtual; - procedure DeleteChildren(Node: PVirtualNode; ResetHasChildren: Boolean = False); - procedure DeleteNode(Node: PVirtualNode; pReIndex: Boolean = True); overload; inline; - procedure DeleteNodes(const pNodes: TNodeArray); - procedure DeleteSelectedNodes; virtual; - function Dragging: Boolean; - function EditNode(Node: PVirtualNode; Column: TColumnIndex): Boolean; virtual; - function EndEditNode: Boolean; - procedure EndSynch; - procedure EndUpdate; virtual; - procedure EnsureNodeSelected(); virtual; - function ExecuteAction(Action: TBasicAction): Boolean; override; - procedure FinishCutOrCopy; - procedure FlushClipboard; - procedure FullCollapse(Node: PVirtualNode = nil); virtual; - procedure FullExpand(Node: PVirtualNode = nil); virtual; - function GetControlsAlignment: TAlignment; override; - function GetDisplayRect(Node: PVirtualNode; Column: TColumnIndex; TextOnly: Boolean; Unclipped: Boolean = False; - ApplyCellContentMargin: Boolean = False): TRect; - function GetEffectivelyFiltered(Node: PVirtualNode): Boolean; - function GetEffectivelyVisible(Node: PVirtualNode): Boolean; - function GetFirst(ConsiderChildrenAbove: Boolean = False): PVirtualNode; - function GetFirstChecked(State: TCheckState = csCheckedNormal; ConsiderChildrenAbove: Boolean = False): PVirtualNode; - function GetFirstChild(Node: PVirtualNode): PVirtualNode; - function GetFirstChildNoInit(Node: PVirtualNode): PVirtualNode; - function GetFirstCutCopy(ConsiderChildrenAbove: Boolean = False): PVirtualNode; - function GetFirstInitialized(ConsiderChildrenAbove: Boolean = False): PVirtualNode; - function GetFirstLeaf: PVirtualNode; - function GetFirstLevel(NodeLevel: Cardinal): PVirtualNode; - function GetFirstNoInit(ConsiderChildrenAbove: Boolean = False): PVirtualNode; - function GetFirstSelected(ConsiderChildrenAbove: Boolean = False): PVirtualNode; - function GetFirstVisible(Node: PVirtualNode = nil; ConsiderChildrenAbove: Boolean = True; - IncludeFiltered: Boolean = False): PVirtualNode; - function GetFirstVisibleChild(Node: PVirtualNode; IncludeFiltered: Boolean = False): PVirtualNode; - function GetFirstVisibleChildNoInit(Node: PVirtualNode; IncludeFiltered: Boolean = False): PVirtualNode; - function GetFirstVisibleNoInit(Node: PVirtualNode = nil; ConsiderChildrenAbove: Boolean = True; - IncludeFiltered: Boolean = False): PVirtualNode; - procedure GetHitTestInfoAt(X, Y: Integer; Relative: Boolean; var HitInfo: THitInfo); virtual; - function GetLast(Node: PVirtualNode = nil; ConsiderChildrenAbove: Boolean = False): PVirtualNode; - function GetLastInitialized(Node: PVirtualNode = nil; ConsiderChildrenAbove: Boolean = False): PVirtualNode; - function GetLastNoInit(Node: PVirtualNode = nil; ConsiderChildrenAbove: Boolean = False): PVirtualNode; - function GetLastChild(Node: PVirtualNode): PVirtualNode; - function GetLastChildNoInit(Node: PVirtualNode): PVirtualNode; - function GetLastVisible(Node: PVirtualNode = nil; ConsiderChildrenAbove: Boolean = True; - IncludeFiltered: Boolean = False): PVirtualNode; - function GetLastVisibleChild(Node: PVirtualNode; IncludeFiltered: Boolean = False): PVirtualNode; - function GetLastVisibleChildNoInit(Node: PVirtualNode; IncludeFiltered: Boolean = False): PVirtualNode; - function GetLastVisibleNoInit(Node: PVirtualNode = nil; ConsiderChildrenAbove: Boolean = True; - IncludeFiltered: Boolean = False): PVirtualNode; - function GetMaxColumnWidth(Column: TColumnIndex; UseSmartColumnWidth: Boolean = False): Integer; virtual; - function GetNext(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode; - function GetNextChecked(Node: PVirtualNode; State: TCheckState = csCheckedNormal; - ConsiderChildrenAbove: Boolean = False): PVirtualNode; overload; - function GetNextChecked(Node: PVirtualNode; ConsiderChildrenAbove: Boolean): PVirtualNode; overload; - function GetNextCutCopy(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode; - function GetNextInitialized(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode; - function GetNextLeaf(Node: PVirtualNode): PVirtualNode; - function GetNextLevel(Node: PVirtualNode; NodeLevel: Cardinal): PVirtualNode; - function GetNextNoInit(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode; - function GetNextSelected(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode; - function GetNextSibling(Node: PVirtualNode): PVirtualNode; - function GetNextSiblingNoInit(Node: PVirtualNode): PVirtualNode; - function GetNextVisible(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = True): PVirtualNode; - function GetNextVisibleNoInit(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = True): PVirtualNode; - function GetNextVisibleSibling(Node: PVirtualNode; IncludeFiltered: Boolean = False): PVirtualNode; - function GetNextVisibleSiblingNoInit(Node: PVirtualNode; IncludeFiltered: Boolean = False): PVirtualNode; - function GetNodeAt(const P: TPoint): PVirtualNode; overload; inline; - function GetNodeAt(X, Y: Integer): PVirtualNode; overload; - function GetNodeAt(X, Y: Integer; Relative: Boolean; var NodeTop: Integer): PVirtualNode; overload; - function GetNodeData(Node: PVirtualNode): Pointer; overload; - function GetNodeData(pNode: PVirtualNode): T; overload; inline; - function GetSelectedData(): TArray; overload; - function GetInterfaceFromNodeData(pNode: PVirtualNode): T; overload; inline; - function GetNodeDataAt(pXCoord: Integer; pYCoord: Integer): T; - function GetFirstSelectedNodeData(): T; - function GetNodeLevel(Node: PVirtualNode): Cardinal; - function GetNodeLevelForSelectConstraint(Node: PVirtualNode): integer; - function GetOffset(pElement: TVTElement; pNode: PVirtualNode): integer; - procedure GetOffsets(pNode: PVirtualNode; out pOffsets: TVTOffsets; pElement: TVTElement = TVTElement.ofsEndOfClientArea; pColumn: Integer = NoColumn); - function GetPrevious(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode; - function GetPreviousChecked(Node: PVirtualNode; State: TCheckState = csCheckedNormal; - ConsiderChildrenAbove: Boolean = False): PVirtualNode; - function GetPreviousCutCopy(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode; - function GetPreviousInitialized(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode; - function GetPreviousLeaf(Node: PVirtualNode): PVirtualNode; - function GetPreviousLevel(Node: PVirtualNode; NodeLevel: Cardinal): PVirtualNode; - function GetPreviousNoInit(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode; - function GetPreviousSelected(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode; - function GetPreviousSibling(Node: PVirtualNode): PVirtualNode; - function GetPreviousSiblingNoInit(Node: PVirtualNode): PVirtualNode; - function GetPreviousVisible(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = True): PVirtualNode; - function GetPreviousVisibleNoInit(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = True): PVirtualNode; - function GetPreviousVisibleSibling(Node: PVirtualNode; IncludeFiltered: Boolean = False): PVirtualNode; - function GetPreviousVisibleSiblingNoInit(Node: PVirtualNode; IncludeFiltered: Boolean = False): PVirtualNode; - function GetSortedCutCopySet(Resolve: Boolean): TNodeArray; - function GetSortedSelection(Resolve: Boolean): TNodeArray; - procedure GetTextInfo(Node: PVirtualNode; Column: TColumnIndex; const AFont: TFont; var R: TRect; - var Text: string); virtual; - function GetTreeRect: TRect; - function GetVisibleParent(Node: PVirtualNode; IncludeFiltered: Boolean = False): PVirtualNode; - function HasAsParent(Node, PotentialParent: PVirtualNode): Boolean; - function InsertNode(Node: PVirtualNode; Mode: TVTNodeAttachMode; UserData: Pointer = nil): PVirtualNode; - procedure InvalidateChildren(Node: PVirtualNode; Recursive: Boolean); - procedure InvalidateColumn(Column: TColumnIndex); - function InvalidateNode(Node: PVirtualNode): TRect; virtual; - procedure InvalidateToBottom(Node: PVirtualNode); - procedure InvertSelection(VisibleOnly: Boolean); - function IsEditing: Boolean; - function IsMouseSelecting: Boolean; - function IsEmpty: Boolean; inline; - function IterateSubtree(Node: PVirtualNode; Callback: TVTGetNodeProc; Data: Pointer; Filter: TVirtualNodeStates = []; - DoInit: Boolean = False; ChildNodesOnly: Boolean = False): PVirtualNode; - procedure LoadFromFile(const FileName: TFileName); virtual; - procedure LoadFromStream(Stream: TStream); virtual; - procedure MeasureItemHeight(const Canvas: TCanvas; Node: PVirtualNode); virtual; - procedure MoveTo(Source, Target: PVirtualNode; Mode: TVTNodeAttachMode; ChildrenOnly: Boolean); overload; - procedure MoveTo(Node: PVirtualNode; Tree: TBaseVirtualTree; Mode: TVTNodeAttachMode; - ChildrenOnly: Boolean); overload; - procedure PaintTree(TargetCanvas: TCanvas; Window: TRect; Target: TPoint; PaintOptions: TVTInternalPaintOptions; - PixelFormat: TPixelFormat = pfDevice); virtual; - function PasteFromClipboard: Boolean; virtual; - procedure PrepareDragImage(HotSpot: TPoint; const DataObject: IDataObject); - procedure Print(Printer: TPrinter; PrintHeader: Boolean); - function ProcessDrop(const DataObject: IDataObject; TargetNode: PVirtualNode; var Effect: Integer; Mode: - TVTNodeAttachMode): Boolean; - function ProcessOLEData(Source: TBaseVirtualTree; const DataObject: IDataObject; TargetNode: PVirtualNode; - Mode: TVTNodeAttachMode; Optimized: Boolean): Boolean; - procedure RepaintNode(Node: PVirtualNode); - procedure ReinitChildren(Node: PVirtualNode; Recursive: Boolean); virtual; - procedure InitRecursive(Node: PVirtualNode; Levels: Cardinal = MaxInt; pVisibleOnly: Boolean = True); - procedure ReinitNode(Node: PVirtualNode; Recursive: Boolean); virtual; - procedure ResetNode(Node: PVirtualNode); virtual; - procedure SaveToFile(const FileName: TFileName); - procedure SaveToStream(Stream: TStream; Node: PVirtualNode = nil); virtual; - function ScaledPixels(pPixels: Integer): Integer; - function ScrollIntoView(Node: PVirtualNode; Center: Boolean; Horizontally: Boolean = False): Boolean; overload; - function ScrollIntoView(Column: TColumnIndex; Center: Boolean; Node: PVirtualNode = nil): Boolean; overload; - procedure SelectAll(VisibleOnly: Boolean); - procedure SetCheckStateForAll(aCheckState: TCheckState; pSelectedOnly: Boolean; pExcludeDisabled: Boolean = True); - procedure SetNodeData(pNode: PVirtualNode; pUserData: Pointer); overload; inline; - procedure SetNodeData(pNode: PVirtualNode; const pUserData: IInterface); overload; inline; - procedure SetNodeData(pNode: PVirtualNode; pUserData: T); overload; - procedure Sort(Node: PVirtualNode; Column: TColumnIndex; Direction: TSortDirection; DoInit: Boolean = True); virtual; - procedure SortTree(Column: TColumnIndex; Direction: TSortDirection; DoInit: Boolean = True); virtual; - procedure ToggleNode(Node: PVirtualNode); - procedure UpdateHorizontalRange; virtual; - procedure UpdateHorizontalScrollBar(DoRepaint: Boolean); - procedure UpdateRanges; - procedure UpdateScrollBars(DoRepaint: Boolean); virtual; - procedure UpdateVerticalRange; - procedure UpdateVerticalScrollBar(DoRepaint: Boolean); - function UseRightToLeftReading: Boolean; - procedure ValidateChildren(Node: PVirtualNode; Recursive: Boolean); - procedure ValidateNode(Node: PVirtualNode; Recursive: Boolean); - - { Enumerations } - function Nodes(ConsiderChildrenAbove: Boolean = False): TVTVirtualNodeEnumeration; - function CheckedNodes(State: TCheckState = csCheckedNormal; ConsiderChildrenAbove: Boolean = False): TVTVirtualNodeEnumeration; - function ChildNodes(Node: PVirtualNode): TVTVirtualNodeEnumeration; - function CutCopyNodes(ConsiderChildrenAbove: Boolean = False): TVTVirtualNodeEnumeration; - function InitializedNodes(ConsiderChildrenAbove: Boolean = False): TVTVirtualNodeEnumeration; - function LeafNodes: TVTVirtualNodeEnumeration; - function LevelNodes(NodeLevel: Cardinal): TVTVirtualNodeEnumeration; - function NoInitNodes(ConsiderChildrenAbove: Boolean = False): TVTVirtualNodeEnumeration; - function SelectedNodes(ConsiderChildrenAbove: Boolean = False): TVTVirtualNodeEnumeration; - function VisibleNodes(Node: PVirtualNode = nil; ConsiderChildrenAbove: Boolean = True; - IncludeFiltered: Boolean = False): TVTVirtualNodeEnumeration; - function VisibleChildNodes(Node: PVirtualNode; IncludeFiltered: Boolean = False): TVTVirtualNodeEnumeration; - function VisibleChildNoInitNodes(Node: PVirtualNode; IncludeFiltered: Boolean = False): TVTVirtualNodeEnumeration; - function VisibleNoInitNodes(Node: PVirtualNode = nil; ConsiderChildrenAbove: Boolean = True; - IncludeFiltered: Boolean = False): TVTVirtualNodeEnumeration; - property Accessible: IAccessible read FAccessible write FAccessible; - property AccessibleItem: IAccessible read FAccessibleItem write FAccessibleItem; - property AccessibleName: string read FAccessibleName write FAccessibleName; - property BottomNode: PVirtualNode read GetBottomNode write SetBottomNode; - property CheckedCount: Integer read GetCheckedCount; - property CheckImages: TCustomImageList read FCheckImages; - property CheckState[Node: PVirtualNode]: TCheckState read GetCheckState write SetCheckState; - property CheckType[Node: PVirtualNode]: TCheckType read GetCheckType write SetCheckType; - property ChildCount[Node: PVirtualNode]: Cardinal read GetChildCount write SetChildCount; - property ChildrenInitialized[Node: PVirtualNode]: Boolean read GetChildrenInitialized; - property CutCopyCount: Integer read GetCutCopyCount; - property DragImage: TVTDragImage read FDragImage; - property DragManager: IVTDragManager read GetDragManager; - property DropTargetNode: PVirtualNode read FDropTargetNode write FDropTargetNode; - property EditLink: IVTEditLink read FEditLink; - property EmptyListMessage: string read FEmptyListMessage write SetEmptyListMessage; - property Expanded[Node: PVirtualNode]: Boolean read GetExpanded write SetExpanded; - property FocusedColumn: TColumnIndex read FFocusedColumn write SetFocusedColumn default InvalidColumn; - property FocusedNode: PVirtualNode read FFocusedNode write SetFocusedNode; - property Font; - property FullyVisible[Node: PVirtualNode]: Boolean read GetFullyVisible write SetFullyVisible; - property HasChildren[Node: PVirtualNode]: Boolean read GetHasChildren write SetHasChildren; - property Header: TVTHeader read FHeader write SetHeader; - property HotNode: PVirtualNode read FCurrentHotNode write SetHotNode; - property IsDisabled[Node: PVirtualNode]: Boolean read GetDisabled write SetDisabled; - property IsEffectivelyFiltered[Node: PVirtualNode]: Boolean read GetEffectivelyFiltered; - property IsEffectivelyVisible[Node: PVirtualNode]: Boolean read GetEffectivelyVisible; - property IsFiltered[Node: PVirtualNode]: Boolean read GetFiltered write SetFiltered; - property IsVisible[Node: PVirtualNode]: Boolean read GetVisible write SetVisible; - property MultiLine[Node: PVirtualNode]: Boolean read GetMultiline write SetMultiline; - property NodeHeight[Node: PVirtualNode]: Cardinal read GetNodeHeight write SetNodeHeight; - property NodeParent[Node: PVirtualNode]: PVirtualNode read GetNodeParent write SetNodeParent; - property OffsetX: Integer read FOffsetX write SetOffsetX; - property OffsetXY: TPoint read GetOffsetXY write SetOffsetXY; - property OffsetY: Integer read FOffsetY write SetOffsetY; - property OperationCount: Cardinal read FOperationCount; - property RootNode: PVirtualNode read FRoot; - property SearchBuffer: string read FSearchBuffer; - property Selected[Node: PVirtualNode]: Boolean read GetSelected write SetSelected; - property SelectionLocked: Boolean read FSelectionLocked write FSelectionLocked; - property TotalCount: Cardinal read GetTotalCount; - property TreeStates: TVirtualTreeStates read FStates write FStates; - property SelectedCount: Integer read FSelectionCount; - property TopNode: PVirtualNode read GetTopNode write SetTopNode; - property VerticalAlignment[Node: PVirtualNode]: Byte read GetVerticalAlignment write SetVerticalAlignment; - property VisibleCount: Cardinal read FVisibleCount; - property VisiblePath[Node: PVirtualNode]: Boolean read GetVisiblePath write SetVisiblePath; - property UpdateCount: Cardinal read FUpdateCount; - property DoubleBuffered: Boolean read GetDoubleBuffered write SetDoubleBuffered default True; - end; - - - // --------- TCustomVirtualStringTree - - // Options regarding strings (useful only for the string tree and descendants): - TVTStringOption = ( - toSaveCaptions, // If set then the caption is automatically saved with the tree node, regardless of what is - // saved in the user data. - toShowStaticText, // Show static text in a caption which can be differently formatted than the caption - // but cannot be edited. - toAutoAcceptEditChange // Automatically accept changes during edit if the user finishes editing other then - // VK_RETURN or ESC. If not set then changes are cancelled. - ); - TVTStringOptions = set of TVTStringOption; - -const - DefaultStringOptions = [toSaveCaptions, toAutoAcceptEditChange]; - -type - TCustomStringTreeOptions = class(TCustomVirtualTreeOptions) - private - FStringOptions: TVTStringOptions; - procedure SetStringOptions(const Value: TVTStringOptions); - protected - property StringOptions: TVTStringOptions read FStringOptions write SetStringOptions default DefaultStringOptions; - public - constructor Create(AOwner: TBaseVirtualTree); override; - - procedure AssignTo(Dest: TPersistent); override; - end; - - TStringTreeOptions = class(TCustomStringTreeOptions) - published - property AnimationOptions; - property AutoOptions; - property ExportMode; - property MiscOptions; - property PaintOptions; - property SelectionOptions; - property StringOptions; - property EditOptions; - end; - - TCustomVirtualStringTree = class; - - // Edit support Classes. - TStringEditLink = class; - - TVTEdit = class(TCustomEdit) - private - procedure CMAutoAdjust(var Message: TMessage); message CM_AUTOADJUST; - procedure CMExit(var Message: TMessage); message CM_EXIT; - procedure CMRelease(var Message: TMessage); message CM_RELEASE; - procedure CNCommand(var Message: TWMCommand); message CN_COMMAND; - procedure WMChar(var Message: TWMChar); message WM_CHAR; - procedure WMDestroy(var Message: TWMDestroy); message WM_DESTROY; - procedure WMGetDlgCode(var Message: TWMGetDlgCode); message WM_GETDLGCODE; - procedure WMKeyDown(var Message: TWMKeyDown); message WM_KEYDOWN; - protected - FRefLink: IVTEditLink; - FLink: TStringEditLink; - procedure AutoAdjustSize; virtual; - function CalcMinHeight: Integer; virtual; - procedure CreateParams(var Params: TCreateParams); override; - function GetTextSize: TSize; virtual; - procedure KeyPress(var Key: Char); override; - public - constructor Create(Link: TStringEditLink); reintroduce; - - procedure Release; virtual; - - property AutoSelect; - property AutoSize; + property AccessibleName; + property Action; + property Align; + property Alignment; + property Anchors; + property AnimationDuration; + property AutoExpandDelay; + property AutoScrollDelay; + property AutoScrollInterval; + property Background; + property BackGroundImageTransparent; + property BackgroundOffsetX; + property BackgroundOffsetY; + property BiDiMode; + property BevelEdges; + property BevelInner; + property BevelOuter; + property BevelKind; + property BevelWidth; property BorderStyle; - property CharCase; - property HideSelection; - property MaxLength; - property OEMConvert; - property PasswordChar; - end; - - TStringEditLink = class(TInterfacedObject, IVTEditLink) - private - FEdit: TVTEdit; // A normal custom edit control. - protected - FTree: TCustomVirtualStringTree; // A back reference to the tree calling. - FNode: PVirtualNode; // The node to be edited. - FColumn: TColumnIndex; // The column of the node. - FAlignment: TAlignment; - FTextBounds: TRect; // Smallest rectangle around the text. - FStopping: Boolean; // Set to True when the edit link requests stopping the edit action. - procedure SetEdit(const Value: TVTEdit); // Setter for the FEdit member; - public - constructor Create; virtual; - destructor Destroy; override; - property Node : PVirtualNode read FNode; // [IPK] Make FNode accessible - property Column: TColumnIndex read FColumn; // [IPK] Make Column(Index) accessible - - function BeginEdit: Boolean; virtual; stdcall; - function CancelEdit: Boolean; virtual; stdcall; - property Edit: TVTEdit read FEdit write SetEdit; - function EndEdit: Boolean; virtual; stdcall; - function GetBounds: TRect; virtual; stdcall; - function PrepareEdit(Tree: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex): Boolean; virtual; stdcall; - procedure ProcessMessage(var Message: TMessage); virtual; stdcall; - procedure SetBounds(R: TRect); virtual; stdcall; - end; - - // Describes the type of text to return in the text and draw info retrival events. - TVSTTextType = ( - ttNormal, // normal label of the node, this is also the text which can be edited - ttStatic // static (non-editable) text after the normal text - ); - - // Describes the source to use when converting a string tree into a string for clipboard etc. - TVSTTextSourceType = ( - tstAll, // All nodes are rendered. Initialization is done on the fly. - tstInitialized, // Only initialized nodes are rendered. - tstSelected, // Only selected nodes are rendered. - tstCutCopySet, // Only nodes currently marked as being in the cut/copy clipboard set are rendered. - tstVisible, // Only visible nodes are rendered. - tstChecked // Only checked nodes are rendered - ); - - TVTPaintText = procedure(Sender: TBaseVirtualTree; const TargetCanvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; - TextType: TVSTTextType) of object; - TVSTGetTextEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; - TextType: TVSTTextType; var CellText: string) of object; - TVSTGetHintEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; - var LineBreakStyle: TVTTooltipLineBreakStyle; var HintText: string) of object; - // New text can only be set for variable caption. - TVSTNewTextEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; - NewText: string) of object; - TVSTShortenStringEvent = procedure(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode; - Column: TColumnIndex; const S: string; TextSpace: Integer; var Result: string; - var Done: Boolean) of object; - TVTMeasureTextEvent = procedure(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode; - Column: TColumnIndex; const Text: string; var Extent: Integer) of object; - TVTDrawTextEvent = procedure(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode; - Column: TColumnIndex; const Text: string; const CellRect: TRect; var DefaultDraw: Boolean) of object; - - /// Event arguments of the OnGetCellText event - TVSTGetCellTextEventArgs = record - Node: PVirtualNode; - Column: TColumnIndex; - CellText: string; - StaticText: string; - StaticTextAlignment: TAlignment; - ExportType: TVTExportType; - constructor Create(pNode: PVirtualNode; pColumn: TColumnIndex; pExportType: TVTExportType = TVTExportType.etNone); - end; - - /// Event signature which is called when text is painted on the canvas or needed for the export. - TVSTGetCellTextEvent = procedure(Sender: TCustomVirtualStringTree; var E: TVSTGetCellTextEventArgs) of object; - - TCustomVirtualStringTree = class(TBaseVirtualTree) - private - FInternalDataOffset: Cardinal; // offset to the internal data of the string tree - FDefaultText: string; // text to show if there's no OnGetText event handler (e.g. at design time) - FTextHeight: Integer; // true size of the font - FEllipsisWidth: Integer; // width of '...' for the current font - - FOnPaintText: TVTPaintText; // triggered before either normal or fixed text is painted to allow - // even finer customization (kind of sub cell painting) - FOnGetText: TVSTGetTextEvent; // used to retrieve the string to be displayed for a specific node - fOnGetCellText: TVSTGetCellTextEvent; // used to retrieve the normal and static text of a tree node - FOnGetHint: TVSTGetHintEvent; // used to retrieve the hint to be displayed for a specific node - FOnNewText: TVSTNewTextEvent; // used to notify the application about an edited node caption - FOnShortenString: TVSTShortenStringEvent; // used to allow the application a customized string shortage - FOnMeasureTextWidth: TVTMeasureTextEvent; // used to adjust the width of the cells - FOnMeasureTextHeight: TVTMeasureTextEvent; - FOnDrawText: TVTDrawTextEvent; // used to custom draw the node text - /// Returns True if the property DefaultText has a value that differs from the default value, False otherwise. - function IsDefaultTextStored(): Boolean; - function GetImageText(Node: PVirtualNode; Kind: TVTImageKind; - Column: TColumnIndex): string; - function GetOptions: TCustomStringTreeOptions; - function GetStaticText(Node: PVirtualNode; Column: TColumnIndex): string; - function GetText(Node: PVirtualNode; Column: TColumnIndex): string; - procedure ReadText(Reader: TReader); - procedure WriteText(Writer: TWriter); - procedure ResetInternalData(Node: PVirtualNode; Recursive: Boolean); - procedure SetDefaultText(const Value: string); - procedure SetOptions(const Value: TCustomStringTreeOptions); - procedure SetText(Node: PVirtualNode; Column: TColumnIndex; const Value: string); - procedure WMSetFont(var Msg: TWMSetFont); message WM_SETFONT; - procedure GetDataFromGrid(const AStrings : TStringList; const IncludeHeading : Boolean = True); - protected - FPreviouslySelected: TStringList; - procedure InitializeTextProperties(var PaintInfo: TVTPaintInfo); // [IPK] - private to protected - procedure PaintNormalText(var PaintInfo: TVTPaintInfo; TextOutFlags: Integer; Text: string); virtual; // [IPK] - private to protected - procedure PaintStaticText(const PaintInfo: TVTPaintInfo; pStaticTextAlignment: TAlignment; const Text: string); virtual; // [IPK] - private to protected - procedure AdjustPaintCellRect(var PaintInfo: TVTPaintInfo; var NextNonEmpty: TColumnIndex); override; - function CanExportNode(Node: PVirtualNode): Boolean; - function CalculateStaticTextWidth(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; const Text: string): Integer; virtual; - function CalculateTextWidth(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; const Text: string): Integer; virtual; - function ColumnIsEmpty(Node: PVirtualNode; Column: TColumnIndex): Boolean; override; - procedure DefineProperties(Filer: TFiler); override; - function DoCreateEditor(Node: PVirtualNode; Column: TColumnIndex): IVTEditLink; override; - function DoGetNodeHint(Node: PVirtualNode; Column: TColumnIndex; var LineBreakStyle: TVTTooltipLineBreakStyle): string; override; - function DoGetNodeTooltip(Node: PVirtualNode; Column: TColumnIndex; var LineBreakStyle: TVTTooltipLineBreakStyle): string; override; - function DoGetNodeExtraWidth(Node: PVirtualNode; Column: TColumnIndex; Canvas: TCanvas = nil): Integer; override; - function DoGetNodeWidth(Node: PVirtualNode; Column: TColumnIndex; Canvas: TCanvas = nil): Integer; override; - procedure DoGetText(var pEventArgs: TVSTGetCellTextEventArgs); virtual; - function DoIncrementalSearch(Node: PVirtualNode; const Text: string): Integer; override; - procedure DoNewText(Node: PVirtualNode; Column: TColumnIndex; const Text: string); virtual; - procedure DoPaintNode(var PaintInfo: TVTPaintInfo); override; - procedure DoPaintText(Node: PVirtualNode; const Canvas: TCanvas; Column: TColumnIndex; - TextType: TVSTTextType); virtual; - function DoShortenString(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; const S: string; Width: Integer; - EllipsisWidth: Integer = 0): string; virtual; - procedure DoTextDrawing(var PaintInfo: TVTPaintInfo; const Text: string; CellRect: TRect; DrawFormat: Cardinal); virtual; - function DoTextMeasuring(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; const Text: string): TSize; virtual; - function GetOptionsClass: TTreeOptionsClass; override; - procedure GetRenderStartValues(Source: TVSTTextSourceType; var Node: PVirtualNode; - var NextNodeProc: TGetNextNodeProc); - function InternalData(Node: PVirtualNode): Pointer; - procedure MainColumnChanged; override; - function ReadChunk(Stream: TStream; Version: Integer; Node: PVirtualNode; ChunkType, - ChunkSize: Integer): Boolean; override; - procedure ReadOldStringOptions(Reader: TReader); - function RenderOLEData(const FormatEtcIn: TFormatEtc; out Medium: TStgMedium; ForClipboard: Boolean): HResult; override; - procedure SetChildCount(Node: PVirtualNode; NewChildCount: Cardinal); override; - procedure WriteChunks(Stream: TStream; Node: PVirtualNode); override; - - property DefaultText: string read FDefaultText write SetDefaultText stored False;// Stored via own writer - property EllipsisWidth: Integer read FEllipsisWidth; - property TreeOptions: TCustomStringTreeOptions read GetOptions write SetOptions; - - property OnGetHint: TVSTGetHintEvent read FOnGetHint write FOnGetHint; - property OnGetText: TVSTGetTextEvent read FOnGetText write FOnGetText; - property OnGetCellText: TVSTGetCellTextEvent read fOnGetCellText write fOnGetCellText; - property OnNewText: TVSTNewTextEvent read FOnNewText write FOnNewText; - property OnPaintText: TVTPaintText read FOnPaintText write FOnPaintText; - property OnShortenString: TVSTShortenStringEvent read FOnShortenString write FOnShortenString; - property OnMeasureTextWidth: TVTMeasureTextEvent read FOnMeasureTextWidth write FOnMeasureTextWidth; - property OnMeasureTextHeight: TVTMeasureTextEvent read FOnMeasureTextHeight write FOnMeasureTextHeight; - property OnDrawText: TVTDrawTextEvent read FOnDrawText write FOnDrawText; - public - constructor Create(AOwner: TComponent); override; - destructor Destroy(); override; - function AddChild(Parent: PVirtualNode; UserData: Pointer = nil): PVirtualNode; override; - function ComputeNodeHeight(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; S: string = ''): Integer; virtual; - function ContentToClipboard(Format: Word; Source: TVSTTextSourceType): HGLOBAL; - procedure ContentToCustom(Source: TVSTTextSourceType); - function ContentToHTML(Source: TVSTTextSourceType; const Caption: string = ''): String; - function ContentToRTF(Source: TVSTTextSourceType): RawByteString; - function ContentToText(Source: TVSTTextSourceType; Separator: Char): String; overload; - function ContentToUnicode(Source: TVSTTextSourceType; Separator: WideChar): string; overload; deprecated 'Use ContentToText instead'; - function ContentToText(Source: TVSTTextSourceType; const Separator: string): string; overload; - procedure GetTextInfo(Node: PVirtualNode; Column: TColumnIndex; const AFont: TFont; var R: TRect; - var Text: string); override; - function InvalidateNode(Node: PVirtualNode): TRect; override; - function Path(Node: PVirtualNode; Column: TColumnIndex; Delimiter: Char): string; - procedure ReinitNode(Node: PVirtualNode; Recursive: Boolean); override; - procedure AddToSelection(Node: PVirtualNode; NotifySynced: Boolean); override; - procedure RemoveFromSelection(Node: PVirtualNode); override; - function SaveToCSVFile(const FileNameWithPath : TFileName; const IncludeHeading : Boolean) : Boolean; - /// Alternate text for images used in Accessibility. - property ImageText[Node: PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex]: string read GetImageText; - property StaticText[Node: PVirtualNode; Column: TColumnIndex]: string read GetStaticText; - property Text[Node: PVirtualNode; Column: TColumnIndex]: string read GetText write SetText; - end; - - [ComponentPlatformsAttribute(pidWin32 or pidWin64)] - TVirtualStringTree = class(TCustomVirtualStringTree) - private - - function GetOptions: TStringTreeOptions; - procedure SetOptions(const Value: TStringTreeOptions); - protected - function GetOptionsClass: TTreeOptionsClass; override; - public - - property Canvas; - property RangeX; - property LastDragEffect; - property CheckImageKind; // should no more be published to make #622 fix working - published - property AccessibleName; - property Action; - property Align; - property Alignment; - property Anchors; - property AnimationDuration; - property AutoExpandDelay; - property AutoScrollDelay; - property AutoScrollInterval; - property Background; - property BackGroundImageTransparent; - property BackgroundOffsetX; - property BackgroundOffsetY; - property BiDiMode; - property BevelEdges; - property BevelInner; - property BevelOuter; - property BevelKind; - property BevelWidth; - property BorderStyle; - property BottomSpace; - property ButtonFillMode; - property ButtonStyle; - property BorderWidth; - property ChangeDelay; - property ClipboardFormats; - property Color; - property Colors; - property Constraints; - property Ctl3D; - property CustomCheckImages; - property DefaultNodeHeight; - property DefaultPasteMode; - property DefaultText; - property DragCursor; - property DragHeight; - property DragKind; - property DragImageKind; - property DragMode; - property DragOperations; - property DragType; - property DragWidth; - property DrawSelectionMode; - property EditDelay; - property EmptyListMessage; - property Enabled; - property Font; - property Header; - property HintMode; - property HotCursor; - property Images; - property IncrementalSearch; - property IncrementalSearchDirection; - property IncrementalSearchStart; - property IncrementalSearchTimeout; - property Indent; - property LineMode; - property LineStyle; - property Margin; - property NodeAlignment; - property NodeDataSize; - property OperationCanceled; - property ParentBiDiMode; - property ParentColor default False; - property ParentCtl3D; - property ParentFont; - property ParentShowHint; - property PopupMenu; - property RootNodeCount; - property ScrollBarOptions; - property SelectionBlendFactor; - property SelectionCurveRadius; - property ShowHint; - property StateImages; - property StyleElements; - property TabOrder; - property TabStop default True; - property TextMargin; - property TreeOptions: TStringTreeOptions read GetOptions write SetOptions; - property Visible; - property WantTabs; + property BottomSpace; + property ButtonFillMode; + property ButtonStyle; + property BorderWidth; + property ChangeDelay; + property ClipboardFormats; + property Color; + property Colors; + property Constraints; + property Ctl3D; + property CustomCheckImages; + property DefaultNodeHeight; + property DefaultPasteMode; + property DefaultText; + property DragCursor; + property DragHeight; + property DragKind; + property DragImageKind; + property DragMode; + property DragOperations; + property DragType; + property DragWidth; + property DrawSelectionMode; + property EditDelay; + property EmptyListMessage; + property Enabled; + property Font; + property Header; + property HintMode; + property HotCursor; + property Images; + property IncrementalSearch; + property IncrementalSearchDirection; + property IncrementalSearchStart; + property IncrementalSearchTimeout; + property Indent; + property LineMode; + property LineStyle; + property Margin; + property NodeAlignment; + property NodeDataSize; + property OperationCanceled; + property ParentBiDiMode; + property ParentColor default False; + property ParentCtl3D; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property RootNodeCount; + property ScrollBarOptions; + property SelectionBlendFactor; + property SelectionCurveRadius; + property ShowHint; + property StateImages; + property StyleElements; + {$if CompilerVersion >= 34}property StyleName;{$ifend} + property TabOrder; + property TabStop default True; + property TextMargin; + property TreeOptions: TStringTreeOptions read GetOptions write SetOptions; + property Visible; + property WantTabs; property OnAddToSelection; property OnAdvancedHeaderDraw; @@ -3624,6 +470,8 @@ TVirtualStringTree = class(TCustomVirtualStringTree) property OnClick; property OnCollapsed; property OnCollapsing; + property OnColumnChecked; + property OnColumnChecking; property OnColumnClick; property OnColumnDblClick; property OnColumnExport; @@ -3722,29629 +570,68 @@ TVirtualStringTree = class(TCustomVirtualStringTree) property OnResize; property OnSaveNode; property OnSaveTree; - property OnScroll; - property OnShortenString; - property OnShowScrollBar; - property OnBeforeGetCheckState; - property OnStartDock; - property OnStartDrag; - property OnStartOperation; - property OnStateChange; - property OnStructureChange; - property OnUpdating; - property OnCanResize; - property OnGesture; - property Touch; - end; - - TVTDrawNodeEvent = procedure(Sender: TBaseVirtualTree; const PaintInfo: TVTPaintInfo) of object; - TVTGetCellContentMarginEvent = procedure(Sender: TBaseVirtualTree; HintCanvas: TCanvas; Node: PVirtualNode; - Column: TColumnIndex; CellContentMarginType: TVTCellContentMarginType; var CellContentMargin: TPoint) of object; - TVTGetNodeWidthEvent = procedure(Sender: TBaseVirtualTree; HintCanvas: TCanvas; Node: PVirtualNode; - Column: TColumnIndex; var NodeWidth: Integer) of object; - - // Tree descendant to let an application draw its stuff itself. - TCustomVirtualDrawTree = class(TBaseVirtualTree) - private - FOnDrawNode: TVTDrawNodeEvent; - FOnGetCellContentMargin: TVTGetCellContentMarginEvent; - FOnGetNodeWidth: TVTGetNodeWidthEvent; - protected - function DoGetCellContentMargin(Node: PVirtualNode; Column: TColumnIndex; - CellContentMarginType: TVTCellContentMarginType = ccmtAllSides; Canvas: TCanvas = nil): TPoint; override; - function DoGetNodeWidth(Node: PVirtualNode; Column: TColumnIndex; Canvas: TCanvas = nil): Integer; override; - procedure DoPaintNode(var PaintInfo: TVTPaintInfo); override; - function GetDefaultHintKind: TVTHintKind; override; - - property OnDrawNode: TVTDrawNodeEvent read FOnDrawNode write FOnDrawNode; - property OnGetCellContentMargin: TVTGetCellContentMarginEvent read FOnGetCellContentMargin write FOnGetCellContentMargin; - property OnGetNodeWidth: TVTGetNodeWidthEvent read FOnGetNodeWidth write FOnGetNodeWidth; - end; - - [ComponentPlatformsAttribute(pidWin32 or pidWin64)] - TVirtualDrawTree = class(TCustomVirtualDrawTree) - private - function GetOptions: TVirtualTreeOptions; - procedure SetOptions(const Value: TVirtualTreeOptions); - protected - function GetOptionsClass: TTreeOptionsClass; override; - public - property Canvas; - property LastDragEffect; - property CheckImageKind; // should no more be published to make #622 fix working - published - property Action; - property Align; - property Alignment; - property Anchors; - property AnimationDuration; - property AutoExpandDelay; - property AutoScrollDelay; - property AutoScrollInterval; - property Background; - property BackgroundOffsetX; - property BackgroundOffsetY; - property BiDiMode; - property BevelEdges; - property BevelInner; - property BevelOuter; - property BevelKind; - property BevelWidth; - property BorderStyle; - property BottomSpace; - property ButtonFillMode; - property ButtonStyle; - property BorderWidth; - property ChangeDelay; - property ClipboardFormats; - property Color; - property Colors; - property Constraints; - property Ctl3D; - property CustomCheckImages; - property DefaultNodeHeight; - property DefaultPasteMode; - property DragCursor; - property DragHeight; - property DragKind; - property DragImageKind; - property DragMode; - property DragOperations; - property DragType; - property DragWidth; - property DrawSelectionMode; - property EditDelay; - property Enabled; - property Font; - property Header; - property HintMode; - property HotCursor; - property Images; - property IncrementalSearch; - property IncrementalSearchDirection; - property IncrementalSearchStart; - property IncrementalSearchTimeout; - property Indent; - property LineMode; - property LineStyle; - property Margin; - property NodeAlignment; - property NodeDataSize; - property OperationCanceled; - property ParentBiDiMode; - property ParentColor default False; - property ParentCtl3D; - property ParentFont; - property ParentShowHint; - property PopupMenu; - property RootNodeCount; - property ScrollBarOptions; - property SelectionBlendFactor; - property SelectionCurveRadius; - property ShowHint; - property StateImages; - property TabOrder; - property TabStop default True; - property TextMargin; - property TreeOptions: TVirtualTreeOptions read GetOptions write SetOptions; - property Visible; - property WantTabs; - - property OnAddToSelection; - property OnAdvancedHeaderDraw; - property OnAfterAutoFitColumn; - property OnAfterAutoFitColumns; - property OnAfterCellPaint; - property OnAfterColumnExport; - property OnAfterColumnWidthTracking; - property OnAfterGetMaxColumnWidth; - property OnAfterHeaderExport; - property OnAfterHeaderHeightTracking; - property OnAfterItemErase; - property OnAfterItemPaint; - property OnAfterNodeExport; - property OnAfterPaint; - property OnAfterTreeExport; - property OnBeforeAutoFitColumn; - property OnBeforeAutoFitColumns; - property OnBeforeCellPaint; - property OnBeforeColumnExport; - property OnBeforeColumnWidthTracking; - property OnBeforeDrawTreeLine; - property OnBeforeGetMaxColumnWidth; - property OnBeforeHeaderExport; - property OnBeforeHeaderHeightTracking; - property OnBeforeItemErase; - property OnBeforeItemPaint; - property OnBeforeNodeExport; - property OnBeforePaint; - property OnBeforeTreeExport; - property OnCanSplitterResizeColumn; - property OnCanSplitterResizeHeader; - property OnCanSplitterResizeNode; - property OnChange; - property OnChecked; - property OnChecking; - property OnClick; - property OnCollapsed; - property OnCollapsing; - property OnColumnClick; - property OnColumnDblClick; - property OnColumnExport; - property OnColumnResize; - property OnColumnVisibilityChanged; - property OnColumnWidthDblClickResize; - property OnColumnWidthTracking; - property OnCompareNodes; - property OnContextPopup; - property OnCreateDataObject; - property OnCreateDragManager; - property OnCreateEditor; - property OnDblClick; - property OnDragAllowed; - property OnDragOver; - property OnDragDrop; - property OnDrawHint; - property OnDrawNode; - property OnEdited; - property OnEditing; - property OnEndDock; - property OnEndDrag; - property OnEndOperation; - property OnEnter; - property OnExit; - property OnExpanded; - property OnExpanding; - property OnFocusChanged; - property OnFocusChanging; - property OnFreeNode; - property OnGetCellIsEmpty; - property OnGetCursor; - property OnGetHeaderCursor; - property OnGetHelpContext; - property OnGetHintKind; - property OnGetHintSize; - property OnGetImageIndex; - property OnGetImageIndexEx; - property OnGetLineStyle; - property OnGetNodeDataSize; - property OnGetNodeWidth; - property OnGetPopupMenu; - property OnGetUserClipboardFormats; - property OnHeaderAddPopupItem; - property OnHeaderClick; - property OnHeaderDblClick; - property OnHeaderDragged; - property OnHeaderDraggedOut; - property OnHeaderDragging; - property OnHeaderDraw; - property OnHeaderDrawQueryElements; - property OnHeaderHeightTracking; - property OnHeaderHeightDblClickResize; - property OnHeaderMouseDown; - property OnHeaderMouseMove; - property OnHeaderMouseUp; - property OnHotChange; - property OnIncrementalSearch; - property OnInitChildren; - property OnInitNode; - property OnKeyAction; - property OnKeyDown; - property OnKeyPress; - property OnKeyUp; - property OnLoadNode; - property OnLoadTree; - property OnMeasureItem; - property OnMouseDown; - property OnMouseMove; - property OnMouseUp; - property OnMouseWheel; - property OnNodeClick; - property OnNodeCopied; - property OnNodeCopying; - property OnNodeDblClick; - property OnNodeExport; - property OnNodeHeightTracking; - property OnNodeHeightDblClickResize; - property OnNodeMoved; - property OnNodeMoving; - property OnPaintBackground; - property OnPrepareButtonBitmaps; - property OnRemoveFromSelection; - property OnRenderOLEData; - property OnResetNode; - property OnResize; - property OnSaveNode; - property OnSaveTree; - property OnScroll; - property OnShowScrollBar; - property OnStartDock; - property OnStartDrag; - property OnStartOperation; - property OnStateChange; - property OnStructureChange; - property OnUpdating; - property OnCanResize; - property OnGesture; - property Touch; - property StyleElements; - end; - - - -// utility routines -function TreeFromNode(Node: PVirtualNode): TBaseVirtualTree; - -//---------------------------------------------------------------------------------------------------------------------- - -implementation - -{$R VirtualTrees.res} - -uses - Vcl.Consts, - System.Math, - Vcl.AxCtrls, // TOLEStream - Winapi.MMSystem, // for animation timer (does not include further resources) - System.TypInfo, // for migration stuff - System.SyncObjs, - Vcl.ActnList, - Vcl.StdActns, // for standard action support - System.StrUtils, - Vcl.GraphUtil, // accessibility helper class - VirtualTrees.AccessibilityFactory, - VirtualTrees.StyleHooks, - VirtualTrees.Classes, - VirtualTrees.WorkerThread, - VirtualTrees.ClipBoard, - VirtualTrees.Utils, - VirtualTrees.Export, - VirtualTrees.HeaderPopup; - -resourcestring - // Localizable strings. - SEditLinkIsNil = 'Edit link must not be nil.'; - SWrongMoveError = 'Target node cannot be a child node of the node to be moved.'; - SWrongStreamFormat = 'Unable to load tree structure, the format is wrong.'; - SWrongStreamVersion = 'Unable to load tree structure, the version is unknown.'; - SStreamTooSmall = 'Unable to load tree structure, not enough data available.'; - SCorruptStream1 = 'Stream data corrupt. A node''s anchor chunk is missing.'; - SCorruptStream2 = 'Stream data corrupt. Unexpected data after node''s end position.'; - SClipboardFailed = 'Clipboard operation failed.'; - -const - ClipboardStates = [tsCopyPending, tsCutPending]; - DefaultScrollUpdateFlags = [suoRepaintHeader, suoRepaintScrollBars, suoScrollClientArea, suoUpdateNCArea]; - TreeNodeSize = (SizeOf(TVirtualNode) + (SizeOf(Pointer) - 1)) and not (SizeOf(Pointer) - 1); // used for node allocation and access to internal data - /// Default value of the DefaultText property - cDefaultText = 'Node'; - MouseButtonDown = [tsLeftButtonDown, tsMiddleButtonDown, tsRightButtonDown]; - - // Do not modify the copyright in any way! Usage of this unit is prohibited without the copyright notice - // in the compiled binary file. - Copyright: string = 'Virtual Treeview 1999, 2010, 2016 Mike Lischke, Joachim Marder'; - -var - StandardOLEFormat: TFormatEtc = ( - // Format must later be set. - cfFormat: 0; - // No specific target device to render on. - ptd: nil; - // Normal content to render. - dwAspect: DVASPECT_CONTENT; - // No specific page of multipage data (we don't use multipage data by default). - lindex: -1; - // Acceptable storage formats are IStream and global memory. The first is preferred. - tymed: TYMED_ISTREAM or TYMED_HGLOBAL; - ); - -type - // protection against TRect record method that cause problems with with-statements - TWithSafeRect = record - case Integer of - 0: (Left, Top, Right, Bottom: Integer); - 1: (TopLeft, BottomRight: TPoint); - end; - -type // streaming support - TMagicID = array[0..5] of WideChar; - - TChunkHeader = record - ChunkType, - ChunkSize: Integer; // contains the size of the chunk excluding the header - end; - - // base information about a node - TBaseChunkBody = packed record - ChildCount, - NodeHeight: Cardinal; - States: TVirtualNodeStates; - Align: Byte; - CheckState: TCheckState; - CheckType: TCheckType; - Reserved: Cardinal; - end; - - TBaseChunk = packed record - Header: TChunkHeader; - Body: TBaseChunkBody; - end; - - // Toggle animation modes. - TToggleAnimationMode = ( - tamScrollUp, - tamScrollDown, - tamNoScroll - ); - - // Internally used data for animations. - TToggleAnimationData = record - Window: HWND; // copy of the tree's window handle - DC: HDC; // the DC of the window to erase uncovered parts - Brush: HBRUSH; // the brush to be used to erase uncovered parts - R1, - R2: TRect; // animation rectangles - Mode1, - Mode2: TToggleAnimationMode; // animation modes - ScaleFactor: Double; // the factor between the missing step size when doing two animations - MissedSteps: Double; - end; - - TCanvasEx = class(TCanvas); - -const - MagicID: TMagicID = (#$2045, 'V', 'T', WideChar(VTTreeStreamVersion), ' ', #$2046); - - // chunk IDs - NodeChunk = 1; - BaseChunk = 2; // chunk containing node state, check state, child node count etc. - // this chunk is immediately followed by all child nodes - CaptionChunk = 3; // used by the string tree to store a node's caption - UserChunk = 4; // used for data supplied by the application - - RTLFlag: array[Boolean] of Integer = (0, ETO_RTLREADING); - AlignmentToDrawFlag: array[TAlignment] of Cardinal = (DT_LEFT, DT_RIGHT, DT_CENTER); - - WideCR = Char(#13); - WideLF = Char(#10); - -var - gWatcher: TCriticalSection = nil; - gInitialized: Integer = 0; // >0 if global structures have been initialized; otherwise 0 - NeedToUnitialize: Boolean = False; // True if the OLE subsystem could be initialized successfully. - - -//---------------------------------------------------------------------------------------------------------------------- - -procedure ShowError(const Msg: string; HelpContext: Integer); - -begin - raise EVirtualTreeError.CreateHelp(Msg, HelpContext); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TreeFromNode(Node: PVirtualNode): TBaseVirtualTree; - -// Returns the tree the node currently belongs to or nil if the node is not attached to a tree. - -begin - Assert(Assigned(Node), 'Node must not be nil.'); - - // The root node is marked by having its NextSibling (and PrevSibling) pointing to itself. - while Assigned(Node) and (Node.NextSibling <> Node) do - Node := Node.Parent; - if Assigned(Node) then - Result := TBaseVirtualTree(Node.Parent) - else - Result := nil; -end; - -//---------------------------------------------------------------------------------------------------------------------- - - -procedure QuickSort(const TheArray: TNodeArray; L, R: Integer); - -var - I, J: Integer; - P, T: Pointer; - -begin - repeat - I := L; - J := R; - P := TheArray[(L + R) shr 1]; - repeat - while PAnsiChar(TheArray[I]) < PAnsiChar(P) do - Inc(I); - while PAnsiChar(TheArray[J]) > PAnsiChar(P) do - Dec(J); - if I <= J then - begin - T := TheArray[I]; - TheArray[I] := TheArray[J]; - TheArray[J] := T; - Inc(I); - Dec(J); - end; - until I > J; - if L < J then - QuickSort(TheArray, L, J); - L := I; - until I >= R; -end; - - -//---------------------------------------------------------------------------------------------------------------------- - - - - -const - Grays: array[0..3] of TColor = (clWhite, clSilver, clGray, clBlack); - SysGrays: array[0..3] of TColor = (clWindow, clBtnFace, clBtnShadow, clBtnText); - -procedure ConvertImageList(IL: TImageList; const ImageName: string; ColorRemapping: Boolean = True); - -// Loads a bunch of images given by ImageName into IL. If ColorRemapping = True then a mapping of gray values to -// system colors is performed. - -var - lImages, - lOneImage: TBitmap; - I: Integer; - MaskColor: TColor; - Source, - Dest: TRect; - -begin - gWatcher.Enter(); - try - // Since we want the image list appearing in the correct system colors, we have to remap its colors. - lImages := TBitmap.Create; - lOneImage := TBitmap.Create; - if ColorRemapping then - lImages.Handle := CreateMappedRes(FindClassHInstance(TBaseVirtualTree), PChar(ImageName), Grays, SysGrays) - else - lImages.Handle := LoadBitmap(FindClassHInstance(TBaseVirtualTree), PChar(ImageName)); - - try - Assert(lImages.Height > 0, 'Internal image "' + ImageName + '" is missing or corrupt.'); - if lImages.Height = 0 then - Exit;// This should never happen, it prevents a division by zero exception below in the for loop, which we have seen in a few cases - // It is assumed that the image height determines also the width of one entry in the image list. - IL.Clear; - IL.Height := lImages.Height; - IL.Width := lImages.Height; - lOneImage.Width := IL.Width; - lOneImage.Height := IL.Height; - MaskColor := lImages.Canvas.Pixels[0, 0]; // this is usually clFuchsia - Dest := Rect(0, 0, IL.Width, IL.Height); - for I := 0 to (lImages.Width div lImages.Height) - 1 do - begin - Source := Rect(I * IL.Width, 0, (I + 1) * IL.Width, IL.Height); - lOneImage.Canvas.CopyRect(Dest, lImages.Canvas, Source); - IL.AddMasked(lOneImage, MaskColor); - end; - finally - lImages.Free; - lOneImage.Free; - end; - finally - gWatcher.Leave(); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function CreateSystemImageSet(pControl: TWinControl): TImageList; - -// Creates a system check image set. -// Note: the DarkCheckImages and FlatImages image lists must already be filled, as some images from them are copied here. - -const - MaskColor: TColor = clRed; - cFlags = ILC_COLOR32 or ILC_MASK; - -var - BM: TBitmap; - Theme: HTHEME; - Details: TThemedElementDetails; - - //--------------------------------------------------------------------------- - - procedure AddSystemImage(IL: TImageList; Index: Integer); - const - States: array [0..19] of Integer = ( - RBS_UNCHECKEDNORMAL, RBS_UNCHECKEDHOT, RBS_UNCHECKEDPRESSED, RBS_UNCHECKEDDISABLED, - RBS_CHECKEDNORMAL, RBS_CHECKEDHOT, RBS_CHECKEDPRESSED, RBS_CHECKEDDISABLED, - CBS_UNCHECKEDNORMAL, CBS_UNCHECKEDHOT, CBS_UNCHECKEDPRESSED, CBS_UNCHECKEDDISABLED, - CBS_CHECKEDNORMAL, CBS_CHECKEDHOT, CBS_CHECKEDPRESSED, CBS_CHECKEDDISABLED, - CBS_MIXEDNORMAL, CBS_MIXEDHOT, CBS_MIXEDPRESSED, CBS_MIXEDDISABLED); - var - ButtonState: Cardinal; - ButtonType: Cardinal; - - begin - BM.Canvas.FillRect(Rect(0, 0, BM.Width, BM.Height)); - if StyleServices.Enabled and StyleServices.IsSystemStyle then - begin - if Index < 8 then - Details.Part := BP_RADIOBUTTON - else - Details.Part := BP_CHECKBOX; - Details.State := States[Index]; - DrawThemeBackground(Theme, BM.Canvas.Handle, Details.Part, Details.State, Rect(0, 0, BM.Width, BM.Height), nil); - end - else - begin - if Index < 8 then - ButtonType := DFCS_BUTTONRADIO - else - ButtonType := DFCS_BUTTONCHECK; - if Index >= 16 then - ButtonType := ButtonType or DFCS_BUTTON3STATE; - - case Index mod 4 of - 0: - ButtonState := 0; - 1: - ButtonState := DFCS_HOT; - 2: - ButtonState := DFCS_PUSHED; - else - ButtonState := DFCS_INACTIVE; - end; - if Index in [4..7, 12..19] then - ButtonState := ButtonState or DFCS_CHECKED; -// if Flat then -// ButtonState := ButtonState or DFCS_FLAT; - DrawFrameControl(BM.Canvas.Handle, Rect(0, 0, BM.Width, BM.Height), DFC_BUTTON, ButtonType or ButtonState); - end; - IL.AddMasked(BM, MaskColor); - end; - - //--------------- end local functions --------------------------------------- - -const - cDefaultCheckboxSize = 13;// Used when no other value is available -var - I: Integer; - lSize: TSize; - Res: Boolean; -begin - BM := TBitmap.Create; // Create a temporary bitmap, which holds the intermediate images. - try - Res := False; - // Retrieve the checkbox image size, prefer theme if available, fall back to GetSystemMetrics() otherwise, but this returns odd results on Windows 8 and higher in high-dpi scenarios. - if StyleServices.Enabled then - if StyleServices.IsSystemStyle then - begin - if Assigned(pControl) then - Theme := OpenThemeData(pControl.Handle, 'BUTTON') - else - Theme := OpenThemeData(Application.Handle, 'BUTTON'); - Details := StyleServices.GetElementDetails(tbCheckBoxUncheckedNormal); - Res := GetThemePartSize(Theme, BM.Canvas.Handle, Details.Part, Details.State, nil, TS_TRUE, lSize) = S_OK; - end - else - Res := StyleServices.GetElementSize(BM.Canvas.Handle, StyleServices.GetElementDetails(tbCheckBoxUncheckedNormal), TElementSize.esActual, lSize); - if not Res then begin - lSize := TSize.Create(GetSystemMetrics(SM_CXMENUCHECK), GetSystemMetrics(SM_CYMENUCHECK)); - if lSize.cx = 0 then begin // error? (Should happen rarely only) - lSize.cx := MulDiv(cDefaultCheckboxSize, Screen.PixelsPerInch, USER_DEFAULT_SCREEN_DPI); - lSize.cy := lSize.cx; - end;// if - end;//if - - Result := TImageList.CreateSize(lSize.cx, lSize.cy); - with Result do - Handle := ImageList_Create(Width, Height, cFlags, 0, AllocBy); - Result.Masked := True; - Result.BkColor := clWhite; - - // Make the bitmap the same size as the image list is to avoid problems when adding. - BM.SetSize(Result.Width, Result.Height); - BM.Canvas.Brush.Color := MaskColor; - BM.Canvas.Brush.Style := bsSolid; - BM.Canvas.FillRect(Rect(0, 0, BM.Width, BM.Height)); - Result.AddMasked(BM, MaskColor); - - // Add the 20 system checkbox and radiobutton images. - for I := 0 to 19 do - AddSystemImage(Result, I); - if StyleServices.Enabled and StyleServices.IsSystemStyle then - CloseThemeData(Theme); - - finally - BM.Free; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - - - - - -procedure InitializeGlobalStructures(); - -// initialization of stuff global to the unit -begin - if (gInitialized > 0) or (InterlockedIncrement(gInitialized) <> 1) then // Ensure threadsafe that this code is executed only once - exit; - - // This watcher is used whenever a global structure could be modified by more than one thread. - gWatcher := TCriticalSection.Create(); - - IsWinVistaOrAbove := (Win32MajorVersion >= 6); - - // Initialize OLE subsystem for drag'n drop and clipboard operations. - NeedToUnitialize := not IsLibrary and Succeeded(OleInitialize(nil)); - - // Register the tree reference clipboard format. Others will be handled in InternalClipboarFormats. - CF_VTREFERENCE := RegisterClipboardFormat(CFSTR_VTREFERENCE); - - // Delphi (at least version 6 and lower) does not provide a standard split cursor. - // Hence we have to load our own. - Screen.Cursors[crHeaderSplit] := LoadCursor(HInstance, 'VT_HEADERSPLIT'); - Screen.Cursors[crVertSplit] := LoadCursor(HInstance, 'VT_VERTSPLIT'); - - // Clipboard format registration. - // Native clipboard format. Needs a new identifier and has an average priority to allow other formats to take over. - // This format is supposed to use the IStream storage format but unfortunately this does not work when - // OLEFlushClipboard is used. Hence it is disabled until somebody finds a solution. - CF_VIRTUALTREE := RegisterVTClipboardFormat(CFSTR_VIRTUALTREE, TBaseVirtualTree, 50, TYMED_HGLOBAL {or TYMED_ISTREAM}); - // Specialized string tree formats. - CF_HTML := RegisterVTClipboardFormat(CFSTR_HTML, TCustomVirtualStringTree, 80); - CF_VRTFNOOBJS := RegisterVTClipboardFormat(CFSTR_RTFNOOBJS, TCustomVirtualStringTree, 84); - CF_VRTF := RegisterVTClipboardFormat(CFSTR_RTF, TCustomVirtualStringTree, 85); - CF_CSV := RegisterVTClipboardFormat(CFSTR_CSV, TCustomVirtualStringTree, 90); - // Predefined clipboard formats. Just add them to the internal list. - RegisterVTClipboardFormat(CF_TEXT, TCustomVirtualStringTree, 100); - RegisterVTClipboardFormat(CF_UNICODETEXT, TCustomVirtualStringTree, 95); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure FinalizeGlobalStructures(); - -var - HintWasEnabled: Boolean; - -begin - if gInitialized = 0 then - exit; // Was not initialized - - if NeedToUnitialize then - OleUninitialize; - - // If VT is used in a package and its special hint window was used then the last instance of this - // window is not freed correctly (bug in the VCL). We explicitely tell the application to free it - // otherwise an AV is raised due to access to an invalid memory area. - if ModuleIsPackage then - begin - HintWasEnabled := Application.ShowHint; - Application.ShowHint := False; - if HintWasEnabled then - Application.ShowHint := True; - end; - gWatcher.Free; - gWatcher := nil; -end; - - - - -//----------------- TCustomVirtualTreeOptions -------------------------------------------------------------------------- - -constructor TCustomVirtualTreeOptions.Create(AOwner: TBaseVirtualTree); - -begin - FOwner := AOwner; - - FPaintOptions := DefaultPaintOptions; - FAnimationOptions := DefaultAnimationOptions; - FAutoOptions := DefaultAutoOptions; - FSelectionOptions := DefaultSelectionOptions; - FMiscOptions := DefaultMiscOptions; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TCustomVirtualTreeOptions.SetAnimationOptions(const Value: TVTAnimationOptions); - -begin - FAnimationOptions := Value; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TCustomVirtualTreeOptions.SetAutoOptions(const Value: TVTAutoOptions); - -var - ChangedOptions: TVTAutoOptions; - -begin - if FAutoOptions <> Value then - begin - // Exclusive ORing to get all entries wich are in either set but not in both. - ChangedOptions := FAutoOptions + Value - (FAutoOptions * Value); - FAutoOptions := Value; - with FOwner do - if (toAutoSpanColumns in ChangedOptions) and not (csLoading in ComponentState) and HandleAllocated then - Invalidate; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TCustomVirtualTreeOptions.SetMiscOptions(const Value: TVTMiscOptions); - -var - ToBeSet, - ToBeCleared: TVTMiscOptions; - -begin - if FMiscOptions <> Value then - begin - ToBeSet := Value - FMiscOptions; - ToBeCleared := FMiscOptions - Value; - FMiscOptions := Value; - - with FOwner do - if not (csLoading in ComponentState) and HandleAllocated then - begin - if toCheckSupport in ToBeSet + ToBeCleared then - Invalidate; - if toEditOnDblClick in ToBeSet then - FMiscOptions := FMiscOptions - [toToggleOnDblClick]; // In order for toEditOnDblClick to take effect, we need to remove toToggleOnDblClick which is handled with priority. See issue #747 - - if not (csDesigning in ComponentState) then - begin - if toAcceptOLEDrop in ToBeCleared then - RevokeDragDrop(Handle); - if toFullRepaintOnResize in ToBeSet + ToBeCleared then - RecreateWnd; - if toAcceptOLEDrop in ToBeSet then - RegisterDragDrop(Handle, DragManager as IDropTarget); - if toVariableNodeHeight in ToBeSet then begin - BeginUpdate(); - try - ReInitNode(nil, True); - finally - EndUpdate(); - end;//try..finally - end;//if toVariableNodeHeight - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TCustomVirtualTreeOptions.SetPaintOptions(const Value: TVTPaintOptions); - -var - ToBeSet, - ToBeCleared: TVTPaintOptions; - Run: PVirtualNode; - HandleWasAllocated: Boolean; - -begin - if FPaintOptions <> Value then - begin - ToBeSet := Value - FPaintOptions; - ToBeCleared := FPaintOptions - Value; - FPaintOptions := Value; - if (toFixedIndent in ToBeSet) then - begin - // Fixes issue #388 - Include(FPaintOptions, toShowRoot); - Include(ToBeSet, toShowRoot); - end;//if - with FOwner do - begin - HandleWasAllocated := HandleAllocated; - - if not (csLoading in ComponentState) and (toShowFilteredNodes in ToBeSet + ToBeCleared) then - begin - if HandleWasAllocated then - BeginUpdate; - InterruptValidation; - Run := GetFirstNoInit; - while Assigned(Run) do - begin - if (vsFiltered in Run.States) then - begin - if FullyVisible[Run] then - begin - if toShowFilteredNodes in ToBeSet then - Inc(FVisibleCount) - else - Dec(FVisibleCount); - end; - if toShowFilteredNodes in ToBeSet then - AdjustTotalHeight(Run, Run.NodeHeight, True) - else - AdjustTotalHeight(Run, -Run.NodeHeight, True); - end; - Run := GetNextNoInit(Run); - end; - if HandleWasAllocated then - EndUpdate; - end; - - if HandleAllocated then - begin - if IsWinVistaOrAbove and ((tsUseThemes in FStates) or - ((toThemeAware in ToBeSet) and StyleServices.Enabled)) and - (toUseExplorerTheme in (ToBeSet + ToBeCleared)) and not VclStyleEnabled then - begin - if (toUseExplorerTheme in ToBeSet) then - begin - SetWindowTheme('explorer'); - DoStateChange([tsUseExplorerTheme]); - end - else - if toUseExplorerTheme in ToBeCleared then - begin - SetWindowTheme(''); - DoStateChange([], [tsUseExplorerTheme]); - end; - end; - - if not (csLoading in ComponentState) then - begin - if ((toThemeAware in ToBeSet + ToBeCleared) or (toUseExplorerTheme in ToBeSet + ToBeCleared) or VclStyleEnabled) then - begin - if ((toThemeAware in ToBeSet) and StyleServices.Enabled) then - DoStateChange([tsUseThemes]) - else - if (toThemeAware in ToBeCleared) then - DoStateChange([], [tsUseThemes]); - - PrepareBitmaps(True, False); - RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_VALIDATE or RDW_FRAME); - end; - - if toChildrenAbove in ToBeSet + ToBeCleared then - begin - InvalidateCache; - if FUpdateCount = 0 then - begin - ValidateCache; - Invalidate; - end; - end; - - Invalidate; - end; - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TCustomVirtualTreeOptions.SetSelectionOptions(const Value: TVTSelectionOptions); - -var - ToBeSet, - ToBeCleared: TVTSelectionOptions; - -begin - if FSelectionOptions <> Value then - begin - ToBeSet := Value - FSelectionOptions; - ToBeCleared := FSelectionOptions - Value; - FSelectionOptions := Value; - - with FOwner do - begin - if (toMultiSelect in (ToBeCleared + ToBeSet)) or - ([toLevelSelectConstraint, toSiblingSelectConstraint] * ToBeSet <> []) then - ClearSelection; - - if (toExtendedFocus in ToBeCleared) and (FFocusedColumn > 0) and HandleAllocated then - begin - FFocusedColumn := FHeader.MainColumn; - Invalidate; - end; - - if not (toExtendedFocus in FSelectionOptions) then - FFocusedColumn := FHeader.MainColumn; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TCustomVirtualTreeOptions.AssignTo(Dest: TPersistent); - -begin - if Dest is TCustomVirtualTreeOptions then - begin - with Dest as TCustomVirtualTreeOptions do - begin - PaintOptions := Self.PaintOptions; - AnimationOptions := Self.AnimationOptions; - AutoOptions := Self.AutoOptions; - SelectionOptions := Self.SelectionOptions; - MiscOptions := Self.MiscOptions; - end; - end - else - inherited; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -// OLE drag and drop support classes -// This is quite heavy stuff (compared with the VCL implementation) but is much better suited to fit the needs -// of DD'ing various kinds of virtual data and works also between applications. - -//----------------- TEnumFormatEtc ------------------------------------------------------------------------------------- - -constructor TEnumFormatEtc.Create(Tree: TBaseVirtualTree; const AFormatEtcArray: TFormatEtcArray); - -var - I: Integer; - -begin - inherited Create; - - FTree := Tree; - // Make a local copy of the format data. - SetLength(FFormatEtcArray, Length(AFormatEtcArray)); - for I := 0 to High(AFormatEtcArray) do - FFormatEtcArray[I] := AFormatEtcArray[I]; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TEnumFormatEtc.Clone(out Enum: IEnumFormatEtc): HResult; - -var - AClone: TEnumFormatEtc; - -begin - Result := S_OK; - try - AClone := TEnumFormatEtc.Create(nil, FFormatEtcArray); - AClone.FCurrentIndex := FCurrentIndex; - Enum := AClone as IEnumFormatEtc; - except - Result := E_FAIL; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TEnumFormatEtc.Next(celt: Integer; out elt; pceltFetched: PLongint): HResult; - -var - CopyCount: Integer; - -begin - Result := S_FALSE; - CopyCount := Length(FFormatEtcArray) - FCurrentIndex; - if celt < CopyCount then - CopyCount := celt; - if CopyCount > 0 then - begin - Move(FFormatEtcArray[FCurrentIndex], elt, CopyCount * SizeOf(TFormatEtc)); - Inc(FCurrentIndex, CopyCount); - Result := S_OK; - end; - if Assigned(pceltFetched) then - pceltFetched^ := CopyCount; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TEnumFormatEtc.Reset: HResult; - -begin - FCurrentIndex := 0; - Result := S_OK; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TEnumFormatEtc.Skip(celt: Integer): HResult; - -begin - if FCurrentIndex + celt < High(FFormatEtcArray) then - begin - Inc(FCurrentIndex, celt); - Result := S_Ok; - end - else - Result := S_FALSE; -end; - -//----------------- TVTDataObject -------------------------------------------------------------------------------------- - -constructor TVTDataObject.Create(AOwner: TBaseVirtualTree; ForClipboard: Boolean); - -begin - inherited Create; - - FOwner := AOwner; - FForClipboard := ForClipboard; - FOwner.GetNativeClipboardFormats(FFormatEtcArray); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -destructor TVTDataObject.Destroy; - -var - I: Integer; - StgMedium: PStgMedium; - -begin - // Cancel a pending clipboard operation if this data object was created for the clipboard and - // is freed because something else is placed there. - if FForClipboard and not (tsClipboardFlushing in FOwner.FStates) then - FOwner.CancelCutOrCopy; - - // Release any internal clipboard formats - for I := 0 to High(FormatEtcArray) do - begin - StgMedium := FindInternalStgMedium(FormatEtcArray[I].cfFormat); - if Assigned(StgMedium) then - ReleaseStgMedium(StgMedium^); - end; - - FormatEtcArray := nil; - inherited; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDataObject.CanonicalIUnknown(const TestUnknown: IUnknown): IUnknown; - -// Uses COM object identity: An explicit call to the IUnknown::QueryInterface method, requesting the IUnknown -// interface, will always return the same pointer. - -begin - if Assigned(TestUnknown) then - begin - if TestUnknown.QueryInterface(IUnknown, Result) = 0 then - Result._Release // Don't actually need it just need the pointer value - else - Result := TestUnknown; - end - else - Result := TestUnknown; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDataObject.EqualFormatEtc(FormatEtc1, FormatEtc2: TFormatEtc): Boolean; - -begin - Result := (FormatEtc1.cfFormat = FormatEtc2.cfFormat) and (FormatEtc1.ptd = FormatEtc2.ptd) and - (FormatEtc1.dwAspect = FormatEtc2.dwAspect) and (FormatEtc1.lindex = FormatEtc2.lindex) and - (FormatEtc1.tymed and FormatEtc2.tymed <> 0); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDataObject.FindFormatEtc(TestFormatEtc: TFormatEtc; const FormatEtcArray: TFormatEtcArray): integer; - -var - I: integer; - -begin - Result := -1; - for I := 0 to High(FormatEtcArray) do - begin - if EqualFormatEtc(TestFormatEtc, FormatEtcArray[I]) then - begin - Result := I; - Break; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDataObject.FindInternalStgMedium(Format: TClipFormat): PStgMedium; - -var - I: integer; -begin - Result := nil; - for I := 0 to High(InternalStgMediumArray) do - begin - if Format = InternalStgMediumArray[I].Format then - begin - Result := @InternalStgMediumArray[I].Medium; - Break; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDataObject.HGlobalClone(HGlobal: THandle): THandle; - -// Returns a global memory block that is a copy of the passed memory block. - -var - Size: Cardinal; - Data, - NewData: PByte; - -begin - Size := GlobalSize(HGlobal); - Result := GlobalAlloc(GPTR, Size); - Data := GlobalLock(hGlobal); - try - NewData := GlobalLock(Result); - try - Move(Data^, NewData^, Size); - finally - GlobalUnLock(Result); - end; - finally - GlobalUnLock(hGlobal); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDataObject.RenderInternalOLEData(const FormatEtcIn: TFormatEtc; var Medium: TStgMedium; - var OLEResult: HResult): Boolean; - -// Tries to render one of the formats which have been stored via the SetData method. -// Since this data is already there it is just copied or its reference count is increased (depending on storage medium). - -var - InternalMedium: PStgMedium; - -begin - Result := True; - InternalMedium := FindInternalStgMedium(FormatEtcIn.cfFormat); - if Assigned(InternalMedium) then - OLEResult := StgMediumIncRef(InternalMedium^, Medium, False, Self as IDataObject) - else - Result := False; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDataObject.StgMediumIncRef(const InStgMedium: TStgMedium; var OutStgMedium: TStgMedium; - CopyInMedium: Boolean; const DataObject: IDataObject): HRESULT; - -// InStgMedium is the data that is requested, OutStgMedium is the data that we are to return either a copy of or -// increase the IDataObject's reference and send ourselves back as the data (unkForRelease). The InStgMedium is usually -// the result of a call to find a particular FormatEtc that has been stored locally through a call to SetData. -// If CopyInMedium is not true we already have a local copy of the data when the SetData function was called (during -// that call the CopyInMedium must be true). Then as the caller asks for the data through GetData we do not have to make -// copy of the data for the caller only to have them destroy it then need us to copy it again if necessary. -// This way we increase the reference count to ourselves and pass the STGMEDIUM structure initially stored in SetData. -// This way when the caller frees the structure it sees the unkForRelease is not nil and calls Release on the object -// instead of destroying the actual data. - -var - Len: Integer; - -begin - Result := S_OK; - - // Simply copy all fields to start with. - OutStgMedium := InStgMedium; - // The data handled here always results from a call of SetData we got. This ensures only one storage format - // is indicated and hence the case statement below is safe (IDataObject.GetData can optionally use several - // storage formats). - case InStgMedium.tymed of - TYMED_HGLOBAL: - begin - if CopyInMedium then - begin - // Generate a unique copy of the data passed - OutStgMedium.hGlobal := HGlobalClone(InStgMedium.hGlobal); - if OutStgMedium.hGlobal = 0 then - Result := E_OUTOFMEMORY; - end - else - // Don't generate a copy just use ourselves and the copy previously saved. - OutStgMedium.unkForRelease := Pointer(DataObject); // Does not increase RefCount. - end; - TYMED_FILE: - begin - Len := lstrLenW(InStgMedium.lpszFileName) + 1; // Don't forget the terminating null character. - OutStgMedium.lpszFileName := CoTaskMemAlloc(2 * Len); - Move(InStgMedium.lpszFileName^, OutStgMedium.lpszFileName^, 2 * Len); - end; - TYMED_ISTREAM: - IUnknown(OutStgMedium.stm)._AddRef; - TYMED_ISTORAGE: - IUnknown(OutStgMedium.stg)._AddRef; - TYMED_GDI: - if not CopyInMedium then - // Don't generate a copy just use ourselves and the previously saved data. - OutStgMedium.unkForRelease := Pointer(DataObject) // Does not increase RefCount. - else - Result := DV_E_TYMED; // Don't know how to copy GDI objects right now. - TYMED_MFPICT: - if not CopyInMedium then - // Don't generate a copy just use ourselves and the previously saved data. - OutStgMedium.unkForRelease := Pointer(DataObject) // Does not increase RefCount. - else - Result := DV_E_TYMED; // Don't know how to copy MetaFile objects right now. - TYMED_ENHMF: - if not CopyInMedium then - // Don't generate a copy just use ourselves and the previously saved data. - OutStgMedium.unkForRelease := Pointer(DataObject) // Does not increase RefCount. - else - Result := DV_E_TYMED; // Don't know how to copy enhanced metafiles objects right now. - else - Result := DV_E_TYMED; - end; - - if (Result = S_OK) and Assigned(OutStgMedium.unkForRelease) then - IUnknown(OutStgMedium.unkForRelease)._AddRef; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDataObject.DAdvise(const FormatEtc: TFormatEtc; advf: Integer; const advSink: IAdviseSink; - out dwConnection: Integer): HResult; - -// Advise sink management is greatly simplified by the IDataAdviseHolder interface. -// We use this interface and forward all concerning calls to it. - -begin - Result := S_OK; - if FAdviseHolder = nil then - Result := CreateDataAdviseHolder(FAdviseHolder); - if Result = S_OK then - Result := FAdviseHolder.Advise(Self as IDataObject, FormatEtc, advf, advSink, dwConnection); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDataObject.DUnadvise(dwConnection: Integer): HResult; - -begin - if FAdviseHolder = nil then - Result := E_NOTIMPL - else - Result := FAdviseHolder.Unadvise(dwConnection); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDataObject.EnumDAdvise(out enumAdvise: IEnumStatData): HResult; - -begin - if FAdviseHolder = nil then - Result := OLE_E_ADVISENOTSUPPORTED - else - Result := FAdviseHolder.EnumAdvise(enumAdvise); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDataObject.EnumFormatEtc(Direction: Integer; out EnumFormatEtc: IEnumFormatEtc): HResult; - -var - NewList: TEnumFormatEtc; - -begin - Result := E_FAIL; - if Direction = DATADIR_GET then - begin - NewList := TEnumFormatEtc.Create(FOwner, FormatEtcArray); - EnumFormatEtc := NewList as IEnumFormatEtc; - Result := S_OK; - end - else - EnumFormatEtc := nil; - if EnumFormatEtc = nil then - Result := OLE_S_USEREG; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDataObject.GetCanonicalFormatEtc(const FormatEtc: TFormatEtc; out FormatEtcOut: TFormatEtc): HResult; - -begin - Result := DATA_S_SAMEFORMATETC; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDataObject.GetData(const FormatEtcIn: TFormatEtc; out Medium: TStgMedium): HResult; - -// Data is requested by clipboard or drop target. This method dispatchs the call -// depending on the data being requested. - -var - I: Integer; - Data: PVTReference; - -begin - // The tree reference format is always supported and returned from here. - if FormatEtcIn.cfFormat = CF_VTREFERENCE then - begin - // Note: this format is not used while flushing the clipboard to avoid a dangling reference - // when the owner tree is destroyed before the clipboard data is replaced with something else. - if tsClipboardFlushing in FOwner.FStates then - Result := E_FAIL - else - begin - Medium.hGlobal := GlobalAlloc(GHND or GMEM_SHARE, SizeOf(TVTReference)); - Data := GlobalLock(Medium.hGlobal); - Data.Process := GetCurrentProcessID; - Data.Tree := FOwner; - GlobalUnlock(Medium.hGlobal); - Medium.tymed := TYMED_HGLOBAL; - Medium.unkForRelease := nil; - Result := S_OK; - end; - end - else - begin - try - // See if we accept this type and if not get the correct return value. - Result := QueryGetData(FormatEtcIn); - if Result = S_OK then - begin - for I := 0 to High(FormatEtcArray) do - begin - if EqualFormatEtc(FormatEtcIn, FormatEtcArray[I]) then - begin - if not RenderInternalOLEData(FormatEtcIn, Medium, Result) then - Result := FOwner.RenderOLEData(FormatEtcIn, Medium, FForClipboard); - Break; - end; - end; - end; - except - ZeroMemory (@Medium, SizeOf(Medium)); - Result := E_FAIL; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDataObject.GetDataHere(const FormatEtc: TFormatEtc; out Medium: TStgMedium): HResult; - -begin - Result := E_NOTIMPL; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDataObject.QueryGetData(const FormatEtc: TFormatEtc): HResult; - -var - I: Integer; - -begin - Result := DV_E_CLIPFORMAT; - for I := 0 to High(FFormatEtcArray) do - begin - if FormatEtc.cfFormat = FFormatEtcArray[I].cfFormat then - begin - if (FormatEtc.tymed and FFormatEtcArray[I].tymed) <> 0 then - begin - if FormatEtc.dwAspect = FFormatEtcArray[I].dwAspect then - begin - if FormatEtc.lindex = FFormatEtcArray[I].lindex then - begin - Result := S_OK; - Break; - end - else - Result := DV_E_LINDEX; - end - else - Result := DV_E_DVASPECT; - end - else - Result := DV_E_TYMED; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDataObject.SetData(const FormatEtc: TFormatEtc; var Medium: TStgMedium; DoRelease: BOOL): HResult; - -// Allows dynamic adding to the IDataObject during its existance. Most noteably it is used to implement -// IDropSourceHelper and allows to set a special format for optimized moves during a shell transfer. - -var - Index: Integer; - LocalStgMedium: PStgMedium; - -begin - // See if we already have a format of that type available. - Index := FindFormatEtc(FormatEtc, FormatEtcArray); - if Index > - 1 then - begin - // Just use the TFormatEct in the array after releasing the data. - LocalStgMedium := FindInternalStgMedium(FormatEtcArray[Index].cfFormat); - if Assigned(LocalStgMedium) then - begin - ReleaseStgMedium(LocalStgMedium^); - ZeroMemory(LocalStgMedium, SizeOf(LocalStgMedium^)); - end; - end - else - begin - // It is a new format so create a new TFormatCollectionItem, copy the - // FormatEtc parameter into the new object and and put it in the list. - SetLength(FFormatEtcArray, Length(FormatEtcArray) + 1); - FormatEtcArray[High(FormatEtcArray)] := FormatEtc; - - // Create a new InternalStgMedium and initialize it and associate it with the format. - SetLength(FInternalStgMediumArray, Length(InternalStgMediumArray) + 1); - InternalStgMediumArray[High(InternalStgMediumArray)].Format := FormatEtc.cfFormat; - LocalStgMedium := @InternalStgMediumArray[High(InternalStgMediumArray)].Medium; - ZeroMemory(LocalStgMedium, SizeOf(LocalStgMedium^)); - end; - - if DoRelease then - begin - // We are simply being given the data and we take control of it. - LocalStgMedium^ := Medium; - Result := S_OK; - end - else - begin - // We need to reference count or copy the data and keep our own references to it. - Result := StgMediumIncRef(Medium, LocalStgMedium^, True, Self as IDataObject); - - // Can get a circular reference if the client calls GetData then calls SetData with the same StgMedium. - // Because the unkForRelease for the IDataObject can be marshalled it is necessary to get pointers that - // can be correctly compared. See the IDragSourceHelper article by Raymond Chen at MSDN. - if Assigned(LocalStgMedium.unkForRelease) then - begin - if CanonicalIUnknown(Self) = CanonicalIUnknown(IUnknown(LocalStgMedium.unkForRelease)) then - IUnknown(LocalStgMedium.unkForRelease) := nil; // release the interface - end; - end; - - // Tell all registered advice sinks about the data change. - if Assigned(FAdviseHolder) then - FAdviseHolder.SendOnDataChange(Self as IDataObject, 0, 0); -end; - -//----------------- TVTDragManager ------------------------------------------------------------------------------------- - -constructor TVTDragManager.Create(AOwner: TBaseVirtualTree); - -begin - inherited Create; - FOwner := AOwner; - - // Create an instance of the drop target helper interface. This will fail but not harm on systems which do - // not support this interface (everything below Windows 2000); - CoCreateInstance(CLSID_DragDropHelper, nil, CLSCTX_INPROC_SERVER, IID_IDropTargetHelper, FDropTargetHelper); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -destructor TVTDragManager.Destroy; - -begin - // Set the owner's reference to us to nil otherwise it will access an invalid pointer - // after our desctruction is complete. - Pointer(FOwner.FDragManager) := nil; - inherited; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDragManager.GetDataObject: IDataObject; - -begin - // When the owner tree starts a drag operation then it gets a data object here to pass it to the OLE subsystem. - // In this case there is no local reference to a data object and one is created (but not stored). - // If there is a local reference then the owner tree is currently the drop target and the stored interface is - // that of the drag initiator. - if Assigned(FDataObject) then - Result := FDataObject - else - begin - Result := FOwner.DoCreateDataObject; - if (Result = nil) and not Assigned(FOwner.OnCreateDataObject) then - // Do not create a TVTDataObject if the event handler explicitely decided not to supply one, issue #736. - Result := TVTDataObject.Create(FOwner, False) as IDataObject; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDragManager.GetDragSource: TBaseVirtualTree; - -begin - Result := FDragSource; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDragManager.GetDropTargetHelperSupported: Boolean; - -begin - Result := Assigned(FDropTargetHelper); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDragManager.GetIsDropTarget: Boolean; - -begin - Result := FIsDropTarget; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDragManager.DragEnter(const DataObject: IDataObject; KeyState: Integer; Pt: TPoint; - var Effect: Integer): HResult; - -begin - FDataObject := DataObject; - FIsDropTarget := True; - - SystemParametersInfo(SPI_GETDRAGFULLWINDOWS, 0, @FFullDragging, 0); - // If full dragging of window contents is disabled in the system then our tree windows will be locked - // and cannot be updated during a drag operation. With the following call painting is again enabled. - if not FFullDragging then - LockWindowUpdate(0); - if Assigned(FDropTargetHelper) and FFullDragging then begin - if toAutoScroll in Self.FOwner.TreeOptions.AutoOptions then - FDropTargetHelper.DragEnter(FOwner.Handle, DataObject, Pt, Effect) - else - FDropTargetHelper.DragEnter(0, DataObject, Pt, Effect);// Do not pass handle, otherwise the IDropTargetHelper will perform autoscroll. Issue #486 - end; - FDragSource := FOwner.GetTreeFromDataObject(DataObject); - Result := FOwner.DragEnter(KeyState, Pt, Effect); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDragManager.DragLeave: HResult; - -begin - if Assigned(FDropTargetHelper) and FFullDragging then - FDropTargetHelper.DragLeave; - - FOwner.DragLeave; - FIsDropTarget := False; - FDragSource := nil; - FDataObject := nil; - Result := NOERROR; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDragManager.DragOver(KeyState: Integer; Pt: TPoint; var Effect: Integer): HResult; - -begin - if Assigned(FDropTargetHelper) and FFullDragging then - FDropTargetHelper.DragOver(Pt, Effect); - - Result := FOwner.DragOver(FDragSource, KeyState, dsDragMove, Pt, Effect); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDragManager.Drop(const DataObject: IDataObject; KeyState: Integer; Pt: TPoint; - var Effect: Integer): HResult; - -begin - if Assigned(FDropTargetHelper) and FFullDragging then - FDropTargetHelper.Drop(DataObject, Pt, Effect); - - Result := FOwner.DragDrop(DataObject, KeyState, Pt, Effect); - FIsDropTarget := False; - FDataObject := nil; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTDragManager.ForceDragLeave; - -// Some drop targets, e.g. Internet Explorer leave a drag image on screen instead removing it when they receive -// a drop action. This method calls the drop target helper's DragLeave method to ensure it removes the drag image from -// screen. Unfortunately, sometimes not even this does help (e.g. when dragging text from VT to a text field in IE). - -begin - if Assigned(FDropTargetHelper) and FFullDragging then - FDropTargetHelper.DragLeave; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDragManager.GiveFeedback(Effect: Integer): HResult; - -begin - Result := DRAGDROP_S_USEDEFAULTCURSORS; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDragManager.QueryContinueDrag(EscapePressed: BOOL; KeyState: Integer): HResult; - -var - RButton, - LButton: Boolean; - -begin - LButton := (KeyState and MK_LBUTTON) <> 0; - RButton := (KeyState and MK_RBUTTON) <> 0; - - // Drag'n drop canceled by pressing both mouse buttons or Esc? - if (LButton and RButton) or EscapePressed then - Result := DRAGDROP_S_CANCEL - else - // Drag'n drop finished? - if not (LButton or RButton) then - Result := DRAGDROP_S_DROP - else - Result := S_OK; -end; - - -//----------------- TVirtualTreeHintWindow ----------------------------------------------------------------------------- - -procedure TVirtualTreeHintWindow.CMTextChanged(var Message: TMessage); - -begin - // swallow this message to prevent the ancestor from resizing the window (we don't use the caption anyway) -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeHintWindow.WMEraseBkgnd(var Message: TWMEraseBkgnd); - -// The control is fully painted by own code so don't erase its background as this causes flickering. - -begin - Message.Result := 1; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeHintWindow.CreateParams(var Params: TCreateParams); - -begin - inherited CreateParams(Params); - - with Params do - begin - Style := WS_POPUP; - ExStyle := ExStyle and not WS_EX_CLIENTEDGE; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeHintWindow.Paint(); -var - R: TRect; - Y: Integer; - S: string; - DrawFormat: Cardinal; - HintKind: TVTHintKind; - LClipRect: TRect; - - LColor: TColor; - LDetails: TThemedElementDetails; - LGradientStart: TColor; - LGradientEnd: TColor; - -begin - with FHintData do - begin - // Do actual painting only in the very first run. - // If the given node is nil then we have to display a header hint. - if (Node = nil) or (Tree.FHintMode <> hmToolTip) then - begin - Canvas.Font := Screen.HintFont; - Canvas.Font.Height := Tree.ScaledPixels(Canvas.Font.Height); - Y := 2; - end - else - begin - Tree.GetTextInfo(Node, Column, Canvas.Font, R, S); - if LineBreakStyle = hlbForceMultiLine then - Y := 1 - else - Y := (R.Top - R.Bottom + Self.Height) div 2; - end; - - R := Rect(0, 0, Width, Height); - - HintKind := vhkText; - if Assigned(Node) then - Tree.DoGetHintKind(Node, Column, HintKind); - - if HintKind = vhkOwnerDraw then - begin - Tree.DoDrawHint(Canvas, Node, R, Column); - end - else - with Canvas do - begin - if Tree.VclStyleEnabled then - begin - InflateRect(R, -1, -1); // Fixes missing border when VCL styles are used - LDetails := StyleServices.GetElementDetails(thHintNormal); - if StyleServices.GetElementColor(LDetails, ecGradientColor1, LColor) and (LColor <> clNone) then - LGradientStart := LColor - else - LGradientStart := clInfoBk; - if StyleServices.GetElementColor(LDetails, ecGradientColor2, LColor) and (LColor <> clNone) then - LGradientEnd := LColor - else - LGradientEnd := clInfoBk; - if StyleServices.GetElementColor(LDetails, ecTextColor, LColor) and (LColor <> clNone) then - Font.Color := LColor - else - Font.Color := Screen.HintFont.Color; - GradientFillCanvas(Canvas, LGradientStart, LGradientEnd, R, gdVertical); - end - else - begin - // Still force tooltip back and text color. - Font.Color := clInfoText; - Pen.Color := clBlack; - Brush.Color := clInfoBk; - if IsWinVistaOrAbove and StyleServices.Enabled and ((toThemeAware in Tree.TreeOptions.PaintOptions) or - (toUseExplorerTheme in Tree.TreeOptions.PaintOptions)) then - begin - if toUseExplorerTheme in Tree.TreeOptions.PaintOptions then // ToolTip style - StyleServices.DrawElement(Canvas.Handle, StyleServices.GetElementDetails(tttStandardNormal), R) - else - begin // Hint style - LClipRect := R; - InflateRect(R, 4, 4); - StyleServices.DrawElement(Handle, StyleServices.GetElementDetails(tttStandardNormal), R, @LClipRect); - R := LClipRect; - StyleServices.DrawEdge(Handle, StyleServices.GetElementDetails(twWindowRoot), R, [eeRaisedOuter], [efRect]); - end; - end - else - if Tree.VclStyleEnabled then - StyleServices.DrawElement(Canvas.Handle, StyleServices.GetElementDetails(tttStandardNormal), R) - else - Rectangle(R); - end; - // Determine text position and don't forget the border. - InflateRect(R, -1, -1); - DrawFormat := DT_TOP or DT_NOPREFIX; - SetBkMode(Handle, Winapi.Windows.TRANSPARENT); - R.Top := Y; - R.Left := R.Left + 3; // Make the text more centered - if Assigned(Node) and (LineBreakStyle = hlbForceMultiLine) then - DrawFormat := DrawFormat or DT_WORDBREAK; - Winapi.Windows.DrawTextW(Handle, PWideChar(HintText), Length(HintText), R, DrawFormat); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeHintWindow.CalcHintRect(MaxWidth: Integer; const AHint: string; AData: Pointer): TRect; - -var - TM: TTextMetric; - R: TRect; - -begin - try - if AData = nil then - // Defensive approach, it *can* happen that AData is nil. Maybe when several user defined hint classes are used. - Result := Rect(0, 0, 0, 0) - else - begin - // The hint window does not need any bidi mode setting but the caller of this method (TApplication.ActivateHint) - // does some unneccessary actions if the hint window is not left-to-right. - // The text alignment is based on the bidi mode passed in the hint data, hence we can - // simply set the window's mode to left-to-right (it might have been modified by the caller, if the - // tree window is right-to-left aligned). - BidiMode := bdLeftToRight; - - FHintData := PVTHintData(AData)^; - - with FHintData do - begin - // The draw tree gets its hint size by the application (but only if not a header hint is about to show). - // If the user will be drawing the hint, it gets its hint size by the application - // (but only if not a header hint is about to show). - // This size has already been determined in CMHintShow. - if Assigned(Node) and (not IsRectEmpty(HintRect)) then - Result := HintRect - else - begin - if Column <= NoColumn then - begin - BidiMode := Tree.BidiMode; - Alignment := Tree.Alignment; - end - else - begin - BidiMode := Tree.Header.Columns[Column].BidiMode; - Alignment := Tree.Header.Columns[Column].Alignment; - end; - - if BidiMode <> bdLeftToRight then - ChangeBidiModeAlignment(Alignment); - - if (Node = nil) or (Tree.FHintMode <> hmToolTip) then - begin - Canvas.Font := Screen.HintFont; - Canvas.Font.Height := Tree.ScaledPixels(Canvas.Font.Height); - end - else - begin - Canvas.Font := Tree.Font; - if Tree is TCustomVirtualStringTree then - with TCustomVirtualStringTree(Tree) do - DoPaintText(Node, Self.Canvas, Column, ttNormal); - end; - - GetTextMetrics(Canvas.Handle, TM); - FTextHeight := TM.tmHeight; - - if Length(HintText) = 0 then - Result := Rect(0, 0, 0, 0) - else - begin - if Assigned(Node) and (Tree.FHintMode = hmToolTip) then - begin - // Determine actual line break style depending on what was returned by the methods and what's in the node. - if LineBreakStyle = hlbDefault then - if vsMultiline in Node.States then - LineBreakStyle := hlbForceMultiLine - else - LineBreakStyle := hlbForceSingleLine; - - // Hint for a node. - if LineBreakStyle = hlbForceMultiLine then - begin - // Multiline tooltips use the columns width but extend the bottom border to fit the whole caption. - Result := Tree.GetDisplayRect(Node, Column, True, False); - R := Result; - - // On Windows NT/2K/XP the behavior of the tooltip is slightly different to that on Windows 9x/Me. - // We don't have Unicode word wrap on the latter so the tooltip gets as wide as the largest line - // in the caption (limited by carriage return), which results in unoptimal overlay of the tooltip. - Winapi.Windows.DrawTextW(Canvas.Handle, PWideChar(HintText), Length(HintText), R, DT_CALCRECT or DT_WORDBREAK); - if BidiMode = bdLeftToRight then - Result.Right := R.Right + Tree.FTextMargin - else - Result.Left := R.Left - Tree.FTextMargin + 1; - Result.Bottom := R.Bottom; - - Inc(Result.Right); - - // If the node height and the column width are both already large enough to cover the entire text, - // then we don't need the hint, though. - // However if the text is partially scrolled out of the client area then a hint is useful as well. - if (Tree.Header.Columns.Count > 0) and ((Integer(Tree.NodeHeight[Node]) + 2) >= (Result.Bottom - Result.Top)) and - ((Tree.Header.Columns[Column].Width + 2) >= (Result.Right - Result.Left)) and not - ((Result.Left < 0) or (Result.Right > Tree.ClientWidth + 3) or - (Result.Top < 0) or (Result.Bottom > Tree.ClientHeight + 3)) then - begin - Result := Rect(0, 0, 0, 0); - Exit; - end; - end - else - begin - Result := Tree.FLastHintRect; // = Tree.GetDisplayRect(Node, Column, True, True, True); see TBaseVirtualTree.CMHintShow - - { Fixes issue #623 - - Measure the rectangle to draw the text. The width of the result - is always adjusted according to the hint text because it may - be a custom hint coming in which can be larger or smaller than - the node text. - Earlier logic was using the current width of the node that was - either cutting off the hint text or producing undesired space - on the right. - } - R := Rect(0, 0, MaxWidth, FTextHeight); - Winapi.Windows.DrawTextW(Canvas.Handle, PWideChar(HintText), Length(HintText), R, DT_CALCRECT or DT_TOP or DT_NOPREFIX or DT_WORDBREAK); - if R.Right <> result.right - result.left then - begin - result.Right := result.Left + r.Right; - - //Space on right--taken from the code in the hmHint branch below. - if Assigned(Tree) then - Inc(Result.Right, Tree.FTextMargin + Tree.FMargin + Tree.ScaledPixels(4)); - end; - // Fix ends. - - if toShowHorzGridLines in Tree.TreeOptions.PaintOptions then - Dec(Result.Bottom); - end; - - // Include a one pixel border. - InflateRect(Result, 1, 1); - - // Make the coordinates relative. They will again be offset by the caller code. - OffsetRect(Result, -Result.Left - 1, -Result.Top - 1); - end - else - begin - // Hint for a header or non-tooltip hint. - - // Start with the base size of the hint in client coordinates. - Result := Rect(0, 0, MaxWidth, FTextHeight); - // Calculate the true size of the text rectangle. - Winapi.Windows.DrawTextW(Canvas.Handle, PWideChar(HintText), Length(HintText), Result, DT_CALCRECT or DT_TOP or DT_NOPREFIX or DT_WORDBREAK); - // The height of the text plus 2 pixels vertical margin plus the border determine the hint window height. - // Minus 4 because THintWindow.ActivateHint adds 4 to Rect.Bottom anyway. Note that it is not scaled because the RTL itself does not do any scaling either. - Inc(Result.Bottom, Tree.ScaledPixels(6) - 4); - // The text is centered horizontally with usual text margin for left and right borders (plus border). - if not Assigned(Tree) then - Exit; // Workaround, because we have seen several exceptions here caught by Eurekalog. Submitted as issue #114 to http://code.google.com/p/virtual-treeview/ - { Issue #623 Fix for strange space on the right. - Original logic was adding FTextHeight. Changed it to add FMargin instead and - it looks OK even if the hint font is larger. - } - Inc(Result.Right, Tree.FTextMargin - + Tree.FMargin + Tree.ScaledPixels(4)); //Issue #623 space on right - //+ FTextHeight); // Old code: We are extending the width here, but the text height scales with the text width and has a similar value as AveCharWdith * 2. - end; - end; - end; - end; - end; - except - Application.HandleException(Self); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeHintWindow.IsHintMsg(var Msg: TMsg): Boolean; - -// The VCL is a bit too generous when telling that an existing hint can be cancelled. Need to specify further here. - -begin - Result := inherited IsHintMsg(Msg) and HandleAllocated and IsWindowVisible(Handle); - // Avoid that mouse moves over the non-client area or cursor key presses cancel the current hint. - if Result and ((Msg.Message = WM_NCMOUSEMOVE) or ((Msg.Message >= WM_KEYFIRST) and (Msg.Message <= WM_KEYLAST) and (Msg.wparam in [VK_UP, VK_DOWN, VK_LEFT, VK_RIGHT]))) then - Result := False; -end; - -//----------------- TVTDragImage --------------------------------------------------------------------------------------- - -constructor TVTDragImage.Create(AOwner: TBaseVirtualTree); - -begin - FOwner := AOwner; - FTransparency := 128; - FPreBlendBias := 0; - FPostBlendBias := 0; - FFade := False; - FRestriction := dmrNone; - FColorKey := clNone; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -destructor TVTDragImage.Destroy; - -begin - EndDrag; - - inherited; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDragImage.GetVisible: Boolean; - -// Returns True if the internal drag image is used (i.e. the system does not natively support drag images) and -// the internal image is currently visible on screen. - -begin - Result := FStates * [disHidden, disInDrag, disPrepared, disSystemSupport] = [disInDrag, disPrepared]; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTDragImage.InternalShowDragImage(ScreenDC: HDC); - -// Frequently called helper routine to actually do the blend and put it onto the screen. -// Only used if the system does not support drag images. - -var - BlendMode: TBlendMode; - -begin - with FAlphaImage do - BitBlt(Canvas.Handle, 0, 0, Width, Height, FBackImage.Canvas.Handle, 0, 0, SRCCOPY); - if not FFade and (FColorKey = clNone) then - BlendMode := bmConstantAlpha - else - BlendMode := bmMasterAlpha; - with FDragImage do - AlphaBlend(Canvas.Handle, FAlphaImage.Canvas.Handle, Rect(0, 0, Width, Height), Point(0, 0), BlendMode, - FTransparency, FPostBlendBias); - - with FAlphaImage do - BitBlt(ScreenDC, FImagePosition.X, FImagePosition.Y, Width, Height, Canvas.Handle, 0, 0, SRCCOPY); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTDragImage.MakeAlphaChannel(Source, Target: TBitmap); - -// Helper method to create a proper alpha channel in Target (which must be in 32 bit pixel format), depending -// on the settings for the drag image and the color values in Source. -// Only used if the system does not support drag images. - -type - PBGRA = ^TBGRA; - TBGRA = packed record - case Boolean of - False: - (Color: Cardinal); - True: - (BGR: array[0..2] of Byte; - Alpha: Byte); - end; - -var - Color, - ColorKeyRef: COLORREF; - UseColorKey: Boolean; - SourceRun, - TargetRun: PBGRA; - X, Y, - MaxDimension, - HalfWidth, - HalfHeight: Integer; - T: Extended; - -begin - UseColorKey := ColorKey <> clNone; - ColorKeyRef := ColorToRGB(ColorKey) and $FFFFFF; - // Color values are in the form BGR (red on LSB) while bitmap colors are in the form ARGB (blue on LSB) - // hence we have to swap red and blue in the color key. - with TBGRA(ColorKeyRef) do - begin - X := BGR[0]; - BGR[0] := BGR[2]; - BGR[2] := X; - end; - - with Target do - begin - MaxDimension := Max(Width, Height); - - HalfWidth := Width div 2; - HalfHeight := Height div 2; - for Y := 0 to Height - 1 do - begin - TargetRun := Scanline[Y]; - SourceRun := Source.Scanline[Y]; - for X := 0 to Width - 1 do - begin - Color := SourceRun.Color and $FFFFFF; - if UseColorKey and (Color = ColorKeyRef) then - TargetRun.Alpha := 0 - else - begin - // If the color is not the given color key (or none is used) then do full calculation of a bell curve. - T := Exp(-8 * Sqrt(Sqr((X - HalfWidth) / MaxDimension) + Sqr((Y - HalfHeight) / MaxDimension))); - TargetRun.Alpha := Round(255 * T); - end; - Inc(SourceRun); - Inc(TargetRun); - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDragImage.DragTo(P: TPoint; ForceRepaint: Boolean): Boolean; - -// Moves the drag image to a new position, which is determined from the passed point P and the previous -// mouse position. -// ForceRepaint is True if something on the screen changed and the back image must be refreshed. - -var - ScreenDC: HDC; - DeltaX, - DeltaY: Integer; - - // optimized drag image move support - RSamp1, - RSamp2, // newly added parts from screen which will be overwritten - RDraw1, - RDraw2, // parts to be restored to screen - RScroll, - RClip: TRect; // ScrollDC of the existent background - -begin - // Determine distances to move the drag image. Take care for restrictions. - case FRestriction of - dmrHorizontalOnly: - begin - DeltaX := FLastPosition.X - P.X; - DeltaY := 0; - end; - dmrVerticalOnly: - begin - DeltaX := 0; - DeltaY := FLastPosition.Y - P.Y; - end; - else // dmrNone - DeltaX := FLastPosition.X - P.X; - DeltaY := FLastPosition.Y - P.Y; - end; - - Result := (DeltaX <> 0) or (DeltaY <> 0) or ForceRepaint; - if Result then - begin - if Visible then - begin - // All this stuff is only called if we have to handle the drag image ourselves. If the system supports - // drag image then this is all never executed. - ScreenDC := GetDC(0); - try - if (Abs(DeltaX) >= FDragImage.Width) or (Abs(DeltaY) >= FDragImage.Height) or ForceRepaint then - begin - // If moved more than image size then just restore old screen and blit image to new position. - BitBlt(ScreenDC, FImagePosition.X, FImagePosition.Y, FBackImage.Width, FBackImage.Height, - FBackImage.Canvas.Handle, 0, 0, SRCCOPY); - - if ForceRepaint then - UpdateWindow(FOwner.Handle); - - Inc(FImagePosition.X, -DeltaX); - Inc(FImagePosition.Y, -DeltaY); - - BitBlt(FBackImage.Canvas.Handle, 0, 0, FBackImage.Width, FBackImage.Height, ScreenDC, FImagePosition.X, - FImagePosition.Y, SRCCOPY); - end - else - begin - // overlapping copy - FillDragRectangles(FDragImage.Width, FDragImage.Height, DeltaX, DeltaY, RClip, RScroll, RSamp1, RSamp2, RDraw1, - RDraw2); - - with FBackImage.Canvas do - begin - // restore uncovered areas of the screen - if DeltaX = 0 then - begin - with TWithSafeRect(RDraw2) do - BitBlt(ScreenDC, FImagePosition.X + Left, FImagePosition.Y + Top, Right, Bottom, Handle, Left, Top, - SRCCOPY); - end - else - begin - if DeltaY = 0 then - begin - with TWithSafeRect(RDraw1) do - BitBlt(ScreenDC, FImagePosition.X + Left, FImagePosition.Y + Top, Right, Bottom, Handle, Left, Top, - SRCCOPY); - end - else - begin - with TWithSafeRect(RDraw1) do - BitBlt(ScreenDC, FImagePosition.X + Left, FImagePosition.Y + Top, Right, Bottom, Handle, Left, Top, - SRCCOPY); - with TWithSafeRect(RDraw2) do - BitBlt(ScreenDC, FImagePosition.X + Left, FImagePosition.Y + Top, Right, Bottom, Handle, Left, Top, - SRCCOPY); - end; - end; - - // move existent background - ScrollDC(Handle, DeltaX, DeltaY, RScroll, RClip, 0, nil); - - Inc(FImagePosition.X, -DeltaX); - Inc(FImagePosition.Y, -DeltaY); - - // Get first and second additional rectangle from screen. - if DeltaX = 0 then - begin - with TWithSafeRect(RSamp2) do - BitBlt(Handle, Left, Top, Right, Bottom, ScreenDC, FImagePosition.X + Left, FImagePosition.Y + Top, - SRCCOPY); - end - else - if DeltaY = 0 then - begin - with TWithSafeRect(RSamp1) do - BitBlt(Handle, Left, Top, Right, Bottom, ScreenDC, FImagePosition.X + Left, FImagePosition.Y + Top, - SRCCOPY); - end - else - begin - with TWithSafeRect(RSamp1) do - BitBlt(Handle, Left, Top, Right, Bottom, ScreenDC, FImagePosition.X + Left, FImagePosition.Y + Top, - SRCCOPY); - with TWithSafeRect(RSamp2) do - BitBlt(Handle, Left, Top, Right, Bottom, ScreenDC, FImagePosition.X + Left, FImagePosition.Y + Top, - SRCCOPY); - end; - end; - end; - InternalShowDragImage(ScreenDC); - finally - ReleaseDC(0, ScreenDC); - end; - end; - FLastPosition.X := P.X; - FLastPosition.Y := P.Y; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTDragImage.EndDrag; - -begin - HideDragImage; - FStates := FStates - [disInDrag, disPrepared]; - - FBackImage.Free; - FBackImage := nil; - FDragImage.Free; - FDragImage := nil; - FAlphaImage.Free; - FAlphaImage := nil; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDragImage.GetDragImageRect: TRect; - -// Returns the current size and position of the drag image (screen coordinates). - -begin - if Visible then - begin - with FBackImage do - Result := Rect(FImagePosition.X, FImagePosition.Y, FImagePosition.X + Width, FImagePosition.Y + Height); - end - else - Result := Rect(0, 0, 0, 0); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTDragImage.HideDragImage; - -var - ScreenDC: HDC; - -begin - if Visible then - begin - Include(FStates, disHidden); - ScreenDC := GetDC(0); - try - // restore screen - with FBackImage do - BitBlt(ScreenDC, FImagePosition.X, FImagePosition.Y, Width, Height, Canvas.Handle, 0, 0, SRCCOPY); - finally - ReleaseDC(0, ScreenDC); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTDragImage.PrepareDrag(DragImage: TBitmap; ImagePosition, HotSpot: TPoint; const DataObject: IDataObject); - -// Creates all necessary structures to do alpha blended dragging using the given image. -// ImagePostion and HotSpot are given in screen coordinates. The first determines where to place the drag image while -// the second is the initial mouse position. -// This method also determines whether the system supports drag images natively. If so then only minimal structures -// are created. - -var - Width, - Height: Integer; - DragSourceHelper: IDragSourceHelper; - DragInfo: TSHDragImage; - lDragSourceHelper2: IDragSourceHelper2;// Needed to get Windows Vista+ style drag hints. - lNullPoint: TPoint; -begin - Width := DragImage.Width; - Height := DragImage.Height; - - // Determine whether the system supports the drag helper interfaces. - if Assigned(DataObject) and Succeeded(CoCreateInstance(CLSID_DragDropHelper, nil, CLSCTX_INPROC_SERVER, - IDragSourceHelper, DragSourceHelper)) then - begin - Include(FStates, disSystemSupport); - lNullPoint := Point(0,0); - if Supports(DragSourceHelper, IDragSourceHelper2, lDragSourceHelper2) then - lDragSourceHelper2.SetFlags(DSH_ALLOWDROPDESCRIPTIONTEXT);// Show description texts - // First let the system try to initialze the DragSourceHelper, this works fine for file system objects (CF_HDROP) - StandardOLEFormat.cfFormat := CF_HDROP; - if not Succeeded(DataObject.QueryGetData(StandardOLEFormat)) or not Succeeded(DragSourceHelper.InitializeFromWindow(0, lNullPoint, DataObject)) then - begin - // Supply the drag source helper with our drag image. - DragInfo.sizeDragImage.cx := Width; - DragInfo.sizeDragImage.cy := Height; - DragInfo.ptOffset.x := Width div 2; - DragInfo.ptOffset.y := Height div 2; - DragInfo.hbmpDragImage := CopyImage(DragImage.Handle, IMAGE_BITMAP, Width, Height, LR_COPYRETURNORG); - DragInfo.crColorKey := ColorToRGB(FColorKey); - if not Succeeded(DragSourceHelper.InitializeFromBitmap(@DragInfo, DataObject)) then - begin - DeleteObject(DragInfo.hbmpDragImage); - Exclude(FStates, disSystemSupport); - end; - end; - end - else - Exclude(FStates, disSystemSupport); - - if not (disSystemSupport in FStates) then - begin - FLastPosition := HotSpot; - - FDragImage := TBitmap.Create; - FDragImage.PixelFormat := pf32Bit; - FDragImage.SetSize(Width, Height); - - FAlphaImage := TBitmap.Create; - FAlphaImage.PixelFormat := pf32Bit; - FAlphaImage.SetSize(Width, Height); - - FBackImage := TBitmap.Create; - FBackImage.PixelFormat := pf32Bit; - FBackImage.SetSize(Width, Height); - - // Copy the given drag image and apply pre blend bias if required. - if FPreBlendBias = 0 then - with FDragImage do - BitBlt(Canvas.Handle, 0, 0, Width, Height, DragImage.Canvas.Handle, 0, 0, SRCCOPY) - else - AlphaBlend(DragImage.Canvas.Handle, FDragImage.Canvas.Handle, Rect(0, 0, Width, Height), Point(0, 0), - bmConstantAlpha, 255, FPreBlendBias); - - // Create a proper alpha channel also if no fading is required (transparent parts). - MakeAlphaChannel(DragImage, FDragImage); - - FImagePosition := ImagePosition; - - // Initially the drag image is hidden and will be shown during the immediately following DragEnter event. - FStates := FStates + [disInDrag, disHidden, disPrepared]; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTDragImage.RecaptureBackground(Tree: TBaseVirtualTree; R: TRect; VisibleRegion: HRGN; - CaptureNCArea, ReshowDragImage: Boolean); - -// Notification by the drop target tree to update the background image because something in the tree has changed. -// Note: The passed rectangle is given in client coordinates of the current drop target tree (given in Tree). -// The caller does not check if the given rectangle is actually within the drag image. Hence this method must do -// all the checks. -// This method does nothing if the system manages the drag image. - -var - DragRect, - ClipRect: TRect; - PaintTarget: TPoint; - PaintOptions: TVTInternalPaintOptions; - ScreenDC: HDC; - -begin - // Recapturing means we want the tree to paint the new part into our back bitmap instead to the screen. - if Visible then - begin - // Create the minimum rectangle to be recaptured. - MapWindowPoints(Tree.Handle, 0, R, 2); - DragRect := GetDragImageRect; - IntersectRect(R, R, DragRect); - - OffsetRgn(VisibleRegion, -DragRect.Left, -DragRect.Top); - - // The target position for painting in the drag image is relative and can be determined from screen coordinates too. - PaintTarget.X := R.Left - DragRect.Left; - PaintTarget.Y := R.Top - DragRect.Top; - - // The source rectangle is determined by the offsets in the tree. - MapWindowPoints(0, Tree.Handle, R, 2); - OffsetRect(R, -Tree.FOffsetX, -Tree.FOffsetY); - - // Finally let the tree paint the relevant part and upate the drag image on screen. - PaintOptions := [poBackground, poColumnColor, poDrawFocusRect, poDrawDropMark, poDrawSelection, poGridLines]; - with FBackImage do - begin - ClipRect.TopLeft := PaintTarget; - ClipRect.Right := ClipRect.Left + R.Right - R.Left; - ClipRect.Bottom := ClipRect.Top + R.Bottom - R.Top; - // TODO: somehow with clipping, the background image is not drawn on the - // backup image. Need to be diagnosed and fixed. For now, we have coded - // a work around in DragTo where this is used by using the condition - // IsInHeader. (found when solving issue 248) - ClipCanvas(Canvas, ClipRect, VisibleRegion); - Tree.PaintTree(Canvas, R, PaintTarget, PaintOptions); - - if CaptureNCArea then - begin - // Header is painted in this part only so when you use this routine and want - // to capture the header in backup image, this flag should be ON. - // For the non-client area we only need the visible region of the window as limit for painting. - SelectClipRgn(Canvas.Handle, VisibleRegion); - // Since WM_PRINT cannot be given a position where to draw we simply move the window origin and - // get the same effect. - GetWindowRect(Tree.Handle, ClipRect); - SetCanvasOrigin(Canvas, DragRect.Left - ClipRect.Left, DragRect.Top - ClipRect.Top); - Tree.Perform(WM_PRINT, WPARAM(Canvas.Handle), PRF_NONCLIENT); - SetCanvasOrigin(Canvas, 0, 0); - end; - SelectClipRgn(Canvas.Handle, 0); - - if ReshowDragImage then - begin - GDIFlush; - ScreenDC := GetDC(0); - try - InternalShowDragImage(ScreenDC); - finally - ReleaseDC(0, ScreenDC); - end; - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTDragImage.ShowDragImage; - -// Shows the drag image after it has been hidden by HideDragImage. -// Note: there might be a new background now. -// Also this method does nothing if the system manages the drag image. - -var - ScreenDC: HDC; - -begin - if FStates * [disInDrag, disHidden, disPrepared, disSystemSupport] = [disInDrag, disHidden, disPrepared] then - begin - Exclude(FStates, disHidden); - - GDIFlush; - ScreenDC := GetDC(0); - try - BitBlt(FBackImage.Canvas.Handle, 0, 0, FBackImage.Width, FBackImage.Height, ScreenDC, FImagePosition.X, - FImagePosition.Y, SRCCOPY); - - InternalShowDragImage(ScreenDC); - finally - ReleaseDC(0, ScreenDC); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDragImage.WillMove(P: TPoint): Boolean; - -// This method determines whether the drag image would "physically" move when DragTo would be called with the same -// target point. -// Always returns False if the system drag image support is available. - -begin - Result := Visible; - if Result then - begin - // Determine distances to move the drag image. Take care for restrictions. - case FRestriction of - dmrHorizontalOnly: - Result := FLastPosition.X <> P.X; - dmrVerticalOnly: - Result := FLastPosition.Y <> P.Y; - else // dmrNone - Result := (FLastPosition.X <> P.X) or (FLastPosition.Y <> P.Y); - end; - end; -end; - -//----------------- TVTVirtualNodeEnumerator --------------------------------------------------------------------------- - -function TVTVirtualNodeEnumerator.GetCurrent: PVirtualNode; - -begin - Result := FNode; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTVirtualNodeEnumerator.MoveNext: Boolean; - -begin - Result := FCanMoveNext; - if Result then - begin - FNode := FEnumeration.GetNext(FNode); - Result := FNode <> nil; - FCanMoveNext := Result; - end; -end; - -//----------------- TVTVirtualNodeEnumeration -------------------------------------------------------------------------- - -function TVTVirtualNodeEnumeration.GetEnumerator: TVTVirtualNodeEnumerator; - -begin - Result.FNode := nil; - Result.FCanMoveNext := True; - Result.FEnumeration := @Self; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTVirtualNodeEnumeration.GetNext(Node: PVirtualNode): PVirtualNode; -begin - case FMode of - vneAll: - if Node = nil then - Result := FTree.GetFirst(FConsiderChildrenAbove) - else - Result := FTree.GetNext(Node, FConsiderChildrenAbove); - - vneChecked: - if Node = nil then - Result := FTree.GetFirstChecked(FState, FConsiderChildrenAbove) - else - Result := FTree.GetNextChecked(Node, FState, FConsiderChildrenAbove); - - vneChild: - if Node = nil then - Result := FTree.GetFirstChild(FNode) - else - Result := FTree.GetNextSibling(Node); - - vneCutCopy: - if Node = nil then - Result := FTree.GetFirstCutCopy(FConsiderChildrenAbove) - else - Result := FTree.GetNextCutCopy(Node, FConsiderChildrenAbove); - - vneInitialized: - if Node = nil then - Result := FTree.GetFirstInitialized(FConsiderChildrenAbove) - else - Result := FTree.GetNextInitialized(Node, FConsiderChildrenAbove); - - vneLeaf: - if Node = nil then - Result := FTree.GetFirstLeaf - else - Result := FTree.GetNextLeaf(Node); - - vneLevel: - if Node = nil then - Result := FTree.GetFirstLevel(FNodeLevel) - else - Result := FTree.GetNextLevel(Node, FNodeLevel); - - vneNoInit: - if Node = nil then - Result := FTree.GetFirstNoInit(FConsiderChildrenAbove) - else - Result := FTree.GetNextNoInit(Node, FConsiderChildrenAbove); - - vneSelected: - if Node = nil then - Result := FTree.GetFirstSelected(FConsiderChildrenAbove) - else - Result := FTree.GetNextSelected(Node, FConsiderChildrenAbove); - - vneVisible: - begin - if Node = nil then - begin - Result := FTree.GetFirstVisible(FNode, FConsiderChildrenAbove, FIncludeFiltered); - if FIncludeFiltered or not FTree.IsEffectivelyFiltered[Result] then - Exit; - end; - repeat - Result := FTree.GetNextVisible(Node{, FConsiderChildrenAbove}); - until not Assigned(Result) or FIncludeFiltered or not FTree.IsEffectivelyFiltered[Result]; - end; - - vneVisibleChild: - if Node = nil then - Result := FTree.GetFirstVisibleChild(FNode, FIncludeFiltered) - else - Result := FTree.GetNextVisibleSibling(Node, FIncludeFiltered); - - vneVisibleNoInitChild: - if Node = nil then - Result := FTree.GetFirstVisibleChildNoInit(FNode, FIncludeFiltered) - else - Result := FTree.GetNextVisibleSiblingNoInit(Node, FIncludeFiltered); - - vneVisibleNoInit: - begin - if Node = nil then - begin - Result := FTree.GetFirstVisibleNoInit(FNode, FConsiderChildrenAbove, FIncludeFiltered); - if FIncludeFiltered or not FTree.IsEffectivelyFiltered[Result] then - Exit; - end; - repeat - Result := FTree.GetNextVisibleNoInit(Node, FConsiderChildrenAbove); - until not Assigned(Result) or FIncludeFiltered or not FTree.IsEffectivelyFiltered[Result]; - end; - else - Result := nil; - end; -end; - -//----------------- TVirtualTreeColumn --------------------------------------------------------------------------------- - -constructor TVirtualTreeColumn.Create(Collection: TCollection); - -begin - FMinWidth := 10; - FMaxWidth := 10000; - FImageIndex := -1; - FMargin := 4; - FSpacing := cDefaultColumnSpacing; - FText := ''; - FOptions := DefaultColumnOptions; - FAlignment := taLeftJustify; - FBiDiMode := bdLeftToRight; - FColor := clWindow; - FLayout := blGlyphLeft; - FBonusPixel := False; - FCaptionAlignment := taLeftJustify; - FCheckType := ctCheckBox; - FCheckState := csUncheckedNormal; - FCheckBox := False; - FHasImage := False; - FDefaultSortDirection := sdAscending; - fEditNextColumn := -1; - - inherited Create(Collection); - - if Assigned(Owner) then begin - FWidth := Owner.FDefaultWidth; - FLastWidth := Owner.FDefaultWidth; - FPosition := Owner.Count - 1; - end; -end; - -procedure TVirtualTreeColumn.SetCollection(Value: TCollection); -begin - inherited; - // Read parent bidi mode and color values as default values. - ParentBiDiModeChanged; - ParentColorChanged; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -destructor TVirtualTreeColumn.Destroy; - -var - I: Integer; - - //--------------- local function --------------------------------------------- - - procedure AdjustColumnIndex(var ColumnIndex: TColumnIndex); - - begin - if Index = ColumnIndex then - ColumnIndex := NoColumn - else - if Index < ColumnIndex then - Dec(ColumnIndex); - end; - - //--------------- end local function ----------------------------------------- - -begin - // Check if this column is somehow referenced by its collection parent or the header. - with Owner do - begin - // If the columns collection object is currently deleting all columns - // then we don't need to check the various cached indices individually. - if not FClearing then - begin - Header.Treeview.CancelEditNode; - IndexChanged(Index, -1); - - AdjustColumnIndex(FHoverIndex); - AdjustColumnIndex(FDownIndex); - AdjustColumnIndex(FTrackIndex); - AdjustColumnIndex(FClickIndex); - - with Header do - begin - AdjustColumnIndex(FAutoSizeIndex); - if Index = FMainColumn then - begin - // If the current main column is about to be destroyed then we have to find a new main column. - FMainColumn := NoColumn; - for I := 0 to Count - 1 do - if I <> Index then - begin - FMainColumn := I; - Break; - end; - end; - AdjustColumnIndex(FSortColumn); - end; - end; - end; - - inherited; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumn.GetCaptionAlignment: TAlignment; - -begin - if coUseCaptionAlignment in FOptions then - Result := FCaptionAlignment - else - Result := FAlignment; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumn.GetCaptionWidth: TDimension; -var - Theme: HTHEME; - AdvancedOwnerDraw: Boolean; - PaintInfo: THeaderPaintInfo; - RequestedElements: THeaderPaintElements; - - TextSize: TSize; - HeaderGlyphSize: TPoint; - UseText: Boolean; - R: TRect; -begin - AdvancedOwnerDraw := (hoOwnerDraw in Owner.FHeader.FOptions) and Assigned(Owner.FHeader.Treeview.FOnAdvancedHeaderDraw) and Assigned(Owner.FHeader.Treeview.FOnHeaderDrawQueryElements) and - not(csDesigning in Owner.FHeader.Treeview.ComponentState); - - PaintInfo.Column := Self; - PaintInfo.TargetCanvas := Owner.FHeaderBitmap.Canvas; - - with PaintInfo, Column do - begin - ShowHeaderGlyph := (hoShowImages in Owner.FHeader.FOptions) and ((Assigned(Owner.FHeader.FImages) and (FImageIndex > -1)) or FCheckBox); - ShowSortGlyph := ((Owner.FHeader.FSortColumn > -1) and (Self = Owner.Items[Owner.FHeader.FSortColumn])) and (hoShowSortGlyphs in Owner.FHeader.FOptions); - - // This path for text columns or advanced owner draw. - // See if the application wants to draw part of the header itself. - RequestedElements := []; - if AdvancedOwnerDraw then - begin - PaintInfo.Column := Self; - Owner.FHeader.Treeview.DoHeaderDrawQueryElements(PaintInfo, RequestedElements); - end; - end; - - UseText := Length(FText) > 0; - // If nothing is to show then don't waste time with useless preparation. - if not(UseText or PaintInfo.ShowHeaderGlyph or PaintInfo.ShowSortGlyph) then - Exit(0); - - // Calculate sizes of the involved items. - with Owner, Header do - begin - if PaintInfo.ShowHeaderGlyph then - if not FCheckBox then - begin - if Assigned(FImages) then - HeaderGlyphSize := Point(FImages.Width, FImages.Height); - end - else - with Self.Owner.Header.Treeview do - begin - if Assigned(FCheckImages) then - HeaderGlyphSize := Point(FCheckImages.Width, FCheckImages.Height); - end - else - HeaderGlyphSize := Point(0, 0); - if PaintInfo.ShowSortGlyph then - begin - if tsUseExplorerTheme in FHeader.Treeview.FStates then - begin - R := Rect(0, 0, 100, 100); - Theme := OpenThemeData(FHeader.Treeview.Handle, 'HEADER'); - GetThemePartSize(Theme, PaintInfo.TargetCanvas.Handle, HP_HEADERSORTARROW, HSAS_SORTEDUP, @R, TS_TRUE, PaintInfo.SortGlyphSize); - CloseThemeData(Theme); - end - else - begin - PaintInfo.SortGlyphSize.cx := Header.Treeview.ScaledPixels(16); - PaintInfo.SortGlyphSize.cy := Header.Treeview.ScaledPixels(4); - end; - end - else - begin - PaintInfo.SortGlyphSize.cx := 0; - PaintInfo.SortGlyphSize.cy := 0; - end; - end; - - if UseText then - begin - GetTextExtentPoint32W(PaintInfo.TargetCanvas.Handle, PWideChar(FText), Length(FText), TextSize); - Inc(TextSize.cx, 2); - end - else - begin - TextSize.cx := 0; - TextSize.cy := 0; - end; - - // if CalculateTextRect then - Result := TextSize.cx; - if PaintInfo.ShowHeaderGlyph then - if Layout in [blGlyphLeft, blGlyphRight] then - Inc(Result, HeaderGlyphSize.X + FSpacing) - else // if Layout in [ blGlyphTop, blGlyphBottom] then - Result := Max(Result, HeaderGlyphSize.X); - if PaintInfo.ShowSortGlyph then - Inc(Result, PaintInfo.SortGlyphSize.cx + FSpacing + 2); // without this +2, there is a slight movement of the sort glyph when expanding the column - -end; -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumn.GetLeft: Integer; - -begin - Result := FLeft; - if [coVisible, coFixed] * FOptions <> [coVisible, coFixed] then - Dec(Result, Owner.Header.Treeview.FEffectiveOffsetX); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumn.IsBiDiModeStored: Boolean; - -begin - Result := not (coParentBiDiMode in FOptions); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumn.IsCaptionAlignmentStored: Boolean; - -begin - Result := coUseCaptionAlignment in FOptions; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumn.IsColorStored: Boolean; - -begin - Result := not (coParentColor in FOptions); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.SetAlignment(const Value: TAlignment); - -begin - if FAlignment <> Value then - begin - FAlignment := Value; - Changed(False); - // Setting the alignment affects also the tree, hence invalidate it too. - Owner.Header.TreeView.Invalidate; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.SetBiDiMode(Value: TBiDiMode); - -begin - if Value <> FBiDiMode then - begin - FBiDiMode := Value; - Exclude(FOptions, coParentBiDiMode); - Changed(False); - // Setting the alignment affects also the tree, hence invalidate it too. - Owner.Header.TreeView.Invalidate; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.SetCaptionAlignment(const Value: TAlignment); - -begin - if not (coUseCaptionAlignment in FOptions) or (FCaptionAlignment <> Value) then - begin - FCaptionAlignment := Value; - Include(FOptions, coUseCaptionAlignment); - // Setting the alignment affects also the tree, hence invalidate it too. - Owner.Header.Invalidate(Self); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.SetColor(const Value: TColor); - -begin - if FColor <> Value then - begin - FColor := Value; - Exclude(FOptions, coParentColor); - Exclude(FOptions, coStyleColor); // Issue #919 - Changed(False); - Owner.Header.TreeView.Invalidate; - end; -end; - -function TVirtualTreeColumn.GetEffectiveColor(): TColor; -// Returns the color that should effectively be used as background color for this -// column considering all flags in the TVirtualTreeColumn.Options property -begin - if (coParentColor in Options) or ((coStyleColor in Options) and Owner.Header.TreeView.VclStyleEnabled) then - Result := Owner.Header.TreeView.FColors.BackGroundColor - else - Result := Self.Color; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.SetCheckBox(Value: Boolean); - -begin - if Value <> FCheckBox then - begin - FCheckBox := Value; - if Value and (csDesigning in Owner.Header.Treeview.ComponentState) then - Owner.Header.Options := Owner.Header.Options + [hoShowImages]; - Changed(False); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.SetCheckState(Value: TCheckState); - -begin - if Value <> FCheckState then - begin - FCheckState := Value; - Changed(False); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.SetCheckType(Value: TCheckType); - -begin - if Value <> FCheckType then - begin - FCheckType := Value; - Changed(False); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.SetImageIndex(Value: TImageIndex); - -begin - if Value <> FImageIndex then - begin - FImageIndex := Value; - Changed(False); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.SetLayout(Value: TVTHeaderColumnLayout); - -begin - if FLayout <> Value then - begin - FLayout := Value; - Changed(False); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.SetMargin(Value: Integer); - -begin - // Compatibility setting for -1. - if Value < 0 then - Value := 4; - if FMargin <> Value then - begin - FMargin := Value; - Changed(False); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.SetMaxWidth(Value: Integer); - -begin - if Value < FMinWidth then - Value := FMinWidth; - FMaxWidth := Value; - SetWidth(FWidth); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.SetMinWidth(Value: Integer); - -begin - if Value < 0 then - Value := 0; - if Value > FMaxWidth then - Value := FMaxWidth; - FMinWidth := Value; - SetWidth(FWidth); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.SetOptions(Value: TVTColumnOptions); - -var - ToBeSet, - ToBeCleared: TVTColumnOptions; - VisibleChanged, - lParentColorSet: Boolean; - lTreeView: TBaseVirtualTree; -begin - if FOptions <> Value then - begin - ToBeCleared := FOptions - Value; - ToBeSet := Value - FOptions; - - FOptions := Value; - - VisibleChanged := coVisible in (ToBeSet + ToBeCleared); - lParentColorSet := coParentColor in ToBeSet; - - if coParentBidiMode in ToBeSet then - ParentBiDiModeChanged; - if lParentColorSet then begin - Include(FOptions, coStyleColor);// Issue #919 - ParentColorChanged(); - end; - - if coAutoSpring in ToBeSet then - FSpringRest := 0; - - if ((coFixed in ToBeSet) or (coFixed in ToBeCleared)) and (coVisible in FOptions) then - Owner.Header.RescaleHeader; - - Changed(False); - // Need to repaint and adjust the owner tree too. - lTreeView := Owner.Header.Treeview; - if not (csLoading in lTreeview.ComponentState) and (VisibleChanged or lParentColorSet) and (Owner.UpdateCount = 0) and lTreeView.HandleAllocated then - begin - lTreeview.Invalidate(); - if VisibleChanged then begin - lTreeview.DoColumnVisibilityChanged(Self.Index, coVisible in ToBeSet); - lTreeview.UpdateHorizontalScrollBar(False); - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.SetPosition(Value: TColumnPosition); - -var - Temp: TColumnIndex; - -begin - if (csLoading in Owner.Header.Treeview.ComponentState) or (Owner.UpdateCount > 0) then - // Only cache the position for final fixup when loading from DFM. - FPosition := Value - else - begin - if Value >= TColumnPosition(Collection.Count) then - Value := Collection.Count - 1; - if FPosition <> Value then - begin - with Owner do - begin - InitializePositionArray; - Header.Treeview.CancelEditNode; - AdjustPosition(Self, Value); - Self.Changed(False); - - // Need to repaint. - with Header do - begin - if (UpdateCount = 0) and Treeview.HandleAllocated then - begin - Invalidate(Self); - Treeview.Invalidate; - end; - end; - end; - - // If the moved column is now within the fixed columns then we make it fixed as well. If it's not - // we clear the fixed state (in case that fixed column is moved outside fixed area). - if (coFixed in FOptions) and (FPosition > 0) then - Temp := Owner.ColumnFromPosition(FPosition - 1) - else - Temp := Owner.ColumnFromPosition(FPosition + 1); - - if Temp <> NoColumn then - begin - if coFixed in Owner[Temp].Options then - Options := Options + [coFixed] - else - Options := Options - [coFixed]; - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.SetSpacing(Value: Integer); - -begin - if FSpacing <> Value then - begin - FSpacing := Value; - Changed(False); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.SetStyle(Value: TVirtualTreeColumnStyle); - -begin - if FStyle <> Value then - begin - FStyle := Value; - Changed(False); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.SetText(const Value: string); - -begin - if FText <> Value then - begin - FText := Value; - FCaptionText := ''; - Changed(False); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.SetWidth(Value: Integer); - -var - EffectiveMaxWidth, - EffectiveMinWidth, - TotalFixedMaxWidth, - TotalFixedMinWidth: Integer; - I: TColumnIndex; - -begin - if not (hsScaling in Owner.FHeader.FStates) then - if ([coVisible, coFixed] * FOptions = [coVisible, coFixed]) then - begin - with Owner, FHeader, FFixedAreaConstraints, TreeView do - begin - TotalFixedMinWidth := 0; - TotalFixedMaxWidth := 0; - for I := 0 to FColumns.Count - 1 do - if ([coVisible, coFixed] * FColumns[I].FOptions = [coVisible, coFixed]) then - begin - Inc(TotalFixedMaxWidth, FColumns[I].FMaxWidth); - Inc(TotalFixedMinWidth, FColumns[I].FMinWidth); - end; - - // The percentage values have precedence over the pixel values. - If FMaxWidthPercent > 0 then - TotalFixedMinWidth:= Min((ClientWidth * FMaxWidthPercent) div 100, TotalFixedMinWidth); - If FMinWidthPercent > 0 then - TotalFixedMaxWidth := Max((ClientWidth * FMinWidthPercent) div 100, TotalFixedMaxWidth); - - EffectiveMaxWidth := Min(TotalFixedMaxWidth - (GetVisibleFixedWidth - Self.FWidth), FMaxWidth); - EffectiveMinWidth := Max(TotalFixedMinWidth - (GetVisibleFixedWidth - Self.FWidth), FMinWidth); - Value := Min(Max(Value, EffectiveMinWidth), EffectiveMaxWidth); - - if FMinWidthPercent > 0 then - Value := Max((ClientWidth * FMinWidthPercent) div 100 - GetVisibleFixedWidth + Self.FWidth, Value); - if FMaxWidthPercent > 0 then - Value := Min((ClientWidth * FMaxWidthPercent) div 100 - GetVisibleFixedWidth + Self.FWidth, Value); - end; - end - else - Value := Min(Max(Value, FMinWidth), FMaxWidth); - - if FWidth <> Value then - begin - FLastWidth := FWidth; - if not (hsResizing in Owner.Header.States) then - FBonusPixel := False; - if not (hoAutoResize in Owner.Header.Options) or (Index <> Owner.Header.AutoSizeIndex) then - begin - FWidth := Value; - Owner.UpdatePositions; - end; - if not (csLoading in Owner.Header.Treeview.ComponentState) and (Owner.UpdateCount = 0) then - begin - if hoAutoResize in Owner.Header.Options then - Owner.AdjustAutoSize(Index); - Owner.Header.Treeview.DoColumnResize(Index); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.ComputeHeaderLayout(var PaintInfo: THeaderPaintInfo; DrawFormat: Cardinal; CalculateTextRect: Boolean = False); - -// The layout of a column header is determined by a lot of factors. This method takes them all into account and -// determines all necessary positions and bounds: -// - for the header text -// - the header glyph -// - the sort glyph - -var - TextSize: TSize; - TextPos, - ClientSize, - HeaderGlyphSize: TPoint; - CurrentAlignment: TAlignment; - MinLeft, - MaxRight, - TextSpacing: Integer; - UseText: Boolean; - R: TRect; - Theme: HTHEME; - -begin - UseText := Length(FText) > 0; - // If nothing is to show then don't waste time with useless preparation. - if not (UseText or PaintInfo.ShowHeaderGlyph or PaintInfo.ShowSortGlyph) then - Exit; - - CurrentAlignment := CaptionAlignment; - if FBiDiMode <> bdLeftToRight then - ChangeBiDiModeAlignment(CurrentAlignment); - - // Calculate sizes of the involved items. - ClientSize := Point(PaintInfo.PaintRectangle.Right - PaintInfo.PaintRectangle.Left, PaintInfo.PaintRectangle.Bottom - PaintInfo.PaintRectangle.Top); - with Owner, Header do - begin - if PaintInfo.ShowHeaderGlyph then - if not FCheckBox then - HeaderGlyphSize := Point(FImages.Width, FImages.Height) - else - with Self.Owner.Header.Treeview do - begin - if Assigned(FCheckImages) then - HeaderGlyphSize := Point(FCheckImages.Width, FCheckImages.Height); - end - else - HeaderGlyphSize := Point(0, 0); - if PaintInfo.ShowSortGlyph then - begin - if tsUseExplorerTheme in FHeader.Treeview.FStates then - begin - R := Rect(0, 0, 100, 100); - Theme := OpenThemeData(FHeader.Treeview.Handle, 'HEADER'); - GetThemePartSize(Theme, PaintInfo.TargetCanvas.Handle, HP_HEADERSORTARROW, HSAS_SORTEDUP, @R, TS_TRUE, PaintInfo.SortGlyphSize); - CloseThemeData(Theme); - end - else - begin - PaintInfo.SortGlyphSize.cx := Header.Treeview.ScaledPixels(16); - PaintInfo.SortGlyphSize.cy := Header.Treeview.ScaledPixels(4); - end; - - // In any case, the sort glyph is vertically centered. - PaintInfo.SortGlyphPos.Y := (ClientSize.Y - PaintInfo.SortGlyphSize.cy) div 2; - end - else - begin - PaintInfo.SortGlyphSize.cx := 0; - PaintInfo.SortGlyphSize.cy := 0; - end; - end; - - if UseText then - begin - if not (coWrapCaption in FOptions) then - begin - FCaptionText := FText; - GetTextExtentPoint32W(PaintInfo.TargetCanvas.Handle, PWideChar(FText), Length(FText), TextSize); - Inc(TextSize.cx, 2); - PaintInfo.TextRectangle := Rect(0, 0, TextSize.cx, TextSize.cy); - end - else - begin - R := PaintInfo.PaintRectangle; - if FCaptionText = '' then - FCaptionText := WrapString(PaintInfo.TargetCanvas.Handle, FText, R, DT_RTLREADING and DrawFormat <> 0, DrawFormat); - - GetStringDrawRect(PaintInfo.TargetCanvas.Handle, FCaptionText, R, DrawFormat); - TextSize.cx := PaintInfo.PaintRectangle.Right - PaintInfo.PaintRectangle.Left; - TextSize.cy := R.Bottom - R.Top; - PaintInfo.TextRectangle := Rect(0, 0, TextSize.cx, TextSize.cy); - end; - TextSpacing := FSpacing; - end - else - begin - TextSpacing := 0; - TextSize.cx := 0; - TextSize.cy := 0; - end; - - // Check first for the special case where nothing is shown except the sort glyph. - if PaintInfo.ShowSortGlyph and not (UseText or PaintInfo.ShowHeaderGlyph) then - begin - // Center the sort glyph in the available area if nothing else is there. - PaintInfo.SortGlyphPos := Point((ClientSize.X - PaintInfo.SortGlyphSize.cx) div 2, (ClientSize.Y - PaintInfo.SortGlyphSize.cy) div 2); - end - else - begin - // Determine extents of text and glyph and calculate positions which are clear from the layout. - if (Layout in [blGlyphLeft, blGlyphRight]) or not PaintInfo.ShowHeaderGlyph then - begin - PaintInfo.GlyphPos.Y := (ClientSize.Y - HeaderGlyphSize.Y) div 2; - // If the text is taller than the given height, perform no vertical centration as this - // would make the text even less readable. - //Using Max() fixes badly positioned text if Extra Large fonts have been activated in the Windows display options - TextPos.Y := Max(-5, (ClientSize.Y - TextSize.cy) div 2); - end - else - begin - if Layout = blGlyphTop then - begin - PaintInfo.GlyphPos.Y := (ClientSize.Y - HeaderGlyphSize.Y - TextSize.cy - TextSpacing) div 2; - TextPos.Y := PaintInfo.GlyphPos.Y + HeaderGlyphSize.Y + TextSpacing; - end - else - begin - TextPos.Y := (ClientSize.Y - HeaderGlyphSize.Y - TextSize.cy - TextSpacing) div 2; - PaintInfo.GlyphPos.Y := TextPos.Y + TextSize.cy + TextSpacing; - end; - end; - - // Each alignment needs special consideration. - case CurrentAlignment of - taLeftJustify: - begin - MinLeft := FMargin; - if PaintInfo.ShowSortGlyph and (FBiDiMode <> bdLeftToRight) then - begin - // In RTL context is the sort glyph placed on the left hand side. - PaintInfo.SortGlyphPos.X := MinLeft; - Inc(MinLeft, PaintInfo.SortGlyphSize.cx + FSpacing); - end; - if Layout in [blGlyphTop, blGlyphBottom] then - begin - // Header glyph is above or below text, so both must be considered when calculating - // the left positition of the sort glyph (if it is on the right hand side). - TextPos.X := MinLeft; - if PaintInfo.ShowHeaderGlyph then - begin - PaintInfo.GlyphPos.X := (ClientSize.X - HeaderGlyphSize.X) div 2; - if PaintInfo.GlyphPos.X < MinLeft then - PaintInfo.GlyphPos.X := MinLeft; - MinLeft := Max(TextPos.X + TextSize.cx + TextSpacing, PaintInfo.GlyphPos.X + HeaderGlyphSize.X + FSpacing); - end - else - MinLeft := TextPos.X + TextSize.cx + TextSpacing; - end - else - begin - // Everything is lined up. TextSpacing might be 0 if there is no text. - // This simplifies the calculation because no extra tests are necessary. - if PaintInfo.ShowHeaderGlyph and (Layout = blGlyphLeft) then - begin - PaintInfo.GlyphPos.X := MinLeft; - Inc(MinLeft, HeaderGlyphSize.X + FSpacing); - end; - TextPos.X := MinLeft; - Inc(MinLeft, TextSize.cx + TextSpacing); - if PaintInfo.ShowHeaderGlyph and (Layout = blGlyphRight) then - begin - PaintInfo.GlyphPos.X := MinLeft; - Inc(MinLeft, HeaderGlyphSize.X + FSpacing); - end; - end; - if PaintInfo.ShowSortGlyph and (FBiDiMode = bdLeftToRight) then - PaintInfo.SortGlyphPos.X := MinLeft; - end; - taCenter: - begin - if Layout in [blGlyphTop, blGlyphBottom] then - begin - PaintInfo.GlyphPos.X := (ClientSize.X - HeaderGlyphSize.X) div 2; - TextPos.X := (ClientSize.X - TextSize.cx) div 2; - if PaintInfo.ShowSortGlyph then - Dec(TextPos.X, PaintInfo.SortGlyphSize.cx div 2); - end - else - begin - MinLeft := (ClientSize.X - HeaderGlyphSize.X - TextSpacing - TextSize.cx) div 2; - if PaintInfo.ShowHeaderGlyph and (Layout = blGlyphLeft) then - begin - PaintInfo.GlyphPos.X := MinLeft; - Inc(MinLeft, HeaderGlyphSize.X + TextSpacing); - end; - TextPos.X := MinLeft; - Inc(MinLeft, TextSize.cx + TextSpacing); - if PaintInfo.ShowHeaderGlyph and (Layout = blGlyphRight) then - PaintInfo.GlyphPos.X := MinLeft; - end; - if PaintInfo.ShowHeaderGlyph then - begin - MinLeft := Min(PaintInfo.GlyphPos.X, TextPos.X); - MaxRight := Max(PaintInfo.GlyphPos.X + HeaderGlyphSize.X, TextPos.X + TextSize.cx); - end - else - begin - MinLeft := TextPos.X; - MaxRight := TextPos.X + TextSize.cx; - end; - // Place the sort glyph directly to the left or right of the larger item. - if PaintInfo.ShowSortGlyph then - if FBiDiMode = bdLeftToRight then - begin - // Sort glyph on the right hand side. - PaintInfo.SortGlyphPos.X := MaxRight + FSpacing; - end - else - begin - // Sort glyph on the left hand side. - PaintInfo.SortGlyphPos.X := MinLeft - FSpacing - PaintInfo.SortGlyphSize.cx; - end; - end; - else - // taRightJustify - MaxRight := ClientSize.X - FMargin; - if PaintInfo.ShowSortGlyph and (FBiDiMode = bdLeftToRight) then - begin - // In LTR context is the sort glyph placed on the right hand side. - Dec(MaxRight, PaintInfo.SortGlyphSize.cx); - PaintInfo.SortGlyphPos.X := MaxRight; - Dec(MaxRight, FSpacing); - end; - if Layout in [blGlyphTop, blGlyphBottom] then - begin - TextPos.X := MaxRight - TextSize.cx; - if PaintInfo.ShowHeaderGlyph then - begin - PaintInfo.GlyphPos.X := (ClientSize.X - HeaderGlyphSize.X) div 2; - if PaintInfo.GlyphPos.X + HeaderGlyphSize.X + FSpacing > MaxRight then - PaintInfo.GlyphPos.X := MaxRight - HeaderGlyphSize.X - FSpacing; - MaxRight := Min(TextPos.X - TextSpacing, PaintInfo.GlyphPos.X - FSpacing); - end - else - MaxRight := TextPos.X - TextSpacing; - end - else - begin - // Everything is lined up. TextSpacing might be 0 if there is no text. - // This simplifies the calculation because no extra tests are necessary. - if PaintInfo.ShowHeaderGlyph and (Layout = blGlyphRight) then - begin - PaintInfo.GlyphPos.X := MaxRight - HeaderGlyphSize.X; - MaxRight := PaintInfo.GlyphPos.X - FSpacing; - end; - TextPos.X := MaxRight - TextSize.cx; - MaxRight := TextPos.X - TextSpacing; - if PaintInfo.ShowHeaderGlyph and (Layout = blGlyphLeft) then - begin - PaintInfo.GlyphPos.X := MaxRight - HeaderGlyphSize.X; - MaxRight := PaintInfo.GlyphPos.X - FSpacing; - end; - end; - if PaintInfo.ShowSortGlyph and (FBiDiMode <> bdLeftToRight) then - PaintInfo.SortGlyphPos.X := MaxRight - PaintInfo.SortGlyphSize.cx; - end; - end; - - // Once the position of each element is determined there remains only one but important step. - // The horizontal positions of every element must be adjusted so that it always fits into the - // given header area. This is accomplished by shorten the text appropriately. - - // These are the maximum bounds. Nothing goes beyond them. - MinLeft := FMargin; - MaxRight := ClientSize.X - FMargin; - if PaintInfo.ShowSortGlyph then - begin - if FBiDiMode = bdLeftToRight then - begin - // Sort glyph on the right hand side. - if PaintInfo.SortGlyphPos.X + PaintInfo.SortGlyphSize.cx > MaxRight then - PaintInfo.SortGlyphPos.X := MaxRight - PaintInfo.SortGlyphSize.cx; - MaxRight := PaintInfo.SortGlyphPos.X - FSpacing; - end; - - // Consider also the left side of the sort glyph regardless of the bidi mode. - if PaintInfo.SortGlyphPos.X < MinLeft then - PaintInfo.SortGlyphPos.X := MinLeft; - // Left border needs only adjustment if the sort glyph marks the left border. - if FBiDiMode <> bdLeftToRight then - MinLeft := PaintInfo.SortGlyphPos.X + PaintInfo.SortGlyphSize.cx + FSpacing; - - // Finally transform sort glyph to its actual position. - Inc(PaintInfo.SortGlyphPos.X, PaintInfo.PaintRectangle.Left); - Inc(PaintInfo.SortGlyphPos.Y, PaintInfo.PaintRectangle.Top); - end; - if PaintInfo.ShowHeaderGlyph then - begin - if PaintInfo.GlyphPos.X + HeaderGlyphSize.X > MaxRight then - PaintInfo.GlyphPos.X := MaxRight - HeaderGlyphSize.X; - if Layout = blGlyphRight then - MaxRight := PaintInfo.GlyphPos.X - FSpacing; - if PaintInfo.GlyphPos.X < MinLeft then - PaintInfo.GlyphPos.X := MinLeft; - if Layout = blGlyphLeft then - MinLeft := PaintInfo.GlyphPos.X + HeaderGlyphSize.X + FSpacing; - if FCheckBox and (Owner.Header.MainColumn = Self.Index) then - Dec(PaintInfo.GlyphPos.X, 2) - else - if Owner.Header.MainColumn <> Self.Index then - Dec(PaintInfo.GlyphPos.X, 2); - - // Finally transform header glyph to its actual position. - Inc(PaintInfo.GlyphPos.X, PaintInfo.PaintRectangle.Left); - Inc(PaintInfo.GlyphPos.Y, PaintInfo.PaintRectangle.Top); - end; - if UseText then - begin - if TextPos.X < MinLeft then - TextPos.X := MinLeft; - OffsetRect(PaintInfo.TextRectangle, TextPos.X, TextPos.Y); - if PaintInfo.TextRectangle.Right > MaxRight then - PaintInfo.TextRectangle.Right := MaxRight; - OffsetRect(PaintInfo.TextRectangle, PaintInfo.PaintRectangle.Left, PaintInfo.PaintRectangle.Top); - - if coWrapCaption in FOptions then - begin - // Wrap the column caption if necessary. - R := PaintInfo.TextRectangle; - FCaptionText := WrapString(PaintInfo.TargetCanvas.Handle, FText, R, DT_RTLREADING and DrawFormat <> 0, DrawFormat); - GetStringDrawRect(PaintInfo.TargetCanvas.Handle, FCaptionText, R, DrawFormat); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.DefineProperties(Filer: TFiler); - -begin - inherited; - - // These properites are remains from non-Unicode Delphi versions, readers remain for backward compatibility. - Filer.DefineProperty('WideText', ReadText, nil, False); - Filer.DefineProperty('WideHint', ReadHint, nil, False); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.GetAbsoluteBounds(var Left, Right: Integer); - -// Returns the column's left and right bounds in header coordinates, that is, independant of the scrolling position. - -begin - Left := FLeft; - Right := FLeft + FWidth; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumn.GetDisplayName: string; - -// Returns the column text if it only contains ANSI characters, otherwise the column id is returned because the IDE -// still cannot handle Unicode strings. - -var - I: Integer; - -begin - // Check if the text of the column contains characters > 255 - I := 1; - while I <= Length(FText) do - begin - if Ord(FText[I]) > 255 then - Break; - Inc(I); - end; - - if I > Length(FText) then - Result := FText // implicit conversion - else - Result := Format('Column %d', [Index]); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumn.GetOwner: TVirtualTreeColumns; - -begin - Result := Collection as TVirtualTreeColumns; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.ReadText(Reader: TReader); - -begin - case Reader.NextValue of - vaLString, vaString: - SetText(Reader.ReadString); - else - SetText(Reader.ReadString); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.ReadHint(Reader: TReader); - -begin - case Reader.NextValue of - vaLString, vaString: - FHint := Reader.ReadString; - else - FHint := Reader.ReadString; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.Assign(Source: TPersistent); - -var - OldOptions: TVTColumnOptions; - -begin - if Source is TVirtualTreeColumn then - begin - OldOptions := FOptions; - FOptions := []; - - BiDiMode := TVirtualTreeColumn(Source).BiDiMode; - ImageIndex := TVirtualTreeColumn(Source).ImageIndex; - Layout := TVirtualTreeColumn(Source).Layout; - Margin := TVirtualTreeColumn(Source).Margin; - MaxWidth := TVirtualTreeColumn(Source).MaxWidth; - MinWidth := TVirtualTreeColumn(Source).MinWidth; - Position := TVirtualTreeColumn(Source).Position; - Spacing := TVirtualTreeColumn(Source).Spacing; - Style := TVirtualTreeColumn(Source).Style; - Text := TVirtualTreeColumn(Source).Text; - Hint := TVirtualTreeColumn(Source).Hint; - Width := TVirtualTreeColumn(Source).Width; - Alignment := TVirtualTreeColumn(Source).Alignment; - CaptionAlignment := TVirtualTreeColumn(Source).CaptionAlignment; - Color := TVirtualTreeColumn(Source).Color; - Tag := TVirtualTreeColumn(Source).Tag; - EditOptions := TVirtualTreeColumn(Source).EditOptions; - EditNextColumn := TVirtualTreeColumn(Source).EditNextColumn; - - // Order is important. Assign options last. - FOptions := OldOptions; - Options := TVirtualTreeColumn(Source).Options; - - Changed(False); - end - else - inherited Assign(Source); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumn.Equals(OtherColumnObj: TObject): Boolean; -var - OtherColumn : TVirtualTreeColumn; -begin - if OtherColumnObj is TVirtualTreeColumn then - begin - OtherColumn := TVirtualTreeColumn (OtherColumnObj); - Result := (BiDiMode = OtherColumn.BiDiMode) and - (ImageIndex = OtherColumn.ImageIndex) and - (Layout = OtherColumn.Layout) and - (Margin = OtherColumn.Margin) and - (MaxWidth = OtherColumn.MaxWidth) and - (MinWidth = OtherColumn.MinWidth) and - (Position = OtherColumn.Position) and - (Spacing = OtherColumn.Spacing) and - (Style = OtherColumn.Style) and - (Text = OtherColumn.Text) and - (Hint = OtherColumn.Hint) and - (Width = OtherColumn.Width) and - (Alignment = OtherColumn.Alignment) and - (CaptionAlignment = OtherColumn.CaptionAlignment) and - (Color = OtherColumn.Color) and - (Tag = OtherColumn.Tag) and - (Options = OtherColumn.Options); - end - else - Result := False; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumn.GetRect: TRect; - -// Returns the rectangle this column occupies in the header (relative to (0, 0) of the non-client area). - -begin - with TVirtualTreeColumns(GetOwner).FHeader do - Result := Treeview.FHeaderRect; - Inc(Result.Left, FLeft); - Result.Right := Result.Left + FWidth; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -// [IPK] -function TVirtualTreeColumn.GetText: string; - -begin - Result := FText; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.LoadFromStream(const Stream: TStream; Version: Integer); -var - Dummy: Integer; - S: string; - -begin - with Stream do - begin - ReadBuffer(Dummy, SizeOf(Dummy)); - SetLength(S, Dummy); - ReadBuffer(PWideChar(S)^, 2 * Dummy); - Text := S; - ReadBuffer(Dummy, SizeOf(Dummy)); - SetLength(FHint, Dummy); - ReadBuffer(PWideChar(FHint)^, 2 * Dummy); - ReadBuffer(Dummy, SizeOf(Dummy)); - Width := Dummy; - ReadBuffer(Dummy, SizeOf(Dummy)); - MinWidth := Dummy; - ReadBuffer(Dummy, SizeOf(Dummy)); - MaxWidth := Dummy; - ReadBuffer(Dummy, SizeOf(Dummy)); - Style := TVirtualTreeColumnStyle(Dummy); - ReadBuffer(Dummy, SizeOf(Dummy)); - ImageIndex := Dummy; - ReadBuffer(Dummy, SizeOf(Dummy)); - Layout := TVTHeaderColumnLayout(Dummy); - ReadBuffer(Dummy, SizeOf(Dummy)); - Margin := Dummy; - ReadBuffer(Dummy, SizeOf(Dummy)); - Spacing := Dummy; - ReadBuffer(Dummy, SizeOf(Dummy)); - BiDiMode := TBiDiMode(Dummy); - - ReadBuffer(Dummy, SizeOf(Dummy)); - if Version >= 3 then - Options := TVTColumnOptions(Dummy); - - if Version > 0 then - begin - // Parts which have been introduced/changed with header stream version 1+. - ReadBuffer(Dummy, SizeOf(Dummy)); - Tag := Dummy; - ReadBuffer(Dummy, SizeOf(Dummy)); - Alignment := TAlignment(Dummy); - - if Version > 1 then - begin - ReadBuffer(Dummy, SizeOf(Dummy)); - Color := TColor(Dummy); - end; - - if Version > 5 then - begin - if coUseCaptionAlignment in FOptions then - begin - ReadBuffer(Dummy, SizeOf(Dummy)); - CaptionAlignment := TAlignment(Dummy); - end; - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.ParentBiDiModeChanged; - -var - Columns: TVirtualTreeColumns; - -begin - if coParentBiDiMode in FOptions then - begin - Columns := GetOwner as TVirtualTreeColumns; - if Assigned(Columns) and (FBiDiMode <> Columns.FHeader.Treeview.BiDiMode) then - begin - FBiDiMode := Columns.FHeader.Treeview.BiDiMode; - Changed(False); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.ParentColorChanged; - -var - Columns: TVirtualTreeColumns; - -begin - if coParentColor in FOptions then - begin - Columns := GetOwner as TVirtualTreeColumns; - if Assigned(Columns) and (FColor <> Columns.FHeader.Treeview.Color) then - begin - FColor := Columns.FHeader.Treeview.Color; - Changed(False); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.RestoreLastWidth; - -begin - TVirtualTreeColumns(GetOwner).AnimatedResize(Index, FLastWidth); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.SaveToStream(const Stream: TStream); - -var - Dummy: Integer; - -begin - with Stream do - begin - Dummy := Length(FText); - WriteBuffer(Dummy, SizeOf(Dummy)); - WriteBuffer(PWideChar(FText)^, 2 * Dummy); - Dummy := Length(FHint); - WriteBuffer(Dummy, SizeOf(Dummy)); - WriteBuffer(PWideChar(FHint)^, 2 * Dummy); - WriteBuffer(FWidth, SizeOf(FWidth)); - WriteBuffer(FMinWidth, SizeOf(FMinWidth)); - WriteBuffer(FMaxWidth, SizeOf(FMaxWidth)); - Dummy := Ord(FStyle); - WriteBuffer(Dummy, SizeOf(Dummy)); - Dummy := FImageIndex; - WriteBuffer(Dummy, SizeOf(Dummy)); - Dummy := Ord(FLayout); - WriteBuffer(Dummy, SizeOf(Dummy)); - WriteBuffer(FMargin, SizeOf(FMargin)); - WriteBuffer(FSpacing, SizeOf(FSpacing)); - Dummy := Ord(FBiDiMode); - WriteBuffer(Dummy, SizeOf(Dummy)); - Dummy := Integer(FOptions); - WriteBuffer(Dummy, SizeOf(Dummy)); - - // parts introduced with stream version 1 - WriteBuffer(FTag, SizeOf(Dummy)); - Dummy := Cardinal(FAlignment); - WriteBuffer(Dummy, SizeOf(Dummy)); - - // parts introduced with stream version 2 - Dummy := Integer(FColor); - WriteBuffer(Dummy, SizeOf(Dummy)); - - // parts introduced with stream version 6 - if coUseCaptionAlignment in FOptions then - begin - Dummy := Cardinal(FCaptionAlignment); - WriteBuffer(Dummy, SizeOf(Dummy)); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumn.UseRightToLeftReading: Boolean; - -begin - Result := FBiDiMode <> bdLeftToRight; -end; - -//----------------- TVirtualTreeColumns -------------------------------------------------------------------------------- - -constructor TVirtualTreeColumns.Create(AOwner: TVTHeader); - -var - ColumnClass: TVirtualTreeColumnClass; - -begin - FHeader := AOwner; - - // Determine column class to be used in the header. - ColumnClass := AOwner.FOwner.GetColumnClass; - // The owner tree always returns the default tree column class if not changed by application/descendants. - inherited Create(ColumnClass); - - FHeaderBitmap := TBitmap.Create; - FHeaderBitmap.PixelFormat := pf32Bit; - - FHoverIndex := NoColumn; - FDownIndex := NoColumn; - FClickIndex := NoColumn; - FDropTarget := NoColumn; - FTrackIndex := NoColumn; - FDefaultWidth := 50; - Self.FColumnPopupMenu := nil; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -destructor TVirtualTreeColumns.Destroy; - -begin - FreeAndNil(FColumnPopupMenu); - FreeAndNil(FHeaderBitmap); - inherited; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumns.GetCount: Integer; - -begin - Result := inherited Count; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumns.GetItem(Index: TColumnIndex): TVirtualTreeColumn; - -begin - Result := TVirtualTreeColumn(inherited GetItem(Index)); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumns.GetNewIndex(P: TPoint; var OldIndex: TColumnIndex): Boolean; - -var - NewIndex: Integer; - -begin - Result := False; - // convert to local coordinates - Inc(P.Y, FHeader.FHeight); - NewIndex := ColumnFromPosition(P); - if NewIndex <> OldIndex then - begin - if OldIndex > NoColumn then - FHeader.Invalidate(Items[OldIndex], False, True); - OldIndex := NewIndex; - if OldIndex > NoColumn then - FHeader.Invalidate(Items[OldIndex], False, True); - Result := True; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumns.SetDefaultWidth(Value: Integer); - -begin - FDefaultWidth := Value; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumns.SetItem(Index: TColumnIndex; Value: TVirtualTreeColumn); - -begin - inherited SetItem(Index, Value); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumns.AdjustAutoSize(CurrentIndex: TColumnIndex; Force: Boolean = False); - -// Called only if the header is in auto-size mode which means a column needs to be so large -// that it fills all the horizontal space not occupied by the other columns. -// CurrentIndex (if not InvalidColumn) describes which column has just been resized. - -var - NewValue, - AutoIndex, - Index, - RestWidth: Integer; - WasUpdating: Boolean; -begin - if Count > 0 then - begin - // Determine index to be used for auto resizing. This is usually given by the owner's AutoSizeIndex, but - // could be different if the column whose resize caused the invokation here is either the auto column itself - // or visually to the right of the auto size column. - AutoIndex := FHeader.FAutoSizeIndex; - if (AutoIndex < 0) or (AutoIndex >= Count) then - AutoIndex := Count - 1; - - if AutoIndex >= 0 then - begin - with FHeader.Treeview do - begin - if HandleAllocated then - RestWidth := ClientWidth - else - RestWidth := Width; - end; - - // Go through all columns and calculate the rest space remaining. - for Index := 0 to Count - 1 do - if (Index <> AutoIndex) and (coVisible in Items[Index].FOptions) then - Dec(RestWidth, Items[Index].Width); - - with Items[AutoIndex] do - begin - NewValue := Max(MinWidth, Min(MaxWidth, RestWidth)); - if Force or (FWidth <> NewValue) then - begin - FWidth := NewValue; - UpdatePositions; - WasUpdating := csUpdating in FHeader.Treeview.ComponentState; - if not WasUpdating then - FHeader.Treeview.Updating();// Fixes #398 - try - FHeader.Treeview.DoColumnResize(AutoIndex); - finally - if not WasUpdating then - FHeader.Treeview.Updated(); - end; - end; - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumns.AdjustDownColumn(P: TPoint): TColumnIndex; - -// Determines the column from the given position and returns it. If this column is allowed to be clicked then -// it is also kept for later use. - -begin - // Convert to local coordinates. - Inc(P.Y, FHeader.FHeight); - Result := ColumnFromPosition(P); - if (Result > NoColumn) and (Result <> FDownIndex) and (coAllowClick in Items[Result].FOptions) and - (coEnabled in Items[Result].FOptions) then - begin - if FDownIndex > NoColumn then - FHeader.Invalidate(Items[FDownIndex]); - FDownIndex := Result; - FCheckBoxHit := Items[Result].FHasImage and PtInRect(Items[Result].FImageRect, P) and Items[Result].CheckBox; - FHeader.Invalidate(Items[FDownIndex]); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumns.AdjustHoverColumn(P: TPoint): Boolean; - -// Determines the new hover column index and returns True if the index actually changed else False. - -begin - Result := GetNewIndex(P, FHoverIndex); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumns.AdjustPosition(Column: TVirtualTreeColumn; Position: Cardinal); - -// Reorders the column position array so that the given column gets the given position. - -var - OldPosition: Cardinal; - -begin - OldPosition := Column.Position; - if OldPosition <> Position then - begin - if OldPosition < Position then - begin - // column will be moved up so move down other entries - Move(FPositionToIndex[OldPosition + 1], FPositionToIndex[OldPosition], (Position - OldPosition) * SizeOf(Cardinal)); - end - else - begin - // column will be moved down so move up other entries - Move(FPositionToIndex[Position], FPositionToIndex[Position + 1], (OldPosition - Position) * SizeOf(Cardinal)); - end; - FPositionToIndex[Position] := Column.Index; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumns.CanSplitterResize(P: TPoint; Column: TColumnIndex): Boolean; - -begin - Result := (Column > NoColumn) and ([coResizable, coVisible] * Items[Column].FOptions = [coResizable, coVisible]); - DoCanSplitterResize(P, Column, Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumns.DoCanSplitterResize(P: TPoint; Column: TColumnIndex; var Allowed: Boolean); - -begin - if Assigned(FHeader.Treeview.FOnCanSplitterResizeColumn) then - FHeader.Treeview.FOnCanSplitterResizeColumn(FHeader, P, Column, Allowed); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumns.DrawButtonText(DC: HDC; Caption: string; Bounds: TRect; Enabled, Hot: Boolean; - DrawFormat: Cardinal; WrapCaption: Boolean); - -var - TextSpace: Integer; - Size: TSize; - -begin - if not WrapCaption then - begin - // Do we need to shorten the caption due to limited space? - GetTextExtentPoint32W(DC, PWideChar(Caption), Length(Caption), Size); - TextSpace := Bounds.Right - Bounds.Left; - if TextSpace < Size.cx then - Caption := ShortenString(DC, Caption, TextSpace); - end; - - SetBkMode(DC, TRANSPARENT); - if not Enabled then - if FHeader.Treeview.VclStyleEnabled then - begin - SetTextColor(DC, ColorToRGB(FHeader.Treeview.FColors.HeaderFontColor)); - Winapi.Windows.DrawTextW(DC, PWideChar(Caption), Length(Caption), Bounds, DrawFormat); - end - else - begin - OffsetRect(Bounds, 1, 1); - SetTextColor(DC, ColorToRGB(clBtnHighlight)); - Winapi.Windows.DrawTextW(DC, PWideChar(Caption), Length(Caption), Bounds, DrawFormat); - OffsetRect(Bounds, -1, -1); - SetTextColor(DC, ColorToRGB(clBtnShadow)); - Winapi.Windows.DrawTextW(DC, PWideChar(Caption), Length(Caption), Bounds, DrawFormat); - end - else - begin - if Hot then - SetTextColor(DC, ColorToRGB(FHeader.Treeview.FColors.HeaderHotColor)) - else - SetTextColor(DC, ColorToRGB(FHeader.Treeview.FColors.HeaderFontColor)); - Winapi.Windows.DrawTextW(DC, PWideChar(Caption), Length(Caption), Bounds, DrawFormat); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumns.FixPositions; - -// Fixes column positions after loading from DFM or Bidi mode change. - -var - I: Integer; - -begin - for I := 0 to Count - 1 do - FPositionToIndex[Items[I].Position] := I; - - FNeedPositionsFix := False; - UpdatePositions(True); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumns.GetColumnAndBounds(P: TPoint; var ColumnLeft, ColumnRight: Integer; - Relative: Boolean = True): Integer; - -// Returns the column where the mouse is currently in as well as the left and right bound of -// this column (Left and Right are undetermined if no column is involved). - -var - I: Integer; - -begin - Result := InvalidColumn; - if Relative and (P.X >= Header.Columns.GetVisibleFixedWidth) then - ColumnLeft := -FHeader.Treeview.FEffectiveOffsetX - else - ColumnLeft := 0; - - if FHeader.Treeview.UseRightToLeftAlignment then - Inc(ColumnLeft, FHeader.Treeview.ComputeRTLOffset(True)); - - for I := 0 to Count - 1 do - with Items[FPositionToIndex[I]] do - if coVisible in FOptions then - begin - ColumnRight := ColumnLeft + FWidth; - - //fix: in right to left alignment, X can be in the - //area on the left of first column which is OUT. - if (P.X < ColumnLeft) and (I = 0) then - begin - Result := InvalidColumn; - exit; - end; - if P.X < ColumnRight then - begin - Result := FPositionToIndex[I]; - Exit; - end; - ColumnLeft := ColumnRight; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumns.GetOwner: TPersistent; - -begin - Result := FHeader; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumns.HandleClick(P: TPoint; Button: TMouseButton; Force, DblClick: Boolean): Boolean; - -// Generates a click event if the mouse button has been released over the same column it was pressed first. -// Alternatively, Force might be set to True to indicate that the down index does not matter (right, middle and -// double click). -// Returns true if the click was handled, False otherwise. - -var - HitInfo: TVTHeaderHitInfo; - NewClickIndex: Integer; - Menu: TPopupMenu; -begin - Result := False; - if (csDesigning in Header.Treeview.ComponentState) then - exit; - // Convert vertical position to local coordinates. - Inc(P.Y, FHeader.FHeight); - NewClickIndex := ColumnFromPosition(P); - with HitInfo do - begin - X := P.X; - Y := P.Y; - Shift := FHeader.GetShiftState; - if DblClick then - Shift := Shift + [ssDouble]; - end; - HitInfo.Button := Button; - - if (NewClickIndex > NoColumn) and (coAllowClick in Items[NewClickIndex].FOptions) and - ((NewClickIndex = FDownIndex) or Force) then - begin - FClickIndex := NewClickIndex; - HitInfo.Column := NewClickIndex; - HitInfo.HitPosition := [hhiOnColumn]; - - if Items[NewClickIndex].FHasImage and PtInRect(Items[NewClickIndex].FImageRect, P) then - begin - Include(HitInfo.HitPosition, hhiOnIcon); - if Items[NewClickIndex].CheckBox then - begin - if Button = mbLeft then - FHeader.Treeview.UpdateColumnCheckState(Items[NewClickIndex]); - Include(HitInfo.HitPosition, hhiOnCheckbox); - end; - end; - end - else - begin - FClickIndex := NoColumn; - HitInfo.Column := NoColumn; - HitInfo.HitPosition := [hhiNoWhere]; - end; - - if DblClick then - FHeader.Treeview.DoHeaderDblClick(HitInfo) - else begin - if (hoHeaderClickAutoSort in Header.Options) and (HitInfo.Button = mbLeft) and not (hhiOnCheckbox in HitInfo.HitPosition) and (HitInfo.Column >= 0) then - begin - // handle automatic setting of SortColumn and toggling of the sort order - if HitInfo.Column <> Header.SortColumn then - begin - // set sort column - Header.DoSetSortColumn(HitInfo.Column, Self[HitInfo.Column].DefaultSortDirection); - end//if - else - begin - // toggle sort direction - if Header.SortDirection = sdDescending then - Header.SortDirection := sdAscending - else - Header.SortDirection := sdDescending; - end;//else - Result := True; - end;//if - - if (Button = mbRight) then - begin - Dec(P.Y, FHeader.FHeight); // popup menus at actual clicked point - FreeAndNil(fColumnPopupMenu);// Attention: Do not free the TVTHeaderPopupMenu at the end of this method, otherwise the clikc events of the menu item will not be fired. - Self.FDownIndex := NoColumn; - Self.FTrackIndex := NoColumn; - Self.FCheckBoxHit := False; - Menu := Header.DoGetPopupMenu(Self.ColumnFromPosition(Point(P.X, P.Y + Integer(Header.Treeview.Height))), P); - if Assigned(Menu) then - begin - Header.Treeview.StopTimer(ScrollTimer); - Header.Treeview.StopTimer(HeaderTimer); - Header.FColumns.FHoverIndex := NoColumn; - Header.Treeview.DoStateChange([], [tsScrollPending, tsScrolling]); - - Menu.PopupComponent := Header.Treeview; - With Header.Treeview.ClientToScreen(P) do - Menu.Popup(X, Y); - Result := True; - end - else if (hoAutoColumnPopupMenu in Header.Options) then - begin - fColumnPopupMenu := TVTHeaderPopupMenu.Create(Header.TreeView); - TVTHeaderPopupMenu(fColumnPopupMenu).OnAddHeaderPopupItem := HeaderPopupMenuAddHeaderPopupItem; - TVTHeaderPopupMenu(fColumnPopupMenu).OnColumnChange := HeaderPopupMenuColumnChange; - fColumnPopupMenu.PopupComponent := Header.Treeview; - if (hoDblClickResize in Header.Options) and ((Header.Treeview.ChildCount[nil] > 0) or (hoAutoResizeInclCaption in Header.Options)) then - TVTHeaderPopupMenu(fColumnPopupMenu).Options := TVTHeaderPopupMenu(fColumnPopupMenu).Options + [poResizeToFitItem] - else - TVTHeaderPopupMenu(fColumnPopupMenu).Options := TVTHeaderPopupMenu(fColumnPopupMenu).Options - [poResizeToFitItem]; - With Header.Treeview.ClientToScreen(P) do - fColumnPopupMenu.Popup(X, Y); - Result := True; - end; // if hoAutoColumnPopupMenu - end;//if mbRight - FHeader.Treeview.DoHeaderClick(HitInfo); - end;//else (not DblClick) - - if not (hhiNoWhere in HitInfo.HitPosition) then - FHeader.Invalidate(Items[NewClickIndex]); - if (FClickIndex > NoColumn) and (FClickIndex <> NewClickIndex) then - FHeader.Invalidate(Items[FClickIndex]); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumns.HeaderPopupMenuAddHeaderPopupItem(const Sender: TBaseVirtualTree; const Column: TColumnIndex; - var Cmd: TAddPopupItemType); -begin - Sender.DoHeaderAddPopupItem(Column, Cmd); -end; - -//---------------------------------------------------------------------------------------------------------------------- - - -procedure TVirtualTreeColumns.HeaderPopupMenuColumnChange(const Sender: TBaseVirtualTree; const Column: TColumnIndex; Visible: Boolean); -begin - Sender.DoColumnVisibilityChanged(Column, Visible); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumns.IndexChanged(OldIndex, NewIndex: Integer); - -// Called by a column when its index in the collection changes. If NewIndex is -1 then the column is -// about to be removed, otherwise it is moved to a new index. -// The method will then update the position array to reflect the change. - -var - I: Integer; - Increment: Integer; - Lower, - Upper: Integer; - -begin - if NewIndex = -1 then - begin - // Find position in the array with the old index. - Upper := High(FPositionToIndex); - for I := 0 to Upper do - begin - if FPositionToIndex[I] = OldIndex then - begin - // Index found. Move all higher entries one step down and remove the last entry. - if I < Upper then - Move(FPositionToIndex[I + 1], FPositionToIndex[I], (Upper - I) * SizeOf(TColumnIndex)); - end; - // Decrease all indices, which are greater than the index to be deleted. - if FPositionToIndex[I] > OldIndex then - Dec(FPositionToIndex[I]); - end; - SetLength(FPositionToIndex, High(FPositionToIndex)); - end - else - begin - if OldIndex < NewIndex then - Increment := -1 - else - Increment := 1; - - Lower := Min(OldIndex, NewIndex); - Upper := Max(OldIndex, NewIndex); - for I := 0 to High(FPositionToIndex) do - begin - if (FPositionToIndex[I] >= Lower) and (FPositionToIndex[I] < Upper) then - Inc(FPositionToIndex[I], Increment) - else - if FPositionToIndex[I] = OldIndex then - FPositionToIndex[I] := NewIndex; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumns.InitializePositionArray; - -// Ensures that the column position array contains as many entries as columns are defined. -// The array is resized and initialized with default values if needed. - -var - I, OldSize: Integer; - Changed: Boolean; - -begin - if Count <> Length(FPositionToIndex) then - begin - OldSize := Length(FPositionToIndex); - SetLength(FPositionToIndex, Count); - if Count > OldSize then - begin - // New items have been added, just set their position to the same as their index. - for I := OldSize to Count - 1 do - FPositionToIndex[I] := I; - end - else - begin - // Items have been deleted, so reindex remaining entries by decrementing values larger than the highest - // possible index until no entry is higher than this limit. - repeat - Changed := False; - for I := 0 to Count - 1 do - if FPositionToIndex[I] >= Count then - begin - Dec(FPositionToIndex[I]); - Changed := True; - end; - until not Changed; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumns.Notify(Item: TCollectionItem; Action: System.Classes.TCollectionNotification); -var - I: Integer; -begin - if Action in [cnExtracting, cnDeleting] then - begin - // Adjust all positions larger than the deleted column's position. Fixes #959 - for I := 0 to Count - 1 do begin - if Items[I].Position > TVirtualTreeColumn(Item).Position then - Items[I].Position := Items[I].Position - 1; - end;//for I - - with Header.Treeview do - if not (csLoading in ComponentState) and (FFocusedColumn = Item.Index) then - FFocusedColumn := NoColumn; - end;// if cnDeleting -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumns.ReorderColumns(RTL: Boolean); - -var - I: Integer; - -begin - if RTL then - begin - for I := 0 to Count - 1 do - FPositionToIndex[I] := Count - I - 1; - end - else - begin - for I := 0 to Count - 1 do - FPositionToIndex[I] := I; - end; - - UpdatePositions(True); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumns.EndUpdate; -begin - InitializePositionArray(); - FixPositions(); // Accept the cuurent order. See issue #753 - inherited; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumns.Update(Item: TCollectionItem); - -begin - // This is the only place which gets notified when a new column has been added or removed - // and we need this event to adjust the column position array. - InitializePositionArray; - if csLoading in Header.Treeview.ComponentState then - FNeedPositionsFix := True - else - UpdatePositions; - - // The first column which is created is by definition also the main column. - if (Count > 0) and (Header.FMainColumn < 0) then - FHeader.FMainColumn := 0; - - if not (csLoading in Header.Treeview.ComponentState) and not (hsLoading in FHeader.FStates) then - begin - with FHeader do - begin - if hoAutoResize in FOptions then - AdjustAutoSize(InvalidColumn); - if Assigned(Item) then - Invalidate(Item as TVirtualTreeColumn) - else - if Treeview.HandleAllocated then - begin - Treeview.UpdateHorizontalScrollBar(False); - Invalidate(nil); - Treeview.Invalidate; - end; - - if not (tsUpdating in Treeview.FStates) then - // This is mainly to let the designer know when a change occurs at design time which - // doesn't involve the object inspector (like column resizing with the mouse). - // This does NOT include design time code as the communication is done via an interface. - Treeview.UpdateDesigner; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumns.UpdatePositions(Force: Boolean = False); - -// Recalculates the left border of every column and updates their position property according to the -// PostionToIndex array which primarily determines where each column is placed visually. - -var - I, RunningPos: Integer; - -begin - if not (csDestroying in FHeader.Treeview.ComponentState) and not FNeedPositionsFix and (Force or (UpdateCount = 0)) then - begin - RunningPos := 0; - for I := 0 to High(FPositionToIndex) do - with Items[FPositionToIndex[I]] do - begin - FPosition := I; - FLeft := RunningPos; - if coVisible in FOptions then - Inc(RunningPos, FWidth); - end; - FHeader.Treeview.UpdateHorizontalScrollBar(False); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumns.Add: TVirtualTreeColumn; - -begin - Assert(GetCurrentThreadId = MainThreadId, 'UI controls may only be chnaged in UI thread.'); - Result := TVirtualTreeColumn(inherited Add); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumns.AnimatedResize(Column: TColumnIndex; NewWidth: Integer); - -// Resizes the given column animated by scrolling the window DC. - -var - OldWidth: Integer; - DC: HDC; - I, - Steps, - DX: Integer; - HeaderScrollRect, - ScrollRect, - R: TRect; - - NewBrush, - LastBrush: HBRUSH; - -begin - if not IsValidColumn(Column) then - Exit; // Just in case. - - // Make sure the width constrains are considered. - if NewWidth < Items[Column].FMinWidth then - NewWidth := Items[Column].FMinWidth; - if NewWidth > Items[Column].FMaxWidth then - NewWidth := Items[Column].FMaxWidth; - - OldWidth := Items[Column].Width; - // Nothing to do if the width is the same. - if OldWidth <> NewWidth then - begin - if not ( (hoDisableAnimatedResize in FHeader.Options) or - (coDisableAnimatedResize in Items[Column].Options) ) then - begin - DC := GetWindowDC(FHeader.Treeview.Handle); - with FHeader.Treeview do - try - Steps := 32; - DX := (NewWidth - OldWidth) div Steps; - - // Determination of the scroll rectangle is a bit complicated since we neither want - // to scroll the scrollbars nor the border of the treeview window. - HeaderScrollRect := FHeaderRect; - ScrollRect := HeaderScrollRect; - // Exclude the header itself from scrolling. - ScrollRect.Top := ScrollRect.Bottom; - ScrollRect.Bottom := ScrollRect.Top + ClientHeight; - ScrollRect.Right := ScrollRect.Left + ClientWidth; - with Items[Column] do - Inc(ScrollRect.Left, FLeft + FWidth); - HeaderScrollRect.Left := ScrollRect.Left; - HeaderScrollRect.Right := ScrollRect.Right; - - // When the new width is larger then avoid artefacts on the left hand side - // by deleting a small stripe - if NewWidth > OldWidth then - begin - R := ScrollRect; - NewBrush := CreateSolidBrush(ColorToRGB(Color)); - LastBrush := SelectObject(DC, NewBrush); - R.Right := R.Left + DX; - FillRect(DC, R, NewBrush); - SelectObject(DC, LastBrush); - DeleteObject(NewBrush); - end - else - begin - Inc(HeaderScrollRect.Left, DX); - Inc(ScrollRect.Left, DX); - end; - - for I := 0 to Steps - 1 do - begin - ScrollDC(DC, DX, 0, HeaderScrollRect, HeaderScrollRect, 0, nil); - Inc(HeaderScrollRect.Left, DX); - ScrollDC(DC, DX, 0, ScrollRect, ScrollRect, 0, nil); - Inc(ScrollRect.Left, DX); - Sleep(1); - end; - finally - ReleaseDC(Handle, DC); - end; - end; - Items[Column].Width := NewWidth; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumns.Assign(Source: TPersistent); - -begin - // Let the collection class assign the items. - inherited; - - if Source is TVirtualTreeColumns then - begin - // Copying the position array is the only needed task here. - FPositionToIndex := Copy(TVirtualTreeColumns(Source).FPositionToIndex, 0, MaxInt); - - // Make sure the left edges are correct after assignment. - FNeedPositionsFix := False; - UpdatePositions(True); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumns.Clear; - -begin - FClearing := True; - try - Header.Treeview.CancelEditNode; - - // Since we're freeing all columns, the following have to be true when we're done. - FHoverIndex := NoColumn; - FDownIndex := NoColumn; - FTrackIndex := NoColumn; - FClickIndex := NoColumn; - FCheckBoxHit := False; - - with Header do - if not (hsLoading in FStates) then - begin - FAutoSizeIndex := NoColumn; - FMainColumn := NoColumn; - FSortColumn := NoColumn; - end; - - with Header.Treeview do - if not (csLoading in ComponentState) then - FFocusedColumn := NoColumn; - - inherited Clear; - finally - FClearing := False; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumns.ColumnFromPosition(P: TPoint; Relative: Boolean = True): TColumnIndex; - -// Determines the current column based on the position passed in P. - -var - I, Sum: Integer; - -begin - Result := InvalidColumn; - - // The position must be within the header area, but we extend the vertical bounds to the entire treeview area. - if (P.X >= 0) and (P.Y >= 0) and (P.Y <= FHeader.TreeView.Height) then - with FHeader, Treeview do - begin - if Relative and (P.X >= GetVisibleFixedWidth) then - Sum := -FEffectiveOffsetX - else - Sum := 0; - - if UseRightToLeftAlignment then - Inc(Sum, ComputeRTLOffset(True)); - - for I := 0 to Count - 1 do - if coVisible in Items[FPositionToIndex[I]].FOptions then - begin - Inc(Sum, Items[FPositionToIndex[I]].Width); - if P.X < Sum then - begin - Result := FPositionToIndex[I]; - Break; - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumns.ColumnFromPosition(PositionIndex: TColumnPosition): TColumnIndex; - -// Returns the index of the column at the given position. - -begin - if Integer(PositionIndex) < Length(FPositionToIndex) then - Result := FPositionToIndex[PositionIndex] - else - Result := NoColumn; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumns.Equals(OtherColumnsObj: TObject): Boolean; - -// Compares itself with the given set of columns and returns True if all published properties are the same -// (including column order), otherwise False is returned. - -var - I: Integer; - OtherColumns : TVirtualTreeColumns; - -begin - if not (OtherColumnsObj is TVirtualTreeColumns) then - begin - Result := False; - Exit; - end; - - OtherColumns := TVirtualTreeColumns (OtherColumnsObj); - - // Same number of columns? - Result := OtherColumns.Count = Count; - if Result then - begin - // Same order of columns? - Result := CompareMem(Pointer(FPositionToIndex), Pointer(OtherColumns.FPositionToIndex), - Length(FPositionToIndex) * SizeOf(TColumnIndex)); - if Result then - begin - for I := 0 to Count - 1 do - if not Items[I].Equals(OtherColumns[I]) then - begin - Result := False; - Break; - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumns.GetColumnBounds(Column: TColumnIndex; var Left, Right: Integer); - -// Returns the left and right bound of the given column. If Column is NoColumn then the entire client width is returned. - -begin - if Column <= NoColumn then - begin - Left := 0; - Right := FHeader.Treeview.ClientWidth; - end - else - begin - Left := Items[Column].Left; - Right := Left + Items[Column].Width; - if FHeader.Treeview.UseRightToLeftAlignment then - begin - Inc(Left, FHeader.Treeview.ComputeRTLOffset(True)); - Inc(Right, FHeader.Treeview.ComputeRTLOffset(True)); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumns.GetScrollWidth: Integer; - -// Returns the average width of all visible, non-fixed columns. If there is no such column the indent is returned. - -var - I: Integer; - ScrollColumnCount: Integer; - -begin - - Result := 0; - - ScrollColumnCount := 0; - for I := 0 to FHeader.Columns.Count - 1 do - begin - if ([coVisible, coFixed] * FHeader.Columns[I].Options = [coVisible]) then - begin - Inc(Result, FHeader.Columns[I].Width); - Inc(ScrollColumnCount); - end; - end; - - if ScrollColumnCount > 0 then // use average width - Result := Round(Result / ScrollColumnCount) - else // use indent - Result := Integer(FHeader.Treeview.FIndent); - -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumns.GetFirstVisibleColumn(ConsiderAllowFocus: Boolean = False): TColumnIndex; - -// Returns the index of the first visible column or "InvalidColumn" if either no columns are defined or -// all columns are hidden. -// If ConsiderAllowFocus is True then the column has not only to be visible but also focus has to be allowed. - -var - I: Integer; - -begin - Result := InvalidColumn; - if (UpdateCount > 0) or (csLoading in Header.TreeView.ComponentState) then - exit; // See issue #760 - for I := 0 to Count - 1 do - if (coVisible in Items[FPositionToIndex[I]].FOptions) and - ( (not ConsiderAllowFocus) or - (coAllowFocus in Items[FPositionToIndex[I]].FOptions) - ) then - begin - Result := FPositionToIndex[I]; - Break; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumns.GetLastVisibleColumn(ConsiderAllowFocus: Boolean = False): TColumnIndex; - -// Returns the index of the last visible column or "InvalidColumn" if either no columns are defined or -// all columns are hidden. -// If ConsiderAllowFocus is True then the column has not only to be visible but also focus has to be allowed. - -var - I: Integer; - -begin - Result := InvalidColumn; - if (UpdateCount > 0) or (csLoading in Header.TreeView.ComponentState) then - exit; // See issue #760 - for I := Count - 1 downto 0 do - if (coVisible in Items[FPositionToIndex[I]].FOptions) and - ( (not ConsiderAllowFocus) or - (coAllowFocus in Items[FPositionToIndex[I]].FOptions) - ) then - begin - Result := FPositionToIndex[I]; - Break; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumns.GetFirstColumn: TColumnIndex; - -// Returns the first column in display order. - -begin - if Count = 0 then - Result := InvalidColumn - else - Result := FPositionToIndex[0]; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumns.GetNextColumn(Column: TColumnIndex): TColumnIndex; - -// Returns the next column in display order. Column is the index of an item in the collection (a column). - -var - Position: Integer; - -begin - if Column < 0 then - Result := InvalidColumn - else - begin - Position := Items[Column].Position; - if Position < Count - 1 then - Result := FPositionToIndex[Position + 1] - else - Result := InvalidColumn; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumns.GetNextVisibleColumn(Column: TColumnIndex; ConsiderAllowFocus: Boolean = False): TColumnIndex; - -// Returns the next visible column in display order, Column is an index into the columns list. -// If ConsiderAllowFocus is True then the column has not only to be visible but also focus has to be allowed. - -begin - Result := Column; - repeat - Result := GetNextColumn(Result); - until (Result = InvalidColumn) or - ( (coVisible in Items[Result].FOptions) and - ( (not ConsiderAllowFocus) or - (coAllowFocus in Items[Result].FOptions) - ) - ); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumns.GetPreviousColumn(Column: TColumnIndex): TColumnIndex; - -// Returns the previous column in display order, Column is an index into the columns list. - -var - Position: Integer; - -begin - if Column < 0 then - Result := InvalidColumn - else - begin - Position := Items[Column].Position; - if Position > 0 then - Result := FPositionToIndex[Position - 1] - else - Result := InvalidColumn; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumns.GetPreviousVisibleColumn(Column: TColumnIndex; ConsiderAllowFocus: Boolean = False): TColumnIndex; - -// Returns the previous visible column in display order, Column is an index into the columns list. -// If ConsiderAllowFocus is True then the column has not only to be visible but also focus has to be allowed. - -begin - Result := Column; - repeat - Result := GetPreviousColumn(Result); - until (Result = InvalidColumn) or - ( (coVisible in Items[Result].FOptions) and - ( (not ConsiderAllowFocus) or - (coAllowFocus in Items[Result].FOptions) - ) - ); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumns.GetVisibleColumns: TColumnsArray; - -// Returns a list of all currently visible columns in actual order. - -var - I, Counter: Integer; - -begin - SetLength(Result, Count); - Counter := 0; - - for I := 0 to Count - 1 do - if coVisible in Items[FPositionToIndex[I]].FOptions then - begin - Result[Counter] := Items[FPositionToIndex[I]]; - Inc(Counter); - end; - // Set result length to actual visible count. - SetLength(Result, Counter); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumns.GetVisibleFixedWidth: Integer; - -// Determines the horizontal space all visible and fixed columns occupy. - -var - I: Integer; - -begin - Result := 0; - for I := 0 to Count - 1 do - begin - if Items[I].Options * [coVisible, coFixed] = [coVisible, coFixed] then - Inc(Result, Items[I].Width); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumns.IsValidColumn(Column: TColumnIndex): Boolean; - -// Determines whether the given column is valid or not, that is, whether it is one of the current columns. - -begin - Result := (Column > NoColumn) and (Column < Count); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumns.LoadFromStream(const Stream: TStream; Version: Integer); - -var - I, - ItemCount: Integer; - -begin - Clear; - Stream.ReadBuffer(ItemCount, SizeOf(ItemCount)); - // number of columns - if ItemCount > 0 then - begin - BeginUpdate; - try - for I := 0 to ItemCount - 1 do - Add.LoadFromStream(Stream, Version); - SetLength(FPositionToIndex, ItemCount); - Stream.ReadBuffer(FPositionToIndex[0], ItemCount * SizeOf(TColumnIndex)); - UpdatePositions(True); - finally - EndUpdate; - end; - end; - - // Data introduced with header stream version 5 - if Version > 4 then - Stream.ReadBuffer(FDefaultWidth, SizeOf(FDefaultWidth)); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumns.PaintHeader(DC: HDC; R: TRect; HOffset: Integer); - -// Backward compatible header paint method. This method takes care of visually moving floating columns - -var - VisibleFixedWidth: Integer; - RTLOffset: Integer; - - procedure PaintFixedArea; - - begin - if VisibleFixedWidth > 0 then - PaintHeader(FHeaderBitmap.Canvas, - Rect(0, 0, Min(R.Right, VisibleFixedWidth), R.Bottom - R.Top), - Point(R.Left, R.Top), RTLOffset); - end; - -begin - // Adjust size of the header bitmap - with TWithSafeRect(FHeader.Treeview.FHeaderRect) do - begin - FHeaderBitmap.SetSize(Max(Right, R.Right - R.Left), Bottom); - end; - - VisibleFixedWidth := GetVisibleFixedWidth; - - // Consider right-to-left directionality. - if FHeader.TreeView.UseRightToLeftAlignment then - RTLOffset := FHeader.Treeview.ComputeRTLOffset - else - RTLOffset := 0; - - if RTLOffset = 0 then - PaintFixedArea; - - // Paint the floating part of the header. - PaintHeader(FHeaderBitmap.Canvas, - Rect(VisibleFixedWidth - HOffset, 0, R.Right + VisibleFixedWidth - HOffset, R.Bottom - R.Top), - Point(R.Left + VisibleFixedWidth, R.Top), RTLOffset); - - // In case of right-to-left directionality we paint the fixed part last. - if RTLOffset <> 0 then - PaintFixedArea; - - // Blit the result to target. - with TWithSafeRect(R) do - BitBlt(DC, Left, Top, Right - Left, Bottom - Top, FHeaderBitmap.Canvas.Handle, Left, Top, SRCCOPY); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumns.PaintHeader(TargetCanvas: TCanvas; R: TRect; const Target: TPoint; - RTLOffset: Integer = 0); - -// Main paint method to draw the header. -// This procedure will paint the a slice (given in R) out of HeaderRect into TargetCanvas starting at position Target. -// This function does not offer the option to visually move floating columns due to scrolling. To accomplish this you -// need to call this method twice. - -var - Run: TColumnIndex; - RightBorderFlag, - NormalButtonStyle, - NormalButtonFlags, - PressedButtonStyle, - PressedButtonFlags, - RaisedButtonStyle, - RaisedButtonFlags: Cardinal; - Images: TCustomImageList; - OwnerDraw, - AdvancedOwnerDraw: Boolean; - PaintInfo: THeaderPaintInfo; - RequestedElements, - ActualElements: THeaderPaintElements; - - //--------------- local functions ------------------------------------------- - - procedure PrepareButtonStyles; - - // Prepare the button styles and flags for later usage. - - begin - RaisedButtonStyle := 0; - RaisedButtonFlags := 0; - case FHeader.Style of - hsThickButtons: - begin - NormalButtonStyle := BDR_RAISEDINNER or BDR_RAISEDOUTER; - NormalButtonFlags := BF_LEFT or BF_TOP or BF_BOTTOM or BF_MIDDLE or BF_SOFT or BF_ADJUST; - PressedButtonStyle := BDR_RAISEDINNER or BDR_RAISEDOUTER; - PressedButtonFlags := NormalButtonFlags or BF_RIGHT or BF_FLAT or BF_ADJUST; - end; - hsFlatButtons: - begin - NormalButtonStyle := BDR_RAISEDINNER; - NormalButtonFlags := BF_LEFT or BF_TOP or BF_BOTTOM or BF_MIDDLE or BF_ADJUST; - PressedButtonStyle := BDR_SUNKENOUTER; - PressedButtonFlags := BF_RECT or BF_MIDDLE or BF_ADJUST; - end; - else - // hsPlates or hsXPStyle, values are not used in the latter case - begin - NormalButtonStyle := BDR_RAISEDINNER; - NormalButtonFlags := BF_RECT or BF_MIDDLE or BF_SOFT or BF_ADJUST; - PressedButtonStyle := BDR_SUNKENOUTER; - PressedButtonFlags := BF_RECT or BF_MIDDLE or BF_ADJUST; - RaisedButtonStyle := BDR_RAISEDINNER; - RaisedButtonFlags := BF_LEFT or BF_TOP or BF_BOTTOM or BF_MIDDLE or BF_ADJUST; - end; - end; - end; - - //--------------------------------------------------------------------------- - - procedure DrawBackground; - - // Draw the header background. - - var - BackgroundRect: TRect; - Details: TThemedElementDetails; - Theme: HTheme; - begin - BackgroundRect := Rect(Target.X, Target.Y, Target.X + R.Right - R.Left, Target.Y + FHeader.Height); - - with TargetCanvas do - begin - if hpeBackground in RequestedElements then - begin - PaintInfo.PaintRectangle := BackgroundRect; - FHeader.Treeview.DoAdvancedHeaderDraw(PaintInfo, [hpeBackground]); - end - else - begin - if (FHeader.Treeview.VclStyleEnabled and (seClient in FHeader.FOwner.StyleElements)) then - begin - Details := StyleServices.GetElementDetails(thHeaderItemRightNormal); - StyleServices.DrawElement(Handle, Details, BackgroundRect, @BackgroundRect); - end - else - if tsUseThemes in FHeader.Treeview.FStates then - begin - Theme := OpenThemeData(FHeader.Treeview.Handle, 'HEADER'); - DrawThemeBackground(Theme, Handle, HP_HEADERITEM, HIS_NORMAL, BackgroundRect, nil); - CloseThemeData(THeme); - end - else - begin - Brush.Color := FHeader.FBackgroundColor; - FillRect(BackgroundRect); - end; - end; - end; - end; - - //--------------------------------------------------------------------------- - - procedure PaintColumnHeader(AColumn: TColumnIndex; ATargetRect: TRect); - - // Draw a single column to TargetRect. The clipping rect needs to be set before - // this procedure is called. - - var - SavedDC: Integer; - ColCaptionText: string; - ColImageInfo: TVTImageInfo; - Glyph: TThemedHeader; - Details: TThemedElementDetails; - WrapCaption: Boolean; - DrawFormat: Cardinal; - Pos: TRect; - DrawHot: Boolean; - ImageWidth: Integer; - Theme: HTheme; - IdState: Integer; - begin - ColImageInfo.Ghosted := False; - PaintInfo.Column := Items[AColumn]; - with PaintInfo, Column do - begin - IsHoverIndex := (AColumn = FHoverIndex) and (hoHotTrack in FHeader.FOptions) and (coEnabled in FOptions); - IsDownIndex := (AColumn = FDownIndex) and not FCheckBoxHit; - - if (coShowDropMark in FOptions) and (AColumn = FDropTarget) and (AColumn <> FDragIndex) then - begin - if FDropBefore then - DropMark := dmmLeft - else - DropMark := dmmRight; - end - else - DropMark := dmmNone; - - //Fix for issue 643 - //Do not show the left drop mark if the position to drop is just preceding the target which means - //the dragged column will stay where it is - if (DropMark = dmmLeft) and (Items[FDragIndex].Position = TColumnPosition(Max(Integer(Items[FDropTarget].Position) - 1, 0))) - then - DropMark := dmmNone - else - //Do not show the right drop mark if the position to drop is just following the target which means - //the dragged column will stay where it is - if (DropMark = dmmRight) and (Items[FDragIndex].Position = Items[FDropTarget].Position + 1) - then - DropMark := dmmNone; - - IsEnabled := (coEnabled in FOptions) and (FHeader.Treeview.Enabled); - ShowHeaderGlyph := (hoShowImages in FHeader.FOptions) and ((Assigned(Images) and (FImageIndex > -1)) or FCheckBox); - ShowSortGlyph := (AColumn = FHeader.FSortColumn) and (hoShowSortGlyphs in FHeader.FOptions); - WrapCaption := coWrapCaption in FOptions; - - PaintRectangle := ATargetRect; - - // This path for text columns or advanced owner draw. - if (Style = vsText) or not OwnerDraw or AdvancedOwnerDraw then - begin - // See if the application wants to draw part of the header itself. - RequestedElements := []; - if AdvancedOwnerDraw then - begin - PaintInfo.Column := Items[AColumn]; - FHeader.Treeview.DoHeaderDrawQueryElements(PaintInfo, RequestedElements); - end; - - if ShowRightBorder or (AColumn < Count - 1) then - RightBorderFlag := BF_RIGHT - else - RightBorderFlag := 0; - - if hpeBackground in RequestedElements then - FHeader.Treeview.DoAdvancedHeaderDraw(PaintInfo, [hpeBackground]) - else - begin - if FHeader.Treeview.VclStyleEnabled and (seClient in FHeader.FOwner.StyleElements) then - begin - if IsDownIndex then - Details := StyleServices.GetElementDetails(thHeaderItemPressed) - else - if IsHoverIndex then - Details := StyleServices.GetElementDetails(thHeaderItemHot) - else - Details := StyleServices.GetElementDetails(thHeaderItemNormal); - StyleServices.DrawElement(TargetCanvas.Handle, Details, PaintRectangle, @PaintRectangle); - end - else - begin - if tsUseThemes in FHeader.Treeview.FStates then - begin - Theme := OpenThemeData(FHeader.Treeview.Handle, 'HEADER'); - if IsDownIndex then - IdState := HIS_PRESSED - else - if IsHoverIndex then - IdState := HIS_HOT - else - IdState := HIS_NORMAL; - DrawThemeBackground(Theme, TargetCanvas.Handle, HP_HEADERITEM, IdState, PaintRectangle, nil); - CloseThemeData(Theme); - end - else - if IsDownIndex then - DrawEdge(TargetCanvas.Handle, PaintRectangle, PressedButtonStyle, PressedButtonFlags) - else - // Plates have the special case of raising on mouse over. - if (FHeader.Style = hsPlates) and IsHoverIndex and - (coAllowClick in FOptions) and (coEnabled in FOptions) then - DrawEdge(TargetCanvas.Handle, PaintRectangle, RaisedButtonStyle, - RaisedButtonFlags or RightBorderFlag) - else - DrawEdge(TargetCanvas.Handle, PaintRectangle, NormalButtonStyle, - NormalButtonFlags or RightBorderFlag); - end; - end; - - PaintRectangle := ATargetRect; - - // calculate text and glyph position - InflateRect(PaintRectangle, -2, -2); - DrawFormat := DT_TOP or DT_NOPREFIX; - case CaptionAlignment of - taLeftJustify : DrawFormat := DrawFormat or DT_LEFT; - taRightJustify : DrawFormat := DrawFormat or DT_RIGHT; - taCenter : DrawFormat := DrawFormat or DT_CENTER; - end; - if UseRightToLeftReading then - DrawFormat := DrawFormat + DT_RTLREADING; - ComputeHeaderLayout(PaintInfo, DrawFormat); - - // Move glyph and text one pixel to the right and down to simulate a pressed button. - if IsDownIndex then - begin - OffsetRect(TextRectangle, 1, 1); - Inc(GlyphPos.X); - Inc(GlyphPos.Y); - Inc(SortGlyphPos.X); - Inc(SortGlyphPos.Y); - end; - - // Advanced owner draw allows to paint elements, which would normally not be painted (because of space - // limitations, empty captions etc.). - ActualElements := RequestedElements * [hpeHeaderGlyph, hpeSortGlyph, hpeDropMark, hpeText, hpeOverlay]; - - // main glyph - FHasImage := False; - if Assigned(Images) then - ImageWidth := Images.Width - else - ImageWidth := 0; - - if not (hpeHeaderGlyph in ActualElements) and ShowHeaderGlyph and - (not ShowSortGlyph or (FBiDiMode <> bdLeftToRight) or (GlyphPos.X + ImageWidth <= SortGlyphPos.X) ) then - begin - if not FCheckBox then - begin - ColImageInfo.Images := Images; - Images.Draw(TargetCanvas, GlyphPos.X, GlyphPos.Y, FImageIndex, IsEnabled); - end - else - begin - with Header.Treeview do - begin - ColImageInfo.Images := FCheckImages; - ColImageInfo.Index := GetCheckImage(nil, FCheckType, FCheckState, IsEnabled); - ColImageInfo.XPos := GlyphPos.X; - ColImageInfo.YPos := GlyphPos.Y; - PaintCheckImage(TargetCanvas, ColImageInfo, False); - end; - end; - - FHasImage := True; - with TWithSafeRect(FImageRect) do - begin - Left := GlyphPos.X; - Top := GlyphPos.Y; - Right := Left + ColImageInfo.Images.Width; - Bottom := Top + ColImageInfo.Images.Height; - end; - end; - - // caption - if WrapCaption then - ColCaptionText := FCaptionText - else - ColCaptionText := Text; - if IsHoverIndex and FHeader.Treeview.VclStyleEnabled then - DrawHot := True - else - DrawHot := (IsHoverIndex and (hoHotTrack in FHeader.FOptions) and not(tsUseThemes in FHeader.Treeview.FStates)); - if not(hpeText in ActualElements) and (Length(Text) > 0) then - DrawButtonText(TargetCanvas.Handle, ColCaptionText, TextRectangle, IsEnabled, DrawHot, DrawFormat, WrapCaption); - - // sort glyph - if not (hpeSortGlyph in ActualElements) and ShowSortGlyph then - begin - if tsUseExplorerTheme in FHeader.Treeview.FStates then - begin - Pos.TopLeft := SortGlyphPos; - Pos.Right := Pos.Left + SortGlyphSize.cx; - Pos.Bottom := Pos.Top + SortGlyphSize.cy; - if FHeader.FSortDirection = sdAscending then - Glyph := thHeaderSortArrowSortedUp - else - Glyph := thHeaderSortArrowSortedDown; - Details := StyleServices.GetElementDetails(Glyph); - if not StyleServices.DrawElement(TargetCanvas.Handle, Details, Pos, @Pos) then - PaintInfo.DrawSortArrow(FHeader.FSortDirection); - end - else - begin - PaintInfo.DrawSortArrow(FHeader.FSortDirection); - end; - end; - - // Show an indication if this column is the current drop target in a header drag operation. - if not (hpeDropMark in ActualElements) and (DropMark <> dmmNone) then - begin - PaintInfo.DrawDropMark(); - end; - - if ActualElements <> [] then - begin - SavedDC := SaveDC(TargetCanvas.Handle); - FHeader.Treeview.DoAdvancedHeaderDraw(PaintInfo, ActualElements); - RestoreDC(TargetCanvas.Handle, SavedDC); - end; - end - else // Let application draw the header. - FHeader.Treeview.DoHeaderDraw(TargetCanvas, Items[AColumn], PaintRectangle, IsHoverIndex, IsDownIndex, - DropMark); - end; - end; - - //--------------- end local functions --------------------------------------- - -var - TargetRect: TRect; - MaxX: Integer; - -begin - if IsRectEmpty(R) then - Exit; - - // If both draw posibillities are specified then prefer the advanced way. - AdvancedOwnerDraw := (hoOwnerDraw in FHeader.FOptions) and Assigned(FHeader.Treeview.FOnAdvancedHeaderDraw) and - Assigned(FHeader.Treeview.FOnHeaderDrawQueryElements) and not (csDesigning in FHeader.Treeview.ComponentState); - OwnerDraw := (hoOwnerDraw in FHeader.FOptions) and Assigned(FHeader.Treeview.FOnHeaderDraw) and - not (csDesigning in FHeader.Treeview.ComponentState) and not AdvancedOwnerDraw; - - ZeroMemory(@PaintInfo, SizeOf(PaintInfo)); - PaintInfo.TargetCanvas := TargetCanvas; - - with PaintInfo, TargetCanvas do - begin - // Use shortcuts for the images and the font. - Images := FHeader.FImages; - Font := FHeader.FFont; - - PrepareButtonStyles; - - // At first, query the application which parts of the header it wants to draw on its own. - RequestedElements := []; - if AdvancedOwnerDraw then - begin - PaintRectangle := R; - Column := nil; - FHeader.Treeview.DoHeaderDrawQueryElements(PaintInfo, RequestedElements); - end; - - // Draw the background. - DrawBackground; - - // Now that we have drawn the background, we apply the header's dimensions to R. - R := Rect(Max(R.Left, 0), Max(R.Top, 0), Min(R.Right, TotalWidth), Min(R.Bottom, Header.Height)); - - // Determine where to stop. - MaxX := Target.X + R.Right - R.Left - //Fixes issues #544, #427 -- MaxX should also shift on BidiMode bdRightToLeft - + RTLOffset; //added for fix - - // Determine the start column. - Run := ColumnFromPosition(Point(R.Left + RTLOffset, 0), False); - if Run <= NoColumn then - Exit; - - TargetRect.Top := Target.Y; - TargetRect.Bottom := Target.Y + R.Bottom - R.Top; - TargetRect.Left := Target.X - R.Left + Items[Run].FLeft + RTLOffset; - // TargetRect.Right will be set in the loop - - ShowRightBorder := (FHeader.Style = hsThickButtons) or not (hoAutoResize in FHeader.FOptions) or - (FHeader.Treeview.BevelKind = bkNone); - - // Now go for each button. - while (Run > NoColumn) and (TargetRect.Left < MaxX) do - begin - TargetRect.Right := TargetRect.Left + Items[Run].FWidth; - - // create a clipping rect to limit painting to button area - ClipCanvas(TargetCanvas, Rect(Max(TargetRect.Left, Target.X), Target.Y + R.Top, - Min(TargetRect.Right, MaxX), TargetRect.Bottom)); - - PaintColumnHeader(Run, TargetRect); - - SelectClipRgn(Handle, 0); - - TargetRect.Left := TargetRect.Right; - Run := GetNextVisibleColumn(Run); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumns.SaveToStream(const Stream: TStream); - -var - I: Integer; - -begin - I := Count; - Stream.WriteBuffer(I, SizeOf(I)); - if I > 0 then - begin - for I := 0 to Count - 1 do - TVirtualTreeColumn(Items[I]).SaveToStream(Stream); - - Stream.WriteBuffer(FPositionToIndex[0], Count * SizeOf(TColumnIndex)); - end; - - // Data introduced with header stream version 5. - Stream.WriteBuffer(DefaultWidth, SizeOf(DefaultWidth)); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumns.TotalWidth: Integer; - -var - LastColumn: TColumnIndex; - -begin - Result := 0; - if (Count > 0) and (Length(FPositionToIndex) > 0) then - begin - LastColumn := FPositionToIndex[Count - 1]; - if not (coVisible in Items[LastColumn].FOptions) then - LastColumn := GetPreviousVisibleColumn(LastColumn); - if LastColumn > NoColumn then - with Items[LastColumn] do - Result := FLeft + FWidth; - end; -end; - -//----------------- TVTFixedAreaConstraints ---------------------------------------------------------------------------- - -constructor TVTFixedAreaConstraints.Create(AOwner: TVTHeader); - -begin - inherited Create; - - FHeader := AOwner; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTFixedAreaConstraints.SetConstraints(Index: Integer; Value: TVTConstraintPercent); - -begin - case Index of - 0: - if Value <> FMaxHeightPercent then - begin - FMaxHeightPercent := Value; - if (Value > 0) and (Value < FMinHeightPercent) then - FMinHeightPercent := Value; - Change; - end; - 1: - if Value <> FMaxWidthPercent then - begin - FMaxWidthPercent := Value; - if (Value > 0) and (Value < FMinWidthPercent) then - FMinWidthPercent := Value; - Change; - end; - 2: - if Value <> FMinHeightPercent then - begin - FMinHeightPercent := Value; - if (FMaxHeightPercent > 0) and (Value > FMaxHeightPercent) then - FMaxHeightPercent := Value; - Change; - end; - 3: - if Value <> FMinWidthPercent then - begin - FMinWidthPercent := Value; - if (FMaxWidthPercent > 0) and (Value > FMaxWidthPercent) then - FMaxWidthPercent := Value; - Change; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTFixedAreaConstraints.Change; - -begin - if Assigned(FOnChange) then - FOnChange(Self); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTFixedAreaConstraints.Assign(Source: TPersistent); - -begin - if Source is TVTFixedAreaConstraints then - begin - FMaxHeightPercent := TVTFixedAreaConstraints(Source).FMaxHeightPercent; - FMaxWidthPercent := TVTFixedAreaConstraints(Source).FMaxWidthPercent; - FMinHeightPercent := TVTFixedAreaConstraints(Source).FMinHeightPercent; - FMinWidthPercent := TVTFixedAreaConstraints(Source).FMinWidthPercent; - Change; - end - else - inherited; -end; - -//----------------- TVTHeader ----------------------------------------------------------------------------------------- - -constructor TVTHeader.Create(AOwner: TBaseVirtualTree); - -begin - inherited Create; - FOwner := AOwner; - FColumns := GetColumnsClass.Create(Self); - FHeight := 19; - FDefaultHeight := FHeight; - FMinHeight := 10; - FMaxHeight := 10000; - FFont := TFont.Create; - FFont.OnChange := FontChanged; - FParentFont := True; - FBackgroundColor := clBtnFace; - FOptions := [hoColumnResize, hoDrag, hoShowSortGlyphs]; - - FImageChangeLink := TChangeLink.Create; - FImageChangeLink.OnChange := ImageListChange; - - FSortColumn := NoColumn; - FSortDirection := sdAscending; - FMainColumn := NoColumn; - - FDragImage := TVTDragImage.Create(AOwner); - with FDragImage do - begin - Fade := False; - PreBlendBias := -50; - Transparency := 140; - end; - - fSplitterHitTolerance := 8; - FFixedAreaConstraints := TVTFixedAreaConstraints.Create(Self); - FFixedAreaConstraints.OnChange := FixedAreaConstraintsChanged; - - FDoingAutoFitColumns := false; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -destructor TVTHeader.Destroy; - -begin - FDragImage.Free; - FFixedAreaConstraints.Free; - FImageChangeLink.Free; - FFont.Free; - FColumns.Clear; // TCollection's Clear method is not virtual, so we have to call our own Clear method manually. - FColumns.Free; - inherited; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.FontChanged(Sender: TObject); -begin - inherited; - AutoScale(); -end; - -procedure TVTHeader.AutoScale(); -var - I: Integer; - lMaxHeight: Integer; -begin - if toAutoChangeScale in Treeview.TreeOptions.AutoOptions then - begin - // Find the largest Columns[].Spacing - lMaxHeight := 0; - for I := 0 to Self.Columns.Count - 1 do - lMaxHeight := Max(lMaxHeight, Columns[I].Spacing); - // Calculate the required size based on the font, this is important as the use migth just vave increased the size of the icon font - with TBitmap.Create do - try - Canvas.Font.Assign(FFont); - lMaxHeight := lMaxHeight {top spacing} + (lMaxHeight div 2) {minimum bottom spacing} + Canvas.TextHeight('Q'); - finally - Free; - end; - // Get the maximum of the scaled original value an - lMaxHeight := Max(lMaxHeight, FHeight); - // Set the calculated size - Self.SetHeight(lMaxHeight); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTHeader.GetMainColumn: TColumnIndex; - -begin - if FColumns.Count > 0 then - Result := FMainColumn - else - Result := NoColumn; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTHeader.GetUseColumns: Boolean; - -begin - Result := FColumns.Count > 0; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTHeader.IsFontStored: Boolean; - -begin - Result := not ParentFont; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.SetAutoSizeIndex(Value: TColumnIndex); - -begin - if FAutoSizeIndex <> Value then - begin - FAutoSizeIndex := Value; - if hoAutoResize in FOptions then - Columns.AdjustAutoSize(InvalidColumn); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.SetBackground(Value: TColor); - -begin - if FBackgroundColor <> Value then - begin - FBackgroundColor := Value; - Invalidate(nil); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.SetColumns(Value: TVirtualTreeColumns); - -begin - FColumns.Assign(Value); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.SetDefaultHeight(Value: Integer); - -begin - if Value < FMinHeight then - Value := FMinHeight; - if Value > FMaxHeight then - Value := FMaxHeight; - - if FHeight = FDefaultHeight then - SetHeight(Value); - FDefaultHeight := Value; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.SetFont(const Value: TFont); - -begin - FFont.Assign(Value); - FParentFont := False; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.SetHeight(Value: Integer); - -var - RelativeMaxHeight, - RelativeMinHeight, - EffectiveMaxHeight, - EffectiveMinHeight: Integer; - -begin - if not TreeView.HandleAllocated then - begin - FHeight := Value; - Include(FStates, hsNeedScaling); - end - else - begin - with FFixedAreaConstraints do - begin - RelativeMaxHeight := ((Treeview.ClientHeight + FHeight) * FMaxHeightPercent) div 100; - RelativeMinHeight := ((Treeview.ClientHeight + FHeight) * FMinHeightPercent) div 100; - - EffectiveMinHeight := IfThen(FMaxHeightPercent > 0, Min(RelativeMaxHeight, FMinHeight), FMinHeight); - EffectiveMaxHeight := IfThen(FMinHeightPercent > 0, Max(RelativeMinHeight, FMaxHeight), FMaxHeight); - - Value := Min(Max(Value, EffectiveMinHeight), EffectiveMaxHeight); - if FMinHeightPercent > 0 then - Value := Max(RelativeMinHeight, Value); - if FMaxHeightPercent > 0 then - Value := Min(RelativeMaxHeight, Value); - end; - - if FHeight <> Value then - begin - FHeight := Value; - if not (csLoading in Treeview.ComponentState) and not (hsScaling in FStates) then - RecalculateHeader; - Treeview.Invalidate; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.SetImages(const Value: TCustomImageList); - -begin - if FImages <> Value then - begin - if Assigned(FImages) then - begin - FImages.UnRegisterChanges(FImageChangeLink); - FImages.RemoveFreeNotification(FOwner); - end; - FImages := Value; - if Assigned(FImages) then - begin - FImages.RegisterChanges(FImageChangeLink); - FImages.FreeNotification(FOwner); - end; - if not (csLoading in Treeview.ComponentState) then - Invalidate(nil); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.SetMainColumn(Value: TColumnIndex); - -begin - if csLoading in Treeview.ComponentState then - FMainColumn := Value - else - begin - if Value < 0 then - Value := 0; - if Value > FColumns.Count - 1 then - Value := FColumns.Count - 1; - if Value <> FMainColumn then - begin - FMainColumn := Value; - if not (csLoading in Treeview.ComponentState) then - begin - Treeview.MainColumnChanged; - if not (toExtendedFocus in Treeview.FOptions.FSelectionOptions) then - Treeview.FocusedColumn := FMainColumn; - Treeview.Invalidate; - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.SetMaxHeight(Value: Integer); - -begin - if Value < FMinHeight then - Value := FMinHeight; - FMaxHeight := Value; - SetHeight(FHeight); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.SetMinHeight(Value: Integer); - -begin - if Value < 0 then - Value := 0; - if Value > FMaxHeight then - Value := FMaxHeight; - FMinHeight := Value; - SetHeight(FHeight); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.SetOptions(Value: TVTHeaderOptions); - -var - ToBeSet, - ToBeCleared: TVTHeaderOptions; - -begin - ToBeSet := Value - FOptions; - ToBeCleared := FOptions - Value; - FOptions := Value; - - if (hoAutoResize in (ToBeSet + ToBeCleared)) and (FColumns.Count > 0) then - begin - FColumns.AdjustAutoSize(InvalidColumn); - if Treeview.HandleAllocated then - begin - Treeview.UpdateHorizontalScrollBar(False); - if hoAutoResize in ToBeSet then - Treeview.Invalidate; - end; - end; - - if not (csLoading in Treeview.ComponentState) and Treeview.HandleAllocated then - begin - if hoVisible in (ToBeSet + ToBeCleared) then - RecalculateHeader; - Invalidate(nil); - Treeview.Invalidate; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.SetParentFont(Value: Boolean); - -begin - if FParentFont <> Value then - begin - FParentFont := Value; - if FParentFont then - FFont.Assign(FOwner.Font); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.SetSortColumn(Value: TColumnIndex); - -begin - if csLoading in Treeview.ComponentState then - FSortColumn := Value - else - DoSetSortColumn(Value, FSortDirection); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.SetSortDirection(const Value: TSortDirection); - -begin - if Value <> FSortDirection then - begin - FSortDirection := Value; - Invalidate(nil); - if ((toAutoSort in Treeview.FOptions.FAutoOptions) or (hoHeaderClickAutoSort in Options)) and (Treeview.FUpdateCount = 0) then - Treeview.SortTree(FSortColumn, FSortDirection, True); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTHeader.CanSplitterResize(P: TPoint): Boolean; - -begin - Result := hoHeightResize in FOptions; - DoCanSplitterResize(P, Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.SetStyle(Value: TVTHeaderStyle); - -begin - if FStyle <> Value then - begin - FStyle := Value; - if not (csLoading in Treeview.ComponentState) then - Invalidate(nil); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTHeader.CanWriteColumns: Boolean; - -// descendants may override this to optionally prevent column writing (e.g. if they are build dynamically). - -begin - Result := True; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.ChangeScale(M, D: Integer); -var - I: Integer; -begin - // This method is only executed if toAutoChangeScale is set - Self.Height := MulDiv(FHeight, M, D); - if not ParentFont then - Font.Height := MulDiv(Font.Height, M, D); - // Scale the columns widths too - for I := 0 to FColumns.Count - 1 do - begin - Self.FColumns[I].Width := MulDiv(Self.FColumns[I].Width, M, D); - end;//for I - AutoScale(); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTHeader.DetermineSplitterIndex(P: TPoint): Boolean; - -// Tries to find the index of that column whose right border corresponds to P. -// Result is True if column border was hit (with -3..+5 pixels tolerance). -// For continuous resizing the current track index and the column's left/right border are set. -// Note: The hit test is checking from right to left (or left to right in RTL mode) to make enlarging of zero-sized -// columns possible. - -var - VisibleFixedWidth: Integer; - SplitPoint: Integer; - - //--------------- local function -------------------------------------------- - - function IsNearBy(IsFixedCol: Boolean; LeftTolerance, RightTolerance: Integer): Boolean; - - begin - if IsFixedCol then - Result := (P.X < SplitPoint + Treeview.FEffectiveOffsetX + RightTolerance) and (P.X > SplitPoint + Treeview.FEffectiveOffsetX - LeftTolerance) - else - Result := (P.X > VisibleFixedWidth) and (P.X < SplitPoint + RightTolerance) and (P.X > SplitPoint - LeftTolerance); - end; - - //--------------- end local function ---------------------------------------- - -var - I: Integer; - LeftTolerance: Integer; // The area left of the column divider which allows column resizing -begin - Result := False; - - if FColumns.Count > 0 then - begin - FColumns.FTrackIndex := NoColumn; - VisibleFixedWidth := FColumns.GetVisibleFixedWidth; - LeftTolerance := Round(SplitterHitTolerance * 0.6); - if Treeview.UseRightToLeftAlignment then - begin - SplitPoint := -Treeview.FEffectiveOffsetX; - if FColumns.TotalWidth < Treeview.ClientWidth then - Inc(SplitPoint, Treeview.ClientWidth - FColumns.TotalWidth); - - for I := 0 to FColumns.Count - 1 do - with FColumns, Items[FPositionToIndex[I]] do - if coVisible in FOptions then - begin - if IsNearBy(coFixed in FOptions, LeftTolerance, SplitterHitTolerance - LeftTolerance) then - begin - if CanSplitterResize(P, FPositionToIndex[I]) then - begin - Result := True; - FTrackIndex := FPositionToIndex[I]; - - // Keep the right border of this column. This and the current mouse position - // directly determine the current column width. - FTrackPoint.X := SplitPoint + IfThen(coFixed in FOptions, Treeview.FEffectiveOffsetX) + FWidth; - FTrackPoint.Y := P.Y; - Break; - end; - end; - Inc(SplitPoint, FWidth); - end; - end - else - begin - SplitPoint := -Treeview.FEffectiveOffsetX + FColumns.TotalWidth; - - for I := FColumns.Count - 1 downto 0 do - with FColumns, Items[FPositionToIndex[I]] do - if coVisible in FOptions then - begin - if IsNearBy(coFixed in FOptions, SplitterHitTolerance - LeftTolerance, LeftTolerance) then - begin - if CanSplitterResize(P, FPositionToIndex[I]) then - begin - Result := True; - FTrackIndex := FPositionToIndex[I]; - - // Keep the left border of this column. This and the current mouse position - // directly determine the current column width. - FTrackPoint.X := SplitPoint + IfThen(coFixed in FOptions, Treeview.FEffectiveOffsetX) - FWidth; - FTrackPoint.Y := P.Y; - Break; - end; - end; - Dec(SplitPoint, FWidth); - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.DoAfterAutoFitColumn(Column: TColumnIndex); - -begin - if Assigned(TreeView.FOnAfterAutoFitColumn) then - TreeView.FOnAfterAutoFitColumn(Self, Column); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.DoAfterColumnWidthTracking(Column: TColumnIndex); - -// Tell the application that a column width tracking operation has been finished. - -begin - if Assigned(TreeView.FOnAfterColumnWidthTracking) then - TreeView.FOnAfterColumnWidthTracking(Self, Column); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.DoAfterHeightTracking; - -// Tell the application that a height tracking operation has been finished. - -begin - if Assigned(TreeView.FOnAfterHeaderHeightTracking) then - TreeView.FOnAfterHeaderHeightTracking(Self); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTHeader.DoBeforeAutoFitColumn(Column: TColumnIndex; SmartAutoFitType: TSmartAutoFitType): Boolean; - -// Query the application if we may autofit a column. - -begin - Result := True; - if Assigned(TreeView.FOnBeforeAutoFitColumn) then - TreeView.FOnBeforeAutoFitColumn(Self, Column, SmartAutoFitType, Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.DoBeforeColumnWidthTracking(Column: TColumnIndex; Shift: TShiftState); - -// Tell the a application that a column width tracking operation may begin. - -begin - if Assigned(TreeView.FOnBeforeColumnWidthTracking) then - TreeView.FOnBeforeColumnWidthTracking(Self, Column, Shift); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.DoBeforeHeightTracking(Shift: TShiftState); - -// Tell the application that a height tracking operation may begin. - -begin - if Assigned(TreeView.FOnBeforeHeaderHeightTracking) then - TreeView.FOnBeforeHeaderHeightTracking(Self, Shift); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.DoCanSplitterResize(P: TPoint; var Allowed: Boolean); -begin - if Assigned(TreeView.FOnCanSplitterResizeHeader) then - TreeView.FOnCanSplitterResizeHeader(Self, P, Allowed); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTHeader.DoColumnWidthDblClickResize(Column: TColumnIndex; P: TPoint; Shift: TShiftState): Boolean; - -// Queries the application whether a double click on the column splitter should resize the column. - -begin - Result := True; - if Assigned(TreeView.FOnColumnWidthDblClickResize) then - TreeView.FOnColumnWidthDblClickResize(Self, Column, Shift, P, Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTHeader.DoColumnWidthTracking(Column: TColumnIndex; Shift: TShiftState; var TrackPoint: TPoint; P: TPoint): Boolean; - -begin - Result := True; - if Assigned(TreeView.FOnColumnWidthTracking) then - TreeView.FOnColumnWidthTracking(Self, Column, Shift, TrackPoint, P, Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTHeader.DoGetPopupMenu(Column: TColumnIndex; Position: TPoint): TPopupMenu; - -// Queries the application whether there is a column specific header popup menu. - -var - AskParent: Boolean; - -begin - Result := PopupMenu; - if Assigned(TreeView.FOnGetPopupMenu) then - TreeView.FOnGetPopupMenu(TreeView, nil, Column, Position, AskParent, Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTHeader.DoHeightTracking(var P: TPoint; Shift: TShiftState): Boolean; - -begin - Result := True; - if Assigned(TreeView.FOnHeaderHeightTracking) then - TreeView.FOnHeaderHeightTracking(Self, P, Shift, Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTHeader.DoHeightDblClickResize(var P: TPoint; Shift: TShiftState): Boolean; - -begin - Result := True; - if Assigned(TreeView.FOnHeaderHeightDblClickResize) then - TreeView.FOnHeaderHeightDblClickResize(Self, P, Shift, Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.DoSetSortColumn(Value: TColumnIndex; pSortDirection: TSortDirection); - -begin - if Value < NoColumn then - Value := NoColumn; - if Value > Columns.Count - 1 then - Value := Columns.Count - 1; - if FSortColumn <> Value then - begin - if FSortColumn > NoColumn then - Invalidate(Columns[FSortColumn]); - FSortColumn := Value; - FSortDirection := pSortDirection; - if FSortColumn > NoColumn then - Invalidate(Columns[FSortColumn]); - if ((toAutoSort in Treeview.FOptions.FAutoOptions) or (hoHeaderClickAutoSort in Options)) and (Treeview.FUpdateCount = 0) then - Treeview.SortTree(FSortColumn, FSortDirection, True); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.DragTo(P: TPoint); - -// Moves the drag image to a new position, which is determined from the passed point P and the previous -// mouse position. - -var - I, - NewTarget: Integer; - // optimized drag image move support - ClientP: TPoint; - Left, - Right: Integer; - NeedRepaint: Boolean; // True if the screen needs an update (changed drop target or drop side) - -begin - // Determine new drop target and which side of it is prefered. - ClientP := Treeview.ScreenToClient(P); - // Make coordinates relative to (0, 0) of the non-client area. - Inc(ClientP.Y, FHeight); - NewTarget := FColumns.ColumnFromPosition(ClientP); - NeedRepaint := (NewTarget <> InvalidColumn) and (NewTarget <> FColumns.FDropTarget); - if NewTarget >= 0 then - begin - FColumns.GetColumnBounds(NewTarget, Left, Right); - if (ClientP.X < ((Left + Right) div 2)) <> FColumns.FDropBefore then - begin - NeedRepaint := True; - FColumns.FDropBefore := not FColumns.FDropBefore; - end; - end; - - if NeedRepaint then - begin - // Invalidate columns which need a repaint. - if FColumns.FDropTarget > NoColumn then - begin - I := FColumns.FDropTarget; - FColumns.FDropTarget := NoColumn; - Invalidate(FColumns.Items[I]); - end; - if (NewTarget > NoColumn) and (NewTarget <> FColumns.FDropTarget) then - begin - Invalidate(FColumns.Items[NewTarget]); - FColumns.FDropTarget := NewTarget; - end; - end; - - // Fix for various problems mentioned in issue 248. - if NeedRepaint then - begin - UpdateWindow(FOwner.Handle); - // The new routine recaptures the backup image after the updatewindow - // Note: We could have called this unconditionally but when called - // over the tree, doesn't capture the background image. Since our - // problems are in painting of the header, we call it only when the - // drag image is over the header. - if - // determine the case when the drag image is or was on the header area - (InHeader(FOwner.ScreenToClient(FDragImage.FLastPosition)) - or InHeader(FOwner.ScreenToClient(FDragImage.FImagePosition)) - ) then - begin - GDIFlush; - FOwner.UpdateWindowAndDragImage(FOwner, FOwner.HeaderRect, True, true); - end; - // since we took care of UpdateWindow above, there is no need to do an - // update window again by sending NeedRepaint. So switch off the second parameter. - NeedRepaint := false; - end; - - FDragImage.DragTo(P, NeedRepaint); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.FixedAreaConstraintsChanged(Sender: TObject); - -// This method gets called when FFixedAreaConstraints is changed. - -begin - if Treeview.HandleAllocated then - RescaleHeader - else - Include(FStates, hsNeedScaling); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTHeader.GetColumnsClass: TVirtualTreeColumnsClass; - -// Returns the class to be used for the actual column implementation. descendants may optionally override this and -// return their own class. - -begin - Result := TVirtualTreeColumns; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTHeader.GetOwner: TPersistent; - -begin - Result := FOwner; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTHeader.GetShiftState: TShiftState; - -begin - Result := []; - if GetKeyState(VK_SHIFT) < 0 then - Include(Result, ssShift); - if GetKeyState(VK_CONTROL) < 0 then - Include(Result, ssCtrl); - if GetKeyState(VK_MENU) < 0 then - Include(Result, ssAlt); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTHeader.HandleHeaderMouseMove(var Message: TWMMouseMove): Boolean; - -var - P: TPoint; - NextColumn, - I: TColumnIndex; - NewWidth: Integer; - -begin - Result := False; - with Message do - begin - P := Point(XPos, YPos); - if hsColumnWidthTrackPending in FStates then - begin - Treeview.StopTimer(HeaderTimer); - FStates := FStates - [hsColumnWidthTrackPending] + [hsColumnWidthTracking]; - HandleHeaderMouseMove := True; - Result := 0; - end - else - if hsHeightTrackPending in FStates then - begin - Treeview.StopTimer(HeaderTimer); - FStates := FStates - [hsHeightTrackPending] + [hsHeightTracking]; - HandleHeaderMouseMove := True; - Result := 0; - end - else - if hsColumnWidthTracking in FStates then - begin - if DoColumnWidthTracking(FColumns.FTrackIndex, GetShiftState, FTrackPoint, P) then - begin - if Treeview.UseRightToLeftAlignment then - begin - NewWidth := FTrackPoint.X - XPos; - NextColumn := FColumns.GetPreviousVisibleColumn(FColumns.FTrackIndex); - end - else - begin - NewWidth := XPos - FTrackPoint.X; - NextColumn := FColumns.GetNextVisibleColumn(FColumns.FTrackIndex); - end; - - // The autosized column cannot be resized using the mouse normally. Instead we resize the next - // visible column, so it look as we directly resize the autosized column. - if (hoAutoResize in FOptions) and (FColumns.FTrackIndex = FAutoSizeIndex) and - (NextColumn > NoColumn) and (coResizable in FColumns[NextColumn].FOptions) and - (FColumns[FColumns.FTrackIndex].FMinWidth < NewWidth) and - (FColumns[FColumns.FTrackIndex].FMaxWidth > NewWidth) then - FColumns[NextColumn].Width := FColumns[NextColumn].Width - NewWidth - + FColumns[FColumns.FTrackIndex].Width - else - FColumns[FColumns.FTrackIndex].Width := NewWidth; // 1 EListError seen here (List index out of bounds (-1)) since 10/2013 - end; - HandleHeaderMouseMove := True; - Result := 0; - end - else - if hsHeightTracking in FStates then - begin - if DoHeightTracking(P, GetShiftState) then - SetHeight(Integer(FHeight) + P.Y); - HandleHeaderMouseMove := True; - Result := 0; - end - else - begin - if hsDragPending in FStates then - begin - P := Treeview.ClientToScreen(P); - // start actual dragging if allowed - if (hoDrag in FOptions) and Treeview.DoHeaderDragging(FColumns.FDownIndex) then - begin - if ((Abs(FDragStart.X - P.X) > Mouse.DragThreshold) or - (Abs(FDragStart.Y - P.Y) > Mouse.DragThreshold)) then - begin - Treeview.StopTimer(HeaderTimer); - I := FColumns.FDownIndex; - FColumns.FDownIndex := NoColumn; - FColumns.FHoverIndex := NoColumn; - if I > NoColumn then - Invalidate(FColumns[I]); - PrepareDrag(P, FDragStart); - FStates := FStates - [hsDragPending] + [hsDragging]; - HandleHeaderMouseMove := True; - Result := 0; - end; - end; - end - else - if hsDragging in FStates then - begin - DragTo(Treeview.ClientToScreen(Point(XPos, YPos))); - HandleHeaderMouseMove := True; - Result := 0; - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTHeader.HandleMessage(var Message: TMessage): Boolean; - -// The header gets here the opportunity to handle certain messages before they reach the tree. This is important -// because the tree needs to handle various non-client area messages for the header as well as some dragging/tracking -// events. -// By returning True the message will not be handled further, otherwise the message is then dispatched -// to the proper message handlers. - -var - P: TPoint; - R: TRect; - I: TColumnIndex; - OldPosition: Integer; - HitIndex: TColumnIndex; - NewCursor: HCURSOR; - Button: TMouseButton; - IsInHeader, - IsHSplitterHit, - IsVSplitterHit: Boolean; - - //--------------- local function -------------------------------------------- - - function HSplitterHit: Boolean; - - var - NextCol: TColumnIndex; - - begin - Result := (hoColumnResize in FOptions) and DetermineSplitterIndex(P); - if Result and not InHeader(P) then - begin - NextCol := FColumns.GetNextVisibleColumn(FColumns.FTrackIndex); - if not (coFixed in FColumns[FColumns.FTrackIndex].Options) or (NextCol <= NoColumn) or - (coFixed in FColumns[NextCol].Options) or (P.Y > Integer(Treeview.FRangeY)) then - Result := False; - end; - end; - - //--------------- end local function ---------------------------------------- - -begin - Result := False; - case Message.Msg of - WM_SIZE: - begin - if not (tsWindowCreating in FOwner.FStates) then - if (hoAutoResize in FOptions) and not (hsAutoSizing in FStates) then - begin - FColumns.AdjustAutoSize(InvalidColumn); - Invalidate(nil); - end - else - if not (hsScaling in FStates) then - begin - RescaleHeader; - Invalidate(nil); - end; - end; - CM_PARENTFONTCHANGED: - if FParentFont then - FFont.Assign(FOwner.Font); - CM_BIDIMODECHANGED: - for I := 0 to FColumns.Count - 1 do - if coParentBiDiMode in FColumns[I].FOptions then - FColumns[I].ParentBiDiModeChanged; - WM_NCMBUTTONDOWN: - begin - with TWMNCMButtonDown(Message) do - P := Treeview.ScreenToClient(Point(XCursor, YCursor)); - if InHeader(P) then - FOwner.DoHeaderMouseDown(mbMiddle, GetShiftState, P.X, P.Y + Integer(FHeight)); - end; - WM_NCMBUTTONUP: - begin - with TWMNCMButtonUp(Message) do - P := FOwner.ScreenToClient(Point(XCursor, YCursor)); - if InHeader(P) then - begin - FColumns.HandleClick(P, mbMiddle, True, False); - FOwner.DoHeaderMouseUp(mbMiddle, GetShiftState, P.X, P.Y + Integer(FHeight)); - FColumns.FDownIndex := NoColumn; - FColumns.FCheckBoxHit := False; - end; - end; - WM_LBUTTONDBLCLK, - WM_NCLBUTTONDBLCLK, - WM_NCMBUTTONDBLCLK, - WM_NCRBUTTONDBLCLK: - begin - if Message.Msg <> WM_LBUTTONDBLCLK then - with TWMNCLButtonDblClk(Message) do - P := FOwner.ScreenToClient(Point(XCursor, YCursor)) - else - with TWMLButtonDblClk(Message) do - P := Point(XPos, YPos); - - if (hoHeightDblClickResize in FOptions) and InHeaderSplitterArea(P) and (FDefaultHeight > 0) then - begin - if DoHeightDblClickResize(P, GetShiftState) and (FDefaultHeight > 0) then - SetHeight(FMinHeight); - Result := True; - end - else - if HSplitterHit and ((Message.Msg = WM_NCLBUTTONDBLCLK) or (Message.Msg = WM_LBUTTONDBLCLK)) and - (hoDblClickResize in FOptions) and (FColumns.FTrackIndex > NoColumn) then - begin - // If the click was on a splitter then resize column to smallest width. - if DoColumnWidthDblClickResize(FColumns.FTrackIndex, P, GetShiftState) then - AutoFitColumns(True, smaUseColumnOption, FColumns[FColumns.FTrackIndex].FPosition, - FColumns[FColumns.FTrackIndex].FPosition); - Message.Result := 0; - Result := True; - end - else - if InHeader(P) and (Message.Msg <> WM_LBUTTONDBLCLK) then - begin - case Message.Msg of - WM_NCMBUTTONDBLCLK: - Button := mbMiddle; - WM_NCRBUTTONDBLCLK: - Button := mbRight; - else - // WM_NCLBUTTONDBLCLK - Button := mbLeft; - end; - if Button = mbLeft then - Columns.AdjustDownColumn(P); - FColumns.HandleClick(P, Button, True, True); - end; - end; - // The "hot" area of the headers horizontal splitter is partly within the client area of the the tree, so we need - // to handle WM_LBUTTONDOWN here, too. - WM_LBUTTONDOWN, - WM_NCLBUTTONDOWN: - begin - - Application.CancelHint; - - if not (csDesigning in Treeview.ComponentState) then - begin - // make sure no auto scrolling is active... - Treeview.StopTimer(ScrollTimer); - Treeview.DoStateChange([], [tsScrollPending, tsScrolling]); - // ... pending editing is cancelled (actual editing remains active) - Treeview.StopTimer(EditTimer); - Treeview.DoStateChange([], [tsEditPending]); - end; - - if Message.Msg = WM_LBUTTONDOWN then - // Coordinates are already client area based. - with TWMLButtonDown(Message) do - begin - P := Point(XPos, YPos); - // #909 - FDragStart := Treeview.ClientToScreen(p); - end - else - with TWMNCLButtonDown(Message) do - begin - // want the drag start point in screen coordinates - FDragStart := Point(XCursor, YCursor); - P := Treeview.ScreenToClient(FDragStart); - end; - - IsInHeader := InHeader(P); - // in design-time header columns are always resizable - if (csDesigning in Treeview.ComponentState) then - IsVSplitterHit := InHeaderSplitterArea(P) - else - IsVSplitterHit := InHeaderSplitterArea(P) and CanSplitterResize(P); - IsHSplitterHit := HSplitterHit; - - if IsVSplitterHit or IsHSplitterHit then - begin - FTrackStart := P; - FColumns.FHoverIndex := NoColumn; - if IsVSplitterHit then - begin - if not (csDesigning in Treeview.ComponentState) then - DoBeforeHeightTracking(GetShiftState); - Include(FStates, hsHeightTrackPending); - end - else - begin - if not (csDesigning in Treeview.ComponentState) then - DoBeforeColumnWidthTracking(FColumns.FTrackIndex, GetShiftState); - Include(FStates, hsColumnWidthTrackPending); - end; - - SetCapture(Treeview.Handle); - Result := True; - Message.Result := 0; - end - else - if IsInHeader then - begin - HitIndex := Columns.AdjustDownColumn(P); - // in design-time header columns are always draggable - if ((csDesigning in Treeview.ComponentState) and (HitIndex > NoColumn)) or - ((hoDrag in FOptions) and (HitIndex > NoColumn) and (coDraggable in FColumns[HitIndex].FOptions)) then - begin - // Show potential drag operation. - // Disabled columns do not start a drag operation because they can't be clicked. - Include(FStates, hsDragPending); - SetCapture(Treeview.Handle); - Result := True; - Message.Result := 0; - end; - end; - - // This is a good opportunity to notify the application. - if not (csDesigning in Treeview.ComponentState) and IsInHeader then - FOwner.DoHeaderMouseDown(mbLeft, GetShiftState, P.X, P.Y + Integer(FHeight)); - end; - WM_NCRBUTTONDOWN: - begin - with TWMNCRButtonDown(Message) do - P := FOwner.ScreenToClient(Point(XCursor, YCursor)); - if InHeader(P) then - FOwner.DoHeaderMouseDown(mbRight, GetShiftState, P.X, P.Y + Integer(FHeight)); - end; - WM_NCRBUTTONUP: - if not (csDesigning in FOwner.ComponentState) then - with TWMNCRButtonUp(Message) do - begin - Application.CancelHint; - P := FOwner.ScreenToClient(Point(XCursor, YCursor)); - if InHeader(P) then - begin - HandleMessage := FColumns.HandleClick(P, mbRight, True, False); - FOwner.DoHeaderMouseUp(mbRight, GetShiftState, P.X, P.Y + Integer(FHeight)); - end; - end; - // When the tree window has an active mouse capture then we only get "client-area" messages. - WM_LBUTTONUP, - WM_NCLBUTTONUP: - begin - Application.CancelHint; - - if FStates <> [] then - begin - ReleaseCapture; - if hsDragging in FStates then - begin - // successfull dragging moves columns - with TWMLButtonUp(Message) do - P := Treeview.ClientToScreen(Point(XPos, YPos)); - GetWindowRect(Treeview.Handle, R); - with FColumns do - begin - FDragImage.EndDrag; - - //Problem fixed: - //Column Header does not paint correctly after a drop in certain conditions - //** The conditions are, drag is across header, mouse is not moved after - //the drop and the graphics hardware is slow in certain operations (encountered - //on Windows 10). - //Fix for the problem on certain systems where the dropped column header - //does not appear in the new position if the mouse is not moved after - //the drop. The reason is that the restore backup image operation (BitBlt) - //in the above EndDrag is slower than the header repaint in the code below - //and overlaps the new changed header with the older image. - //This happens because BitBlt seems to operate in its own thread in the - //graphics hardware and finishes later than the following code. - // - //To solve this problem, we introduce a small delay here so that the - //changed header in the following code is correctly repainted after - //the delayed BitBlt above has finished operation to restore the old - //backup image. - sleep(50); - - if (FDropTarget > -1) and (FDropTarget <> FDragIndex) and PtInRect(R, P) then - begin - OldPosition := FColumns[FDragIndex].Position; - if FColumns.FDropBefore then - begin - if FColumns[FDragIndex].Position < FColumns[FDropTarget].Position then - FColumns[FDragIndex].Position := Max(0, FColumns[FDropTarget].Position - 1) - else - FColumns[FDragIndex].Position := FColumns[FDropTarget].Position; - end - else - begin - if FColumns[FDragIndex].Position < FColumns[FDropTarget].Position then - FColumns[FDragIndex].Position := FColumns[FDropTarget].Position - else - FColumns[FDragIndex].Position := FColumns[FDropTarget].Position + 1; - end; - Treeview.DoHeaderDragged(FDragIndex, OldPosition); - end - else - Treeview.DoHeaderDraggedOut(FDragIndex, P); - FDropTarget := NoColumn; - end; - Invalidate(nil); - end; - Result := True; - Message.Result := 0; - end; - - case Message.Msg of - WM_LBUTTONUP: - with TWMLButtonUp(Message) do - begin - if FColumns.FDownIndex > NoColumn then - FColumns.HandleClick(Point(XPos, YPos), mbLeft, False, False); - if FStates <> [] then - FOwner.DoHeaderMouseUp(mbLeft, KeysToShiftState(Keys), XPos, YPos); - end; - WM_NCLBUTTONUP: - with TWMNCLButtonUp(Message) do - begin - P := FOwner.ScreenToClient(Point(XCursor, YCursor)); - FColumns.HandleClick(P, mbLeft, False, False); - FOwner.DoHeaderMouseUp(mbLeft, GetShiftState, P.X, P.Y + Integer(FHeight)); - end; - end; - - if FColumns.FTrackIndex > NoColumn then - begin - if hsColumnWidthTracking in FStates then - DoAfterColumnWidthTracking(FColumns.FTrackIndex); - Invalidate(Columns[FColumns.FTrackIndex]); - FColumns.FTrackIndex := NoColumn; - end; - if FColumns.FDownIndex > NoColumn then - begin - Invalidate(Columns[FColumns.FDownIndex]); - FColumns.FDownIndex := NoColumn; - end; - if hsHeightTracking in FStates then - DoAfterHeightTracking; - - FStates := FStates - [hsDragging, hsDragPending, - hsColumnWidthTracking, hsColumnWidthTrackPending, - hsHeightTracking, hsHeightTrackPending]; - end;// WM_NCLBUTTONUP - // hovering, mouse leave detection - WM_NCMOUSEMOVE: - with TWMNCMouseMove(Message), FColumns do - begin - P := Treeview.ScreenToClient(Point(XCursor, YCursor)); - Treeview.DoHeaderMouseMove(GetShiftState, P.X, P.Y + Integer(FHeight)); - if InHeader(P) and ((AdjustHoverColumn(P)) or ((FDownIndex >= 0) and (FHoverIndex <> FDownIndex))) then - begin - // We need a mouse leave detection from here for the non client area. - // TODO: The best solution available would be the TrackMouseEvent API. - // With the drop of the support of Win95 totally and WinNT4 we should replace the timer. - Treeview.StopTimer(HeaderTimer); - SetTimer(Treeview.Handle, HeaderTimer, 50, nil); - // use Delphi's internal hint handling for header hints too - if hoShowHint in FOptions then - begin - // client coordinates! - XCursor := P.X; - YCursor := P.Y + Integer(FHeight); - Application.HintMouseMessage(Treeview, Message); - end; - end; - end; - WM_TIMER: - if TWMTimer(Message).TimerID = HeaderTimer then - begin - // determine current mouse position to check if it left the window - GetCursorPos(P); - P := Treeview.ScreenToClient(P); - with FColumns do - begin - if not InHeader(P) or ((FDownIndex > NoColumn) and (FHoverIndex <> FDownIndex)) then - begin - Treeview.StopTimer(HeaderTimer); - FHoverIndex := NoColumn; - FClickIndex := NoColumn; - FDownIndex := NoColumn; - FCheckBoxHit := False; - Result := True; - Message.Result := 0; - Invalidate(nil); - end; - end; - end; - WM_MOUSEMOVE: // mouse capture and general message redirection - Result := HandleHeaderMouseMove(TWMMouseMove(Message)); - WM_SETCURSOR: - // Feature: design-time header - if (FStates = []) then - begin - // Retrieve last cursor position (GetMessagePos does not work here, I don't know why). - GetCursorPos(P); - - // Is the mouse in the header rectangle and near the splitters? - P := Treeview.ScreenToClient(P); - IsHSplitterHit := HSplitterHit; - // in design-time header columns are always resizable - if (csDesigning in Treeview.ComponentState) then - IsVSplitterHit := InHeaderSplitterArea(P) - else - IsVSplitterHit := InHeaderSplitterArea(P) and CanSplitterResize(P); - - if IsVSplitterHit or IsHSplitterHit then - begin - NewCursor := Screen.Cursors[Treeview.Cursor]; - if IsVSplitterHit and ((hoHeightResize in FOptions) or (csDesigning in Treeview.ComponentState)) then - NewCursor := Screen.Cursors[crVertSplit] - else - if IsHSplitterHit then - NewCursor := Screen.Cursors[crHeaderSplit]; - - if not (csDesigning in Treeview.ComponentState) then - Treeview.DoGetHeaderCursor(NewCursor); - Result := NewCursor <> Screen.Cursors[crDefault]; - if Result then - begin - Winapi.Windows.SetCursor(NewCursor); - Message.Result := 1; - end; - end; - end - else - begin - Message.Result := 1; - Result := True; - end; - WM_KEYDOWN, - WM_KILLFOCUS: - if (Message.Msg = WM_KILLFOCUS) or - (TWMKeyDown(Message).CharCode = VK_ESCAPE) then - begin - if hsDragging in FStates then - begin - ReleaseCapture; - FDragImage.EndDrag; - Exclude(FStates, hsDragging); - FColumns.FDropTarget := NoColumn; - Invalidate(nil); - Result := True; - Message.Result := 0; - end - else - begin - if [hsColumnWidthTracking, hsHeightTracking] * FStates <> [] then - begin - ReleaseCapture; - if hsColumnWidthTracking in FStates then - DoAfterColumnWidthTracking(FColumns.FTrackIndex); - if hsHeightTracking in FStates then - DoAfterHeightTracking; - Result := True; - Message.Result := 0; - end; - - FStates := FStates - [hsColumnWidthTracking, hsColumnWidthTrackPending, - hsHeightTracking, hsHeightTrackPending]; - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.ImageListChange(Sender: TObject); - -begin - if not (csDestroying in Treeview.ComponentState) then - Invalidate(nil); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.PrepareDrag(P, Start: TPoint); - -// Initializes dragging of the header, P is the current mouse postion and Start the initial mouse position. - -var - Image: TBitmap; - ImagePos: TPoint; - DragColumn: TVirtualTreeColumn; - RTLOffset: Integer; - -begin - // Determine initial position of drag image (screen coordinates). - FColumns.FDropTarget := NoColumn; - Start := Treeview.ScreenToClient(Start); - Inc(Start.Y, FHeight); - FColumns.FDragIndex := FColumns.ColumnFromPosition(Start); - DragColumn := FColumns[FColumns.FDragIndex]; - - Image := TBitmap.Create; - with Image do - try - PixelFormat := pf32Bit; - SetSize(DragColumn.Width, FHeight); - - // Erase the entire image with the color key value, for the case not everything - // in the image is covered by the header image. - Canvas.Brush.Color := clBtnFace; - Canvas.FillRect(Rect(0, 0, Width, Height)); - - if TreeView.UseRightToLeftAlignment then - RTLOffset := Treeview.ComputeRTLOffset - else - RTLOffset := 0; - with DragColumn do - FColumns.PaintHeader(Canvas, Rect(FLeft, 0, FLeft + Width, Height), Point(-RTLOffset, 0), RTLOffset); - - if Treeview.UseRightToLeftAlignment then - ImagePos := Treeview.ClientToScreen(Point(DragColumn.Left + Treeview.ComputeRTLOffset(True), 0)) - else - ImagePos := Treeview.ClientToScreen(Point(DragColumn.Left, 0)); - // Column rectangles are given in local window coordinates not client coordinates. - Dec(ImagePos.Y, FHeight); - - if hoRestrictDrag in FOptions then - FDragImage.MoveRestriction := dmrHorizontalOnly - else - FDragImage.MoveRestriction := dmrNone; - FDragImage.PrepareDrag(Image, ImagePos, P, nil); - FDragImage.ShowDragImage; - finally - Image.Free; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.ReadColumns(Reader: TReader); - -begin - Include(FStates, hsLoading); - Columns.Clear; - Reader.ReadValue; - Reader.ReadCollection(Columns); - Exclude(FStates, hsLoading); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.RecalculateHeader; - -// Initiate a recalculation of the non-client area of the owner tree. - -begin - if Treeview.HandleAllocated then - begin - Treeview.UpdateHeaderRect; - SetWindowPos(Treeview.Handle, 0, 0, 0, 0, 0, SWP_FRAMECHANGED or SWP_NOMOVE or SWP_NOACTIVATE or SWP_NOOWNERZORDER or - SWP_NOSENDCHANGING or SWP_NOSIZE or SWP_NOZORDER); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.RescaleHeader; - -// Rescale the fixed elements (fixed columns, header itself) to FixedAreaConstraints. - -var - FixedWidth, - MaxFixedWidth, - MinFixedWidth: Integer; - - //--------------- local function -------------------------------------------- - - procedure ComputeConstraints; - - var - I: TColumnIndex; - - begin - with FColumns do - begin - I := GetFirstVisibleColumn; - while I > NoColumn do - begin - if (coFixed in FColumns[I].Options) and (FColumns[I].Width < FColumns[I].MinWidth) then - FColumns[I].FWidth := FColumns[I].FMinWidth; - I := GetNextVisibleColumn(I); - end; - FixedWidth := GetVisibleFixedWidth; - end; - - with FFixedAreaConstraints do - begin - MinFixedWidth := (TreeView.ClientWidth * FMinWidthPercent) div 100; - MaxFixedWidth := (TreeView.ClientWidth * FMaxWidthPercent) div 100; - end; - end; - - //----------- end local function -------------------------------------------- - -begin - if ([csLoading, csReading, csWriting, csDestroying] * Treeview.ComponentState = []) and not - (hsLoading in FStates) and Treeview.HandleAllocated then - begin - Include(FStates, hsScaling); - - SetHeight(FHeight); - RecalculateHeader; - - with FFixedAreaConstraints do - if (FMinHeightPercent > 0) or (FMaxHeightPercent > 0) then - begin - ComputeConstraints; - - with FColumns do - if (FMaxWidthPercent > 0) and (FixedWidth > MaxFixedWidth) then - ResizeColumns(MaxFixedWidth - FixedWidth, 0, Count - 1, [coVisible, coFixed]) - else - if (FMinWidthPercent > 0) and (FixedWidth < MinFixedWidth) then - ResizeColumns(MinFixedWidth - FixedWidth, 0, Count - 1, [coVisible, coFixed]); - - FColumns.UpdatePositions; - end; - - Exclude(FStates, hsScaling); - Exclude(FStates, hsNeedScaling); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.UpdateMainColumn; - -// Called once the load process of the owner tree is done. - -begin - if FMainColumn < 0 then - FMainColumn := 0; - if FMainColumn > FColumns.Count - 1 then - FMainColumn := FColumns.Count - 1; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.UpdateSpringColumns; - -var - I: TColumnIndex; - SpringCount: Integer; - Sign: Integer; - ChangeBy: Single; - Difference: Single; - NewAccumulator: Single; - -begin - with TreeView do - ChangeBy := FHeaderRect.Right - FHeaderRect.Left - FLastWidth; - if (hoAutoSpring in FOptions) and (FLastWidth <> 0) and (ChangeBy <> 0) then - begin - // Stay positive if downsizing the control. - if ChangeBy < 0 then - Sign := -1 - else - Sign := 1; - ChangeBy := Abs(ChangeBy); - // Count how many columns have spring enabled. - SpringCount := 0; - for I := 0 to FColumns.Count-1 do - if [coVisible, coAutoSpring] * FColumns[I].FOptions = [coVisible, coAutoSpring] then - Inc(SpringCount); - if SpringCount > 0 then - begin - // Calculate the size to add/sub to each columns. - Difference := ChangeBy / SpringCount; - // Adjust the column's size accumulators and resize if the result is >= 1. - for I := 0 to FColumns.Count - 1 do - if [coVisible, coAutoSpring] * FColumns[I].FOptions = [coVisible, coAutoSpring] then - begin - // Sum up rest changes from previous runs and the amount from this one and store it in the - // column. If there is at least one pixel difference then do a resize and reset the accumulator. - NewAccumulator := FColumns[I].FSpringRest + Difference; - // Set new width if at least one pixel size difference is reached. - if NewAccumulator >= 1 then - FColumns[I].SetWidth(FColumns[I].FWidth + (Trunc(NewAccumulator) * Sign)); - FColumns[I].FSpringRest := Frac(NewAccumulator); - - // Keep track of the size count. - ChangeBy := ChangeBy - Difference; - // Exit loop if resize count drops below freezing point. - if ChangeBy < 0 then - Break; - end; - end; - end; - with TreeView do - FLastWidth := FHeaderRect.Right - FHeaderRect.Left; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -type - // --- HACK WARNING! - // This type cast is a partial rewrite of the private section of TWriter. The purpose is to have access to - // the FPropPath member, which is otherwise not accessible. The reason why this access is needed is that - // with nested components this member contains unneeded property path information. These information prevent - // successful load of the stored properties later. - // In System.Classes.pas you can see that FPropPath is reset several times to '' to prevent this case for certain properies. - // Unfortunately, there is no clean way for us here to do the same. - {$hints off} - TWriterHack = class(TFiler) - private - FRootAncestor: TComponent; - FPropPath: string; - end; - {$hints on} - -procedure TVTHeader.WriteColumns(Writer: TWriter); - -// Write out the columns but take care for the case VT is a nested component. - -var - LastPropPath: string; - -begin - // Save last property path for restoration. - LastPropPath := TWriterHack(Writer).FPropPath; - try - // If VT is a nested component then this path contains the name of the parent component at this time - // (otherwise it is already empty). This path is then combined with the property name under which the tree - // is defined in the parent component. Unfortunately, the load code in System.Classes.pas does not consider this case - // is then unable to load this property. - TWriterHack(Writer).FPropPath := ''; - Writer.WriteCollection(Columns); - finally - TWriterHack(Writer).FPropPath := LastPropPath; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTHeader.AllowFocus(ColumnIndex: TColumnIndex): Boolean; -begin - Result := False; - if not FColumns.IsValidColumn(ColumnIndex) then - Exit; // Just in case. - - Result := (coAllowFocus in FColumns[ColumnIndex].Options); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.Assign(Source: TPersistent); - -begin - if Source is TVTHeader then - begin - AutoSizeIndex := TVTHeader(Source).AutoSizeIndex; - Background := TVTHeader(Source).Background; - Columns := TVTHeader(Source).Columns; - Font := TVTHeader(Source).Font; - FixedAreaConstraints.Assign(TVTHeader(Source).FixedAreaConstraints); - Height := TVTHeader(Source).Height; - Images := TVTHeader(Source).Images; - MainColumn := TVTHeader(Source).MainColumn; - Options := TVTHeader(Source).Options; - ParentFont := TVTHeader(Source).ParentFont; - PopupMenu := TVTHeader(Source).PopupMenu; - SortColumn := TVTHeader(Source).SortColumn; - SortDirection := TVTHeader(Source).SortDirection; - Style := TVTHeader(Source).Style; - - RescaleHeader; - end - else - inherited; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.AutoFitColumns(Animated: Boolean = True; SmartAutoFitType: TSmartAutoFitType = smaUseColumnOption; - RangeStartCol: Integer = NoColumn; RangeEndCol: Integer = NoColumn); - - //--------------- local functions ------------------------------------------- - - function GetUseSmartColumnWidth(ColumnIndex: TColumnIndex): Boolean; - - begin - case SmartAutoFitType of - smaAllColumns: - Result := True; - smaUseColumnOption: - Result := coSmartResize in FColumns.Items[ColumnIndex].FOptions; - else - Result := False; - end; - end; - - //---------------------------------------------------------------------------- - - procedure DoAutoFitColumn(Column: TColumnIndex); - - begin - with FColumns do - if ([coResizable, coVisible] * Items[FPositionToIndex[Column]].FOptions = [coResizable, coVisible]) and - DoBeforeAutoFitColumn(FPositionToIndex[Column], SmartAutoFitType) and not TreeView.OperationCanceled then - begin - if Animated then - AnimatedResize(FPositionToIndex[Column], Treeview.GetMaxColumnWidth(FPositionToIndex[Column], - GetUseSmartColumnWidth(FPositionToIndex[Column]))) - else - FColumns[FPositionToIndex[Column]].Width := Treeview.GetMaxColumnWidth(FPositionToIndex[Column], - GetUseSmartColumnWidth(FPositionToIndex[Column])); - - DoAfterAutoFitColumn(FPositionToIndex[Column]); - end; - end; - - //--------------- end local functions ---------------------------------------- - -var - I: Integer; - StartCol, - EndCol: Integer; - -begin - StartCol := Max(NoColumn + 1, RangeStartCol); - - if RangeEndCol <= NoColumn then - EndCol := FColumns.Count - 1 - else - EndCol := Min(RangeEndCol, FColumns.Count - 1); - - if StartCol > EndCol then - Exit; // nothing to do - - TreeView.StartOperation(okAutoFitColumns); - FDoingAutoFitColumns := true; - try - if Assigned(TreeView.FOnBeforeAutoFitColumns) then - TreeView.FOnBeforeAutoFitColumns(Self, SmartAutoFitType); - - for I := StartCol to EndCol do - DoAutoFitColumn(I); - - if Assigned(TreeView.FOnAfterAutoFitColumns) then - TreeView.FOnAfterAutoFitColumns(Self); - - finally - Treeview.EndOperation(okAutoFitColumns); - TreeView.Invalidate(); - FDoingAutoFitColumns := false; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTHeader.InHeader(P: TPoint): Boolean; - -// Determines whether the given point (client coordinates!) is within the header rectangle (non-client coordinates). - -var - R, RW: TRect; - -begin - R := Treeview.FHeaderRect; - - // Current position of the owner in screen coordinates. - GetWindowRect(Treeview.Handle, RW); - - // Convert to client coordinates. - MapWindowPoints(0, Treeview.Handle, RW, 2); - - // Consider the header within this rectangle. - OffsetRect(R, RW.Left, RW.Top); - Result := PtInRect(R, P); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTHeader.InHeaderSplitterArea(P: TPoint): Boolean; - -// Determines whether the given point (client coordinates!) hits the horizontal splitter area of the header. - -var - R, RW: TRect; - -begin - if (P.Y > 2) or (P.Y < -2) or not (hoVisible in FOptions) then - Result := False - else - begin - R := Treeview.FHeaderRect; - Inc(R.Bottom, 2); - - // Current position of the owner in screen coordinates. - GetWindowRect(Treeview.Handle, RW); - - // Convert to client coordinates. - MapWindowPoints(0, Treeview.Handle, RW, 2); - - // Consider the header within this rectangle. - OffsetRect(R, RW.Left, RW.Top); - Result := PtInRect(R, P); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.Invalidate(Column: TVirtualTreeColumn; ExpandToBorder: Boolean = False; UpdateNowFlag : Boolean = False); - -// Because the header is in the non-client area of the tree it needs some special handling in order to initiate its -// repainting. -// If ExpandToBorder is True then not only the given column but everything or (depending on hoFullRepaintOnResize) just -// everything to its right (or left, in RTL mode) will be invalidated (useful for resizing). This makes only sense when -// a column is given. - -var - R, RW: TRect; - Flags: Cardinal; - -begin - if (hoVisible in FOptions) and Treeview.HandleAllocated then - with Treeview do - begin - if Column = nil then - R := FHeaderRect - else - begin - R := Column.GetRect; - if not (coFixed in Column.Options) then - OffsetRect(R, -FEffectiveOffsetX, 0); - if UseRightToLeftAlignment then - OffsetRect(R, ComputeRTLOffset, 0); - if ExpandToBorder then - begin - if (hoFullRepaintOnResize in FHeader.FOptions) then - begin - R.Left := FHeaderRect.Left; - R.Right := FHeaderRect.Right; - end - else - begin - if UseRightToLeftAlignment then - R.Left := FHeaderRect.Left - else - R.Right := FHeaderRect.Right; - end; - end; - end; - R.Bottom := Treeview.ClientHeight; // We want to repaint the entire column to bottom, not just the header - - // Current position of the owner in screen coordinates. - GetWindowRect(Handle, RW); - - // Consider the header within this rectangle. - OffsetRect(R, RW.Left, RW.Top); - - // Expressed in client coordinates (because RedrawWindow wants them so, they will actually become negative). - MapWindowPoints(0, Handle, R, 2); - Flags := RDW_FRAME or RDW_INVALIDATE or RDW_VALIDATE or RDW_NOINTERNALPAINT or RDW_NOERASE or RDW_NOCHILDREN; - if UpdateNowFlag then - Flags := Flags or RDW_UPDATENOW; - RedrawWindow(Handle, @R, 0, Flags); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.LoadFromStream(const Stream: TStream); - -// restore the state of the header from the given stream - -var - Dummy, - Version: Integer; - S: AnsiString; - OldOptions: TVTHeaderOptions; - -begin - Include(FStates, hsLoading); - with Stream do - try - // Switch off all options which could influence loading the columns (they will be later set again). - OldOptions := FOptions; - FOptions := []; - - // Determine whether the stream contains data without a version number. - ReadBuffer(Dummy, SizeOf(Dummy)); - if Dummy > -1 then - begin - // Seek back to undo the read operation if this is an old stream format. - Seek(-SizeOf(Dummy), soFromCurrent); - Version := -1; - end - else // Read version number if this is a "versionized" format. - ReadBuffer(Version, SizeOf(Version)); - Columns.LoadFromStream(Stream, Version); - - ReadBuffer(Dummy, SizeOf(Dummy)); - AutoSizeIndex := Dummy; - ReadBuffer(Dummy, SizeOf(Dummy)); - Background := Dummy; - ReadBuffer(Dummy, SizeOf(Dummy)); - Height := Dummy; - ReadBuffer(Dummy, SizeOf(Dummy)); - FOptions := OldOptions; - Options := TVTHeaderOptions(Dummy); - // PopupMenu is neither saved nor restored - ReadBuffer(Dummy, SizeOf(Dummy)); - Style := TVTHeaderStyle(Dummy); - // TFont has no own save routine so we do it manually - with Font do - begin - ReadBuffer(Dummy, SizeOf(Dummy)); - Color := Dummy; - ReadBuffer(Dummy, SizeOf(Dummy)); - Height := Dummy; - ReadBuffer(Dummy, SizeOf(Dummy)); - SetLength(S, Dummy); - ReadBuffer(PAnsiChar(S)^, Dummy); - Name := UTF8ToString(S); - ReadBuffer(Dummy, SizeOf(Dummy)); - Pitch := TFontPitch(Dummy); - ReadBuffer(Dummy, SizeOf(Dummy)); - Style := TFontStyles(Byte(Dummy)); - end; - - // Read data introduced by stream version 1+. - if Version > 0 then - begin - ReadBuffer(Dummy, SizeOf(Dummy)); - MainColumn := Dummy; - ReadBuffer(Dummy, SizeOf(Dummy)); - SortColumn := Dummy; - ReadBuffer(Dummy, SizeOf(Dummy)); - SortDirection := TSortDirection(Byte(Dummy)); - end; - - // Read data introduced by stream version 5+. - if Version > 4 then - begin - ReadBuffer(Dummy, SizeOf(Dummy)); - ParentFont := Boolean(Dummy); - ReadBuffer(Dummy, SizeOf(Dummy)); - FMaxHeight := Integer(Dummy); - ReadBuffer(Dummy, SizeOf(Dummy)); - FMinHeight := Integer(Dummy); - ReadBuffer(Dummy, SizeOf(Dummy)); - FDefaultHeight := Integer(Dummy); - with FFixedAreaConstraints do - begin - ReadBuffer(Dummy, SizeOf(Dummy)); - FMaxHeightPercent := TVTConstraintPercent(Dummy); - ReadBuffer(Dummy, SizeOf(Dummy)); - FMaxWidthPercent := TVTConstraintPercent(Dummy); - ReadBuffer(Dummy, SizeOf(Dummy)); - FMinHeightPercent := TVTConstraintPercent(Dummy); - ReadBuffer(Dummy, SizeOf(Dummy)); - FMinWidthPercent := TVTConstraintPercent(Dummy); - end; - end; - finally - Exclude(FStates, hsLoading); - RecalculateHeader(); - Treeview.DoColumnResize(NoColumn); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTHeader.ResizeColumns(ChangeBy: Integer; RangeStartCol: TColumnIndex; RangeEndCol: TColumnIndex; - Options: TVTColumnOptions = [coVisible]): Integer; - -// Distribute the given width change to a range of columns. A 'fair' way is used to distribute ChangeBy to the columns, -// while ensuring that everything that can be distributed will be distributed. - -var - Start, - I: TColumnIndex; - ColCount, - ToGo, - Sign, - Rest, - MaxDelta, - Difference: Integer; - Constraints, - Widths: array of Integer; - BonusPixel: Boolean; - - //--------------- local functions ------------------------------------------- - - function IsResizable (Column: TColumnIndex): Boolean; - - begin - if BonusPixel then - Result := Widths[Column - RangeStartCol] < Constraints[Column - RangeStartCol] - else - Result := Widths[Column - RangeStartCol] > Constraints[Column - RangeStartCol]; - end; - - //--------------------------------------------------------------------------- - - procedure IncDelta(Column: TColumnIndex); - - begin - if BonusPixel then - Inc(MaxDelta, FColumns[Column].MaxWidth - Widths[Column - RangeStartCol]) - else - Inc(MaxDelta, Widths[Column - RangeStartCol] - Constraints[Column - RangeStartCol]); - end; - - //--------------------------------------------------------------------------- - - function ChangeWidth(Column: TColumnIndex; Delta: Integer): Integer; - - begin - if Delta > 0 then - Delta := Min(Delta, Constraints[Column - RangeStartCol] - Widths[Column - RangeStartCol]) - else - Delta := Max(Delta, Constraints[Column - RangeStartCol] - Widths[Column - RangeStartCol]); - - Inc(Widths[Column - RangeStartCol], Delta); - Dec(ToGo, Abs(Delta)); - Result := Abs(Delta); - end; - - //--------------------------------------------------------------------------- - - function ReduceConstraints: Boolean; - - var - MaxWidth, - MaxReserveCol, - Column: TColumnIndex; - - begin - Result := True; - if not (hsScaling in FStates) or BonusPixel then - Exit; - - MaxWidth := 0; - MaxReserveCol := NoColumn; - for Column := RangeStartCol to RangeEndCol do - if (Options * FColumns[Column].FOptions = Options) and - (FColumns[Column].FWidth > MaxWidth) then - begin - MaxWidth := Widths[Column - RangeStartCol]; - MaxReserveCol := Column; - end; - - if (MaxReserveCol <= NoColumn) or (Constraints[MaxReserveCol - RangeStartCol] <= 10) then - Result := False - else - Dec(Constraints[MaxReserveCol - RangeStartCol], - Constraints[MaxReserveCol - RangeStartCol] div 10); - end; - - //----------- end local functions ------------------------------------------- - -begin - Result := 0; - if ChangeBy <> 0 then - begin - // Do some initialization here - BonusPixel := ChangeBy > 0; - Sign := IfThen(BonusPixel, 1, -1); - Start := IfThen(BonusPixel, RangeStartCol, RangeEndCol); - ToGo := Abs(ChangeBy); - SetLength(Widths, RangeEndCol - RangeStartCol + 1); - SetLength(Constraints, RangeEndCol - RangeStartCol + 1); - for I := RangeStartCol to RangeEndCol do - begin - Widths[I - RangeStartCol] := FColumns[I].FWidth; - Constraints[I - RangeStartCol] := IfThen(BonusPixel, FColumns[I].MaxWidth, FColumns[I].MinWidth); - end; - - repeat - repeat - MaxDelta := 0; - ColCount := 0; - for I := RangeStartCol to RangeEndCol do - if (Options * FColumns[I].FOptions = Options) and IsResizable(I) then - begin - Inc(ColCount); - IncDelta(I); - end; - if MaxDelta < Abs(ChangeBy) then - if not ReduceConstraints then - Break; - until (MaxDelta >= Abs(ChangeBy)) or not (hsScaling in FStates); - - if ColCount = 0 then - Break; - - ToGo := Min(ToGo, MaxDelta); - Difference := ToGo div ColCount; - Rest := ToGo mod ColCount; - - if Difference > 0 then - for I := RangeStartCol to RangeEndCol do - if (Options * FColumns[I].FOptions = Options) and IsResizable(I) then - ChangeWidth(I, Difference * Sign); - - // Now distribute Rest. - I := Start; - while Rest > 0 do - begin - if (Options * FColumns[I].FOptions = Options) and IsResizable(I) then - if FColumns[I].FBonusPixel <> BonusPixel then - begin - Dec(Rest, ChangeWidth(I, Sign)); - FColumns[I].FBonusPixel := BonusPixel; - end; - Inc(I, Sign); - if (BonusPixel and (I > RangeEndCol)) or (not BonusPixel and (I < RangeStartCol)) then - begin - for I := RangeStartCol to RangeEndCol do - if Options * FColumns[I].FOptions = Options then - FColumns[I].FBonusPixel := not FColumns[I].FBonusPixel; - I := Start; - end; - end; - until ToGo <= 0; - - // Now set the computed widths. We also compute the result here. - Include(FStates, hsResizing); - for I := RangeStartCol to RangeEndCol do - if (Options * FColumns[I].FOptions = Options) then - begin - Inc(Result, Widths[I - RangeStartCol] - FColumns[I].FWidth); - FColumns[I].SetWidth(Widths[I - RangeStartCol]); - end; - Exclude(FStates, hsResizing); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.RestoreColumns; - -// Restores all columns to their width which they had before they have been auto fitted. - -var - I: TColumnIndex; - -begin - with FColumns do - for I := Count - 1 downto 0 do - if [coResizable, coVisible] * Items[FPositionToIndex[I]].FOptions = [coResizable, coVisible] then - Items[I].RestoreLastWidth; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.SaveToStream(const Stream: TStream); - -// Saves the complete state of the header into the provided stream. - -var - Dummy: Integer; - Tmp: AnsiString; - -begin - with Stream do - begin - // In previous version of VT was no header stream version defined. - // For feature enhancements it is necessary, however, to know which stream - // format we are trying to load. - // In order to distict from non-version streams an indicator is inserted. - Dummy := -1; - WriteBuffer(Dummy, SizeOf(Dummy)); - // Write current stream version number, nothing more is required at the time being. - Dummy := VTHeaderStreamVersion; - WriteBuffer(Dummy, SizeOf(Dummy)); - - // Save columns in case they depend on certain options (like auto size). - Columns.SaveToStream(Stream); - - Dummy := FAutoSizeIndex; - WriteBuffer(Dummy, SizeOf(Dummy)); - Dummy := FBackgroundColor; - WriteBuffer(Dummy, SizeOf(Dummy)); - Dummy := FHeight; - WriteBuffer(Dummy, SizeOf(Dummy)); - Dummy := Integer(FOptions); - WriteBuffer(Dummy, SizeOf(Dummy)); - // PopupMenu is neither saved nor restored - Dummy := Ord(FStyle); - WriteBuffer(Dummy, SizeOf(Dummy)); - // TFont has no own save routine so we do it manually - with Font do - begin - Dummy := Color; - WriteBuffer(Dummy, SizeOf(Dummy)); - - // Need only to write one: size or height, I decided to write height. - Dummy := Height; - WriteBuffer(Dummy, SizeOf(Dummy)); - Tmp := UTF8Encode(Name); - Dummy := Length(Tmp); - WriteBuffer(Dummy, SizeOf(Dummy)); - WriteBuffer(PAnsiChar(Tmp)^, Dummy); - Dummy := Ord(Pitch); - WriteBuffer(Dummy, SizeOf(Dummy)); - Dummy := Byte(Style); - WriteBuffer(Dummy, SizeOf(Dummy)); - end; - - // Data introduced by stream version 1. - Dummy := FMainColumn; - WriteBuffer(Dummy, SizeOf(Dummy)); - Dummy := FSortColumn; - WriteBuffer(Dummy, SizeOf(Dummy)); - Dummy := Byte(FSortDirection); - WriteBuffer(Dummy, SizeOf(Dummy)); - - // Data introduced by stream version 5. - Dummy := Integer(ParentFont); - WriteBuffer(Dummy, SizeOf(Dummy)); - Dummy := Integer(FMaxHeight); - WriteBuffer(Dummy, SizeOf(Dummy)); - Dummy := Integer(FMinHeight); - WriteBuffer(Dummy, SizeOf(Dummy)); - Dummy := Integer(FDefaultHeight); - WriteBuffer(Dummy, SizeOf(Dummy)); - with FFixedAreaConstraints do - begin - Dummy := Integer(FMaxHeightPercent); - WriteBuffer(Dummy, SizeOf(Dummy)); - Dummy := Integer(FMaxWidthPercent); - WriteBuffer(Dummy, SizeOf(Dummy)); - Dummy := Integer(FMinHeightPercent); - WriteBuffer(Dummy, SizeOf(Dummy)); - Dummy := Integer(FMinWidthPercent); - WriteBuffer(Dummy, SizeOf(Dummy)); - end; - end; -end; - -//----------------- TScrollBarOptions ---------------------------------------------------------------------------------- - -constructor TScrollBarOptions.Create(AOwner: TBaseVirtualTree); - -begin - inherited Create; - - FOwner := AOwner; - FAlwaysVisible := False; - FScrollBarStyle := sbmRegular; - FScrollBars := ssBoth; - FIncrementX := 20; - FIncrementY := 20; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TScrollBarOptions.SetAlwaysVisible(Value: Boolean); - -begin - if FAlwaysVisible <> Value then - begin - FAlwaysVisible := Value; - if not (csLoading in FOwner.ComponentState) and FOwner.HandleAllocated then - FOwner.RecreateWnd; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TScrollBarOptions.SetScrollBars(Value: TScrollStyle); - -begin - if FScrollBars <> Value then - begin - FScrollBars := Value; - if not (csLoading in FOwner.ComponentState) and FOwner.HandleAllocated then - FOwner.RecreateWnd; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TScrollBarOptions.SetScrollBarStyle(Value: TScrollBarStyle); - -begin - if FScrollBarStyle <> Value then - begin - FScrollBarStyle := Value; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TScrollBarOptions.GetOwner: TPersistent; - -begin - Result := FOwner; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TScrollBarOptions.Assign(Source: TPersistent); - -begin - if Source is TScrollBarOptions then - begin - AlwaysVisible := TScrollBarOptions(Source).AlwaysVisible; - HorizontalIncrement := TScrollBarOptions(Source).HorizontalIncrement; - ScrollBars := TScrollBarOptions(Source).ScrollBars; - ScrollBarStyle := TScrollBarOptions(Source).ScrollBarStyle; - VerticalIncrement := TScrollBarOptions(Source).VerticalIncrement; - end - else - inherited; -end; - -//----------------- TVTColors ------------------------------------------------------------------------------------------ - -constructor TVTColors.Create(AOwner: TBaseVirtualTree); -var - CE : TVTColorEnum; -begin - FOwner := AOwner; - for CE := Low(TVTColorEnum) to High(TVTColorEnum) do - FColors[CE] := cDefaultColors[CE]; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTColors.GetBackgroundColor: TColor; -begin -// XE2 VCL Style - if FOwner.VclStyleEnabled and (seClient in FOwner.StyleElements) then - Result := StyleServices.GetStyleColor(scTreeView) - else - Result := FOwner.Color; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTColors.GetColor(const Index: TVTColorEnum): TColor; -begin - // Only try to fetch the color via StyleServices if theses are enabled - // Return default/user defined color otherwise - if FOwner.VclStyleEnabled then - begin - // If the ElementDetails are not defined, fall back to the SystemColor - case Index of - cDisabledColor: - if not StyleServices.GetElementColor(StyleServices.GetElementDetails(ttItemDisabled), ecTextColor, Result) then - Result := StyleServices.GetSystemColor(FColors[Index]); - cTreeLineColor: - if not StyleServices.GetElementColor(StyleServices.GetElementDetails(ttBranch), ecBorderColor, Result) then - Result := StyleServices.GetSystemColor(FColors[Index]); - cBorderColor: - if (seBorder in FOwner.StyleElements) then - Result := StyleServices.GetSystemColor(FColors[Index]) - else - Result := FColors[Index]; - cHotColor: - if not StyleServices.GetElementColor(StyleServices.GetElementDetails(ttItemHot), ecTextColor, Result) then - Result := StyleServices.GetSystemColor(FColors[Index]); - cHeaderHotColor: - if not StyleServices.GetElementColor(StyleServices.GetElementDetails(thHeaderItemHot), ecTextColor, Result) then - Result := StyleServices.GetSystemColor(FColors[Index]); - cSelectionTextColor: - if not StyleServices.GetElementColor(StyleServices.GetElementDetails(ttItemSelected), ecTextColor, Result) then - Result := StyleServices.GetSystemColor(clHighlightText); - cUnfocusedColor: - if not StyleServices.GetElementColor(StyleServices.GetElementDetails(ttItemSelectedNotFocus), ecTextColor, Result) then - Result := StyleServices.GetSystemColor(FColors[Index]); - else - Result := StyleServices.GetSystemColor(FColors[Index]); - end; - end - else - Result := FColors[Index]; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTColors.GetHeaderFontColor: TColor; -begin -// XE2+ VCL Style - if FOwner.VclStyleEnabled and (seFont in FOwner.StyleElements) then - StyleServices.GetElementColor(StyleServices.GetElementDetails(thHeaderItemNormal), ecTextColor, Result) - else - Result := FOwner.FHeader.Font.Color; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTColors.GetNodeFontColor: TColor; -begin - if FOwner.VclStyleEnabled and (seFont in FOwner.StyleElements) then - StyleServices.GetElementColor(StyleServices.GetElementDetails(ttItemNormal), ecTextColor, Result) - else - Result := FOwner.Font.Color; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTColors.GetSelectedNodeFontColor(Focused: boolean): TColor; -begin - if Focused then begin - if (tsUseExplorerTheme in FOwner.FStates) and not IsHighContrastEnabled then begin - Result := NodeFontColor - end - else - Result := SelectionTextColor - end// if Focused - else - Result := UnfocusedColor; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTColors.SetColor(const Index: TVTColorEnum; const Value: TColor); - -begin - if FColors[Index] <> Value then - begin - FColors[Index] := Value; - if not (csLoading in FOwner.ComponentState) and FOwner.HandleAllocated then - begin - // Cause helper bitmap rebuild if the button color changed. - case Index of - cTreeLineColor: - begin - FOwner.PrepareBitmaps(True, False); - FOwner.Invalidate; - end; - cBorderColor: - RedrawWindow(FOwner.Handle, nil, 0, RDW_FRAME or RDW_INVALIDATE or RDW_NOERASE or RDW_NOCHILDREN) - else - FOwner.Invalidate; - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTColors.Assign(Source: TPersistent); - -begin - if Source is TVTColors then - begin - FColors := TVTColors(Source).FColors; - if FOwner.FUpdateCount = 0 then - FOwner.Invalidate; - end - else - inherited; -end; - -//----------------- TClipboardFormats ---------------------------------------------------------------------------------- - -constructor TClipboardFormats.Create(AOwner: TBaseVirtualTree); - -begin - FOwner := AOwner; - Sorted := True; - Duplicates := dupIgnore; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TClipboardFormats.Add(const S: string): Integer; - -// Restrict additions to the clipbard formats to only those which are registered with the owner tree or one of its -// ancestors. - -var - Format: Word; - RegisteredClass: TVirtualTreeClass; - -begin - RegisteredClass := TClipboardFormatList.FindFormat(S, Format); - if Assigned(RegisteredClass) and FOwner.ClassType.InheritsFrom(RegisteredClass) then - Result := inherited Add(S) - else - Result := -1; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TClipboardFormats.Insert(Index: Integer; const S: string); - -// Restrict additions to the clipbard formats to only those which are registered with the owner tree or one of its -// ancestors. - -var - Format: Word; - RegisteredClass: TVirtualTreeClass; - -begin - RegisteredClass := TClipboardFormatList.FindFormat(S, Format); - if Assigned(RegisteredClass) and FOwner.ClassType.InheritsFrom(RegisteredClass) then - inherited Insert(Index, S); -end; - -//----------------- TBaseVirtualTree ----------------------------------------------------------------------------------- - -constructor TBaseVirtualTree.Create(AOwner: TComponent); - -begin - InitializeGlobalStructures(); - - inherited; - - ControlStyle := ControlStyle - [csSetCaption] + [csCaptureMouse, csOpaque, csReplicatable, csDisplayDragImage, - csReflector]; - FTotalInternalDataSize := 0; - FNodeDataSize := -1; - Width := 200; - Height := 100; - TabStop := True; - ParentColor := False; - FDefaultNodeHeight := 18; - FDragOperations := [doCopy, doMove]; - FHotCursor := crDefault; - FScrollBarOptions := TScrollBarOptions.Create(Self); - FFocusedColumn := NoColumn; - FDragImageKind := diComplete; - FLastSelectionLevel := -1; - FSelectionBlendFactor := 128; - - FIndent := 18; - - FPlusBM := TBitmap.Create; - FHotPlusBM := TBitmap.Create; - FMinusBM := TBitmap.Create; - FHotMinusBM := TBitmap.Create; - FSelectedHotPlusBM := TBitmap.Create; - FSelectedHotMinusBM := TBitmap.Create; - - FBorderStyle := bsSingle; - FButtonStyle := bsRectangle; - FButtonFillMode := fmTreeColor; - - FHeader := GetHeaderClass.Create(Self); - - // we have an own double buffer handling - inherited DoubleBuffered := False; - - FCheckImageKind := ckSystemDefault; - - FImageChangeLink := TChangeLink.Create; - FImageChangeLink.OnChange := ImageListChange; - FStateChangeLink := TChangeLink.Create; - FStateChangeLink.OnChange := ImageListChange; - FCustomCheckChangeLink := TChangeLink.Create; - FCustomCheckChangeLink.OnChange := ImageListChange; - - FAutoExpandDelay := 1000; - FAutoScrollDelay := 1000; - FAutoScrollInterval := 1; - - FBackground := TPicture.Create; - // Similar to the Transparent property of TImage, - // this flag is Off by default. - FBackGroundImageTransparent := False; - - FDefaultPasteMode := amAddChildLast; - FMargin := 4; - FTextMargin := 4; - FImagesMargin := 2; - FLastDragEffect := DROPEFFECT_NONE; - FDragType := dtOLE; - FDragHeight := 350; - FDragWidth := 200; - - FColors := TVTColors.Create(Self); - FEditDelay := 1000; - - FDragImage := TVTDragImage.Create(Self); - with FDragImage do - begin - Fade := True; - PreBlendBias := 0; - Transparency := 200; - end; - - FAnimationDuration := 200; - FSearchTimeout := 1000; - FSearchStart := ssFocusedNode; - FNodeAlignment := naProportional; - FLineStyle := lsDotted; - FIncrementalSearch := isNone; - FClipboardFormats := TClipboardFormats.Create(Self); - FOptions := GetOptionsClass.Create(Self); - - if not (csDesigning in ComponentState) then //Don't create worker thread in IDE, there is no use for it - TWorkerThread.AddThreadReference(); - VclStyleChanged(); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -destructor TBaseVirtualTree.Destroy; - -begin - // Disconnect all remote MSAA connections - if Assigned(FAccessibleItem) then begin - CoDisconnectObject(FAccessibleItem, 0); - FAccessibleItem := nil; - end; - if Assigned(fAccessible) then begin - CoDisconnectObject(fAccessible, 0); - fAccessible := nil; - end; - - InterruptValidation(); - Exclude(FOptions.FMiscOptions, toReadOnly); - // Make sure there is no reference remaining to the releasing tree. - TWorkerThread.ReleaseThreadReference(); - StopWheelPanning; - CancelEditNode; - - // Just in case it didn't happen already release the edit link. - FEditLink := nil; - FClipboardFormats.Free; - // Clear will also free the drag manager if it is still alive. - Clear; - FDragImage.Free; - FColors.Free; - FBackground.Free; - FImageChangeLink.Free; - FStateChangeLink.Free; - FCustomCheckChangeLink.Free; - if CheckImageKind = ckSystemDefault then - FCheckImages.Free; - FScrollBarOptions.Free; - - // The window handle must be destroyed before the header is freed because it is needed in WM_NCDESTROY. - if HandleAllocated then - DestroyWindowHandle; - - // Release FDottedBrush in case WM_NCDESTROY hasn't been triggered. - if FDottedBrush <> 0 then - DeleteObject(FDottedBrush); - FDottedBrush := 0; - - FHeader.Free; - FHeader := nil; // Do not use FreeAndNil() before checking issue #497 - FreeAndNil(FOptions); // WM_NCDESTROY accesses FOptions - - FreeMem(FRoot); - - FPlusBM.Free; - FHotPlusBM.Free; - FMinusBM.Free; - FHotMinusBM.Free; - FSelectedHotPlusBM.Free; - FSelectedHotMinusBM.Free; - - inherited; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.AdjustTotalCount(Node: PVirtualNode; Value: Integer; Relative: Boolean = False); - -// Sets a node's total count to the given value and recursively adjusts the parent's total count -// (actually, the adjustment is done iteratively to avoid function call overheads). - -var - Difference: Integer; - Run: PVirtualNode; - -begin - if Relative then - Difference := Value - else - Difference := Value - Integer(Node.TotalCount); - if Difference <> 0 then - begin - Run := Node; - // Root node has as parent the tree view. - while Assigned(Run) and (Run <> Pointer(Self)) do - begin - Inc(Integer(Run.TotalCount), Difference); - Run := Run.Parent; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.AdjustTotalHeight(Node: PVirtualNode; Value: Integer; Relative: Boolean = False); - -// Sets a node's total height to the given value and recursively adjusts the parent's total height. - -var - Difference: Integer; - Run: PVirtualNode; - -begin - if Relative then - Difference := Value - else - Difference := Value - Integer(Node.TotalHeight); - if Difference <> 0 then - begin - Run := Node; - repeat - Inc(Integer(Run.TotalHeight), Difference); - // If the node is not visible or the parent node is not expanded or we are already at the top - // then nothing more remains to do. - if not (vsVisible in Run.States) or (Run = FRoot) or - (Run.Parent = nil) or not (vsExpanded in Run.Parent.States) then - Break; - - Run := Run.Parent; - until False; - end; - - UpdateVerticalRange; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.CalculateCacheEntryCount: Integer; - -// Calculates the size of the position cache. - -begin - if FVisibleCount > 1 then - Result := Ceil(FVisibleCount / CacheThreshold) - else - Result := 0; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.CalculateVerticalAlignments(var PaintInfo: TVTPaintInfo; var VButtonAlign: Integer); - -// Calculates the vertical alignment of the given node and its associated expand/collapse button during -// a node paint cycle depending on the required node alignment style. - -begin - With PaintInfo do begin - // For absolute alignment the calculation is trivial. - case FNodeAlignment of - naFromTop: - VAlign := Node.Align; - naFromBottom: - VAlign := Integer(NodeHeight[Node]) - Node.Align; - else // naProportional - // Consider button and line alignment, but make sure neither the image nor the button (whichever is taller) - // go out of the entire node height (100% means bottom alignment to the node's bounds). - if (ImageInfo[iiNormal].Index >= 0) or (ImageInfo[iiState].Index >= 0) then - begin - if (ImageInfo[iiNormal].Index >= 0) then - VAlign := ImageInfo[iiNormal].Images.Height - else - VAlign := ImageInfo[iiState].Images.Height; - VAlign := MulDiv((Integer(NodeHeight[Node]) - VAlign), Node.Align, 100) + VAlign div 2; - end - else - if toShowButtons in FOptions.FPaintOptions then - VAlign := MulDiv((Integer(NodeHeight[Node]) - FPlusBM.Height), Node.Align, 100) + FPlusBM.Height div 2 - else - VAlign := MulDiv(Integer(Node.NodeHeight), Node.Align, 100); - end; - - VButtonAlign := VAlign - FPlusBM.Height div 2 - (FPlusBM.Height and 1); - end;// With PaintInfo -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.ChangeCheckState(Node: PVirtualNode; Value: TCheckState): Boolean; - -// Sets the check state of the node according to the given value and the node's check type. -// If the check state must be propagated to the parent nodes and one of them refuses to change then -// nothing happens and False is returned, otherwise True. - -var - Run: PVirtualNode; - UncheckedCount, - MixedCheckCount, - CheckedCount: Cardinal; - -begin - Result := not (vsChecking in Node.States); - with Node^ do - if Result then - begin - Include(States, vsChecking); - try - if not (vsInitialized in States) then - InitNode(Node) - else if CheckState = Value then - begin - // Value didn't change and node was initialized, so nothing to do - Result := False; - Exit; - end;//if - - // Indicate that we are going to propagate check states up and down the hierarchy. - if FCheckPropagationCount = 0 then begin - // Do not enter tsCheckPropagation more than once - DoStateChange([tsCheckPropagation]); - BeginUpdate(); - end; - Inc(FCheckPropagationCount); - try - // Do actions which are associated with the given check state. - case CheckType of - // Check state change with additional consequences for check states of the children. - ctTriStateCheckBox: - begin - // Propagate state down to the children. - if toAutoTristateTracking in FOptions.FAutoOptions then - case Value of - csUncheckedNormal: - if Node.ChildCount > 0 then - begin - Run := FirstChild; - CheckedCount := 0; - MixedCheckCount := 0; - UncheckedCount := 0; - while Assigned(Run) do - begin - if Run.CheckType in [ctCheckBox, ctTriStateCheckBox] then - begin - if not Self.GetCheckState(Run).IsDisabled() then - SetCheckState(Run, csUncheckedNormal); - // Check if the new child state was set successfully, otherwise we have to adjust the - // node's new check state accordingly. - case Self.GetCheckState(Run) of - csCheckedNormal, csCheckedDisabled: - Inc(CheckedCount); - csMixedNormal: - Inc(MixedCheckCount); - csUncheckedNormal, csUncheckedDisabled: - Inc(UncheckedCount); - end; - end; - Run := Run.NextSibling; - end; - - // If there is still a mixed state child node checkbox then this node must be mixed checked too. - if MixedCheckCount > 0 then - Value := csMixedNormal - else - // If nodes are normally checked child nodes then the unchecked count determines what - // to set for the node itself. - if CheckedCount > 0 then - if UncheckedCount > 0 then - Value := csMixedNormal - else - Value := csCheckedNormal; - end; - csCheckedNormal: - if Node.ChildCount > 0 then - begin - Run := FirstChild; - CheckedCount := 0; - MixedCheckCount := 0; - UncheckedCount := 0; - while Assigned(Run) do - begin - if Run.CheckType in [ctCheckBox, ctTriStateCheckBox] then - begin - if not Self.GetCheckState(Run).IsDisabled() then - SetCheckState(Run, csCheckedNormal); - // Check if the new child state was set successfully, otherwise we have to adjust the - // node's new check state accordingly. - case Self.GetCheckState(Run) of - csCheckedNormal: - Inc(CheckedCount); - csMixedNormal: - Inc(MixedCheckCount); - csUncheckedNormal: - Inc(UncheckedCount); - end; - end; - Run := Run.NextSibling; - end; - - // If there is still a mixed state child node checkbox then this node must be mixed checked too. - if MixedCheckCount > 0 then - Value := csMixedNormal - else - // If nodes are normally checked child nodes then the unchecked count determines what - // to set for the node itself. - if CheckedCount > 0 then - if UncheckedCount > 0 then - Value := csMixedNormal - else - Value := csCheckedNormal; - end; - end; - end; - // radio button check state change - ctRadioButton: - if Value = csCheckedNormal then - begin - Value := csCheckedNormal; - // Make sure only this node is checked. - Run := Parent.FirstChild; - while Assigned(Run) do - begin - if Run.CheckType = ctRadioButton then - Run.CheckState := csUncheckedNormal; - Run := Run.NextSibling; - end; - Invalidate; - end; - end; - - if Result then - CheckState := Value // Set new check state - else - CheckState := Self.GetCheckState(Node).GetUnpressed(); // Reset dynamic check state. - - // Propagate state up to the parent. - if not (vsInitialized in Parent.States) then - InitNode(Parent); - if (toAutoTristateTracking in FOptions.FAutoOptions) and ([vsChecking, vsDisabled] * Parent.States = []) and - (CheckType in [ctCheckBox, ctTriStateCheckBox]) and (Parent <> FRoot) and - (Parent.CheckType = ctTriStateCheckBox) then - Result := CheckParentCheckState(Node, Value) - else - Result := True; - - InvalidateNode(Node); - finally - Dec(FCheckPropagationCount); // WL, 05.02.2004 - if FCheckPropagationCount = 0 then begin - // Allow state change event after all check operations finished - DoStateChange([], [tsCheckPropagation]); - EndUpdate(); - end; - end; - finally - Exclude(States, vsChecking); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.CollectSelectedNodesLTR(MainColumn, NodeLeft, NodeRight: Integer; Alignment: TAlignment; - OldRect, NewRect: TRect): Boolean; - -// Helper routine used when a draw selection takes place. This version handles left-to-right directionality. -// In the process of adding or removing nodes the current selection is modified which requires to pack it after -// the function returns. Another side effect of this method is that a temporary list of nodes will be created -// (see also InternalCacheNode) which must be inserted into the current selection by the caller. - -var - Run, - NextNode: PVirtualNode; - TextRight, - TextLeft, - CurrentTop, - CurrentRight, - NextTop, - NextColumn, - NodeWidth, - Dummy: Integer; - MinY, MaxY: Integer; - LabelOffset: Integer; - IsInOldRect, - IsInNewRect: Boolean; - - // quick check variables for various parameters - DoSwitch, - AutoSpan: Boolean; - SimpleSelection: Boolean; - -begin - // A priori nothing changes. - Result := False; - - // Determine minimum and maximum vertical coordinates to limit iteration to. - MinY := Min(OldRect.Top, NewRect.Top); - MaxY := Max(OldRect.Bottom, NewRect.Bottom); - - // Initialize short hand variables to speed up tests below. - DoSwitch := ssCtrl in FDrawSelShiftState; - AutoSpan := FHeader.UseColumns and (toAutoSpanColumns in FOptions.FAutoOptions); - SimpleSelection := toSimpleDrawSelection in FOptions.FSelectionOptions; - // This is the node to start with. - Run := GetNodeAt(0, MinY, False, CurrentTop); - - if Assigned(Run) then - begin - LabelOffset := GetOffset(TVTElement.ofsLabel, Run); - - // ----- main loop - // Change selection depending on the node's rectangle being in the selection rectangle or not, but - // touch only those nodes which overlap either the old selection rectangle or the new one but not both. - repeat - // Collect offsets for check, normal and state images. - TextLeft := NodeLeft + LabelOffset; - NextTop := CurrentTop + Integer(NodeHeight[Run]); - - // Simple selection allows to draw the selection rectangle anywhere. No intersection with node captions is - // required. Only top and bottom bounds of the rectangle matter. - if SimpleSelection or (toFullRowSelect in FOptions.FSelectionOptions) then - begin - IsInOldRect := (NextTop > OldRect.Top) and (CurrentTop < OldRect.Bottom) and - ((FHeader.Columns.Count = 0) or (FHeader.Columns.TotalWidth > OldRect.Left)) and ((NodeLeft + LabelOffset) < OldRect.Right); - IsInNewRect := (NextTop > NewRect.Top) and (CurrentTop < NewRect.Bottom) and - ((FHeader.Columns.Count = 0) or (FHeader.Columns.TotalWidth > NewRect.Left)) and ((NodeLeft + LabelOffset) < NewRect.Right); - end - else - begin - // The right column border might be extended if column spanning is enabled. - if AutoSpan then - begin - with FHeader.FColumns do - begin - NextColumn := MainColumn; - repeat - Dummy := GetNextVisibleColumn(NextColumn); - if (Dummy = InvalidColumn) or not ColumnIsEmpty(Run, Dummy) or - (Items[Dummy].BidiMode <> bdLeftToRight) then - Break; - NextColumn := Dummy; - until False; - if NextColumn = MainColumn then - CurrentRight := NodeRight - else - GetColumnBounds(NextColumn, Dummy, CurrentRight); - end; - end - else - CurrentRight := NodeRight; - // Check if we need the node's width. This is the case when the node is not left aligned or the - // left border of the selection rectangle is to the right of the left node border. - if (TextLeft < OldRect.Left) or (TextLeft < NewRect.Left) or (Alignment <> taLeftJustify) then - begin - NodeWidth := DoGetNodeWidth(Run, MainColumn); - if NodeWidth >= (CurrentRight - TextLeft) then - TextRight := CurrentRight - else - case Alignment of - taLeftJustify: - TextRight := TextLeft + NodeWidth; - taCenter: - begin - TextLeft := (TextLeft + CurrentRight - NodeWidth) div 2; - TextRight := TextLeft + NodeWidth; - end; - else - // taRightJustify - TextRight := CurrentRight; - TextLeft := TextRight - NodeWidth; - end; - end - else - TextRight := CurrentRight; - - // Now determine whether we need to change the state. - IsInOldRect := (OldRect.Left <= TextRight) and (OldRect.Right >= TextLeft) and - (NextTop > OldRect.Top) and (CurrentTop < OldRect.Bottom); - IsInNewRect := (NewRect.Left <= TextRight) and (NewRect.Right >= TextLeft) and - (NextTop > NewRect.Top) and (CurrentTop < NewRect.Bottom); - end; - - if IsInOldRect xor IsInNewRect then - begin - Result := True; - if DoSwitch then - begin - if vsSelected in Run.States then - InternalRemoveFromSelection(Run) - else - InternalCacheNode(Run); - end - else - begin - if IsInNewRect then - InternalCacheNode(Run) - else - InternalRemoveFromSelection(Run); - end; - end; - CurrentTop := NextTop; - // Get next visible node and update left node position. - NextNode := GetNextVisibleNoInit(Run, True); - if NextNode = nil then - Break; - Inc(NodeLeft, CountLevelDifference(Run, NextNode) * Integer(FIndent)); - Run := NextNode; - until CurrentTop > MaxY; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.CollectSelectedNodesRTL(MainColumn, NodeLeft, NodeRight: Integer; Alignment: TAlignment; - OldRect, NewRect: TRect): Boolean; - -// Helper routine used when a draw selection takes place. This version handles right-to-left directionality. -// See also comments in CollectSelectedNodesLTR. - -var - Run, - NextNode: PVirtualNode; - TextRight, - TextLeft, - CheckOffset, - CurrentTop, - CurrentLeft, - NextTop, - NextColumn, - NodeWidth, - Dummy: Integer; - MinY, MaxY: Integer; - IsInOldRect, - IsInNewRect: Boolean; - - // quick check variables for various parameters - WithCheck, - WithStateImages, - DoSwitch, - AutoSpan: Boolean; - SimpleSelection: Boolean; - -begin - // A priori nothing changes. - Result := False; - // Switch the alignment to the opposite value in RTL context. - ChangeBiDiModeAlignment(Alignment); - - // Determine minimum and maximum vertical coordinates to limit iteration to. - MinY := Min(OldRect.Top, NewRect.Top); - MaxY := Max(OldRect.Bottom, NewRect.Bottom); - - // Initialize short hand variables to speed up tests below. - DoSwitch := ssCtrl in FDrawSelShiftState; - WithCheck := (toCheckSupport in FOptions.FMiscOptions) and Assigned(FCheckImages); - // Don't check the events here as descendant trees might have overriden the DoGetImageIndex method. - WithStateImages := Assigned(FStateImages) or Assigned(OnGetImageIndexEx); - if WithCheck then - CheckOffset := FCheckImages.Width + FImagesMargin - else - CheckOffset := 0; - AutoSpan := FHeader.UseColumns and (toAutoSpanColumns in FOptions.FAutoOptions); - SimpleSelection := toSimpleDrawSelection in FOptions.FSelectionOptions; - // This is the node to start with. - Run := GetNodeAt(0, MinY, False, CurrentTop); - - if Assigned(Run) then - begin - // The initial minimal left border is determined by the identation level of the node and is dynamically adjusted. - if toShowRoot in FOptions.FPaintOptions then - Dec(NodeRight, Integer((GetNodeLevel(Run) + 1) * FIndent) + FMargin) - else - Dec(NodeRight, Integer(GetNodeLevel(Run) * FIndent) + FMargin); - - // ----- main loop - // Change selection depending on the node's rectangle being in the selection rectangle or not, but - // touch only those nodes which overlap either the old selection rectangle or the new one but not both. - repeat - // Collect offsets for check, normal and state images. - TextRight := NodeRight; - if WithCheck and (Run.CheckType <> ctNone) then - Dec(TextRight, CheckOffset); - Dec(TextRight, GetImageSize(Run, ikNormal, MainColumn).cx); - if WithStateImages then - Dec(TextRight, GetImageSize(Run, ikState, MainColumn).cx); - NextTop := CurrentTop + Integer(NodeHeight[Run]); - - // Simple selection allows to draw the selection rectangle anywhere. No intersection with node captions is - // required. Only top and bottom bounds of the rectangle matter. - if SimpleSelection then - begin - IsInOldRect := (NextTop > OldRect.Top) and (CurrentTop < OldRect.Bottom); - IsInNewRect := (NextTop > NewRect.Top) and (CurrentTop < NewRect.Bottom); - end - else - begin // The left column border might be extended if column spanning is enabled. - if AutoSpan then - begin - NextColumn := MainColumn; - repeat - Dummy := FHeader.FColumns.GetPreviousVisibleColumn(NextColumn); - if (Dummy = InvalidColumn) or not ColumnIsEmpty(Run, Dummy) or - (FHeader.FColumns[Dummy].BiDiMode = bdLeftToRight) then - Break; - NextColumn := Dummy; - until False; - if NextColumn = MainColumn then - CurrentLeft := NodeLeft - else - FHeader.FColumns.GetColumnBounds(NextColumn, CurrentLeft, Dummy); - end - else - CurrentLeft := NodeLeft; - // Check if we need the node's width. This is the case when the node is not left aligned (in RTL context this // means actually right aligned) or the right border of the selection rectangle is to the left - // of the right node border. - if (TextRight > OldRect.Right) or (TextRight > NewRect.Right) or (Alignment <> taRightJustify) then - begin - NodeWidth := DoGetNodeWidth(Run, MainColumn); - if NodeWidth >= (TextRight - CurrentLeft) then - TextLeft := CurrentLeft - else - case Alignment of - taLeftJustify: - begin - TextLeft := CurrentLeft; - TextRight := TextLeft + NodeWidth; - end; - taCenter: - begin - TextLeft := (TextRight + CurrentLeft - NodeWidth) div 2; - TextRight := TextLeft + NodeWidth; - end; - else - // taRightJustify - TextLeft := TextRight - NodeWidth; - end; - end - else - TextLeft := CurrentLeft; - - // Now determine whether we need to change the state. - IsInOldRect := (OldRect.Right >= TextLeft) and (OldRect.Left <= TextRight) and - (NextTop > OldRect.Top) and (CurrentTop < OldRect.Bottom); - IsInNewRect := (NewRect.Right >= TextLeft) and (NewRect.Left <= TextRight) and - (NextTop > NewRect.Top) and (CurrentTop < NewRect.Bottom); - end; - - if IsInOldRect xor IsInNewRect then - begin - Result := True; - if DoSwitch then - begin - if vsSelected in Run.States then - InternalRemoveFromSelection(Run) - else - InternalCacheNode(Run); - end - else - begin - if IsInNewRect then - InternalCacheNode(Run) - else - InternalRemoveFromSelection(Run); - end; - end; - CurrentTop := NextTop; - // Get next visible node and update left node position. - NextNode := GetNextVisibleNoInit(Run, True); - if NextNode = nil then - Break; - Dec(NodeRight, CountLevelDifference(Run, NextNode) * Integer(FIndent)); - Run := NextNode; - until CurrentTop > MaxY; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.ClearNodeBackground(const PaintInfo: TVTPaintInfo; UseBackground, Floating: Boolean; - R: TRect); - -// Erases a node's background depending on what the application decides to do. -// UseBackground determines whether or not to use the background picture, while Floating indicates -// that R is given in coordinates of the small node bitmap or the superordinated target bitmap used in PaintTree. - -var - BackColor: TColor; - EraseAction: TItemEraseAction; - Offset: TPoint; - -begin - BackColor := FColors.BackGroundColor; - with PaintInfo do - begin - EraseAction := eaDefault; - - if Floating then - begin - Offset := Point(-FEffectiveOffsetX, R.Top); - OffsetRect(R, 0, -Offset.Y); - end - else - Offset := Point(0, 0); - - DoBeforeItemErase(Canvas, Node, R, BackColor, EraseAction); - - with Canvas do - begin - case EraseAction of - eaNone: - ; - eaColor: - begin - // User has given a new background color. - Brush.Color := BackColor; - FillRect(R); - end; - else // eaDefault - if UseBackground then - begin - if toStaticBackground in TreeOptions.PaintOptions then - StaticBackground(FBackground, Canvas, Offset, R, FColors.BackGroundColor) - else - TileBackground(FBackground, Canvas, Offset, R, FColors.BackGroundColor); - end - else - begin - if (poDrawSelection in PaintOptions) and (toFullRowSelect in FOptions.FSelectionOptions) and - (vsSelected in Node.States) and not (toUseBlendedSelection in FOptions.PaintOptions) and not - (tsUseExplorerTheme in FStates) then - begin - if toShowHorzGridLines in FOptions.PaintOptions then - begin - Brush.Color := BackColor; - FillRect(Rect(R.Left, R.Bottom - 1, R.Right, R.Bottom)); - Dec(R.Bottom); - end; - if Focused or (toPopupMode in FOptions.FPaintOptions) then - begin - Brush.Color := FColors.FocusedSelectionColor; - Pen.Color := FColors.FocusedSelectionBorderColor; - end - else - begin - Brush.Color := FColors.UnfocusedSelectionColor; - Pen.Color := FColors.UnfocusedSelectionBorderColor; - end; - - with TWithSafeRect(R) do - RoundRect(Left, Top, Right, Bottom, FSelectionCurveRadius, FSelectionCurveRadius); - end - else - begin - Brush.Color := BackColor; - FillRect(R); - end; - end; - end; - DoAfterItemErase(Canvas, Node, R); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.CompareNodePositions(Node1, Node2: PVirtualNode; ConsiderChildrenAbove: Boolean = False): Integer; - -// Tries hard and smart to quickly determine whether Node1's structural position is before Node2's position. -// If ConsiderChildrenAbove is True, the nodes will be compared with their visual order in mind. -// Returns 0 if Node1 = Node2, < 0 if Node1 is located before Node2 else > 0. - -var - Run1, - Run2: PVirtualNode; - Level1, - Level2: Cardinal; - -begin - Assert(Assigned(Node1) and Assigned(Node2), 'Nodes must never be nil.'); - - if Node1 = Node2 then - Result := 0 - else - begin - if HasAsParent(Node1, Node2) then - Result := IfThen(ConsiderChildrenAbove and (toChildrenAbove in FOptions.FPaintOptions), -1, 1) - else - if HasAsParent(Node2, Node1) then - Result := IfThen(ConsiderChildrenAbove and (toChildrenAbove in FOptions.FPaintOptions), 1, -1) - else - begin - // the given nodes are neither equal nor are they parents of each other, so go up to FRoot - // for each node and compare the child indices of the top level parents - // Note: neither Node1 nor Node2 can be FRoot at this point as this (a bit strange) circumstance would - // be caught by the previous code. - - // start lookup at the same level - Level1 := GetNodeLevel(Node1); - Level2 := GetNodeLevel(Node2); - Run1 := Node1; - while Level1 > Level2 do - begin - Run1 := Run1.Parent; - Dec(Level1); - end; - Run2 := Node2; - while Level2 > Level1 do - begin - Run2 := Run2.Parent; - Dec(Level2); - end; - - // now go up until we find a common parent node (loop will safely stop at FRoot if the nodes - // don't share a common parent) - while Run1.Parent <> Run2.Parent do - begin - Run1 := Run1.Parent; - Run2 := Run2.Parent; - end; - Result := Integer(Run1.Index) - Integer(Run2.Index); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DrawLineImage(const PaintInfo: TVTPaintInfo; X, Y, H, VAlign: Integer; Style: TVTLineType; - Reverse: Boolean); - -// Draws (depending on Style) one of the 5 line types of the tree. -// If Reverse is True then a right-to-left column is being drawn, hence horizontal lines must be mirrored. -// X and Y describe the left upper corner of the line image rectangle, while H denotes its height (and width). - -var - HalfWidth, - TargetX: Integer; - -begin - HalfWidth := (FIndent div 2); - if Reverse then - TargetX := 0 - else - TargetX := Integer(FIndent) + ScaledPixels(FImagesMargin); - - with PaintInfo.Canvas do - begin - case Style of - ltBottomRight: - begin - DrawDottedVLine(PaintInfo, Y + VAlign, Y + H, X + HalfWidth); - DrawDottedHLine(PaintInfo, X + HalfWidth, X + TargetX, Y + VAlign); - end; - ltTopDown: - DrawDottedVLine(PaintInfo, Y, Y + H, X + HalfWidth); - ltTopDownRight: - begin - DrawDottedVLine(PaintInfo, Y, Y + H, X + HalfWidth); - DrawDottedHLine(PaintInfo, X + HalfWidth, X + TargetX, Y + VAlign); - end; - ltRight: - DrawDottedHLine(PaintInfo, X + HalfWidth, X + TargetX, Y + VAlign); - ltTopRight: - begin - DrawDottedVLine(PaintInfo, Y, Y + VAlign, X + HalfWidth); - DrawDottedHLine(PaintInfo, X + HalfWidth, X + TargetX, Y + VAlign); - end; - ltLeft: // left can also mean right for RTL context - if Reverse then - DrawDottedVLine(PaintInfo, Y, Y + H, X + Integer(FIndent)) - else - DrawDottedVLine(PaintInfo, Y, Y + H, X); - ltLeftBottom: - if Reverse then - begin - DrawDottedVLine(PaintInfo, Y, Y + H, X + Integer(FIndent)); - DrawDottedHLine(PaintInfo, X, X + Integer(FIndent), Y + H); - end - else - begin - DrawDottedVLine(PaintInfo, Y, Y + H, X); - DrawDottedHLine(PaintInfo, X, X + Integer(FIndent), Y + H); - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.FindInPositionCache(Node: PVirtualNode; var CurrentPos: Cardinal): PVirtualNode; - -// Looks through the position cache and returns the node whose top position is the largest one which is smaller or equal -// to the position of the given node. - -var - L, H, I: Integer; - -begin - L := 0; - H := High(FPositionCache); - while L <= H do - begin - I := (L + H) shr 1; - if CompareNodePositions(FPositionCache[I].Node, Node) <= 0 then - L := I + 1 - else - H := I - 1; - end; - if L = 0 then // High(FPositionCache) = -1 - begin - Result := nil; - CurrentPos := 0; - end - else - begin - Result := FPositionCache[L - 1].Node; - CurrentPos := FPositionCache[L - 1].AbsoluteTop; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.FindInPositionCache(Position: Cardinal; var CurrentPos: Cardinal): PVirtualNode; - -// Looks through the position cache and returns the node whose top position is the largest one which is smaller or equal -// to the given vertical position. -// The returned node does not necessarily occupy the given position but is the nearest one to start -// iterating from to approach the real node for a given position. CurrentPos receives the actual position of the found -// node which is needed for further iteration. - -var - L, H, I: Integer; - -begin - L := 0; - H := High(FPositionCache); - while L <= H do - begin - I := (L + H) shr 1; - if FPositionCache[I].AbsoluteTop <= Position then - L := I + 1 - else - H := I - 1; - end; - if L = 0 then // High(FPositionCache) = -1 - begin - Result := nil; - CurrentPos := 0; - end - else - begin - Result := FPositionCache[L - 1].Node; - CurrentPos := FPositionCache[L - 1].AbsoluteTop; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.FixupTotalCount(Node: PVirtualNode); - -// Called after loading a subtree from stream. The child count in each node is already set but not -// their total count. - -var - Child: PVirtualNode; - -begin - // Initial total count is set to one on node creation. - Child := Node.FirstChild; - while Assigned(Child) do - begin - FixupTotalCount(Child); - Inc(Node.TotalCount, Child.TotalCount); - Child := Child.NextSibling; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.FixupTotalHeight(Node: PVirtualNode); - -// Called after loading a subtree from stream. The individual height of each node is set already, -// but their total height needs an adjustment depending on their visibility state. - -var - Child: PVirtualNode; - -begin - // Initial total height is set to the node height on load. - Child := Node.FirstChild; - - if vsExpanded in Node.States then - begin - while Assigned(Child) do - begin - FixupTotalHeight(Child); - if vsVisible in Child.States then - Inc(Node.TotalHeight, Child.TotalHeight); - Child := Child.NextSibling; - end; - end - else - begin - // The node is collapsed, so just update the total height of its child nodes. - while Assigned(Child) do - begin - FixupTotalHeight(Child); - Child := Child.NextSibling; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetBottomNode: PVirtualNode; - -begin - Result := GetNodeAt(0, ClientHeight - 1); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetCheckedCount: Integer; - -var - Node: PVirtualNode; - -begin - Result := 0; - Node := GetFirstChecked; - while Assigned(Node) do - begin - Inc(Result); - Node := GetNextChecked(Node); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetCheckState(Node: PVirtualNode): TCheckState; - -begin - if Assigned(FOnBeforeGetCheckState) then - FOnBeforeGetCheckState(Self, Node); - - Result := Node.CheckState; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetCheckType(Node: PVirtualNode): TCheckType; - -begin - Result := Node.CheckType; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetChildCount(Node: PVirtualNode): Cardinal; -begin - if (Node = nil) or (Node = FRoot) then - Exit(FRoot.ChildCount); - if not GetChildrenInitialized(Node) then - InitChildren(Node); - Exit(Node.ChildCount); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetChildrenInitialized(Node: PVirtualNode): Boolean; - -begin - Result := not (vsHasChildren in Node.States) or (Node.ChildCount > 0); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetCutCopyCount: Integer; - -var - Node: PVirtualNode; - -begin - Result := 0; - Node := GetFirstCutCopy; - while Assigned(Node) do - begin - Inc(Result); - Node := GetNextCutCopy(Node); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetDisabled(Node: PVirtualNode): Boolean; - -begin - Result := Assigned(Node) and (vsDisabled in Node.States); -end; - -//---------------------------------------------------------------------------------------------------------------------- -// whether the sync of checkbox with selection is allowed for this node -function TBaseVirtualTree.GetSyncCheckstateWithSelection(Node: PVirtualNode): Boolean; - -begin - Result := (toSyncCheckboxesWithSelection in FOptions.FSelectionOptions) - and (toCheckSupport in FOptions.FMiscOptions) - and Assigned(FCheckImages) - and (Node.CheckType = ctCheckBox); ; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetDragManager: IVTDragManager; - -// Returns the internal drag manager interface. If this does not yet exist then it is created here. - -begin - if FDragManager = nil then - begin - FDragManager := DoCreateDragManager; - if FDragManager = nil then - FDragManager := TVTDragManager.Create(Self); - end; - - Result := FDragManager; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetExpanded(Node: PVirtualNode): Boolean; - -begin - if Assigned(Node) then - Result := vsExpanded in Node.States - else - Result := False; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetFiltered(Node: PVirtualNode): Boolean; - -begin - Result := vsFiltered in Node.States; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetFullyVisible(Node: PVirtualNode): Boolean; - -// Determines whether the given node has the visibility flag set as well as all its parents are expanded. - -begin - Assert(Assigned(Node), 'Invalid parameter.'); - Result := vsVisible in Node.States; - if Result and (Node <> FRoot) then - Result := VisiblePath[Node]; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetHasChildren(Node: PVirtualNode): Boolean; - -begin - if Assigned(Node) then - Result := vsHasChildren in Node.States - else - Result := vsHasChildren in FRoot.States; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetMultiline(Node: PVirtualNode): Boolean; - -begin - Result := Assigned(Node) and (Node <> FRoot) and (vsMultiline in Node.States); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetNodeHeight(Node: PVirtualNode): Cardinal; - -begin - if Assigned(Node) and (Node <> FRoot) then - begin - if (toVariableNodeHeight in FOptions.FMiscOptions) and not (vsDeleting in Node.States) then - begin - if not (vsInitialized in Node.States) then - InitNode(Node); - - // Ensure the node's height is determined. - MeasureItemHeight(Self.Canvas, Node); - end; - Result := Node.NodeHeight; - end - else - Result := 0; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetNodeParent(Node: PVirtualNode): PVirtualNode; - -begin - if Assigned(Node) and (Node.Parent <> FRoot) then - Result := Node.Parent - else - Result := nil; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetOffset(pElement: TVTElement; pNode: PVirtualNode): integer; -// Calculates the offset of the given element -var - lOffsets: TVTOffsets; -begin - GetOffsets(pNode, lOffsets, pElement); - Exit(lOffsets[pElement]); -end; - -procedure TBaseVirtualTree.GetOffsets(pNode: PVirtualNode; out pOffsets: TVTOffsets; pElement: TVTElement = TVTElement.ofsEndOfClientArea; pColumn: Integer = NoColumn); -// Calculates the offset up to the given element and supplies them in an array. -var - lNodeLevel: Integer; -begin - // If no specific column was given, assume the main column - if pColumn = -1 then - pColumn := Header.MainColumn; - - // Left Margin - pOffsets[TVTElement.ofsMargin] := FMargin; - if pElement = ofsMargin then - exit; - pOffsets[TVTElement.ofsCheckBox] := FMargin + fImagesMargin; - if (pColumn = Header.MainColumn) then - begin - if not (toFixedIndent in TreeOptions.PaintOptions) then begin - // plus Indent - lNodeLevel := GetNodeLevel(pNode); - if toShowRoot in FOptions.FPaintOptions then - Inc(lNodeLevel); - end - else - lNodeLevel := 1; - Inc(pOffsets[TVTElement.ofsCheckBox], lNodeLevel * Integer(FIndent)); - // toggle buttons - pOffsets[TVTElement.ofsToggleButton] := pOffsets[TVTElement.ofsCheckBox] - fImagesMargin - ((Integer(FIndent) - FPlusBM.Width) div 2) + 1 - FPlusBM.Width; //Compare PaintTree() relative line 107 - end;//if MainColumn - - // The area in which the toggle buttons are painted must have exactly the size of one indent level - if pElement <= TVTElement.ofsCheckBox then - exit; - - // right of checkbox, left of state image - if (toCheckSupport in FOptions.FMiscOptions) and Assigned(FCheckImages) and (pNode.CheckType <> ctNone) and (pColumn = Header.MainColumn) then - pOffsets[TVTElement.ofsStateImage] := pOffsets[TVTElement.ofsCheckBox] + FCheckImages.Width + fImagesMargin - else - pOffsets[TVTElement.ofsStateImage] := pOffsets[TVTElement.ofsCheckBox]; - if pElement = TVTElement.ofsStateImage then - exit; - // right of left image, left of normal image - pOffsets[TVTElement.ofsImage] := pOffsets[TVTElement.ofsStateImage] + GetImageSize(pNode, TVTImageKind.ikState, pColumn).cx; - if pElement = TVTElement.ofsImage then - exit; - // label - pOffsets[TVTElement.ofsLabel] := pOffsets[TVTElement.ofsImage] + GetImageSize(pNode, TVTImageKind.ikNormal, pColumn).cx; - pOffsets[TVTElement.ofsText] := pOffsets[TVTElement.ofsLabel] + FTextMargin; - Dec(pOffsets[TVTElement.ofsText]); //TODO: This should no longer be necessary once issue #369 is resolved. - if pElement <= TVTElement.ofsText then - exit; - - // End of text - pOffsets[TVTElement.ofsRightOfText] := pOffsets[TVTElement.ofsText] + DoGetNodeWidth(pNode, pColumn) + DoGetNodeExtraWidth(pNode, pColumn); - - // end of client area - pOffsets[TVTElement.ofsEndOfClientArea] := Max(FRangeX, ClientWidth) - FTextMargin; -end; - -function TBaseVirtualTree.GetOffsetXY: TPoint; - -begin - Result := Point(FOffsetX, FOffsetY); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetRangeX: Cardinal; -begin - Result := Max(0, FRangeX); -end; - -function TBaseVirtualTree.GetRootNodeCount: Cardinal; - -begin - Result := FRoot.ChildCount; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetSelected(Node: PVirtualNode): Boolean; - -begin - Result := Assigned(Node) and (vsSelected in Node.States); -end; - -function TBaseVirtualTree.GetSelectedData: TArray; -var - lItem: PVirtualNode; - i: Integer; -begin - SetLEngth(Result, Self.SelectedCount); - i := 0; - lItem := Self.GetFirstSelected; - while Assigned(lItem) do - begin - Result[i] := Self.GetNodeData(lItem); - lItem := Self.GetNextSelected(lItem); - Inc(i); - end; - SetLength(Result, i); // See issue #927, SelectedCount may not yet be updated. -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetTopNode: PVirtualNode; - -var - Dummy: Integer; - -begin - Result := GetNodeAt(0, 0, True, Dummy); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetTotalCount: Cardinal; - -begin - Inc(FUpdateCount); - try - ValidateNode(FRoot, True); - finally - Dec(FUpdateCount); - end; - // The root node itself doesn't count as node. - Result := FRoot.TotalCount - 1; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetVerticalAlignment(Node: PVirtualNode): Byte; - -begin - Result := Node.Align; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetVisible(Node: PVirtualNode): Boolean; - -// Determines if the given node is marked as being visible. - -begin - if Node = nil then - Node := FRoot; - - if not (vsInitialized in Node.States) then - InitNode(Node); - - Result := vsVisible in Node.States; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetVisiblePath(Node: PVirtualNode): Boolean; - -// Determines if all parents of the given node are expanded and have the visibility flag set. - -begin - Assert(Assigned(Node) and (Node <> FRoot), 'Invalid parameters.'); - - // FRoot is always expanded - repeat - Node := Node.Parent; - until (Node = FRoot) or not (vsExpanded in Node.States) or not (vsVisible in Node.States); - - Result := Node = FRoot; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.HandleClickSelection(LastFocused, NewNode: PVirtualNode; Shift: TShiftState; - DragPending: Boolean); - -// Handles multi-selection with mouse click. - -begin - // Ctrl key down - if ssCtrl in Shift then - begin - if ssShift in Shift then - begin - SelectNodes(FRangeAnchor, NewNode, True); - end - else - begin - if not (toSiblingSelectConstraint in FOptions.SelectionOptions) then - FRangeAnchor := NewNode; - // Delay selection change if a drag operation is pending. - // Otherwise switch selection state here. - if DragPending then - DoStateChange([tsToggleFocusedSelection]) - else - if vsSelected in NewNode.States then - RemoveFromSelection(NewNode) - else - AddToSelection(NewNode, True); - end; - end - else - // Shift key down - if ssShift in Shift then - begin - if FRangeAnchor = nil then - FRangeAnchor := FRoot.FirstChild; - - // select node range - if Assigned(FRangeAnchor) then - begin - SelectNodes(FRangeAnchor, NewNode, False); - Invalidate; - end; - end - else - begin - // any other case - if not (vsSelected in NewNode.States) then - AddToSelection(NewNode, True); - // assign new reference item - FRangeAnchor := NewNode; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.HandleDrawSelection(X, Y: Integer): Boolean; - -// Handles multi-selection with a focus rectangle. -// Result is True if something changed in selection. - -var - OldRect, - NewRect: TRect; - MainColumn: TColumnIndex; - MaxValue: Integer; - - // limits of a node and its text - NodeLeft, - NodeRight: Integer; - - // alignment and directionality - CurrentBidiMode: TBidiMode; - CurrentAlignment: TAlignment; - -begin - Result := False; - - // Selection changes are only done if the user drew a selection rectangle large - // enough to exceed the threshold. - if (FRoot.TotalCount > 1) and (tsDrawSelecting in FStates) then - begin - // Effective handling of node selection is done by using two rectangles stored in FSelectRec. - OldRect := OrderRect(FLastSelRect); - NewRect := OrderRect(FNewSelRect); - ClearTempCache; - - MainColumn := FHeader.MainColumn; - - // Alignment and bidi mode determine where the node text is located within a node. - if MainColumn <= NoColumn then - begin - CurrentBidiMode := BidiMode; - CurrentAlignment := Alignment; - end - else - begin - CurrentBidiMode := FHeader.FColumns[MainColumn].BidiMode; - CurrentAlignment := FHeader.FColumns[MainColumn].Alignment; - end; - - // Determine initial left border of first node (take column reordering into account). - if FHeader.UseColumns then - begin - // The mouse coordinates don't include any horizontal scrolling hence take this also - // out from the returned column position. - NodeLeft := FHeader.FColumns[MainColumn].Left + FEffectiveOffsetX; - NodeRight := NodeLeft + FHeader.FColumns[MainColumn].Width; - end - else - begin - NodeLeft := 0 + FEffectiveOffsetX; - NodeRight := NodeLeft + ClientWidth; - end; - if CurrentBidiMode = bdLeftToRight then - Result := CollectSelectedNodesLTR(MainColumn, NodeLeft, NodeRight, CurrentAlignment, OldRect, NewRect) - else - Result := CollectSelectedNodesRTL(MainColumn, NodeLeft, NodeRight, CurrentAlignment, OldRect, NewRect); - end; - - if Result then - begin - // Do some housekeeping if there was a change. - MaxValue := PackArray(FSelection, FSelectionCount); - if MaxValue > -1 then - begin - FSelectionCount := MaxValue; - SetLength(FSelection, FSelectionCount); - end; - if FTempNodeCount > 0 then - begin - if tsClearOnNewSelection in fStates then - begin - DoStateChange([], [tsClearOnNewSelection]); - ClearSelection(False); - end; - - AddToSelection(FTempNodeCache, FTempNodeCount); - ClearTempCache; - end; - - Change(nil); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.HasVisibleNextSibling(Node: PVirtualNode): Boolean; - -// Helper method to determine if the given node has a visible next sibling. This is needed to -// draw correct tree lines. - -begin - // Check if there is a sibling at all. - Result := Assigned(Node.NextSibling); - - if Result then - begin - repeat - Node := Node.NextSibling; - Result := IsEffectivelyVisible[Node]; - until Result or (Node.NextSibling = nil); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.HasVisiblePreviousSibling(Node: PVirtualNode): Boolean; - -// Helper method to determine if the given node has a visible previous sibling. This is needed to -// draw correct tree lines. - -begin - // Check if there is a sibling at all. - Result := Assigned(Node.PrevSibling); - - if Result then - begin - repeat - Node := Node.PrevSibling; - Result := IsEffectivelyVisible[Node]; - until Result or (Node.PrevSibling = nil); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.ImageListChange(Sender: TObject); - -begin - if not (csDestroying in ComponentState) then - Invalidate; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.InitializeFirstColumnValues(var PaintInfo: TVTPaintInfo); - -// Determines initial index, position and cell size of the first visible column. - -begin - PaintInfo.Column := FHeader.FColumns.GetFirstVisibleColumn; - with FHeader.FColumns, PaintInfo do - begin - if Column > NoColumn then - begin - CellRect.Right := CellRect.Left + Items[Column].Width; - Position := Items[Column].Position; - end - else - Position := 0; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.InitRecursive(Node: PVirtualNode; Levels: Cardinal = MaxInt; pVisibleOnly: Boolean = True); - -// Initializes a node and optionally its children up to a certain level. -// The sepcified number of levels are latrive to the givne Node. - -var - Run: PVirtualNode; -begin - if not Assigned(Node) then - Node := FRoot; - - if (Node <> FRoot) and not (vsInitialized in Node.States) then - InitNode(Node); - if (Levels = 0) or (pVisibleOnly and not (vsExpanded in Node.States)) then - exit; - Run := Node.FirstChild; - - while Assigned(Run) do - begin - InitRecursive(Run, Levels - 1, pVisibleOnly); - Run := Run.NextSibling; - end; -end; - -procedure TBaseVirtualTree.InitRootNode(OldSize: Cardinal = 0); - -// Reinitializes the root node. - -var - NewSize: Cardinal; - -begin - NewSize := TreeNodeSize + FTotalInternalDataSize; - if FRoot = nil then - FRoot := AllocMem(NewSize) - else - begin - ReallocMem(FRoot, NewSize); - ZeroMemory(PByte(FRoot) + OldSize, NewSize - OldSize); - end; - - with FRoot^ do - begin - // Indication that this node is the root node. - PrevSibling := FRoot; - NextSibling := FRoot; - Parent := Pointer(Self); - States := [vsInitialized, vsExpanded, vsHasChildren, vsVisible]; - TotalHeight := FDefaultNodeHeight; - TotalCount := 1; - NodeHeight := FDefaultNodeHeight; - Align := 50; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.InterruptValidation; - -var - WasValidating: Boolean; - -begin - DoStateChange([tsStopValidation], [tsUseCache]); - - // Check the worker thread existance. It might already be gone (usually on destruction of the last tree). - WasValidating := (tsValidating in FStates); - TWorkerThread.RemoveTree(Self); - if WasValidating then - InvalidateCache(); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.IsFirstVisibleChild(Parent, Node: PVirtualNode): Boolean; - -// Helper method to check if Node is the same as the first visible child of Parent. - -var - Run: PVirtualNode; - -begin - // Find first visible child. - Run := Parent.FirstChild; - while Assigned(Run) and not IsEffectivelyVisible[Run] do - Run := Run.NextSibling; - - Result := Assigned(Run) and (Run = Node); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.IsLastVisibleChild(Parent, Node: PVirtualNode): Boolean; - -// Helper method to check if Node is the same as the last visible child of Parent. - -var - Run: PVirtualNode; - -begin - // Find last visible child. - Run := Parent.LastChild; - while Assigned(Run) and not IsEffectivelyVisible[Run] do - Run := Run.PrevSibling; - - Result := Assigned(Run) and (Run = Node); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.MakeNewNode: PVirtualNode; - -var - Size: Cardinal; - -begin - Size := TreeNodeSize; - if not (csDesigning in ComponentState) then - begin // Make sure FNodeDataSize is valid. - if FNodeDataSize <= 0 then - ValidateNodeDataSize(FNodeDataSize); - - // Take record alignment into account. - Inc(Size, FNodeDataSize); - end//not csDesigning - else - Inc(Size, SizeOf(Pointer)); // Fixes #702 - - - Result := AllocMem(Size + FTotalInternalDataSize); - - // Fill in some default values. - with Result^ do - begin - TotalCount := 1; - TotalHeight := FDefaultNodeHeight; - NodeHeight := FDefaultNodeHeight; - States := [vsVisible]; - Align := 50; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.PackArray({*}const TheArray: TNodeArray; Count: Integer): Integer; assembler; -// *This is an optimization to get as near as possible with the PUREPASCAL code without the -// compiler generating a _DynArrayAddRef call. We still modify the array's content via pointers. - -// Removes all entries from the selection array which are no longer in use. The selection array must be sorted for this -// algo to work. Values which must be removed are marked with bit 0 (LSB) set. This little trick works because memory -// is always allocated DWORD aligned. Since the selection array must be sorted while determining the entries to be -// removed it is much more efficient to increment the entry in question instead of setting it to nil (which would break -// the ordered appearance of the list). -// -// On enter EAX contains self reference, EDX the address to TheArray and ECX Count -// The returned value is the number of remaining entries in the array, so the caller can reallocate (shorten) -// the selection array if needed or -1 if nothing needs to be changed. - -{$ifdef CPUX64} -var - Source, Dest: ^PVirtualNode; - ConstOne: NativeInt; -begin - Source := Pointer(TheArray); - ConstOne := 1; - Result := 0; - // Do the fastest scan possible to find the first entry - while (Count <> 0) and {not Odd(NativeInt(Source^))} (NativeInt(Source^) and ConstOne = 0) do - begin - Inc(Result); - Inc(Source); - Dec(Count); - end; - - if Count <> 0 then - begin - Dest := Source; - repeat - // Skip odd entries - if {not Odd(NativeInt(Source^))} NativeInt(Source^) and ConstOne = 0 then - begin - Dest^ := Source^; - Inc(Result); - Inc(Dest); - end; - Inc(Source); // Point to the next entry - Dec(Count); - until Count = 0; - end; -end; -{$else} -asm - PUSH EBX - PUSH EDI - PUSH ESI - MOV ESI, EDX - MOV EDX, -1 - JCXZ @@Finish // Empty list? - INC EDX // init remaining entries counter - MOV EDI, ESI // source and destination point to the list memory - MOV EBX, 1 // use a register instead of immediate operant to check against -@@PreScan: - TEST [ESI], EBX // do the fastest scan possible to find the first entry - // which must be removed - JNZ @@DoMainLoop - INC EDX - ADD ESI, 4 - DEC ECX - JNZ @@PreScan - JMP @@Finish - -@@DoMainLoop: - MOV EDI, ESI -@@MainLoop: - TEST [ESI], EBX // odd entry? - JNE @@Skip // yes, so skip this one - MOVSD // else move the entry to new location - INC EDX // count the moved entries - DEC ECX - JNZ @@MainLoop // do it until all entries are processed - JMP @@Finish - -@@Skip: - ADD ESI, 4 // point to the next entry - DEC ECX - JNZ @@MainLoop // do it until all entries are processed -@@Finish: - MOV EAX, EDX // prepare return value - POP ESI - POP EDI - POP EBX -end; -{$endif CPUX64} - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.PrepareBitmaps(NeedButtons, NeedLines: Boolean); - -// initializes the contents of the internal bitmaps - -const - LineBitsDotted: array [0..8] of Word = ($55, $AA, $55, $AA, $55, $AA, $55, $AA, $55); - LineBitsSolid: array [0..7] of Word = (0, 0, 0, 0, 0, 0, 0, 0); - -var - PatternBitmap: HBITMAP; - Bits: Pointer; - Size: TSize; - Theme: HTHEME; - R: TRect; - - //--------------- local function -------------------------------------------- - - procedure FillBitmap (ABitmap: TBitmap); - begin - with ABitmap, Canvas do - begin - SetSize(Size.cx, Size.cy); - - if IsWinVistaOrAbove and (tsUseThemes in FStates) and (toUseExplorerTheme in FOptions.FPaintOptions) or VclStyleEnabled then - begin - if (FHeader.MainColumn > NoColumn) then - Brush.Color := FHeader.FColumns[FHeader.MainColumn].GetEffectiveColor - else - Brush.Color := FColors.BackGroundColor; - end - else - Brush.Color := clFuchsia; - - Transparent := True; - TransparentColor := Brush.Color; - - FillRect(Rect(0, 0, Width, Height)); - end; - end; - - //--------------- end local function ---------------------------------------- - -begin - if VclStyleEnabled and (seClient in StyleElements) then - begin - Size.cx := ScaledPixels(11); - Size.cy := ScaledPixels(11); - FillBitmap(FPlusBM); - FillBitmap(FHotPlusBM); - FillBitmap(FSelectedHotPlusBM); - FillBitmap(FMinusBM); - FillBitmap(FHotMinusBM); - FillBitmap(FSelectedHotMinusBM); - R := Rect(0,0,Size. cx,Size.cy); - // tcbCategoryGlyphClosed, tcbCategoryGlyphOpened from CategoryButtons - StyleServices.DrawElement(FPlusBM.Canvas.Handle, StyleServices.GetElementDetails(tcbCategoryGlyphClosed), R); - StyleServices.DrawElement(FMinusBM.Canvas.Handle, StyleServices.GetElementDetails(tcbCategoryGlyphOpened), R); - FHotMinusBM.Canvas.Draw(0, 0, FMinusBM); - FSelectedHotMinusBM.Canvas.Draw(0, 0, FMinusBM); - FHotPlusBM.Canvas.Draw(0, 0, FPlusBM); - FSelectedHotPlusBM.Canvas.Draw(0, 0, FPlusBM); - if Assigned(FOnPrepareButtonImages) then - FOnPrepareButtonImages(Self, FPlusBM, FHotPlusBM, FSelectedHotPlusBM, FMinusBM, FHotMinusBM, FSelectedHotMinusBM, size); - end - else - begin - Size.cx := 9; - Size.cy := 9; - if tsUseThemes in FStates then - begin - R := Rect(0, 0, 100, 100); - Theme := OpenThemeData(Handle, 'TREEVIEW'); - GetThemePartSize(Theme, FPlusBM.Canvas.Handle, TVP_GLYPH, GLPS_OPENED, @R, TS_TRUE, Size); - end - else - Theme := 0; - - if NeedButtons then - begin - //VCL Themes do not really have ability to provide tree plus/minus images when not using the - //windows theme. The bitmap style designer doesn't have any elements for for them, and you - //cannot name any elements you add, which makes it useless. - //To mitigate this, Hook up the OnPrepareButtonImages and draw them yourself. - if Assigned(FOnPrepareButtonImages) then - begin - FillBitmap(FPlusBM); - FillBitmap(FHotPlusBM); - FillBitmap(FSelectedHotPlusBM); - FillBitmap(FMinusBM); - FillBitmap(FHotMinusBM); - FillBitmap(FSelectedHotMinusBM); - FOnPrepareButtonImages(Self, FPlusBM, FHotPlusBM, FSelectedHotPlusBM, FMinusBM, FHotMinusBM, FSelectedHotMinusBM, size); - end - else - begin - with FMinusBM, Canvas do - begin - // box is always of odd size - FillBitmap(FMinusBM); - FillBitmap(FHotMinusBM); - FillBitmap(FSelectedHotMinusBM); - // Weil die selbstgezeichneten Bitmaps sehen im Vcl Style scheie aus - // Because the self-drawn bitmaps view Vcl Style shit - if Theme = 0 then - begin - if not(tsUseExplorerTheme in FStates) then - begin - if FButtonStyle = bsTriangle then - begin - Brush.Color := clBlack; - Pen.Color := clBlack; - Polygon([Point(0, 2), Point(8, 2), Point(4, 6)]); - end - else - begin - // Button style is rectangular. Now ButtonFillMode determines how to fill the interior. - if FButtonFillMode in [fmTreeColor, fmWindowColor, fmTransparent] then - begin - case FButtonFillMode of - fmTreeColor: - Brush.Color := FColors.BackGroundColor; - fmWindowColor: - Brush.Color := clWindow; - end; - Pen.Color := FColors.TreeLineColor; - Rectangle(0, 0, Width, Height); - Pen.Color := FColors.NodeFontColor; - MoveTo(2, Width div 2); - LineTo(Width - 2, Width div 2); - end - else - FMinusBM.Handle := LoadBitmap(HInstance, 'VT_XPBUTTONMINUS'); - end; - FHotMinusBM.Canvas.Draw(0, 0, FMinusBM); - FSelectedHotMinusBM.Canvas.Draw(0, 0, FMinusBM); - end; - end; - end; - with FPlusBM, Canvas do - begin - FillBitmap(FPlusBM); - FillBitmap(FHotPlusBM); - FillBitmap(FSelectedHotPlusBM); - if Theme = 0 then - begin - if not(tsUseExplorerTheme in FStates) then - begin - if FButtonStyle = bsTriangle then - begin - Brush.Color := clBlack; - Pen.Color := clBlack; - Polygon([Point(2, 0), Point(6, 4), Point(2, 8)]); - end - else - begin - // Button style is rectangular. Now ButtonFillMode determines how to fill the interior. - if FButtonFillMode in [fmTreeColor, fmWindowColor, fmTransparent] then - begin - case FButtonFillMode of - fmTreeColor: - Brush.Color := FColors.BackGroundColor; - fmWindowColor: - Brush.Color := clWindow; - end; - Pen.Color := FColors.TreeLineColor; - Rectangle(0, 0, Width, Height); - Pen.Color := FColors.NodeFontColor; - MoveTo(2, Width div 2); - LineTo(Width - 2, Width div 2); - MoveTo(Width div 2, 2); - LineTo(Width div 2, Width - 2); - end - else - FPlusBM.Handle := LoadBitmap(HInstance, 'VT_XPBUTTONPLUS'); - end; - FHotPlusBM.Canvas.Draw(0, 0, FPlusBM); - FSelectedHotPlusBM.Canvas.Draw(0, 0, FPlusBM); - end; - end; - end; - - - // Overwrite glyph images if theme is active. - if (tsUseThemes in FStates) and (Theme <> 0) then - begin - R := Rect(0, 0, Size.cx, Size.cy); - DrawThemeBackground(Theme, FPlusBM.Canvas.Handle, TVP_GLYPH, GLPS_CLOSED, R, nil); - DrawThemeBackground(Theme, FMinusBM.Canvas.Handle, TVP_GLYPH, GLPS_OPENED, R, nil); - if tsUseExplorerTheme in FStates then - begin - DrawThemeBackground(Theme, FHotPlusBM.Canvas.Handle, TVP_HOTGLYPH, GLPS_CLOSED, R, nil); - DrawThemeBackground(Theme, FSelectedHotPlusBM.Canvas.Handle, TVP_HOTGLYPH, GLPS_CLOSED, R, nil); - DrawThemeBackground(Theme, FHotMinusBM.Canvas.Handle, TVP_HOTGLYPH, GLPS_OPENED, R, nil); - DrawThemeBackground(Theme, FSelectedHotMinusBM.Canvas.Handle, TVP_HOTGLYPH, GLPS_OPENED, R, nil); - end - else - begin - FHotPlusBM.Canvas.Draw(0, 0, FPlusBM); - FSelectedHotPlusBM.Canvas.Draw(0, 0, FPlusBM); - FHotMinusBM.Canvas.Draw(0, 0, FMinusBM); - FSelectedHotMinusBM.Canvas.Draw(0, 0, FMinusBM); - end; - end; - end; - if tsUseThemes in FStates then - CloseThemeData(Theme); - end; - end; - - if NeedLines then - begin - if FDottedBrush <> 0 then - DeleteObject(FDottedBrush); - case FLineStyle of - lsDotted: - Bits := @LineBitsDotted; - lsSolid: - Bits := @LineBitsSolid; - else // lsCustomStyle - Bits := @LineBitsDotted; - DoGetLineStyle(Bits); - end; - PatternBitmap := CreateBitmap(8, 8, 1, 1, Bits); - FDottedBrush := CreatePatternBrush(PatternBitmap); - DeleteObject(PatternBitmap); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetAlignment(const Value: TAlignment); - -begin - if FAlignment <> Value then - begin - FAlignment := Value; - if not (csLoading in ComponentState) then - Invalidate; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetAnimationDuration(const Value: Cardinal); - -begin - FAnimationDuration := Value; - if FAnimationDuration = 0 then - Exclude(FOptions.FAnimationOptions, toAnimatedToggle) - else - Include(FOptions.FAnimationOptions, toAnimatedToggle); -end; - -//---------------------------------------------------------------------------------------------------------------------- -{ New, Support for transparent background: - * Image types: BMP, PNG, GIF, ICO, EMF, TIFF and WMF are automatically identified to support transparent background - * Also detects certain third party image classes registered for PNG, GIF and other image types so that the - transparency related code is used for them. See the code below. - * If some other third party image class is registered that is not detected, - set the flag BackgroundTransparentExternalType explicitly in order to properly do - transparent painting. -} -procedure TBaseVirtualTree.SetBackground(const Value: TPicture); - -begin - FBackground.Assign(Value); - Invalidate; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetBackGroundImageTransparent(const Value: Boolean); - -begin - if Value <> FBackGroundImageTransparent then - begin - FBackGroundImageTransparent := Value; - Invalidate; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetBackgroundOffset(const Index, Value: Integer); - -begin - case Index of - 0: - if FBackgroundOffsetX <> Value then - begin - FBackgroundOffsetX := Value; - Invalidate; - end; - 1: - if FBackgroundOffsetY <> Value then - begin - FBackgroundOffsetY := Value; - Invalidate; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetBorderStyle(Value: TBorderStyle); - -begin - if FBorderStyle <> Value then - begin - FBorderStyle := Value; - RecreateWnd; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetBottomNode(Node: PVirtualNode); - -var - Run: PVirtualNode; - R: TRect; - -begin - if Assigned(Node) then - begin - // make sure all parents of the node are expanded - Run := Node.Parent; - while Run <> FRoot do - begin - if not (vsExpanded in Run.States) then - ToggleNode(Run); - Run := Run.Parent; - end; - R := GetDisplayRect(Node, FHeader.MainColumn, True); - DoSetOffsetXY(Point(FOffsetX, FOffsetY + ClientHeight - R.Top - Integer(NodeHeight[Node])), - [suoRepaintScrollBars, suoUpdateNCArea]); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetBottomSpace(const Value: Cardinal); - -begin - if FBottomSpace <> Value then - begin - FBottomSpace := Value; - UpdateVerticalScrollBar(True); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetButtonFillMode(const Value: TVTButtonFillMode); - -begin - if FButtonFillMode <> Value then - begin - FButtonFillMode := Value; - if not (csLoading in ComponentState) then - begin - PrepareBitmaps(True, False); - if HandleAllocated then - Invalidate; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetButtonStyle(const Value: TVTButtonStyle); - -begin - if FButtonStyle <> Value then - begin - FButtonStyle := Value; - if not (csLoading in ComponentState) then - begin - PrepareBitmaps(True, False); - if HandleAllocated then - Invalidate; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetCheckState(Node: PVirtualNode; Value: TCheckState); - -begin - if (Node.CheckState <> Value) and DoChecking(Node, Value) then - DoCheckClick(Node, Value); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetCheckStateForAll(aCheckState: TCheckState; pSelectedOnly: Boolean; pExcludeDisabled: Boolean = True); - -// Changes the check state for all or for all seledcted nodes. -// aCheckState: The new check state. -// pSelectedOnly: If passed True, only the selected nodes will bechnaged, if passed False all nodes in the control will be changed. -// pExcludeDisabled: Optiopnal. If passed True (the default value), disabled checkboxes won't be changed, if passed False disabled checkboxes will be altered too. - -var - lItem : PVirtualNode; -begin - With Self do begin - Screen.Cursor := crHourGlass; - BeginUpdate; - try - if pSelectedOnly then - lItem := GetFirstSelected - else - lItem := GetFirst; - //for i:=0 to List.Items.Count-1 do begin - while Assigned(lItem) do begin - if not pExcludeDisabled or not CheckState[lItem].IsDisabled() then - CheckState[lItem] := aCheckState; - if pSelectedOnly then - lItem := GetNextSelected(lItem) - else - lItem := GetNext(lItem); - end;//while - finally - Screen.Cursor := crDefault; - EndUpdate; - end;//try..finally - end;//With -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetCheckType(Node: PVirtualNode; Value: TCheckType); - -begin - if (Node.CheckType <> Value) and not (toReadOnly in FOptions.FMiscOptions) then - begin - Node.CheckType := Value; - if (Value <> ctTriStateCheckBox) and (Node.CheckState in [csMixedNormal, csMixedPressed]) then - Node.CheckState := csUncheckedNormal;// reset check state if it doesn't fit the new check type - // For check boxes with tri-state check box parents we have to initialize differently. - if (toAutoTriStateTracking in FOptions.FAutoOptions) and (Value in [ctCheckBox, ctTriStateCheckBox]) and - (Node.Parent <> FRoot) then - begin - if not (vsInitialized in Node.Parent.States) then - InitNode(Node.Parent); - if (Node.Parent.CheckType = ctTriStateCheckBox) then begin - if (GetCheckState(Node.Parent) in [csUncheckedNormal, csUncheckedDisabled]) then - CheckState[Node] := csUncheckedNormal - else if (GetCheckState(Node.Parent) in [csCheckedNormal, csCheckedDisabled]) then - CheckState[Node] := csCheckedNormal; - end;//if - end;//if - InvalidateNode(Node); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetChildCount(Node: PVirtualNode; NewChildCount: Cardinal); - -// Changes a node's child structure to accomodate the new child count. This is used to add or delete -// child nodes to/from the end of the node's child list. To insert or delete a specific node a separate -// routine is used. - -var - Remaining: Cardinal; - Index: Cardinal; - Child: PVirtualNode; - Count: Integer; - NewHeight: Integer; -begin - if not (toReadOnly in FOptions.FMiscOptions) then - begin - if Node = nil then - Node := FRoot; - - Assert(GetCurrentThreadId = MainThreadId, 'UI controls may only be chnaged in UI thread.'); - if NewChildCount = 0 then - DeleteChildren(Node) - else - begin - // If nothing changed then do nothing. - if NewChildCount <> Node.ChildCount then - begin - InterruptValidation; - - if NewChildCount > Node.ChildCount then - begin - Remaining := NewChildCount - Node.ChildCount; - Count := Remaining; - NewHeight := Node.TotalHeight; - - // New nodes to add. - if Assigned(Node.LastChild) then - Index := Node.LastChild.Index + 1 - else - begin - Index := 0; - Include(Node.States, vsHasChildren); - end; - Node.States := Node.States - [vsAllChildrenHidden, vsHeightMeasured]; - if (vsExpanded in Node.States) and FullyVisible[Node] then - Inc(FVisibleCount, Count); // Do this before a possible init of the sub-nodes in DoMeasureItem() - - // New nodes are by default always visible, so we don't need to check the visibility. - while Remaining > 0 do - begin - Child := MakeNewNode; - Child.Index := Index; - Child.PrevSibling := Node.LastChild; - if Assigned(Node.LastChild) then - Node.LastChild.NextSibling := Child; - Child.Parent := Node; - Node.LastChild := Child; - if Node.FirstChild = nil then - Node.FirstChild := Child; - Dec(Remaining); - Inc(Index); - - if (toVariableNodeHeight in FOptions.FMiscOptions) then - GetNodeHeight(Child); - Inc(NewHeight, Child.TotalHeight); - end; - - if vsExpanded in Node.States then - AdjustTotalHeight(Node, NewHeight, False); - - AdjustTotalCount(Node, Count, True); - Node.ChildCount := NewChildCount; - if (FUpdateCount = 0) and (toAutoSort in FOptions.FAutoOptions) and (FHeader.FSortColumn > InvalidColumn) then - Sort(Node, FHeader.FSortColumn, FHeader.FSortDirection, True); - - InvalidateCache; - end//if NewChildCount > Node.ChildCount - else - begin - // Nodes have to be deleted. - Remaining := Node.ChildCount - NewChildCount; - while Remaining > 0 do - begin - DeleteNode(Node.LastChild); - Dec(Remaining); - end; - end; - - if FUpdateCount = 0 then - begin - ValidateCache; - UpdateScrollBars(True); - Invalidate; - end; - - if Node = FRoot then - StructureChange(nil, crChildAdded) - else - StructureChange(Node, crChildAdded); - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetClipboardFormats(const Value: TClipboardFormats); - -var - I: Integer; - -begin - // Add string by string instead doing an Assign or AddStrings because the list may return -1 for - // invalid entries which cause trouble for the standard implementation. - FClipboardFormats.Clear; - for I := 0 to Value.Count - 1 do - FClipboardFormats.Add(Value[I]); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetColors(const Value: TVTColors); - -begin - FColors.Assign(Value); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetCheckImageKind(Value: TCheckImageKind); -begin - if (Value < Low(Value)) or (Value> High(Value)) then - Value := ckSystemDefault; - // property is deprecated. See issue #622 - if FCheckImageKind <> Value then - begin - if FCheckImageKind = ckSystemDefault then - FreeAndNil(FCheckImages); - FCheckImageKind := Value; - if Value = ckCustom then - FCheckImages := FCustomCheckImages - else if HandleAllocated then - FCheckImages := CreateSystemImageSet(Self); - if HandleAllocated and (FUpdateCount = 0) and not (csLoading in ComponentState) then - InvalidateRect(Handle, nil, False); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetCustomCheckImages(const Value: TCustomImageList); - -begin - if FCustomCheckImages <> Value then - begin - if Assigned(FCustomCheckImages) then - begin - FCustomCheckImages.UnRegisterChanges(FCustomCheckChangeLink); - FCustomCheckImages.RemoveFreeNotification(Self); - // Reset the internal check image list reference too, if necessary. - if FCheckImages = FCustomCheckImages then - FCheckImages := nil; - end; - FCustomCheckImages := Value; - if Assigned(FCustomCheckImages) then - begin - // If custom check images are assigned, we switch the property CheckImageKind to ckCustom so that they are actually used - CheckImageKind := ckCustom; - FCustomCheckImages.RegisterChanges(FCustomCheckChangeLink); - FCustomCheckImages.FreeNotification(Self); - end - else - CheckImageKind := ckSystemDefault; - if not (csLoading in ComponentState) then - Invalidate; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetDefaultNodeHeight(Value: Cardinal); - -begin - if Value = 0 then - Value := 18; - if FDefaultNodeHeight <> Value then - begin - Inc(Integer(FRoot.TotalHeight), Integer(Value) - Integer(FDefaultNodeHeight)); - Inc(SmallInt(FRoot.NodeHeight), Integer(Value) - Integer(FDefaultNodeHeight)); - FDefaultNodeHeight := Value; - InvalidateCache; - if (FUpdateCount = 0) and HandleAllocated and not (csLoading in ComponentState) then - begin - ValidateCache; - UpdateScrollBars(True); - ScrollIntoView(FFocusedNode, toCenterScrollIntoView in FOptions.SelectionOptions, True); - Invalidate; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetDisabled(Node: PVirtualNode; Value: Boolean); - -begin - if Assigned(Node) and (Value xor (vsDisabled in Node.States)) then - begin - if Value then - Include(Node.States, vsDisabled) - else - Exclude(Node.States, vsDisabled); - - if FUpdateCount = 0 then - InvalidateNode(Node); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetDoubleBuffered(const Value: Boolean); -begin - // empty by intention, we do our own buffering -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetDoubleBuffered: Boolean; -begin - Result := True; // we do our own buffering -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetEmptyListMessage(const Value: string); - -begin - if Value <> EmptyListMessage then - begin - FEmptyListMessage := Value; - Invalidate; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetExpanded(Node: PVirtualNode; Value: Boolean); - -begin - if Assigned(Node) and (Node <> FRoot) and (Value xor (vsExpanded in Node.States)) then - ToggleNode(Node); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetFocusedColumn(Value: TColumnIndex); - -begin - if (FFocusedColumn <> Value) and - DoFocusChanging(FFocusedNode, FFocusedNode, FFocusedColumn, Value) then - begin - CancelEditNode; - InvalidateColumn(FFocusedColumn); - InvalidateColumn(Value); - FFocusedColumn := Value; - if Assigned(FFocusedNode) and not (toDisableAutoscrollOnFocus in FOptions.FAutoOptions) then - begin - if ScrollIntoView(FFocusedNode, toCenterScrollIntoView in FOptions.SelectionOptions, True) then - InvalidateNode(FFocusedNode); - end; - - if Assigned(FDropTargetNode) then - InvalidateNode(FDropTargetNode); - - DoFocusChange(FFocusedNode, FFocusedColumn); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetFocusedNode(Value: PVirtualNode); - -var - WasDifferent: Boolean; - -begin - WasDifferent := Value <> FFocusedNode; - DoFocusNode(Value, True); - // Do change event only if there was actually a change. - if WasDifferent and (FFocusedNode = Value) then - DoFocusChange(FFocusedNode, FFocusedColumn); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetFullyVisible(Node: PVirtualNode; Value: Boolean); - -// This method ensures that a node is visible and all its parent nodes are expanded and also visible -// if Value is True. Otherwise the visibility flag of the node is reset but the expand state -// of the parent nodes stays untouched. - -begin - Assert(Assigned(Node) and (Node <> FRoot), 'Invalid parameter'); - - IsVisible[Node] := Value; - if Value then - begin - repeat - Node := Node.Parent; - if Node = FRoot then - Break; - if not (vsExpanded in Node.States) then - ToggleNode(Node); - if not (vsVisible in Node.States) then - IsVisible[Node] := True; - until False; - end; - ScrollIntoView(Node, False); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetHasChildren(Node: PVirtualNode; Value: Boolean); - -begin - if Assigned(Node) and not (toReadOnly in FOptions.FMiscOptions) then - begin - if Value then - Include(Node.States, vsHasChildren) - else - begin - Exclude(Node.States, vsHasChildren); - DeleteChildren(Node); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetHeader(const Value: TVTHeader); - -begin - FHeader.Assign(Value); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetHotNode(Value: PVirtualNode); - -begin - FCurrentHotNode := Value; -end; - - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetFiltered(Node: PVirtualNode; Value: Boolean); - -// Sets the 'filtered' flag of the given node according to Value and updates all dependent states. - -var - NeedUpdate: Boolean; - -begin - Assert(Assigned(Node) and (Node <> FRoot), 'Invalid parameter.'); - - // Initialize the node if necessary as this might change the filtered state. - if not (vsInitialized in Node.States) then - InitNode(Node); - - if Value <> (vsFiltered in Node.States) then - begin - InterruptValidation; - NeedUpdate := False; - if Value then - begin - Include(Node.States, vsFiltered); - if not (toShowFilteredNodes in FOptions.FPaintOptions) then - begin - if (vsInitializing in Node.States) and not (vsHasChildren in Node.States) then - AdjustTotalHeight(Node, 0, False) - else - AdjustTotalHeight(Node, -Integer(NodeHeight[Node]), True); - if FullyVisible[Node] then - begin - Dec(FVisibleCount); - NeedUpdate := True; - end; - if FocusedNode = Node then - FocusedNode := nil; - end; - - if FUpdateCount = 0 then - DetermineHiddenChildrenFlag(Node.Parent) - else - Include(FStates, tsUpdateHiddenChildrenNeeded); - end - else - begin - Exclude(Node.States, vsFiltered); - if not (toShowFilteredNodes in FOptions.FPaintOptions) then - begin - AdjustTotalHeight(Node, Integer(NodeHeight[Node]), True); - if FullyVisible[Node] then - begin - Inc(FVisibleCount); - NeedUpdate := True; - end; - end; - - if vsVisible in Node.States then - // Update the hidden children flag of the parent. - // Since this node is now visible we simply have to remove the flag. - Exclude(Node.Parent.States, vsAllChildrenHidden); - end; - - InvalidateCache; - if NeedUpdate and (FUpdateCount = 0) then - begin - ValidateCache; - UpdateScrollBars(True); - Invalidate; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- -procedure TBaseVirtualTree.SetImages(const Value: TCustomImageList); - -begin - if FImages <> Value then - begin - if Assigned(FImages) then - begin - FImages.UnRegisterChanges(FImageChangeLink); - FImages.RemoveFreeNotification(Self); - end; - FImages := Value; - if Assigned(FImages) then - begin - FImages.RegisterChanges(FImageChangeLink); - FImages.FreeNotification(Self); - end; - if not (csLoading in ComponentState) then - Invalidate; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetIndent(Value: Cardinal); - -begin - if FIndent <> Value then - begin - FIndent := Value; - if not (csLoading in ComponentState) and (FUpdateCount = 0) and HandleAllocated then - begin - UpdateScrollBars(True); - Invalidate; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetLineMode(const Value: TVTLineMode); - -begin - if FLineMode <> Value then - begin - FLineMode := Value; - if HandleAllocated and not (csLoading in ComponentState) then - Invalidate; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetLineStyle(const Value: TVTLineStyle); - -begin - if FLineStyle <> Value then - begin - FLineStyle := Value; - if not (csLoading in ComponentState) then - begin - PrepareBitmaps(False, True); - if HandleAllocated then - Invalidate; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetMargin(Value: Integer); - -begin - if FMargin <> Value then - begin - FMargin := Value; - if HandleAllocated and not (csLoading in ComponentState) then - Invalidate; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetMultiline(Node: PVirtualNode; const Value: Boolean); - -begin - if Assigned(Node) and (Node <> FRoot) then - if Value <> (vsMultiline in Node.States) then - begin - if Value then - Include(Node.States, vsMultiline) - else - Exclude(Node.States, vsMultiline); - - if FUpdateCount = 0 then - InvalidateNode(Node); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetNodeAlignment(const Value: TVTNodeAlignment); - -begin - if FNodeAlignment <> Value then - begin - FNodeAlignment := Value; - if HandleAllocated and not (csReading in ComponentState) then - Invalidate; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetNodeData(pNode: PVirtualNode; pUserData: Pointer); - - // Can be used to set user data of a PVirtualNode with the size of a pointer, useful for setting - // A pointer to a record or a reference to a class instance. - -var - NodeData: PPointer; -begin - // Check if there is initial user data and there is also enough user data space allocated. - Assert(FNodeDataSize >= SizeOf(Pointer), Self.Classname + ': Cannot set initial user data because there is not enough user data space allocated.'); - NodeData := PPointer(@pNode.Data); - NodeData^ := pUserData; - Include(pNode.States, vsOnFreeNodeCallRequired); -end; - -procedure TBaseVirtualTree.SetNodeData(pNode: PVirtualNode; pUserData: T); - - // Can be used to set user data of a PVirtualNode to a class instance. - -begin - pNode.SetData(pUserData); -end; - -procedure TBaseVirtualTree.SetNodeData(pNode: PVirtualNode; const pUserData: IInterface); - - // Can be used to set user data of a PVirtualNode to a class instance, - // will take care about reference counting. - -begin - pNode.SetData(pUserData); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetNodeDataSize(Value: Integer); - -var - LastRootCount: Cardinal; - -begin - if Value < -1 then - Value := -1; - if FNodeDataSize <> Value then - begin - FNodeDataSize := Value; - if not (csLoading in ComponentState) and not (csDesigning in ComponentState) then - begin - LastRootCount := FRoot.ChildCount; - Clear; - SetRootNodeCount(LastRootCount); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetNodeHeight(Node: PVirtualNode; Value: Cardinal); - -var - Difference: Integer; - -begin - Assert(Assigned(Node), 'SetNodeHeight() cannot be called with Node = nil'); - Assert((Node <> FRoot), 'SetNodeHeight() cannot be called for the root node FRoot'); - if (Node.NodeHeight <> Value) then - begin - Difference := Integer(Value) - Integer(Node.NodeHeight); - Node.NodeHeight := Value; - - // If the node is effectively filtered out, nothing else has to be done, as it is not visible anyway. - if not IsEffectivelyFiltered[Node] then - begin - AdjustTotalHeight(Node, Difference, True); - - // If an edit operation is currently active then update the editors boundaries as well. - UpdateEditBounds; - - InvalidateCache; - // Stay away from touching the node cache while it is being validated. - if not (tsValidating in FStates) and FullyVisible[Node] then - begin - if (FUpdateCount = 0) and ([tsPainting, tsSizing] * FStates = []) then - begin - ValidateCache; - InvalidateToBottom(Node); - UpdateScrollBars(True); - end; - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetNodeParent(Node: PVirtualNode; const Value: PVirtualNode); - -begin - if Assigned(Node) and Assigned(Value) and (Node.Parent <> Value) then - MoveTo(Node, Value, amAddChildLast, False); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetOffsetX(const Value: Integer); - -begin - DoSetOffsetXY(Point(Value, FOffsetY), DefaultScrollUpdateFlags); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetOffsetXY(const Value: TPoint); - -begin - DoSetOffsetXY(Value, DefaultScrollUpdateFlags); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetOffsetY(const Value: Integer); - -begin - DoSetOffsetXY(Point(FOffsetX, Value), DefaultScrollUpdateFlags); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetOptions(const Value: TCustomVirtualTreeOptions); - -begin - FOptions.Assign(Value); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetRangeX(value: Cardinal); -begin - FRangeX := value; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetRootNodeCount(Value: Cardinal); - -begin - // Don't set the root node count until all other properties (in particular the OnInitNode event) have been set. - if csLoading in ComponentState then - begin - FRoot.ChildCount := Value; - DoStateChange([tsNeedRootCountUpdate]); - end - else - if FRoot.ChildCount <> Value then - begin - BeginUpdate; - InterruptValidation; - SetChildCount(FRoot, Value); - EndUpdate; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetScrollBarOptions(Value: TScrollBarOptions); - -begin - FScrollBarOptions.Assign(Value); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetSearchOption(const Value: TVTIncrementalSearch); - -begin - if FIncrementalSearch <> Value then - begin - FIncrementalSearch := Value; - if FIncrementalSearch = isNone then - begin - StopTimer(SearchTimer); - FSearchBuffer := ''; - FLastSearchNode := nil; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetSelected(Node: PVirtualNode; Value: Boolean); - -begin - if not FSelectionLocked and Assigned(Node) and (Node <> FRoot) and (Value xor (vsSelected in Node.States)) then - begin - if Value then - begin - if FSelectionCount = 0 then - FRangeAnchor := Node - else begin - if not (toMultiSelect in FOptions.FSelectionOptions) then - ClearSelection; - if FRangeAnchor = nil then - FRangeAnchor := Node; - end; - - AddToSelection(Node, True); - - if not (toMultiSelect in FOptions.FSelectionOptions) then - FocusedNode := GetFirstSelected; // if only one node can be selected, make sure the focused node changes with the selected node - // Make sure there is a valid column selected (if there are columns at all). - if ((FFocusedColumn < 0) or not (coVisible in FHeader.Columns[FFocusedColumn].Options)) and - (FHeader.MainColumn > NoColumn) then - if ([coVisible, coAllowFocus] * FHeader.Columns[FHeader.MainColumn].Options = [coVisible, coAllowFocus]) then - FFocusedColumn := FHeader.MainColumn - else - FFocusedColumn := FHeader.Columns.GetFirstVisibleColumn(True); - end - else - begin - RemoveFromSelection(Node); - if FSelectionCount = 0 then - ResetRangeAnchor; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetSelectionCurveRadius(const Value: Cardinal); - -begin - if FSelectionCurveRadius <> Value then - begin - FSelectionCurveRadius := Value; - if HandleAllocated and not (csLoading in ComponentState) then - Invalidate; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetStateImages(const Value: TCustomImageList); - -begin - if FStateImages <> Value then - begin - if Assigned(FStateImages) then - begin - FStateImages.UnRegisterChanges(FStateChangeLink); - FStateImages.RemoveFreeNotification(Self); - end; - FStateImages := Value; - if Assigned(FStateImages) then - begin - FStateImages.RegisterChanges(FStateChangeLink); - FStateImages.FreeNotification(Self); - end; - if HandleAllocated and not (csLoading in ComponentState) then - Invalidate; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetTextMargin(Value: Integer); - -begin - if FTextMargin <> Value then - begin - FTextMargin := Value; - if not (csLoading in ComponentState) then - Invalidate; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetTopNode(Node: PVirtualNode); - -var - R: TRect; - Run: PVirtualNode; - -begin - if Assigned(Node) then - begin - // make sure all parents of the node are expanded - Run := Node.Parent; - while Run <> FRoot do - begin - if not (vsExpanded in Run.States) then - ToggleNode(Run); - Run := Run.Parent; - end; - R := GetDisplayRect(Node, FHeader.MainColumn, True); - SetOffsetY(FOffsetY - R.Top); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetUpdateState(Updating: Boolean); - -begin - // The check for visibility is necessary otherwise the tree is automatically shown when - // updating is allowed. As this happens internally the VCL does not get notified and - // still assumes the control is hidden. This results in weird "cannot focus invisible control" errors. - if Visible and HandleAllocated and (FUpdateCount = 0) then - SendMessage(Handle, WM_SETREDRAW, Ord(not Updating), 0); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetVerticalAlignment(Node: PVirtualNode; Value: Byte); - -begin - if Value > 100 then - Value := 100; - if Node.Align <> Value then - begin - Node.Align := Value; - if FullyVisible[Node] and not IsEffectivelyFiltered[Node] then - InvalidateNode(Node); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetVisible(Node: PVirtualNode; Value: Boolean); - -// Sets the visibility style of the given node according to Value. - -var - NeedUpdate: Boolean; - -begin - Assert(Assigned(Node) and (Node <> FRoot), 'Invalid parameter.'); - - if Value <> (vsVisible in Node.States) then - begin - InterruptValidation; - NeedUpdate := False; - if Value then - begin - Include(Node.States, vsVisible); - if vsExpanded in Node.Parent.States then - AdjustTotalHeight(Node.Parent, Node.TotalHeight, True); - if VisiblePath[Node] then - begin - Inc(FVisibleCount, CountVisibleChildren(Node) + Cardinal(IfThen(IsEffectivelyVisible[Node], 1))); - NeedUpdate := True; - end; - - // Update the hidden children flag of the parent. - // Since this node is now visible we simply have to remove the flag. - if not IsEffectivelyFiltered[Node] then - Exclude(Node.Parent.States, vsAllChildrenHidden); - end - else - begin - if vsExpanded in Node.Parent.States then - AdjustTotalHeight(Node.Parent, -Integer(Node.TotalHeight), True); - if VisiblePath[Node] then - begin - Dec(FVisibleCount, CountVisibleChildren(Node) + Cardinal(IfThen(IsEffectivelyVisible[Node], 1))); - NeedUpdate := True; - end; - Exclude(Node.States, vsVisible); - - if FUpdateCount = 0 then - DetermineHiddenChildrenFlag(Node.Parent) - else - Include(FStates, tsUpdateHiddenChildrenNeeded); - end; - - InvalidateCache; - if NeedUpdate and (FUpdateCount = 0) then - begin - ValidateCache; - UpdateScrollBars(True); - Invalidate; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetVisiblePath(Node: PVirtualNode; Value: Boolean); - -// If Value is True then all parent nodes of Node are expanded. - -begin - Assert(Assigned(Node) and (Node <> FRoot), 'Invalid parameter.'); - - if Value then - begin - repeat - Node := Node.Parent; - if Node = FRoot then - Break; - if not (vsExpanded in Node.States) then - ToggleNode(Node); - until False; - end; -end; - -// ---------------------------------------------------------------------------------------------------------------------- -procedure TBaseVirtualTree.PrepareBackGroundPicture(Source: TPicture; - DrawBitmap: TBitmap; DrawBitmapWidth: Integer; DrawBitMapHeight: Integer; ABkgcolor: TColor); -const - DST = $00AA0029; // Ternary Raster Operation - Destination unchanged - - // fill background will work for transparent images and - // will not disturb non-transparent ones - procedure FillDrawBitmapWithBackGroundColor; - begin - DrawBitmap.Canvas.Brush.Color := ABkgcolor; - DrawBitmap.Canvas.FillRect(Rect(0, 0, DrawBitmap.Width, DrawBitmap.Height)); - end; - -begin - DrawBitmap.SetSize(DrawBitmapWidth, DrawBitMapHeight); - - if (Source.Graphic is TBitmap) and - (FBackGroundImageTransparent or Source.Bitmap.TRANSPARENT) - then - begin - FillDrawBitmapWithBackGroundColor; - MaskBlt(DrawBitmap.Canvas.Handle, 0, 0, Source.Width, Source.Height, - Source.Bitmap.Canvas.Handle, 0, 0, Source.Bitmap.MaskHandle, 0, 0, - MakeROP4(DST, SRCCOPY)); - end - else - begin - // Similar to TImage's Transparent property behavior, we don't want - // to draw transparent if the following flag is OFF. - if FBackGroundImageTransparent then - FillDrawBitmapWithBackGroundColor; - DrawBitmap.Canvas.Draw(0, 0, Source.Graphic); - end -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.StaticBackground(Source: TPicture; Target: TCanvas; OffsetPosition: TPoint; R: TRect; aBkgColor: TColor); - -// Draws the given source graphic so that it stays static in the given rectangle which is relative to the target bitmap. -// The graphic is aligned so that it always starts at the upper left corner of the target canvas. -// Offset gives the position of the target window as a possible superordinated surface. - -const - DST = $00AA0029; // Ternary Raster Operation - Destination unchanged - -var - PicRect: TRect; - AreaRect: TRect; - DrawRect: TRect; - DrawBitmap: TBitmap; -begin - DrawBitmap := TBitmap.Create; - try - // clear background - Target.Brush.Color := aBkgColor; - Target.FillRect(R); - - // Picture rect in relation to client viewscreen. - PicRect := Rect(FBackgroundOffsetX, FBackgroundOffsetY, FBackgroundOffsetX + Source.Width, FBackgroundOffsetY + Source.Height); - - // Area to be draw in relation to client viewscreen. - AreaRect := Rect(OffsetPosition.X + R.Left, OffsetPosition.Y + R.Top, OffsetPosition.X + R.Right, OffsetPosition.Y + R.Bottom); - - // If picture falls in AreaRect, return intersection (DrawRect). - if IntersectRect(DrawRect, PicRect, AreaRect) then - begin - PrepareBackGroundPicture(Source, DrawBitmap, Source.Width, Source.Height, aBkgColor); - // copy image to destination - BitBlt(Target.Handle, DrawRect.Left - OffsetPosition.X, DrawRect.Top - OffsetPosition.Y, (DrawRect.Right - OffsetPosition.X) - (DrawRect.Left - OffsetPosition.X), - (DrawRect.Bottom - OffsetPosition.Y) - (DrawRect.Top - OffsetPosition.Y) + R.Top, DrawBitmap.Canvas.Handle, DrawRect.Left - PicRect.Left, DrawRect.Top - PicRect.Top, - SRCCOPY); - end; - finally - DrawBitmap.Free; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.StopTimer(ID: Integer); - -begin - if HandleAllocated then - KillTimer(Handle, ID); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetWindowTheme(const Theme: string); - -begin - FChangingTheme := True; - Winapi.UxTheme.SetWindowTheme(Handle, PWideChar(Theme), nil); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.TileBackground(Source: TPicture; Target: TCanvas; Offset: TPoint; R: TRect; aBkgColor: TColor); - -// Draws the given source graphic so that it tiles into the given rectangle which is relative to the target bitmap. -// The graphic is aligned so that it always starts at the upper left corner of the target canvas. -// Offset gives the position of the target window in an possible superordinated surface. - -var - SourceX, - SourceY, - TargetX, - DeltaY: Integer; - DrawBitmap: TBitmap; -begin - DrawBitmap := TBitmap.Create; - try - PrepareBackGroundPicture(Source, DrawBitmap, Source.Width, Source.Height, aBkgColor); - with Target do - begin - SourceY := (R.Top + Offset.Y + FBackgroundOffsetY) mod Source.Height; - // Always wrap the source coordinates into positive range. - if SourceY < 0 then - SourceY := Source.Height + SourceY; - - // Tile image vertically until target rect is filled. - while R.Top < R.Bottom do - begin - SourceX := (R.Left + Offset.X + FBackgroundOffsetX) mod Source.Width; - // always wrap the source coordinates into positive range - if SourceX < 0 then - SourceX := Source.Width + SourceX; - - TargetX := R.Left; - // height of strip to draw - DeltaY := Min(R.Bottom - R.Top, Source.Height - SourceY); - - // tile the image horizontally - while TargetX < R.Right do - begin - BitBlt(Handle, TargetX, R.Top, Min(R.Right - TargetX, Source.Width - SourceX), DeltaY, - DrawBitmap.Canvas.Handle, SourceX, SourceY, SRCCOPY); - Inc(TargetX, Source.Width - SourceX); - SourceX := 0; - end; - Inc(R.Top, Source.Height - SourceY); - SourceY := 0; - end; - end; - finally - DrawBitmap.Free; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.ToggleCallback(Step, StepSize: Integer; Data: Pointer): Boolean; - -var - Column: TColumnIndex; - Run: TRect; - SecondaryStepSize: Integer; - - //--------------- local functions ------------------------------------------- - - procedure EraseLine; - - var - LocalBrush: HBRUSH; - - begin - with TToggleAnimationData(Data^), FHeader.FColumns do - begin - // Iterate through all columns and erase background in their local color. - // LocalBrush is a brush in the color of the particular column. - Column := GetFirstVisibleColumn; - while (Column > InvalidColumn) and (Run.Left < ClientWidth) do - begin - GetColumnBounds(Column, Run.Left, Run.Right); - if coParentColor in Items[Column].FOptions then - FillRect(DC, Run, Brush) - else - begin - if VclStyleEnabled then - LocalBrush := CreateSolidBrush(ColorToRGB(FColors.BackGroundColor)) - else - LocalBrush := CreateSolidBrush(ColorToRGB(Items[Column].Color)); - FillRect(DC, Run, LocalBrush); - DeleteObject(LocalBrush); - end; - Column := GetNextVisibleColumn(Column); - end; - end; - end; - - //--------------------------------------------------------------------------- - - procedure DoScrollUp(DC: HDC; Brush: HBRUSH; Area: TRect; Steps: Integer); - - begin - ScrollDC(DC, 0, -Steps, Area, Area, 0, nil); - - if Step = 0 then - if not FHeader.UseColumns then - FillRect(DC, Rect(Area.Left, Area.Bottom - Steps - 1, Area.Right, Area.Bottom), Brush) - else - begin - Run := Rect(Area.Left, Area.Bottom - Steps - 1, Area.Right, Area.Bottom); - EraseLine; - end; - end; - - //--------------------------------------------------------------------------- - - procedure DoScrollDown(DC: HDC; Brush: HBRUSH; Area: TRect; Steps: Integer); - - begin - ScrollDC(DC, 0, Steps, Area, Area, 0, nil); - - if Step = 0 then - if not FHeader.UseColumns then - FillRect(DC, Rect(Area.Left, Area.Top, Area.Right, Area.Top + Steps + 1), Brush) - else - begin - Run := Rect(Area.Left, Area.Top, Area.Right, Area.Top + Steps + 1); - EraseLine; - end; - end; - - //--------------- end local functions --------------------------------------- - -begin - Result := True; - if StepSize > 0 then - begin - SecondaryStepSize := 0; - with TToggleAnimationData(Data^) do - begin - if Mode1 <> tamNoScroll then - begin - if Mode1 = tamScrollUp then - DoScrollUp(DC, Brush, R1, StepSize) - else - DoScrollDown(DC, Brush, R1, StepSize); - - if (Mode2 <> tamNoScroll) and (ScaleFactor > 0) then - begin - // As this routine is able to scroll two independent areas at once, the missing StepSize is - // computed in that case. To ensure the maximal accuracy the rounding error is accumulated. - SecondaryStepSize := Round((StepSize + MissedSteps) * ScaleFactor); - MissedSteps := MissedSteps + StepSize * ScaleFactor - SecondaryStepSize; - end; - end - else - SecondaryStepSize := StepSize; - - if Mode2 <> tamNoScroll then - if Mode2 = tamScrollUp then - DoScrollUp(DC, Brush, R2, SecondaryStepSize) - else - DoScrollDown(DC, Brush, R2, SecondaryStepSize); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.CMColorChange(var Message: TMessage); - -begin - if not (csLoading in ComponentState) then - begin - PrepareBitmaps(True, False); - if HandleAllocated then - Invalidate; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.CMCtl3DChanged(var Message: TMessage); - -begin - inherited; - if FBorderStyle = bsSingle then - RecreateWnd; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.CMBiDiModeChanged(var Message: TMessage); - -begin - inherited; - - if UseRightToLeftAlignment then - FEffectiveOffsetX := Integer(FRangeX) - ClientWidth + FOffsetX - else - FEffectiveOffsetX := -FOffsetX; - if FEffectiveOffsetX < 0 then - FEffectiveOffsetX := 0; - - if toAutoBidiColumnOrdering in FOptions.FAutoOptions then - FHeader.FColumns.ReorderColumns(UseRightToLeftAlignment); - FHeader.Invalidate(nil); -end; - -procedure TBaseVirtualTree.CMBorderChanged(var Message: TMessage); -begin - inherited; - if VclStyleEnabled and (seBorder in StyleElements) then - RecreateWnd; -end; - -procedure TBaseVirtualTree.CMParentDoubleBufferedChange(var Message: TMessage); -begin - // empty by intention, we do our own buffering -end; - -procedure TBaseVirtualTree.CMStyleChanged(var Message: TMessage); -begin - VclStyleChanged; - RecreateWnd; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.CMDenySubclassing(var Message: TMessage); - -// If a Windows XP Theme Manager component is used in the application it will try to subclass all controls which do not -// explicitly deny this. Virtual Treeview knows how to handle XP themes so it does not need subclassing. - -begin - Message.Result := 1; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.CMDrag(var Message: TCMDrag); - -var - S: TObject; - ShiftState: Integer; - P: TPoint; - Formats: TFormatArray; - Effect: Integer; - -begin - with Message, DragRec^ do - begin - S := Source; - Formats := nil; - - // Let the ancestor handle dock operations. - if S is TDragDockObject then - inherited - else - begin - // We need an extra check for the control drag object as there might be other objects not derived from - // this class (e.g. TActionDragObject). - if not (tsUserDragObject in FStates) and (S is TBaseDragControlObject) then - S := (S as TBaseDragControlObject).Control; - case DragMessage of - dmDragEnter, dmDragLeave, dmDragMove: - begin - if DragMessage = dmDragEnter then - DoStateChange([tsVCLDragging]); - if DragMessage = dmDragLeave then - DoStateChange([tsVCLDragFinished], [tsVCLDragging]); - - if DragMessage = dmDragMove then - with ScreenToClient(Pos) do - DoAutoScroll(X, Y); - - ShiftState := 0; - // Alt key will be queried by the KeysToShiftState function in DragOver. - if GetKeyState(VK_SHIFT) < 0 then - ShiftState := ShiftState or MK_SHIFT; - if GetKeyState(VK_CONTROL) < 0 then - ShiftState := ShiftState or MK_CONTROL; - - // Allowed drop effects are simulated for VCL dd. - Effect := DROPEFFECT_MOVE or DROPEFFECT_COPY; - DragOver(S, ShiftState, TDragState(DragMessage), Pos, Effect); - FLastVCLDragTarget := FDropTargetNode; - FVCLDragEffect := Effect; - if (DragMessage = dmDragLeave) and Assigned(FDropTargetNode) then - begin - InvalidateNode(FDropTargetNode); - FDropTargetNode := nil; - end; - Result := LRESULT(Effect); - end; - dmDragDrop: - begin - ShiftState := 0; - // Alt key will be queried by the KeysToShiftState function in DragOver - if GetKeyState(VK_SHIFT) < 0 then - ShiftState := ShiftState or MK_SHIFT; - if GetKeyState(VK_CONTROL) < 0 then - ShiftState := ShiftState or MK_CONTROL; - - // allowed drop effects are simulated for VCL dd, - // replace target node with cached node from other VCL dd messages - if Assigned(FDropTargetNode) then - InvalidateNode(FDropTargetNode); - FDropTargetNode := FLastVCLDragTarget; - P := Point(Pos.X, Pos.Y); - P := ScreenToClient(P); - try - DoDragDrop(S, nil, Formats, KeysToShiftState(ShiftState), P, FVCLDragEffect, FLastDropMode); - finally - if Assigned(FDropTargetNode) then - begin - InvalidateNode(FDropTargetNode); - FDropTargetNode := nil; - end; - end; - end; - dmFindTarget: - begin - Result := LRESULT(ControlAtPos(ScreenToClient(Pos), False)); - if Result = 0 then - Result := LRESULT(Self); - - // This is a reliable place to check whether VCL drag has - // really begun. - if tsVCLDragPending in FStates then - DoStateChange([tsVCLDragging], [tsVCLDragPending, tsEditPending, tsClearPending]); - end; - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.CMEnabledChanged(var Message: TMessage); - -begin - inherited; - - // Need to invalidate the non-client area as well, since the header must be redrawn too. - if csDesigning in ComponentState then - RedrawWindow(Handle, nil, 0, RDW_FRAME or RDW_INVALIDATE or RDW_NOERASE or RDW_NOCHILDREN); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.CMFontChanged(var Message: TMessage); - -var - HeaderMessage: TMessage; - -begin - inherited; - - if not (csLoading in ComponentState) then - begin - PrepareBitmaps(True, False); - if HandleAllocated then begin - AutoScale(False); - Invalidate; - end - end; - - HeaderMessage.Msg := CM_PARENTFONTCHANGED; - HeaderMessage.WParam := 0; - HeaderMessage.LParam := 0; - HeaderMessage.Result := 0; - FHeader.HandleMessage(HeaderMessage); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.CMHintShow(var Message: TCMHintShow); - -// Determines hint message (tooltip) and out-of-hint rect. -// Note: A special handling is needed here because we cannot pass wide strings back to the caller. -// I had to introduce the hint data record anyway so we can use this to pass the hint string. -// We still need to set a dummy hint string in the message to make the VCL showing the hint window. - -var - NodeRect: TRect; - SpanColumn, - Dummy, - ColLeft, - ColRight: Integer; - HitInfo: THitInfo; - ShowOwnHint: Boolean; - IsFocusedOrEditing: Boolean; - ParentForm: TCustomForm; - BottomRightCellContentMargin: TPoint; - HintKind: TVTHintKind; -begin - with Message do - begin - Result := 1; - - if PtInRect(FLastHintRect, HintInfo.CursorPos) then - Exit; - - // Determine node for which to show hint/tooltip. - with HintInfo^ do - GetHitTestInfoAt(CursorPos.X, CursorPos.Y, True, HitInfo); - - // Make sure a hint is only shown if the tree or at least its parent form is active. - // Active editing is ok too as long as we don't want the hint for the current edit node. - if IsEditing then - IsFocusedOrEditing := HitInfo.HitNode <> FFocusedNode - else - begin - IsFocusedOrEditing := Focused; - ParentForm := GetParentForm(Self); - if Assigned(ParentForm) then - IsFocusedOrEditing := ParentForm.Focused or Application.Active; - end; - - if (GetCapture = 0) and ShowHint and not (Dragging or IsMouseSelecting) and ([tsScrolling] * FStates = []) and - (FHeader.States = []) and IsFocusedOrEditing then - begin - with HintInfo^ do - begin - Result := 0; - ShowOwnHint := False; - - //workaround for issue #291 - //it duplicates parts of the following code and code in TVirtualTreeHintWindow - HintStr := ''; - if FHeader.UseColumns and (hoShowHint in FHeader.FOptions) and FHeader.InHeader(CursorPos) then - begin - CursorRect := FHeaderRect; - // Convert the cursor rectangle into real client coordinates. - OffsetRect(CursorRect, 0, -Integer(FHeader.FHeight)); - HitInfo.HitColumn := FHeader.FColumns.GetColumnAndBounds(CursorPos, CursorRect.Left, CursorRect.Right); - if (HitInfo.HitColumn > NoColumn) and not (csLButtonDown in ControlState) and - (FHeader.FColumns[HitInfo.HitColumn].FHint <> '') then - HintStr := FHeader.FColumns[HitInfo.HitColumn].FHint; - end - else - if HintMode = hmDefault then - HintStr := GetShortHint(Hint) - else - if Assigned(HitInfo.HitNode) and (HitInfo.HitColumn > InvalidColumn) then - begin - if HintMode = hmToolTip then - HintStr := DoGetNodeToolTip(HitInfo.HitNode, HitInfo.HitColumn, fHintData.LineBreakStyle) - else - HintStr := DoGetNodeHint(HitInfo.HitNode, HitInfo.HitColumn, fHintData.LineBreakStyle); - end; - - // First check whether there is a header hint to show. - if FHeader.UseColumns and (hoShowHint in FHeader.FOptions) and FHeader.InHeader(CursorPos) then - begin - CursorRect := FHeaderRect; - // Convert the cursor rectangle into real client coordinates. - OffsetRect(CursorRect, 0, -Integer(FHeader.FHeight)); - HitInfo.HitColumn := FHeader.FColumns.GetColumnAndBounds(CursorPos, CursorRect.Left, CursorRect.Right); - // align the vertical hint position on the bottom bound of the header, but - // avoid overlapping of mouse cursor and hint - HintPos.Y := Max(HintPos.Y, ClientToScreen(Point(0, CursorRect.Bottom)).Y); - // Note: the test for the left mouse button in ControlState might cause problems whenever the VCL does not - // realize when the button is released. This, for instance, happens when doing OLE drag'n drop and - // cancel this with ESC. - if (HitInfo.HitColumn > NoColumn) and not (csLButtonDown in ControlState) then - begin - HintStr := FHeader.FColumns[HitInfo.HitColumn].FHint; - if HintStr = '' then - with FHeader.FColumns[HitInfo.HitColumn] do - begin - if (2 * FMargin + CaptionWidth + 1) >= Width then - HintStr := FCaptionText; - end; - if HintStr <> '' then - ShowOwnHint := True - else - Result := 1; - end - else - Result := 1; - end - else - begin - // Default mode is handled as would the tree be a usual VCL control (no own hint window necessary). - if FHintMode = hmDefault then - HintStr := GetShortHint(Hint) - else - begin - if Assigned(HitInfo.HitNode) and (HitInfo.HitColumn > InvalidColumn) then - begin - // An owner-draw tree should only display a hint when at least - // its OnGetHintSize event handler is assigned. - DoGetHintKind(HitInfo.HitNode, HitInfo.HitColumn, HintKind); - FHintData.HintRect := Rect(0, 0, 0, 0); - if (HintKind = vhkOwnerDraw) then - begin - DoGetHintSize(HitInfo.HitNode, HitInfo.HitColumn, FHintData.HintRect); - ShowOwnHint := not IsRectEmpty(FHintData.HintRect); - end - else - // For trees displaying text hints, a decision about showing the hint or not is based - // on the hint string (if it is empty then no hint is shown). - ShowOwnHint := True; - - if ShowOwnHint then - begin - if HitInfo.HitColumn > NoColumn then - begin - FHeader.FColumns.GetColumnBounds(HitInfo.HitColumn, ColLeft, ColRight); - // The right column border might be extended if column spanning is enabled. - if toAutoSpanColumns in FOptions.FAutoOptions then - begin - SpanColumn := HitInfo.HitColumn; - repeat - Dummy := FHeader.FColumns.GetNextVisibleColumn(SpanColumn); - if (Dummy = InvalidColumn) or not ColumnIsEmpty(HitInfo.HitNode, Dummy) then - Break; - SpanColumn := Dummy; - until False; - if SpanColumn <> HitInfo.HitColumn then - FHeader.FColumns.GetColumnBounds(SpanColumn, Dummy, ColRight); - end; - end - else - begin - ColLeft := 0; - ColRight := ClientWidth; - end; - - if FHintMode <> hmTooltip then - begin - // Node specific hint text. - CursorRect := GetDisplayRect(HitInfo.HitNode, HitInfo.HitColumn, False); - CursorRect.Left := ColLeft; - CursorRect.Right := ColRight; - // Align the vertical hint position on the bottom bound of the node, but - // avoid overlapping of mouse cursor and hint. - HintPos.Y := Max(HintPos.Y, ClientToScreen(CursorRect.BottomRight).Y) + ScaledPixels(2); - end - else - begin - // Tool tip to show. This means the full caption of the node must be displayed. - if vsMultiline in HitInfo.HitNode.States then - begin - if hiOnItemLabel in HitInfo.HitPositions then - begin - ShowOwnHint := True; - NodeRect := GetDisplayRect(HitInfo.HitNode, HitInfo.HitColumn, True, False); - end - else - ShowOwnHint := False; - end - else - begin - NodeRect := GetDisplayRect(HitInfo.HitNode, HitInfo.HitColumn, True, True, True); - BottomRightCellContentMargin := DoGetCellContentMargin(HitInfo.HitNode, HitInfo.HitColumn, ccmtBottomRightOnly); - - ShowOwnHint := (HitInfo.HitColumn > InvalidColumn) and PtInRect(NodeRect, CursorPos) and - (CursorPos.X <= ColRight) and (CursorPos.X >= ColLeft) and - ( - // Show hint also if the node text is partially out of the client area. - // "ColRight - 1", since the right column border is not part of this cell. - ( (NodeRect.Right + BottomRightCellContentMargin.X) > Min(ColRight - 1, ClientWidth) ) or - (NodeRect.Left < Max(ColLeft, 0)) or - ( (NodeRect.Bottom + BottomRightCellContentMargin.Y) > ClientHeight ) or - (NodeRect.Top < 0) - ); - end; - - if ShowOwnHint then - begin - // Node specific hint text given will be retrieved when needed. - HintPos := ClientToScreen(Point(NodeRect.Left, NodeRect.Top)); - CursorRect := NodeRect; - end - else - // nothing to show - Result := 1; - end; - end - else - Result := 1; // Avoid hint if this is a draw tree returning an empty hint rectangle. - end - else - begin - // No node so fall back to control's hint (if indicated) or show nothing. - if FHintMode = hmHintAndDefault then - begin - HintStr := GetShortHint(Hint); - - // Fix for the problem: Default Hint once shown stayed even when - // node hint was to be displayed. The reason was that CursorRect - // was for the full client area. Now reducing it to remove the - // columns from it. - if BidiMode = bdLeftToRight then - CursorRect.Left := Header.Columns.TotalWidth - else - CursorRect.right := CursorRect.right - Header.Columns.TotalWidth; - - if Length(HintStr) = 0 then - Result := 1 - else - ShowOwnHint := True; - end - else - Result := 1; - end; - end; - end; - - // Set our own hint window class and prepare structure to be passed to the hint window. - if ShowOwnHint and (Result = 0) then - begin - HintWindowClass := GetHintWindowClass; - FHintData.HintText := HintStr; - FHintData.Tree := Self; - FHintData.Column := HitInfo.HitColumn; - FHintData.Node := HitInfo.HitNode; - FLastHintRect := CursorRect; - HintData := @FHintData; - end - else - FLastHintRect := Rect(0, 0, 0, 0); - end; - - // Remind that a hint is about to show. - if Result = 0 then - DoStateChange([tsHint]) - else - DoStateChange([], [tsHint]); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.CMHintShowPause(var Message: TCMHintShowPause); - -// Tells the application that the tree (and only the tree) does not want a delayed tool tip. -// Normal hints / header hints use the default delay (except for the first time). - - begin - if ShowHint and (FHintMode = hmToolTip) then - Message.Pause^ := 0; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.CMMouseEnter(var Message: TMessage); -begin - DoMouseEnter(); - inherited; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.CMMouseLeave(var Message: TMessage); - -var - LeaveStates: TVirtualTreeStates; - -begin - // Reset the last used hint rectangle in case the mouse enters the window within the bounds - if Assigned(FHintData.Tree) then - FHintData.Tree.FLastHintRect := Rect(0, 0, 0, 0); - - LeaveStates := [tsHint]; - if [tsWheelPanning, tsWheelScrolling] * FStates = [] then - begin - StopTimer(ScrollTimer); - LeaveStates := LeaveStates + [tsScrollPending, tsScrolling]; - end; - DoStateChange([], LeaveStates); - if Assigned(FCurrentHotNode) then - begin - DoHotChange(FCurrentHotNode, nil); - if (toHotTrack in FOptions.PaintOptions) or (toCheckSupport in FOptions.FMiscOptions) then - InvalidateNode(FCurrentHotNode); - FCurrentHotNode := nil; - end; - - if Assigned(Header) then - begin - Header.FColumns.FDownIndex := NoColumn; - Header.FColumns.FHoverIndex := NoColumn; - Header.FColumns.FCheckBoxHit := False; - end; - DoMouseLeave(); - inherited; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.CMMouseWheel(var Message: TCMMouseWheel); - -var - ScrollAmount: Integer; - ScrollLines: DWORD; - RTLFactor: Integer; - WheelFactor: Double; - -begin - StopWheelPanning; - - inherited; - - if Message.Result = 0 then - begin - with Message do - begin - Result := 1; - WheelFactor := WheelDelta / WHEEL_DELTA; - if (FRangeY > Cardinal(ClientHeight)) and (not (ssShift in ShiftState)) then - begin - // Scroll vertically if there's something to scroll... - if ssCtrl in ShiftState then - ScrollAmount := Trunc(WheelFactor * ClientHeight) - else - begin - SystemParametersInfo(SPI_GETWHEELSCROLLLINES, 0, @ScrollLines, 0); - if ScrollLines = WHEEL_PAGESCROLL then - ScrollAmount := Trunc(WheelFactor * ClientHeight) - else - ScrollAmount := Integer(Trunc(WheelFactor * ScrollLines * FDefaultNodeHeight)); - end; - SetOffsetY(FOffsetY + ScrollAmount); - end - else - begin - // ...else scroll horizontally if there's something to scroll. - if UseRightToLeftAlignment then - RTLFactor := -1 - else - RTLFactor := 1; - - if ssCtrl in ShiftState then - ScrollAmount := Trunc(WheelFactor * (ClientWidth - FHeader.Columns.GetVisibleFixedWidth)) - else - begin - SystemParametersInfo(SPI_GETWHEELSCROLLLINES, 0, @ScrollLines, 0); - ScrollAmount := Trunc(WheelFactor * ScrollLines * FHeader.Columns.GetScrollWidth); - end; - SetOffsetX(FOffsetX + RTLFactor * ScrollAmount); - end; - end; - - end; - -end; - -//---------------------------------------------------------------------------------------------------------------------- -procedure TBaseVirtualTree.CMSysColorChange(var Message: TMessage); - -begin - inherited; - Message.Msg := WM_SYSCOLORCHANGE; - DefaultHandler(Message); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.TVMGetItem(var Message: TMessage); - -// Screen reader support function. The method returns information about a particular node. - -const - StateMask = TVIS_STATEIMAGEMASK or TVIS_OVERLAYMASK or TVIS_EXPANDED or TVIS_DROPHILITED or TVIS_CUT or - TVIS_SELECTED or TVIS_FOCUSED; - -var - Item: PTVItemEx; - Node: PVirtualNode; - Ghosted: Boolean; - ImageIndex: TImageIndex; - R: TRect; - Text: string; -begin - // We can only return valid data if a nodes reference is given. - Item := Pointer(Message.LParam); - Message.Result := Ord(((Item.mask and TVIF_HANDLE) <> 0) and Assigned(Item.hItem)); - if Message.Result = 1 then - begin - Node := Pointer(Item.hItem); - // Child count requested? - if (Item.mask and TVIF_CHILDREN) <> 0 then - Item.cChildren := Node.ChildCount; - // Index for normal image requested? - if (Item.mask and TVIF_IMAGE) <> 0 then - begin - ImageIndex := -1; - DoGetImageIndex(Node, ikNormal, -1, Ghosted, ImageIndex); - Item.iImage := ImageIndex; - end; - // Index for selected image requested? - if (Item.mask and TVIF_SELECTEDIMAGE) <> 0 then - begin - ImageIndex := -1; - DoGetImageIndex(Node, ikSelected, -1, Ghosted, ImageIndex); - Item.iSelectedImage := ImageIndex; - end; - // State info requested? - if (Item.mask and TVIF_STATE) <> 0 then - begin - // Everything, which is possible is returned. - Item.stateMask := StateMask; - Item.state := 0; - if Node = FFocusedNode then - Item.state := Item.state or TVIS_FOCUSED; - if vsSelected in Node.States then - Item.state := Item.state or TVIS_SELECTED; - if vsCutOrCopy in Node.States then - Item.state := Item.state or TVIS_CUT; - if Node = FDropTargetNode then - Item.state := Item.state or TVIS_DROPHILITED; - if vsExpanded in Node.States then - Item.state := Item.state or TVIS_EXPANDED; - - // Construct state image and overlay image indices. They are one based, btw. - // and zero means there is no image. - ImageIndex := -1; - DoGetImageIndex(Node, ikState, -1, Ghosted, ImageIndex); - Item.state := Item.state or Byte(IndexToStateImageMask(ImageIndex + 1)); - ImageIndex := -1; - DoGetImageIndex(Node, ikOverlay, -1, Ghosted, ImageIndex); - Item.state := Item.state or Byte(IndexToOverlayMask(ImageIndex + 1)); - end; - // Node caption requested? - if (Item.mask and TVIF_TEXT) <> 0 then - begin - GetTextInfo(Node, -1, Font, R, Text); - - StrLCopy(Item.pszText, PWideChar(Text), Item.cchTextMax - 1); - Item.pszText[Length(Text)] := #0; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.TVMGetItemRect(var Message: TMessage); - -// Screen read support function. This method returns a node's display rectangle. - -var - TextOnly: Boolean; - Node: PVirtualNode; - -begin - // The lparam member is used two-way. On enter it contains a pointer to the item (node). - // On exit it is to be considered as pointer to a rectangle structure. - Node := Pointer(Pointer(Message.LParam)^); - Message.Result := Ord(IsVisible[Node]); - if Message.Result <> 0 then - begin - TextOnly := Message.WParam <> 0; - PRect(Message.LParam)^ := GetDisplayRect(Node, NoColumn, TextOnly); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.TVMGetNextItem(var Message: TMessage); - -// Screen read support function. This method returns a node depending on the requested case. - -var - Node: PVirtualNode; - -begin - // Start with a nil result. - Message.Result := 0; - Node := Pointer(Message.LParam); - case Message.WParam of - TVGN_CARET: - Message.Result := LRESULT(FFocusedNode); - TVGN_CHILD: - if Assigned(Node) then - Message.Result := LRESULT(GetFirstChild(Node)); - TVGN_DROPHILITE: - Message.Result := LRESULT(FDropTargetNode); - TVGN_FIRSTVISIBLE: - Message.Result := LRESULT(GetFirstVisible(nil, True)); - TVGN_LASTVISIBLE: - Message.Result := LRESULT(GetLastVisible(nil, True)); - TVGN_NEXT: - if Assigned(Node) then - Message.Result := LRESULT(GetNextSibling(Node)); - TVGN_NEXTVISIBLE: - if Assigned(Node) then - Message.Result := LRESULT(GetNextVisible(Node, True)); - TVGN_PARENT: - if Assigned(Node) and (Node <> FRoot) and (Node.Parent <> FRoot) then - Message.Result := LRESULT(Node.Parent); - TVGN_PREVIOUS: - if Assigned(Node) then - Message.Result := LRESULT(GetPreviousSibling(Node)); - TVGN_PREVIOUSVISIBLE: - if Assigned(Node) then - Message.Result := LRESULT(GetPreviousVisible(Node, True)); - TVGN_ROOT: - Message.Result := LRESULT(GetFirst); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WMCancelMode(var Message: TWMCancelMode); - -begin - // Clear any transient state. - StopTimer(ExpandTimer); - StopTimer(EditTimer); - StopTimer(HeaderTimer); - StopTimer(ScrollTimer); - StopTimer(SearchTimer); - StopTimer(ThemeChangedTimer); - FSearchBuffer := ''; - FLastSearchNode := nil; - - DoStateChange([], [tsClearPending, tsEditPending, tsOLEDragPending, tsVCLDragPending, tsDrawSelecting, - tsDrawSelPending, tsIncrementalSearching]); - - inherited; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WMChar(var Message: TWMChar); - -begin - if tsIncrementalSearchPending in FStates then - begin - HandleIncrementalSearch(Message.CharCode); - DoStateChange([], [tsIncrementalSearchPending]); - end; - - inherited; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WMContextMenu(var Message: TWMContextMenu); - -// This method is called when a popup menu is about to be displayed. -// We have to cancel some pending states here to avoid interferences. - -begin - DoStateChange([], [tsClearPending, tsEditPending, tsOLEDragPending, tsVCLDragPending]); - - if not (tsPopupMenuShown in FStates) then - inherited; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WMCopy(var Message: TWMCopy); - -begin - CopyToClipboard; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WMCut(var Message: TWMCut); - -begin - CutToClipboard; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WMEnable(var Message: TWMEnable); - -begin - inherited; - RedrawWindow(Handle, nil, 0, RDW_FRAME or RDW_INVALIDATE or RDW_NOERASE or RDW_NOCHILDREN); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WMEraseBkgnd(var Message: TWMEraseBkgnd); - -begin - Message.Result := 1; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WMGetDlgCode(var Message: TWMGetDlgCode); - -begin - Message.Result := DLGC_WANTCHARS or DLGC_WANTARROWS; - if FWantTabs then - Message.Result := Message.Result or DLGC_WANTTAB; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WMGetObject(var Message: TMessage); - -begin - if TVTAccessibilityFactory.GetAccessibilityFactory <> nil then - begin - // Create the IAccessibles for the tree view and tree view items, if necessary. - if FAccessible = nil then - FAccessible := TVTAccessibilityFactory.GetAccessibilityFactory.CreateIAccessible(Self); - if FAccessibleItem = nil then - FAccessibleItem := TVTAccessibilityFactory.GetAccessibilityFactory.CreateIAccessible(Self); - if Cardinal(Message.LParam) = OBJID_CLIENT then - if Assigned(Accessible) then - Message.Result := LresultFromObject(IID_IAccessible, Message.WParam, FAccessible) - else - Message.Result := 0; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WMHScroll(var Message: TWMHScroll); - - //--------------- local functions ------------------------------------------- - - function GetRealScrollPosition: Integer; - - var - SI: TScrollInfo; - Code: Integer; - - begin - SI.cbSize := SizeOf(TScrollInfo); - SI.fMask := SIF_TRACKPOS; - Code := SB_HORZ; - GetScrollInfo(Handle, Code, SI); - Result := SI.nTrackPos; - end; - - //--------------- end local functions --------------------------------------- - -var - RTLFactor: Integer; - -begin - if UseRightToLeftAlignment then - RTLFactor := -1 - else - RTLFactor := 1; - - case Message.ScrollCode of - SB_BOTTOM: - SetOffsetX(-Integer(FRangeX)); - SB_ENDSCROLL: - begin - DoStateChange([], [tsThumbTracking]); - // avoiding to adjust the vertical scroll position while tracking makes it much smoother - // but we need to adjust the final position here then - UpdateHorizontalScrollBar(False); - end; - SB_LINELEFT: - SetOffsetX(FOffsetX + RTLFactor * FScrollBarOptions.FIncrementX); - SB_LINERIGHT: - SetOffsetX(FOffsetX - RTLFactor * FScrollBarOptions.FIncrementX); - SB_PAGELEFT: - SetOffsetX(FOffsetX + RTLFactor * (ClientWidth - FHeader.Columns.GetVisibleFixedWidth)); - SB_PAGERIGHT: - SetOffsetX(FOffsetX - RTLFactor * (ClientWidth - FHeader.Columns.GetVisibleFixedWidth)); - SB_THUMBPOSITION, - SB_THUMBTRACK: - begin - DoStateChange([tsThumbTracking]); - if UseRightToLeftAlignment then - SetOffsetX(-Integer(FRangeX) + ClientWidth + GetRealScrollPosition) - else - SetOffsetX(-GetRealScrollPosition); - end; - SB_TOP: - SetOffsetX(0); - end; - - Message.Result := 0; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WMKeyDown(var Message: TWMKeyDown); - -// Keyboard event handling for node focus, selection, node specific popup menus and help invokation. -// For a detailed description of every action done here read the help. - -var - Shift: TShiftState; - Node, Temp, - LastFocused: PVirtualNode; - Offset: Integer; - ClearPending, - NeedInvalidate, - DoRangeSelect, - PerformMultiSelect: Boolean; - Context: Integer; - ParentControl: TWinControl; - R: TRect; - NewCheckState: TCheckState; - TempColumn, - NewColumn: TColumnIndex; - ActAsGrid: Boolean; - ForceSelection: Boolean; - NewWidth, - NewHeight: Integer; - RTLFactor: Integer; - - // for tabulator handling - GetStartColumn: function(ConsiderAllowFocus: Boolean = False): TColumnIndex of object; - GetNextColumn: function(Column: TColumnIndex; ConsiderAllowFocus: Boolean = False): TColumnIndex of object; - GetNextNode: TGetNextNodeProc; - - KeyState: TKeyboardState; - Buffer: array[0..1] of AnsiChar; - - //--------------- local functions ------------------------------------------- - function getPreviousVisibleAutoSpanColumn(acolumn: TColumnIndex; anode: PVirtualNode): TColumnIndex; - var - PrevColumn: Integer; - begin - if (not assigned(anode)) - or (not FHeader.UseColumns) - or (not (toAutoSpanColumns in FOptions.FAutoOptions)) - or (acolumn = FHeader.MainColumn) then - begin - //previously existing logic - result := FHeader.Columns.GetPreviousVisibleColumn(acolumn, True); - exit; - end; - //consider auto spanning - with FHeader.FColumns do //standard loop for auto span - begin - PrevColumn := acolumn; - repeat - result := FHeader.Columns.GetPreviousVisibleColumn(PrevColumn); - if (result = InvalidColumn) or - (not ColumnIsEmpty(anode, result)) - //Any other BidiMode is not supported as already - //documented by original developer - or (Items[result].BidiMode <> bdLeftToRight) then - Break; - PrevColumn := result; - until False; - end; - end; - - //--------------------------------------------------------------------------- - function getNextVisibleAutoSpanColumn(acolumn: TColumnIndex; anode: PVirtualNode): TColumnIndex; - var - NextColumn: Integer; - begin - if (not assigned(anode)) - or (not FHeader.UseColumns) - or (not (toAutoSpanColumns in FOptions.FAutoOptions)) - or (acolumn = FHeader.MainColumn) then - begin - //previously existing logic - result := FHeader.Columns.GetNextVisibleColumn(acolumn, True); - exit; - end; - //consider auto spanning - with FHeader.FColumns do //standard loop for auto span - begin - NextColumn := acolumn; - repeat - result := FHeader.Columns.GetNextVisibleColumn(NextColumn); - if (result = InvalidColumn) or - not ColumnIsEmpty(anode, result) - //Any other BidiMode is not supported as already - //documented by original developer - or (Items[result].BidiMode <> bdLeftToRight) then - Break; - NextColumn := result; - until False; - end; - end; - - //--------------------------------------------------------------------------- - function isEmptyAutoSpanColumn(acolumn: TColumnIndex; anode: PVirtualNode): boolean; - var - previousColumn: Integer; - begin - result := false; - if (not assigned(anode)) - or (not FHeader.UseColumns) - or (not (toAutoSpanColumns in FOptions.FAutoOptions)) - or (acolumn = FHeader.MainColumn) then - exit; - with FHeader.FColumns do - begin - previousColumn := FHeader.Columns.GetPreviousVisibleColumn(acolumn); - if (previousColumn = InvalidColumn) //there is no previous column - //Any other BidiMode is not supported as already - //documented by original developer - or (Items[acolumn].BidiMode <> bdLeftToRight) then - exit; //returning false - result := ColumnIsEmpty(anode, acolumn); - end; - end; - - - //--------------- end local functions --------------------------------------- - -begin - // Make form key preview work and let application modify the key if it wants this. - inherited; - - with Message do - begin - Shift := KeyDataToShiftState(KeyData); - // Ask the application if the default key handling is desired. - if DoKeyAction(CharCode, Shift) then - begin - if (CharCode in [VK_HOME, VK_END, VK_PRIOR, VK_NEXT, VK_UP, VK_DOWN, VK_LEFT, VK_RIGHT, VK_BACK, VK_TAB]) and (RootNode.FirstChild <> nil) then - begin - PerformMultiSelect := (ssShift in Shift) and (toMultiSelect in FOptions.FSelectionOptions) and not IsEditing; - - // Flag to avoid range selection in case of single node advance. - DoRangeSelect := (CharCode in [VK_HOME, VK_END, VK_PRIOR, VK_NEXT]) and PerformMultiSelect and not IsEditing; - - NeedInvalidate := DoRangeSelect or (FSelectionCount > 1); - ActAsGrid := toGridExtensions in FOptions.FMiscOptions; - ClearPending := (Shift = []) or (ActAsGrid and not (ssShift in Shift)) or - not (toMultiSelect in FOptions.FSelectionOptions) or (CharCode in [VK_TAB, VK_BACK]); - - // Keep old focused node for range selection. Use a default node if none was focused until now. - LastFocused := FFocusedNode; - if (LastFocused = nil) and (Shift <> []) then - LastFocused := GetFirstVisible(nil, True); - - // Set an initial range anchor if there is not yet one. - if FRangeAnchor = nil then - FRangeAnchor := GetFirstSelected; - if FRangeAnchor = nil then - FRangeAnchor := GetFirst; - - if UseRightToLeftAlignment then - RTLFactor := -1 - else - RTLFactor := 1; - - // Determine new focused node. - case CharCode of - VK_HOME, VK_END: - begin - if (CharCode = VK_END) xor UseRightToLeftAlignment then - begin - GetStartColumn := FHeader.FColumns.GetLastVisibleColumn; - GetNextColumn := FHeader.FColumns.GetPreviousVisibleColumn; - GetNextNode := GetPreviousVisible; - Node := GetLastVisible(nil, True); - end - else - begin - GetStartColumn := FHeader.FColumns.GetFirstVisibleColumn; - GetNextColumn := FHeader.FColumns.GetNextVisibleColumn; - GetNextNode := GetNextVisible; - Node := GetFirstVisible(nil, True); - end; - - // Advance to next/previous visible column. - if FHeader.UseColumns then - NewColumn := GetStartColumn - else - NewColumn := NoColumn; - // Find a column for the new/current node which can be focused. - // Make the 'DoFocusChanging' for finding a valid column - // identifiable from the 'DoFocusChanging' raised later on by - // "FocusedNode := Node;" - while (NewColumn > NoColumn) and not DoFocusChanging(FFocusedNode, FFocusedNode, FFocusedColumn, NewColumn) do - NewColumn := GetNextColumn(NewColumn); - if NewColumn > InvalidColumn then - begin - if (Shift = [ssCtrl]) and not ActAsGrid then - begin - ScrollIntoView(Node, toCenterScrollIntoView in FOptions.SelectionOptions, - not (toDisableAutoscrollOnFocus in FOptions.FAutoOptions)); - if (CharCode = VK_HOME) and not UseRightToLeftAlignment then - SetOffsetX(0) - else - SetOffsetX(-MaxInt); - end - else - begin - if not ActAsGrid or (ssCtrl in Shift) then - FocusedNode := Node; - //fix: In grid mode, if full row select option is ON, - //then also go to the node determined from the earlier logic - if ActAsGrid and (toFullRowSelect in FOptions.FSelectionOptions) then - FocusedNode := Node; - if ActAsGrid and not (toFullRowSelect in FOptions.FSelectionOptions) then - begin - FocusedColumn := NewColumn; - // fix: If auto span is ON the last column may be a merged column. So take - // care of selecting the whole merged column on END key. - if (CharCode = VK_END) and isEmptyAutoSpanColumn(NewColumn, FFocusedNode) then - FocusedColumn := getPreviousVisibleAutoSpanColumn(NewColumn, FFocusedNode); - end; - end; - end; - end; - VK_PRIOR: - if Shift = [ssCtrl, ssShift] then - SetOffsetX(FOffsetX + ClientWidth) - else - if [ssShift, ssAlt] = Shift then - begin - if FFocusedColumn <= NoColumn then - NewColumn := FHeader.FColumns.GetFirstVisibleColumn - else - begin - Offset := FHeader.FColumns.GetVisibleFixedWidth; - NewColumn := FFocusedColumn; - while True do - begin - TempColumn := FHeader.FColumns.GetPreviousVisibleColumn(NewColumn); - NewWidth := FHeader.FColumns[NewColumn].Width; - if (TempColumn <= NoColumn) or - (Offset + NewWidth >= ClientWidth) or - (coFixed in FHeader.FColumns[TempColumn].FOptions) then - Break; - NewColumn := TempColumn; - Inc(Offset, NewWidth); - end; - end; - SetFocusedColumn(NewColumn); - end - else - if ssCtrl in Shift then - SetOffsetY(FOffsetY + ClientHeight) - else - begin - Offset := 0; - // If there's no focused node then just take the very first visible one. - if FFocusedNode = nil then - Node := GetFirstVisible(nil, True) - else - begin - // Go up as many nodes as comprise together a size of ClientHeight. - Node := FFocusedNode; - while True do - begin - Temp := GetPreviousVisible(Node, True); - NewHeight := NodeHeight[Node]; - if (Temp = nil) or (Offset + NewHeight >= ClientHeight) then - Break; - Node := Temp; - Inc(Offset, NodeHeight[Node]); - end; - end; - FocusedNode := Node; - end; - VK_NEXT: - if Shift = [ssCtrl, ssShift] then - SetOffsetX(FOffsetX - ClientWidth) - else - if [ssShift, ssAlt] = Shift then - begin - if FFocusedColumn <= NoColumn then - NewColumn := FHeader.FColumns.GetFirstVisibleColumn - else - begin - Offset := FHeader.FColumns.GetVisibleFixedWidth; - NewColumn := FFocusedColumn; - while True do - begin - TempColumn := FHeader.FColumns.GetNextVisibleColumn(NewColumn); - NewWidth := FHeader.FColumns[NewColumn].Width; - if (TempColumn <= NoColumn) or - (Offset + NewWidth >= ClientWidth) or - (coFixed in FHeader.FColumns[TempColumn].FOptions) then - Break; - NewColumn := TempColumn; - Inc(Offset, NewWidth); - end; - end; - SetFocusedColumn(NewColumn); - end - else - if ssCtrl in Shift then - SetOffsetY(FOffsetY - ClientHeight) - else - begin - Offset := 0; - // If there's no focused node then just take the very last one. - if FFocusedNode = nil then - Node := GetLastVisible(nil, True) - else - begin - // Go up as many nodes as comprise together a size of ClientHeight. - Node := FFocusedNode; - while True do - begin - Temp := GetNextVisible(Node, True); - NewHeight := NodeHeight[Node]; - if (Temp = nil) or (Offset + NewHeight >= ClientHeight) then - Break; - Node := Temp; - Inc(Offset, NewHeight); - end; - end; - FocusedNode := Node; - end; - VK_UP: - begin - // scrolling without selection change - if ssCtrl in Shift then - SetOffsetY(FOffsetY + Integer(FDefaultNodeHeight)) - else - begin - if FFocusedNode = nil then - Node := GetLastVisible(nil, True) - else - Node := GetPreviousVisible(FFocusedNode, True); - - if Assigned(Node) then - begin - if not EndEditNode then - exit; - if (not PerformMultiSelect or (CompareNodePositions(LastFocused, Node) < -1)) and Assigned(FFocusedNode) then - ClearSelection(False); // Clear selection only if more than one node was skipped. See issue #926 - if FFocusedColumn <= NoColumn then - FFocusedColumn := FHeader.MainColumn; - FocusedNode := Node; - end - else - if Assigned(FFocusedNode) then - InvalidateNode(FFocusedNode); - end; - end; - VK_DOWN: - begin - // scrolling without selection change - if ssCtrl in Shift then - SetOffsetY(FOffsetY - Integer(FDefaultNodeHeight)) - else - begin - if FFocusedNode = nil then - Node := GetFirstVisible(nil, True) - else - Node := GetNextVisible(FFocusedNode, True); - - if Assigned(Node) then - begin - if not EndEditNode then - exit; - if (not PerformMultiSelect or (CompareNodePositions(LastFocused, Node) > 1)) and Assigned(FFocusedNode) then - ClearSelection(False); // Clear selection only if more than one node was skipped. See issue #926 - if FFocusedColumn <= NoColumn then - FFocusedColumn := FHeader.MainColumn; - FocusedNode := Node; - end - else - if Assigned(FFocusedNode) then - InvalidateNode(FFocusedNode); - end; - end; - VK_LEFT: - begin - // special handling - if ssCtrl in Shift then - SetOffsetX(FOffsetX + RTLFactor * FHeader.Columns.GetScrollWidth) - else - begin - // other special cases - Context := NoColumn; - if (toExtendedFocus in FOptions.FSelectionOptions) and (toGridExtensions in FOptions.FMiscOptions) then - begin - Context := getPreviousVisibleAutoSpanColumn(FFocusedColumn, FFocusedNode); - if Context > NoColumn then - FocusedColumn := Context; - end - else - if Assigned(FFocusedNode) and (vsExpanded in FFocusedNode.States) and - (Shift = []) and (vsHasChildren in FFocusedNode.States) then - ToggleNode(FFocusedNode) - else - begin - if FFocusedNode = nil then - FocusedNode := GetFirstVisible(nil, True) - else - begin - if FFocusedNode.Parent <> FRoot then - Node := FFocusedNode.Parent - else - Node := nil; - if Assigned(Node) then - begin - if PerformMultiSelect then - begin - // and a third special case - if FFocusedNode.Index > 0 then - DoRangeSelect := True - else - if CompareNodePositions(Node, FRangeAnchor) > 0 then - RemoveFromSelection(FFocusedNode); - end; - FocusedNode := Node; - end - else begin - // If already a root node is selected, then scroll to the left as there is nothing else we could do. #691 - SetOffsetX(FOffsetX + RTLFactor * FHeader.Columns.GetScrollWidth); - end;//else - end; - end; - end; - end; - VK_RIGHT: - begin - // special handling - if ssCtrl in Shift then - SetOffsetX(FOffsetX - RTLFactor * FHeader.Columns.GetScrollWidth) - else - begin - // other special cases - Context := NoColumn; - if (toExtendedFocus in FOptions.FSelectionOptions) and (toGridExtensions in FOptions.FMiscOptions) then - begin - Context := getNextVisibleAutoSpanColumn(FFocusedColumn, FFocusedNode); - if Context > NoColumn then - FocusedColumn := Context; - end - else - if Assigned(FFocusedNode) and not (vsExpanded in FFocusedNode.States) and - (Shift = []) and (vsHasChildren in FFocusedNode.States) then - ToggleNode(FFocusedNode) - else - begin - if FFocusedNode = nil then - FocusedNode := GetFirstVisible(nil, True) - else - begin - Node := GetFirstVisibleChild(FFocusedNode); - if Assigned(Node) then - begin - if PerformMultiSelect and (CompareNodePositions(Node, FRangeAnchor) < 0) then - RemoveFromSelection(FFocusedNode); - FocusedNode := Node; - end - else begin - // If already a leaf node is selected, then scroll to the right as there is nothing else we could do. #691 - SetOffsetX(FOffsetX - RTLFactor * FHeader.Columns.GetScrollWidth); - end;//else - end; - end; - end; - end; - VK_BACK: - if tsIncrementalSearching in FStates then - DoStateChange([tsIncrementalSearchPending]) - else - if Assigned(FFocusedNode) and (FFocusedNode.Parent <> FRoot) then - FocusedNode := FocusedNode.Parent; - VK_TAB: - if (toExtendedFocus in FOptions.FSelectionOptions) and FHeader.UseColumns then - begin - // In order to avoid duplicating source code just to change the direction - // we use function variables. - if ssShift in Shift then - begin - GetStartColumn := FHeader.FColumns.GetLastVisibleColumn; - GetNextColumn := FHeader.FColumns.GetPreviousVisibleColumn; - GetNextNode := GetPreviousVisible; - end - else - begin - GetStartColumn := FHeader.FColumns.GetFirstVisibleColumn; - GetNextColumn := FHeader.FColumns.GetNextVisibleColumn; - GetNextNode := GetNextVisible; - end; - - // Advance to next/previous visible column/node. - Node := FFocusedNode; - NewColumn := GetNextColumn(FFocusedColumn, True); - repeat - // Find a column for the current node which can be focused. - while (NewColumn > NoColumn) and not DoFocusChanging(FFocusedNode, Node, FFocusedColumn, NewColumn) - //Fix: for Tab Key to properly skip the empty auto span column - or isEmptyAutoSpanColumn(NewColumn, Node) do - NewColumn := GetNextColumn(NewColumn, True); - - if NewColumn > NoColumn then - begin - // Set new node and column in one go. - SetFocusedNodeAndColumn(Node, NewColumn); - Break; - end; - - // No next column was accepted for the current node. So advance to next node and try again. - Node := GetNextNode(Node); - NewColumn := GetStartColumn; - - // fix: From last column, the Tab key should always go to next row irrespective of auto span - // Similarly the Shift-Tab key should go to previos row from first column - if (Node <> nil) and (NewColumn > NoColumn) then - SetFocusedNodeAndColumn(Node, NewColumn); - - until Node = nil; - end; - end; - - // Clear old selection if required but take care to select the new focused node if it was not selected before. - ForceSelection := False; - if ClearPending and ((LastFocused <> FFocusedNode) or (FSelectionCount <> 1)) then - begin - ClearSelection(not Assigned(FFocusedNode)); - ForceSelection := True; - end; - - // Determine new selection anchor. - if Shift = [] then - begin - FRangeAnchor := FFocusedNode; - FLastSelectionLevel := GetNodeLevelForSelectConstraint(FFocusedNode); - end; - - if Assigned(FFocusedNode) then - begin - // Finally change the selection for a specific range of nodes. - if DoRangeSelect then - ToggleSelection(LastFocused, FFocusedNode) - // Make sure the new focused node is also selected. - else if (LastFocused <> FFocusedNode) then begin - if ForceSelection then - AddToSelection(FFocusedNode, False) - else - ToggleSelection(LastFocused, FFocusedNode); // See issue #926 - end; - end; - - // If a repaint is needed then paint the entire tree because of the ClearSelection call, - if NeedInvalidate then - Invalidate; - end - else - begin - // Second chance for keys not directly concerned with selection changes. - - // For +, -, /, * keys on the main keyboard (not numpad) there is no virtual key code defined. - // We have to do special processing to get them working too. - GetKeyboardState(KeyState); - // Avoid conversion to control characters. We have captured the control key state already in Shift. - KeyState[VK_CONTROL] := 0; - if ToASCII(Message.CharCode, (Message.KeyData shr 16) and 7, KeyState, PChar(@Buffer), 0) > 0 then - begin - case Buffer[0] of - '*': - CharCode := VK_MULTIPLY; - '+': - CharCode := VK_ADD; - '/': - CharCode := VK_DIVIDE; - '-': - CharCode := VK_SUBTRACT; - end; - end; - - // According to https://web.archive.org/web/20041129085958/http://www.it-faq.pl/mskb/99/337.HTM - // there is a problem with ToASCII when used in conjunction with dead chars. - // The article recommends to call ToASCII twice to restore a deleted flag in the key message - // structure under certain circumstances. It turned out it is best to always call ToASCII twice. - ToASCII(Message.CharCode, (Message.KeyData shr 16) and 7, KeyState, PChar(@Buffer), 0); - - case CharCode of - VK_F2: - if (Shift = []) and Assigned(FFocusedNode) and CanEdit(FFocusedNode, FFocusedColumn) then - begin - FEditColumn := FFocusedColumn; - DoEdit; - end; - VK_ADD: - if not (tsIncrementalSearching in FStates) then - begin - if ssCtrl in Shift then begin// When changing this code review issue #781 - if ((toReverseFullExpandHotKey in TreeOptions.MiscOptions) and (Shift = [ssCtrl])) xor (Shift = [ssCtrl, ssShift]) then - FullExpand - else if Shift = [ssCtrl] then - FHeader.AutoFitColumns - end - else if Shift = [] then begin - if Assigned(FFocusedNode) and not (vsExpanded in FFocusedNode.States) then - ToggleNode(FFocusedNode); - end// if Shift = [] - else - DoStateChange([tsIncrementalSearchPending]); - end;//if not (tsIncrementalSearching in FStates) - VK_SUBTRACT: - if not (tsIncrementalSearching in FStates) then - begin - if ssCtrl in Shift then - if (toReverseFullExpandHotKey in TreeOptions.MiscOptions) xor (ssShift in Shift) then - FullCollapse - else - FHeader.RestoreColumns - else - if Assigned(FFocusedNode) and (vsExpanded in FFocusedNode.States) then - ToggleNode(FFocusedNode); - end - else - DoStateChange([tsIncrementalSearchPending]); - VK_MULTIPLY: - if not (tsIncrementalSearching in FStates) then - begin - if Assigned(FFocusedNode) then - FullExpand(FFocusedNode); - end - else - DoStateChange([tsIncrementalSearchPending]); - VK_DIVIDE: - if not (tsIncrementalSearching in FStates) then - begin - if Assigned(FFocusedNode) then - FullCollapse(FFocusedNode); - end - else - DoStateChange([tsIncrementalSearchPending]); - VK_ESCAPE: // cancel actions currently in progress - begin - if IsMouseSelecting then - begin - DoStateChange([], [tsDrawSelecting, tsDrawSelPending]); - Invalidate; - end - else - if IsEditing then - CancelEditNode; - end; - VK_SPACE: - if (toCheckSupport in FOptions.FMiscOptions) and Assigned(FFocusedNode) and - (FFocusedNode.CheckType <> ctNone) then - begin - NewCheckState := DetermineNextCheckState(FFocusedNode.CheckType, GetCheckState(FFocusedNode)); - if DoChecking(FFocusedNode, NewCheckState) then - begin - if SelectedCount > 1 then - SetCheckStateForAll(NewCheckState, True) - else - DoCheckClick(FFocusedNode, NewCheckState); - end; - end - else - DoStateChange([tsIncrementalSearchPending]); - VK_F1: - if Assigned(FOnGetHelpContext) then - begin - Context := 0; - if Assigned(FFocusedNode) then - begin - Node := FFocusedNode; - // Traverse the tree structure up to the root. - repeat - FOnGetHelpContext(Self, Node, IfThen(FFocusedColumn > NoColumn, FFocusedColumn, 0), Context); - Node := Node.Parent; - until (Node = FRoot) or (Context <> 0); - end; - - // If no help context could be found try the tree's one or its parent's contexts. - ParentControl := Self; - while Assigned(ParentControl) and (Context = 0) do - begin - Context := ParentControl.HelpContext; - ParentControl := ParentControl.Parent; - end; - if Context <> 0 then - Application.HelpContext(Context); - end; - VK_APPS: - if Assigned(FFocusedNode) then - begin - R := GetDisplayRect(FFocusedNode, FFocusedColumn, True); - Offset := DoGetNodeWidth(FFocusedNode, FFocusedColumn); - if FFocusedColumn >= 0 then - begin - if Offset > FHeader.Columns[FFocusedColumn].Width then - Offset := FHeader.Columns[FFocusedColumn].Width; - end - else - begin - if Offset > ClientWidth then - Offset := ClientWidth; - end; - DoPopupMenu(FFocusedNode, FFocusedColumn, Point(R.Left + Offset div 2, (R.Top + R.Bottom) div 2)); - end - else - DoPopupMenu(nil, FFocusedColumn, Point(-1, -1)); - Ord('a'), Ord('A'): - if ssCtrl in Shift then - SelectAll(True) - else - DoStateChange([tsIncrementalSearchPending]); - else - begin - // Use the key for incremental search. - // Since we are dealing with Unicode all the time there should be a more sophisticated way - // of checking for valid characters for incremental search. - // This is available but would require to include a significant amount of Unicode character - // properties, so we stick with the simple space check. - if ((Shift * [ssCtrl, ssAlt] = []) or ((Shift * [ssCtrl, ssAlt] = [ssCtrl, ssAlt]))) and (CharCode >= 32) then - DoStateChange([tsIncrementalSearchPending]); - end; - end; - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WMKeyUp(var Message: TWMKeyUp); - -begin - inherited; - - case Message.CharCode of - VK_TAB: - EnsureNodeFocused(); // Always select a node if the control gets the focus via TAB key, #237 - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WMKillFocus(var Msg: TWMKillFocus); - -var - Form: TCustomForm; - Control: TWinControl; - Pos: TSmallPoint; - Unknown: IUnknown; - -begin - inherited; - - // Remove hint if shown currently. - if tsHint in Self.FStates then - Application.CancelHint; - - // Stop wheel panning if active. - StopWheelPanning; - - // Don't let any timer continue if the tree is no longer the active control (except change timers). - StopTimer(ExpandTimer); - StopTimer(EditTimer); - StopTimer(HeaderTimer); - StopTimer(ScrollTimer); - StopTimer(SearchTimer); - FSearchBuffer := ''; - FLastSearchNode := nil; - - DoStateChange([], [tsScrollPending, tsScrolling, tsEditPending, tsLeftButtonDown, tsRightButtonDown, - tsMiddleButtonDown, tsOLEDragPending, tsVCLDragPending, tsIncrementalSearching, tsNodeHeightTrackPending, - tsNodeHeightTracking]); - - if (FSelectionCount > 0) or not (toGhostedIfUnfocused in FOptions.FPaintOptions) then - Invalidate - else - if Assigned(FFocusedNode) then - InvalidateNode(FFocusedNode); - - // Workaround for wrapped non-VCL controls (like TWebBrowser), which do not use VCL mechanisms and - // leave the ActiveControl property in the wrong state, which causes trouble when the control is refocused. - Form := GetParentForm(Self); - if Assigned(Form) and (Form.ActiveControl = Self) then - begin - Cardinal(Pos) := GetMessagePos; - Control := FindVCLWindow(SmallPointToPoint(Pos)); - // Every control derived from TOleControl has potentially the focus problem. In order to avoid including - // the OleCtrls unit (which will, among others, include Variants), which would allow to test for the TOleControl - // class, the IOleClientSite interface is used for the test, which is supported by TOleControl and a good indicator. - if Assigned(Control) and Control.GetInterface(IOleClientSite, Unknown) then - Form.ActiveControl := nil; - - // For other classes the active control should not be modified. Otherwise you need two clicks to select it. - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WMLButtonDblClk(var Message: TWMLButtonDblClk); - -var - HitInfo: THitInfo; - -begin - DoStateChange([tsLeftDblClick]); - try - // get information about the hit, before calling inherited, is this may change the scroll postion and so the node under the mouse would chnage and would no longer be the one the user actually clicked - GetHitTestInfoAt(Message.XPos, Message.YPos, True, HitInfo); - HandleMouseDblClick(Message, HitInfo); - // Call inherited after doing our standard handling, as the event handler may close the form or re-fill the control, so our clicked node would be no longer valid. - // Our standard handling does not do that. - inherited; - // #909 - // if we show a modal form in the HandleMouseDblClick(), the mouse capture wont be released - if csCaptureMouse in ControlStyle then MouseCapture := False; - finally - DoStateChange([], [tsLeftDblClick]); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WMLButtonDown(var Message: TWMLButtonDown); - -var - HitInfo: THitInfo; - -begin - DoStateChange([tsLeftButtonDown]); - inherited; - - // get information about the hit - GetHitTestInfoAt(Message.XPos, Message.YPos, True, HitInfo); - HandleMouseDown(Message, HitInfo); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WMLButtonUp(var Message: TWMLButtonUp); - -var - HitInfo: THitInfo; - -begin - DoStateChange([], [tsLeftButtonDown, tsNodeHeightTracking, tsNodeHeightTrackPending]); - - // get information about the hit - GetHitTestInfoAt(Message.XPos, Message.YPos, True, HitInfo); - HandleMouseUp(Message, HitInfo); - - inherited; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WMMButtonDblClk(var Message: TWMMButtonDblClk); - -var - HitInfo: THitInfo; - -begin - DoStateChange([tsMiddleDblClick]); - inherited; - - // get information about the hit - if toMiddleClickSelect in FOptions.FSelectionOptions then - begin - GetHitTestInfoAt(Message.XPos, Message.YPos, True, HitInfo); - HandleMouseDblClick(Message, HitInfo); - end; - DoStateChange([], [tsMiddleDblClick]); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WMMButtonDown(var Message: TWMMButtonDown); - -var - HitInfo: THitInfo; - -begin - DoStateChange([tsMiddleButtonDown]); - - if FHeader.FStates = [] then - begin - inherited; - - // Start wheel panning or scrolling if not already active, allowed and scrolling is useful at all. - if (toWheelPanning in FOptions.FMiscOptions) and ([tsWheelScrolling, tsWheelPanning] * FStates = []) and - ((Integer(FRangeX) > ClientWidth) or (Integer(FRangeY) > ClientHeight)) then - begin - FLastClickPos := SmallPointToPoint(Message.Pos); - StartWheelPanning(FLastClickPos); - end - else - begin - StopWheelPanning; - - // Get information about the hit. - if toMiddleClickSelect in FOptions.FSelectionOptions then - begin - GetHitTestInfoAt(Message.XPos, Message.YPos, True, HitInfo); - HandleMouseDown(Message, HitInfo); - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WMMButtonUp(var Message: TWMMButtonUp); - -var - HitInfo: THitInfo; - -begin - DoStateChange([], [tsMiddleButtonDown]); - - // If wheel panning/scrolling is active and the mouse has not yet been moved then the user starts wheel auto scrolling. - // Indicate this by removing the panning flag. Otherwise (the mouse has moved meanwhile) stop panning. - if [tsWheelPanning, tsWheelScrolling] * FStates <> [] then - begin - if tsWheelScrolling in FStates then - DoStateChange([], [tsWheelPanning]) - else - StopWheelPanning; - end - else - if FHeader.FStates = [] then - begin - inherited; - - // get information about the hit - if toMiddleClickSelect in FOptions.FSelectionOptions then - begin - GetHitTestInfoAt(Message.XPos, Message.YPos, True, HitInfo); - HandleMouseUp(Message, HitInfo); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WMNCCalcSize(var Message: TWMNCCalcSize); - -begin - inherited; - - with FHeader do - if hoVisible in FHeader.FOptions then - with Message.CalcSize_Params^ do - Inc(rgrc[0].Top, FHeight); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WMNCDestroy(var Message: TWMNCDestroy); - -// Used to release a reference of the drag manager. This is the only reliable way we get notified about -// window destruction, because of the automatic release of a window if its parent window is freed. - -begin - InterruptValidation; - - StopTimer(ChangeTimer); - StopTimer(StructureChangeTimer); - - if not (csDesigning in ComponentState) and (toAcceptOLEDrop in FOptions.FMiscOptions) then - RevokeDragDrop(Handle); - - // Clean up other stuff. - DeleteObject(FDottedBrush); - FDottedBrush := 0; - inherited; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WMNCHitTest(var Message: TWMNCHitTest); - -begin - inherited; - if (hoVisible in FHeader.FOptions) and - FHeader.InHeader(ScreenToClient(SmallPointToPoint(Message.Pos))) then - Message.Result := HTBORDER; -end; - -//---------------------------------------------------------------------------------------------------------------------- - - -procedure TBaseVirtualTree.WMNCPaint(var Message: TWMNCPaint); - -var - DC: HDC; - R: TRect; - Flags: DWORD; - ExStyle: Integer; - TempRgn: HRGN; - BorderWidth, - BorderHeight: Integer; - -begin - if tsUseThemes in FStates then - begin - // If theming is enabled and the client edge border is set for the window then prevent the default window proc - // from painting the old border to avoid flickering. - ExStyle := GetWindowLong(Handle, GWL_EXSTYLE); - if (ExStyle and WS_EX_CLIENTEDGE) <> 0 then - begin - GetWindowRect(Handle, R); - // Determine width of the client edge. - BorderWidth := GetSystemMetrics(SM_CXEDGE); - BorderHeight := GetSystemMetrics(SM_CYEDGE); - InflateRect(R, -BorderWidth, -BorderHeight); - TempRgn := CreateRectRgnIndirect(R); - // Exclude the border from the message region if there is one. Otherwise just use the inflated - // window area region. - if Message.Rgn <> 1 then - CombineRgn(TempRgn, Message.Rgn, TempRgn, RGN_AND); - DefWindowProc(Handle, Message.Msg, WPARAM(TempRgn), 0); - DeleteObject(TempRgn); - end - else - DefaultHandler(Message); - end - else - DefaultHandler(Message); - - Flags := DCX_CACHE or DCX_CLIPSIBLINGS or DCX_WINDOW or DCX_VALIDATE; - - if (Message.Rgn = 1) then - DC := GetDCEx(Handle, 0, Flags) - else - DC := GetDCEx(Handle, Message.Rgn, Flags or DCX_INTERSECTRGN); - - if DC <> 0 then - try - OriginalWMNCPaint(DC); - finally - ReleaseDC(Handle, DC); - end; - if (((tsUseThemes in FStates) and not VclStyleEnabled) or (VclStyleEnabled and (seBorder in StyleElements))) then - StyleServices.PaintBorder(Self, False) - else - if (VclStyleEnabled and not (seBorder in StyleElements)) then - TStyleManager.SystemStyle.PaintBorder(Self, False) -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WMPaint(var Message: TWMPaint); -var - DC: HDC; -begin - if tsVCLDragging in FStates then - ImageList_DragShowNolock(False); - if csPaintCopy in ControlState then - FUpdateRect := ClientRect - else - GetUpdateRect(Handle, FUpdateRect, True); - - inherited; - - if tsVCLDragging in FStates then - ImageList_DragShowNolock(True); - - if hoVisible in FHeader.FOptions then - begin - DC := GetDCEx(Handle, 0, DCX_CACHE or DCX_CLIPSIBLINGS or DCX_WINDOW or DCX_VALIDATE); - if DC <> 0 then - try - FHeader.FColumns.PaintHeader(DC, FHeaderRect, -FEffectiveOffsetX); - finally - ReleaseDC(Handle, DC); - end; - end;//if header visible -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WMPaste(var Message: TWMPaste); - -begin - PasteFromClipboard; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WMPrint(var Message: TWMPrint); - -// This message is sent to request that the tree draws itself to a given device context. This includes not only -// the client area but also the non-client area (header!). - -begin - // Draw only if the window is visible or visibility is not required. - if ((Message.Flags and PRF_CHECKVISIBLE) = 0) or IsWindowVisible(Handle) then - Header.Columns.PaintHeader(Message.DC, FHeaderRect, -FEffectiveOffsetX); - - inherited; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WMPrintClient(var Message: TWMPrintClient); - -var - Window: TRect; - Target: TPoint; - Canvas: TCanvas; - -begin - // Draw only if the window is visible or visibility is not required. - if ((Message.Flags and PRF_CHECKVISIBLE) = 0) or IsWindowVisible(Handle) then - begin - // Determine area of the entire tree to be displayed in the control. - Window := ClientRect; - Target := Window.TopLeft; - - // The Window rectangle is given in client coordinates. We have to convert it into - // a sliding window of the tree image. - OffsetRect(Window, FEffectiveOffsetX, -FOffsetY); - - Canvas := TCanvas.Create; - try - Canvas.Handle := Message.DC; - PaintTree(Canvas, Window, Target, [poBackground, poDrawFocusRect, poDrawDropMark, poDrawSelection, poGridLines]); - finally - Canvas.Handle := 0; - Canvas.Free; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WMRButtonDblClk(var Message: TWMRButtonDblClk); - -var - HitInfo: THitInfo; - -begin - DoStateChange([tsRightDblClick]); - inherited; - - // get information about the hit - if toMiddleClickSelect in FOptions.FSelectionOptions then - begin - GetHitTestInfoAt(Message.XPos, Message.YPos, True, HitInfo); - HandleMouseDblClick(Message, HitInfo); - end; - DoStateChange([], [tsRightDblClick]); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WMRButtonDown(var Message: TWMRButtonDown); - -var - HitInfo: THitInfo; - RemoveSynchMode: Boolean; // Needed to restore tsSynchMode correctly - -begin - DoStateChange([tsRightButtonDown]); - - if FHeader.FStates = [] then - begin - inherited; - - // get information about the hit - if toRightClickSelect in FOptions.FSelectionOptions then - begin - GetHitTestInfoAt(Message.XPos, Message.YPos, True, HitInfo); - // Go temporarily into sync mode to avoid a delayed change event for the node when selecting. #679 - RemoveSynchMode := not (tsSynchMode in FStates); - Include(FStates, tsSynchMode); - HandleMouseDown(Message, HitInfo); - if RemoveSynchMode then - Exclude(FStates, tsSynchMode); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WMRButtonUp(var Message: TWMRButtonUp); - -// handle right click selection and node specific popup menu - -var - HitInfo: THitInfo; - -begin - DoStateChange([], [tsPopupMenuShown, tsRightButtonDown]); - - if FHeader.FStates = [] then - begin - Application.CancelHint; - - if IsMouseSelecting and Assigned(PopupMenu) then - begin - // Reset selection state already here, before the inherited handler opens the default menu. - DoStateChange([], [tsDrawSelecting, tsDrawSelPending]); - Invalidate; - end; - - inherited; - - // get information about the hit - GetHitTestInfoAt(Message.XPos, Message.YPos, True, HitInfo); - - if toRightClickSelect in FOptions.FSelectionOptions then - HandleMouseUp(Message, HitInfo); - - if not Assigned(PopupMenu) then - DoPopupMenu(HitInfo.HitNode, HitInfo.HitColumn, Point(Message.XPos, Message.YPos)); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WMSetCursor(var Message: TWMSetCursor); - -// Sets the hot node mouse cursor for the tree. Cursor changes for the header are handled in Header.HandleMessage. - -var - NewCursor: TCursor; - HitInfo: THitInfo; - P: TPoint; - Node: PVirtualNode; - -begin - with Message do - begin - // Feature: design-time header #415 - // Allow header to handle cursor and return control's default if it did nothing - if (CursorWnd = Handle) and - ([tsWheelPanning, tsWheelScrolling] * FStates = []) then - begin - if not FHeader.HandleMessage(TMessage(Message)) then - begin - // Apply own cursors only if there is no global cursor set. - if Screen.Cursor = crDefault then - begin - // node resizing and hot tracking - for run-time only - if not (csDesigning in ComponentState) then - begin - NewCursor := crDefault; - if (toNodeHeightResize in FOptions.FMiscOptions) then - begin - GetCursorPos(P); - P := ScreenToClient(P); - GetHitTestInfoAt(P.X, P.Y, True, HitInfo); - if (hiOnItem in HitInfo.HitPositions) and - ([hiUpperSplitter, hiLowerSplitter] * HitInfo.HitPositions <> []) then - begin - if hiUpperSplitter in HitInfo.HitPositions then - Node := GetPreviousVisible(HitInfo.HitNode, True) - else - Node := HitInfo.HitNode; - - if CanSplitterResizeNode(P, Node, HitInfo.HitColumn) then - NewCursor := crVertSplit; - end; - end; - - if (NewCursor = crDefault) then - if (toHotTrack in FOptions.PaintOptions) and Assigned(FCurrentHotNode) and (FHotCursor <> crDefault) then - NewCursor := FHotCursor - else - NewCursor := Cursor; - - DoGetCursor(NewCursor); - end - else - NewCursor := Cursor; - Winapi.Windows.SetCursor(Screen.Cursors[NewCursor]); - Message.Result := 1; - end - else - inherited; - end; - end - else - inherited; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WMSetFocus(var Msg: TWMSetFocus); - -begin - inherited; - if (FSelectionCount > 0) or not (toGhostedIfUnfocused in FOptions.FPaintOptions) then - Invalidate; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WMSize(var Message: TWMSize); - -begin - inherited; - - // Need to update scroll bars here. This will cause a recursion because of the change of the client area - // when changing a scrollbar. Usually this is no problem since with the second level recursion no change of the - // window size happens (the same values for the scrollbars are set, which shouldn't cause a window size change). - // Appearently, this applies not to all systems, however. - if HandleAllocated and ([tsSizing, tsWindowCreating] * FStates = []) and (ClientHeight > 0) then - try - DoStateChange([tsSizing]); - // This call will invalidate the entire non-client area which needs recalculation on resize. - FHeader.RescaleHeader; - FHeader.UpdateSpringColumns; - UpdateScrollBars(True); - - if (tsEditing in FStates) and not FHeader.UseColumns then - UpdateEditBounds; - finally - DoStateChange([], [tsSizing]); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WMThemeChanged(var Message: TMessage); - -begin - inherited; - - if StyleServices.Enabled and (toThemeAware in TreeOptions.PaintOptions) then - DoStateChange([tsUseThemes]) - else - DoStateChange([], [tsUseThemes]); - - // Updating the visuals here will not work correctly. Therefore we postpone - // the update by using a timer. - if not FChangingTheme then - SetTimer(Handle, ThemeChangedTimer, ThemeChangedTimerDelay, nil); - FChangingTheme := False; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WMTimer(var Message: TWMTimer); - -// centralized timer handling happens here - -begin - with Message do - begin - case TimerID of - ExpandTimer: - DoDragExpand; - EditTimer: - DoEdit; - ScrollTimer: - begin - if tsScrollPending in FStates then - begin - Application.CancelHint; - // Scroll delay has elapsed, set to normal scroll interval now. - SetTimer(Handle, ScrollTimer, FAutoScrollInterval, nil); - DoStateChange([tsScrolling], [tsScrollPending]); - end; - DoTimerScroll; - end; - ChangeTimer: - if tsChangePending in FStates then // see issue #602 - DoChange(FLastChangedNode); - StructureChangeTimer: - DoStructureChange(FLastStructureChangeNode, FLastStructureChangeReason); - SearchTimer: - begin - // When this event triggers then the user did not pressed any key for the specified timeout period. - // Hence incremental searching is stopped. - DoStateChange([], [tsIncrementalSearching]); - StopTimer(SearchTimer); - FSearchBuffer := ''; - FLastSearchNode := nil; - end; - ThemeChangedTimer: - begin - StopTimer(ThemeChangedTimer); - RecreateWnd; - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WMVScroll(var Message: TWMVScroll); - - //--------------- local functions ------------------------------------------- - - function GetRealScrollPosition: Integer; - - var - SI: TScrollInfo; - Code: Integer; - - begin - SI.cbSize := SizeOf(TScrollInfo); - SI.fMask := SIF_TRACKPOS; - Code := SB_VERT; - GetScrollInfo(Handle, Code, SI); - Result := SI.nTrackPos; - end; - - //--------------- end local functions --------------------------------------- - -begin - case Message.ScrollCode of - SB_BOTTOM: - SetOffsetY(-Integer(FRoot.TotalHeight)); - SB_ENDSCROLL: - begin - DoStateChange([], [tsThumbTracking]); - // Avoiding to adjust the horizontal scroll position while tracking makes scrolling much smoother - // but we need to adjust the final position here then. - UpdateScrollBars(True); - // Really weird invalidation needed here (and I do it only because it happens so rarely), because - // when showing the horizontal scrollbar while scrolling down using the down arrow button, - // the button will be repainted on mouse up (at the wrong place in the far right lower corner)... - RedrawWindow(Handle, nil, 0, RDW_FRAME or RDW_INVALIDATE or RDW_NOERASE or RDW_NOCHILDREN); - end; - SB_LINEUP: - SetOffsetY(FOffsetY + FScrollBarOptions.FIncrementY); - SB_LINEDOWN: - SetOffsetY(FOffsetY - FScrollBarOptions.FIncrementY); - SB_PAGEUP: - SetOffsetY(FOffsetY + ClientHeight); - SB_PAGEDOWN: - SetOffsetY(FOffsetY - ClientHeight); - - SB_THUMBPOSITION, - SB_THUMBTRACK: - begin - DoStateChange([tsThumbTracking]); - SetOffsetY(-GetRealScrollPosition); - end; - SB_TOP: - SetOffsetY(0); - end; - Message.Result := 0; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.AddToSelection(Node: PVirtualNode; NotifySynced: Boolean); - -var - Changed: Boolean; - RemoveSyncAfterChange: Boolean; -begin - if not FSelectionLocked then - begin - Assert(Assigned(Node), 'Node must not be nil!'); - Changed := InternalAddToSelection(Node, False); - if Changed then - begin - UpdateNextNodeToSelect(Node); - if (SelectedCount = 1) then - FocusedNode := Node; // if only one node is selected, make sure the focused node changes with the selected node - InvalidateNode(Node); - RemoveSyncAfterChange := NotifySynced and not (tsSynchMode in fStates); - if RemoveSyncAfterChange then - Include(FStates, tsSynchMode); - try - Change(Node); - finally - if RemoveSyncAfterChange then - Exclude(FStates, tsSynchMode); - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.AddToSelection(const NewItems: TNodeArray; NewLength: Integer; ForceInsert: Boolean = False); - -// Adds the given items all at once into the current selection array. NewLength is the amount of -// nodes to add (necessary to allow NewItems to be larger than the actual used entries). -// ForceInsert is True if nodes must be inserted without consideration of level select constraint or -// already set selected flags (e.g. when loading from stream). -// Note: In the case ForceInsert is True the caller is responsible for making sure the new nodes aren't already in the -// selection array! - -var - Changed: Boolean; - -begin - Changed := InternalAddToSelection(NewItems, NewLength, ForceInsert); - if Changed then - begin - if NewLength = 1 then - begin - InvalidateNode(NewItems[0]); - Change(NewItems[0]); - end - else - begin - Invalidate; - Change(nil); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.AdjustPaintCellRect(var PaintInfo: TVTPaintInfo; var NextNonEmpty: TColumnIndex); - -// Used in descendants to modify the paint rectangle of the current column while painting a certain node. - -begin - // Since cells are always drawn from left to right the next column index is independent of the - // bidi mode, but not the column borders, which might change depending on the cell's content. - NextNonEmpty := FHeader.FColumns.GetNextVisibleColumn(PaintInfo.Column); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.AdjustPanningCursor(X, Y: Integer); - -// Triggered by a mouse move when wheel panning/scrolling is active. -// Loads the proper cursor which indicates into which direction scrolling is done. - -var - Name: string; - NewCursor: HCURSOR; - ScrollHorizontal, - ScrollVertical: Boolean; - -begin - ScrollHorizontal := Integer(FRangeX) > ClientWidth; - ScrollVertical := Integer(FRangeY) > ClientHeight; - - if (Abs(X - FLastClickPos.X) < 8) and (Abs(Y - FLastClickPos.Y) < 8) then - begin - // Mouse is in the neutral zone. - if ScrollHorizontal then - begin - if ScrollVertical then - Name := 'VT_MOVEALL' - else - Name := 'VT_MOVEEW'; - end - else - Name := 'VT_MOVENS'; - end - else - begin - // One of 8 directions applies: north, north-east, east, south-east, south, south-west, west and north-west. - // Check also if scrolling in the particular direction is possible. - if ScrollVertical and ScrollHorizontal then - begin - // All directions allowed. - if X - FLastClickPos.X < -8 then - begin - // Left hand side. - if Y - FLastClickPos.Y < -8 then - Name := 'VT_MOVENW' - else - if Y - FLastClickPos.Y > 8 then - Name := 'VT_MOVESW' - else - Name := 'VT_MOVEW'; - end - else - if X - FLastClickPos.X > 8 then - begin - // Right hand side. - if Y - FLastClickPos.Y < -8 then - Name := 'VT_MOVENE' - else - if Y - FLastClickPos.Y > 8 then - Name := 'VT_MOVESE' - else - Name := 'VT_MOVEE'; - end - else - begin - // Up or down. - if Y < FLastClickPos.Y then - Name := 'VT_MOVEN' - else - Name := 'VT_MOVES'; - end; - end - else - if ScrollHorizontal then - begin - // Only horizontal movement allowed. - if X < FLastClickPos.X then - Name := 'VT_MOVEW' - else - Name := 'VT_MOVEE'; - end - else - begin - // Only vertical movement allowed. - if Y < FLastClickPos.Y then - Name := 'VT_MOVEN' - else - Name := 'VT_MOVES'; - end; - end; - - // Now load the cursor and apply it. - NewCursor := LoadCursor(HInstance, PChar(Name)); - if FPanningCursor <> NewCursor then - begin - DeleteObject(FPanningCursor); - FPanningCursor := NewCursor; - Winapi.Windows.SetCursor(FPanningCursor); - end - else - DeleteObject(NewCursor); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.AdviseChangeEvent(StructureChange: Boolean; Node: PVirtualNode; Reason: TChangeReason); - -// Used to register a delayed change event. If StructureChange is False then we have a selection change event (without -// a specific reason) otherwise it is a structure change. - -begin - if StructureChange then - begin - if tsStructureChangePending in FStates then - StopTimer(StructureChangeTimer) - else - DoStateChange([tsStructureChangePending]); - - FLastStructureChangeNode := Node; - if FLastStructureChangeReason = crIgnore then - FLastStructureChangeReason := Reason - else - if Reason <> crIgnore then - FLastStructureChangeReason := crAccumulated; - end - else - begin - if tsChangePending in FStates then - StopTimer(ChangeTimer) - else - DoStateChange([tsChangePending]); - - FLastChangedNode := Node; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.AllocateInternalDataArea(Size: Cardinal): Cardinal; - -// Simple registration method to be called by each descendant to claim their internal data area. -// Result is the offset from the begin of the node to the internal data area of the calling tree class. - -begin - Assert((FRoot = nil) or (FRoot.ChildCount = 0), 'Internal data allocation must be done before any node is created.'); - Result := TreeNodeSize + FTotalInternalDataSize; - Inc(FTotalInternalDataSize, (Size + (SizeOf(Pointer) - 1)) and not (SizeOf(Pointer) - 1)); - InitRootNode(Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.Animate(Steps, Duration: Cardinal; Callback: TVTAnimationCallback; Data: Pointer); - -// This method does the calculation part of an animation as used for node toggling and hint animations. -// Steps is the maximum amount of animation steps to do and Duration determines the milliseconds the animation -// has to run. Callback is a task specific method which is called in the loop for every step and Data is simply -// something to pass on to the callback. -// The callback is called with the current step, the current step size and the Data parameter. Since the step amount -// as well as the step size are possibly adjusted during the animation, it is impossible to determine if the current -// step is the last step, even if the original step amount is known. To solve this problem the callback will be -// called after the loop has finished with a step size of 0 indicating so to execute any post processing. - -var - StepSize, - RemainingTime, - RemainingSteps, - NextTimeStep, - CurrentStep, - StartTime: Cardinal; - CurrentTime: Int64; - -begin - if not (tsInAnimation in FStates) and (Duration > 0) then - begin - DoStateChange([tsInAnimation]); - try - RemainingTime := Duration; - RemainingSteps := Steps; - - // Determine the initial step size which is either 1 if the needed steps are less than the number of - // steps possible given by the duration or > 1 otherwise. - StepSize := Round(Max(1, RemainingSteps / Duration)); - RemainingSteps := RemainingSteps div StepSize; - CurrentStep := 0; - - while (RemainingSteps > 0) and (RemainingTime > 0) and not Application.Terminated do - begin - StartTime := timeGetTime; - NextTimeStep := StartTime + RemainingTime div RemainingSteps; - if not Callback(CurrentStep, StepSize, Data) then - Break; - - // Keep duration for this step for rest calculation. - CurrentTime := timeGetTime; - // Wait until the calculated time has been reached. - while CurrentTime < NextTimeStep do - CurrentTime := timeGetTime; - - // Subtract the time this step really needed. - if RemainingTime >= CurrentTime - StartTime then - begin - Dec(RemainingTime, CurrentTime - StartTime); - Dec(RemainingSteps); - end - else - begin - RemainingTime := 0; - RemainingSteps := 0; - end; - // If the remaining time per step is less than one time step then we have to decrease the - // step count and increase the step size. - if (RemainingSteps > 0) and ((RemainingTime div RemainingSteps) < 1) then - begin - repeat - Inc(StepSize); - RemainingSteps := RemainingTime div StepSize; - until (RemainingSteps <= 0) or ((RemainingTime div RemainingSteps) >= 1); - end; - CurrentStep := Steps - RemainingSteps; - end; - - if not Application.Terminated then - Callback(0, 0, Data); - finally - DoStateChange([], [tsInAnimation]); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.StartOperation(OperationKind: TVTOperationKind); - -// Called to indicate that a long-running operation has been started. - -begin - Inc(FOperationCount); - if FOperationCount = 1 then - FOperationCanceled := False; - DoStartOperation(OperationKind); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.CalculateSelectionRect(X, Y: Integer): Boolean; - -// Recalculates old and new selection rectangle given that X, Y are new mouse coordinates. -// Returns True if there was a change since the last call. - -var - MaxValue: Integer; - -begin - if tsDrawSelecting in FStates then - FLastSelRect := FNewSelRect; - FNewSelRect.BottomRight := Point(X + FEffectiveOffsetX, Y - FOffsetY); - if FNewSelRect.Right < 0 then - FNewSelRect.Right := 0; - if FNewSelRect.Bottom < 0 then - FNewSelRect.Bottom := 0; - MaxValue := ClientWidth; - if FRangeX > Cardinal(MaxValue) then - MaxValue := FRangeX; - if FNewSelRect.Right > MaxValue then - FNewSelRect.Right := MaxValue; - MaxValue := ClientHeight; - if FRangeY > Cardinal(MaxValue) then - MaxValue := FRangeY; - if FNewSelRect.Bottom > MaxValue then - FNewSelRect.Bottom := MaxValue; - - Result := not CompareMem(@FLastSelRect, @FNewSelRect, SizeOf(FNewSelRect)); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.CanAutoScroll: Boolean; - -// Determines if auto scrolling is currently allowed. - -var - IsDropTarget: Boolean; - IsDrawSelecting: Boolean; - IsWheelPanning: Boolean; - -begin - // Don't scroll the client area if the header is currently doing tracking or dragging. - // Do auto scroll only if there is a draw selection in progress or the tree is the current drop target or - // wheel panning/scrolling is active. - IsDropTarget := Assigned(FDragManager) and DragManager.IsDropTarget; - IsDrawSelecting := [tsDrawSelPending, tsDrawSelecting] * FStates <> []; - IsWheelPanning := [tsWheelPanning, tsWheelScrolling] * FStates <> []; - Result := ((toAutoScroll in FOptions.FAutoOptions) or IsWheelPanning) and - (FHeader.FStates = []) and (IsDrawSelecting or IsDropTarget or (tsVCLDragging in FStates) or IsWheelPanning); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.CanShowDragImage: Boolean; - -// Determines whether a drag image should be shown. - -begin - Result := FDragImageKind <> diNoImage; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.CanSplitterResizeNode(P: TPoint; Node: PVirtualNode; Column: TColumnIndex): Boolean; - -begin - Result := (toNodeHeightResize in FOptions.FMiscOptions) and Assigned(Node) and (Node <> FRoot) and - (Column > NoColumn) and (coFixed in FHeader.FColumns[Column].FOptions); - DoCanSplitterResizeNode(P, Node, Column, Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.Change(Node: PVirtualNode); - -begin - AdviseChangeEvent(False, Node, crIgnore); - - if FUpdateCount = 0 then - begin - if (FChangeDelay > 0) and HandleAllocated and not (tsSynchMode in FStates) then - SetTimer(Handle, ChangeTimer, FChangeDelay, nil) - else - DoChange(Node); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.ChangeScale(M, D: Integer{$if CompilerVersion >= 31}; isDpiChange: Boolean{$ifend}); -{$if CompilerVersion < 27} -const - DefaultScalingFlags = [sfLeft, sfTop, sfWidth, sfHeight, sfFont]; // Was introduced with XE6: http://docwiki.embarcadero.com/Libraries/XE6/en/Vcl.Controls.TControl.DefaultScalingFlags -{$ifend} -var - Flags: TScalingFlags; - Run: PVirtualNode; -begin - if (toAutoChangeScale in FOptions.FAutoOptions) then - begin - if (M <> D) then - begin - // It is important to evaluate the TScalingFlags before calling inherited, becuase they are differetn afterwards! - if csLoading in ComponentState then - Flags := ScalingFlags - else - Flags := DefaultScalingFlags; // Important for #677 - if (sfHeight in Flags) then begin - FHeader.ChangeScale(M, D); - SetDefaultNodeHeight(MulDiv(FDefaultNodeHeight, M, D)); - Indent := MulDiv(Indent, M, D); - FTextMargin := MulDiv(FTextMargin, M, D); - FMargin := MulDiv(FMargin, M, D); - FImagesMargin := MulDiv(FImagesMargin, M, D); - // Scale utility images, #796 - if FCheckImageKind = ckSystemDefault then begin - FreeAndNil(FCheckImages); - if HandleAllocated then - FCheckImages := CreateSystemImageSet(Self); - end; - UpdateHeaderRect(); - // Scale also node heights - BeginUpdate(); - try - Run := GetFirst(); - while Assigned(Run) do - begin - if vsInitialized in Run.States then - SetNodeHeight(Run, MulDiv(Run.NodeHeight, M, D)) - else // prevent initialization of non-initialzed nodes - Run.NodeHeight := MulDiv(Run.NodeHeight, M, D); - Run := GetNextNoInit(Run); - end; // while - finally - EndUpdate(); - end; - end;//if sfHeight - end;// if M<>D - end;//if toAutoChangeScale - inherited ChangeScale(M, D{$if CompilerVersion >= 31}, isDpiChange{$ifend}); - // It is important to do this call after calling inherited, so that the Font has been updated. - AutoScale(M <> D); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.ChangeTreeStatesAsync(EnterStates, LeaveStates: TVirtualTreeStates); -begin - //TODO: If this works reliable, move to TWorkerThread - if (Self.HandleAllocated) then - TThread.Synchronize(nil, procedure - begin - // Prevent invalid combination tsUseCache + tsValidationNeeded (#915) - if not ((tsUseCache in EnterStates) and (tsValidationNeeded in FStates + LeaveStates)) then - DoStateChange(EnterStates, LeaveStates) - end); - -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.CheckParentCheckState(Node: PVirtualNode; NewCheckState: TCheckState): Boolean; - -// Checks all siblings of node to determine which check state Node's parent must get. - -var - CheckCount, - BoxCount: Cardinal; - PartialCheck: Boolean; - Run: PVirtualNode; - -begin - CheckCount := 0; - BoxCount := 0; - PartialCheck := False; - Run := Node.Parent.FirstChild; - while Assigned(Run) do - begin - if Run = Node then - begin - // The given node cannot be checked because it does not yet have its new check state (as this depends - // on the outcome of this method). Instead NewCheckState is used as this contains the new state the node - // will get if this method returns True. - if Run.CheckType in [ctCheckBox, ctTriStateCheckBox] then - begin - Inc(BoxCount); - if NewCheckState.IsChecked then - Inc(CheckCount); - PartialCheck := PartialCheck or (NewCheckState = csMixedNormal); - end; - end - else - if Run.CheckType in [ctCheckBox, ctTriStateCheckBox] then - begin - Inc(BoxCount); - if GetCheckState(Run).IsChecked then - Inc(CheckCount); - PartialCheck := PartialCheck or (GetCheckState(Run) = csMixedNormal); - end; - Run := Run.NextSibling; - end; - - if (CheckCount = 0) and not PartialCheck then - NewCheckState := csUncheckedNormal - else - if CheckCount < BoxCount then - NewCheckState := csMixedNormal - else - NewCheckState := csCheckedNormal; - - Node := Node.Parent; - Result := DoChecking(Node, NewCheckState); - if Result then - begin - DoCheckClick(Node, NewCheckState); - // Recursively adjust parent of parent. - // This is already done in the function DoCheckClick() called in the above line - // We revent unnecessary upward recursion by commenting this code. - // with Node^ do - // begin - // if not (vsInitialized in Parent.States) then - // InitNode(Parent); - // if ([vsChecking, vsDisabled] * Parent.States = []) and (Parent <> FRoot) and - // (Parent.CheckType = ctTriStateCheckBox) then - // Result := CheckParentCheckState(Node, NewCheckState); - // end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.ClearTempCache; - -// make sure the temporary node cache is in a reliable state - -begin - FTempNodeCache := nil; - FTempNodeCount := 0; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.ColumnIsEmpty(Node: PVirtualNode; Column: TColumnIndex): Boolean; - -// Returns True if the given column is to be considered as being empty. This will usually be determined by -// descendants as the base tree implementation has not enough information to decide. - -begin - Result := True; - if Assigned(FOnGetCellIsEmpty) then - FOnGetCellIsEmpty(Self, Node, Column, Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.ComputeRTLOffset(ExcludeScrollBar: Boolean): Integer; - -// Computes the horizontal offset needed when all columns are automatically right aligned (in RTL bidi mode). -// ExcludeScrollBar determines if the left-hand vertical scrollbar is to be included (if visible) or not. - -var - HeaderWidth: Integer; - ScrollBarVisible: Boolean; -begin - ScrollBarVisible := (Integer(FRangeY) > ClientHeight) and (ScrollBarOptions.ScrollBars in [ssVertical, ssBoth]); - if ScrollBarVisible then - Result := GetSystemMetrics(SM_CXVSCROLL) - else - Result := 0; - - // Make everything right aligned. - HeaderWidth := FHeaderRect.Right - FHeaderRect.Left; - if Integer(FRangeX) + Result <= HeaderWidth then - Result := HeaderWidth - Integer(FRangeX); - // Otherwise take only left-hand vertical scrollbar into account. - - if ScrollBarVisible and ExcludeScrollBar then - Dec(Result, GetSystemMetrics(SM_CXVSCROLL)); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.CountLevelDifference(Node1, Node2: PVirtualNode): Integer; - -// This method counts how many indentation levels the given nodes are apart. If both nodes have the same parent then the -// difference is 0 otherwise the result is basically GetNodeLevel(Node2) - GetNodeLevel(Node1), but with sign. -// If the result is negative then Node2 is less intended than Node1. - -var - Level1, Level2: Integer; - -begin - Assert(Assigned(Node1) and Assigned(Node2), 'Both nodes must be Assigned.'); - - Level1 := 0; - while Node1.Parent <> FRoot do - begin - Inc(Level1); - Node1 := Node1.Parent; - end; - - Level2 := 0; - while Node2.Parent <> FRoot do - begin - Inc(Level2); - Node2 := Node2.Parent; - end; - - Result := Level2 - Level1; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.CountVisibleChildren(Node: PVirtualNode): Cardinal; - -// Returns the number of visible child nodes of the given node. - -begin - Result := 0; - - // The node's direct children... - if vsExpanded in Node.States then - begin - // ...and their children. - Node := Node.FirstChild; - while Assigned(Node) do - begin - if vsVisible in Node.States then - Inc(Result, CountVisibleChildren(Node) + Cardinal(IfThen(IsEffectivelyVisible[Node], 1))); - Node := Node.NextSibling; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.CreateParams(var Params: TCreateParams); - -const - ScrollBar: array[TScrollStyle] of Cardinal = (0, WS_HSCROLL, WS_VSCROLL, WS_HSCROLL or WS_VSCROLL); - -begin - inherited CreateParams(Params); - - with Params do - begin - Style := Style or WS_CLIPCHILDREN or WS_CLIPSIBLINGS or ScrollBar[ScrollBarOptions.FScrollBars]; - if toFullRepaintOnResize in FOptions.FMiscOptions then - WindowClass.style := WindowClass.style or CS_HREDRAW or CS_VREDRAW - else - WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW); - if FBorderStyle = bsSingle then - begin - if Ctl3D then - begin - ExStyle := ExStyle or WS_EX_CLIENTEDGE; - Style := Style and not WS_BORDER; - end - else - Style := Style or WS_BORDER; - end - else - Style := Style and not WS_BORDER; - - AddBiDiModeExStyle(ExStyle); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.CreateWnd; - -// Initializes data which depends on a valid window handle. - -begin - DoStateChange([tsWindowCreating]); - inherited; - DoStateChange([], [tsWindowCreating]); - - if not Assigned(FCheckImages) then - FCheckImages := CreateSystemImageSet(Self); - - if ((StyleServices.Enabled ) and (toThemeAware in TreeOptions.PaintOptions) ) then - begin - DoStateChange([tsUseThemes]); - if (toUseExplorerTheme in FOptions.FPaintOptions) and IsWinVistaOrAbove then - begin - DoStateChange([tsUseExplorerTheme]); - SetWindowTheme('explorer'); - end - else - DoStateChange([], [tsUseExplorerTheme]); - end - else - DoStateChange([], [tsUseThemes, tsUseExplorerTheme]); - - // Because of the special recursion and update stopper when creating the window (or resizing it) - // we have to manually trigger the auto size calculation here. - if hsNeedScaling in FHeader.FStates then - FHeader.RescaleHeader; - if hoAutoResize in FHeader.FOptions then - FHeader.FColumns.AdjustAutoSize(InvalidColumn); - - PrepareBitmaps(True, True); - - // Register tree as OLE drop target. - if not (csDesigning in ComponentState) and (toAcceptOLEDrop in FOptions.FMiscOptions) then - if not (csLoading in ComponentState) then // will be done in Loaded after all inherited settings are loaded from the DFMs - RegisterDragDrop(Handle, DragManager as IDropTarget); - - UpdateScrollBars(True); - UpdateHeaderRect; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.FakeReadIdent(Reader: TReader); -begin - Assert(Reader.NextValue = vaIdent); - Reader.ReadIdent; -end; - - -procedure TBaseVirtualTree.DefineProperties(Filer: TFiler); - -// There were heavy changes in some properties during development of VT. This method helps to make migration easier -// by reading old properties manually and put them into the new properties as appropriate. -// Note: these old properties are never written again and silently disappear. -// June 2002: Meanwhile another task is done here too: working around the problem that TCollection is not streamed -// correctly when using Visual Form Inheritance (VFI). - -var - StoreIt: Boolean; - -begin - inherited; - - // The header can prevent writing columns altogether. - if FHeader.CanWriteColumns then - begin - // Check if we inherit from an ancestor form (Visual Form Inheritance). - StoreIt := Filer.Ancestor = nil; - // If there is an ancestor then save columns only if they are different to the base set. - if not StoreIt then - StoreIt := not FHeader.Columns.Equals(TBaseVirtualTree(Filer.Ancestor).FHeader.Columns); - end - else - StoreIt := False; - - Filer.DefineProperty('Columns', FHeader.ReadColumns, FHeader.WriteColumns, StoreIt); - - // #622 made old DFMs incompatible with new VTW - so the program is compiled successfully - // and then suddenly crashes at user site in runtime. - Filer.DefineProperty('CheckImageKind', FakeReadIdent, nil, false); - /// #730 removed property HintAnimation - Filer.DefineProperty('HintAnimation', FakeReadIdent, nil, false); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.DetermineDropMode(const P: TPoint; var HitInfo: THitInfo; var NodeRect: TRect): TDropMode; - -// Determine the DropMode. - -var - ImageHit: Boolean; - LabelHit: Boolean; - ItemHit: Boolean; - -begin - ImageHit := HitInfo.HitPositions * [hiOnNormalIcon, hiOnStateIcon] <> []; - LabelHit := hiOnItemLabel in HitInfo.HitPositions; - ItemHit := ((hiOnItem in HitInfo.HitPositions) and - ((toFullRowDrag in FOptions.FMiscOptions) or (toFullRowSelect in FOptions.FSelectionOptions))); - - // In report mode only direct hits of the node captions/images in the main column are accepted as hits. - if (toReportMode in FOptions.FMiscOptions) and not (ItemHit or ((LabelHit or ImageHit) and - (HitInfo.HitColumn = FHeader.MainColumn))) then - HitInfo.HitNode := nil; - - if Assigned(HitInfo.HitNode) then - begin - if LabelHit or ImageHit or not (toShowDropmark in FOptions.FPaintOptions) then - Result := dmOnNode - else - if ((NodeRect.Top + NodeRect.Bottom) div 2) > P.Y then - Result := dmAbove - else - Result := dmBelow; - end - else - Result := dmNowhere; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DetermineHiddenChildrenFlag(Node: PVirtualNode); - -// Update the hidden children flag of the given node. - -var - Run: PVirtualNode; - -begin - if Node.ChildCount = 0 then - begin - if vsHasChildren in Node.States then - Exclude(Node.States, vsAllChildrenHidden) - else - Include(Node.States, vsAllChildrenHidden); - end - else - begin - // Iterate through all siblings and stop when one visible is found. - Run := Node.FirstChild; - while Assigned(Run) and not IsEffectivelyVisible[Run] do - Run := Run.NextSibling; - if Assigned(Run) then - Exclude(Node.States, vsAllChildrenHidden) - else - Include(Node.States, vsAllChildrenHidden); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DetermineHiddenChildrenFlagAllNodes; - -var - Run: PVirtualNode; - -begin - Run := GetFirstNoInit(False); - while Assigned(Run) do - begin - DetermineHiddenChildrenFlag(Run); - Run := GetNextNoInit(Run); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DetermineHitPositionLTR(var HitInfo: THitInfo; Offset, Right: Integer; - Alignment: TAlignment); - -// This method determines the hit position within a node with left-to-right orientation. - -var - MainColumnHit: Boolean; - lIndent, - TextWidth, - ImageOffset: Integer; - lOffsets: TVTOffsets; -begin - MainColumnHit := HitInfo.HitColumn = FHeader.MainColumn; - GetOffsets(HitInfo.HitNode, lOffsets, ofsRightOfText, HitInfo.HitColumn); - - if (MainColumnHit and (Offset < lOffsets[ofsCheckbox])) then - begin - // Position is to the left of calculated indentation which can only happen for the main column. - // Check whether it corresponds to a button/checkbox. - if (toShowButtons in FOptions.FPaintOptions) and (vsHasChildren in HitInfo.HitNode.States) then - begin - // Position of button is interpreted very generously to avoid forcing the user - // to click exactly into the 9x9 pixels area. The entire node height and one full - // indentation level is accepted as button hit. - if Offset >= lOffsets[ofsCheckbox] - Integer(FIndent) then - Include(HitInfo.HitPositions, hiOnItemButton); - if Offset > lOffsets[ofsToggleButton] then - Include(HitInfo.HitPositions, hiOnItemButtonExact); - end; - // no button hit so position is on indent - if HitInfo.HitPositions = [] then - Include(HitInfo.HitPositions, hiOnItemIndent); - end - else - begin - // The next hit positions can be: - // - on the check box - // - on the state image - // - on the normal image - // - to the left of the text area - // - on the label or - // - to the right of the text area - // (in this order). - - // In report mode no hit other than in the main column is possible. - if MainColumnHit or not (toReportMode in FOptions.FMiscOptions) then - begin - if MainColumnHit and (Offset < lOffsets[ofsStateImage]) then - begin - HitInfo.HitPositions := [hiOnItem]; - if (HitInfo.HitNode.CheckType <> ctNone) then - Include(HitInfo.HitPositions, hiOnItemCheckBox); - end - else - begin - ImageOffset := lOffsets[ofsImage]; - if Offset < ImageOffset then - Include(HitInfo.HitPositions, hiOnStateIcon) - else - begin - ImageOffset := lOffsets[ofsLabel]; - if Offset < ImageOffset then - Include(HitInfo.HitPositions, hiOnNormalIcon) - else - begin - TextWidth := lOffsets[ofsRightOfText] - lOffsets[ofsText]; - // ImageOffset contains now the left border of the node label area. This is used to calculate the - // correct alignment in the column. - - // Check if the text can be aligned at all. This is only possible if there is enough room - // in the remaining text rectangle. - if TextWidth > Right - ImageOffset then - Include(HitInfo.HitPositions, hiOnItemLabel) - else - begin - case Alignment of - taCenter: - begin - lIndent := (ImageOffset + Right - TextWidth) div 2; - if Offset < lIndent then - Include(HitInfo.HitPositions, hiOnItemLeft) - else - if Offset < lIndent + TextWidth then - Include(HitInfo.HitPositions, hiOnItemLabel) - else - Include(HitInfo.HitPositions, hiOnItemRight); - end; - taRightJustify: - begin - lIndent := Right - TextWidth; - if Offset < lIndent then - Include(HitInfo.HitPositions, hiOnItemLeft) - else - Include(HitInfo.HitPositions, hiOnItemLabel); - end; - else // taLeftJustify - if Offset < ImageOffset + TextWidth then - Include(HitInfo.HitPositions, hiOnItemLabel) - else - Include(HitInfo.HitPositions, hiOnItemRight); - end; - end; - end; - end; - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DetermineHitPositionRTL(var HitInfo: THitInfo; Offset, Right: Integer; Alignment: TAlignment); - -// This method determines the hit position within a node with right-to-left orientation. - -var - MainColumnHit: Boolean; - Run: PVirtualNode; - Indent, - TextWidth, - ImageOffset: Integer; - -begin - MainColumnHit := HitInfo.HitColumn = FHeader.MainColumn; - - // If columns are not used or the main column is hit then the tree indentation must be considered too. - if MainColumnHit then - begin - if toFixedIndent in FOptions.FPaintOptions then - Dec(Right, FIndent) - else - begin - Run := HitInfo.HitNode; - while (Run.Parent <> FRoot) do - begin - Dec(Right, FIndent); - Run := Run.Parent; - end; - if toShowRoot in FOptions.FPaintOptions then - Dec(Right, FIndent); - end; - end; - - if Offset >= Right then - begin - // Position is to the right of calculated indentation which can only happen for the main column. - // Check whether it corresponds to a button/checkbox. - if (toShowButtons in FOptions.FPaintOptions) and (vsHasChildren in HitInfo.HitNode.States) then - begin - // Position of button is interpreted very generously to avoid forcing the user - // to click exactly into the 9x9 pixels area. The entire node height and one full - // indentation level is accepted as button hit. - if Offset <= Right + Integer(FIndent) then - Include(HitInfo.HitPositions, hiOnItemButton); - if Offset <= Right + FPlusBM.Width then - Include(HitInfo.HitPositions, hiOnItemButtonExact); - end; - // no button hit so position is on indent - if HitInfo.HitPositions = [] then - Include(HitInfo.HitPositions, hiOnItemIndent); - end - else - begin - // The next hit positions can be: - // - on the check box - // - on the state image - // - on the normal image - // - to the left of the text area - // - on the label or - // - to the right of the text area - // (in this order). - - // In report mode no hit other than in the main column is possible. - if MainColumnHit or not (toReportMode in FOptions.FMiscOptions) then - begin - ImageOffset := Right - FMargin; - - // Check support is only available for the main column. - if MainColumnHit and (toCheckSupport in FOptions.FMiscOptions) and Assigned(FCheckImages) and - (HitInfo.HitNode.CheckType <> ctNone) then - Dec(ImageOffset, FCheckImages.Width + FImagesMargin); - - if MainColumnHit and (Offset > ImageOffset) then - begin - HitInfo.HitPositions := [hiOnItem]; - if (HitInfo.HitNode.CheckType <> ctNone) then - Include(HitInfo.HitPositions, hiOnItemCheckBox); - end - else - begin - Dec(ImageOffset, GetImageSize(HitInfo.HitNode, ikState, HitInfo.HitColumn).cx); - if Offset > ImageOffset then - Include(HitInfo.HitPositions, hiOnStateIcon) - else - begin - Dec(ImageOffset, GetImageSize(HitInfo.HitNode, ikNormal, HitInfo.HitColumn).cx); - if Offset > ImageOffset then - Include(HitInfo.HitPositions, hiOnNormalIcon) - else - begin - // ImageOffset contains now the right border of the node label area. This is used to calculate the - // correct alignment in the column. - TextWidth := DoGetNodeWidth(HitInfo.HitNode, HitInfo.HitColumn); - - // Check if the text can be aligned at all. This is only possible if there is enough room - // in the remaining text rectangle. - if TextWidth > ImageOffset then - Include(HitInfo.HitPositions, hiOnItemLabel) - else - begin - // Consider bidi mode here. In RTL context does left alignment actually mean right alignment - // and vice versa. - ChangeBiDiModeAlignment(Alignment); - - case Alignment of - taCenter: - begin - Indent := (ImageOffset - TextWidth) div 2; - if Offset < Indent then - Include(HitInfo.HitPositions, hiOnItemLeft) - else - if Offset < Indent + TextWidth then - Include(HitInfo.HitPositions, hiOnItemLabel) - else - Include(HitInfo.HitPositions, hiOnItemRight); - end; - taRightJustify: - begin - Indent := ImageOffset - TextWidth; - if Offset < Indent then - Include(HitInfo.HitPositions, hiOnItemLeft) - else - Include(HitInfo.HitPositions, hiOnItemLabel); - end; - else // taLeftJustify - if Offset > TextWidth then - Include(HitInfo.HitPositions, hiOnItemRight) - else - Include(HitInfo.HitPositions, hiOnItemLabel); - end; - end; - end; - end; - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.DetermineLineImageAndSelectLevel(Node: PVirtualNode; var LineImage: TLineImage): Integer; - -// This method is used during paint cycles and initializes an array of line type IDs. These IDs are used to paint -// the tree lines in front of the given node. -// Additionally an initial count of selected parents is determined and returned which is used for specific painting. - -var - X: Integer; - Indent: Integer; - Run: PVirtualNode; - -begin - Result := 0; - if toShowRoot in FOptions.FPaintOptions then - X := 1 - else - X := 0; - Run := Node; - // Determine indentation level of top node. - while Run.Parent <> FRoot do - begin - Inc(X); - Run := Run.Parent; - // Count selected nodes (FRoot is never selected). - if vsSelected in Run.States then - Inc(Result); - end; - - // Set initial size of line index array, this will automatically initialized all entries to ltNone. - SetLength(LineImage, X); - Indent := X - 1; - - // Only use lines if requested. - if (toShowTreeLines in FOptions.FPaintOptions) and - (not (toHideTreeLinesIfThemed in FOptions.FPaintOptions) or not (tsUseThemes in FStates)) then - begin - if toChildrenAbove in FOptions.FPaintOptions then - begin - Dec(X); - if not HasVisiblePreviousSibling(Node) then - begin - if (Node.Parent <> FRoot) or HasVisibleNextSibling(Node) then - LineImage[X] := ltBottomRight - else - LineImage[X] := ltRight; - end - else - if (Node.Parent = FRoot) and (not HasVisibleNextSibling(Node)) then - LineImage[X] := ltTopRight - else - LineImage[X] := ltTopDownRight; - - // Now go up to the root to determine the rest. - Run := Node.Parent; - while Run <> FRoot do - begin - Dec(X); - if HasVisiblePreviousSibling(Run) then - LineImage[X] := ltTopDown - else - LineImage[X] := ltNone; - - Run := Run.Parent; - end; - end - else - begin - // Start over parent traversal if necessary. - Run := Node; - - if Run.Parent <> FRoot then - begin - // The very last image (the one immediately before the item label) is different. - if HasVisibleNextSibling(Run) then - LineImage[X - 1] := ltTopDownRight - else - LineImage[X - 1] := ltTopRight; - Run := Run.Parent; - - // Now go up all parents. - repeat - if Run.Parent = FRoot then - Break; - Dec(X); - if HasVisibleNextSibling(Run) then - LineImage[X - 1] := ltTopDown - else - LineImage[X - 1] := ltNone; - Run := Run.Parent; - until False; - end; - - // Prepare root level. Run points at this stage to a top level node. - if (toShowRoot in FOptions.FPaintOptions) and ((toShowTreeLines in FOptions.FPaintOptions) and - (not (toHideTreeLinesIfThemed in FOptions.FPaintOptions) or not (tsUseThemes in FStates))) then - begin - // Is the top node a root node? - if Run = Node then - begin - // First child gets the bottom-right bitmap if it isn't also the only child. - if IsFirstVisibleChild(FRoot, Run) then - // Is it the only child? - if IsLastVisibleChild(FRoot, Run) then - LineImage[0] := ltRight - else - LineImage[0] := ltBottomRight - else - // real last child - if IsLastVisibleChild(FRoot, Run) then - LineImage[0] := ltTopRight - else - LineImage[0] := ltTopDownRight; - end - else - begin - // No, top node is not a top level node. So we need different painting. - if HasVisibleNextSibling(Run) then - LineImage[0] := ltTopDown - else - LineImage[0] := ltNone; - end; - end; - end; - end; - - if (tsUseExplorerTheme in FStates) and HasChildren[Node] and (Indent >= 0) - and not ((vsAllChildrenHidden in Node.States) and (toAutoHideButtons in TreeOptions.FAutoOptions)) then - LineImage[Indent] := ltNone; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.DetermineNextCheckState(CheckType: TCheckType; CheckState: TCheckState): TCheckState; - -// Determines the next check state in case the user click the check image or pressed the space key. - -begin - case CheckType of - ctTriStateCheckBox, - ctButton, - ctCheckBox: - begin - Result := CheckState.GetToggled(); - end;//ctCheckbox - ctRadioButton: - Result := csCheckedNormal; - else - Result := csMixedNormal; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.DetermineScrollDirections(X, Y: Integer): TScrollDirections; - -// Determines which direction the client area must be scrolled depending on the given position. - -begin - Result:= []; - - if CanAutoScroll then - begin - // Calculation for wheel panning/scrolling is a bit different to normal auto scroll. - if [tsWheelPanning, tsWheelScrolling] * FStates <> [] then - begin - if (X - FLastClickPos.X) < -8 then - Include(Result, sdLeft); - if (X - FLastClickPos.X) > 8 then - Include(Result, sdRight); - - if (Y - FLastClickPos.Y) < -8 then - Include(Result, sdUp); - if (Y - FLastClickPos.Y) > 8 then - Include(Result, sdDown); - end - else - begin - if (X < Integer(FDefaultNodeHeight)) and (FEffectiveOffsetX <> 0) then - Include(Result, sdLeft); - if (ClientWidth + FEffectiveOffsetX < Integer(FRangeX)) and (X > ClientWidth - Integer(FDefaultNodeHeight)) then - Include(Result, sdRight); - - if (Y < Integer(FDefaultNodeHeight)) and (FOffsetY <> 0) then - Include(Result, sdUp); - if (ClientHeight - FOffsetY < Integer(FRangeY)) and (Y > ClientHeight - Integer(FDefaultNodeHeight)) then - Include(Result, sdDown); - - // Since scrolling during dragging is not handled via the timer we do a check here whether the auto - // scroll timeout already has elapsed or not. - if (Result <> []) and - ((Assigned(FDragManager) and DragManager.IsDropTarget) or - (FindDragTarget(Point(X, Y), False) = Self)) then - begin - if FDragScrollStart = 0 then - FDragScrollStart := timeGetTime; - // Reset any scroll direction to avoid scroll in the case the user is dragging and the auto scroll time has not - // yet elapsed. - if ((Int64(timeGetTime) - FDragScrollStart) < FAutoScrollDelay) then - Result := []; - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoAdvancedHeaderDraw(var PaintInfo: THeaderPaintInfo; const Elements: THeaderPaintElements); - -begin - if Assigned(FOnAdvancedHeaderDraw) then - FOnAdvancedHeaderDraw(FHeader, PaintInfo, Elements); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoAfterCellPaint(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; CellRect: TRect); - -begin - if Assigned(FOnAfterCellPaint) then - FOnAfterCellPaint(Self, Canvas, Node, Column, CellRect); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoAfterItemErase(Canvas: TCanvas; Node: PVirtualNode; ItemRect: TRect); - -begin - if Assigned(FOnAfterItemErase) then - FOnAfterItemErase(Self, Canvas, Node, ItemRect); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoAfterItemPaint(Canvas: TCanvas; Node: PVirtualNode; ItemRect: TRect); - -begin - if Assigned(FOnAfterItemPaint) then - FOnAfterItemPaint(Self, Canvas, Node, ItemRect); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoAfterPaint(Canvas: TCanvas); - -begin - if Assigned(FOnAfterPaint) then - FOnAfterPaint(Self, Canvas); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoAutoScroll(X, Y: Integer); - -begin - FScrollDirections := DetermineScrollDirections(X, Y); - - if FStates * [tsWheelPanning, tsWheelScrolling] = [] then - begin - if FScrollDirections = [] then - begin - if ((FStates * [tsScrollPending, tsScrolling]) <> []) then - begin - StopTimer(ScrollTimer); - DoStateChange([], [tsScrollPending, tsScrolling]); - end; - end - else - begin - // start auto scroll if not yet done - if (FStates * [tsScrollPending, tsScrolling]) = [] then - begin - DoStateChange([tsScrollPending]); - SetTimer(Handle, ScrollTimer, FAutoScrollDelay, nil); - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.DoBeforeDrag(Node: PVirtualNode; Column: TColumnIndex): Boolean; - -begin - Result := False; - if Assigned(FOnDragAllowed) then - FOnDragAllowed(Self, Node, Column, Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoBeforeCellPaint(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; - CellPaintMode: TVTCellPaintMode; CellRect: TRect; var ContentRect: TRect); - -var - UpdateRect: TRect; - -begin - if Assigned(FOnBeforeCellPaint) then - begin - if CellPaintMode = cpmGetContentMargin then - begin - // Prevent drawing if we are only about to get the margin. As this also clears the update rect we need to save it. - GetUpdateRect(Handle, UpdateRect, False); - SetUpdateState(True); - end; - - Canvas.Font := Self.Font; // Fixes issue #298 - FOnBeforeCellPaint(Self, Canvas, Node, Column, CellPaintMode, CellRect, ContentRect); - - if CellPaintMode = cpmGetContentMargin then - SetUpdateState(False); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoBeforeItemErase(Canvas: TCanvas; Node: PVirtualNode; ItemRect: TRect; var Color: TColor; - var EraseAction: TItemEraseAction); - -begin - if Assigned(FOnBeforeItemErase) then - FOnBeforeItemErase(Self, Canvas, Node, ItemRect, Color, EraseAction); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.DoBeforeItemPaint(Canvas: TCanvas; Node: PVirtualNode; ItemRect: TRect): Boolean; - -begin - // By default custom draw will not be used, so the tree handles drawing the node. - Result := False; - if Assigned(FOnBeforeItemPaint) then - FOnBeforeItemPaint(Self, Canvas, Node, ItemRect, Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoBeforePaint(Canvas: TCanvas); - -begin - if Assigned(FOnBeforePaint) then - FOnBeforePaint(Self, Canvas); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.DoCancelEdit(): Boolean; - -// Called when the current edit action or a pending edit must be cancelled. - -begin - StopTimer(EditTimer); - DoStateChange([], [tsEditPending]); - Result := (tsEditing in FStates) and FEditLink.CancelEdit; - if Result then - begin - DoStateChange([], [tsEditing]); - if Assigned(FOnEditCancelled) then - FOnEditCancelled(Self, FEditColumn); - if not (csDestroying in ComponentState) then - FEditLink := nil; - SetFocus(); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoCanEdit(Node: PVirtualNode; Column: TColumnIndex; var Allowed: Boolean); - -begin - if Assigned(FOnEditing) then - FOnEditing(Self, Node, Column, Allowed); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoCanSplitterResizeNode(P: TPoint; Node: PVirtualNode; Column: TColumnIndex; - var Allowed: Boolean); - -begin - if Assigned(FOnCanSplitterResizeNode) then - FOnCanSplitterResizeNode(Self, P, Node, Column, Allowed); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoChange(Node: PVirtualNode); - -begin - StopTimer(ChangeTimer); - if Assigned(FOnChange) then - FOnChange(Self, Node); - - // This is a good place to reset the cached node. This is the same as the node passed in here. - // This is necessary to allow descendants to override this method and get the node then. - DoStateChange([], [tsChangePending]); - FLastChangedNode := nil; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoCheckClick(Node: PVirtualNode; NewCheckState: TCheckState); - -begin - if ChangeCheckState(Node, NewCheckState) then - begin - DoChecked(Node); - if SyncCheckstateWithSelection[Node] then - begin - // selection should follow check state - if (NewCheckState = csCheckedNormal) then - Selected[node] := true - else - Selected[node] := false; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoChecked(Node: PVirtualNode); - -begin - if Assigned(FOnChecked) then - FOnChecked(Self, Node); - if Assigned(FAccessibleItem) then - NotifyWinEvent(EVENT_OBJECT_STATECHANGE, Handle, OBJID_CLIENT, CHILDID_SELF); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.DoChecking(Node: PVirtualNode; var NewCheckState: TCheckState): Boolean; - -// Determines if a node is allowed to change its check state to NewCheckState. - -begin - if (toReadOnly in FOptions.FMiscOptions) or (vsDisabled in Node.States) then - Result := False - else - begin - Result := True; - if Assigned(FOnChecking) then - FOnChecking(Self, Node, NewCheckState, Result); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoCollapsed(Node: PVirtualNode); -var - lFirstSelected: PVirtualNode; - lParent: PVirtualNode; -begin - if Assigned(FOnCollapsed) then - FOnCollapsed(Self, Node); - - if Assigned(FAccessibleItem) then - NotifyWinEvent(EVENT_OBJECT_STATECHANGE, Handle, OBJID_CLIENT, CHILDID_SELF); - - if (toAlwaysSelectNode in TreeOptions.SelectionOptions) then - begin - // Select the next visible parent if the currently selected node gets invisible due to a collapse - // This makes the VT behave more like the Win32 custom TreeView control - // This makes only sense no no multi selection is allowed and if there is a selected node at all - lFirstSelected := GetFirstSelected(); - if Assigned(lFirstSelected) and not FullyVisible[lFirstSelected] then - begin - lParent := GetVisibleParent(lFirstSelected); - Selected[lFirstSelected] := False; - Selected[lParent] := True; - end;//if - //if there is (still) no selected node, then use FNextNodeToSelect to select one - if SelectedCount = 0 then - EnsureNodeSelected(); - end;//if -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.DoCollapsing(Node: PVirtualNode): Boolean; - -begin - Result := True; - if Assigned(FOnCollapsing) then - FOnCollapsing(Self, Node, Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoColumnClick(Column: TColumnIndex; Shift: TShiftState); - -begin - if Assigned(FOnColumnClick) then - FOnColumnClick(Self, Column, Shift); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoColumnDblClick(Column: TColumnIndex; Shift: TShiftState); - -begin - if Assigned(FOnColumnDblClick) then - FOnColumnDblClick(Self, Column, Shift); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoColumnResize(Column: TColumnIndex); - -var - R: TRect; - Run: PVirtualNode; - -begin - if not (csLoading in ComponentState) and HandleAllocated then -begin - // Reset all vsHeightMeasured flags if we are in multiline mode. - Run := GetFirstInitialized; - while Assigned(Run) do - begin - if vsMultiline in Run.States then - Exclude(Run.States, vsHeightMeasured); - Run := GetNextInitialized(Run); - end; - - UpdateHorizontalScrollBar(True); - if Column > NoColumn then - begin - // Invalidate client area from the current column all to the right (or left in RTL mode). - R := ClientRect; - if not (toAutoSpanColumns in FOptions.FAutoOptions) then - if UseRightToLeftAlignment then - R.Right := FHeader.Columns[Column].Left + FHeader.Columns[Column].Width + ComputeRTLOffset - else - R.Left := FHeader.Columns[Column].Left; - InvalidateRect(Handle, @R, False); - FHeader.Invalidate(FHeader.Columns[Column], True); - end; - if [hsColumnWidthTracking, hsResizing] * FHeader.States = [hsColumnWidthTracking] then - UpdateWindow(Handle); - - if not (tsUpdating in FStates) then - UpdateDesigner; // design time only - - if Assigned(FOnColumnResize) and not (hsResizing in FHeader.States) then - FOnColumnResize(FHeader, Column); - - // If the tree is currently in edit state then notify edit link. - if tsEditing in FStates then - UpdateEditBounds; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoColumnVisibilityChanged(const Column: TColumnIndex; Visible: Boolean); - // Triggers the OnColumnVisibilityChanged event. -begin - if Assigned(OnColumnVisibilityChanged) then - OnColumnVisibilityChanged(Self, Column, Visible); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.DoCompare(Node1, Node2: PVirtualNode; Column: TColumnIndex): Integer; - -begin - Result := 0; - if Assigned(FOnCompareNodes) then - FOnCompareNodes(Self, Node1, Node2, Column, Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.DoCreateDataObject: IDataObject; - -begin - Result := nil; - if Assigned(FOnCreateDataObject) then - FOnCreateDataObject(Self, Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.DoCreateDragManager: IVTDragManager; - -begin - Result := nil; - if Assigned(FOnCreateDragManager) then - FOnCreateDragManager(Self, Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.DoCreateEditor(Node: PVirtualNode; Column: TColumnIndex): IVTEditLink; - -begin - Result := nil; - if Assigned(FOnCreateEditor) then - FOnCreateEditor(Self, Node, Column, Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoDragging(P: TPoint); - -// Initiates finally the drag'n drop operation and returns after DD is finished. - - //--------------- local function -------------------------------------------- - - function GetDragOperations: Integer; - - begin - if FDragOperations = [] then - Result := DROPEFFECT_COPY or DROPEFFECT_MOVE or DROPEFFECT_LINK - else - begin - Result := 0; - if doCopy in FDragOperations then - Result := Result or DROPEFFECT_COPY; - if doLink in FDragOperations then - Result := Result or DROPEFFECT_LINK; - if doMove in FDragOperations then - Result := Result or DROPEFFECT_MOVE; - end; - end; - - //--------------- end local function ---------------------------------------- - -var - AllowedEffects: Integer; - DragObject: TDragObject; - - DataObject: IDataObject; - -begin - DataObject := nil; - // Dragging is dragging, nothing else. - DoCancelEdit; - - if Assigned(FCurrentHotNode) then - begin - InvalidateNode(FCurrentHotNode); - FCurrentHotNode := nil; - end; - // Select the focused node if not already done. - if Assigned(FFocusedNode) and not (vsSelected in FFocusedNode.States) then - begin - InternalAddToSelection(FFocusedNode, False); - InvalidateNode(FFocusedNode); - end; - - UpdateWindow(Handle); - - // Keep a list of all currently selected nodes as this list might change, - // but we have probably to delete currently selected nodes. - FDragSelection := GetSortedSelection(True); - try - DoStateChange([tsOLEDragging], [tsOLEDragPending, tsClearPending]); - - // An application might create a drag object like used during VCL dd. This is not required for OLE dd but - // required as parameter. - DragObject := nil; - DoStartDrag(DragObject); - DragObject.Free; - - DataObject := DragManager.DataObject; - PrepareDragImage(P, DataObject); - - FLastDropMode := dmOnNode; - // Don't forget to initialize the result. It might never be touched. - FLastDragEffect := DROPEFFECT_NONE; - AllowedEffects := GetDragOperations; - try - DragAndDrop(AllowedEffects, DataObject, FLastDragEffect); - DragManager.ForceDragLeave; - finally - GetCursorPos(P); - P := ScreenToClient(P); - DoEndDrag(Self, P.X, P.Y); - - FDragImage.EndDrag; - - // Finish the operation. - if (FLastDragEffect = DROPEFFECT_MOVE) and (toAutoDeleteMovedNodes in TreeOptions.AutoOptions) then - begin - // The operation was a move so delete the previously selected nodes. - DeleteSelectedNodes; - end; - - DoStateChange([], [tsOLEDragging]); - end; - finally - FDragSelection := nil; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoDragExpand; - -var - SourceTree: TBaseVirtualTree; - -begin - StopTimer(ExpandTimer); - if Assigned(FDropTargetNode) and (vsHasChildren in FDropTargetNode.States) and - not (vsExpanded in FDropTargetNode.States) then - begin - if Assigned(FDragManager) then - SourceTree := DragManager.DragSource - else - SourceTree := nil; - - if not DragManager.DropTargetHelperSupported and Assigned(SourceTree) then - SourceTree.FDragImage.HideDragImage; - ToggleNode(FDropTargetNode); - UpdateWindow(Handle); - if not DragManager.DropTargetHelperSupported and Assigned(SourceTree) then - SourceTree.FDragImage.ShowDragImage; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.DoDragOver(Source: TObject; Shift: TShiftState; State: TDragState; Pt: TPoint; Mode: TDropMode; - var Effect: Integer): Boolean; - -begin - Result := False; - if Assigned(FOnDragOver) then - FOnDragOver(Self, Source, Shift, State, Pt, Mode, Effect, Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoDragDrop(Source: TObject; const DataObject: IDataObject; const Formats: TFormatArray; - Shift: TShiftState; Pt: TPoint; var Effect: Integer; Mode: TDropMode); - -begin - if Assigned(FOnDragDrop) then - FOnDragDrop(Self, Source, DataObject, Formats, Shift, Pt, Effect, Mode); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoBeforeDrawLineImage(Node: PVirtualNode; Level: Integer; var XPos: Integer); - -begin - if Assigned(FOnBeforeDrawLineImage) then - FOnBeforeDrawLineImage(Self, Node, Level, XPos); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoEdit; - -begin - Application.CancelHint; - StopTimer(ScrollTimer); - StopTimer(EditTimer); - DoStateChange([], [tsEditPending]); - if Assigned(FFocusedNode) and not (vsDisabled in FFocusedNode.States) and - not (toReadOnly in FOptions.FMiscOptions) and (FEditLink = nil) then - begin - FEditLink := DoCreateEditor(FFocusedNode, FEditColumn); - if Assigned(FEditLink) then - begin - DoStateChange([tsEditing], [tsDrawSelecting, tsDrawSelPending, tsToggleFocusedSelection, tsOLEDragPending, - tsOLEDragging, tsClearPending, tsDrawSelPending, tsScrollPending, tsScrolling]); - ScrollIntoView(FFocusedNode, toCenterScrollIntoView in FOptions.SelectionOptions, - not (toDisableAutoscrollOnEdit in FOptions.AutoOptions)); - if FEditLink.PrepareEdit(Self, FFocusedNode, FEditColumn) then - begin - UpdateEditBounds; - // Node needs repaint because the selection rectangle and static text must disappear. - InvalidateNode(FFocusedNode); - if not FEditLink.BeginEdit then - DoStateChange([], [tsEditing]); - end - else - DoStateChange([], [tsEditing]); - if not (tsEditing in FStates) then - FEditLink := nil; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoEndDrag(Target: TObject; X, Y: Integer); - -// Does some housekeeping for VCL drag'n drop; - -begin - inherited; - - DragFinished; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.DoEndEdit: Boolean; - -// Called to finish a current edit action or stop the edit timer if an edit operation is pending. -// Returns True if editing was successfully ended or the control was not in edit mode -// Returns False if the control could not leave the edit mode e.g. due to an invalid value that was entered. - -begin - StopTimer(EditTimer); - Result := (tsEditing in FStates) and FEditLink.EndEdit; - if Result then - begin - DoStateChange([], [tsEditing]); - FEditLink := nil; - if Assigned(FOnEdited) then - FOnEdited(Self, FFocusedNode, FEditColumn); - end; - DoStateChange([], [tsEditPending]); - // Causes the editor to end prematurely, after having tabbed into a new cell - // see https://github.com/JAM-Software/Virtual-TreeView/commit/de863b4417dfd98caffe8d0c283959b4842d2a82 - // see https://github.com/HeidiSQL/HeidiSQL/issues/937 - //SetFocus(); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoEndOperation(OperationKind: TVTOperationKind); - -begin - if Assigned(FOnEndOperation) then - FOnEndOperation(Self, OperationKind); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoEnter(); -begin - inherited; - EnsureNodeSelected(); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoExpanded(Node: PVirtualNode); - -begin - if Assigned(FOnExpanded) then - FOnExpanded(Self, Node); - - if Assigned(FAccessibleItem) then - NotifyWinEvent(EVENT_OBJECT_STATECHANGE, Handle, OBJID_CLIENT, CHILDID_SELF); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.DoExpanding(Node: PVirtualNode): Boolean; - -begin - Result := True; - if Assigned(FOnExpanding) then - FOnExpanding(Self, Node, Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoFocusChange(Node: PVirtualNode; Column: TColumnIndex); - -begin - if Assigned(FOnFocusChanged) then - FOnFocusChanged(Self, Node, Column); - - if Assigned(FAccessibleItem) then - begin - NotifyWinEvent(EVENT_OBJECT_LOCATIONCHANGE, Handle, OBJID_CLIENT, CHILDID_SELF); - NotifyWinEvent(EVENT_OBJECT_NAMECHANGE, Handle, OBJID_CLIENT, CHILDID_SELF); - NotifyWinEvent(EVENT_OBJECT_VALUECHANGE, Handle, OBJID_CLIENT, CHILDID_SELF); - NotifyWinEvent(EVENT_OBJECT_STATECHANGE, Handle, OBJID_CLIENT, CHILDID_SELF); - NotifyWinEvent(EVENT_OBJECT_SELECTION, Handle, OBJID_CLIENT, CHILDID_SELF); - NotifyWinEvent(EVENT_OBJECT_FOCUS, Handle, OBJID_CLIENT, CHILDID_SELF); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.DoFocusChanging(OldNode, NewNode: PVirtualNode; OldColumn, NewColumn: TColumnIndex): Boolean; - -begin - Result := (OldColumn = NewColumn) or FHeader.AllowFocus(NewColumn); - if Assigned(FOnFocusChanging) then - FOnFocusChanging(Self, OldNode, NewNode, OldColumn, NewColumn, Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoFocusNode(Node: PVirtualNode; Ask: Boolean); - -begin - if not (tsEditing in FStates) or EndEditNode then - begin - if Node = FRoot then - Node := nil; - if (FFocusedNode <> Node) and (not Ask or DoFocusChanging(FFocusedNode, Node, FFocusedColumn, FFocusedColumn)) then - begin - if Assigned(FFocusedNode) then - begin - // Do automatic collapsing of last focused node if enabled. This is however only done if - // old and new focused node have a common parent node. - if (toAutoExpand in FOptions.FAutoOptions) and Assigned(Node) and (Node.Parent = FFocusedNode.Parent) and - (vsExpanded in FFocusedNode.States) then - ToggleNode(FFocusedNode) - else - InvalidateNode(FFocusedNode); - end; - FFocusedNode := Node; - end; - - // Have to scroll the node into view, even it is the same node as before. - if Assigned(FFocusedNode) then - begin - // Make sure a valid column is set if columns are used and no column has currently the focus. - if FHeader.UseColumns and (not FHeader.FColumns.IsValidColumn(FFocusedColumn)) then - FFocusedColumn := FHeader.MainColumn; - // Do automatic expansion of the newly focused node if enabled. - if (toAutoExpand in FOptions.FAutoOptions) and not (vsExpanded in FFocusedNode.States) then - ToggleNode(FFocusedNode); - InvalidateNode(FFocusedNode); - if (FUpdateCount = 0) and not (toDisableAutoscrollOnFocus in FOptions.FAutoOptions) then - ScrollIntoView(FFocusedNode, (toCenterScrollIntoView in FOptions.SelectionOptions) and - (MouseButtonDown * FStates = []), not (toFullRowSelect in FOptions.SelectionOptions) ); - end; - - // Reset range anchor if necessary. - if FSelectionCount = 0 then - ResetRangeAnchor; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoFreeNode(Node: PVirtualNode); - -var - IntfData: IInterface; -begin - // Prevent invalid references - if Node = FLastChangedNode then - FLastChangedNode := nil; - if Node = FCurrentHotNode then - FCurrentHotNode := nil; - if Node = FDropTargetNode then - FDropTargetNode := nil; - if Node = FLastStructureChangeNode then - FLastStructureChangeNode := nil; - if Node = FFocusedNode then - FFocusedNode := nil; - if Node = FNextNodeToSelect then - UpdateNextNodeToSelect(Node); - if Node = FLastHitInfo.HitNode then - FLastHitInfo.HitNode := nil; - // fire event - if Assigned(FOnFreeNode) and ([vsInitialized, vsOnFreeNodeCallRequired] * Node.States <> []) then - FOnFreeNode(Self, Node); - - if vsReleaseCallOnUserDataRequired in Node.States then - begin - // Data may have been set to nil, in which case we can't call _Release on it - IntfData := GetInterfaceFromNodeData(Node); - if Assigned(IntfData) then - IntfData._Release(); - end; - - FreeMem(Node); - if Self.UpdateCount = 0 then - EnsureNodeSelected(); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.DoGetCellContentMargin(Node: PVirtualNode; Column: TColumnIndex; - CellContentMarginType: TVTCellContentMarginType = ccmtAllSides; Canvas: TCanvas = nil): TPoint; - -// Determines the margins of the content rectangle caused by DoBeforeCellPaint. -// Note that shrinking the content rectangle results in positive margins whereas enlarging the content rectangle results -// in negative margins. - -var - CellRect, - ContentRect: TRect; - -begin - Result := Point(0, 0); - - if Assigned(FOnBeforeCellPaint) then // Otherwise DoBeforeCellPaint has no effect. - begin - if Canvas = nil then - Canvas := Self.Canvas; - - // Determine then node's cell rectangle and content rectangle before calling DoBeforeCellPaint. - CellRect := GetDisplayRect(Node, Column, True); - ContentRect := CellRect; - DoBeforeCellPaint(Canvas, Node, Column, cpmGetContentMargin, CellRect, ContentRect); - - // Calculate the changes caused by DoBeforeCellPaint. - case CellContentMarginType of - ccmtAllSides: - // Calculate the width difference and high difference. - Result := Point((CellRect.Right - CellRect.Left) - (ContentRect.Right - ContentRect.Left), - (CellRect.Bottom - CellRect.Top) - (ContentRect.Bottom - ContentRect.Top)); - ccmtTopLeftOnly: - // Calculate the left margin and top margin only. - Result := Point(ContentRect.Left - CellRect.Left, ContentRect.Top - CellRect.Top); - ccmtBottomRightOnly: - // Calculate the right margin and bottom margin only. - Result := Point(CellRect.Right - ContentRect.Right, CellRect.Bottom - ContentRect.Bottom); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoGetCursor(var Cursor: TCursor); - -begin - if Assigned(FOnGetCursor) then - FOnGetCursor(Self, Cursor); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoGetHeaderCursor(var Cursor: HCURSOR); - -begin - if Assigned(FOnGetHeaderCursor) then - FOnGetHeaderCursor(FHeader, Cursor); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.DoGetImageIndex(Node: PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex; - var Ghosted: Boolean; var Index: TImageIndex): TCustomImageList; - -// Queries the application/descendant about certain image properties for a node. -// Returns a custom image list if given by the callee, otherwise nil. -const - cTVTImageKind2String: Array [TVTImageKind] of string = ('ikNormal', 'ikSelected', 'ikState', 'ikOverlay'); -begin - if (Kind = ikState) and Assigned(StateImages) then - Result := Self.StateImages - else - Result := Self.Images; - // First try the enhanced event to allow for custom image lists. - if Assigned(FOnGetImageEx) then - FOnGetImageEx(Self, Node, Kind, Column, Ghosted, Index, Result) - else if Assigned(FOnGetImage) then - FOnGetImage(Self, Node, Kind, Column, Ghosted, Index); - - Assert((Index < 0) or Assigned(Result), 'An image index was supplied for TVTImageKind.' + cTVTImageKind2String[Kind] + ' but no image list was supplied.'); - if not Assigned(Result) then - Index := -1; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoGetImageText(Node: PVirtualNode; Kind: TVTImageKind; - Column: TColumnIndex; var ImageText: string); - -// Queries the application/descendant about alternative image text for a node. - -begin - if Assigned(FOnGetImageText) then - FOnGetImageText(Self, Node, Kind, Column, ImageText); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoGetLineStyle(var Bits: Pointer); - -begin - if Assigned(FOnGetLineStyle) then - FOnGetLineStyle(Self, Bits); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.DoGetNodeHint(Node: PVirtualNode; Column: TColumnIndex; - var LineBreakStyle: TVTTooltipLineBreakStyle): string; - -begin - Result := Hint; - LineBreakStyle := hlbDefault; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.DoGetNodeTooltip(Node: PVirtualNode; Column: TColumnIndex; - var LineBreakStyle: TVTTooltipLineBreakStyle): string; - -begin - Result := Hint; - LineBreakStyle := hlbDefault; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.DoGetNodeExtraWidth(Node: PVirtualNode; Column: TColumnIndex; Canvas: TCanvas = nil): Integer; - -// Returns the pixel width of extra space occupied by node contents (for example, static text). - -begin - Result := 0; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.DoGetNodeWidth(Node: PVirtualNode; Column: TColumnIndex; Canvas: TCanvas = nil): Integer; - -// Returns the pixel width of a node. - -begin - Result := 0; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.DoGetPopupMenu(Node: PVirtualNode; Column: TColumnIndex; Position: TPoint): TPopupMenu; - -// Queries the application whether there is a node specific popup menu. - -var - Run: PVirtualNode; - AskParent: Boolean; - -begin - Result := nil; - if Assigned(FOnGetPopupMenu) then - begin - Run := Node; - - if Assigned(Run) then - begin - AskParent := True; - repeat - FOnGetPopupMenu(Self, Run, Column, Position, AskParent, Result); - Run := Run.Parent; - until (Run = FRoot) or Assigned(Result) or not AskParent; - end - else - FOnGetPopupMenu(Self, nil, NoColumn, Position, AskParent, Result); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoGetUserClipboardFormats(var Formats: TFormatEtcArray); - -begin - if Assigned(FOnGetUserClipboardFormats) then - FOnGetUserClipboardFormats(Self, Formats); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoHeaderAddPopupItem(const Column: TColumnIndex; var Cmd: TAddPopupItemType); - -begin - if Assigned(FOnHeaderAddPopupItem) then - FOnHeaderAddPopupItem(Self, Column, Cmd); - -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoHeaderClick(const HitInfo: TVTHeaderHitInfo); - -begin - if Assigned(FOnHeaderClick) then - FOnHeaderClick(FHeader, HitInfo); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoHeaderDblClick(const HitInfo: TVTHeaderHitInfo); - -begin - if Assigned(FOnHeaderDblClick) then - FOnHeaderDblClick(FHeader, HitInfo); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoHeaderDragged(Column: TColumnIndex; OldPosition: TColumnPosition); - -begin - if Assigned(FOnHeaderDragged) then - FOnHeaderDragged(FHeader, Column, OldPosition); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoHeaderDraggedOut(Column: TColumnIndex; DropPosition: TPoint); - -begin - if Assigned(FOnHeaderDraggedOut) then - FOnHeaderDraggedOut(FHeader, Column, DropPosition); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.DoHeaderDragging(Column: TColumnIndex): Boolean; - -begin - Result := True; - if Assigned(FOnHeaderDragging) then - FOnHeaderDragging(FHeader, Column, Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoHeaderDraw(Canvas: TCanvas; Column: TVirtualTreeColumn; R: TRect; Hover, Pressed: Boolean; - DropMark: TVTDropMarkMode); - -begin - if Assigned(FOnHeaderDraw) then - FOnHeaderDraw(FHeader, Canvas, Column, R, Hover, Pressed, DropMark); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoHeaderDrawQueryElements(var PaintInfo: THeaderPaintInfo; var Elements: THeaderPaintElements); - -begin - if Assigned(FOnHeaderDrawQueryElements) then - FOnHeaderDrawQueryElements(FHeader, PaintInfo, Elements); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoHeaderMouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); - -begin - if Assigned(FOnHeaderMouseDown) then - FOnHeaderMouseDown(FHeader, Button, Shift, X, Y); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoHeaderMouseMove(Shift: TShiftState; X, Y: Integer); - -begin - if Assigned(FOnHeaderMouseMove) then - FOnHeaderMouseMove(FHeader, Shift, X, Y); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoHeaderMouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); - -begin - if Assigned(FOnHeaderMouseUp) then - FOnHeaderMouseUp(FHeader, Button, Shift, X, Y); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoHotChange(Old, New: PVirtualNode); - -begin - if Assigned(FOnHotChange) then - FOnHotChange(Self, Old, New); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.DoIncrementalSearch(Node: PVirtualNode; const Text: string): Integer; - -begin - Result := 0; - if Assigned(FOnIncrementalSearch) then - FOnIncrementalSearch(Self, Node, Text, Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.DoInitChildren(Node: PVirtualNode; var ChildCount: Cardinal): Boolean; -/// The function calls the OnInitChildren and returns True if the event was called; it returns False if the caller can expect that no changes have been made to ChildCount -begin - if Assigned(FOnInitChildren) then - begin - FOnInitChildren(Self, Node, ChildCount); - Result := True; - end - else - Result := False; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoInitNode(Parent, Node: PVirtualNode; var InitStates: TVirtualNodeInitStates); - -begin - if Assigned(FOnInitNode) then - FOnInitNode(Self, Parent, Node, InitStates); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.DoKeyAction(var CharCode: Word; var Shift: TShiftState): Boolean; - -begin - Result := True; - if Assigned(FOnKeyAction) then - FOnKeyAction(Self, CharCode, Shift, Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoLoadUserData(Node: PVirtualNode; Stream: TStream); - -begin - if Assigned(FOnLoadNode) then - if Node = FRoot then - FOnLoadNode(Self, nil, Stream) - else - FOnLoadNode(Self, Node, Stream); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoMeasureItem(TargetCanvas: TCanvas; Node: PVirtualNode; var NodeHeight: Integer); - -begin - if not (vsInitialized in Node.States) then - InitNode(Node); - if Assigned(FOnMeasureItem) then - FOnMeasureItem(Self, TargetCanvas, Node, NodeHeight); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoMouseEnter(); - -begin - if Assigned(FOnMouseEnter) then - FOnMouseEnter(Self); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoMouseLeave; - -begin - if Assigned(FOnMouseLeave) then - FOnMouseLeave(Self); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoNodeCopied(Node: PVirtualNode); - -begin - if Assigned(FOnNodeCopied) then - FOnNodeCopied(Self, Node); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.DoNodeCopying(Node, NewParent: PVirtualNode): Boolean; - -begin - Result := True; - if Assigned(FOnNodeCopying) then - FOnNodeCopying(Self, Node, NewParent, Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoNodeClick(const HitInfo: THitInfo); - -begin - if Assigned(FOnNodeClick) then - FOnNodeClick(Self, HitInfo); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoNodeDblClick(const HitInfo: THitInfo); - -begin - if Assigned(FOnNodeDblClick) then - FOnNodeDblClick(Self, HitInfo); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.DoNodeHeightDblClickResize(Node: PVirtualNode; Column: TColumnIndex; Shift: TShiftState; - P: TPoint): Boolean; - -begin - Result := True; - if Assigned(FOnNodeHeightDblClickResize) then - FOnNodeHeightDblClickResize(Self, Node, Column, Shift, P, Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.DoNodeHeightTracking(Node: PVirtualNode; Column: TColumnIndex; Shift: TShiftState; - var TrackPoint: TPoint; P: TPoint): Boolean; - -begin - Result := True; - if Assigned(FOnNodeHeightTracking) then - FOnNodeHeightTracking(Self, Node, Column, Shift, TrackPoint, P, Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoNodeMoved(Node: PVirtualNode); - -begin - if Assigned(FOnNodeMoved) then - FOnNodeMoved(Self, Node); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.DoNodeMoving(Node, NewParent: PVirtualNode): Boolean; - -begin - Result := True; - if Assigned(FOnNodeMoving) then - FOnNodeMoving(Self, Node, NewParent, Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.DoPaintBackground(Canvas: TCanvas; R: TRect): Boolean; - -begin - Result := False; - if Assigned(FOnPaintBackground) then - FOnPaintBackground(Self, Canvas, R, Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoPaintDropMark(Canvas: TCanvas; Node: PVirtualNode; R: TRect); - -// draws the drop mark into the given rectangle -// Note: Changed properties of the given canvas should be reset to their previous values. - -var - SaveBrushColor: TColor; - SavePenStyle: TPenStyle; - -begin - if FLastDropMode in [dmAbove, dmBelow] then - with Canvas do - begin - SavePenStyle := Pen.Style; - Pen.Style := psClear; - SaveBrushColor := Brush.Color; - Brush.Color := FColors.DropMarkColor; - - if FLastDropMode = dmAbove then - begin - Polygon([Point(R.Left + 2, R.Top), - Point(R.Right - 2, R.Top), - Point(R.Right - 2, R.Top + 6), - Point(R.Right - 6, R.Top + 2), - Point(R.Left + 6 , R.Top + 2), - Point(R.Left + 2, R.Top + 6) - ]); - end - else - Polygon([Point(R.Left + 2, R.Bottom - 1), - Point(R.Right - 2, R.Bottom - 1), - Point(R.Right - 2, R.Bottom - 8), - Point(R.Right - 7, R.Bottom - 3), - Point(R.Left + 7 , R.Bottom - 3), - Point(R.Left + 2, R.Bottom - 8) - ]); - Brush.Color := SaveBrushColor; - Pen.Style := SavePenStyle; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoPaintNode(var PaintInfo: TVTPaintInfo); - -begin -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoPopupMenu(Node: PVirtualNode; Column: TColumnIndex; Position: TPoint); - -// Support for node dependent popup menus. - -var - Menu: TPopupMenu; - -begin - Menu := DoGetPopupMenu(Node, Column, Position); - - if Assigned(Menu) then - begin - DoStateChange([tsPopupMenuShown]); - StopTimer(EditTimer); - Menu.PopupComponent := Self; - with ClientToScreen(Position) do - Menu.Popup(X, Y); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoRemoveFromSelection(Node: PVirtualNode); - -begin - if Assigned(FOnRemoveFromSelection) then - FOnRemoveFromSelection(Self, Node); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.DoRenderOLEData(const FormatEtcIn: TFormatEtc; out Medium: TStgMedium; - ForClipboard: Boolean): HRESULT; - -begin - Result := E_FAIL; - if Assigned(FOnRenderOLEData) then - FOnRenderOLEData(Self, FormatEtcIn, Medium, ForClipboard, Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoReset(Node: PVirtualNode); - -begin - if Assigned(FOnResetNode) then - FOnResetNode(Self, Node); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoSaveUserData(Node: PVirtualNode; Stream: TStream); - -begin - if Assigned(FOnSaveNode) then - if Node = FRoot then - FOnSaveNode(Self, nil, Stream) - else - FOnSaveNode(Self, Node, Stream); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoScroll(DeltaX, DeltaY: Integer); - -begin - if Assigned(FOnScroll) then - FOnScroll(Self, DeltaX, DeltaY); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.DoSetOffsetXY(Value: TPoint; Options: TScrollUpdateOptions; ClipRect: PRect = nil): Boolean; - -// Actual offset setter used to scroll the client area, update scroll bars and invalidating the header (all optional). -// Returns True if the offset really changed otherwise False is returned. - -var - DeltaX: Integer; - DeltaY: Integer; - DWPStructure: HDWP; - I: Integer; - P: TPoint; - R: TRect; - -begin - // Range check, order is important here. - if Value.X < (ClientWidth - Integer(FRangeX)) then - Value.X := ClientWidth - Integer(FRangeX); - if Value.X > 0 then - Value.X := 0; - DeltaX := Value.X - FOffsetX; - if UseRightToLeftAlignment then - DeltaX := -DeltaX; - if Value.Y < (ClientHeight - Integer(FRangeY)) then - Value.Y := ClientHeight - Integer(FRangeY); - if Value.Y > 0 then - Value.Y := 0; - DeltaY := Value.Y - FOffsetY; - - Result := (DeltaX <> 0) or (DeltaY <> 0); - if Result then - begin - FOffsetX := Value.X; - FOffsetY := Value.Y; - Result := True; - - if tsHint in Self.FStates then - Application.CancelHint; - if FUpdateCount = 0 then - begin - // The drag image from VCL controls need special consideration. - if tsVCLDragging in FStates then - ImageList_DragShowNolock(False); - - if (suoScrollClientArea in Options) and not (tsToggling in FStates) then - begin - // Have to invalidate the entire window if there's a background. - if (toShowBackground in FOptions.FPaintOptions) and Assigned(FBackground.Graphic) then - begin - // Since we don't use ScrollWindow here we have to move all client windows ourselves. - DWPStructure := BeginDeferWindowPos(ControlCount); - for I := 0 to ControlCount - 1 do - if Controls[I] is TWinControl then - begin - with Controls[I] as TWinControl do - DWPStructure := DeferWindowPos(DWPStructure, Handle, 0, Left + DeltaX, Top + DeltaY, 0, 0, - SWP_NOZORDER or SWP_NOACTIVATE or SWP_NOSIZE); - if DWPStructure = 0 then - Break; - end; - if DWPStructure <> 0 then - EndDeferWindowPos(DWPStructure); - InvalidateRect(Handle, nil, False); - end - else - begin - if (DeltaX <> 0) and (Header.Columns.GetVisibleFixedWidth > 0) then - begin - // When fixed columns exists we have to scroll separately horizontally and vertically. - // Horizontally is scroll only the client area not occupied by fixed columns and - // vertically entire client area (or clipping area if one exists). - R := ClientRect; - R.Left := Header.Columns.GetVisibleFixedWidth; - - ScrollWindow(Handle, DeltaX, 0, @R, @R); - if DeltaY <> 0 then - ScrollWindow(Handle, 0, DeltaY, ClipRect, ClipRect); - end - else - ScrollWindow(Handle, DeltaX, DeltaY, ClipRect, ClipRect); - end; - end; - - if suoUpdateNCArea in Options then - begin - if DeltaX <> 0 then - begin - UpdateHorizontalScrollBar(suoRepaintScrollBars in Options); - if (suoRepaintHeader in Options) and (hoVisible in FHeader.FOptions) then - FHeader.Invalidate(nil); - if not (tsSizing in FStates) and (FScrollBarOptions.ScrollBars in [System.UITypes.TScrollStyle.ssHorizontal, System.UITypes.TScrollStyle.ssBoth]) then - UpdateVerticalScrollBar(suoRepaintScrollBars in Options); - end; - - if (DeltaY <> 0) and ([tsThumbTracking, tsSizing] * FStates = []) then - begin - UpdateVerticalScrollBar(suoRepaintScrollBars in Options); - if not (FHeader.UseColumns or IsMouseSelecting) and - (FScrollBarOptions.ScrollBars in [System.UITypes.TScrollStyle.ssHorizontal, System.UITypes.TScrollStyle.ssBoth]) then - UpdateHorizontalScrollBar(suoRepaintScrollBars in Options); - end; - end; - - if tsVCLDragging in FStates then - ImageList_DragShowNolock(True); - end; - - // Finally update "hot" node if hot tracking is activated - GetCursorPos(P); - P := ScreenToClient(P); - if PtInRect(ClientRect, P) then - HandleHotTrack(P.X, P.Y); - - DoScroll(DeltaX, DeltaY); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoShowScrollBar(Bar: Integer; Show: Boolean); - -begin - ShowScrollBar(Handle, Bar, Show); - if Assigned(FOnShowScrollBar) then - FOnShowScrollBar(Self, Bar, Show); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoStartDrag(var DragObject: TDragObject); - -begin - inherited; - - // Check if the application created an own drag object. This is needed to pass the correct source in - // OnDragOver and OnDragDrop. - if Assigned(DragObject) then - DoStateChange([tsUserDragObject]); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoStartOperation(OperationKind: TVTOperationKind); - -begin - if Assigned(FOnStartOperation) then - FOnStartOperation(Self, OperationKind); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoStateChange(Enter: TVirtualTreeStates; Leave: TVirtualTreeStates = []); - -var - ActualEnter, - ActualLeave: TVirtualTreeStates; - -begin - if Assigned(FOnStateChange) then - begin - ActualEnter := Enter - FStates; - ActualLeave := FStates * Leave; - if (ActualEnter + ActualLeave) <> [] then - FOnStateChange(Self, Enter, Leave); - end; - FStates := FStates + Enter - Leave; - Assert(FStates * [tsUseCache, tsValidationNeeded] <> [tsUseCache, tsValidationNeeded], 'Invalid state. tsUseCache and tsValidationNeeded are mutually exclusive and must not be set at the same time'); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoStructureChange(Node: PVirtualNode; Reason: TChangeReason); - -begin - StopTimer(StructureChangeTimer); - if Assigned(FOnStructureChange) then - FOnStructureChange(Self, Node, Reason); - - // This is a good place to reset the cached node and reason. These are the same as the values passed in here. - // This is necessary to allow descendants to override this method and get them. - DoStateChange([], [tsStructureChangePending]); - FLastStructureChangeNode := nil; - FLastStructureChangeReason := crIgnore; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoTimerScroll; - -var - P, - ClientP: TPoint; - InRect, - Panning: Boolean; - R, - ClipRect: TRect; - DeltaX, - DeltaY: Integer; - -begin - GetCursorPos(P); - R := ClientRect; - ClipRect := R; - MapWindowPoints(Handle, 0, R, 2); - InRect := PtInRect(R, P); - ClientP := ScreenToClient(P); - Panning := [tsWheelPanning, tsWheelScrolling] * FStates <> []; - - if IsMouseSelecting or InRect or Panning then - begin - DeltaX := 0; - DeltaY := 0; - if sdUp in FScrollDirections then - begin - if Panning then - DeltaY := FLastClickPos.Y - ClientP.Y - 8 - else - if InRect then - DeltaY := Min(FScrollBarOptions.FIncrementY, ClientHeight) - else - DeltaY := Min(FScrollBarOptions.FIncrementY, ClientHeight) * Abs(R.Top - P.Y); - if FOffsetY = 0 then - Exclude(FScrollDirections, sdUp); - end; - - if sdDown in FScrollDirections then - begin - if Panning then - DeltaY := FLastClickPos.Y - ClientP.Y + 8 - else - if InRect then - DeltaY := -Min(FScrollBarOptions.FIncrementY, ClientHeight) - else - DeltaY := -Min(FScrollBarOptions.FIncrementY, ClientHeight) * Abs(P.Y - R.Bottom); - if (ClientHeight - FOffsetY) = Integer(FRangeY) then - Exclude(FScrollDirections, sdDown); - end; - - if sdLeft in FScrollDirections then - begin - if Panning then - DeltaX := FLastClickPos.X - ClientP.X - 8 - else - if InRect then - DeltaX := FScrollBarOptions.FIncrementX - else - DeltaX := FScrollBarOptions.FIncrementX * Abs(R.Left - P.X); - if FEffectiveOffsetX = 0 then - Exclude(FScrollDirections, sdleft); - end; - - if sdRight in FScrollDirections then - begin - if Panning then - DeltaX := FLastClickPos.X - ClientP.X + 8 - else - if InRect then - DeltaX := -FScrollBarOptions.FIncrementX - else - DeltaX := -FScrollBarOptions.FIncrementX * Abs(P.X - R.Right); - - if (ClientWidth + FEffectiveOffsetX) = Integer(FRangeX) then - Exclude(FScrollDirections, sdRight); - end; - - if UseRightToLeftAlignment then - DeltaX := - DeltaX; - - if IsMouseSelecting then - begin - // In order to avoid scrolling the area which needs a repaint due to the changed selection rectangle - // we limit the scroll area explicitely. - OffsetRect(ClipRect, DeltaX, DeltaY); - DoSetOffsetXY(Point(FOffsetX + DeltaX, FOffsetY + DeltaY), DefaultScrollUpdateFlags, @ClipRect); - // When selecting with the mouse then either update only the parts of the window which have been uncovered - // by the scroll operation if no change in the selection happend or invalidate and redraw the entire - // client area otherwise (to avoid the time consuming task of determining the display rectangles of every - // changed node). - if CalculateSelectionRect(ClientP.X, ClientP.Y) and HandleDrawSelection(ClientP.X, ClientP.Y) then - InvalidateRect(Handle, nil, False) - else - begin - // The selection did not change so invalidate only the part of the window which really needs an update. - // 1) Invalidate the parts uncovered by the scroll operation. Add another offset range, we have to - // scroll only one stripe but have to update two. - OffsetRect(ClipRect, DeltaX, DeltaY); - SubtractRect(ClipRect, ClientRect, ClipRect); - InvalidateRect(Handle, @ClipRect, False); - - // 2) Invalidate the selection rectangles. - UnionRect(ClipRect, OrderRect(FNewSelRect), OrderRect(FLastSelRect)); - OffsetRect(ClipRect, FOffsetX, FOffsetY); - InvalidateRect(Handle, @ClipRect, False); - end; - end - else - begin - // Scroll only if there is no drag'n drop in progress. Drag'n drop scrolling is handled in DragOver. - if ((FDragManager = nil) or not DragManager.IsDropTarget) and ((DeltaX <> 0) or (DeltaY <> 0)) then - DoSetOffsetXY(Point(FOffsetX + DeltaX, FOffsetY + DeltaY), DefaultScrollUpdateFlags, nil); - end; - UpdateWindow(Handle); - - if (FScrollDirections = []) and ([tsWheelPanning, tsWheelScrolling] * FStates = []) then - begin - StopTimer(ScrollTimer); - DoStateChange([], [tsScrollPending, tsScrolling]); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoUpdating(State: TVTUpdateState); - -begin - if Assigned(FOnUpdating) then - FOnUpdating(Self, State); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.DoValidateCache(): Boolean; - -// This method fills the cache, which is used to speed up searching for nodes. -// The strategy is simple: Take the current number of visible nodes and distribute evenly a number of marks -// (which are stored in FPositionCache) so that iterating through the tree doesn't cost too much time. -// If there are less than 'CacheThreshold' nodes in the tree then the cache remains empty. -// Result is True if the cache was filled without interruption, otherwise False. -// Note: You can adjust the maximum number of nodes between two cache entries by changing CacheThreshold. - -var - EntryCount, - CurrentTop, - Index: Cardinal; - CurrentNode, - Temp: PVirtualNode; - -begin - EntryCount := 0; - if not (tsStopValidation in FStates) then - begin - if FStartIndex = 0 then - FPositionCache := nil; - - EntryCount := CalculateCacheEntryCount; - SetLength(FPositionCache, EntryCount); - if FStartIndex > EntryCount then - FStartIndex := EntryCount; - - // Optimize validation by starting with FStartIndex if set. - if (FStartIndex > 0) and Assigned(FPositionCache[FStartIndex - 1].Node) then - begin - // Index is the current entry in FPositionCache. - Index := FStartIndex - 1; - // Running term for absolute top value. - CurrentTop := FPositionCache[Index].AbsoluteTop; - // Running node pointer. - CurrentNode := FPositionCache[Index].Node; - end - else - begin - // Index is the current entry in FPositionCache. - Index := 0; - // Running term for absolute top value. - CurrentTop := 0; - // Running node pointer. - CurrentNode := GetFirstVisibleNoInit(nil, True); - end; - - // EntryCount serves as counter for processed nodes here. This value can always start at 0 as - // the validation either starts also at index 0 or an index which is always a multiple of CacheThreshold - // and EntryCount is only used with modulo CacheThreshold. - EntryCount := 0; - if Assigned(CurrentNode) then - begin - while not (tsStopValidation in FStates) do - begin - // If the cache is full then stop the loop. - if (Integer(Index) >= Length(FPositionCache)) then - Break; - if (EntryCount mod CacheThreshold) = 0 then - begin - // New cache entry to set up. - with FPositionCache[Index] do - begin - Node := CurrentNode; // 2 EAccessViolation seen here in TreeSize V4.3.1, 1 in V4.4.0 (Write of address 00000000) - AbsoluteTop := CurrentTop; - end; - Inc(Index); - end; - - Inc(CurrentTop, NodeHeight[CurrentNode]); - // Advance to next visible node. - Temp := GetNextVisibleNoInit(CurrentNode, True); - // If there is no further node then stop the loop. - if (Temp = nil) then // CHANGED: 17.09.2013 - Veit Zimmermann - Break; // CHANGED: 17.09.2013 - Veit Zimmermann - - CurrentNode := Temp; - Inc(EntryCount); - end; - end; - // Finalize the position cache so no nil entry remains there. - if not (tsStopValidation in FStates) and (Integer(Index) <= High(FPositionCache)) then - begin - SetLength(FPositionCache, Index + 1); - with FPositionCache[Index] do - begin - Node := CurrentNode; - AbsoluteTop := CurrentTop; - end; - end; - end; - - Result := (EntryCount > 0) and not (tsStopValidation in FStates); - - // In variable node height mode it might have happend that some or all of the nodes have been adjusted in their - // height. During validation updates of the scrollbars is disabled so let's do this here. - if Result and (toVariableNodeHeight in FOptions.FMiscOptions) then - begin - TThread.Queue(nil, procedure begin UpdateScrollBars(True) end); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DragAndDrop(AllowedEffects: Dword; const DataObject: IDataObject; var DragEffect: Integer); -var - lDragEffect: DWord; // required for type compatibility with SHDoDragDrop -begin - if IsWinVistaOrAbove then - begin - lDragEffect := DWord(DragEffect); - SHDoDragDrop(Self.Handle, DataObject, nil, AllowedEffects, lDragEffect); // supports drag hints on Windows Vista and later - DragEffect := Integer(lDragEffect); - end - else - Winapi.ActiveX.DoDragDrop(DataObject, DragManager as IDropSource, AllowedEffects, DragEffect); - end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DragCanceled; - -// Does some housekeeping for VCL drag'n drop; - -begin - inherited; - - DragFinished; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.DragDrop(const DataObject: IDataObject; KeyState: Integer; Pt: TPoint; - var Effect: Integer): HResult; - -var - Shift: TShiftState; - EnumFormat: IEnumFormatEtc; - Fetched: Integer; - OLEFormat: TFormatEtc; - Formats: TFormatArray; - -begin - StopTimer(ExpandTimer); - StopTimer(ScrollTimer); - DoStateChange([], [tsScrollPending, tsScrolling]); - Formats := nil; - - // Ask explicitly again whether the action is allowed. Otherwise we may accept a drop which is intentionally not - // allowed but cannot be prevented by the application because when the tree was scrolling while dropping - // no DragOver event is created by the OLE subsystem. - Result := DragOver(DragManager.DragSource, KeyState, dsDragMove, Pt, Effect); - try - if (Result <> NOERROR) or ((Effect and not DROPEFFECT_SCROLL) = DROPEFFECT_NONE) then - Result := E_FAIL - else - begin - try - Shift := KeysToShiftState(KeyState); - if tsRightButtonDown in FStates then - Include(Shift, ssRight) - else if tsMiddleButtonDown in FStates then - Include(Shift, ssMiddle) - else - Include(Shift, ssLeft); - Pt := ScreenToClient(Pt); - // Determine which formats we can get and pass them along with the data object to the drop handler. - Result := DataObject.EnumFormatEtc(DATADIR_GET, EnumFormat); - if Failed(Result) then - Abort; - Result := EnumFormat.Reset; - if Failed(Result) then - Abort; - // create a list of available formats - while EnumFormat.Next(1, OLEFormat, @Fetched) = S_OK do - begin - SetLength(Formats, Length(Formats) + 1); - Formats[High(Formats)] := OLEFormat.cfFormat; - end; - DoDragDrop(DragManager.DragSource, DataObject, Formats, Shift, Pt, Effect, FLastDropMode); - except - // An unhandled exception here leaks memory. - Application.HandleException(Self); - Result := E_UNEXPECTED; - end; - end; - finally - if Assigned(FDropTargetNode) then - begin - InvalidateNode(FDropTargetNode); - FDropTargetNode := nil; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.DragEnter(KeyState: Integer; Pt: TPoint; var Effect: Integer): HResult; - -// callback routine for the drop target interface - -var - Shift: TShiftState; - Accept: Boolean; - R: TRect; - HitInfo: THitInfo; - -begin - try - // Determine acceptance of drag operation and reset scroll start time. - FDragScrollStart := 0; - - Shift := KeysToShiftState(KeyState); - if tsLeftButtonDown in FStates then - Include(Shift, ssLeft); - if tsMiddleButtonDown in FStates then - Include(Shift, ssMiddle); - if tsRightButtonDown in FStates then - Include(Shift, ssRight); - Pt := ScreenToClient(Pt); - Effect := SuggestDropEffect(DragManager.DragSource, Shift, Pt, Effect); - Accept := DoDragOver(DragManager.DragSource, Shift, dsDragEnter, Pt, FLastDropMode, Effect); - if not Accept then - Effect := DROPEFFECT_NONE - else - begin - // Set initial drop target node and drop mode. - GetHitTestInfoAt(Pt.X, Pt.Y, True, HitInfo); - if Assigned(HitInfo.HitNode) then - begin - FDropTargetNode := HitInfo.HitNode; - R := GetDisplayRect(HitInfo.HitNode, FHeader.MainColumn, False); - if (hiOnItemLabel in HitInfo.HitPositions) or ((hiOnItem in HitInfo.HitPositions) and - ((toFullRowDrag in FOptions.FMiscOptions) or (toFullRowSelect in FOptions.FSelectionOptions)))then - FLastDropMode := dmOnNode - else - if ((R.Top + R.Bottom) div 2) > Pt.Y then - FLastDropMode := dmAbove - else - FLastDropMode := dmBelow; - end - else - FLastDropMode := dmNowhere; - end; - - // If the drag source is a virtual tree then we know how to control the drag image - // and can show it even if the source is not the target tree. - // This is only necessary if we cannot use the drag image helper interfaces. - if not DragManager.DropTargetHelperSupported and Assigned(DragManager.DragSource) then - DragManager.DragSource.FDragImage.ShowDragImage; - Result := NOERROR; - except - Result := E_UNEXPECTED; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DragFinished; - -// Called by DragCancelled or EndDrag to make up for the still missing mouse button up messages. -// These are important for such important things like popup menus. - -var - P: TPoint; - -begin - if [tsOLEDragging, tsVCLDragPending, tsVCLDragging, tsVCLDragFinished] * FStates = [] then - Exit; - - DoStateChange([], [tsVCLDragPending, tsVCLDragging, tsUserDragObject, tsVCLDragFinished]); - - GetCursorPos(P); - P := ScreenToClient(P); - if tsRightButtonDown in FStates then - Perform(WM_RBUTTONUP, 0, LPARAM(Integer(PointToSmallPoint(P)))) - else - if tsMiddleButtonDown in FStates then - Perform(WM_MBUTTONUP, 0, LPARAM(Integer(PointToSmallPoint(P)))) - else - Perform(WM_LBUTTONUP, 0, LPARAM(Integer(PointToSmallPoint(P)))); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DragLeave; - -var - Effect: Integer; - -begin - StopTimer(ExpandTimer); - - if not DragManager.DropTargetHelperSupported and Assigned(DragManager.DragSource) then - DragManager.DragSource.FDragImage.HideDragImage; - - if Assigned(FDropTargetNode) then - begin - InvalidateNode(FDropTargetNode); - FDropTargetNode := nil; - end; - UpdateWindow(Handle); - - Effect := 0; - DoDragOver(nil, [], dsDragLeave, Point(0, 0), FLastDropMode, Effect); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.DragOver(Source: TObject; KeyState: Integer; DragState: TDragState; Pt: TPoint; - var Effect: Integer): HResult; - -// callback routine for the drop target interface - -var - Shift: TShiftState; - Accept, - DragImageWillMove, - WindowScrolled: Boolean; - OldR, R: TRect; - NewDropMode: TDropMode; - HitInfo: THitInfo; - DragPos: TPoint; - Tree: TBaseVirtualTree; - LastNode: PVirtualNode; - DeltaX, - DeltaY: Integer; - ScrollOptions: TScrollUpdateOptions; - -begin - if not DragManager.DropTargetHelperSupported and (Source is TBaseVirtualTree) then - begin - Tree := Source as TBaseVirtualTree; - ScrollOptions := [suoUpdateNCArea]; - end - else - begin - Tree := nil; - ScrollOptions := DefaultScrollUpdateFlags; - end; - - try - DragPos := Pt; - Pt := ScreenToClient(Pt); - - // Check if we have to scroll the client area. - FScrollDirections := DetermineScrollDirections(Pt.X, Pt.Y); - DeltaX := 0; - DeltaY := 0; - if FScrollDirections <> [] then - begin - // Determine amount to scroll. - if sdUp in FScrollDirections then - begin - DeltaY := Min(FScrollBarOptions.FIncrementY, ClientHeight); - if FOffsetY = 0 then - Exclude(FScrollDirections, sdUp); - end; - if sdDown in FScrollDirections then - begin - DeltaY := -Min(FScrollBarOptions.FIncrementY, ClientHeight); - if (ClientHeight - FOffsetY) = Integer(FRangeY) then - Exclude(FScrollDirections, sdDown); - end; - if sdLeft in FScrollDirections then - begin - DeltaX := FScrollBarOptions.FIncrementX; - if FEffectiveOffsetX = 0 then - Exclude(FScrollDirections, sdleft); - end; - if sdRight in FScrollDirections then - begin - DeltaX := -FScrollBarOptions.FIncrementX; - if (ClientWidth + FEffectiveOffsetX) = Integer(FRangeX) then - Exclude(FScrollDirections, sdRight); - end; - WindowScrolled := DoSetOffsetXY(Point(FOffsetX + DeltaX, FOffsetY + DeltaY), ScrollOptions, nil); - end - else - WindowScrolled := False; - - // Determine acceptance of drag operation as well as drag target. - Shift := KeysToShiftState(KeyState); - if tsLeftButtonDown in FStates then - Include(Shift, ssLeft); - if tsMiddleButtonDown in FStates then - Include(Shift, ssMiddle); - if tsRightButtonDown in FStates then - Include(Shift, ssRight); - GetHitTestInfoAt(Pt.X, Pt.Y, True, HitInfo); - - if Assigned(HitInfo.HitNode) then - R := GetDisplayRect(HitInfo.HitNode, NoColumn, False) - else - R := Rect(0, 0, 0, 0); - NewDropMode := DetermineDropMode(Pt, HitInfo, R); - - if Assigned(Tree) then - DragImageWillMove := Tree.FDragImage.WillMove(DragPos) - else - DragImageWillMove := False; - - if (HitInfo.HitNode <> FDropTargetNode) or (FLastDropMode <> NewDropMode) then - begin - // Something in the tree will change. This requires to update the screen and/or the drag image. - FLastDropMode := NewDropMode; - if HitInfo.HitNode <> FDropTargetNode then - begin - StopTimer(ExpandTimer); - // The last target node is needed for the rectangle determination but must already be set for - // the recapture call, hence it must be stored somewhere. - LastNode := FDropTargetNode; - FDropTargetNode := HitInfo.HitNode; - // In order to show a selection rectangle a column must be focused. - if FFocusedColumn <= NoColumn then - FFocusedColumn := FHeader.MainColumn; - - if Assigned(LastNode) and Assigned(FDropTargetNode) then - begin - // Optimize the case that the selection moved between two nodes. - OldR := GetDisplayRect(LastNode, NoColumn, False); - UnionRect(R, R, OldR); - if Assigned(Tree) then - begin - if WindowScrolled then - UpdateWindowAndDragImage(Tree, ClientRect, True, not DragImageWillMove) - else - UpdateWindowAndDragImage(Tree, R, False, not DragImageWillMove); - end - else - InvalidateRect(Handle, @R, False); - end - else - begin - if Assigned(LastNode) then - begin - // Repaint last target node. - OldR := GetDisplayRect(LastNode, NoColumn, False); - if Assigned(Tree) then - begin - if WindowScrolled then - UpdateWindowAndDragImage(Tree, ClientRect, WindowScrolled, not DragImageWillMove) - else - UpdateWindowAndDragImage(Tree, OldR, False, not DragImageWillMove); - end - else - InvalidateRect(Handle, @OldR, False); - end - else - begin - if Assigned(Tree) then - begin - if WindowScrolled then - UpdateWindowAndDragImage(Tree, ClientRect, WindowScrolled, not DragImageWillMove) - else - UpdateWindowAndDragImage(Tree, R, False, not DragImageWillMove); - end - else - InvalidateRect(Handle, @R, False); - end; - end; - - // Start auto expand timer if necessary. - if (toAutoDropExpand in FOptions.FAutoOptions) and Assigned(FDropTargetNode) and - (vsHasChildren in FDropTargetNode.States) then - SetTimer(Handle, ExpandTimer, FAutoExpandDelay, nil); - end - else - begin - // Only the drop mark position changed so invalidate the current drop target node. - if Assigned(Tree) then - begin - if WindowScrolled then - UpdateWindowAndDragImage(Tree, ClientRect, WindowScrolled, not DragImageWillMove) - else - UpdateWindowAndDragImage(Tree, R, False, not DragImageWillMove); - end - else - InvalidateRect(Handle, @R, False); - end; - end - else - begin - // No change in the current drop target or drop mode. This might still mean horizontal or vertical scrolling. - if Assigned(Tree) and ((DeltaX <> 0) or (DeltaY <> 0)) then - UpdateWindowAndDragImage(Tree, ClientRect, WindowScrolled, not DragImageWillMove); - end; - - Update; - - if Assigned(Tree) and DragImageWillMove then - Tree.FDragImage.DragTo(DragPos, False); - - Effect := SuggestDropEffect(Source, Shift, Pt, Effect); - Accept := DoDragOver(Source, Shift, DragState, Pt, FLastDropMode, Effect); - if not Accept then - Effect := DROPEFFECT_NONE; - if WindowScrolled then - Effect := Effect or Integer(DROPEFFECT_SCROLL); - Result := NOERROR; - except - Result := E_UNEXPECTED; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DrawDottedHLine(const PaintInfo: TVTPaintInfo; Left, Right, Top: Integer); - -// Draws a horizontal line with alternating pixels (this style is not supported for pens under Win9x). - -var - R: TRect; - -begin - with PaintInfo, Canvas do - begin - Brush.Color := FColors.BackGroundColor; - R := Rect(Min(Left, Right), Top, Max(Left, Right) + 1, Top + 1); - Winapi.Windows.FillRect(Handle, R, FDottedBrush - ); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DrawDottedVLine(const PaintInfo: TVTPaintInfo; Top, Bottom, Left: Integer; UseSelectedBkColor: Boolean = False); - -// Draws a horizontal line with alternating pixels (this style is not supported for pens under Win9x). - -var - R: TRect; - -begin - with PaintInfo, Canvas do - begin - if UseSelectedBkColor then - begin - if Focused or (toPopupMode in FOptions.FPaintOptions) then - Brush.Color := FColors.FocusedSelectionColor - else - Brush.Color := FColors.UnfocusedSelectionColor; - end - else - Brush.Color := FColors.BackGroundColor; - R := Rect(Left, Min(Top, Bottom), Left + 1, Max(Top, Bottom) + 1); - Winapi.Windows.FillRect(Handle, R, FDottedBrush); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.EndOperation(OperationKind: TVTOperationKind); - -// Called to indicate that a long-running operation has finished. - -begin - Assert(FOperationCount > 0, 'EndOperation must not be called when no operation in progress.'); - Dec(FOperationCount); - DoEndOperation(OperationKind); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.EnsureNodeFocused(); -begin - if FocusedNode = nil then - FocusedNode := Self.GetFirstSelected(); - if FocusedNode = nil then - FocusedNode := Self.GetFirstVisible(); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.EnsureNodeSelected(); -begin - if (toAlwaysSelectNode in TreeOptions.SelectionOptions) and not IsEmpty then - begin - if (SelectedCount = 0) and not SelectionLocked then - begin - if not Assigned(FNextNodeToSelect) then - begin - FNextNodeToSelect := GetFirstVisible; - // Avoid selecting a disabled node, see #954 - while Assigned(FNextNodeToSelect) and IsDisabled[FNextNodeToSelect] do - FNextNodeToSelect := GetNextVisible(FNextNodeToSelect); - end; - Selected[FNextNodeToSelect] := True; - Self.ScrollIntoView(Self.GetFirstSelected, False); - end;// if nothing selected - EnsureNodeFocused(); - end;//if toAlwaysSelectNode -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.FindNodeInSelection(P: PVirtualNode; var Index: Integer; LowBound, - HighBound: Integer): Boolean; - -// Search routine to find a specific node in the selection array. -// LowBound and HighBound determine the range in which to search the node. -// Either value can be -1 to denote the maximum range otherwise LowBound must be less or equal HighBound. - -var - L, H, - I: Integer; - -begin - Result := False; - L := 0; - if LowBound >= 0 then - L := LowBound; - H := FSelectionCount - 1; - if HighBound >= 0 then - H := HighBound; - while L <= H do - begin - I := (L + H) shr 1; - if PAnsiChar(FSelection[I]) < PAnsiChar(P) then - L := I + 1 - else - begin - H := I - 1; - if FSelection[I] = P then - begin - Result := True; - L := I; - end; - end; - end; - Index := L; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.FinishChunkHeader(Stream: TStream; StartPos, EndPos: Integer); - -// used while streaming out a node to finally write out the size of the chunk - -var - Size: Integer; - -begin - // seek back to the second entry in the chunk header - Stream.Position := StartPos + SizeOf(Size); - // determine size of chunk without the chunk header - Size := EndPos - StartPos - SizeOf(TChunkHeader); - // write the size... - Stream.Write(Size, SizeOf(Size)); - // ... and seek to the last endposition - Stream.Position := EndPos; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.FontChanged(AFont: TObject); - -// Little helper function for font changes (as they are not tracked in TBitmap/TCanvas.OnChange). - -begin - FFontChanged := True; - if Assigned(FOldFontChange) then - FOldFontChange(AFont); - //if not (tsPainting in TreeStates) then AutoScale(); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetBorderDimensions: TSize; - -// Returns the overall width of the current window border, depending on border styles. -// Note: these numbers represent the system's standards not special properties, which can be set for TWinControl -// (e.g. bevels, border width). - -var - Styles: Integer; - -begin - Result.cx := 0; - Result.cy := 0; - - Styles := GetWindowLong(Handle, GWL_STYLE); - if (Styles and WS_BORDER) <> 0 then - begin - Dec(Result.cx); - Dec(Result.cy); - end; - if (Styles and WS_THICKFRAME) <> 0 then - begin - Dec(Result.cx, GetSystemMetrics(SM_CXFIXEDFRAME)); - Dec(Result.cy, GetSystemMetrics(SM_CYFIXEDFRAME)); - end; - Styles := GetWindowLong(Handle, GWL_EXSTYLE); - if (Styles and WS_EX_CLIENTEDGE) <> 0 then - begin - Dec(Result.cx, GetSystemMetrics(SM_CXEDGE)); - Dec(Result.cy, GetSystemMetrics(SM_CYEDGE)); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetCheckImage(Node: PVirtualNode; ImgCheckType: TCheckType = ctNone; ImgCheckState: - TCheckState = csUncheckedNormal; ImgEnabled: Boolean = True): Integer; - -// Determines the index into the check image list for the given node depending on the check type -// and enabled state. - -const - // Four dimensional array consisting of image indices for the check type, the check state, the enabled state and the - // hot state. - CheckStateToCheckImage: array[ctCheckBox..ctButton, csUncheckedNormal..csMixedPressed, Boolean, Boolean] of Integer = ( - // ctCheckBox, ctTriStateCheckBox - ( - // csUncheckedNormal (disabled [not hot, hot], enabled [not hot, hot]) - ((ckCheckUncheckedDisabled, ckCheckUncheckedDisabled), (ckCheckUncheckedNormal, ckCheckUncheckedHot)), - // csUncheckedPressed (disabled [not hot, hot], enabled [not hot, hot]) - ((ckCheckUncheckedDisabled, ckCheckUncheckedDisabled), (ckCheckUncheckedPressed, ckCheckUncheckedPressed)), - // csCheckedNormal - ((ckCheckCheckedDisabled, ckCheckCheckedDisabled), (ckCheckCheckedNormal, ckCheckCheckedHot)), - // csCheckedPressed - ((ckCheckCheckedDisabled, ckCheckCheckedDisabled), (ckCheckCheckedPressed, ckCheckCheckedPressed)), - // csMixedNormal - ((ckCheckMixedDisabled, ckCheckMixedDisabled), (ckCheckMixedNormal, ckCheckMixedHot)), - // csMixedPressed - ((ckCheckMixedDisabled, ckCheckMixedDisabled), (ckCheckMixedPressed, ckCheckMixedPressed)) - ), - // ctRadioButton - ( - // csUncheckedNormal (disabled [not hot, hot], enabled [not hot, hot]) - ((ckRadioUncheckedDisabled, ckRadioUncheckedDisabled), (ckRadioUncheckedNormal, ckRadioUncheckedHot)), - // csUncheckedPressed (disabled [not hot, hot], enabled [not hot, hot]) - ((ckRadioUncheckedDisabled, ckRadioUncheckedDisabled), (ckRadioUncheckedPressed, ckRadioUncheckedPressed)), - // csCheckedNormal - ((ckRadioCheckedDisabled, ckRadioCheckedDisabled), (ckRadioCheckedNormal, ckRadioCheckedHot)), - // csCheckedPressed - ((ckRadioCheckedDisabled, ckRadioCheckedDisabled), (ckRadioCheckedPressed, ckRadioCheckedPressed)), - // csMixedNormal (should never appear with ctRadioButton) - ((ckCheckMixedDisabled, ckCheckMixedDisabled), (ckCheckMixedNormal, ckCheckMixedHot)), - // csMixedPressed (should never appear with ctRadioButton) - ((ckCheckMixedDisabled, ckCheckMixedDisabled), (ckCheckMixedPressed, ckCheckMixedPressed)) - ), - // ctButton - ( - // csUncheckedNormal (disabled [not hot, hot], enabled [not hot, hot]) - ((ckButtonDisabled, ckButtonDisabled), (ckButtonNormal, ckButtonHot)), - // csUncheckedPressed (disabled [not hot, hot], enabled [not hot, hot]) - ((ckButtonDisabled, ckButtonDisabled), (ckButtonPressed, ckButtonPressed)), - // csCheckedNormal - ((ckButtonDisabled, ckButtonDisabled), (ckButtonNormal, ckButtonHot)), - // csCheckedPressed - ((ckButtonDisabled, ckButtonDisabled), (ckButtonPressed, ckButtonPressed)), - // csMixedNormal (should never appear with ctButton) - ((ckCheckMixedDisabled, ckCheckMixedDisabled), (ckCheckMixedNormal, ckCheckMixedHot)), - // csMixedPressed (should never appear with ctButton) - ((ckCheckMixedDisabled, ckCheckMixedDisabled), (ckCheckMixedPressed, ckCheckMixedPressed)) - ) - ); - -var - IsHot: Boolean; - -begin - if Assigned(Node) then - begin - ImgCheckType := Node.CheckType; - ImgCheckState := GetCheckState(Node); - ImgEnabled := not (vsDisabled in Node.States) and Self.Enabled; - - IsHot := Node = FCurrentHotNode; - end - else - IsHot := False; - - if ImgCheckState.IsDisabled then begin // disabled image? - // We need to use disabled images, so map ImgCheckState value from disabled to normal, as disabled state is expressed by ImgEnabled. - ImgEnabled := False; - ImgCheckState := ImgCheckState.GetEnabled(); - end;//if - - if ImgCheckType = ctTriStateCheckBox then - ImgCheckType := ctCheckBox; - if IsHot and (ImgCheckState in [csCheckedNormal, csUncheckedNormal]) and (GetKeyState(VK_LBUTTON) < 0) and (hiOnItemCheckbox in FLastHitInfo.HitPositions) then - Inc(ImgCheckState); // Advance to pressed state - - if ImgCheckType = ctNone then - Result := -1 - else - Result := CheckStateToCheckImage[ImgCheckType, ImgCheckState, ImgEnabled, IsHot]; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetColumnClass: TVirtualTreeColumnClass; - -begin - Result := TVirtualTreeColumn; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetHeaderClass: TVTHeaderClass; - -begin - Result := TVTHeader; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetHintWindowClass: THintWindowClass; - -// Returns the default hint window class used for the tree. Descendants can override it to use their own classes. - -begin - Result := TVirtualTreeHintWindow; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.GetImageIndex(var Info: TVTPaintInfo; Kind: TVTImageKind; InfoIndex: TVTImageInfoIndex); - -// Retrieves the image index and an eventual customized image list for drawing. - -var - CustomImages: TCustomImageList; - -begin - with Info do - begin - ImageInfo[InfoIndex].Index := -1; - ImageInfo[InfoIndex].Ghosted := False; - - CustomImages := DoGetImageIndex(Node, Kind, Column, ImageInfo[InfoIndex].Ghosted, ImageInfo[InfoIndex].Index); - if Assigned(CustomImages) then - ImageInfo[InfoIndex].Images := CustomImages - end; -end; - -function TBaseVirtualTree.GetImageSize(Node: PVirtualNode; Kind: TVTImageKind = TVTImageKind.ikNormal; Column: TColumnIndex = 0; IncludePadding: Boolean = True): TSize; - -// Determines whether the given node has got an image of the given kind in the given column. -// Returns the size of the image, or (0,0) if no image is available -// The given node will be implicitly initialized if needed. - -var - Ghosted: Boolean; - Index: TImageIndex; - lImageList: TCustomImageList; -begin - if not Assigned(OnGetImageIndexEx) and (((Kind = TVTImageKind.ikNormal) and not Assigned(fImages)) - or ((Kind = TVTImageKind.ikState) and not Assigned(fStateImages))) then - begin - Result.cx := 0; - Result.cy := 0; - end; - if not (vsInitialized in Node.States) then - InitNode(Node); - Index := -1; - Ghosted := False; - lImageList := DoGetImageIndex(Node, Kind, Column, Ghosted, Index); - if Index >= 0 then begin - if IncludePadding then - Result.cx := lImageList.Width + ScaledPixels(2) - else - Result.cx := lImageList.Width; - Result.cy := lImageList.Height; - end - else begin - Result.cx := 0; - Result.cy := 0; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.IsEmpty: Boolean; -begin - Result := (Self.ChildCount[nil] = 0); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetNodeImageSize(Node: PVirtualNode): TSize; - - // Returns the size of an image - // Override if you need different sized images for certain nodes. -begin - Result := GetImageSize(Node); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetMaxRightExtend(): Cardinal; - -// Determines the maximum with of the currently visible part of the tree, depending on the length -// of the node texts. This method is used for determining the horizontal scroll range if no columns are used. - -var - Node, - NextNode: PVirtualNode; - TopPosition: Integer; - CurrentWidth: Integer; - -begin - Node := GetNodeAt(0, 0, True, TopPosition); - Result := 0; - if not Assigned(Node) then - exit; - - while Assigned(Node) do - begin - if not (vsInitialized in Node.States) then - InitNode(Node); - CurrentWidth := GetOffset(TVTElement.ofsRightOfText, Node); - if Integer(Result) < (CurrentWidth) then - Result := CurrentWidth; - Inc(TopPosition, NodeHeight[Node]); - if TopPosition > Height then - Break; - - // Get next visible node and update left node position. - NextNode := GetNextVisible(Node, True); - if NextNode = nil then - Break; - Node := NextNode; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.GetNativeClipboardFormats(var Formats: TFormatEtcArray); - -// Returns the supported clipboard formats of the tree. - -begin - TClipboardFormatList.EnumerateFormats(TVirtualTreeClass(ClassType), Formats, FClipboardFormats); - // Ask application/descendants for self defined formats. - DoGetUserClipboardFormats(Formats); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetOperationCanceled; - -begin - Result := FOperationCanceled and (FOperationCount > 0); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetOptionsClass: TTreeOptionsClass; - -begin - Result := TCustomVirtualTreeOptions; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetTreeFromDataObject(const DataObject: IDataObject): TBaseVirtualTree; - -// Returns the owner/sender of the given data object by means of a special clipboard format -// or nil if the sender is in another process or no virtual tree at all. - -var - Medium: TStgMedium; - Data: PVTReference; - -begin - Result := nil; - if Assigned(DataObject) then - begin - StandardOLEFormat.cfFormat := CF_VTREFERENCE; - if DataObject.GetData(StandardOLEFormat, Medium) = S_OK then - begin - Data := GlobalLock(Medium.hGlobal); - if Assigned(Data) then - begin - if Data.Process = GetCurrentProcessID then - Result := Data.Tree; - GlobalUnlock(Medium.hGlobal); - end; - ReleaseStgMedium(Medium); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.HandleHotTrack(X, Y: Integer); - -// Updates the current "hot" node. - -var - HitInfo: THitInfo; - CheckPositions: THitPositions; - ButtonIsHit, - DoInvalidate: Boolean; - oldHotNode : PVirtualNode; -begin - if not IsMouseCursorVisible then - begin - if Assigned(FCurrentHotNode) then - begin - InvalidateNode(FCurrentHotNode); - FCurrentHotNode := nil; - end; - Exit; - end;//if not IsMouseCursorVisible - - DoInvalidate := False; - oldHotNode := FCurrentHotNode; - // Get information about the hit. - GetHitTestInfoAt(X, Y, True, HitInfo); - - // Only make the new node being "hot" if its label is hit or full row selection is enabled. - CheckPositions := [hiOnItemLabel, hiOnItemCheckbox]; - - // If running under Windows Vista using the explorer theme hitting the buttons makes the node hot, too. - if tsUseExplorerTheme in FStates then - Include(CheckPositions, hiOnItemButtonExact); - - if (CheckPositions * HitInfo.HitPositions = []) and - (not (toFullRowSelect in FOptions.FSelectionOptions) or (hiNowhere in HitInfo.HitPositions)) then - FCurrentHotNode := nil - else - FCurrentHotNode := HitInfo.HitNode; - if (FCurrentHotNode <> oldHotNode) or (HitInfo.HitColumn <> FCurrentHotColumn) then - begin - DoInvalidate := (toHotTrack in FOptions.PaintOptions) or (toCheckSupport in FOptions.FMiscOptions) or (oldHotNode <> FCurrentHotNode); - DoHotChange(oldHotNode, HitInfo.HitNode); - if Assigned(oldHotNode) and DoInvalidate then - InvalidateNode(oldHotNode); - FCurrentHotColumn := HitInfo.HitColumn; - end; - - ButtonIsHit := (hiOnItemButtonExact in HitInfo.HitPositions); - if Assigned(HitInfo.HitNode) and ((FHotNodeButtonHit <> ButtonIsHit) or (FCurrentHotNode <> oldHotNode) or DoInvalidate) then - begin - FHotNodeButtonHit := ButtonIsHit; - InvalidateNode(HitInfo.HitNode); - end - else - if not Assigned(HitInfo.HitNode) then - FHotNodeButtonHit := False; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.HandleIncrementalSearch(CharCode: Word); - -var - Run, Stop: PVirtualNode; - GetNextNode: TGetNextNodeProc; - NewSearchText: string; - SingleLetter, - PreviousSearch: Boolean; // True if VK_BACK was sent. - SearchDirection: TVTSearchDirection; - - //--------------- local functions ------------------------------------------- - - procedure SetupNavigation; - - // If the search buffer is empty then we start searching with the next node after the last one, otherwise - // we continue with the last one. Node navigation function is set up too here, to avoid frequent checks. - - var - FindNextNode: Boolean; - - begin - FindNextNode := (Length(FSearchBuffer) = 0) or (Run = nil) or SingleLetter or PreviousSearch; - case FIncrementalSearch of - isVisibleOnly: - if SearchDirection = sdForward then - begin - GetNextNode := GetNextVisible; - if FindNextNode then - begin - if Run = nil then - Run := GetFirstVisible(nil, True) - else - begin - Run := GetNextVisible(Run, True); - // Do wrap around. - if Run = nil then - Run := GetFirstVisible(nil, True); - end; - end; - end - else - begin - GetNextNode := GetPreviousVisible; - if FindNextNode then - begin - if Run = nil then - Run := GetLastVisible(nil, True) - else - begin - Run := GetPreviousVisible(Run, True); - // Do wrap around. - if Run = nil then - Run := GetLastVisible(nil, True); - end; - end; - end; - isInitializedOnly: - if SearchDirection = sdForward then - begin - GetNextNode := GetNextNoInit; - if FindNextNode then - begin - if Run = nil then - Run := GetFirstNoInit - else - begin - Run := GetNextNoInit(Run); - // Do wrap around. - if Run = nil then - Run := GetFirstNoInit; - end; - end; - end - else - begin - GetNextNode := GetPreviousNoInit; - if FindNextNode then - begin - if Run = nil then - Run := GetLastNoInit - else - begin - Run := GetPreviousNoInit(Run); - // Do wrap around. - if Run = nil then - Run := GetLastNoInit; - end; - end; - end; - else - // isAll - if SearchDirection = sdForward then - begin - GetNextNode := GetNext; - if FindNextNode then - begin - if Run = nil then - Run := GetFirst - else - begin - Run := GetNext(Run); - // Do wrap around. - if Run = nil then - Run := GetFirst; - end; - end; - end - else - begin - GetNextNode := GetPrevious; - if FindNextNode then - begin - if Run = nil then - Run := GetLast - else - begin - Run := GetPrevious(Run); - // Do wrap around. - if Run = nil then - Run := GetLast; - end; - end; - end; - end; - end; - - //--------------------------------------------------------------------------- - - function CodePageFromLocale(Language: LCID): Integer; - - // Determines the code page for a given locale. - // Unfortunately there is no easier way than this, currently. - - var - Buf: array[0..6] of Char; - - begin - GetLocaleInfo(Language, LOCALE_IDEFAULTANSICODEPAGE, Buf, 6); - Result := StrToIntDef(Buf, GetACP); - end; - - //--------------------------------------------------------------------------- - - function KeyUnicode(C: Char): WideChar; - // Converts the given character into its corresponding Unicode character - // depending on the active keyboard layout. - begin - Result := C; //!!!!!! - end; - - //--------------- end local functions --------------------------------------- - -var - FoundMatch: Boolean; - NewChar: WideChar; - -begin - StopTimer(SearchTimer); - - if FIncrementalSearch <> isNone then - begin - if CharCode <> 0 then - begin - DoStateChange([tsIncrementalSearching]); - - // Convert the given virtual key code into a Unicode character based on the current locale. - NewChar := KeyUnicode(Char(CharCode)); - PreviousSearch := NewChar = WideChar(VK_BACK); - // We cannot do a search with an empty search buffer. - if not PreviousSearch or (FSearchBuffer <> '') then - begin - // Determine which method to use to advance nodes and the start node to search from. - case FSearchStart of - ssAlwaysStartOver: - Run := nil; - ssFocusedNode: - Run := FFocusedNode; - else // ssLastHit - Run := FLastSearchNode; - end; - - // Make sure the start node corresponds to the search criterion. - if Assigned(Run) then - begin - case FIncrementalSearch of - isInitializedOnly: - if not (vsInitialized in Run.States) then - Run := nil; - isVisibleOnly: - if not FullyVisible[Run] or IsEffectivelyFiltered[Run] then - Run := nil; - end; - end; - Stop := Run; - - // VK_BACK temporarily changes search direction to opposite mode. - if PreviousSearch then - begin - if SearchDirection = sdBackward then - SearchDirection := sdForward - else - SearchDirection := sdBackward; - end - else - SearchDirection := FSearchDirection; - // The "single letter mode" is used to advance quickly from node to node when pressing the same key several times. - SingleLetter := (Length(FSearchBuffer) = 1) and not PreviousSearch and (FSearchBuffer[1] = NewChar); - // However if the current hit (if there is one) would fit also with a repeated character then - // don't use single letter mode. - if SingleLetter and (DoIncrementalSearch(Run, FSearchBuffer + NewChar) = 0) then - SingleLetter := False; - SetupNavigation; - FoundMatch := False; - - if Assigned(Run) then - begin - if SingleLetter then - NewSearchText := FSearchBuffer - else - if PreviousSearch then - begin - SetLength(FSearchBuffer, Length(FSearchBuffer) - 1); - NewSearchText := FSearchBuffer; - end - else - NewSearchText := FSearchBuffer + NewChar; - - repeat - if DoIncrementalSearch(Run, NewSearchText) = 0 then - begin - FoundMatch := True; - Break; - end; - - // Advance to next node if we have not found a match. - Run := GetNextNode(Run); - // Do wrap around start or end of tree. - if (Run <> Stop) and (Run = nil) then - SetupNavigation; - until Run = Stop; - end; - - if FoundMatch then - begin - ClearSelection; - FSearchBuffer := NewSearchText; - FLastSearchNode := Run; - FocusedNode := Run; - Selected[Run] := True; - FLastSearchNode := Run; - end - else - // Play an acoustic signal if nothing could be found but don't beep if only the currently - // focused node matches. - if Assigned(Run) and (DoIncrementalSearch(Run, NewSearchText) <> 0) then - Beep; - end; - end; - - // Restart search timeout interval. - SetTimer(Handle, SearchTimer, FSearchTimeout, nil); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.HandleMouseDblClick(var Message: TWMMouse; const HitInfo: THitInfo); - -var - NewCheckState: TCheckState; - Node: PVirtualNode; - MayEdit: Boolean; - -begin - MayEdit := not (tsEditing in FStates) and (toEditOnDblClick in FOptions.FMiscOptions); - if tsEditPending in FStates then - begin - StopTimer(EditTimer); - DoStateChange([], [tsEditPending]); - end; - - if not (tsEditing in FStates) or DoEndEdit then - begin - if HitInfo.HitColumn = FHeader.FColumns.FClickIndex then - DoColumnDblClick(HitInfo.HitColumn, KeysToShiftState(Message.Keys)); - - if HitInfo.HitNode <> nil then - DoNodeDblClick(HitInfo); - - Node := nil; - if (hiOnItem in HitInfo.HitPositions) and (HitInfo.HitColumn > NoColumn) and - (coFixed in FHeader.FColumns[HitInfo.HitColumn].FOptions) then - begin - if hiUpperSplitter in HitInfo.HitPositions then - Node := GetPreviousVisible(HitInfo.HitNode, True) - else - if hiLowerSplitter in HitInfo.HitPositions then - Node := HitInfo.HitNode; - end; - - if Assigned(Node) and (Node <> FRoot) and (toNodeHeightDblClickResize in FOptions.FMiscOptions) then - begin - if DoNodeHeightDblClickResize(Node, HitInfo.HitColumn, KeysToShiftState(Message.Keys), Point(Message.XPos, Message.YPos)) then - begin - SetNodeHeight(Node, FDefaultNodeHeight); - UpdateWindow(Handle); - MayEdit := False; - end; - end - else - if hiOnItemCheckBox in HitInfo.HitPositions then - begin - NewCheckState := DetermineNextCheckState(HitInfo.HitNode.CheckType, HitInfo.HitNode.CheckState); - if (ssLeft in KeysToShiftState(Message.Keys)) and DoChecking(HitInfo.HitNode, NewCheckState) then - begin - SetCheckStateForAll(NewCheckState, True); - MayEdit := False; - end; - end// if hiOnItemCheckBox - else - begin - if hiOnItemButton in HitInfo.HitPositions then - begin - ToggleNode(HitInfo.HitNode); - MayEdit := False; - end - else - begin - if toToggleOnDblClick in FOptions.FMiscOptions then - begin - if ((([hiOnItemButton, hiOnItemLabel, hiOnNormalIcon, hiOnStateIcon] * HitInfo.HitPositions) <> []) or - ((toFullRowSelect in FOptions.FSelectionOptions) and Assigned(HitInfo.HitNode))) then - begin - ToggleNode(HitInfo.HitNode); - MayEdit := False; - end; - end; - end; - end; - end; - - if MayEdit and Assigned(FFocusedNode) and (FFocusedNode = HitInfo.HitNode) and - (FFocusedColumn = HitInfo.HitColumn) and CanEdit(FFocusedNode, HitInfo.HitColumn) then - begin - DoStateChange([tsEditPending]); - FEditColumn := FFocusedColumn; - SetTimer(Handle, EditTimer, 0, nil); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.HandleMouseDown(var Message: TWMMouse; var HitInfo: THitInfo); - -// centralized mouse button down handling - -var - LastFocused: PVirtualNode; - Column: TColumnIndex; - ShiftState: TShiftState; - - // helper variables to shorten boolean equations/expressions - AutoDrag, // automatic (or allowed) drag start - IsLabelHit, // the node's caption or images are hit - IsCellHit, // for grid extension or full row select (but not check box, button) - IsAnyHit, // either IsHit or IsCellHit - IsHeightTracking, // height tracking - MultiSelect, // multiselection is enabled - ShiftEmpty, // ShiftState = [] - NodeSelected: Boolean; // the new node (if any) is selected - NewColumn: Boolean; // column changed - NewNode: Boolean; // Node changed. - NeedChangeEvent: Boolean; // change event is required for selection change - CanClear: Boolean; - NewCheckState: TCheckState; - AltPressed: Boolean; // Pressing the Alt key enables special processing for selection. - FullRowDrag: Boolean; // Start dragging anywhere within a node's bound. - NodeRect: TRect; - - //--------------- local functions ------------------------------------------- - - //Fix for issue: 310 whenever there is a need to invalidate a column, consider - //auto spanned columns if applicable - procedure invalidateWithAutoSpan(acolumn: TColumnIndex; anode: PVirtualNode); - var - NextColumn: Integer; - Dummy: TColumnIndex; - begin - if (not FHeader.UseColumns) or (not (toAutoSpanColumns in FOptions.FAutoOptions)) - or (acolumn = FHeader.MainColumn) then - begin - //no need to find auto spanned next columns - InvalidateColumn(acolumn); - exit; - end; - //invalidate auto spanned columns too - with FHeader.FColumns do //standard loop for auto span - begin - NextColumn := acolumn; - repeat - InvalidateColumn(NextColumn); - Dummy := GetNextVisibleColumn(NextColumn); - if (Dummy = InvalidColumn) or - not ColumnIsEmpty(anode, Dummy) - or - (Items[Dummy].BidiMode <> bdLeftToRight) then - Break; - NextColumn := Dummy; - until False; - end; - end; - - //--------------- end local functions --------------------------------------- - -begin - if IsEmpty then - Exit; // Nothing to do - if [tsWheelPanning, tsWheelScrolling] * FStates <> [] then - begin - StopWheelPanning; - Exit; - end; - - if tsEditPending in FStates then - begin - StopTimer(EditTimer); - DoStateChange([], [tsEditPending]); - end; - - FLastHitInfo := HitInfo; // Save for later use in OnNodeClick event, see issue #692 - if (tsEditing in FStates) then begin - if not DoEndEdit then - exit; - // Repeat the hit test as an OnEdited event might got triggered that could modify the tree. - GetHitTestInfoAt(Message.XPos, Message.YPos, True, HitInfo); - end;//if tsEditing - - // Focus change. Don't use the SetFocus method as this does not work for MDI Winapi.Windows. - if not Focused and CanFocus then - begin - Winapi.Windows.SetFocus(Handle); - // Repeat the hit test as an OnExit event might got triggered that could modify the tree. - GetHitTestInfoAt(Message.XPos, Message.YPos, True, HitInfo); - end; - - // Keep clicked column in case the application needs it. - FHeader.FColumns.FClickIndex := HitInfo.HitColumn; - - // Change column only if we have hit the node label. - if (hiOnItemLabel in HitInfo.HitPositions) or - (toFullRowSelect in FOptions.FSelectionOptions) or - (toGridExtensions in FOptions.FMiscOptions) then - begin - NewColumn := FFocusedColumn <> HitInfo.HitColumn; - if toExtendedFocus in FOptions.FSelectionOptions then - Column := HitInfo.HitColumn - else - Column := FHeader.MainColumn; - end - else - begin - NewColumn := False; - Column := FFocusedColumn; - end; - - if NewColumn and not FHeader.AllowFocus(Column) then - begin - NewColumn := False; - Column := FFocusedColumn; - end; - - NewNode := FFocusedNode <> HitInfo.HitNode; - - // Translate keys and filter out shift and control key. - ShiftState := KeysToShiftState(Message.Keys) * [ssShift, ssCtrl, ssAlt]; - if ssAlt in ShiftState then - begin - AltPressed := True; - // Remove the Alt key from the shift state. It is not meaningful there. - Exclude(ShiftState, ssAlt); - end - else - AltPressed := False; - - // Various combinations determine what states the tree enters now. - // We initialize shorthand variables to avoid the following expressions getting too large - // and to avoid repeative expensive checks. - IsLabelHit := not AltPressed and not (toSimpleDrawSelection in FOptions.FSelectionOptions) and - ((hiOnItemLabel in HitInfo.HitPositions) or (hiOnNormalIcon in HitInfo.HitPositions)); - - IsCellHit := not AltPressed and not IsLabelHit and Assigned(HitInfo.HitNode) and - ([hiOnItemButton, hiOnItemCheckBox, hiNoWhere] * HitInfo.HitPositions = []) and - ((toFullRowSelect in FOptions.FSelectionOptions) or - ((toGridExtensions in FOptions.FMiscOptions) and (HitInfo.HitColumn > NoColumn))); - - IsAnyHit := IsLabelHit or IsCellHit; - MultiSelect := toMultiSelect in FOptions.FSelectionOptions; - ShiftEmpty := ShiftState = []; - NodeSelected := IsAnyHit and (vsSelected in HitInfo.HitNode.States); - - // Determine the Drag behavior. - if MultiSelect and not (toDisableDrawSelection in FOptions.FSelectionOptions) then - begin - // We have MultiSelect and want to draw a selection rectangle. - // We will start a full row drag only in case a label was hit, - // otherwise a multi selection will start. - FullRowDrag := (toFullRowDrag in FOptions.FMiscOptions) and IsCellHit and - not (hiNowhere in HitInfo.HitPositions) and - (NodeSelected or (hiOnItemLabel in HitInfo.HitPositions) or (hiOnNormalIcon in HitInfo.HitPositions)); - end - else // No MultiSelect, hence we can start a drag anywhere in the row. - FullRowDrag := toFullRowDrag in FOptions.FMiscOptions; - - IsHeightTracking := (Message.Msg = WM_LBUTTONDOWN) and - (hiOnItem in HitInfo.HitPositions) and - ([hiUpperSplitter, hiLowerSplitter] * HitInfo.HitPositions <> []); - - // Dragging might be started in the inherited handler manually (which is discouraged for stability reasons) - // the test for manual mode is done below (after the focused node is set). - AutoDrag := ((DragMode = dmAutomatic) or Dragging) and (not IsCellHit or FullRowDrag); - - // Query the application to learn if dragging may start now (if set to dmManual). - if Assigned(HitInfo.HitNode) and not AutoDrag and (DragMode = dmManual) then - AutoDrag := DoBeforeDrag(HitInfo.HitNode, Column) and (FullRowDrag or IsLabelHit); - - // handle node height tracking - if IsHeightTracking then - begin - if hiUpperSplitter in HitInfo.HitPositions then - FHeightTrackNode := GetPreviousVisible(HitInfo.HitNode, True) - else - FHeightTrackNode := HitInfo.HitNode; - - if CanSplitterResizeNode(Point(Message.XPos, Message.YPos), FHeightTrackNode, HitInfo.HitColumn) then - begin - FHeightTrackColumn := HitInfo.HitColumn; - NodeRect := GetDisplayRect(FHeightTrackNode, FHeightTrackColumn, False); - FHeightTrackPoint := Point(NodeRect.Left, NodeRect.Top); - DoStateChange([tsNodeHeightTrackPending]); - Exit; - end; - end; - - // handle button clicks - if (hiOnItemButton in HitInfo.HitPositions) and (vsHasChildren in HitInfo.HitNode.States) then - begin - ToggleNode(HitInfo.HitNode); - Exit; - end; - - // check event - if hiOnItemCheckBox in HitInfo.HitPositions then - begin - NewCheckState := DetermineNextCheckState(HitInfo.HitNode.CheckType, HitInfo.HitNode.CheckState); - if (ssLeft in KeysToShiftState(Message.Keys)) and DoChecking(HitInfo.HitNode, NewCheckState) then - begin - if (Self.SelectedCount > 1) and (Selected[HitInfo.HitNode]) and not (toSyncCheckboxesWithSelection in TreeOptions.SelectionOptions) then - SetCheckStateForAll(NewCheckState, True) - else - DoCheckClick(HitInfo.HitNode, NewCheckState); - end;//if ssLeft - Exit; - end; - - // Keep this node's level in case we need it for constraint selection. - if (FRoot.ChildCount > 0) and ShiftEmpty or (FSelectionCount = 0) then - if Assigned(HitInfo.HitNode) then - FLastSelectionLevel := GetNodeLevelForSelectConstraint(HitInfo.HitNode) - else - FLastSelectionLevel := GetNodeLevelForSelectConstraint(GetLastVisibleNoInit(nil, True)); - - // immediate clearance - // Determine for the right mouse button if there is a popup menu. In this case and if drag'n drop is pending - // the current selection has to stay as it is. - with HitInfo, Message do - CanClear := not AutoDrag and - (not (tsRightButtonDown in FStates) or not HasPopupMenu(HitNode, HitColumn, Point(XPos, YPos))); - - // pending clearance - if MultiSelect and ShiftEmpty and not (hiOnItemCheckbox in HitInfo.HitPositions) and IsAnyHit and AutoDrag and - NodeSelected and not FSelectionLocked - then - DoStateChange([tsClearPending]); - - // User starts a selection with a selection rectangle. - if not (toDisableDrawSelection in FOptions.FSelectionOptions) and not (IsLabelHit or FullRowDrag) and MultiSelect then - begin - SetCapture(Handle); - DoStateChange([tsDrawSelPending]); - FDrawSelShiftState := ShiftState; - FNewSelRect := Rect(Message.XPos + FEffectiveOffsetX, Message.YPos - FOffsetY, Message.XPos + FEffectiveOffsetX, - Message.YPos - FOffsetY); - FLastSelRect := Rect(0, 0, 0, 0); - end; - - NeedChangeEvent := FSelectionCount >= 1; - if not FSelectionLocked and ((not (IsAnyHit or FullRowDrag) and MultiSelect and ShiftEmpty) or - (IsAnyHit and (not NodeSelected or (NodeSelected and CanClear)) and (ShiftEmpty or not MultiSelect or (tsRightButtonDown in FStates)))) then - begin - Assert(not (tsClearPending in FStates), 'Pending and direct clearance are mutual exclusive!'); - - // If the currently hit node was already selected then we have to reselect it again after clearing the current - // selection, but without a change event if it is the only selected node. - // The same applies if the Alt key is pressed, which allows to start drawing the selection rectangle also - // on node captions and images. Here the previous selection state does not matter, though. - if NodeSelected or (AltPressed and Assigned(HitInfo.HitNode) and (HitInfo.HitColumn = FHeader.MainColumn)) and not (hiNowhere in HitInfo.HitPositions) then - begin - InternalClearSelection; - InternalAddToSelection(HitInfo.HitNode, True); - if NeedChangeEvent then - begin - Invalidate; - Change(nil); - end; - end - else if (toAlwaysSelectNode in Self.TreeOptions.SelectionOptions) then - begin - if not (hiNowhere in HitInfo.HitPositions) then - ClearSelection(False) - else - if not (ssCtrl in ShiftState) then - DoStateChange([tsClearOnNewSelection], []); - end - else - ClearSelection(False); - end; - - // pending node edit - if Focused and - ((hiOnItemLabel in HitInfo.HitPositions) or ((toGridExtensions in FOptions.FMiscOptions) and - (hiOnItem in HitInfo.HitPositions))) and NodeSelected and not NewColumn and ShiftEmpty and (SelectedCount = 1) then - begin - DoStateChange([tsEditPending]); - end; - - if not (toDisableDrawSelection in FOptions.FSelectionOptions) - and not (IsLabelHit or FullRowDrag) and (MultiSelect or (hiNowhere in HitInfo.HitPositions)) then - begin - // The original code here was moved up to fix issue #187. - // In order not to break the semantics of this procedure, we are leaving these if statements here - if not IsCellHit then begin - if NeedChangeEvent then - Change(nil); - Exit; - end; - end; - - // Keep current mouse position. - FLastClickPos := Point(Message.XPos, Message.YPos); - - // Handle selection and node focus change. - if (IsLabelHit or IsCellHit) and - DoFocusChanging(FFocusedNode, HitInfo.HitNode, FFocusedColumn, Column) then - begin - if NewColumn then - begin - - if not Assigned(FFocusedNode) then - InvalidateColumn(FFocusedColumn) - else - invalidateWithAutoSpan(FFocusedColumn, FFocusedNode); //fix: issue 310 - if not Assigned(HitInfo.HitNode) then - InvalidateColumn(Column) - else - invalidateWithAutoSpan(Column, HitInfo.HitNode); //fix: issue 310 - FFocusedColumn := Column; - end; - if DragKind = dkDock then - begin - StopTimer(ScrollTimer); - DoStateChange([], [tsScrollPending, tsScrolling]); - end; - // Get the currently focused node to make multiple multi-selection blocks possible. - LastFocused := FFocusedNode; - if NewNode then - DoFocusNode(HitInfo.HitNode, False); - - if MultiSelect and not ShiftEmpty and not (tsRightButtonDown in FStates) then - HandleClickSelection(LastFocused, HitInfo.HitNode, ShiftState, AutoDrag) - else - begin - if ShiftEmpty then - FRangeAnchor := HitInfo.HitNode; - - // If the hit node is not yet selected then do it now. - if not NodeSelected then - AddToSelection(HitInfo.HitNode, True); - end; - - if NewNode or NewColumn then - begin - ScrollIntoView(FFocusedNode, False, - not (toDisableAutoscrollOnFocus in FOptions.FAutoOptions) - and not (toFullRowSelect in FOptions.SelectionOptions)); - - DoFocusChange(FFocusedNode, FFocusedColumn); - end; - end; - - if (SelectedCount = 0) and NeedChangeEvent then - Change(nil); - - // Drag'n drop initiation - // If we lost focus in the interim the button states would be cleared in WM_KILLFOCUS. - if AutoDrag and IsAnyHit and (FStates * [tsLeftButtonDown, tsRightButtonDown, tsMiddleButtonDown] <> []) then - BeginDrag(False); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.HandleMouseUp(var Message: TWMMouse; const HitInfo: THitInfo); - -// Counterpart to the mouse down handler. - -var - ReselectFocusedNode: Boolean; - -begin - ReleaseCapture; - - if not (tsVCLDragPending in FStates) then - begin - // reset pending or persistent states - if IsMouseSelecting then - begin - DoStateChange([], [tsDrawSelecting, tsDrawSelPending, tsToggleFocusedSelection, tsClearOnNewSelection]); - Invalidate; - end; - - if tsClearPending in FStates then - begin - ReselectFocusedNode := Assigned(FFocusedNode) and (vsSelected in FFocusedNode.States); - ClearSelection; - if ReselectFocusedNode then - AddToSelection(FFocusedNode, False); - end; - - if (tsToggleFocusedSelection in FStates) and (HitInfo.HitNode = FFocusedNode) and Assigned(HitInfo.HitNode) then //Prevent AV when dereferencing HitInfo.HitNode below, see bug #100 - begin - if vsSelected in HitInfo.HitNode.States then - begin - if not (toAlwaysSelectNode in TreeOptions.SelectionOptions) or (Self.SelectedCount > 1) then - RemoveFromSelection(HitInfo.HitNode); - end - else - AddToSelection(HitInfo.HitNode, False); - end; - - DoStateChange([], [tsOLEDragPending, tsOLEDragging, tsClearPending, tsDrawSelPending, tsToggleFocusedSelection, - tsScrollPending, tsScrolling]); - StopTimer(ScrollTimer); - - if (FHeader.FColumns.FClickIndex > NoColumn) and (FHeader.FColumns.FClickIndex = HitInfo.HitColumn) then - DoColumnClick(HitInfo.HitColumn, KeysToShiftState(Message.Keys)); - - if FLastHitInfo.HitNode <> nil then begin // Use THitInfo of mouse down here, see issue #692 - DoNodeClick(FLastHitInfo); - if Assigned(FLastHitInfo.HitNode) then begin - InvalidateNode(FLastHitInfo.HitNode); - FLastHitInfo.HitNode := nil; // prevent firing the event again - end;//if - end; - - // handle a pending edit event - if tsEditPending in FStates then - begin - // Is the mouse still over the same node? - if (HitInfo.HitNode = FFocusedNode) and (hiOnItem in HitInfo.HitPositions) and - (toEditOnClick in FOptions.FMiscOptions) and (FFocusedColumn = HitInfo.HitColumn) and - CanEdit(FFocusedNode, HitInfo.HitColumn) then - begin - FEditColumn := FFocusedColumn; - SetTimer(Handle, EditTimer, FEditDelay, nil); - end - else - DoStateChange([], [tsEditPending]); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.HasImage(Node: PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex): Boolean; - -// Determines whether the given node has got an image of the given kind in the given column. -// Returns True if so, otherwise False. -// The given node will be implicitly initialized if needed. - -var - Ghosted: Boolean; - Index: TImageIndex; - -begin - if not (vsInitialized in Node.States) then - InitNode(Node); - - Index := -1; - Ghosted := False; - DoGetImageIndex(Node, Kind, Column, Ghosted, Index); - Result := Index > -1; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.HasPopupMenu(Node: PVirtualNode; Column: TColumnIndex; Pos: TPoint): Boolean; - -// Determines whether the tree got a popup menu, either in its PopupMenu property, via the OnGetPopupMenu event or -// through inheritance. The latter case must be checked by the descendant which must override this method. - -begin - Result := Assigned(PopupMenu) or Assigned(DoGetPopupMenu(Node, Column, Pos)); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.InitChildren(Node: PVirtualNode); - -// Initiates the initialization of the child number of the given node. - -var - Count: Cardinal; - -begin - if Assigned(Node) and (Node <> FRoot) and (vsHasChildren in Node.States) then - begin - Count := Node.ChildCount; - if DoInitChildren(Node, Count) then - begin - SetChildCount(Node, Count); - if Count = 0 then - Exclude(Node.States, vsHasChildren); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.InitNode(Node: PVirtualNode); - -// Initiates the initialization of the given node to allow the application to load needed data for it. - -var - InitStates: TVirtualNodeInitStates; - MustAdjustInternalVariables: Boolean; - ParentCheckState, SelfCheckState: TCheckState; -begin - with Node^ do - begin - Include(States, vsInitializing); - try - InitStates := []; - if vsInitialized in States then - Include(InitStates, ivsReInit); - Include(States, vsInitialized); - if Parent = FRoot then - DoInitNode(nil, Node, InitStates) - else - DoInitNode(Parent, Node, InitStates); - - // Fix: Any parent check state must be propagated here. - // Because the CheckType is normally set in DoInitNode - // by the App. - if (Node.CheckType = ctTriStateCheckBox) and (toAutoTristateTracking in FOptions.FAutoOptions) then - begin - ParentCheckState := Self.GetCheckState(Node.Parent); - SelfCheckState := Self.GetCheckState(Node); - if ((ParentCheckState = csCheckedNormal) - or (ParentCheckState = csUncheckedNormal)) - and (not SelfCheckState.IsDisabled()) - and (SelfCheckState <> ParentCheckState) - and (Parent <> FRoot) - then - SetCheckState(Node, Node.Parent.CheckState); - end - else if (toSyncCheckboxesWithSelection in TreeOptions.SelectionOptions) then - Node.CheckType := TCheckType.ctCheckBox; - - if ivsDisabled in InitStates then - Include(States, vsDisabled); - if ivsHasChildren in InitStates then - Include(States, vsHasChildren); - if ivsSelected in InitStates then - InternalAddToSelection(Node, False); - if ivsMultiline in InitStates then - Include(States, vsMultiline); - if ivsFiltered in InitStates then - begin - MustAdjustInternalVariables := not ((ivsReInit in InitStates) and (vsFiltered in States)); - - Include(States, vsFiltered); - - if not (toShowFilteredNodes in FOptions.FPaintOptions) and MustAdjustInternalVariables then - begin - AdjustTotalHeight(Node, -NodeHeight, True); - if FullyVisible[Node] then - Dec(FVisibleCount); - if FUpdateCount = 0 then - UpdateScrollBars(True); - end; - end; - - // Expanded may already be set (when called from ReinitNode) or be set in DoInitNode, allow both. - if (vsExpanded in Node.States) xor (ivsExpanded in InitStates) then - begin - // Expand node if not yet done (this will automatically initialize child nodes). - if ivsExpanded in InitStates then - ToggleNode(Node) - else - // If the node already was expanded then explicitly trigger child initialization. - if vsHasChildren in Node.States then - InitChildren(Node); - end; - finally - Exclude(States, vsInitializing); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.InternalAddFromStream(Stream: TStream; Version: Integer; Node: PVirtualNode); - -// Loads all details for Node (including its children) from the given stream. -// Because the new nodes might be selected this method also fixes the selection array. - -var - Stop: PVirtualNode; - Index: Integer; - LastTotalHeight: Cardinal; - WasFullyVisible: Boolean; - -begin - Assert(Node <> FRoot, 'The root node cannot be loaded from stream.'); - - // Keep the current total height value of Node as it has already been applied - // but might change in the load and fixup code. We have to adjust that afterwards. - LastTotalHeight := Node.TotalHeight; - WasFullyVisible := FullyVisible[Node] and not IsEffectivelyFiltered[Node]; - - // Read in the new nodes. - ReadNode(Stream, Version, Node); - - // One time update of node-internal states and the global visibility counter. - // This is located here to ease and speed up the loading process. - FixupTotalCount(Node); - AdjustTotalCount(Node.Parent, Node.TotalCount - 1, True); // -1 because Node itself was already set. - FixupTotalHeight(Node); - AdjustTotalHeight(Node.Parent, Integer(Node.TotalHeight) - Integer(LastTotalHeight), True); - - // New nodes are always visible, so the visible node count has been increased already. - // If Node is now invisible we have to take back this increment and don't need to add any visible child node. - if not FullyVisible[Node] or IsEffectivelyFiltered[Node] then - begin - if WasFullyVisible then - Dec(FVisibleCount); - end - else - // It can never happen that the node is now fully visible but was not before as this would require - // that the visibility state of one of its parents has changed, which cannot happen during loading. - Inc(FVisibleCount, CountVisibleChildren(Node)); - - // Fix selection array. - ClearTempCache; - if Node = FRoot then - Stop := nil - else - Stop := Node.NextSibling; - - if toMultiSelect in FOptions.FSelectionOptions then - begin - // Add all nodes which were selected before to the current selection (unless they are already there). - while Node <> Stop do - begin - if (vsSelected in Node.States) and not FindNodeInSelection(Node, Index, 0, High(FSelection)) then - InternalCacheNode(Node); - Node := GetNextNoInit(Node); - end; - if FTempNodeCount > 0 then - AddToSelection(FTempNodeCache, FTempNodeCount, True); - ClearTempCache; - end - else // No further selected nodes allowed so delete the corresponding flag in all new nodes. - while Node <> Stop do - begin - Exclude(Node.States, vsSelected); - Node := GetNextNoInit(Node); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.InternalAddToSelection(Node: PVirtualNode; ForceInsert: Boolean): Boolean; -var - lSingletonNodeArray: TNodeArray; -begin - Assert(Assigned(Node), 'Node must not be nil!'); - SetLength(lSingletonNodeArray, 1); - lSingletonNodeArray[0] := Node; - Result := InternalAddToSelection(lSingletonNodeArray, 1, ForceInsert); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.InternalAddToSelection(const NewItems: TNodeArray; NewLength: Integer; - ForceInsert: Boolean): Boolean; - -// Internal version of method AddToSelection which does not trigger OnChange events - -var - I, J: Integer; - CurrentEnd: Integer; - Constrained, - SiblingConstrained: Boolean; - lPreviousSelectedCount: Integer; - AddedNodesSize: Integer; - PTmpNode: PVirtualNode; - -begin - lPreviousSelectedCount := FSelectionCount; - // The idea behind this code is to use a kind of reverse merge sort. QuickSort is quite fast - // and would do the job here too but has a serious problem with already sorted lists like FSelection. - - // current number of valid entries - AddedNodesSize := 0; - - // 1) Remove already selected items, mark all other as being selected. - if ForceInsert then - begin - //Fix: For already selected node when selected, this path - //is used that didn't contain the Constraint logic. Added. - Constrained := toLevelSelectConstraint in FOptions.FSelectionOptions; - if Constrained and (FLastSelectionLevel = -1) then - FLastSelectionLevel := GetNodeLevelForSelectConstraint(NewItems[0]); - AddedNodesSize := NewLength; - end - else - begin - Constrained := toLevelSelectConstraint in FOptions.FSelectionOptions; - if Constrained and (FLastSelectionLevel = -1) then - FLastSelectionLevel := GetNodeLevelForSelectConstraint(NewItems[0]); - SiblingConstrained := toSiblingSelectConstraint in FOptions.FSelectionOptions; - if SiblingConstrained and (FRangeAnchor = nil) then - FRangeAnchor := NewItems[0]; - - for I := 0 to NewLength - 1 do - if ([vsSelected, vsDisabled] * NewItems[I].States <> []) or - (Constrained and (Cardinal(FLastSelectionLevel) <> GetNodeLevel(NewItems[I]))) or - (SiblingConstrained and (FRangeAnchor.Parent <> NewItems[I].Parent)) - then - Inc(PAnsiChar(NewItems[I])) // mark as invalid by setting the LSB - else - Inc(AddedNodesSize); - end; - - I := PackArray(NewItems, NewLength); - if I > -1 then - NewLength := I; - - Result := NewLength > 0; - if Result then - begin - // 2) Sort the new item list so we can easily traverse it. - if NewLength > 1 then - QuickSort(NewItems, 0, NewLength - 1); - // 3) Make room in FSelection for the new items. - if lPreviousSelectedCount + NewLength >= Length(FSelection) then - SetLength(FSelection, lPreviousSelectedCount + NewLength); - - // 4) Merge in new items - J := NewLength - 1; - CurrentEnd := lPreviousSelectedCount - 1; - - while J >= 0 do - begin - // First insert all new entries which are greater than the greatest entry in the old list. - // If the current end marker is < 0 then there's nothing more to move in the selection - // array and only the remaining new items must be inserted. - if CurrentEnd >= 0 then - begin - while (J >= 0) and (PAnsiChar(NewItems[J]) > PAnsiChar(FSelection[CurrentEnd])) do - begin - FSelection[CurrentEnd + J + 1] := NewItems[J]; - Dec(J); - end; - // early out if nothing more needs to be copied - if J < 0 then - Break; - end - else - begin - // insert remaining new entries at position 0 - Move(NewItems[0], FSelection[0], (J + 1) * SizeOf(Pointer)); - // nothing more to do so exit main loop - Break; - end; - - // find the last entry in the remaining selection list which is smaller then the largest - // entry in the remaining new items list - FindNodeInSelection(NewItems[J], I, 0, CurrentEnd); - Dec(I); - // move all entries which are greater than the greatest entry in the new items list up - // so the remaining gap travels down to where new items must be inserted - Move(FSelection[I + 1], FSelection[I + J + 2], (CurrentEnd - I) * SizeOf(Pointer)); - CurrentEnd := I; - end; - - // update selection count - Inc(FSelectionCount, AddedNodesSize); - - // post process added nodes - for I := 0 to AddedNodesSize - 1 do - begin - PTmpNode := NewItems[I]; - //sync path note: on click, multi-select ctrl-click and draw selection - Include(PTmpNode.States, vsSelected); - // call on add event callbackevent - if Assigned(FOnAddToSelection) then - FOnAddToSelection(Self, PTmpNode); - if SyncCheckstateWithSelection[PTmpNode] then - checkstate[PTmpNode] := csCheckedNormal; - end; - - Assert(FSelectionCount = (lPreviousSelectedCount + NewLength), 'Fixing issue #487 seems to ahve caused a problem here.') - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.InternalCacheNode(Node: PVirtualNode); - -// Adds the given node to the temporary node cache (used when collecting possibly large amounts of nodes). - -var - Len: Cardinal; - -begin - Len := Length(FTempNodeCache); - if FTempNodeCount = Len then - begin - if Len < 100 then - Len := 100 - else - Len := Len + Len div 10; - SetLength(FTempNodeCache, Len); - end; - FTempNodeCache[FTempNodeCount] := Node; - Inc(FTempNodeCount); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.InternalClearSelection(); - -var - Count: Integer; - lNode: PVirtualNode; -begin - // It is possible that there are invalid node references in the selection array - // if the tree update is locked and changes in the structure were made. - // Handle this potentially dangerous situation by packing the selection array explicitely. - if FUpdateCount > 0 then - begin - Count := PackArray(FSelection, FSelectionCount); - if Count > -1 then - begin - FSelectionCount := Count; - SetLength(FSelection, FSelectionCount); - end; - end; - - while FSelectionCount > 0 do - begin - Dec(FSelectionCount); - lNode := FSelection[FSelectionCount]; - //sync path note: deselect when click on another or on outside area - Exclude(lNode.States, vsSelected); - if SyncCheckstateWithSelection[lNode] then - CheckState[lNode] := csUncheckedNormal; - DoRemoveFromSelection(lNode); - end; - ResetRangeAnchor; - FSelection := nil; - DoStateChange([], [tsClearPending]); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.InternalConnectNode(Node, Destination: PVirtualNode; Target: TBaseVirtualTree; - Mode: TVTNodeAttachMode); - -// Connects Node with Destination depending on Mode. -// No error checking takes place. Node as well as Destination must be valid. Node must never be a root node and -// Destination must not be a root node if Mode is amInsertBefore or amInsertAfter. - -var - Run: PVirtualNode; - -begin - // Keep in mind that the destination node might belong to another tree. - with Target do - begin - case Mode of - amInsertBefore: - begin - Node.PrevSibling := Destination.PrevSibling; - Destination.PrevSibling := Node; - Node.NextSibling := Destination; - Node.Parent := Destination.Parent; - Node.Index := Destination.Index; - if Node.PrevSibling = nil then - Node.Parent.FirstChild := Node - else - Node.PrevSibling.NextSibling := Node; - - // reindex all following nodes - Run := Destination; - while Assigned(Run) do - begin - Inc(Run.Index); - Run := Run.NextSibling; - end; - end; - amInsertAfter: - begin - Node.NextSibling := Destination.NextSibling; - Destination.NextSibling := Node; - Node.PrevSibling := Destination; - Node.Parent := Destination.Parent; - if Node.NextSibling = nil then - Node.Parent.LastChild := Node - else - Node.NextSibling.PrevSibling := Node; - Node.Index := Destination.Index; - - // reindex all following nodes - Run := Node; - while Assigned(Run) do - begin - Inc(Run.Index); - Run := Run.NextSibling; - end; - end; - amAddChildFirst: - begin - if Assigned(Destination.FirstChild) then - begin - // If there's a first child then there must also be a last child. - Destination.FirstChild.PrevSibling := Node; - Node.NextSibling := Destination.FirstChild; - Destination.FirstChild := Node; - end - else - begin - // First child node at this location. - Destination.FirstChild := Node; - Destination.LastChild := Node; - Node.NextSibling := nil; - end; - Node.PrevSibling := nil; - Node.Parent := Destination; - Node.Index := 0; - // reindex all following nodes - Run := Node.NextSibling; - while Assigned(Run) do - begin - Inc(Run.Index); - Run := Run.NextSibling; - end; - end; - amAddChildLast: - begin - if Assigned(Destination.LastChild) then - begin - // If there's a last child then there must also be a first child. - Destination.LastChild.NextSibling := Node; - Node.PrevSibling := Destination.LastChild; - Destination.LastChild := Node; - end - else - begin - // first child node at this location - Destination.FirstChild := Node; - Destination.LastChild := Node; - Node.PrevSibling := nil; - end; - Node.NextSibling := nil; - Node.Parent := Destination; - if Assigned(Node.PrevSibling) then - Node.Index := Node.PrevSibling.Index + 1 - else - Node.Index := 0; - end; - else - // amNoWhere: do nothing - end; - // Remove temporary states. - Node.States := Node.States - [vsChecking, vsCutOrCopy, vsDeleting]; - - if (Mode <> amNoWhere) then begin - Inc(Node.Parent.ChildCount); - Include(Node.Parent.States, vsHasChildren); - AdjustTotalCount(Node.Parent, Node.TotalCount, True); - - // Add the new node's height only if its parent is expanded. - if (vsExpanded in Node.Parent.States) and (vsVisible in Node.States) then begin - AdjustTotalHeight(Node.Parent, Node.TotalHeight, True); - Inc(FVisibleCount, CountVisibleChildren(Node) + Cardinal(IfThen(IsEffectivelyVisible[Node], 1))); - end;//if - - // Update the hidden children flag of the parent. - if (Node.Parent <> FRoot) then - begin - // If we have added a visible node then simply remove the all-children-hidden flag. - if IsEffectivelyVisible[Node] then - Exclude(Node.Parent.States, vsAllChildrenHidden) - else begin - // If we have added an invisible node and this is the only child node then - // make sure the all-children-hidden flag is in a determined state. - // If there were child nodes before then no action is needed. - if Node.Parent.ChildCount = 1 then - Include(Node.Parent.States, vsAllChildrenHidden); - end;//else - end; //if Node.Parent <> FRoot - end;//if Mode <> amNoWhere - end;//With -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.InternalData(Node: PVirtualNode): Pointer; - -begin - Result := nil; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.InternalDisconnectNode(Node: PVirtualNode; KeepFocus: Boolean; Reindex: Boolean = True; ParentClearing: Boolean = False); - -// Disconnects the given node from its parent and siblings. The node's pointer are not reset so they can still be used -// after return from this method (probably a very short time only!). -// If KeepFocus is True then the focused node is not reset. This is useful if the given node is reconnected to the tree -// immediately after return of this method and should stay being the focused node if it was it before. -// Note: Node must not be nil or the root node. - -var - Parent, - Run: PVirtualNode; - Index: Integer; - AdjustHeight: Boolean; - -begin - Assert(Assigned(Node) and (Node <> FRoot), 'Node must neither be nil nor the root node.'); - - if (Node = FFocusedNode) and not KeepFocus then - begin - DoFocusNode(nil, False); - DoFocusChange(FFocusedNode, FFocusedColumn); - end; - - if Node = FRangeAnchor then - ResetRangeAnchor; - - // Update the hidden children flag of the parent. - if (Node.Parent <> FRoot) and not (ParentClearing) then - if FUpdateCount = 0 then - DetermineHiddenChildrenFlag(Node.Parent) - else - Include(FStates, tsUpdateHiddenChildrenNeeded); - - if not (vsDeleting in Node.States) then - begin - // Some states are only temporary so take them out. - Node.States := Node.States - [vsChecking]; - Parent := Node.Parent; - Dec(Parent.ChildCount); - AdjustHeight := (vsExpanded in Parent.States) and (vsVisible in Node.States); - if Parent.ChildCount = 0 then - begin - Parent.States := Parent.States - [vsAllChildrenHidden, vsHasChildren]; - if (Parent <> FRoot) and (vsExpanded in Parent.States) then - Exclude(Parent.States, vsExpanded); - end; - AdjustTotalCount(Parent, -Integer(Node.TotalCount), True); - if AdjustHeight then - AdjustTotalHeight(Parent, -Integer(Node.TotalHeight), True); - if FullyVisible[Node] then - Dec(FVisibleCount, CountVisibleChildren(Node) + Cardinal(IfThen(IsEffectivelyVisible[Node], 1))); - - if Assigned(Node.PrevSibling) then - Node.PrevSibling.NextSibling := Node.NextSibling - else - Parent.FirstChild := Node.NextSibling; - - if Assigned(Node.NextSibling) then - begin - Node.NextSibling.PrevSibling := Node.PrevSibling; - // Reindex all following nodes. - if Reindex then - begin - Run := Node.NextSibling; - Index := Node.Index; - while Assigned(Run) do - begin - Run.Index := Index; - Inc(Index); - Run := Run.NextSibling; - end; - end; - end - else - Parent.LastChild := Node.PrevSibling; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.InternalRemoveFromSelection(Node: PVirtualNode); - -// Special version to mark a node to be no longer in the current selection. PackArray must -// be used to remove finally those entries. - -var - Index: Integer; - -begin - // Because pointers are always DWORD aligned we can simply increment all those - // which we want to have removed (see also PackArray) and still have the - // order in the list preserved. - if FindNodeInSelection(Node, Index, -1, -1) then - begin - //sync path note: deselect when overlapping drawselection is made - Exclude(Node.States, vsSelected); - if SyncCheckstateWithSelection[Node] then - Node.CheckState := csUncheckedNormal; // Avoid using SetCheckState() as it handles toSyncCheckboxesWithSelection as well. - Inc(PAnsiChar(FSelection[Index])); - DoRemoveFromSelection(Node); - AdviseChangeEvent(False, Node, crIgnore); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.InvalidateCache; - -// Marks the cache as invalid. - -begin - DoStateChange([tsValidationNeeded], [tsUseCache]); - //ChangeTreeStatesAsync([csValidationNeeded], [csUseCache]); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.MarkCutCopyNodes; - -// Sets the vsCutOrCopy style in every currently selected but not disabled node to indicate it is -// now part of a clipboard operation. - -var - Nodes: TNodeArray; - I: Integer; - -begin - Nodes := nil; - if FSelectionCount > 0 then - begin - // need the current selection sorted to exclude selected nodes which are children, grandchildren etc. of - // already selected nodes - Nodes := GetSortedSelection(False); - for I := 0 to High(Nodes) do - with Nodes[I]^ do - if not (vsDisabled in States) then - Include(States, vsCutOrCopy); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.Loaded; - -var - LastRootCount: Cardinal; - IsReadOnly: Boolean; - -begin - inherited; - - // Call RegisterDragDrop after all visual inheritance changes to MiscOptions have been applied. - if not (csDesigning in ComponentState) and (toAcceptOLEDrop in FOptions.FMiscOptions) then - if HandleAllocated then - RegisterDragDrop(Handle, DragManager as IDropTarget); - - // If a root node count has been set during load of the tree then update its child structure now - // as this hasn't been done yet in this case. - if (tsNeedRootCountUpdate in FStates) and (FRoot.ChildCount > 0) then - begin - DoStateChange([], [tsNeedRootCountUpdate]); - IsReadOnly := toReadOnly in FOptions.FMiscOptions; - Exclude(FOptions.FMiscOptions, toReadOnly); - LastRootCount := FRoot.ChildCount; - FRoot.ChildCount := 0; - BeginUpdate; - SetChildCount(FRoot, LastRootCount); - EndUpdate; - if IsReadOnly then - Include(FOptions.FMiscOptions, toReadOnly); - end; - - // Prevent the object inspector at design time from marking the header as being modified - // when auto resize is enabled. - Updating; - try - FHeader.UpdateMainColumn; - FHeader.FColumns.FixPositions; - if toAutoBidiColumnOrdering in FOptions.FAutoOptions then - FHeader.FColumns.ReorderColumns(UseRightToLeftAlignment); - // Because of the special recursion and update stopper when creating the window (or resizing it) - // we have to manually trigger the auto size calculation here. - if hsNeedScaling in FHeader.FStates then - FHeader.RescaleHeader - else - FHeader.RecalculateHeader; - if hoAutoResize in FHeader.FOptions then - FHeader.FColumns.AdjustAutoSize(InvalidColumn, True); - finally - Updated; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.MainColumnChanged; - -begin - DoCancelEdit; - - if Assigned(FAccessibleItem) then - NotifyWinEvent(EVENT_OBJECT_NAMECHANGE, Handle, OBJID_CLIENT, CHILDID_SELF); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.MouseMove(Shift: TShiftState; X, Y: Integer); - -var - R: TRect; - -begin - if tsNodeHeightTrackPending in FStates then - begin - // Remove hint if shown currently. - Application.CancelHint; - - // Stop wheel panning if active. - StopWheelPanning; - - // Stop timers - StopTimer(ExpandTimer); - StopTimer(EditTimer); - StopTimer(HeaderTimer); - StopTimer(ScrollTimer); - StopTimer(SearchTimer); - FSearchBuffer := ''; - FLastSearchNode := nil; - - DoStateChange([tsNodeHeightTracking], [tsScrollPending, tsScrolling, tsEditPending, tsOLEDragPending, tsVCLDragPending, - tsIncrementalSearching, tsNodeHeightTrackPending]); - end; - - if tsDrawSelPending in FStates then - begin - // Remove current selection in case the user clicked somewhere in the window (but not a node) - // and moved the mouse. - if CalculateSelectionRect(X, Y) then - begin - InvalidateRect(Handle, @FNewSelRect, False); - UpdateWindow(Handle); - if (Abs(FNewSelRect.Right - FNewSelRect.Left) > Mouse.DragThreshold) or - (Abs(FNewSelRect.Bottom - FNewSelRect.Top) > Mouse.DragThreshold) then - begin - if tsClearPending in FStates then - begin - DoStateChange([], [tsClearPending]); - ClearSelection; - end; - DoStateChange([tsDrawSelecting], [tsDrawSelPending]); - - // Reset to main column for multiselection. - FocusedColumn := FHeader.MainColumn; - - // The current rectangle may already include some node captions. Handle this. - if HandleDrawSelection(X, Y) then - InvalidateRect(Handle, nil, False); - end; - end; - end - else - begin - if tsNodeHeightTracking in FStates then - begin - // Handle height tracking. - if DoNodeHeightTracking(FHeightTrackNode, FHeightTrackColumn, FHeader.GetShiftState, - FHeightTrackPoint, Point(X, Y)) then - begin - // Avoid negative (or zero) node heights. - if FHeightTrackPoint.Y >= Y then - Y := FHeightTrackPoint.Y + 1; - SetNodeHeight(FHeightTrackNode, Y - FHeightTrackPoint.Y); - UpdateWindow(Handle); - Exit; - end; - end; - - // If both wheel panning and auto scrolling are pending then the user moved the mouse while holding down the - // middle mouse button. This means panning is being used, hence remove the wheel scroll flag. - if [tsWheelPanning, tsWheelScrolling] * FStates = [tsWheelPanning, tsWheelScrolling] then - begin - if ((Abs(FLastClickPos.X - X) >= Mouse.DragThreshold) or (Abs(FLastClickPos.Y - Y) >= Mouse.DragThreshold)) then - DoStateChange([], [tsWheelScrolling]); - end; - - // Really start dragging if the mouse has been moved more than the threshold. - if (tsOLEDragPending in FStates) and - ( - ((Abs(FLastClickPos.X - X) >= FDragThreshold) and (X > 0)) or // Check >0 to fix issue #833 - ((Abs(FLastClickPos.Y - Y) >= FDragThreshold) and (Y > 0)) - ) - then - DoDragging(FLastClickPos) - else - begin - if CanAutoScroll then - DoAutoScroll(X, Y); - if [tsWheelPanning, tsWheelScrolling] * FStates <> [] then - AdjustPanningCursor(X, Y); - if not IsMouseSelecting then - begin - HandleHotTrack(X, Y); - inherited MouseMove(Shift, X, Y); - end - else - begin - // Handle draw selection if required, but don't do the work twice if the - // auto scrolling code already cares about the selection. - if not (tsScrolling in FStates) and CalculateSelectionRect(X, Y) then - begin - // If something in the selection changed then invalidate the entire - // tree instead trying to figure out the display rects of all changed nodes. - if HandleDrawSelection(X, Y) then - InvalidateRect(Handle, nil, False) - else - begin - UnionRect(R, OrderRect(FNewSelRect), OrderRect(FLastSelRect)); - OffsetRect(R, -FEffectiveOffsetX, FOffsetY); - InvalidateRect(Handle, @R, False); - end; - UpdateWindow(Handle); - end; - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.Notification(AComponent: TComponent; Operation: TOperation); - -begin - if (AComponent <> Self) and (Operation = opRemove) then - begin - // Check for components linked to the tree. - if AComponent = FImages then - begin - Images := nil; - if not (csDestroying in ComponentState) then - Invalidate; - end - else - if AComponent = FStateImages then - begin - StateImages := nil; - if not (csDestroying in ComponentState) then - Invalidate; - end - else - if AComponent = FCustomCheckImages then - begin - CustomCheckImages := nil; - FCheckImageKind := ckSystemDefault; - if not (csDestroying in ComponentState) then - Invalidate; - end - else - if AComponent = PopupMenu then - PopupMenu := nil - else - // Check for components linked to the header. - if Assigned(FHeader) then - begin - if AComponent = FHeader.FImages then - FHeader.Images := nil - else - if AComponent = FHeader.PopupMenu then - FHeader.PopupMenu := nil; - end; - end; - inherited; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.OriginalWMNCPaint(DC: HDC); - -// Unfortunately, the painting for the non-client area in TControl is not always correct and does also not consider -// existing clipping regions, so it has been modified here to take this into account. - -const - InnerStyles: array[TBevelCut] of Integer = (0, BDR_SUNKENINNER, BDR_RAISEDINNER, 0); - OuterStyles: array[TBevelCut] of Integer = (0, BDR_SUNKENOUTER, BDR_RAISEDOUTER, 0); - EdgeStyles: array[TBevelKind] of Integer = (0, 0, BF_SOFT, BF_FLAT); - Ctl3DStyles: array[Boolean] of Integer = (BF_MONO, 0); - -var - RC, RW: TRect; - EdgeSize: Integer; - Size: TSize; - -begin - if (BevelKind <> bkNone) or (BorderWidth > 0) then - begin - RC := Rect(0, 0, Width, Height); - Size := GetBorderDimensions; - InflateRect(RC, Size.cx, Size.cy); - - RW := RC; - - if BevelKind <> bkNone then - begin - DrawEdge(DC, RC, InnerStyles[BevelInner] or OuterStyles[BevelOuter], Byte(BevelEdges) or EdgeStyles[BevelKind] or - Ctl3DStyles[Ctl3D]); - - EdgeSize := 0; - if BevelInner <> bvNone then - Inc(EdgeSize, BevelWidth); - if BevelOuter <> bvNone then - Inc(EdgeSize, BevelWidth); - with TWithSafeRect(RC) do - begin - if beLeft in BevelEdges then - Inc(Left, EdgeSize); - if beTop in BevelEdges then - Inc(Top, EdgeSize); - if beRight in BevelEdges then - Dec(Right, EdgeSize); - if beBottom in BevelEdges then - Dec(Bottom, EdgeSize); - end; - end; - - // Repaint only the part in the original clipping region and not yet drawn parts. - IntersectClipRect(DC, RC.Left, RC.Top, RC.Right, RC.Bottom); - - // Determine inner rectangle to exclude (RC corresponds then to the client area). - InflateRect(RC, -Integer(BorderWidth), -Integer(BorderWidth)); - - // Remove the inner rectangle. - ExcludeClipRect(DC, RC.Left, RC.Top, RC.Right, RC.Bottom); - - // Erase parts not drawn. - Brush.Color := FColors.BorderColor; - Winapi.Windows.FillRect(DC, RW, Brush.Handle); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.Paint; - -// Window paint routine. Used when the tree window needs to be updated. - -var - Window: TRect; - Target: TPoint; - Temp: Integer; - Options: TVTInternalPaintOptions; - RTLOffset: Integer; - -begin - - Options := [poBackground, poColumnColor, poDrawFocusRect, poDrawDropMark, poDrawSelection, poGridLines]; - if UseRightToLeftAlignment and FHeader.UseColumns then - RTLOffset := ComputeRTLOffset(True) - else - RTLOffset := 0; - - // The update rect has already been filled in WMPaint, as it is the window's update rect, which gets - // reset when BeginPaint is called (in the ancestor). - // The difference to the DC's clipbox is that it is also valid with internal paint operations used - // e.g. by the Explorer while dragging, but show window content while dragging is disabled. - if not IsRectEmpty(FUpdateRect) then - begin - Temp := Header.Columns.GetVisibleFixedWidth; - if Temp = 0 then - begin - Window := FUpdateRect; - Target := Window.TopLeft; - - // The clipping rectangle is given in client coordinates of the window. We have to convert it into - // a sliding window of the tree image. - OffsetRect(Window, FEffectiveOffsetX - RTLOffset, -FOffsetY); - PaintTree(Canvas, Window, Target, Options); - end - else - begin - // First part, fixed columns - Window := ClientRect; - Window.Right := Temp; - Target := Window.TopLeft; - - OffsetRect(Window, -RTLOffset, -FOffsetY); - PaintTree(Canvas, Window, Target, Options); - - // Second part, other columns - Window := GetClientRect; - - if Temp > Window.Right then - Exit; - - Window.Left := Temp; - Target := Window.TopLeft; - - OffsetRect(Window, FEffectiveOffsetX - RTLOffset, -FOffsetY); - PaintTree(Canvas, Window, Target, Options); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.PaintCheckImage(Canvas: TCanvas; const ImageInfo: TVTImageInfo; Selected: Boolean); - -var - ForegroundColor: COLORREF; - R: TRect; - Details, lSizeDetails: TThemedElementDetails; - lSize: TSize; - Theme: HTHEME; -begin - with ImageInfo do - begin - if (tsUseThemes in FStates) and (FCheckImageKind = ckSystemDefault) then - begin - Details.Element := teButton; - case Index of - // ctRadioButton - 1 : Details := StyleServices.GetElementDetails(tbRadioButtonUncheckedNormal); - 2 : Details := StyleServices.GetElementDetails(tbRadioButtonUncheckedHot); - 3 : Details := StyleServices.GetElementDetails(tbRadioButtonUncheckedPressed); - 4 : Details := StyleServices.GetElementDetails(tbRadioButtonUncheckedDisabled); - 5 : Details := StyleServices.GetElementDetails(tbRadioButtonCheckedNormal); - 6 : Details := StyleServices.GetElementDetails(tbRadioButtonCheckedHot); - 7 : Details := StyleServices.GetElementDetails(tbRadioButtonCheckedPressed); - 8 : Details := StyleServices.GetElementDetails(tbRadioButtonCheckedDisabled); - // ct(TriState)CheckBox - 9 : Details := StyleServices.GetElementDetails(tbCheckBoxUncheckedNormal); - 10 : Details := StyleServices.GetElementDetails(tbCheckBoxUncheckedHot); - 11 : Details := StyleServices.GetElementDetails(tbCheckBoxUncheckedPressed); - 12 : Details := StyleServices.GetElementDetails(tbCheckBoxUncheckedDisabled); - 13 : Details := StyleServices.GetElementDetails(tbCheckBoxCheckedNormal); - 14 : Details := StyleServices.GetElementDetails(tbCheckBoxCheckedHot); - 15 : Details := StyleServices.GetElementDetails(tbCheckBoxCheckedPressed); - 16 : Details := StyleServices.GetElementDetails(tbCheckBoxCheckedDisabled); - 17 : Details := StyleServices.GetElementDetails(tbCheckBoxMixedNormal); - 18 : Details := StyleServices.GetElementDetails(tbCheckBoxMixedHot); - 19 : Details := StyleServices.GetElementDetails(tbCheckBoxMixedPressed); - 20 : Details := StyleServices.GetElementDetails(tbCheckBoxMixedDisabled); - // ctButton - ckButtonNormal: Details := StyleServices.GetElementDetails(tbPushButtonNormal); - ckButtonHot: Details := StyleServices.GetElementDetails(tbPushButtonHot); - ckButtonPressed: Details := StyleServices.GetElementDetails(tbPushButtonPressed); - ckButtonDisabled: Details := StyleServices.GetElementDetails(tbPushButtonDisabled); - else - Details := StyleServices.GetElementDetails(tbButtonRoot); - end; - if StyleServices.IsSystemStyle {and not (Index in [ckButtonNormal..ckButtonDisabled])} then - begin - Theme := OpenThemeData(Handle, 'BUTTON'); - GetThemePartSize(Theme, Canvas.Handle, Details.Part, Details.State, nil, TS_TRUE, lSize); - if (Index in [ckButtonNormal..ckButtonDisabled]) then begin - lSizeDetails := StyleServices.GetElementDetails(tbCheckBoxCheckedNormal); // Size of dropdown button should be based on size of checkboxes - GetThemePartSize(Theme, Canvas.Handle, lSizeDetails.Part, lSizeDetails.State, nil, TS_TRUE, lSize); - // dropdown buttons should be slightly larger than checkboxes, see issue #887 - lSize.cx := Round(lSize.cx * 1.15); - lSize.cy := Round(lSize.cy * 1.1); - end; - R := Rect(XPos, YPos, XPos + lSize.cx, YPos + lSize.cy); - if (Index in [ckButtonNormal..ckButtonDisabled]) then - R.Offset(-1, 0); // Eliminate 1 pixel border around Windows themed button - DrawThemeBackground(Theme, Canvas.Handle, Details.Part, Details.State, R, nil); - CloseThemeData(Theme); - end - else - begin - if (Index in [ckButtonNormal..ckButtonDisabled]) or not StyleServices.GetElementSize(Canvas.Handle, Details, TElementSize.esActual, lSize) then begin - // radio buttons fail in RAD Studio 10 Seattle and lower, fallback to checkbox images. See issue #615 - if not StyleServices.GetElementSize(Canvas.Handle, StyleServices.GetElementDetails(tbCheckBoxUncheckedNormal), TElementSize.esActual, lSize) then - lSize := TSize.Create(GetSystemMetrics(SM_CXMENUCHECK), GetSystemMetrics(SM_CYMENUCHECK)); - end;//if - R := Rect(XPos, YPos, XPos + lSize.cx, YPos + lSize.cy); - StyleServices.DrawElement(Canvas.Handle, Details, R); - Canvas.Refresh; // Every time you give a Canvas.Handle away to some other code you can't control you have to call Canvas.Refresh afterwards because the Canvas object and the HDC can be out of sync. - end; - if (Index in [ckButtonNormal..ckButtonDisabled]) then begin - Canvas.Pen.Color := clGray; - // These constants have been determined by test using various themes and dpi-scalings - DrawArrow(Canvas, TScrollDirection.sdDown, Point(R.Left + Round(lSize.cx * 0.22), R.Top + Round(lSize.cy * 0.33)), Round(lSize.cx *0.28)); - end;//if - end - else - with FCheckImages do - begin - if Selected and not Ghosted then - begin - if Focused or (toPopupMode in FOptions.FPaintOptions) then - ForegroundColor := ColorToRGB(FColors.FocusedSelectionColor) - else - ForegroundColor := ColorToRGB(FColors.UnfocusedSelectionColor); - end - else - ForegroundColor := GetRGBColor(BlendColor); - - ImageList_DrawEx(Handle, Index, Canvas.Handle, XPos, YPos, 0, 0, GetRGBColor(BkColor), ForegroundColor, - ILD_TRANSPARENT); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - - -procedure TBaseVirtualTree.PaintImage(var PaintInfo: TVTPaintInfo; ImageInfoIndex: TVTImageInfoIndex; DoOverlay: Boolean); -const - Style: array[TImageType] of Cardinal = (0, ILD_MASK); -var - ExtraStyle: Cardinal; - CutNode: Boolean; - PaintFocused: Boolean; - DrawEnabled: Boolean; - CustomOverlayDrawing: Boolean; // False if the built-in overloay drawing of TImageList should be used, True if custom drawing should take place. -begin - with PaintInfo do - begin - CutNode := (vsCutOrCopy in Node.States) and (tsCutPending in FStates); - PaintFocused := Focused or (toGhostedIfUnfocused in FOptions.FPaintOptions); - - // Since the overlay image must be specified together with the image to draw - // it is meaningfull to retrieve it in advance. - if DoOverlay then - GetImageIndex(PaintInfo, ikOverlay, iiOverlay) - else - PaintInfo.ImageInfo[iiOverlay].Index := -1; - - DrawEnabled := not (vsDisabled in Node.States) and Enabled; - with ImageInfo[ImageInfoIndex] do - begin - if (vsSelected in Node.States) and not(Ghosted or CutNode) then - begin - if PaintFocused or (toPopupMode in FOptions.FPaintOptions) then - Images.BlendColor := FColors.FocusedSelectionColor - else - Images.BlendColor := FColors.UnfocusedSelectionColor; - end - else - Images.BlendColor := Color; - - ExtraStyle := ILD_TRANSPARENT; - // If the user returned an index >= 15 then we cannot use the built-in overlay image drawing. - // Instead we do it manually. Also of the image list of the normal and the overlay icon is different, - // we can't use the built-in drawing. See issue #779. - if (ImageInfo[iiOverlay].Index > -1) then begin - CustomOverlayDrawing := (ImageInfo[iiOverlay].Index >= 15) or (ImageInfo[iiOverlay].Images <> ImageInfo[iiNormal].Images); - if not CustomOverlayDrawing then - ExtraStyle := ILD_TRANSPARENT or ILD_OVERLAYMASK and IndexToOverlayMask(ImageInfo[iiOverlay].Index + 1); - end - else - CustomOverlayDrawing := False; - - // Blend image if enabled and the tree has the focus (or ghosted images must be drawn also if unfocused) ... - if (toUseBlendedImages in FOptions.FPaintOptions) and PaintFocused - // ... and the image is ghosted... - and (Ghosted or - // ... or it is not the check image and the node is selected (but selection is not for the entire row)... - ((vsSelected in Node.States) and - not (toFullRowSelect in FOptions.FSelectionOptions) and - not (toGridExtensions in FOptions.FMiscOptions)) or - // ... or the node must be shown in cut mode. - CutNode) then - ExtraStyle := ExtraStyle or ILD_BLEND50; - - if (vsSelected in Node.States) and not Ghosted then - Images.BlendColor := clDefault; - - DrawImage(Images, Index, Canvas, XPos, YPos, Style[Images.ImageType] or ExtraStyle, DrawEnabled); - - // Now, draw the overlay. This circumnavigates limitations in the overlay mask index (it has to be 4 bits in size, - // anything larger will be truncated by the ILD_OVERLAYMASK). - // However this will only be done if the overlay image index is > 15, to avoid breaking code that relies - // on overlay image indices (e.g. when using system image lists). - if CustomOverlayDrawing then begin - ExtraStyle := ExtraStyle and not ILD_BLEND50; // Fixes issue #551 - // Note: XPos and YPos are those of the normal images. - DrawImage(ImageInfo[iiOverlay].Images, ImageInfo[iiOverlay].Index, Canvas, XPos, YPos, - Style[ImageInfo[iiOverlay].Images.ImageType] or ExtraStyle, DrawEnabled); - end;//if - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.PaintNodeButton(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; const R: TRect; - ButtonX, ButtonY: Integer; BidiMode: TBiDiMode); - -var - Bitmap: TBitmap; - XPos: Integer; - IsHot: Boolean; - IsSelected : boolean; - Theme: HTHEME; - Glyph: Integer; - State: Integer; - Pos: TRect; - -begin - IsHot := (FCurrentHotNode = Node) and FHotNodeButtonHit; - IsSelected := (vsSelected in Node.States); - - // Draw the node's plus/minus button according to the directionality. - if BidiMode = bdLeftToRight then - XPos := R.Left + ButtonX - else - XPos := R.Right - ButtonX - FPlusBM.Width; - - if (tsUseExplorerTheme in FStates) and not VclStyleEnabled then - begin - Glyph := IfThen(IsHot, TVP_HOTGLYPH, TVP_GLYPH); - State := IfThen(vsExpanded in Node.States, GLPS_OPENED, GLPS_CLOSED); - Pos := Rect(XPos, R.Top + ButtonY, XPos + FPlusBM.Width, R.Top + ButtonY + FPlusBM.Height); - Theme := OpenThemeData(Handle, 'TREEVIEW'); - DrawThemeBackground(Theme, Canvas.Handle, Glyph, State, Pos, nil); - CloseThemeData(Theme); - end - else - begin - if vsExpanded in Node.States then - begin - if IsHot then - begin - if IsSelected then - BitMap := FSelectedHotMinusBM - else - Bitmap := FHotMinusBM; - end - else - Bitmap := FMinusBM; - end - else - begin - if IsHot then - begin - if IsSelected then - BitMap := FSelectedHotPlusBM - else - Bitmap := FHotPlusBM; - end - else - Bitmap := FPlusBM; - end; - // Need to draw this masked. - Canvas.Draw(XPos, R.Top + ButtonY, Bitmap); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.PaintTreeLines(const PaintInfo: TVTPaintInfo; IndentSize: Integer; const LineImage: TLineImage); - -var - I: Integer; - XPos, - Offset: Integer; - NewStyles: TLineImage; - -begin - NewStyles := nil; - - with PaintInfo do - begin - if BidiMode = bdLeftToRight then - begin - XPos := CellRect.Left + PaintInfo.Offsets[ofsMargin]; - Offset := FIndent; - end - else - begin - Offset := -Integer(FIndent); - XPos := CellRect.Right - PaintInfo.Offsets[ofsMargin] + Offset; - end; - - case FLineMode of - lmBands: - if poGridLines in PaintInfo.PaintOptions then - begin - // Convert the line images in correct bands. - SetLength(NewStyles, Length(LineImage)); - for I := IndentSize - 1 downto 0 do - begin - if (vsExpanded in Node.States) and not (vsAllChildrenHidden in Node.States) then - NewStyles[I] := ltLeft - else - case LineImage[I] of - ltRight, - ltBottomRight, - ltTopDownRight, - ltTopRight: - NewStyles[I] := ltLeftBottom; - ltNone: - // Have to take over the image to the right of this one. A no line entry can never appear as - // last entry so I don't need an end check here. - if LineImage[I + 1] in [ltNone, ltTopRight] then - NewStyles[I] := NewStyles[I + 1] - else - NewStyles[I] := ltLeft; - ltTopDown: - // Have to check the image to the right of this one. A top down line can never appear as - // last entry so I don't need an end check here. - if LineImage[I + 1] in [ltNone, ltTopRight] then - NewStyles[I] := NewStyles[I + 1] - else - NewStyles[I] := ltLeft; - end; - end; - - PaintInfo.Canvas.Font.Color := FColors.GridLineColor; - for I := 0 to IndentSize - 1 do - begin - DoBeforeDrawLineImage(PaintInfo.Node, I + Ord(not (toShowRoot in TreeOptions.PaintOptions)), XPos); - DrawLineImage(PaintInfo, XPos, CellRect.Top, NodeHeight[Node] - 1, VAlign - 1, NewStyles[I], - BidiMode <> bdLeftToRight); - Inc(XPos, Offset); - end; - end; - else // lmNormal - PaintInfo.Canvas.Font.Color := FColors.TreeLineColor; - for I := 0 to IndentSize - 1 do - begin - DoBeforeDrawLineImage(PaintInfo.Node, I + Ord(not (toShowRoot in TreeOptions.PaintOptions)), XPos); - DrawLineImage(PaintInfo, XPos, CellRect.Top, NodeHeight[Node], VAlign - 1, LineImage[I], - BidiMode <> bdLeftToRight); - Inc(XPos, Offset); - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.PaintSelectionRectangle(Target: TCanvas; WindowOrgX: Integer; const SelectionRect: TRect; - TargetRect: TRect); - -// Helper routine to draw a selection rectangle in the mode determined by DrawSelectionMode. - -var - BlendRect: TRect; - TextColorBackup, - BackColorBackup: COLORREF; // used to restore forground and background colors when drawing a selection rectangle - -begin - if ((FDrawSelectionMode = smDottedRectangle) and not (tsUseThemes in FStates)) then - begin - // Classical selection rectangle using dotted borderlines. - TextColorBackup := GetTextColor(Target.Handle); - SetTextColor(Target.Handle, $FFFFFF); - BackColorBackup := GetBkColor(Target.Handle); - SetBkColor(Target.Handle, 0); - Target.DrawFocusRect(SelectionRect); - SetTextColor(Target.Handle, TextColorBackup); - SetBkColor(Target.Handle, BackColorBackup); - end - else - begin - // Modern alpha blended style. - OffsetRect(TargetRect, WindowOrgX, 0); - if IntersectRect(BlendRect, OrderRect(SelectionRect), TargetRect) then - begin - OffsetRect(BlendRect, -WindowOrgX, 0); - AlphaBlend(0, Target.Handle, BlendRect, Point(0, 0), bmConstantAlphaAndColor, FSelectionBlendFactor, - ColorToRGB(FColors.SelectionRectangleBlendColor)); - - Target.Brush.Color := FColors.SelectionRectangleBorderColor; - Target.FrameRect(SelectionRect); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.PanningWindowProc(var Message: TMessage); - -var - PS: TPaintStruct; - Canvas: TCanvas; - -begin - if Message.Msg = WM_PAINT then - begin - BeginPaint(FPanningWindow, PS); - Canvas := TCanvas.Create; - Canvas.Handle := PS.hdc; - try - Canvas.Draw(0, 0, FPanningImage); - finally - Canvas.Handle := 0; - Canvas.Free; - EndPaint(FPanningWindow, PS); - end; - Message.Result := 0; - end - else - with Message do - Result := DefWindowProc(FPanningWindow, Msg, wParam, lParam); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.PrepareCell(var PaintInfo: TVTPaintInfo; WindowOrgX, MaxWidth: Integer); - -// This method is called immediately before a cell's content is drawn und is responsible to paint selection colors etc. - -var - TextColorBackup, - BackColorBackup: COLORREF; - FocusRect, - InnerRect: TRect; - RowRect: TRect; - Theme: HTHEME; -const - TREIS_HOTSELECTED = 6; - - //--------------- local functions ------------------------------------------- - - procedure AlphaBlendSelection(Color: TColor); - - var - R: TRect; - - begin - // Take into account any window offset and size limitations in the target bitmap, as this is only as large - // as necessary and might not cover the whole node. For normal painting this does not matter (because of - // clipping) but for the MMX code there is no such check and it will crash badly when bitmap boundaries are - // crossed. - R := InnerRect; - OffsetRect(R, -WindowOrgX, 0); - if R.Left < 0 then - R.Left := 0; - if R.Right > MaxWidth then - R.Right := MaxWidth; - AlphaBlend(0, PaintInfo.Canvas.Handle, R, Point(0, 0), bmConstantAlphaAndColor, - FSelectionBlendFactor, ColorToRGB(Color)); - end; - - //--------------------------------------------------------------------------- - - procedure DrawBackground(State: Integer); - begin - // if the full row selection is disabled or toGridExtensions is in the MiscOptions, draw the selection - // into the InnerRect, otherwise into the RowRect - if not (toFullRowSelect in FOptions.FSelectionOptions) or (toGridExtensions in FOptions.FMiscOptions) then - DrawThemeBackground(Theme, PaintInfo.Canvas.Handle, TVP_TREEITEM, State, InnerRect, nil) - else - DrawThemeBackground(Theme, PaintInfo.Canvas.Handle, TVP_TREEITEM, State, RowRect, nil); - end; - - procedure DrawThemedFocusRect(State: Integer); - var - Theme: HTHEME; - begin - Theme := OpenThemeData(Application.ActiveFormHandle, 'Explorer::ItemsView'); - if not (toFullRowSelect in FOptions.FSelectionOptions) or (toGridExtensions in FOptions.FMiscOptions) then - DrawThemeBackground(Theme, PaintInfo.Canvas.Handle, LVP_LISTDETAIL, State, InnerRect, nil) - else - DrawThemeBackground(Theme, PaintInfo.Canvas.Handle, LVP_LISTDETAIL, State, RowRect, nil); - CloseThemeData(Theme); - end; - - //--------------- end local functions --------------------------------------- - -begin - if tsUseExplorerTheme in FStates then - begin - Theme := OpenThemeData(Application.ActiveFormHandle, 'Explorer::TreeView'); - RowRect := Rect(0, PaintInfo.CellRect.Top, FRangeX, PaintInfo.CellRect.Bottom); - if (Header.Columns.Count = 0) and (toFullRowSelect in TreeOptions.SelectionOptions) then - RowRect.Right := Max(ClientWidth, RowRect.Right); - if toShowVertGridLines in FOptions.PaintOptions then - Dec(RowRect.Right); - end; - - with PaintInfo, Canvas do - begin - // Fill cell background if its color differs from tree background. - with FHeader.FColumns do - if poColumnColor in PaintOptions then - begin - Brush.Color := Items[Column].GetEffectiveColor; - FillRect(CellRect); - end; - - // Let the application customize the cell background and the content rectangle. - DoBeforeCellPaint(Canvas, Node, Column, cpmPaint, CellRect, ContentRect); - - InnerRect := ContentRect; - - // The selection rectangle depends on alignment. - if not (toGridExtensions in FOptions.FMiscOptions) then - begin - case Alignment of - taLeftJustify: - with TWithSafeRect(InnerRect) do - if Left + NodeWidth < Right then - Right := Left + NodeWidth; - taCenter: - with TWithSafeRect(InnerRect) do - if (Right - Left) > NodeWidth then - begin - Left := (Left + Right - NodeWidth) div 2; - Right := Left + NodeWidth; - end; - taRightJustify: - with TWithSafeRect(InnerRect) do - if (Right - Left) > NodeWidth then - Left := Right - NodeWidth; - end; - end; - - if (Column = FFocusedColumn) or (toFullRowSelect in FOptions.FSelectionOptions) then - begin - // Fill the selection rectangle. - if poDrawSelection in PaintOptions then - begin - if Node = FDropTargetNode then - begin - if (FLastDropMode = dmOnNode) or (vsSelected in Node.States) then - begin - Brush.Color := FColors.DropTargetColor; - Pen.Color := FColors.DropTargetBorderColor; - - if (toGridExtensions in FOptions.FMiscOptions) or - (toFullRowSelect in FOptions.FSelectionOptions) then - InnerRect := CellRect; - if not IsRectEmpty(InnerRect) then - if tsUseExplorerTheme in FStates then - DrawBackground(TREIS_SELECTED) - else - if (toUseBlendedSelection in FOptions.PaintOptions) then - AlphaBlendSelection(Brush.Color) - else - with TWithSafeRect(InnerRect) do - RoundRect(Left, Top, Right, Bottom, FSelectionCurveRadius, FSelectionCurveRadius); - end - else - begin - Brush.Style := bsClear; - end; - end - else - if vsSelected in Node.States then - begin - if Focused or (toPopupMode in FOptions.FPaintOptions) then - begin - Brush.Color := FColors.FocusedSelectionColor; - Pen.Color := FColors.FocusedSelectionBorderColor; - end - else - begin - Brush.Color := FColors.UnfocusedSelectionColor; - Pen.Color := FColors.UnfocusedSelectionBorderColor; - end; - if (toGridExtensions in FOptions.FMiscOptions) or (toFullRowSelect in FOptions.FSelectionOptions) then - InnerRect := CellRect; - if not IsRectEmpty(InnerRect) then - if tsUseExplorerTheme in FStates then - begin - // If the node is also hot, its background will be drawn later. - if not (toHotTrack in FOptions.FPaintOptions) or (Node <> FCurrentHotNode) or - ((Column <> FCurrentHotColumn) and not (toFullRowSelect in FOptions.FSelectionOptions)) then - DrawBackground(IfThen(Self.Focused, TREIS_SELECTED, TREIS_SELECTEDNOTFOCUS)); - end - else - if (toUseBlendedSelection in FOptions.PaintOptions) then - AlphaBlendSelection(Brush.Color) - else - with TWithSafeRect(InnerRect) do - RoundRect(Left, Top, Right, Bottom, FSelectionCurveRadius, FSelectionCurveRadius); - end; - end; - end; - - if (tsUseExplorerTheme in FStates) and (toHotTrack in FOptions.FPaintOptions) and (Node = FCurrentHotNode) and - ((Column = FCurrentHotColumn) or (toFullRowSelect in FOptions.FSelectionOptions)) then - DrawBackground(IfThen((vsSelected in Node.States) and not (toAlwaysHideSelection in FOptions.FPaintOptions), - TREIS_HOTSELECTED, TREIS_HOT)); - - if (Column = FFocusedColumn) or (toFullRowSelect in FOptions.FSelectionOptions) then - begin - // draw focus rect - if (poDrawFocusRect in PaintOptions) and - (Focused or (toPopupMode in FOptions.FPaintOptions)) and (FFocusedNode = Node) and - ( (Column = FFocusedColumn) or - ((not (toExtendedFocus in FOptions.FSelectionOptions) or IsWinVistaOrAbove) and - (toFullRowSelect in FOptions.FSelectionOptions) and - (tsUseExplorerTheme in FStates) ) ) then - begin - TextColorBackup := GetTextColor(Handle); - SetTextColor(Handle, $FFFFFF); - BackColorBackup := GetBkColor(Handle); - SetBkColor(Handle, 0); - - if not (toExtendedFocus in FOptions.FSelectionOptions) and (toFullRowSelect in FOptions.FSelectionOptions) and - (tsUseExplorerTheme in FStates) then - FocusRect := RowRect - else - if toGridExtensions in FOptions.FMiscOptions then - FocusRect := CellRect - else - FocusRect := InnerRect; - - if tsUseExplorerTheme in FStates then - InflateRect(FocusRect, -1, -1); - - if (tsUseExplorerTheme in FStates) and IsWinVistaOrAbove then - begin - //Draw focused unselected style like Windows 7 Explorer - if not (vsSelected in Node.States) then - DrawThemedFocusRect(LIS_NORMAL) - else - DrawBackground(TREIS_HOTSELECTED); - end - else - Winapi.Windows.DrawFocusRect(Handle, FocusRect); - SetTextColor(Handle, TextColorBackup); - SetBkColor(Handle, BackColorBackup); - end; - end; - end; - - if tsUseExplorerTheme in FStates then - CloseThemeData(Theme); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.ReadChunk(Stream: TStream; Version: Integer; Node: PVirtualNode; ChunkType, - ChunkSize: Integer): Boolean; - -// Called while loading a tree structure, Node is already valid (allocated) at this point. -// The function handles the base and user chunks, any other chunk is marked as being unknown (result becomes False) -// and skipped. descendants may handle them by overriding this method. -// Returns True if the chunk could be handled, otherwise False. -type - TAdvancedVersion2Identifier = packed record - ChildCount, - NodeHeight: Cardinal; - States: Word; - Align: Byte; - CheckState: TCheckState; - CheckType: TCheckType; - Reserved: Cardinal; - end; - -var - IdBody: TAdvancedVersion2Identifier; - ChunkBody: TBaseChunkBody; - Run: PVirtualNode; - LastPosition: Integer; - -begin - case ChunkType of - BaseChunk: - begin - // Load base chunk's body (chunk header has already been consumed). - case Version of - 1: - begin - with ChunkBody do - begin - // In version prior to 2 there was a smaller chunk body. Hence we have to read it entry by entry now. - Stream.Read(ChildCount, SizeOf(ChildCount)); - Stream.Read(NodeHeight, SizeOf(NodeHeight)); - // TVirtualNodeStates was a byte sized type in version 1. - States := []; - Stream.Read(States, SizeOf(Byte)); - // vsVisible is now in the place where vsSelected was before, but every node was visible in the old version - // so we need to fix this too. - if vsVisible in States then - //sync path note: prior version stream reading, ignored for syncing - Include(States, vsSelected) - else - Include(States, vsVisible); - Stream.Read(Align, SizeOf(Align)); - Stream.Read(CheckState, SizeOf(CheckState)); - Stream.Read(CheckType, SizeOf(CheckType)); - end; - end; - 2: - begin - ZeroMemory(@IdBody, SizeOf(IdBody)); - Stream.Read(IdBody, SizeOf(IdBody)); - // If Align is greater than zero, we have a stream prior to VT version 6.2 - if IdBody.Align > 0 then - with ChunkBody do - begin - ChildCount := IdBody.ChildCount; - NodeHeight := IdBody.NodeHeight; - States := []; - Move(IdBody.States, States, SizeOf(IdBody.States)); - CheckState := IdBody.CheckState; - CheckType := IdBody.CheckType; - Reserved := IdBody.Reserved; - end - else - begin - // Stream is compatible with current size of TBaseChunkBody - Stream.Position := Stream.Position - SizeOf(IdBody); - Stream.Read(ChunkBody, SizeOf(ChunkBody)); - end; - end; - 3: - Stream.Read(ChunkBody, SizeOf(ChunkBody)); - end; - - with Node^ do - begin - // Set states first, in case the node is invisible. - States := ChunkBody.States; - NodeHeight := ChunkBody.NodeHeight; - TotalHeight := NodeHeight; - Align := ChunkBody.Align; - CheckState := ChunkBody.CheckState; - CheckType := ChunkBody.CheckType; - ChildCount := ChunkBody.ChildCount; - - // Create and read child nodes. - while ChunkBody.ChildCount > 0 do - begin - Run := MakeNewNode; - - Run.PrevSibling := Node.LastChild; - if Assigned(Run.PrevSibling) then - Run.Index := Run.PrevSibling.Index + 1; - if Assigned(Node.LastChild) then - Node.LastChild.NextSibling := Run - else - Node.FirstChild := Run; - Node.LastChild := Run; - Run.Parent := Node; - - ReadNode(Stream, Version, Run); - Dec(ChunkBody.ChildCount); - end; - end; - Result := True; - end; - UserChunk: - if ChunkSize > 0 then - begin - // need to know whether the data was read - LastPosition := Stream.Position; - DoLoadUserData(Node, Stream); - // compare stream position to learn whether the data was read - Result := Stream.Position > LastPosition; - // Improve stability by advancing the stream to the chunk's real end if - // the application did not read what has been written. - if not Result or (Stream.Position <> (LastPosition + ChunkSize)) then - Stream.Position := LastPosition + ChunkSize; - end - else - Result := True; - else - // unknown chunk, skip it - Stream.Position := Stream.Position + ChunkSize; - Result := False; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.ReadNode(Stream: TStream; Version: Integer; Node: PVirtualNode); - -// Reads the anchor chunk of each node and initiates reading the sub chunks for this node - -var - Header: TChunkHeader; - EndPosition: Integer; - -begin - with Stream do - begin - // Read anchor chunk of the node. - Stream.Read(Header, SizeOf(Header)); - if Header.ChunkType = NodeChunk then - begin - EndPosition := Stream.Position + Header.ChunkSize; - // Read all subchunks until the indicated chunk end position is reached in the stream. - while Position < EndPosition do - begin - // Read new chunk header. - Stream.Read(Header, SizeOf(Header)); - ReadChunk(Stream, Version, Node, Header.ChunkType, Header.ChunkSize); - end; - // If the last chunk does not end at the given end position then there is something wrong. - if Position <> EndPosition then - ShowError(SCorruptStream2, hcTFCorruptStream2); - end - else - ShowError(SCorruptStream1, hcTFCorruptStream1); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.RedirectFontChangeEvent(Canvas: TCanvas); - -begin - if @Canvas.Font.OnChange <> @FOldFontChange then - begin - FOldFontChange := Canvas.Font.OnChange; - Canvas.Font.OnChange := FontChanged; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.RemoveFromSelection(Node: PVirtualNode); - -var - Index: Integer; - -begin - if not FSelectionLocked then - begin - Assert(Assigned(Node), 'Node must not be nil!'); - Assert(GetCurrentThreadId = MainThreadId, Self.Classname + '.RemoveFromSelection() must only be called from UI thread.'); - if vsSelected in Node.States then - begin - Assert(FSelectionCount > 0, 'if one node has set the vsSelected flag, SelectionCount must be >0.'); - //sync path note: deselect when a ctrl click removes a selection - Exclude(Node.States, vsSelected); - if SyncCheckstateWithSelection[Node] then - Node.CheckState := csUncheckedNormal; // Avoid using SetCheckState() as it handles toSyncCheckboxesWithSelection as well. - - if FindNodeInSelection(Node, Index, -1, -1) and (Index < FSelectionCount - 1) then - Move(FSelection[Index + 1], FSelection[Index], (FSelectionCount - Index - 1) * SizeOf(Pointer)); - if FSelectionCount > 0 then - Dec(FSelectionCount); - SetLength(FSelection, FSelectionCount); - - if FSelectionCount = 0 then - ResetRangeAnchor; - - if FSelectionCount <= 1 then - UpdateNextNodeToSelect(Node); - - DoRemoveFromSelection(Node); - InvalidateNode(Node); - Change(Node); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.UpdateNextNodeToSelect(Node: PVirtualNode); - -// save a potential node to select after the currently selected node will be deleted. -// This will make the VT to behave more like the Win32 TreeView, which always selecta a new node if the currently -// selected one gets deleted. - -begin - if not (toAlwaysSelectNode in TreeOptions.SelectionOptions) then - Exit; - if GetNextSibling(Node) <> nil then - FNextNodeToSelect := GetNextSibling(Node) - else if GetPreviousSibling(Node) <> nil then - FNextNodeToSelect := GetPreviousSibling(Node) - else if Node.Parent <> FRoot then - FNextNodeToSelect := Node.Parent - else - FNextNodeToSelect := nil; -end;//if Assigned(Node); - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.RenderOLEData(const FormatEtcIn: TFormatEtc; out Medium: TStgMedium; - ForClipboard: Boolean): HResult; - -// Returns a memory expression of all currently selected nodes in the Medium structure. -// Note: The memory requirement of this method might be very high. This depends however on the requested storage format. -// For HGlobal (a global memory block) we need to render first all nodes to local memory and copy this then to -// the global memory in Medium. This is necessary because we have first to determine how much -// memory is needed before we can allocate it. Hence for a short moment we need twice the space as used by the -// nodes alone (plus the amount the nodes need in the tree anyway)! -// With IStream this does not happen. We directly stream out the nodes and pass the constructed stream along. - - //--------------- local function -------------------------------------------- - - procedure WriteNodes(Stream: TStream); - - var - Selection: TNodeArray; - I: Integer; - - begin - if ForClipboard then - Selection := GetSortedCutCopySet(True) - else - Selection := GetSortedSelection(True); - for I := 0 to High(Selection) do - WriteNode(Stream, Selection[I]); - end; - - //--------------- end local function ---------------------------------------- - -var - Data: PCardinal; - ResPointer: Pointer; - ResSize: Integer; - OLEStream: IStream; - VCLStream: TStream; - -begin - ZeroMemory (@Medium, SizeOf(Medium)); - - // We can render the native clipboard format in two different storage media. - if (FormatEtcIn.cfFormat = CF_VIRTUALTREE) and (FormatEtcIn.tymed and (TYMED_HGLOBAL or TYMED_ISTREAM) <> 0) then - begin - VCLStream := nil; - try - Medium.unkForRelease := nil; - // Return data in one of the supported storage formats, prefer IStream. - if FormatEtcIn.tymed and TYMED_ISTREAM <> 0 then - begin - // Create an IStream on a memory handle (here it is 0 which indicates to implicitely allocated a handle). - // Do not use TStreamAdapter as it is not compatible with OLE (when flushing the clipboard OLE wants the HGlobal - // back which is not supported by TStreamAdapater). - CreateStreamOnHGlobal(0, True, OLEStream); - VCLStream := TOLEStream.Create(OLEStream); - WriteNodes(VCLStream); - // Rewind stream. - VCLStream.Position := 0; - Medium.tymed := TYMED_ISTREAM; - IUnknown(Medium.stm) := OLEStream; - Result := S_OK; - end - else - begin - VCLStream := TMemoryStream.Create; - WriteNodes(VCLStream); - ResPointer := TMemoryStream(VCLStream).Memory; - ResSize := VCLStream.Position; - - // Allocate memory to hold the string. - if ResSize > 0 then - begin - Medium.hGlobal := GlobalAlloc(GHND or GMEM_SHARE, ResSize + SizeOf(Cardinal)); - Data := GlobalLock(Medium.hGlobal); - // Store the size of the data too, for easy retrival. - Data^ := ResSize; - Inc(Data); - Move(ResPointer^, Data^, ResSize); - GlobalUnlock(Medium.hGlobal); - Medium.tymed := TYMED_HGLOBAL; - - Result := S_OK; - end - else - Result := E_FAIL; - end; - finally - // We can free the VCL stream here since it was either a pure memory stream or only a wrapper around - // the OLEStream which exists independently. - VCLStream.Free; - end; - end - else // Ask application descendants to render self defined formats. - Result := DoRenderOLEData(FormatEtcIn, Medium, ForClipboard); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.ResetRangeAnchor; - -// Called when there is no selected node anymore and the selection range anchor needs a new value. - -begin - FRangeAnchor := FFocusedNode; - FLastSelectionLevel := -1; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.RestoreFontChangeEvent(Canvas: TCanvas); - -begin - Canvas.Font.OnChange := FOldFontChange; - FOldFontChange := nil; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SelectNodes(StartNode, EndNode: PVirtualNode; AddOnly: Boolean); - -// Selects a range of nodes and unselects all other eventually selected nodes which are not in this range if -// AddOnly is False. -// EndNode must be visible while StartNode does not necessarily as in the case where the last focused node is the start -// node but it is a child of a node which has been collapsed previously. In this case the first visible parent node -// is used as start node. StartNode can be nil in which case the very first node in the tree is used. - -var - NodeFrom, - NodeTo, - LastAnchor: PVirtualNode; - Index: Integer; - -begin - Assert(Assigned(EndNode), 'EndNode must not be nil!'); - if not FSelectionLocked then - begin - ClearTempCache; - if StartNode = nil then - StartNode := GetFirstVisibleNoInit(nil, True) - else - if not FullyVisible[StartNode] then - begin - StartNode := GetPreviousVisible(StartNode, True); - if StartNode = nil then - StartNode := GetFirstVisibleNoInit(nil, True); - end; - - if CompareNodePositions(StartNode, EndNode, True) < 0 then - begin - NodeFrom := StartNode; - NodeTo := EndNode; - end - else - begin - NodeFrom := EndNode; - NodeTo := StartNode; - end; - - // The range anchor will be reset by the following call. - LastAnchor := FRangeAnchor; - if not AddOnly then - InternalClearSelection; - - while NodeFrom <> NodeTo do - begin - InternalCacheNode(NodeFrom); - NodeFrom := GetNextVisible(NodeFrom, True); - end; - // select last node too - InternalCacheNode(NodeFrom); - // now add them all in "one" step - AddToSelection(FTempNodeCache, FTempNodeCount); - ClearTempCache; - if Assigned(LastAnchor) and FindNodeInSelection(LastAnchor, Index, -1, -1) then - FRangeAnchor := LastAnchor; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetFocusedNodeAndColumn(Node: PVirtualNode; Column: TColumnIndex); - -var - OldColumn: TColumnIndex; - WasDifferent: Boolean; - -begin - if not FHeader.AllowFocus(Column) then - Column := FFocusedColumn; - - WasDifferent := (Node <> FFocusedNode) or (Column <> FFocusedColumn); - - OldColumn := FFocusedColumn; - FFocusedColumn := Column; - - DoFocusNode(Node, True); - - // Check if the change was accepted. - if FFocusedNode = Node then - begin - CancelEditNode; - if WasDifferent then - DoFocusChange(FFocusedNode, FFocusedColumn); - end - else - // If the user did not accept the new cell to focus then set also the focused column back - // to its original state. - FFocusedColumn := OldColumn; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SkipNode(Stream: TStream); - -// Skips the data for the next node in the given stream (including the child nodes). - -var - Header: TChunkHeader; - -begin - with Stream do - begin - // read achor chunk of the node - Stream.Read(Header, SizeOf(Header)); - if Header.ChunkType = NodeChunk then - Stream.Position := Stream.Position + Header.ChunkSize - else - ShowError(SCorruptStream1, hcTFCorruptStream1); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -var - PanningWindowClass: TWndClass = ( - style: 0; - lpfnWndProc: @DefWindowProc; - cbClsExtra: 0; - cbWndExtra: 0; - hInstance: 0; - hIcon: 0; - hCursor: 0; - hbrBackground: 0; - lpszMenuName: nil; - lpszClassName: 'VTPanningWindow' - ); - -procedure TBaseVirtualTree.StartWheelPanning(Position: TPoint); - -// Called when wheel panning should start. A little helper window is created to indicate the reference position, -// which determines in which direction and how far wheel panning/scrolling will happen. - - //--------------- local function -------------------------------------------- - - function CreateClipRegion: HRGN; - - // In order to avoid doing all the transparent drawing ourselves we use a - // window region for the wheel window. - // Since we only work on a very small image (32x32 pixels) this is acceptable. - - var - Start, X, Y: Integer; - Temp: HRGN; - - begin - Assert(not FPanningImage.Empty, 'Invalid wheel panning image.'); - - // Create an initial region on which we operate. - Result := CreateRectRgn(0, 0, 0, 0); - with FPanningImage, Canvas do - begin - for Y := 0 to Height - 1 do - begin - Start := -1; - for X := 0 to Width - 1 do - begin - // Start a new span if we found a non-transparent pixel and no span is currently started. - if (Start = -1) and (Pixels[X, Y] <> clFuchsia) then - Start := X - else - if (Start > -1) and (Pixels[X, Y] = clFuchsia) then - begin - // A non-transparent span is finished. Add it to the result region. - Temp := CreateRectRgn(Start, Y, X, Y + 1); - CombineRgn(Result, Result, Temp, RGN_OR); - DeleteObject(Temp); - Start := -1; - end; - end; - // If there is an open span then add this also to the result region. - if Start > -1 then - begin - Temp := CreateRectRgn(Start, Y, Width, Y + 1); - CombineRgn(Result, Result, Temp, RGN_OR); - DeleteObject(Temp); - end; - end; - end; - // The resulting region is used as window region so we must not delete it. - // Windows will own it after the assignment below. - end; - - //--------------- end local function ---------------------------------------- - -var - TempClass: TWndClass; - ClassRegistered: Boolean; - ImageName: string; - Pt: TPoint; - -begin - // Set both panning and scrolling flag. One will be removed shortly depending on whether the middle mouse button is - // released before the mouse is moved or vice versa. The first case is referred to as wheel scrolling while the - // latter is called wheel panning. - StopTimer(ScrollTimer); - DoStateChange([tsWheelPanning, tsWheelScrolling]); - - // Register the helper window class. - PanningWindowClass.hInstance := HInstance; - ClassRegistered := GetClassInfo(HInstance, PanningWindowClass.lpszClassName, TempClass); - if not ClassRegistered or (TempClass.lpfnWndProc <> @DefWindowProc) then - begin - if ClassRegistered then - Winapi.Windows.UnregisterClass(PanningWindowClass.lpszClassName, HInstance); - Winapi.Windows.RegisterClass(PanningWindowClass); - end; - // Create the helper window and show it at the given position without activating it. - Pt := ClientToScreen(Position); - FPanningWindow := CreateWindowEx(WS_EX_TOOLWINDOW, PanningWindowClass.lpszClassName, nil, WS_POPUP, Pt.X - 16, Pt.Y - 16, - 32, 32, Handle, 0, HInstance, nil); - - FPanningImage := TBitmap.Create; - if Integer(FRangeX) > ClientWidth then - begin - if Integer(FRangeY) > ClientHeight then - ImageName := 'VT_MOVEALL' - else - ImageName := 'VT_MOVEEW'; - end - else - ImageName := 'VT_MOVENS'; - FPanningImage.LoadFromResourceName(HInstance, ImageName); - SetWindowRgn(FPanningWindow, CreateClipRegion, False); - - {$ifdef CPUX64} - SetWindowLongPtr(FPanningWindow, GWLP_WNDPROC, LONG_PTR(System.Classes.MakeObjectInstance(PanningWindowProc))); - {$else} - SetWindowLong(FPanningWindow, GWL_WNDPROC, NativeInt(System.Classes.MakeObjectInstance(PanningWindowProc))); - {$endif CPUX64} - ShowWindow(FPanningWindow, SW_SHOWNOACTIVATE); - - // Setup the panscroll timer and capture all mouse input. - SetFocus; - SetCapture(Handle); - SetTimer(Handle, ScrollTimer, 20, nil); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.StopWheelPanning; - -// Stops panning if currently active and destroys the helper window. - -var - Instance: Pointer; - -begin - if [tsWheelPanning, tsWheelScrolling] * FStates <> [] then - begin - // Release the mouse capture and stop the panscroll timer. - StopTimer(ScrollTimer); - ReleaseCapture; - DoStateChange([], [tsWheelPanning, tsWheelScrolling]); - - // Destroy the helper window. - {$ifdef CPUX64} - Instance := Pointer(GetWindowLongPtr(FPanningWindow, GWLP_WNDPROC)); - {$else} - Instance := Pointer(GetWindowLong(FPanningWindow, GWL_WNDPROC)); - {$endif CPUX64} - DestroyWindow(FPanningWindow); - if Instance <> @DefWindowProc then - System.Classes.FreeObjectInstance(Instance); - FPanningWindow := 0; - FPanningImage.Free; - FPanningImage := nil; - DeleteObject(FPanningCursor); - FPanningCursor := 0; - Winapi.Windows.SetCursor(Screen.Cursors[Cursor]); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.StructureChange(Node: PVirtualNode; Reason: TChangeReason); - -begin - AdviseChangeEvent(True, Node, Reason); - - if FUpdateCount = 0 then - begin - if (FChangeDelay > 0) and HandleAllocated and not (tsSynchMode in FStates) then - SetTimer(Handle, StructureChangeTimer, FChangeDelay, nil) - else - DoStructureChange(Node, Reason); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.SuggestDropEffect(Source: TObject; Shift: TShiftState; Pt: TPoint; - AllowedEffects: Integer): Integer; - -// determines the drop action to take if the drag'n drop operation ends on this tree -// Note: Source can be any Delphi object not just a virtual tree - -begin - Result := AllowedEffects; - - // prefer MOVE if source and target are the same control, otherwise whatever is allowed as initial value - if Assigned(Source) and (Source = Self) then - if (AllowedEffects and DROPEFFECT_MOVE) <> 0 then - Result := DROPEFFECT_MOVE - else // no change - else - // drag between different applicatons - if (AllowedEffects and DROPEFFECT_COPY) <> 0 then - Result := DROPEFFECT_COPY; - - // consider modifier keys and what is allowed at the moment, if none of the following conditions apply then - // the initial value just set is used - if ssCtrl in Shift then - begin - // copy or link - if ssShift in Shift then - begin - // link - if (AllowedEffects and DROPEFFECT_LINK) <> 0 then - Result := DROPEFFECT_LINK; - end - else - begin - // copy - if (AllowedEffects and DROPEFFECT_COPY) <> 0 then - Result := DROPEFFECT_COPY; - end; - end - else - begin - // move, link or default - if ssShift in Shift then - begin - // move - if (AllowedEffects and DROPEFFECT_MOVE) <> 0 then - Result := DROPEFFECT_MOVE; - end - else - begin - // link or default - if ssAlt in Shift then - begin - // link - if (AllowedEffects and DROPEFFECT_LINK) <> 0 then - Result := DROPEFFECT_LINK; - end; - // else default - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.ToggleSelection(StartNode, EndNode: PVirtualNode); - -// Switchs the selection state of a range of nodes. -// Note: This method is specifically designed to help selecting ranges with the keyboard and considers therefore -// the range anchor. - -var - NodeFrom, - NodeTo: PVirtualNode; - NewSize: Integer; - Position: Integer; - -begin - if not FSelectionLocked then - begin - Assert(Assigned(EndNode), 'EndNode must not be nil!'); - if StartNode = nil then - StartNode := FRoot.FirstChild - else - if not FullyVisible[StartNode] then - StartNode := GetPreviousVisible(StartNode, True); - - Position := CompareNodePositions(StartNode, EndNode); - // nothing to do if start and end node are the same - if Position <> 0 then - begin - if Position < 0 then - begin - NodeFrom := StartNode; - NodeTo := EndNode; - end - else - begin - NodeFrom := EndNode; - NodeTo := StartNode; - end; - - ClearTempCache; - - // 1) toggle the start node if it is before the range anchor - if CompareNodePositions(NodeFrom, FRangeAnchor) < 0 then - if not (vsSelected in NodeFrom.States) then - InternalCacheNode(NodeFrom) - else - InternalRemoveFromSelection(NodeFrom); - - // 2) toggle all nodes within the range - NodeFrom := GetNextVisible(NodeFrom, True); - while NodeFrom <> NodeTo do - begin - if not (vsSelected in NodeFrom.States) then - InternalCacheNode(NodeFrom) - else - InternalRemoveFromSelection(NodeFrom); - NodeFrom := GetNextVisible(NodeFrom, True); - end; - - // 3) toggle end node if it is after the range anchor - if CompareNodePositions(NodeFrom, FRangeAnchor) > 0 then - if not (vsSelected in NodeFrom.States) then - InternalCacheNode(NodeFrom) - else - InternalRemoveFromSelection(NodeFrom); - - // Do some housekeeping if there was a change. - NewSize := PackArray(FSelection, FSelectionCount); - if NewSize > -1 then - begin - FSelectionCount := NewSize; - SetLength(FSelection, FSelectionCount); - end; - // If the range went over the anchor then we need to reselect it. - if not (vsSelected in FRangeAnchor.States) then - InternalCacheNode(FRangeAnchor); - if FTempNodeCount > 0 then - AddToSelection(FTempNodeCache, FTempNodeCount); - ClearTempCache; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.UnselectNodes(StartNode, EndNode: PVirtualNode); - -// Deselects a range of nodes. -// EndNode must be visible while StartNode must not as in the case where the last focused node is the start node -// but it is a child of a node which has been collapsed previously. In this case the first visible parent node -// is used as start node. StartNode can be nil in which case the very first node in the tree is used. - -var - NodeFrom, - NodeTo: PVirtualNode; - NewSize: Integer; - -begin - if not FSelectionLocked then - begin - Assert(Assigned(EndNode), 'EndNode must not be nil!'); - - if StartNode = nil then - StartNode := FRoot.FirstChild - else - if not FullyVisible[StartNode] then - begin - StartNode := GetPreviousVisible(StartNode, True); - if StartNode = nil then - StartNode := FRoot.FirstChild; - end; - - if CompareNodePositions(StartNode, EndNode) < 0 then - begin - NodeFrom := StartNode; - NodeTo := EndNode; - end - else - begin - NodeFrom := EndNode; - NodeTo := StartNode; - end; - - while NodeFrom <> NodeTo do - begin - InternalRemoveFromSelection(NodeFrom); - NodeFrom := GetNextVisible(NodeFrom, True); - end; - // Deselect last node too. - InternalRemoveFromSelection(NodeFrom); - - // Do some housekeeping. - NewSize := PackArray(FSelection, FSelectionCount); - if NewSize > -1 then - begin - FSelectionCount := NewSize; - SetLength(FSelection, FSelectionCount); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.UpdateColumnCheckState(Col: TVirtualTreeColumn); - -begin - Col.CheckState := DetermineNextCheckState(Col.CheckType, Col.CheckState); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.UpdateDesigner; - -var - ParentForm: TCustomForm; - -begin - if (csDesigning in ComponentState) and not (csUpdating in ComponentState) then - begin - ParentForm := GetParentForm(Self); - if Assigned(ParentForm) and Assigned(ParentForm.Designer) then - ParentForm.Designer.Modified; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.UpdateHeaderRect(); - -// Calculates the rectangle the header occupies in non-client area. -// These coordinates are in window rectangle. - -var - OffsetX, - OffsetY: Integer; - EdgeSize: Integer; - Size: TSize; - -begin - FHeaderRect := Rect(0, 0, Width, Height); - - // Consider borders... - if HandleAllocated then begin // Prevent preliminary creation of window handle, see issue #933 - Size := GetBorderDimensions(); - InflateRect(FHeaderRect, Size.cx, Size.cy); - end; - - // ... and bevels. - OffsetX := BorderWidth; - OffsetY := BorderWidth; - if BevelKind <> bkNone then - begin - EdgeSize := 0; - if BevelInner <> bvNone then - Inc(EdgeSize, BevelWidth); - if BevelOuter <> bvNone then - Inc(EdgeSize, BevelWidth); - if beLeft in BevelEdges then - Inc(OffsetX, EdgeSize); - if beTop in BevelEdges then - Inc(OffsetY, EdgeSize); - end; - - InflateRect(FHeaderRect, -OffsetX, -OffsetY); - - if hoVisible in FHeader.FOptions then - begin - if FHeaderRect.Left <= FHeaderRect.Right then - FHeaderRect.Bottom := FHeaderRect.Top + Integer(FHeader.FHeight) - else - FHeaderRect := Rect(0, 0, 0, 0); - end - else - FHeaderRect.Bottom := FHeaderRect.Top; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.UpdateEditBounds; - -// Used to update the bounds of the current node editor if editing is currently active. - -var - R: TRect; - CurrentAlignment: TAlignment; - CurrentBidiMode: TBidiMode; - offsets : TVTOffsets; - offset : Integer; - -begin - if (tsEditing in FStates) and Assigned(FFocusedNode) and - (FEditColumn < FHeader.Columns.Count) then // prevent EArgumentOutOfRangeException - begin - if (GetCurrentThreadId <> MainThreadID) then - begin - // UpdateEditBounds() will be called at the end of the thread - Exit; - end; - if vsMultiline in FFocusedNode.States then - R := GetDisplayRect(FFocusedNode, FEditColumn, True, False) - else if not (toGridExtensions in FOptions.FMiscOptions) then - R := GetDisplayRect(FFocusedNode, FEditColumn, True, True); - - if (toGridExtensions in FOptions.FMiscOptions) then - begin - // Use the whole cell when grid extensions are on. - R := GetDisplayRect(FFocusedNode, FEditColumn, False, False); - if FEditColumn = FHeader.MainColumn then - begin - // Calculate an offset for the main column. - GetOffsets(FFocusedNode, offsets, ofsLabel, FEditColumn); - offset := offsets[ofsLabel]; -// if offsets[ofsToggleButton] < 0 then -// Inc(offset, offsets[ofsToggleButton]); - end - else - offset := 0; - - // Adjust edit bounds depending on alignment and bidi mode. - if FEditColumn <= NoColumn then - begin - CurrentAlignment := Alignment; - CurrentBidiMode := BiDiMode; - end - else - begin - CurrentAlignment := FHeader.Columns[FEditColumn].FAlignment; - CurrentBidiMode := FHeader.Columns[FEditColumn].FBiDiMode; - end; - // Consider bidi mode here. In RTL context does left alignment actually mean right alignment and vice versa. - if CurrentBidiMode <> bdLeftToRight then - ChangeBiDiModeAlignment(CurrentAlignment); - if CurrentAlignment = taLeftJustify then - begin - if CurrentBiDiMode = bdLeftToRight then - Inc(R.Left, offset) - else - Dec(R.Right, offset); - end - else - begin - if CurrentBiDiMode = bdLeftToRight then - Inc(R.Left, offset) - else - Dec(R.Right, offset); - end; - end; - if toShowHorzGridLines in TreeOptions.PaintOptions then - Dec(R.Bottom); - R.Bottom := R.Top + R.Bottom - R.Top; - FEditLink.SetBounds(R); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -const - ScrollMasks: array[Boolean] of Cardinal = (0, SIF_DISABLENOSCROLL); - -const // Region identifiers for GetRandomRgn - CLIPRGN = 1; - METARGN = 2; - APIRGN = 3; - SYSRGN = 4; - -function GetRandomRgn(DC: HDC; Rgn: HRGN; iNum: Integer): Integer; stdcall; external 'GDI32.DLL'; - -procedure TBaseVirtualTree.UpdateWindowAndDragImage(const Tree: TBaseVirtualTree; TreeRect: TRect; UpdateNCArea, - ReshowDragImage: Boolean); - -// Method to repaint part of the window area which is not covered by the drag image and to initiate a recapture -// of the drag image. -// Note: This method must only be called during a drag operation and the tree passed in is the one managing the current -// drag image (so it is the actual drag source). - -var - DragRegion, // the region representing the drag image - UpdateRegion, // the unclipped region within the tree to be updated - NCRegion: HRGN; // the region representing the non-client area of the tree - DragRect, - NCRect: TRect; - RedrawFlags: Cardinal; - - VisibleTreeRegion: HRGN; - - DC: HDC; - - //This function was originally designed only for tree's drag image. But we modified - //it for reusing it with header's drag image too for solving issue 248. - useDragImage: TVTDragImage; -begin - if IntersectRect(TreeRect, TreeRect, ClientRect) then - begin - // Retrieve the visible region of the window. This is important to avoid overpainting parts of other windows - // which overlap this one. - VisibleTreeRegion := CreateRectRgn(0, 0, 1, 1); - DC := GetDCEx(Handle, 0, DCX_CACHE or DCX_WINDOW or DCX_CLIPSIBLINGS or DCX_CLIPCHILDREN); - GetRandomRgn(DC, VisibleTreeRegion, SYSRGN); - ReleaseDC(Handle, DC); - - //Take proper drag image depending on whether the drag is being done in the tree - //or in the header. - useDragImage := Tree.FDragImage; - if (not useDragImage.Visible) - and (Tree.FHeader.DragImage <> nil) and (Tree.FHeader.DragImage.Visible) - then - useDragImage := Tree.FHeader.DragImage; - - // The drag image will figure out itself what part of the rectangle can be recaptured. - // Recapturing is not done by taking a snapshot of the screen, but by letting the tree draw itself - // into the back bitmap of the drag image. So the order here is unimportant. - useDragImage.RecaptureBackground(Self, TreeRect, VisibleTreeRegion, UpdateNCArea, ReshowDragImage); - - // Calculate the screen area not covered by the drag image and which needs an update. - DragRect := useDragImage.GetDragImageRect; - MapWindowPoints(0, Handle, DragRect, 2); - DragRegion := CreateRectRgnIndirect(DragRect); - - // Start with non-client area if requested. - if UpdateNCArea then - begin - // Compute the part of the non-client area which must be updated. - - // Determine the outer rectangle of the entire tree window. - GetWindowRect(Handle, NCRect); - // Express the tree window rectangle in client coordinates (because RedrawWindow wants them so). - MapWindowPoints(0, Handle, NCRect, 2); - NCRegion := CreateRectRgnIndirect(NCRect); - // Determine client rect in screen coordinates and create another region for it. - UpdateRegion := CreateRectRgnIndirect(ClientRect); - // Create a region which only contains the NC part by subtracting out the client area. - CombineRgn(NCRegion, NCRegion, UpdateRegion, RGN_DIFF); - // Subtract also out what is hidden by the drag image. - CombineRgn(NCRegion, NCRegion, DragRegion, RGN_DIFF); - RedrawWindow(Handle, nil, NCRegion, RDW_FRAME or RDW_NOERASE or RDW_NOCHILDREN or RDW_INVALIDATE or RDW_VALIDATE or - RDW_UPDATENOW); - DeleteObject(NCRegion); - DeleteObject(UpdateRegion); - end; - - UpdateRegion := CreateRectRgnIndirect(TreeRect); - RedrawFlags := RDW_INVALIDATE or RDW_VALIDATE or RDW_UPDATENOW or RDW_NOERASE or RDW_NOCHILDREN; - // Remove the part of the update region which is covered by the drag image. - CombineRgn(UpdateRegion, UpdateRegion, DragRegion, RGN_DIFF); - RedrawWindow(Handle, nil, UpdateRegion, RedrawFlags); - DeleteObject(UpdateRegion); - DeleteObject(DragRegion); - DeleteObject(VisibleTreeRegion); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.ValidateCache(); - -// Starts cache validation if not already done by adding this instance to the worker thread's waiter list -// (if not already there) and signalling the thread it can start validating. - -begin - // Wait for thread to stop validation if it is currently validating this tree's cache. - InterruptValidation; - - FStartIndex := 0; - if (tsValidationNeeded in FStates) and (FVisibleCount > CacheThreshold) then - begin - // Tell the thread this tree needs actually something to do. - TWorkerThread.AddTree(Self); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.ValidateNodeDataSize(var Size: Integer); - -begin - Size := SizeOf(Pointer); - if Assigned(FOnGetNodeDataSize) then - FOnGetNodeDataSize(Self, Size); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.VclStyleChanged; - - // Updates the member FVclStyleEnabled, should be called initially and when the VCL style changes - -begin - FVclStyleEnabled := StyleServices.Enabled and not StyleServices.IsSystemStyle and not (csDesigning in ComponentState); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -//PROFILE-NO -procedure TBaseVirtualTree.WndProc(var Message: TMessage); - -var - Handled: Boolean; - -begin - Handled := False; - - // Try the header whether it needs to take this message. - if Assigned(FHeader) and (FHeader.FStates <> []) then - Handled := FHeader.HandleMessage(Message); - if not Handled then - begin - // For auto drag mode, let tree handle itself, instead of TControl. - if not (csDesigning in ComponentState) and - ((Message.Msg = WM_LBUTTONDOWN) or (Message.Msg = WM_LBUTTONDBLCLK)) then - begin - if (DragMode = dmAutomatic) and (DragKind = dkDrag) then - begin - if IsControlMouseMsg(TWMMouse(Message)) then - Handled := True; - if not Handled then - begin - ControlState := ControlState + [csLButtonDown]; - Dispatch(Message); // overrides TControl's BeginDrag - Handled := True; - end; - end; - end; - - if not Handled and Assigned(FHeader) then - Handled := FHeader.HandleMessage(Message); - - if not Handled then - begin - if (Message.Msg in [WM_NCLBUTTONDOWN, WM_NCRBUTTONDOWN, WM_NCMBUTTONDOWN]) and not Focused and CanFocus then - SetFocus; - inherited; - end; - end; -end; -//PROFILE-YES - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WriteChunks(Stream: TStream; Node: PVirtualNode); - -// Writes the core chunks for Node into the stream. -// Note: descendants can optionally override this method to add other node specific chunks. -// Keep in mind that this method is also called for the root node. Using this fact in descendants you can -// create a kind of "global" chunks not directly bound to a specific node. - -var - Header: TChunkHeader; - LastPosition, - ChunkSize: Integer; - Chunk: TBaseChunk; - Run: PVirtualNode; - -begin - with Stream do - begin - // 1. The base chunk... - LastPosition := Position; - Chunk.Header.ChunkType := BaseChunk; - with Node^, Chunk do - begin - Body.ChildCount := ChildCount; - Body.NodeHeight := NodeHeight; - // Some states are only temporary so take them out as they make no sense at the new location. - Body.States := States - [vsChecking, vsCutOrCopy, vsDeleting, vsOnFreeNodeCallRequired, vsHeightMeasured]; - Body.Align := Align; - Body.CheckState := GetCheckState(Node); - Body.CheckType := CheckType; - Body.Reserved := 0; - end; - // write the base chunk - Write(Chunk, SizeOf(Chunk)); - - // 2. ... directly followed by the child node chunks (actually they are child chunks of - // the base chunk) - if vsInitialized in Node.States then - begin - Run := Node.FirstChild; - while Assigned(Run) do - begin - WriteNode(Stream, Run); - Run := Run.NextSibling; - end; - end; - - FinishChunkHeader(Stream, LastPosition, Position); - - // 3. write user data - LastPosition := Position; - Header.ChunkType := UserChunk; - Write(Header, SizeOf(Header)); - DoSaveUserData(Node, Stream); - // check if the application actually wrote data - ChunkSize := Position - LastPosition - SizeOf(TChunkHeader); - // seek back to start of chunk if nothing has been written - if ChunkSize = 0 then - begin - Position := LastPosition; - Size := Size - SizeOf(Header); - end - else - FinishChunkHeader(Stream, LastPosition, Position); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WriteNode(Stream: TStream; Node: PVirtualNode); - -// Writes the "cover" chunk for Node to Stream and initiates writing child nodes and chunks. - -var - LastPosition: Integer; - Header: TChunkHeader; - -begin - // Initialize the node first if necessary and wanted. - if toInitOnSave in FOptions.FMiscOptions then - begin - if not (vsInitialized in Node.States) then - InitNode(Node); - if (vsHasChildren in Node.States) and (Node.ChildCount = 0) then - InitChildren(Node); - end; - - with Stream do - begin - LastPosition := Position; - // Emit the anchor chunk. - Header.ChunkType := NodeChunk; - Write(Header, SizeOf(Header)); - // Write other chunks to stream taking their size into this chunk's size. - WriteChunks(Stream, Node); - - // Update chunk size. - FinishChunkHeader(Stream, LastPosition, Position); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.AbsoluteIndex(Node: PVirtualNode): Cardinal; - -begin - Result := 0; - while Assigned(Node) and (Node <> FRoot) do - begin - if not (vsInitialized in Node.States) then - InitNode(Node); - if Assigned(Node.PrevSibling) then - begin - // if there's a previous sibling then add its total count to the result - Node := Node.PrevSibling; - Inc(Result, Node.TotalCount); - end - else - begin - Node := Node.Parent; - if Node <> FRoot then - Inc(Result); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.AddChild(Parent: PVirtualNode; UserData: Pointer = nil): PVirtualNode; - -// Adds a new node to the given parent node. This is simply done by increasing the child count of the -// parent node. If Parent is nil then the new node is added as (last) top level node. -// UserData can be used to set the first SizeOf(Pointer) bytes of the user data area to an initial value which can be used -// in OnInitNode and will also cause to trigger the OnFreeNode event (if <> nil) even if the node is not yet -// "officially" initialized. -// AddChild is a compatibility method and will implicitly validate the parent node. This is however -// against the virtual paradigm and hence I dissuade from its usage. - -begin - if not (toReadOnly in FOptions.FMiscOptions) then - Result := InsertNode(Parent, TVTNodeAttachMode.amAddChildLast, UserData) - else - Result := nil; -end; - -function TBaseVirtualTree.AddChild(Parent: PVirtualNode; const UserData: IInterface): PVirtualNode; -begin - UserData._AddRef(); - Result := AddChild(Parent, Pointer(UserData)); - Include(Result.States, vsReleaseCallOnUserDataRequired); -end; - -function TBaseVirtualTree.AddChild(Parent: PVirtualNode; const UserData: TObject): PVirtualNode; -begin - Result := AddChild(Parent, Pointer(UserData)); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.AddFromStream(Stream: TStream; TargetNode: PVirtualNode); - -// loads nodes from the given stream and adds them to TargetNode -// the current content is not cleared before the load process starts (see also LoadFromStream) - -var - ThisID: TMagicID; - Version, - Count: Cardinal; - Node: PVirtualNode; - -begin - if not (toReadOnly in FOptions.FMiscOptions) then - begin - // check first whether this is a stream we can read - Stream.ReadBuffer(ThisID, SizeOf(TMagicID)); - if (ThisID[0] = MagicID[0]) and - (ThisID[1] = MagicID[1]) and - (ThisID[2] = MagicID[2]) and - (ThisID[5] = MagicID[5]) then - begin - Version := Word(ThisID[3]); - if Version <= VTTreeStreamVersion then - begin - BeginUpdate; - try - if Version < 2 then - Count := MaxInt - else - Stream.ReadBuffer(Count, SizeOf(Count)); - - while (Stream.Position < Stream.Size) and (Count > 0) do - begin - Dec(Count); - Node := MakeNewNode; - InternalConnectNode(Node, TargetNode, Self, amAddChildLast); - InternalAddFromStream(Stream, Version, Node); - end; - if TargetNode = FRoot then - DoNodeCopied(nil) - else - DoNodeCopied(TargetNode); - finally - EndUpdate; - end; - end - else - ShowError(SWrongStreamVersion, hcTFWrongStreamVersion); - end - else - ShowError(SWrongStreamVersion, hcTFWrongStreamVersion); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.AfterConstruction; - -begin - inherited; - - if FRoot = nil then - InitRootNode; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.Assign(Source: TPersistent); - -begin - if (Source is TBaseVirtualTree) and not (toReadOnly in FOptions.FMiscOptions) then - with Source as TBaseVirtualTree do - begin - Self.Align := Align; - Self.Anchors := Anchors; - Self.AutoScrollDelay := AutoScrollDelay; - Self.AutoScrollInterval := AutoScrollInterval; - Self.AutoSize := AutoSize; - Self.Background := Background; - Self.BevelEdges := BevelEdges; - Self.BevelInner := BevelInner; - Self.BevelKind := BevelKind; - Self.BevelOuter := BevelOuter; - Self.BevelWidth := BevelWidth; - Self.BiDiMode := BiDiMode; - Self.BorderStyle := BorderStyle; - Self.BorderWidth := BorderWidth; - Self.ChangeDelay := ChangeDelay; - Self.CheckImageKind := CheckImageKind; - Self.Color := Color; - Self.Colors.Assign(Colors); - Self.Constraints.Assign(Constraints); - Self.Ctl3D := Ctl3D; - Self.DefaultNodeHeight := DefaultNodeHeight; - Self.DefaultPasteMode := DefaultPasteMode; - Self.DragCursor := DragCursor; - Self.DragImageKind := DragImageKind; - Self.DragKind := DragKind; - Self.DragMode := DragMode; - Self.Enabled := Enabled; - Self.Font := Font; - Self.Header := Header; - Self.HintMode := HintMode; - Self.HotCursor := HotCursor; - Self.Images := Images; - Self.ImeMode := ImeMode; - Self.ImeName := ImeName; - Self.Indent := Indent; - Self.Margin := Margin; - Self.NodeAlignment := NodeAlignment; - Self.NodeDataSize := NodeDataSize; - Self.TreeOptions := TreeOptions; - Self.ParentBiDiMode := ParentBiDiMode; - Self.ParentColor := ParentColor; - Self.ParentCtl3D := ParentCtl3D; - Self.ParentFont := ParentFont; - Self.ParentShowHint := ParentShowHint; - Self.PopupMenu := PopupMenu; - Self.RootNodeCount := RootNodeCount; - Self.ScrollBarOptions := ScrollBarOptions; - Self.ShowHint := ShowHint; - Self.StateImages := StateImages; - Self.StyleElements := StyleElements; - Self.TabOrder := TabOrder; - Self.TabStop := TabStop; - Self.Visible := Visible; - Self.SelectionCurveRadius := SelectionCurveRadius; - Self.SelectionBlendFactor := SelectionBlendFactor; - Self.EmptyListMessage := EmptyListMessage; - end - else - inherited; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.AutoScale(isDpiChange: Boolean); - -// If toAutoChangeScale is set, this method ensures that the defaulz node height is set correctly. -// isDPIChnage is True, if the DPI of the form has changed. In this case the font may not yet be adapted to this, so do not adjust DefualtNodeHeight. - -var - lTextHeight: Cardinal; -begin - if HandleAllocated and (toAutoChangeScale in TreeOptions.AutoOptions) and not isDpiChange then - begin - Canvas.Font.Assign(Self.Font); - lTextHeight := Canvas.TextHeight('Tg') + 2; - // By default, we only ensure that DefaultNodeHeight is large enough. - // If the form's dpi has changed, we scale up and down the DefaultNodeHeight, See issue #677. - if (lTextHeight > Self.DefaultNodeHeight) then - Self.DefaultNodeHeight := lTextHeight; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.BeginDrag(Immediate: Boolean; Threshold: Integer); - -// Reintroduced method to allow to start OLE drag'n drop as well as VCL drag'n drop. - -begin - if FDragType = dtVCL then - begin - DoStateChange([tsVCLDragPending]); - inherited; - end - else - if (FStates * [tsOLEDragPending, tsOLEDragging]) = [] then - begin - // Drag start position has already been recorded in WMMouseDown. - if Threshold < 0 then - FDragThreshold := Mouse.DragThreshold - else - FDragThreshold := Threshold; - if Immediate then - DoDragging(FLastClickPos) - else - DoStateChange([tsOLEDragPending]); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.BeginSynch; - -// Starts the synchronous update mode (if not already active). - -begin - if not (csDestroying in ComponentState) then - begin - if FSynchUpdateCount = 0 then - begin - DoUpdating(usBeginSynch); - - // Stop all timers... - StopTimer(ChangeTimer); - StopTimer(StructureChangeTimer); - StopTimer(ExpandTimer); - StopTimer(EditTimer); - StopTimer(HeaderTimer); - StopTimer(ScrollTimer); - StopTimer(SearchTimer); - FSearchBuffer := ''; - FLastSearchNode := nil; - DoStateChange([], [tsEditPending, tsScrollPending, tsScrolling, tsIncrementalSearching]); - - // ...and trigger pending update states. - if tsStructureChangePending in FStates then - DoStructureChange(FLastStructureChangeNode, FLastStructureChangeReason); - if tsChangePending in FStates then - DoChange(FLastChangedNode); - end - else - DoUpdating(usSynch); - end; - Inc(FSynchUpdateCount); - DoStateChange([tsSynchMode]); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.BeginUpdate; - -begin - Assert(GetCurrentThreadId = MainThreadId, 'UI controls like ' + Classname + ' should only be manipulated through the main thread.'); - if not (csDestroying in ComponentState) then - begin - if FUpdateCount = 0 then - begin - DoUpdating(usBegin); - SetUpdateState(True); - end - else - DoUpdating(usUpdate); - end; - Inc(FUpdateCount); - DoStateChange([tsUpdating]); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.CancelCutOrCopy; - -// Resets nodes which are marked as being cut. - -var - Run: PVirtualNode; - -begin - if ([tsCutPending, tsCopyPending] * FStates) <> [] then - begin - Run := FRoot.FirstChild; - while Assigned(Run) do - begin - if vsCutOrCopy in Run.States then - Exclude(Run.States, vsCutOrCopy); - Run := GetNextNoInit(Run); - end; - end; - DoStateChange([], [tsCutPending, tsCopyPending]); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.CancelEditNode: Boolean; - -// Called by the application or the current edit link to cancel the edit action. - -begin - if HandleAllocated and ([tsEditing, tsEditPending] * FStates <> []) then - Result := DoCancelEdit - else - Result := True; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.CancelOperation; - -// Called by the application to cancel a long-running operation. - -begin - if FOperationCount > 0 then - FOperationCanceled := True; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.CanEdit(Node: PVirtualNode; Column: TColumnIndex): Boolean; - -// Returns True if the given node can be edited. - -begin - Result := (toEditable in FOptions.FMiscOptions) and Enabled and not (toReadOnly in FOptions.FMiscOptions) - and ((Column < 0) or (coEditable in FHeader.Columns[Column].Options)); - DoCanEdit(Node, Column, Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.CanFocus: Boolean; - -var - Form: TCustomForm; - -begin - Result := inherited CanFocus; - - if Result and not (csDesigning in ComponentState) then - begin - Form := GetParentForm(Self); - Result := (Form = nil) or (Form.Enabled and Form.Visible); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.Clear; - -begin - if (not IsEmpty and not (toReadOnly in FOptions.FMiscOptions)) or (csDestroying in ComponentState) then - begin - BeginUpdate; - try - InterruptValidation; - if IsEditing then - CancelEditNode; - - if ClipboardStates * FStates <> [] then - begin - OleSetClipboard(nil); - DoStateChange([], ClipboardStates); - end; - ClearSelection; - FFocusedNode := nil; - FLastSelected := nil; - FCurrentHotNode := nil; - FDropTargetNode := nil; - FLastChangedNode := nil; - FRangeAnchor := nil; - FLastVCLDragTarget := nil; - FLastSearchNode := nil; - DeleteChildren(FRoot, True); - FOffsetX := 0; - FOffsetY := 0; - - finally - EndUpdate; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.ClearChecked; - -var - Node: PVirtualNode; - -begin - Node := RootNode.FirstChild; - while Assigned(Node) do - begin - if Node.CheckState <> csUncheckedNormal then - CheckState[Node] := csUncheckedNormal; - Node := GetNextNoInit(Node); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.ClearSelection(); -begin - ClearSelection(True); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.ClearSelection(pFireChangeEvent: Boolean); - -var - Node: PVirtualNode; - Dummy: Integer; - R: TRect; - Counter: Integer; - -begin - Assert(GetCurrentThreadId = MainThreadId, Self.Classname + '.ClearSelection() must only be called from UI thread.'); - if not FSelectionLocked and (FSelectionCount > 0) and not (csDestroying in ComponentState) then - begin - if (FUpdateCount = 0) and HandleAllocated and (FVisibleCount > 0) then - begin - // Iterate through nodes currently visible in the client area and invalidate them. - Node := GetNodeAt(0, 0, True, Dummy); - if Assigned(Node) then - R := GetDisplayRect(Node, NoColumn, False); - Counter := FSelectionCount; - - while Assigned(Node) do - begin - R.Bottom := R.Top + Integer(NodeHeight[Node]); - if vsSelected in Node.States then - begin - InvalidateRect(Handle, @R, False); - Dec(Counter); - // Only try as many nodes as are selected. - if Counter = 0 then - Break; - end; - R.Top := R.Bottom; - if R.Top > ClientHeight then - Break; - Node := GetNextVisibleNoInit(Node, True); - end; - end; - - InternalClearSelection; - if pFireChangeEvent then - Change(nil); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.CopyTo(Source: PVirtualNode; Tree: TBaseVirtualTree; Mode: TVTNodeAttachMode; - ChildrenOnly: Boolean): PVirtualNode; - -// A simplified CopyTo method to allow to copy nodes to the root of another tree. - -begin - Result := CopyTo(Source, Tree.FRoot, Mode, ChildrenOnly); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.CopyTo(Source, Target: PVirtualNode; Mode: TVTNodeAttachMode; - ChildrenOnly: Boolean): PVirtualNode; - -// Copies Source and all its child nodes to Target. -// Mode is used to specify further where to add the new node actually (as sibling of Target or as child of Target). -// Result is the newly created node to which source has been copied if ChildrenOnly is False or just contains Target -// in the other case. -// ChildrenOnly determines whether to copy also the source node or only its child nodes. - -var - TargetTree: TBaseVirtualTree; - Stream: TMemoryStream; - -begin - Assert(TreeFromNode(Source) = Self, 'The source tree must contain the source node.'); - - Result := nil; - if (Mode <> amNoWhere) and Assigned(Source) and (Source <> FRoot) then - begin - // Assume that an empty destination means the root in this (the source) tree. - if Target = nil then - begin - TargetTree := Self; - Target := FRoot; - Mode := amAddChildFirst; - end - else - TargetTree := TreeFromNode(Target); - - if not (toReadOnly in TargetTree.FOptions.FMiscOptions) then - begin - if Target = TargetTree.FRoot then - begin - case Mode of - amInsertBefore: - Mode := amAddChildFirst; - amInsertAfter: - Mode := amAddChildLast; - end; - end; - - Stream := TMemoryStream.Create; - try - // Write all nodes into a temprary stream depending on the ChildrenOnly flag. - if not ChildrenOnly then - WriteNode(Stream, Source) - else - begin - Source := Source.FirstChild; - while Assigned(Source) do - begin - WriteNode(Stream, Source); - Source := Source.NextSibling; - end; - end; - // Now load the serialized nodes into the target node (tree). - TargetTree.BeginUpdate; - try - Stream.Position := 0; - while Stream.Position < Stream.Size do - begin - Result := TargetTree.MakeNewNode; - InternalConnectNode(Result, Target, TargetTree, Mode); - TargetTree.InternalAddFromStream(Stream, VTTreeStreamVersion, Result); - if not DoNodeCopying(Result, Target) then - begin - TargetTree.DeleteNode(Result); - Result := nil; - end - else - DoNodeCopied(Result); - end; - if ChildrenOnly then - Result := Target; - finally - TargetTree.EndUpdate; - end; - finally - Stream.Free; - end; - - with TargetTree do - begin - InvalidateCache; - if FUpdateCount = 0 then - begin - ValidateCache; - UpdateScrollBars(True); - Invalidate; - end; - StructureChange(Source, crNodeCopied); - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.CopyToClipboard; - -var - DataObject: IDataObject; - -begin - if FSelectionCount > 0 then - begin - DataObject := TVTDataObject.Create(Self, True) as IDataObject; - if OleSetClipboard(DataObject) = S_OK then - begin - MarkCutCopyNodes; - DoStateChange([tsCopyPending]); - Invalidate; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.CutToClipboard; -begin - if (FSelectionCount > 0) and not (toReadOnly in FOptions.FMiscOptions) then - begin - if OleSetClipboard(TVTDataObject.Create(Self, True)) = S_OK then - begin - MarkCutCopyNodes; - DoStateChange([tsCutPending], [tsCopyPending]); - Invalidate; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DeleteChildren(Node: PVirtualNode; ResetHasChildren: Boolean = False); - -// Removes all children and their children from memory without changing the vsHasChildren style by default. - -var - Run, - Mark: PVirtualNode; - LastTop, - LastLeft, - NewSize: Integer; - ParentVisible: Boolean; - -begin - if Assigned(Node) and (Node.ChildCount > 0) and not (toReadOnly in FOptions.FMiscOptions) then - begin - Assert(not (tsIterating in FStates), 'Deleting nodes during tree iteration leads to invalid pointers.'); - - // The code below uses some flags for speed improvements which may cause invalid pointers if updates of - // the tree happen. Hence switch updates off until we have finished the operation. - Inc(FUpdateCount); - try - InterruptValidation; - LastLeft := -FEffectiveOffsetX; - LastTop := FOffsetY; - - // Make a local copy of the visibility state of this node to speed up - // adjusting the visible nodes count. - ParentVisible := Node = FRoot; - if not ParentVisible then - ParentVisible := FullyVisible[Node] and (vsExpanded in Node.States); - - // Show that we are clearing the child list, to avoid registering structure change events. - Run := Node.LastChild; - while Assigned(Run) do - begin - if ParentVisible and IsEffectivelyVisible[Run] then - Dec(FVisibleCount); - - Include(Run.States, vsDeleting); - Mark := Run; - Run := Run.PrevSibling; - // Important, to avoid exchange of invalid pointers while disconnecting the node. - if Assigned(Run) then - Run.NextSibling := nil; - DeleteNode(Mark, False, True); - end; - if ResetHasChildren then - Exclude(Node.States, vsHasChildren); - if Node <> FRoot then - Exclude(Node.States, vsExpanded); - Node.ChildCount := 0; - if (Node = FRoot) or (vsDeleting in Node.States) then - begin - Node.TotalHeight := FDefaultNodeHeight + NodeHeight[Node]; - Node.TotalCount := 1; - end - else - begin - AdjustTotalHeight(Node, NodeHeight[Node]); - AdjustTotalCount(Node, 1); - end; - Node.FirstChild := nil; - Node.LastChild := nil; - finally - Dec(FUpdateCount); - end; - - InvalidateCache; - if FUpdateCount = 0 then - begin - NewSize := PackArray(FSelection, FSelectionCount); - if NewSize > -1 then - begin - FSelectionCount := NewSize; - SetLength(FSelection, FSelectionCount); - end; - - ValidateCache; - UpdateScrollBars(True); - // Invalidate entire tree if it scrolled e.g. to make the last node also the - // bottom node in the treeview. - if (LastLeft <> FOffsetX) or (LastTop <> FOffsetY) then - Invalidate - else - InvalidateToBottom(Node); - if tsChangePending in FStates then begin - DoChange(FLastChangedNode); - EnsureNodeSelected(); - end; - end; - StructureChange(Node, crChildDeleted); - end - else if ResetHasChildren then - Exclude(Node.States, vsHasChildren); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DeleteNode(Node: PVirtualNode; Reindex: Boolean; ParentClearing: Boolean); - -var - LastTop, - LastLeft: Integer; - LastParent: PVirtualNode; - WasInSynchMode: Boolean; - -begin - if Assigned(Node) and (Node <> FRoot) and not (toReadOnly in FOptions.FMiscOptions) then - begin - Assert(not (tsIterating in FStates), 'Deleting nodes during tree iteration leads to invalid pointers.'); - - // Determine parent node for structure change notification. - LastParent := Node.Parent; - - if not ParentClearing then - begin - if LastParent = FRoot then - StructureChange(nil, crChildDeleted) - else - StructureChange(LastParent, crChildDeleted); - if Node = FNextNodeToSelect then - FNextNodeToSelect := nil; - end; - - LastLeft := -FEffectiveOffsetX; - LastTop := FOffsetY; - - if tsHint in FStates then - begin - Application.CancelHint; - DoStateChange([], [tsHint]); - end; - - if not ParentClearing then - InterruptValidation; - - DeleteChildren(Node); - - if vsSelected in Node.States then - begin - if FUpdateCount = 0 then - begin - // Go temporarily into sync mode to avoid a delayed change event for the node - // when unselecting. - WasInSynchMode := tsSynchMode in FStates; - Include(FStates, tsSynchMode); - RemoveFromSelection(Node); - //EnsureNodeSelected(); // also done in DoFreeNode() - if not WasInSynchMode then - Exclude(FStates, tsSynchMode); - InvalidateToBottom(LastParent); - end - else - InternalRemoveFromSelection(Node); - end - else - InvalidateToBottom(LastParent); - - InternalDisconnectNode(Node, False, Reindex); - DoFreeNode(Node); - - if not ParentClearing then - begin - DetermineHiddenChildrenFlag(LastParent); - InvalidateCache; - if FUpdateCount = 0 then - begin - ValidateCache; - UpdateScrollBars(True); - // Invalidate entire tree if it scrolled e.g. to make the last node also the - // bottom node in the treeview. - if (LastLeft <> FOffsetX) or (LastTop <> FOffsetY) then - Invalidate; - end; - end; - end; -end; - -procedure TBaseVirtualTree.DeleteNode(Node: PVirtualNode; pReIndex: Boolean = True); -begin - DeleteNode(Node, pReIndex, False); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DeleteNodes(const pNodes: TNodeArray); - - // Deletes all given nodes. - // Best performance is achieved if nodes are sorted by parent - -var - I: Integer; - LevelChange: Boolean; -begin - BeginUpdate; - try - for I := High(pNodes) downto 1 do - begin - LevelChange := pNodes[I].Parent <> pNodes[I - 1].Parent; - DeleteNode(pNodes[I], LevelChange, False); - end; - DeleteNode(pNodes[0]); - finally - EndUpdate; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DeleteSelectedNodes; - -// Deletes all currently selected nodes (including their child nodes). - -var - lNodes: TNodeArray; -begin - lNodes := nil; - if (FSelectionCount > 0) and not (toReadOnly in FOptions.FMiscOptions) then - begin - lNodes := GetSortedSelection(True); - DeleteNodes(lNodes); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.Dragging: Boolean; - -begin - // Check for both OLE drag'n drop as well as VCL drag'n drop. - Result := ([tsOLEDragPending, tsOLEDragging] * FStates <> []) or inherited Dragging; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.EditNode(Node: PVirtualNode; Column: TColumnIndex): Boolean; - -// Application triggered edit event for the given node. -// Returns True if the tree started editing otherwise False. - -begin - Assert(Assigned(Node), 'Node must not be nil.'); - Assert((Column > InvalidColumn) and (Column < FHeader.Columns.Count), - 'Column must be a valid column index (-1 if no header is shown).'); - - Result := tsEditing in FStates; - // If the tree is already editing then we don't disrupt this. - if not Result and not (toReadOnly in FOptions.FMiscOptions) then - begin - FocusedNode := Node; - if Assigned(FFocusedNode) and (Node = FFocusedNode) and CanEdit(FFocusedNode, Column) then - begin - FEditColumn := Column; - if not (vsInitialized in Node.States) then - InitNode(Node); - DoEdit; - Result := tsEditing in FStates; - end - else - Result := False; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.EndEditNode: Boolean; - -// Called to finish a current edit action or stop the edit timer if an edit operation is pending. -// Returns True if editing was successfully ended or the control was not in edit mode -// Returns False if the control could not leave the edit mode e.g. due to an invalid value that was entered. - -begin - if [tsEditing, tsEditPending] * FStates <> [] then - Result := DoEndEdit - else - Result := True; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.EndSynch; - -begin - if FSynchUpdateCount > 0 then - Dec(FSynchUpdateCount); - - if not (csDestroying in ComponentState) then - begin - if FSynchUpdateCount = 0 then - begin - DoStateChange([], [tsSynchMode]); - DoUpdating(usEndSynch); - end - else - DoUpdating(usSynch); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.EndUpdate; - -var - NewSize: Integer; - -begin - if FUpdateCount > 0 then - Dec(FUpdateCount); - - if not (csDestroying in ComponentState) then - begin - if (FUpdateCount = 0) and (tsUpdating in FStates) then - begin - if tsUpdateHiddenChildrenNeeded in FStates then - begin - DetermineHiddenChildrenFlagAllNodes; - Exclude(FStates, tsUpdateHiddenChildrenNeeded); - end; - - DoStateChange([], [tsUpdating]); - - NewSize := PackArray(FSelection, FSelectionCount); - if NewSize > -1 then - begin - FSelectionCount := NewSize; - SetLength(FSelection, FSelectionCount); - end; - - InvalidateCache; - ValidateCache; - if HandleAllocated then - UpdateScrollBars(False); - - if tsStructureChangePending in FStates then - DoStructureChange(FLastStructureChangeNode, FLastStructureChangeReason); - try - if tsChangePending in FStates then - DoChange(FLastChangedNode); - finally - if toAutoSort in FOptions.FAutoOptions then - SortTree(FHeader.FSortColumn, FHeader.FSortDirection, True); - - SetUpdateState(False); - if HandleAllocated then - Invalidate; - UpdateDesigner; - end; - end; - - if FUpdateCount = 0 then begin - DoUpdating(usEnd); - EnsureNodeSelected(); - end - else - DoUpdating(usUpdate); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.ExecuteAction(Action: TBasicAction): Boolean; - -// Some support for standard actions. - -begin - Result := inherited ExecuteAction(Action); - - if not Result then - begin - Result := Action is TEditSelectAll; - if Result then - SelectAll(False) - else - begin - Result := Action is TEditCopy; - if Result then - CopyToClipboard - else - if not (toReadOnly in FOptions.FMiscOptions) then - begin - Result := Action is TEditCut; - if Result then - CutToClipboard - else - begin - Result := Action is TEditPaste; - if Result then - PasteFromClipboard - else - begin - Result := Action is TEditDelete; - if Result then - DeleteSelectedNodes; - end; - end; - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.FinishCutOrCopy; - -// Deletes nodes which are marked as being cutted. - -var - Run: PVirtualNode; - -begin - if tsCutPending in FStates then - begin - Run := FRoot.FirstChild; - while Assigned(Run) do - begin - if vsCutOrCopy in Run.States then - DeleteNode(Run); - Run := GetNextNoInit(Run); - end; - DoStateChange([], [tsCutPending]); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.FlushClipboard; - -// Used to render the data which is currently on the clipboard (finishes delayed rendering). - -begin - if ClipboardStates * FStates <> [] then - begin - DoStateChange([tsClipboardFlushing]); - OleFlushClipboard; - CancelCutOrCopy; - DoStateChange([], [tsClipboardFlushing]); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.FullCollapse(Node: PVirtualNode = nil); - -// This routine collapses all expanded nodes in the subtree given by Node or the whole tree if Node is FRoot or nil. -// Only nodes which are expanded will be collapsed. This excludes uninitialized nodes but nodes marked as visible -// will still be collapsed if they are expanded. - -var - Stop: PVirtualNode; - -begin - if FRoot.TotalCount > 1 then - begin - if Node = FRoot then - Node := nil; - - DoStateChange([tsCollapsing]); - BeginUpdate; - try - Stop := Node; - Node := GetLastVisibleNoInit(Node, True); - - if Assigned(Node) then - begin - repeat - if [vsHasChildren, vsExpanded] * Node.States = [vsHasChildren, vsExpanded] then - ToggleNode(Node); - Node := GetPreviousNoInit(Node, True); - until (Node = Stop) or not Assigned(Node); - - // Collapse the start node too. - if Assigned(Stop) and ([vsHasChildren, vsExpanded] * Stop.States = [vsHasChildren, vsExpanded]) then - ToggleNode(Stop); - end; - finally - EndUpdate; - DoStateChange([], [tsCollapsing]); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.FullExpand(Node: PVirtualNode = nil); - -// This routine expands all collapsed nodes in the subtree given by Node or the whole tree if Node is FRoot or nil. -// All nodes on the way down are initialized so this procedure might take a long time. -// Since all nodes are validated, the tree cannot make use of optimatizations. Hence it is counter productive and you -// should consider avoiding its use. - -var - Stop: PVirtualNode; - -begin - if FRoot.TotalCount > 1 then - begin - DoStateChange([tsExpanding]); - StartOperation(TVTOperationKind.okExpand); - BeginUpdate; - try - if Node = nil then - begin - Node := FRoot.FirstChild; - Stop := nil; - end - else - begin - Stop := Node.NextSibling; - if Stop = nil then - begin - Stop := Node; - repeat - Stop := Stop.Parent; - until (Stop = FRoot) or Assigned(Stop.NextSibling); - if Stop = FRoot then - Stop := nil - else - Stop := Stop.NextSibling; - end; - end; - - // Initialize the start node. Others will be initialized in GetNext. - if not (vsInitialized in Node.States) then - InitNode(Node); - - repeat - if not (vsExpanded in Node.States) then - ToggleNode(Node); - Node := GetNext(Node); - until (Node = Stop) or OperationCanceled; - finally - EndOperation(TVTOperationKind.okExpand); - EndUpdate; - DoStateChange([], [tsExpanding]); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetControlsAlignment: TAlignment; - -begin - Result := FAlignment; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetDisplayRect(Node: PVirtualNode; Column: TColumnIndex; TextOnly: Boolean; - Unclipped: Boolean = False; ApplyCellContentMargin: Boolean = False): TRect; - -// Determines the client coordinates the given node covers, depending on scrolling, expand state etc. -// If the given node cannot be found (because one of its parents is collapsed or it is invisible) then an empty -// rectangle is returned. -// If TextOnly is True then only the text bounds are returned, that is, the resulting rectangle's left and right border -// are updated according to bidi mode, alignment and text width of the node. -// If Unclipped is True (which only makes sense if also TextOnly is True) then the calculated text rectangle is -// not clipped if the text does not entirely fit into the text space. This is special handling needed for hints. -// If ApplyCellContentMargin is True (which only makes sense if also TextOnly is True) then the calculated text -// rectangle respects the cell content margin. -// If Column is -1 then the entire client width is used before determining the node's width otherwise the bounds of the -// particular column are used. -// Note: Column must be a valid column and is used independent of whether the header is visible or not. - -var - Temp: PVirtualNode; - LeftOffset: Cardinal; - TopOffset: Cardinal; - CacheIsAvailable: Boolean; - TextWidth: Integer; - CurrentBidiMode: TBidiMode; - CurrentAlignment: TAlignment; - MaxUnclippedHeight: Integer; - TM: TTextMetric; - ExtraVerticalMargin: Integer; - lOffsets: TVTOffsets; -begin - Assert(Assigned(Node), 'Node must not be nil.'); - Assert(Node <> FRoot, 'Node must not be the hidden root node.'); - - if not (vsInitialized in Node.States) then - InitNode(Node); - - Result := Rect(0, 0, 0, 0); - - // Check whether the node is visible (determine indentation level btw.). - if not IsEffectivelyVisible[Node] then - Exit; - - // Here we know the node is visible. - TopOffset := 0; - CacheIsAvailable := False; - if tsUseCache in FStates then - begin - // If we can use the position cache then do a binary search to find a cached node which is as close as possible - // to the current node. Iterate then through all following and visible nodes and sum up their heights. - Temp := FindInPositionCache(Node, TopOffset); - CacheIsAvailable := Assigned(Temp); - while Assigned(Temp) and (Temp <> Node) do - begin - Inc(TopOffset, NodeHeight[Temp]); - Temp := GetNextVisibleNoInit(Temp, True); - end; - end; - if not CacheIsAvailable then - begin - // If the cache is not available then go straight through all nodes up to the root and sum up their heights. - Temp := Node; - repeat - Temp := GetPreviousVisibleNoInit(Temp, True); - if Temp = nil then - Break; - Inc(TopOffset, NodeHeight[Temp]); - until False; - end; - - Result := Rect(0, TopOffset, Max(FRangeX, ClientWidth), TopOffset + NodeHeight[Node]); - - // Limit left and right bounds to the given column (if any) and move bounds according to current scroll state. - if Column > NoColumn then - begin - FHeader.FColumns.GetColumnBounds(Column, Result.Left, Result.Right); - // The right column border is not part of this cell. - Dec(Result.Right); - OffsetRect(Result, 0, FOffsetY); - end - else - OffsetRect(Result, -FEffectiveOffsetX, FOffsetY); - - // Limit left and right bounds further if only the text area is required. - if TextOnly then - begin - // If the text of a node is involved then we have to consider directionality and alignment too. - if Column <= NoColumn then - begin - CurrentBidiMode := BidiMode; - CurrentAlignment := Alignment; - end - else - begin - CurrentBidiMode := FHeader.FColumns[Column].BidiMode; - CurrentAlignment := FHeader.FColumns[Column].Alignment; - end; - - GetOffsets(Node, lOffsets, TVTElement.ofsLabel, Column); - LeftOffset := lOffSets[TVTElement.ofsLabel]; - // Offset contains now the distance from the left or right border of the rectangle (depending on bidi mode). - // Now consider the alignment too and calculate the final result. - if CurrentBidiMode = bdLeftToRight then - begin - Inc(Result.Left, LeftOffset); - // Left-to-right reading does not need any special adjustment of the alignment. - end - else - begin - Dec(Result.Right, LeftOffset); - - // Consider bidi mode here. In RTL context does left alignment actually mean right alignment and vice versa. - ChangeBiDiModeAlignment(CurrentAlignment); - end; - - TextWidth := DoGetNodeWidth(Node, Column); - - // Keep cell height before applying cell content margin in order to increase cell height if text does not fit - // and Unclipped it true (see below). - MaxUnclippedHeight := Result.Bottom - Result.Top; - - if ApplyCellContentMargin then - DoBeforeCellPaint(Self.Canvas, Node, Column, cpmGetContentMargin, Result, Result); - - if Unclipped then - begin - // The caller requested the text coordinates unclipped. This means they must be calculated so as would - // there be enough space, regardless of column bounds etc. - // The layout still depends on the available space too, because this determines the position - // of the unclipped text rectangle. - if Result.Right - Result.Left < TextWidth - 1 then - if CurrentBidiMode = bdLeftToRight then - CurrentAlignment := taLeftJustify - else - CurrentAlignment := taRightJustify; - - // Increase cell height (up to MaxUnclippedHeight determined above) if text does not fit. - GetTextMetrics(Self.Canvas.Handle, TM); - ExtraVerticalMargin := System.Math.Min(TM.tmHeight, MaxUnclippedHeight) - (Result.Bottom - Result.Top); - if ExtraVerticalMargin > 0 then - InflateRect(Result, 0, (ExtraVerticalMargin + 1) div 2); - - case CurrentAlignment of - taCenter: - begin - Result.Left := (Result.Left + Result.Right - TextWidth) div 2; - Result.Right := Result.Left + TextWidth; - end; - taRightJustify: - Result.Left := Result.Right - TextWidth; - else // taLeftJustify - Result.Right := Result.Left + TextWidth - 1; - end; - end - else - // Modify rectangle only if the text fits entirely into the given room. - if Result.Right - Result.Left > TextWidth then - case CurrentAlignment of - taCenter: - begin - Result.Left := (Result.Left + Result.Right - TextWidth) div 2; - Result.Right := Result.Left + TextWidth; - end; - taRightJustify: - Result.Left := Result.Right - TextWidth; - else // taLeftJustify - Result.Right := Result.Left + TextWidth; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetEffectivelyFiltered(Node: PVirtualNode): Boolean; - -// Checks if a node is effectively filtered out. This depends on the nodes state and the paint options. - -begin - if Assigned(Node) then - Result := (vsFiltered in Node.States) and not (toShowFilteredNodes in FOptions.FPaintOptions) - else - Result := False; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetEffectivelyVisible(Node: PVirtualNode): Boolean; - -begin - Result := (vsVisible in Node.States) and not IsEffectivelyFiltered[Node]; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetFirst(ConsiderChildrenAbove: Boolean = False): PVirtualNode; - -// Returns the first node in the tree while optionally considering toChildrenAbove. - -begin - if ConsiderChildrenAbove and (toChildrenAbove in FOptions.FPaintOptions) then - begin - if vsHasChildren in FRoot.States then - begin - Result := FRoot; - - // Child nodes are the first choice if possible. - if Assigned(Result.FirstChild) then - begin - while Assigned(Result.FirstChild) do - begin - Result := Result.FirstChild; - if not (vsInitialized in Result.States) then - InitNode(Result); - - if (vsHasChildren in Result.States) and (Result.ChildCount = 0) then - InitChildren(Result); - end; - end - else - Result := nil; - end - else - Result := nil; - end - else - Result := FRoot.FirstChild; - - if Assigned(Result) and not (vsInitialized in Result.States) then - InitNode(Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetFirstChecked(State: TCheckState = csCheckedNormal; - ConsiderChildrenAbove: Boolean = False): PVirtualNode; - -// Returns the first node in the tree with the given check state. - -begin - Result := GetNextChecked(nil, State, ConsiderChildrenAbove); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetFirstChild(Node: PVirtualNode): PVirtualNode; - -// Returns the first child of the given node. The result node is initialized before exit. - -begin - if (Node = nil) or (Node = FRoot) then - Result := FRoot.FirstChild - else - begin - if not (vsInitialized in Node.States) then - InitNode(Node); - if vsHasChildren in Node.States then - begin - if Node.ChildCount = 0 then - InitChildren(Node); - Result := Node.FirstChild; - end - else - Result := nil; - end; - - if Assigned(Result) and not (vsInitialized in Result.States) then - InitNode(Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetFirstChildNoInit(Node: PVirtualNode): PVirtualNode; -// Determines the first child of the given node but does not initialize it. - -begin - if (Node = nil) or (Node = FRoot) then - Result := FRoot.FirstChild - else - begin - if vsHasChildren in Node.States then - Result := Node.FirstChild - else - Result := nil; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetFirstCutCopy(ConsiderChildrenAbove: Boolean = False): PVirtualNode; - -// Returns the first node in the tree which is currently marked for a clipboard operation. -// See also GetNextCutCopy for comments on initialization. - -begin - Result := GetNextCutCopy(nil, ConsiderChildrenAbove); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetFirstInitialized(ConsiderChildrenAbove: Boolean = False): PVirtualNode; - -// Returns the first node which is already initialized. - -begin - Result := GetFirstNoInit(ConsiderChildrenAbove); - if Assigned(Result) and not (vsInitialized in Result.States) then - Result := GetNextInitialized(Result, ConsiderChildrenAbove); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetFirstLeaf: PVirtualNode; - -// Returns the first node in the tree which has currently no children. -// The result is initialized if necessary. - -begin - Result := GetNextLeaf(nil); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetFirstLevel(NodeLevel: Cardinal): PVirtualNode; - -// Returns the first node in the tree on a specific level. -// The result is initialized if necessary. - -begin - Result := GetFirstNoInit(True); - while Assigned(Result) and (GetNodeLevel(Result) <> NodeLevel) do - Result := GetNextNoInit(Result, True); - - if Assigned(Result) and (GetNodeLevel(Result) <> NodeLevel) then // i.e. there is no node with the desired level in the tree - Result := nil; - - if Assigned(Result) and not (vsInitialized in Result.States) then - InitNode(Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetFirstNoInit(ConsiderChildrenAbove: Boolean = False): PVirtualNode; - -// Returns the first node in the tree while optionally considering toChildrenAbove. -// No initialization is performed. - -begin - if ConsiderChildrenAbove and (toChildrenAbove in FOptions.FPaintOptions) then - begin - if vsHasChildren in FRoot.States then - begin - Result := FRoot; - - // Child nodes are the first choice if possible. - if Assigned(Result.FirstChild) then - begin - while Assigned(Result.FirstChild) do - Result := Result.FirstChild; - end - else - Result := nil; - end - else - Result := nil; - end - else - Result := FRoot.FirstChild; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetFirstSelected(ConsiderChildrenAbove: Boolean = False): PVirtualNode; - -// Returns the first node in the current selection while optionally considering toChildrenAbove. - -begin - Result := GetNextSelected(nil, ConsiderChildrenAbove); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetFirstVisible(Node: PVirtualNode = nil; ConsiderChildrenAbove: Boolean = True; - IncludeFiltered: Boolean = False): PVirtualNode; - -// Returns the first visible node in the tree while optionally considering toChildrenAbove. -// If necessary nodes are initialized on demand. - -begin - Result := Node; - if not Assigned(Result) then - Result := FRoot; - - if vsHasChildren in Result.States then - begin - if Result.ChildCount = 0 then - InitChildren(Result); - - // Child nodes are the first choice if possible. - if Assigned(Result.FirstChild) then - begin - Result := GetFirstChild(Result); - - if ConsiderChildrenAbove and (toChildrenAbove in FOptions.FPaintOptions) then - begin - repeat - // Search the first visible sibling. - while Assigned(Result.NextSibling) and not (vsVisible in Result.States) do - begin - Result := Result.NextSibling; - // Init node on demand as this might change the visibility. - if not (vsInitialized in Result.States) then - InitNode(Result); - end; - - // If there are no visible siblings take the parent. - if not (vsVisible in Result.States) then - begin - Result := Result.Parent; - if Result = FRoot then - Result := nil; - Break; - end - else - begin - if (vsHasChildren in Result.States) and (Result.ChildCount = 0) then - InitChildren(Result); - if (not Assigned(Result.FirstChild)) or (not (vsExpanded in Result.States)) then - Break; - end; - - Result := Result.FirstChild; - if not (vsInitialized in Result.States) then - InitNode(Result); - until False; - end - else - begin - // If there are no children or the first child is not visible then search the sibling nodes or traverse parents. - if not (vsVisible in Result.States) then - begin - repeat - // Is there a next sibling? - if Assigned(Result.NextSibling) then - begin - Result := Result.NextSibling; - // The visible state can be removed during initialization so init the node first. - if not (vsInitialized in Result.States) then - InitNode(Result); - if vsVisible in Result.States then - Break; - end - else - begin - // No sibling anymore, so use the parent's next sibling. - if Result.Parent <> FRoot then - Result := Result.Parent - else - begin - // There are no further nodes to examine, hence there is no further visible node. - Result := nil; - Break; - end; - end; - until False; - end; - end; - end - else - Result := nil; - end - else - Result := nil; - - if Assigned(Result) and not IncludeFiltered and IsEffectivelyFiltered[Result] then - Result := GetNextVisible(Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetFirstVisibleChild(Node: PVirtualNode; IncludeFiltered: Boolean = False): PVirtualNode; - -// Returns the first visible child node of Node. If necessary nodes are initialized on demand. - -begin - if Node = nil then - Node := FRoot; - Result := GetFirstChild(Node); - - if Assigned(Result) and (not (vsVisible in Result.States) or - (not IncludeFiltered and IsEffectivelyFiltered[Result])) then - Result := GetNextVisibleSibling(Result, IncludeFiltered); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetFirstVisibleChildNoInit(Node: PVirtualNode; IncludeFiltered: Boolean = False): PVirtualNode; - -// Returns the first visible child node of Node. - -begin - if Node = nil then - Node := FRoot; - Result := Node.FirstChild; - if Assigned(Result) and (not (vsVisible in Result.States) or - (not IncludeFiltered and IsEffectivelyFiltered[Result])) then - Result := GetNextVisibleSiblingNoInit(Result, IncludeFiltered); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetFirstVisibleNoInit(Node: PVirtualNode = nil; - ConsiderChildrenAbove: Boolean = True; IncludeFiltered: Boolean = False): PVirtualNode; - -// Returns the first visible node in the tree or given subtree while optionally considering toChildrenAbove. -// No initialization is performed. - -begin - Result := Node; - if not Assigned(Result) then - Result := FRoot; - - if vsHasChildren in Result.States then - begin - // Child nodes are the first choice if possible. - if Assigned(Result.FirstChild) then - begin - Result := Result.FirstChild; - - if ConsiderChildrenAbove and (toChildrenAbove in FOptions.FPaintOptions) then - begin - repeat - // Search the first visible sibling. - while Assigned(Result.NextSibling) and not (vsVisible in Result.States) do - Result := Result.NextSibling; - - // If there a no visible siblings take the parent. - if not (vsVisible in Result.States) then - begin - Result := Result.Parent; - if Result = FRoot then - Result := nil; - Break; - end - else - if (not Assigned(Result.FirstChild)) or (not (vsExpanded in Result.States))then - Break; - - Result := Result.FirstChild; - until False; - end - else - begin - // If there are no children or the first child is not visible then search the sibling nodes or traverse parents. - if not (vsVisible in Result.States) then - begin - repeat - // Is there a next sibling? - if Assigned(Result.NextSibling) then - begin - Result := Result.NextSibling; - if vsVisible in Result.States then - Break; - end - else - begin - // No sibling anymore, so use the parent's next sibling. - if Result.Parent <> FRoot then - Result := Result.Parent - else - begin - // There are no further nodes to examine, hence there is no further visible node. - Result := nil; - Break; - end; - end; - until False; - end; - end; - end - else - Result := nil; - end - else - Result := nil; - - if Assigned(Result) and not IncludeFiltered and IsEffectivelyFiltered[Result] then - Result := GetNextVisibleNoInit(Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.GetHitTestInfoAt(X, Y: Integer; Relative: Boolean; var HitInfo: THitInfo); - -// Determines the node that occupies the specified point or nil if there's none. The parameter Relative determines -// whether to consider X and Y as being client coordinates (if True) or as being absolute tree coordinates. -// HitInfo is filled with flags describing the hit further. - -var - ColLeft, - ColRight: Integer; - NodeTop: Integer; - InitialColumn, - NextColumn: TColumnIndex; - CurrentBidiMode: TBidiMode; - CurrentAlignment: TAlignment; - NodeRect: TRect; - -begin - HitInfo.HitNode := nil; - HitInfo.HitPositions := []; - HitInfo.HitColumn := NoColumn; - - // Determine if point lies in the tree's client area. - if X < 0 then - Include(HitInfo.HitPositions, hiToLeft) - else - if X > Max(FRangeX, ClientWidth) then - Include(HitInfo.HitPositions, hiToRight); - - if Y < 0 then - Include(HitInfo.HitPositions, hiAbove) - else - if Y > Max(FRangeY, ClientHeight) then - Include(HitInfo.HitPositions, hiBelow); - - // Convert position into absolute coordinate if necessary. - if Relative then - begin - if X >= Header.Columns.GetVisibleFixedWidth then - Inc(X, FEffectiveOffsetX); - Inc(Y, -FOffsetY); - end; - HitInfo.HitPoint.X := X; - HitInfo.HitPoint.Y := Y; - - // If the point is in the tree area then check the nodes. - if HitInfo.HitPositions = [] then - begin - HitInfo.HitNode := GetNodeAt(X, Y, False, NodeTop); - if HitInfo.HitNode = nil then - Include(HitInfo.HitPositions, hiNowhere) - else - begin - // At this point we need some info about the node, so it must be initialized. - if not (vsInitialized in HitInfo.HitNode.States) then - InitNode(HitInfo.HitNode); - - if FHeader.UseColumns then - begin - HitInfo.HitColumn := FHeader.Columns.GetColumnAndBounds(Point(X, Y), ColLeft, ColRight, False); - // If auto column spanning is enabled then look for the last non empty column. - if toAutoSpanColumns in FOptions.FAutoOptions then - begin - InitialColumn := HitInfo.HitColumn; - // Search to the left of the hit column for empty columns. - while (HitInfo.HitColumn > NoColumn) and ColumnIsEmpty(HitInfo.HitNode, HitInfo.HitColumn) do - begin - NextColumn := FHeader.FColumns.GetPreviousVisibleColumn(HitInfo.HitColumn); - if NextColumn = InvalidColumn then - Break; - HitInfo.HitColumn := NextColumn; - Dec(ColLeft, FHeader.FColumns[NextColumn].Width); - end; - // Search to the right of the hit column for empty columns. - repeat - InitialColumn := FHeader.FColumns.GetNextVisibleColumn(InitialColumn); - if (InitialColumn = InvalidColumn) or not ColumnIsEmpty(HitInfo.HitNode, InitialColumn) then - Break; - Inc(ColRight, FHeader.FColumns[InitialColumn].Width); - until False; - end; - // Make the X position and the right border relative to the start of the column. - Dec(X, ColLeft); - Dec(ColRight, ColLeft); - end - else - begin - HitInfo.HitColumn := NoColumn; - ColRight := Max(FRangeX, ClientWidth); - end; - ColLeft := 0; - - if HitInfo.HitColumn = InvalidColumn then - Include(HitInfo.HitPositions, hiNowhere) - else - begin - // From now on X is in "column" coordinates (relative to the left column border). - HitInfo.HitPositions := [hiOnItem]; - - // Avoid getting the display rect if this is not necessary. - if toNodeHeightResize in FOptions.FMiscOptions then - begin - NodeRect := GetDisplayRect(HitInfo.HitNode, HitInfo.HitColumn, False); - if Y <= (NodeRect.Top - FOffsetY + 1) then - Include(HitInfo.HitPositions, hiUpperSplitter) - else - if Y >= (NodeRect.Bottom - FOffsetY - 3) then - Include(HitInfo.HitPositions, hiLowerSplitter); - end; - - if HitInfo.HitColumn <= NoColumn then - begin - CurrentBidiMode := BidiMode; - CurrentAlignment := Alignment; - end - else - begin - CurrentBidiMode := FHeader.FColumns[HitInfo.HitColumn].BidiMode; - CurrentAlignment := FHeader.FColumns[HitInfo.HitColumn].Alignment; - end; - - if CurrentBidiMode = bdLeftToRight then - DetermineHitPositionLTR(HitInfo, X, ColRight, CurrentAlignment) - else - DetermineHitPositionRTL(HitInfo, X, ColRight, CurrentAlignment); - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetLast(Node: PVirtualNode = nil; ConsiderChildrenAbove: Boolean = False): PVirtualNode; - -// Returns the very last node in the tree branch given by Node and initializes the nodes all the way down including the -// result. toChildrenAbove is optionally considered. By using Node = nil the very last node in the tree is returned. - -var - Next: PVirtualNode; - -begin - Result := GetLastChild(Node); - if not ConsiderChildrenAbove or not (toChildrenAbove in FOptions.FPaintOptions) then - while Assigned(Result) do - begin - // Test if there is a next last child. If not keep the node from the last run. - // Otherwise use the next last child. - Next := GetLastChild(Result); - if Next = nil then - Break; - Result := Next; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetLastInitialized(Node: PVirtualNode = nil; - ConsiderChildrenAbove: Boolean = False): PVirtualNode; - -// Returns the very last initialized child node in the tree branch given by Node. - -begin - Result := GetLastNoInit(Node, ConsiderChildrenAbove); - if Assigned(Result) and not (vsInitialized in Result.States) then - Result := GetPreviousInitialized(Result, ConsiderChildrenAbove); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetLastNoInit(Node: PVirtualNode = nil; ConsiderChildrenAbove: Boolean = False): PVirtualNode; - -// Returns the very last node in the tree branch given by Node without initialization. - -var - Next: PVirtualNode; - -begin - Result := GetLastChildNoInit(Node); - if not ConsiderChildrenAbove or not (toChildrenAbove in FOptions.FPaintOptions) then - while Assigned(Result) do - begin - // Test if there is a next last child. If not keep the node from the last run. - // Otherwise use the next last child. - Next := GetLastChildNoInit(Result); - if Next = nil then - Break; - Result := Next; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetLastChild(Node: PVirtualNode): PVirtualNode; - -// Determines the last child of the given node and initializes it if there is one. - -begin - if (Node = nil) or (Node = FRoot) then - Result := FRoot.LastChild - else - begin - if not (vsInitialized in Node.States) then - InitNode(Node); - if vsHasChildren in Node.States then - begin - if Node.ChildCount = 0 then - InitChildren(Node); - Result := Node.LastChild; - end - else - Result := nil; - end; - - if Assigned(Result) and not (vsInitialized in Result.States) then - InitNode(Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetLastChildNoInit(Node: PVirtualNode): PVirtualNode; - -// Determines the last child of the given node but does not initialize it. - -begin - if (Node = nil) or (Node = FRoot) then - Result := FRoot.LastChild - else - begin - if vsHasChildren in Node.States then - Result := Node.LastChild - else - Result := nil; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetLastVisible(Node: PVirtualNode = nil; ConsiderChildrenAbove: Boolean = True; - IncludeFiltered: Boolean = False): PVirtualNode; - -// Returns the very last visible node in the tree while optionally considering toChildrenAbove. -// The nodes are intialized all the way up including the result node. - -var - Run: PVirtualNode; - -begin - Result := GetLastVisibleNoInit(Node, ConsiderChildrenAbove); - - Run := Result; - while Assigned(Run) and (Run <> Node) and (Run <> RootNode) do - begin - if not (vsInitialized in Run.States) then - InitNode(Run); - Run := Run.Parent; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetLastVisibleChild(Node: PVirtualNode; IncludeFiltered: Boolean = False): PVirtualNode; - -// Determines the last visible child of the given node and initializes it if necessary. - -begin - if (Node = nil) or (Node = FRoot) then - Result := GetLastChild(FRoot) - else - if FullyVisible[Node] and (vsExpanded in Node.States) then - Result := GetLastChild(Node) - else - Result := nil; - - if Assigned(Result) and (not (vsVisible in Result.States) or - (not IncludeFiltered and IsEffectivelyFiltered[Result])) then - Result := GetPreviousVisibleSibling(Result, IncludeFiltered); - - if Assigned(Result) and not (vsInitialized in Result.States) then - InitNode(Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetLastVisibleChildNoInit(Node: PVirtualNode; IncludeFiltered: Boolean = False): PVirtualNode; - -// Determines the last visible child of the given node without initialization. - -begin - if (Node = nil) or (Node = FRoot) then - Result := GetLastChildNoInit(FRoot) - else - if FullyVisible[Node] and (vsExpanded in Node.States) then - Result := GetLastChildNoInit(Node) - else - Result := nil; - - if Assigned(Result) and (not (vsVisible in Result.States) or - (not IncludeFiltered and IsEffectivelyFiltered[Result])) then - Result := GetPreviousVisibleSiblingNoInit(Result, IncludeFiltered); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetLastVisibleNoInit(Node: PVirtualNode = nil; - ConsiderChildrenAbove: Boolean = True; IncludeFiltered: Boolean = False): PVirtualNode; - -// Returns the very last visible node in the tree while optionally considering toChildrenAbove. -// No initialization is performed. -var - Next: PVirtualNode; - -begin - Result := GetLastVisibleChildNoInit(Node, IncludeFiltered); - if not ConsiderChildrenAbove or not (toChildrenAbove in FOptions.FPaintOptions) then - while Assigned(Result) and (vsExpanded in Result.States) do - begin - // Test if there is a next last child. If not keep the node from the last run. - // Otherwise use the next last child. - Next := GetLastChildNoInit(Result); - if Assigned(Next) and (not (vsVisible in Next.States) or - (not IncludeFiltered and IsEffectivelyFiltered[Next])) then - Next := GetPreviousVisibleSiblingNoInit(Next, IncludeFiltered); - if Next = nil then - Break; - Result := Next; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetMaxColumnWidth(Column: TColumnIndex; UseSmartColumnWidth: Boolean = False): Integer; - -// This method determines the width of the largest node in the given column. -// If UseSmartColumnWidth is True then only the visible nodes which are in view will be considered -// Note: If UseSmartColumnWidth is False then every visible node in the tree will be initialized contradicting so -// the virtual paradigm. - -var - Run, - LastNode, - NextNode: PVirtualNode; - TextLeft, - CurrentWidth: Integer; - lOffsets: TVTOffsets; -begin - if OperationCanceled then - begin - // Behave non-destructive. - Result := FHeader.FColumns[Column].Width; - Exit; - end - else - Result := 0; - - StartOperation(okGetMaxColumnWidth); - try - if Assigned(FOnBeforeGetMaxColumnWidth) then - FOnBeforeGetMaxColumnWidth(FHeader, Column, UseSmartColumnWidth); - - if UseSmartColumnWidth then // Get first visible node which is in view. - Run := GetTopNode - else - Run := GetFirstVisible(nil, True); - - // Decide where to stop. - if UseSmartColumnWidth then - LastNode := GetNextVisible(BottomNode) - else - LastNode := nil; - - if hoAutoResizeInclCaption in FHeader.Options then - Result := Result + (2 * Header.Columns[Column].FMargin + Header.Columns[Column].CaptionWidth + 2); - - while Assigned(Run) and not OperationCanceled do - begin - GetOffsets(Run, lOffsets, TVTElement.ofsLabel, Column); - TextLeft := lOffsets[TVTElement.ofsLabel]; - CurrentWidth := DoGetNodeWidth(Run, Column); - Inc(CurrentWidth, DoGetNodeExtraWidth(Run, Column)); - Inc(CurrentWidth, DoGetCellContentMargin(Run, Column).X); - - // Background for fix: - // DoGetNodeWidth works correctly to return just the - // headerwidth in vsMultiline state of the node. But the - // following code was adding TextLeft unnecessarily. This - // caused a width increase each time a column splitter - // was double-clicked for the option hoDblClickResize that - // really does not apply for vsMultiline case. - // Fix: If the node is multiline, leave the current width as - // it is as returned by DoGetNodeWidth logic above. - if (Column > NoColumn) and (vsMultiline in Run.States) then - Result := CurrentWidth - else - if Result < (TextLeft + CurrentWidth) then - Result := TextLeft + CurrentWidth; - - // Get next visible node and update left node position if needed. - NextNode := GetNextVisible(Run, True); - if NextNode = LastNode then - Break; - Run := NextNode; - end; - if toShowVertGridLines in FOptions.FPaintOptions then - Inc(Result); - - if Assigned(FOnAfterGetMaxColumnWidth) then - FOnAfterGetMaxColumnWidth(FHeader, Column, Result); - - finally - EndOperation(okGetMaxColumnWidth); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetNext(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode; - -// Returns next node in tree while optionally considering toChildrenAbove. The Result will be initialized if needed. - -begin - Result := Node; - if Assigned(Result) then - begin - Assert(Result <> FRoot, 'Node must not be the hidden root node.'); - - if ConsiderChildrenAbove and (toChildrenAbove in FOptions.FPaintOptions) then - begin - // If this node has no siblings use the parent. - if not Assigned(Result.NextSibling) then - begin - Result := Result.Parent; - if Result = FRoot then - begin - Result := nil; - end; - end - else - begin - // There is at least one sibling so take it. - Result := Result.NextSibling; - - // Has this node got children? Initialize them if necessary. - if (vsHasChildren in Result.States) and (Result.ChildCount = 0) then - InitChildren(Result); - - // Now take a look at the children. - while Assigned(Result.FirstChild) do - begin - Result := Result.FirstChild; - if (vsHasChildren in Result.States) and (Result.ChildCount = 0) then - InitChildren(Result); - end; - end; - end - else - begin - // Has this node got children? - if vsHasChildren in Result.States then - begin - // Yes, there are child nodes. Initialize them if necessary. - if Result.ChildCount = 0 then - InitChildren(Result); - end; - - // if there is no child node try siblings - if Assigned(Result.FirstChild) then - Result := Result.FirstChild - else - begin - repeat - // Is there a next sibling? - if Assigned(Result.NextSibling) then - begin - Result := Result.NextSibling; - Break; - end - else - begin - // No sibling anymore, so use the parent's next sibling. - if Result.Parent <> FRoot then - Result := Result.Parent - else - begin - // There are no further nodes to examine, hence there is no further visible node. - Result := nil; - Break; - end; - end; - until False; - end; - end; - end; - - if Assigned(Result) and not (vsInitialized in Result.States) then - InitNode(Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetNextChecked(Node: PVirtualNode; State: TCheckState = csCheckedNormal; - ConsiderChildrenAbove: Boolean = False): PVirtualNode; - -begin - if (Node = nil) or (Node = FRoot) then - Result := GetFirstNoInit(ConsiderChildrenAbove) - else - Result := GetNextNoInit(Node, ConsiderChildrenAbove); - - while Assigned(Result) and (GetCheckState(Result) <> State) do - Result := GetNextNoInit(Result, ConsiderChildrenAbove); - - if Assigned(Result) and not (vsInitialized in Result.States) then - InitNode(Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetNextChecked(Node: PVirtualNode; ConsiderChildrenAbove: Boolean): PVirtualNode; -begin - Result := Self.GetNextChecked(Node, csCheckedNormal, ConsiderChildrenAbove); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetNextCutCopy(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode; - -// Returns the next node in the tree which is currently marked for a clipboard operation. Since only visible nodes can -// be marked (or they are hidden after they have been marked) it is not necessary to initialize nodes to check for -// child nodes. The result, however, is initialized if necessary. - -begin - if ClipboardStates * FStates <> [] then - begin - if (Node = nil) or (Node = FRoot) then - Result := GetFirstNoInit(ConsiderChildrenAbove) - else - Result := GetNextNoInit(Node, ConsiderChildrenAbove); - while Assigned(Result) and not (vsCutOrCopy in Result.States) do - Result := GetNextNoInit(Result, ConsiderChildrenAbove); - if Assigned(Result) and not (vsInitialized in Result.States) then - InitNode(Result); - end - else - Result := nil; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetNextInitialized(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode; - -// Returns the next node in tree which is initialized. - -begin - Result := Node; - repeat - Result := GetNextNoInit(Result, ConsiderChildrenAbove); - until (Result = nil) or (vsInitialized in Result.States); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetNextLeaf(Node: PVirtualNode): PVirtualNode; - -// Returns the next node in the tree which has currently no children. -// The result is initialized if necessary. - -begin - if (Node = nil) or (Node = FRoot) then - Result := FRoot.FirstChild - else - Result := GetNext(Node); - while Assigned(Result) and (vsHasChildren in Result.States) do - Result := GetNext(Result); - if Assigned(Result) and not (vsInitialized in Result.States) then - InitNode(Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetNextLevel(Node: PVirtualNode; NodeLevel: Cardinal): PVirtualNode; - -// Returns the next node in the tree on a specific level. -// The result is initialized if necessary. - -var - StartNodeLevel: Cardinal; - -begin - Result := nil; - - if Assigned(Node) and (Node <> FRoot) then - begin - StartNodeLevel := GetNodeLevel(Node); - - if StartNodeLevel < NodeLevel then - begin - Result := GetNext(Node); - if Assigned(Result) and (GetNodeLevel(Result) <> NodeLevel) then - Result := GetNextLevel(Result, NodeLevel); - end - else - if StartNodeLevel = NodeLevel then - begin - Result := Node.NextSibling; - if not Assigned(Result) then // i.e. start node was a last sibling - begin - Result := Node.Parent; - if Assigned(Result) then - begin - // go to next anchestor of the start node which has a next sibling (if exists) - while Assigned(Result) and not Assigned(Result.NextSibling) do - Result := Result.Parent; - if Assigned(Result) then - Result := GetNextLevel(Result.NextSibling, NodeLevel); - end; - end; - end - else - // i.e. StartNodeLevel > NodeLevel - Result := GetNextLevel(Node.Parent, NodeLevel); - end; - - if Assigned(Result) and not (vsInitialized in Result.States) then - InitNode(Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetNextNoInit(Node: PVirtualNode; ConsiderChildrenAbove: Boolean): PVirtualNode; - -// Optimized version of GetNext performing no initialization, but optionally considering toChildrenAbove. - -begin - Result := Node; - if Assigned(Result) then - begin - Assert(Result <> FRoot, 'Node must not be the hidden root node.'); - - if ConsiderChildrenAbove and (toChildrenAbove in FOptions.FPaintOptions) then - begin - // If this node has no siblings use the parent. - if not Assigned(Result.NextSibling) then - begin - Result := Result.Parent; - if Result = FRoot then - begin - Result := nil; - end; - end - else - begin - // There is at least one sibling so take it. - Result := Result.NextSibling; - - // Now take a look at the children. - while Assigned(Result.FirstChild) do - begin - Result := Result.FirstChild; - end; - end; - end - else - begin - // If there is no child node try siblings. - if Assigned(Result.FirstChild) then - Result := Result.FirstChild - else - begin - repeat - // Is there a next sibling? - if Assigned(Result.NextSibling) then - begin - Result := Result.NextSibling; - Break; - end - else - begin - // No sibling anymore, so use the parent's next sibling. - if Result.Parent <> FRoot then - Result := Result.Parent - else - begin - // There are no further nodes to examine, hence there is no further visible node. - Result := nil; - Break; - end; - end; - until False; - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetNextSelected(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode; - -// Returns the next node in the tree which is currently selected. Since children of unitialized nodes cannot be -// in the current selection (because they simply do not exist yet) it is not necessary to initialize nodes here. -// The result however is initialized if necessary. - -begin - if FSelectionCount > 0 then - begin - if (Node = nil) or (Node = FRoot) then - Result := GetFirstNoInit(ConsiderChildrenAbove) - else - Result := GetNextNoInit(Node, ConsiderChildrenAbove); - while Assigned(Result) and not (vsSelected in Result.States) do - Result := GetNextNoInit(Result, ConsiderChildrenAbove); - if Assigned(Result) and not (vsInitialized in Result.States) then - InitNode(Result); - end - else - Result := nil; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetNextSibling(Node: PVirtualNode): PVirtualNode; - -// Returns the next sibling of Node and initializes it if necessary. - -begin - Result := Node; - if Assigned(Result) then - begin - Assert(Result <> FRoot, 'Node must not be the hidden root node.'); - - Result := Result.NextSibling; - if Assigned(Result) and not (vsInitialized in Result.States) then - InitNode(Result); - end; -end; - -function TBaseVirtualTree.GetNextSiblingNoInit(Node: PVirtualNode): PVirtualNode; - -// Returns the next sibling of Node. - -begin - Result := Node; - if Assigned(Result) then - begin - Assert(Result <> FRoot, 'Node must not be the hidden root node.'); - - Result := Result.NextSibling; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetNextVisible(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = True): PVirtualNode; - -// Returns next node in tree, with regard to Node, which is visible. -// Nodes which need an initialization (including the result) are initialized. -// toChildrenAbove is optionally considered which is the default here. - -var - ForceSearch: Boolean; - -begin - Result := Node; - if Assigned(Result) then - begin - Assert(Result <> FRoot, 'Node must not be the hidden root node.'); - - repeat - // If the given node is not visible then look for a parent node which is visible, otherwise we will - // likely go unnecessarily through a whole bunch of invisible nodes. - if not FullyVisible[Result] then - Result := GetVisibleParent(Result, True); - - if ConsiderChildrenAbove and (toChildrenAbove in FOptions.FPaintOptions) then - begin - repeat - // If there a no siblings anymore, go up one level. - if not Assigned(Result.NextSibling) then - begin - Result := Result.Parent; - if Result = FRoot then - begin - Result := nil; - Break; - end; - - if not (vsInitialized in Result.States) then - InitNode(Result); - if vsVisible in Result.States then - Break; - end - else - begin - // There is at least one sibling so take it. - Result := Result.NextSibling; - if not (vsInitialized in Result.States) then - InitNode(Result); - if not (vsVisible in Result.States) then - Continue; - - // Now take a look at the children. - // As the children are initialized while toggling, we don't need to do this here. - while (vsExpanded in Result.States) and Assigned(Result.FirstChild) do - begin - Result := Result.FirstChild; - if not (vsInitialized in Result.States) then - InitNode(Result); - if not (vsVisible in Result.States) then - Break; - end; - - // If we found a visible node we don't need to search any longer. - if vsVisible in Result.States then - Break; - end; - until False; - end - else - begin - // Has this node got children? - if [vsHasChildren, vsExpanded] * Result.States = [vsHasChildren, vsExpanded] then - begin - // Yes, there are child nodes. Initialize them if necessary. - if Result.ChildCount = 0 then - InitChildren(Result); - end; - - // Child nodes are the first choice if possible. - if (vsExpanded in Result.States) and Assigned(Result.FirstChild) then - begin - Result := GetFirstChild(Result); - ForceSearch := False; - end - else - ForceSearch := True; - - // If there are no children or the first child is not visible then search the sibling nodes or traverse parents. - if Assigned(Result) and (ForceSearch or not (vsVisible in Result.States)) then - begin - repeat - // Is there a next sibling? - if Assigned(Result.NextSibling) then - begin - Result := Result.NextSibling; - if not (vsInitialized in Result.States) then - InitNode(Result); - if vsVisible in Result.States then - Break; - end - else - begin - // No sibling anymore, so use the parent's next sibling. - if Result.Parent <> FRoot then - Result := Result.Parent - else - begin - // There are no further nodes to examine, hence there is no further visible node. - Result := nil; - Break; - end; - end; - until False; - end; - end; - until not Assigned(Result) or IsEffectivelyVisible[Result]; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetNextVisibleNoInit(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = True): PVirtualNode; - -// Returns the next node in tree, with regard to Node, which is visible. -// toChildrenAbove is optionally considered (which is the default). No initialization is done. - -var - ForceSearch: Boolean; - -begin - Result := Node; - if Assigned(Result) then - begin - Assert(Result <> FRoot, 'Node must not be the hidden root node.'); - - repeat - if ConsiderChildrenAbove and (toChildrenAbove in FOptions.FPaintOptions) then - begin - repeat - // If there a no siblings anymore, go up one level. - if not Assigned(Result.NextSibling) then - begin - Result := Result.Parent; - if Result = FRoot then - begin - Result := nil; - Break; - end; - if vsVisible in Result.States then - Break; - end - else - begin - // There is at least one sibling so take it. - Result := Result.NextSibling; - if not (vsVisible in Result.States) then - Continue; - - // Now take a look at the children. - while (vsExpanded in Result.States) and Assigned(Result.FirstChild) do - begin - Result := Result.FirstChild; - if not (vsVisible in Result.States) then - Break; - end; - - // If we found a visible node we don't need to search any longer. - if vsVisible in Result.States then - Break; - end; - until False; - end - else - begin - // If the given node is not visible then look for a parent node which is visible, otherwise we will - // likely go unnecessarily through a whole bunch of invisible nodes. - if not FullyVisible[Result] then - Result := GetVisibleParent(Result, True); - - // Child nodes are the first choice if possible. - if (vsExpanded in Result.States) and Assigned(Result.FirstChild) then - begin - Result := Result.FirstChild; - ForceSearch := False; - end - else - ForceSearch := True; - - // If there are no children or the first child is not visible then search the sibling nodes or traverse parents. - if ForceSearch or not (vsVisible in Result.States) then - begin - repeat - // Is there a next sibling? - if Assigned(Result.NextSibling) then - begin - Result := Result.NextSibling; - if vsVisible in Result.States then - Break; - end - else - begin - // No sibling anymore, so use the parent's next sibling. - if Result.Parent <> FRoot then - Result := Result.Parent - else - begin - // There are no further nodes to examine, hence there is no further visible node. - Result := nil; - Break; - end; - end; - until False; - end; - end; - until not Assigned(Result) or IsEffectivelyVisible[Result]; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetNextVisibleSibling(Node: PVirtualNode; IncludeFiltered: Boolean = False): PVirtualNode; - -// Returns the next visible sibling after Node. Initialization is done implicitly. - -begin - Assert(Assigned(Node) and (Node <> FRoot), 'Invalid parameter.'); - - Result := Node; - repeat - Result := GetNextSibling(Result); - until not Assigned(Result) or ((vsVisible in Result.States) and - (IncludeFiltered or not IsEffectivelyFiltered[Result])); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetNextVisibleSiblingNoInit(Node: PVirtualNode; IncludeFiltered: Boolean = False): PVirtualNode; - -// Returns the next visible sibling after Node. - -begin - Assert(Assigned(Node) and (Node <> FRoot), 'Invalid parameter.'); - - Result := Node; - repeat - Result := Result.NextSibling; - until not Assigned(Result) or ((vsVisible in Result.States) and - (IncludeFiltered or not IsEffectivelyFiltered[Result])); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetNodeAt(X, Y: Integer): PVirtualNode; - -// Overloaded variant of GetNodeAt to easy life of application developers which do not need to have the exact -// top position returned and always use client coordinates. - -var - Dummy: Integer; - -begin - Result := GetNodeAt(X, Y, True, Dummy); -end; - -function TBaseVirtualTree.GetNodeAt(const P: TPoint): PVirtualNode; -begin - Result := GetNodeAt(P.X, P.Y); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetNodeAt(X, Y: Integer; Relative: Boolean; var NodeTop: Integer): PVirtualNode; - -// This method returns the node that occupies the specified point, or nil if there's none. -// If Releative is True then X and Y are given in client coordinates otherwise they are considered as being -// absolute values into the virtual tree image (regardless of the current offsets in the tree window). -// NodeTop gets the absolute or relative top position of the node returned or is untouched if no node -// could be found. - -var - AbsolutePos, - CurrentPos: Cardinal; - -begin - if Y < 0 then - Y := 0; - - AbsolutePos := Y; - if Relative then - Inc(AbsolutePos, -FOffsetY); - - // CurrentPos tracks a running term of the current position to test for. - // It corresponds always to the top position of the currently considered node. - CurrentPos := 0; - - // If the cache is available then use it. - if tsUseCache in FStates then - Result := FindInPositionCache(AbsolutePos, CurrentPos) - else - Result := GetFirstVisibleNoInit(nil, True); - - // Determine node, of which position and height corresponds to the scroll position most closely. - while Assigned(Result) and (Result <> FRoot) do - begin - if AbsolutePos < (CurrentPos + NodeHeight[Result]) then - Break; - Inc(CurrentPos, NodeHeight[Result]); - Result := GetNextVisibleNoInit(Result, True); - end; - - if Result = FRoot then - Result := nil; - - // Since the given vertical position is likely not the same as the top position - // of the found node this top position is returned. - if Assigned(Result) then - begin - NodeTop := CurrentPos; - if Relative then - Inc(NodeTop, FOffsetY); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - - -function TBaseVirtualTree.GetNodeData(Node: PVirtualNode): Pointer; - -// Returns the address of the user defined data area in the node. - -begin - Assert(FNodeDataSize > 0, 'NodeDataSize not initialized.'); - if (FNodeDataSize <= 0) or (Node = nil) or (Node = FRoot) then - Result := nil - else - begin - Result := @Node.Data; - Include(Node.States, vsOnFreeNodeCallRequired); // We now need to call OnFreeNode, see bug #323 - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetNodeData(pNode: PVirtualNode): T; - -// Returns the associated data converted to the class given in the generic part of the function. - -begin - if Assigned(pNode) then - Result := T(Self.GetNodeData(pNode)^) - else - Result := Default(T); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetInterfaceFromNodeData(pNode: PVirtualNode): T; -begin - if Assigned(pNode) then - Result := T(Self.GetNodeData(pNode)^) - else - Result := nil; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetNodeDataAt(pXCoord, pYCoord: Integer): T; - -// Returns the associated data at the specified coordinates converted to the type given in the generic part of the function. - -var - lNode: PVirtualNode; -begin - lNode := GetNodeAt(pXCoord, pYCoord); - Result := Self.GetNodeData(lNode); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetFirstSelectedNodeData(): T; - -// Returns of the first selected node associated data converted to the type given in the generic part of the function. - -begin - Result := Self.GetNodeData(GetFirstSelected()); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetNodeLevel(Node: PVirtualNode): Cardinal; - -// returns the level of the given node - -var - Run: PVirtualNode; - -begin - Result := 0; - if Assigned(Node) and (Node <> FRoot) then - begin - Run := Node.Parent; - while Run <> FRoot do - begin - Run := Run.Parent; - Inc(Result); - end; - end; -end; - - -//---------------------------------------------------------------------------------------------------------------------- -// Function introduced to avoid spaghetti code to fix setting of FLastSelectionLevel -// at various places that now needs to avoid setting it for a disabled node -function TBaseVirtualTree.GetNodeLevelForSelectConstraint(Node: PVirtualNode): integer; -begin - if Assigned(Node) and not (vsDisabled in Node.States) then - result := GetNodeLevel(Node) - else - result := -1; -end; - - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetPrevious(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode; - -// Returns previous node in tree. If ConsiderChildrenAbove is True the function considers -// whether toChildrenAbove is currently set, otherwise the result will always be the previous -// node in top-down order regardless of the current PaintOptions. -// The Result will be initialized if needed. - -var - Run: PVirtualNode; - -begin - Result := Node; - if Assigned(Result) then - begin - Assert(Result <> FRoot, 'Node must not be the hidden root node.'); - - if ConsiderChildrenAbove and (toChildrenAbove in FOptions.FPaintOptions) then - begin - // Has this node got children? Initialize them if necessary. - if (vsHasChildren in Result.States) and (Result.ChildCount = 0) then - InitChildren(Result); - - // If there is a last child, take it; if not try the previous sibling. - if Assigned(Result.LastChild) then - Result := Result.LastChild - else - if Assigned(Result.PrevSibling) then - Result := Result.PrevSibling - else - begin - // If neither a last child nor a previous sibling exist, go the tree upwards and - // look, wether one of the parent nodes have a previous sibling. If not the result - // will ne nil. - repeat - Result := Result.Parent; - Run := nil; - if Result <> FRoot then - Run := Result.PrevSibling - else - Result := nil; - until Assigned(Run) or (Result = nil); - - if Assigned(Run) then - Result := Run; - end; - end - else - begin - // Is there a previous sibling? - if Assigned(Node.PrevSibling) then - begin - // Go down and find the last child node. - Result := GetLast(Node.PrevSibling); - if Result = nil then - Result := Node.PrevSibling; - end - else - // no previous sibling so the parent of the node is the previous visible node - if Node.Parent <> FRoot then - Result := Node.Parent - else - Result := nil; - end; - end; - - if Assigned(Result) and not (vsInitialized in Result.States) then - InitNode(Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetPreviousChecked(Node: PVirtualNode; State: TCheckState = csCheckedNormal; - ConsiderChildrenAbove: Boolean = False): PVirtualNode; - -begin - if (Node = nil) or (Node = FRoot) then - Result := GetLastNoInit(nil, ConsiderChildrenAbove) - else - Result := GetPreviousNoInit(Node, ConsiderChildrenAbove); - - while Assigned(Result) and (GetCheckState(Result) <> State) do - Result := GetPreviousNoInit(Result, ConsiderChildrenAbove); - - if Assigned(Result) and not (vsInitialized in Result.States) then - InitNode(Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetPreviousCutCopy(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode; - -// Returns the previous node in the tree which is currently marked for a clipboard operation. Since only visible nodes can -// be marked (or they are hidden after they have been marked) it is not necessary to initialize nodes to check for -// child nodes. The result, however, is initialized if necessary. - -begin - if ClipboardStates * FStates <> [] then - begin - if (Node = nil) or (Node = FRoot) then - Result := GetLastNoInit(nil, ConsiderChildrenAbove) - else - Result := GetPreviousNoInit(Node, ConsiderChildrenAbove); - while Assigned(Result) and not (vsCutOrCopy in Result.States) do - Result := GetPreviousNoInit(Result, ConsiderChildrenAbove); - if Assigned(Result) and not (vsInitialized in Result.States) then - InitNode(Result); - end - else - Result := nil; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetPreviousInitialized(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode; - -// Returns the previous node in tree which is initialized. - -begin - Result := Node; - repeat - Result := GetPreviousNoInit(Result, ConsiderChildrenAbove); - until (Result = nil) or (vsInitialized in Result.States); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetPreviousLeaf(Node: PVirtualNode): PVirtualNode; - -// Returns the previous node in the tree which has currently no children. -// The result is initialized if necessary. - -begin - if (Node = nil) or (Node = FRoot) then - Result := FRoot.LastChild - else - Result := GetPrevious(Node); - while Assigned(Result) and (vsHasChildren in Result.States) do - Result := GetPrevious(Result); - if Assigned(Result) and not (vsInitialized in Result.States) then - InitNode(Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetPreviousLevel(Node: PVirtualNode; NodeLevel: Cardinal): PVirtualNode; - -// Returns the previous node in the tree on a specific level. -// The result is initialized if necessary. - -var - StartNodeLevel: Cardinal; - Run: PVirtualNode; - -begin - Result := nil; - - if Assigned(Node) and (Node <> FRoot) then - begin - StartNodeLevel := GetNodeLevel(Node); - - if StartNodeLevel < NodeLevel then - begin - Result := Node.PrevSibling; - if Assigned(Result) then - begin - // go to last descendant of previous sibling with desired node level (if exists) - Run := Result; - while Assigned(Run) and (GetNodeLevel(Run) < NodeLevel) do - begin - Result := Run; - Run := GetLastChild(Run); - end; - if Assigned(Run) and (GetNodeLevel(Run) = NodeLevel) then - Result := Run - else - begin - if Assigned(Result.PrevSibling) then - Result := GetPreviousLevel(Result, NodeLevel) - else - if Assigned(Result) and (Result.Parent <> FRoot) then - Result := GetPreviousLevel(Result.Parent, NodeLevel) - else - Result := nil; - end; - end - else - Result := GetPreviousLevel(Node.Parent, NodeLevel); - end - else - if StartNodeLevel = NodeLevel then - begin - Result := Node.PrevSibling; - if not Assigned(Result) then // i.e. start node was a first sibling - begin - Result := Node.Parent; - if Assigned(Result) then - Result := GetPreviousLevel(Result, NodeLevel); - end; - end - else // i.e. StartNodeLevel > NodeLevel - Result := GetPreviousLevel(Node.Parent, NodeLevel); - end; - - if Assigned(Result) and not (vsInitialized in Result.States) then - InitNode(Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetPreviousNoInit(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode; - -// Returns previous node in tree, optionally considering toChildrenAbove. No initialization is performed. - -var - Run: PVirtualNode; - -begin - Result := Node; - if Assigned(Result) then - begin - Assert(Result <> FRoot, 'Node must not be the hidden root node.'); - - if ConsiderChildrenAbove and (toChildrenAbove in FOptions.FPaintOptions) then - begin - // If there is a last child, take it; if not try the previous sibling. - if Assigned(Result.LastChild) then - Result := Result.LastChild - else - if Assigned(Result.PrevSibling) then - Result := Result.PrevSibling - else - begin - // If neither a last child nor a previous sibling exist, go the tree upwards and - // look, wether one of the parent nodes have a previous sibling. If not the result - // will ne nil. - repeat - Result := Result.Parent; - Run := nil; - if Result <> FRoot then - Run := Result.PrevSibling - else - Result := nil; - until Assigned(Run) or (Result = nil); - - if Assigned(Run) then - Result := Run; - end; - end - else - begin - // Is there a previous sibling? - if Assigned(Node.PrevSibling) then - begin - // Go down and find the last child node. - Result := GetLastNoInit(Node.PrevSibling); - if Result = nil then - Result := Node.PrevSibling; - end - else - // No previous sibling so the parent of the node is the previous node. - if Node.Parent <> FRoot then - Result := Node.Parent - else - Result := nil; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetPreviousSelected(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode; - -// Returns the previous node in the tree which is currently selected. Since children of unitialized nodes cannot be -// in the current selection (because they simply do not exist yet) it is not necessary to initialize nodes here. -// The result however is initialized if necessary. - -begin - if FSelectionCount > 0 then - begin - if (Node = nil) or (Node = FRoot) then - Result := FRoot.LastChild - else - Result := GetPreviousNoInit(Node, ConsiderChildrenAbove); - while Assigned(Result) and not (vsSelected in Result.States) do - Result := GetPreviousNoInit(Result, ConsiderChildrenAbove); - if Assigned(Result) and not (vsInitialized in Result.States) then - InitNode(Result); - end - else - Result := nil; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetPreviousSibling(Node: PVirtualNode): PVirtualNode; - -// Returns the previous sibling of Node and initializes it if necessary. - -begin - Result := Node; - if Assigned(Result) then - begin - Assert(Result <> FRoot, 'Node must not be the hidden root node.'); - - Result := Result.PrevSibling; - if Assigned(Result) and not (vsInitialized in Result.States) then - InitNode(Result); - end; -end; - -function TBaseVirtualTree.GetPreviousSiblingNoInit(Node: PVirtualNode): PVirtualNode; - -// Returns the previous sibling of Node - -begin - Result := Node; - if Assigned(Result) then - begin - Assert(Result <> FRoot, 'Node must not be the hidden root node.'); - - Result := Result.PrevSibling; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetPreviousVisible(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = True): PVirtualNode; - -// Returns the previous node in tree, with regard to Node, which is visible. -// Nodes which need an initialization (including the result) are initialized. -// toChildrenAbove is optionally considered which is the default here. - -var - Marker: PVirtualNode; - -begin - Result := Node; - if Assigned(Result) then - begin - Assert(Result <> FRoot, 'Node must not be the hidden root node.'); - - repeat - // If the given node is not visible then look for a parent node which is visible and use its last visible - // child or the parent node (if there is no visible child) as result. - if not FullyVisible[Result] then - begin - Result := GetVisibleParent(Result, True); - if Result = FRoot then - Result := nil; - Marker := GetLastVisible(Result, True); - if Assigned(Marker) then - Result := Marker; - end - else - begin - if ConsiderChildrenAbove and (toChildrenAbove in FOptions.FPaintOptions) then - begin - repeat - if Assigned(Result.LastChild) and (vsExpanded in Result.States) then - begin - Result := Result.LastChild; - if not (vsInitialized in Result.States) then - InitNode(Result); - - if vsVisible in Result.States then - Break; - end - else - if Assigned(Result.PrevSibling) then - begin - if not (vsInitialized in Result.PrevSibling.States) then - InitNode(Result.PrevSibling); - - if vsVisible in Result.PrevSibling.States then - begin - Result := Result.PrevSibling; - Break; - end; - end - else - begin - Marker := nil; - repeat - Result := Result.Parent; - if Result <> FRoot then - Marker := GetPreviousVisibleSibling(Result, True) - else - Result := nil; - until Assigned(Marker) or (Result = nil); - if Assigned(Marker) then - Result := Marker; - - Break; - end; - until False; - end - else - begin - repeat - // Is there a previous sibling node? - if Assigned(Result.PrevSibling) then - begin - Result := Result.PrevSibling; - // Initialize the new node and check its visibility. - if not (vsInitialized in Result.States) then - InitNode(Result); - if vsVisible in Result.States then - begin - // If there are visible child nodes then use the last one. - Marker := GetLastVisible(Result, True, True); - if Assigned(Marker) then - Result := Marker; - Break; - end; - end - else - begin - // No previous sibling there so the parent node is the nearest previous node. - Result := Result.Parent; - if Result = FRoot then - Result := nil; - Break; - end; - until False; - end; - - if Assigned(Result) and not (vsInitialized in Result.States) then - InitNode(Result); - end; - until not Assigned(Result) or IsEffectivelyVisible[Result]; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetPreviousVisibleNoInit(Node: PVirtualNode; - ConsiderChildrenAbove: Boolean = True): PVirtualNode; - -// Returns the previous node in tree, with regard to Node, which is visible. -// toChildrenAbove is optionally considered which is the default here. - -var - Marker: PVirtualNode; - -begin - Result := Node; - if Assigned(Result) then - begin - Assert(Result <> FRoot, 'Node must not be the hidden root node.'); - - repeat - // If the given node is not visible then look for a parent node which is visible and use its last visible - // child or the parent node (if there is no visible child) as result. - if not FullyVisible[Result] then - begin - Result := GetVisibleParent(Result, True); - if Result = FRoot then - Result := nil; - Marker := GetLastVisibleNoInit(Result, True); - if Assigned(Marker) then - Result := Marker; - end - else - begin - if ConsiderChildrenAbove and (toChildrenAbove in FOptions.FPaintOptions) then - begin - repeat - // Is the current node expanded and has children? - if (vsExpanded in Result.States) and Assigned(Result.LastChild) then - begin - Result := Result.LastChild; - if vsVisible in Result.States then - Break; - end - else - if Assigned(Result.PrevSibling) then - begin - // No children anymore, so take the previous sibling. - Result := Result.PrevSibling; - if vsVisible in Result.States then - Break; - end - else - begin - // No children and no previous siblings, so walk up the tree and look wether - // a parent has a previous visible sibling. If that is the case take it, - // otherwise there is no previous visible node. - Marker := nil; - repeat - Result := Result.Parent; - if Result <> FRoot then - Marker := GetPreviousVisibleSiblingNoInit(Result, True) - else - Result := nil; - until Assigned(Marker) or (Result = nil); - if Assigned(Marker) then - Result := Marker; - Break; - end; - until False; - end - else - begin - repeat - // Is there a previous sibling node? - if Assigned(Result.PrevSibling) then - begin - Result := Result.PrevSibling; - if vsVisible in Result.States then - begin - // If there are visible child nodes then use the last one. - Marker := GetLastVisibleNoInit(Result, True, True); - if Assigned(Marker) then - Result := Marker; - Break; - end; - end - else - begin - // No previous sibling there so the parent node is the nearest previous node. - Result := Result.Parent; - if Result = FRoot then - Result := nil; - Break; - end; - until False; - end; - end; - until not Assigned(Result) or IsEffectivelyVisible[Result]; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetPreviousVisibleSibling(Node: PVirtualNode; IncludeFiltered: Boolean = False): PVirtualNode; - -// Returns the previous visible sibling before Node. Initialization is done implicitly. - -begin - Assert(Assigned(Node) and (Node <> FRoot), 'Invalid parameter.'); - - Result := Node; - repeat - Result := GetPreviousSibling(Result); - until not Assigned(Result) or ((vsVisible in Result.States) and - (IncludeFiltered or not IsEffectivelyFiltered[Result])); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetPreviousVisibleSiblingNoInit(Node: PVirtualNode; - IncludeFiltered: Boolean = False): PVirtualNode; - -// Returns the previous visible sibling before Node. - -begin - Assert(Assigned(Node) and (Node <> FRoot), 'Invalid parameter.'); - - Result := Node; - repeat - Result := Result.PrevSibling; - until not Assigned(Result) or ((vsVisible in Result.States) and - (IncludeFiltered or not IsEffectivelyFiltered[Result])); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.Nodes(ConsiderChildrenAbove: Boolean): TVTVirtualNodeEnumeration; - -// Enumeration for all nodes - -begin - Result.FMode := vneAll; - Result.FTree := Self; - Result.FConsiderChildrenAbove := ConsiderChildrenAbove; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.CheckedNodes(State: TCheckState; ConsiderChildrenAbove: Boolean): TVTVirtualNodeEnumeration; - -// Enumeration for all checked nodes - -begin - Result.FMode := vneChecked; - Result.FTree := Self; - Result.FState := State; - Result.FConsiderChildrenAbove := ConsiderChildrenAbove; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.ChildNodes(Node: PVirtualNode): TVTVirtualNodeEnumeration; - -// Enumeration for child nodes - -begin - Result.FMode := vneChild; - Result.FTree := Self; - Result.FNode := Node; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.CutCopyNodes(ConsiderChildrenAbove: Boolean): TVTVirtualNodeEnumeration; - -// Enumeration for cut copy node - -begin - Result.FMode := vneCutCopy; - Result.FTree := Self; - Result.FConsiderChildrenAbove := ConsiderChildrenAbove; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.InitializedNodes(ConsiderChildrenAbove: Boolean): TVTVirtualNodeEnumeration; - -// Enumeration for initialized nodes - -begin - Result.FMode := vneInitialized; - Result.FTree := Self; - Result.FConsiderChildrenAbove := ConsiderChildrenAbove; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.LeafNodes: TVTVirtualNodeEnumeration; - -// Enumeration for leaf nodes - -begin - Result.FMode := vneLeaf; - Result.FTree := Self; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.LevelNodes(NodeLevel: Cardinal): TVTVirtualNodeEnumeration; - -// Enumeration for level nodes - -begin - Result.FMode := vneLevel; - Result.FTree := Self; - Result.FNodeLevel := NodeLevel; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.NoInitNodes(ConsiderChildrenAbove: Boolean): TVTVirtualNodeEnumeration; - -// Enumeration for no init nodes -begin - Result.FMode := vneNoInit; - Result.FTree := Self; - Result.FConsiderChildrenAbove := ConsiderChildrenAbove; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.SelectedNodes(ConsiderChildrenAbove: Boolean): TVTVirtualNodeEnumeration; - -// Enumeration for selected nodes - -begin - Result.FMode := vneSelected; - Result.FTree := Self; - Result.FConsiderChildrenAbove := ConsiderChildrenAbove; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.VisibleNodes(Node: PVirtualNode; ConsiderChildrenAbove: Boolean; - IncludeFiltered: Boolean): TVTVirtualNodeEnumeration; - -// Enumeration for visible nodes - -begin - Result.FMode := vneVisible; - Result.FTree := Self; - Result.FNode := Node; - Result.FConsiderChildrenAbove := ConsiderChildrenAbove; - Result.FIncludeFiltered := IncludeFiltered; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.VisibleChildNodes(Node: PVirtualNode; IncludeFiltered: Boolean): TVTVirtualNodeEnumeration; - -// Enumeration for visible child nodes - -begin - Result.FMode := vneVisibleChild; - Result.FTree := Self; - Result.FNode := Node; - Result.FIncludeFiltered := IncludeFiltered; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.VisibleChildNoInitNodes(Node: PVirtualNode; IncludeFiltered: Boolean): TVTVirtualNodeEnumeration; - -// Enumeration for visible child no init nodes - -begin - Result.FMode := vneVisibleNoInitChild; - Result.FTree := Self; - Result.FNode := Node; - Result.FIncludeFiltered := IncludeFiltered; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.VisibleNoInitNodes(Node: PVirtualNode; ConsiderChildrenAbove: Boolean; - IncludeFiltered: Boolean): TVTVirtualNodeEnumeration; - -// Enumeration for visible no init nodes - -begin - Result.FMode := vneVisibleNoInit; - Result.FTree := Self; - Result.FNode := Node; - Result.FConsiderChildrenAbove := ConsiderChildrenAbove; - Result.FIncludeFiltered := IncludeFiltered; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetSortedCutCopySet(Resolve: Boolean): TNodeArray; - -// Same as GetSortedSelection but with nodes marked as being part in the current cut/copy set (e.g. for clipboard). - -var - Run: PVirtualNode; - Counter: Cardinal; - - //--------------- local function -------------------------------------------- - - procedure IncludeThisNode(Node: PVirtualNode); - - // adds the given node to the result - - var - Len: Cardinal; - - begin - Len := Length(Result); - if Counter = Len then - begin - if Len < 100 then - Len := 100 - else - Len := Len + Len div 10; - SetLength(Result, Len); - end; - Result[Counter] := Node; - Inc(Counter); - end; - - //--------------- end local function ---------------------------------------- - -begin - Run := FRoot.FirstChild; - Counter := 0; - if Resolve then - begin - // Resolving is actually easy: just find the first cutted node in logical order - // and then never go deeper in level than this node as long as there's a sibling node. - // Restart the search for a cutted node (at any level) if there are no further siblings. - while Assigned(Run) do - begin - if vsCutOrCopy in Run.States then - begin - IncludeThisNode(Run); - if Assigned(Run.NextSibling) then - Run := Run.NextSibling - else - begin - // If there are no further siblings then go up one or more levels until a node is - // found or all nodes have been processed. Although we consider here only initialized - // nodes we don't need to make any special checks as only initialized nodes can also be selected. - repeat - Run := Run.Parent; - until (Run = FRoot) or Assigned(Run.NextSibling); - if Run = FRoot then - Break - else - Run := Run.NextSibling; - end; - end - else - Run := GetNextNoInit(Run); - end; - end - else - while Assigned(Run) do - begin - if vsCutOrCopy in Run.States then - IncludeThisNode(Run); - Run := GetNextNoInit(Run); - end; - - // set the resulting array to its real length - SetLength(Result, Counter); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetSortedSelection(Resolve: Boolean): TNodeArray; - -// Returns a list of selected nodes sorted in logical order, that is, as they appear in the tree. -// If Resolve is True then nodes which are children of other selected nodes are not put into the new array. -// This feature is in particuar important when doing drag'n drop as in this case all selected node plus their children -// need to be considered. A selected node which is child (grand child etc.) of another selected node is then -// automatically included and doesn't need to be explicitely mentioned in the returned selection array. -// -// Note: The caller is responsible for freeing the array. Allocation is done here. Usually, though, freeing the array -// doesn't need additional attention as it is automatically freed by Delphi when it gets out of scope. - -var - Run: PVirtualNode; - Counter: Cardinal; - -begin - SetLength(Result, FSelectionCount); - if FSelectionCount > 0 then - begin - Run := FRoot.FirstChild; - Counter := 0; - if Resolve then - begin - // Resolving is actually easy: just find the first selected node in logical order - // and then never go deeper in level than this node as long as there's a sibling node. - // Restart the search for a selected node (at any level) if there are no further siblings. - while Assigned(Run) do - begin - if vsSelected in Run.States then - begin - Result[Counter] := Run; - Inc(Counter); - if Assigned(Run.NextSibling) then - Run := Run.NextSibling - else - begin - // If there are no further siblings then go up one or more levels until a node is - // found or all nodes have been processed. Although we consider here only initialized - // nodes we don't need to make any special checks as only initialized nodes can also be selected. - repeat - Run := Run.Parent; - until (Run = FRoot) or Assigned(Run.NextSibling); - if Run = FRoot then - Break - else - Run := Run.NextSibling; - end; - end - else - Run := GetNextNoInit(Run); - end; - end - else - while Assigned(Run) do - begin - if vsSelected in Run.States then - begin - Result[Counter] := Run; - Inc(Counter); - end; - Run := GetNextNoInit(Run); - end; - - // Since we may have skipped some nodes the result array is likely to be smaller than the - // selection array, hence shorten the result to true length. - if Integer(Counter) < Length(Result) then - SetLength(Result, Counter); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.GetTextInfo(Node: PVirtualNode; Column: TColumnIndex; const AFont: TFont; var R: TRect; - var Text: string); - -// Generic base method for editors, hint windows etc. to get some info about a node. - -begin - R := Rect(0, 0, 0, 0); - Text := ''; - if Assigned(Font) then // 1 EConvertError due to Font being nil seen here in 01/2019, See issue #878 - AFont.Assign(Font); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetTreeRect: TRect; - -// Returns the true size of the tree in pixels. This size is at least ClientHeight x ClientWidth and depends on -// the expand state, header size etc. -// Note: if no columns are used then the width of the tree is determined by the largest node which is currently in the -// client area. This might however not be the largest node in the entire tree. - -begin - Result := Rect(0, 0, Max(FRangeX, ClientWidth), Max(FRangeY, ClientHeight)); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetVisibleParent(Node: PVirtualNode; IncludeFiltered: Boolean = False): PVirtualNode; - -// Returns the first (nearest) parent node of Node which is visible. -// This method is one of the seldom cases where the hidden root node could be returned. - -begin - Assert(Assigned(Node), 'Node must not be nil.'); - Assert(Node <> FRoot, 'Node must not be the hidden root node.'); - - Result := Node.Parent; - while (Result <> FRoot) and (not FullyVisible[Result] or (not IncludeFiltered and IsEffectivelyFiltered[Result])) do - Result := Result.Parent; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.HasAsParent(Node, PotentialParent: PVirtualNode): Boolean; - -// Determines whether Node has got PotentialParent as one of its parents. - -var - Run: PVirtualNode; - -begin - Result := Assigned(Node) and Assigned(PotentialParent) and (Node <> PotentialParent); - if Result then - begin - Run := Node; - while (Run <> FRoot) and (Run <> PotentialParent) do - Run := Run.Parent; - Result := Run = PotentialParent; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.InsertNode(Node: PVirtualNode; Mode: TVTNodeAttachMode; UserData: Pointer = nil): PVirtualNode; - -// Adds a new node relative to Node. The final position is determined by Mode. -// UserData can be used to set the first SizeOf(Pointer) bytes of the user data area to an initial value which can be used -// in OnInitNode and will also cause to trigger the OnFreeNode event (if <> nil) even if the node is not yet -// "officially" initialized. -// InsertNode is a compatibility method and will implicitly validate the given node if the new node -// is to be added as child node. This is however against the virtual paradigm and hence I dissuade from its usage. - -begin - if Mode <> amNoWhere then - begin - CancelEditNode; - - if Node = nil then - Node := FRoot; - // we need a new node... - Result := MakeNewNode; - // avoid erronous attach modes - if Node = FRoot then - begin - case Mode of - amInsertBefore: - Mode := amAddChildFirst; - amInsertAfter: - Mode := amAddChildLast; - end; - end; - - // Validate given node in case the new node becomes its child. - if (Mode in [amAddChildFirst, amAddChildLast]) and not (vsInitialized in Node.States) then - InitNode(Node); - InternalConnectNode(Result, Node, Self, Mode); - - // Check if there is initial user data and there is also enough user data space allocated. - if Assigned(UserData) then - SetNodeData(Result, UserData); - - if FUpdateCount = 0 then - begin - case Mode of - amInsertBefore, - amInsertAfter: - begin - // Here no initialization is necessary because *if* a node has already got children then it - // must also be initialized. - // Note: Node can never be FRoot at this point. - StructureChange(Result, crNodeAdded); - // If auto sort is enabled then sort the node or its parent (depending on the insert mode). - if (toAutoSort in FOptions.FAutoOptions) and (FHeader.FSortColumn > InvalidColumn) then - Sort(Node.Parent, FHeader.FSortColumn, FHeader.FSortDirection, True); - InvalidateToBottom(Result) - end; - amAddChildFirst, - amAddChildLast: - begin - StructureChange(Node, crChildAdded); - // If auto sort is enabled then sort the node or its parent (depending on the insert mode). - if (toAutoSort in FOptions.FAutoOptions) and (FHeader.FSortColumn > InvalidColumn) then - Sort(Node, FHeader.FSortColumn, FHeader.FSortDirection, True); - InvalidateToBottom(Node); - end; - end; - InvalidateCache(); - UpdateScrollBars(True); - end; - end - else - Result := nil; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.InvalidateChildren(Node: PVirtualNode; Recursive: Boolean); - -// Invalidates Node and its immediate children. -// If Recursive is True then all grandchildren are invalidated as well. -// The node itself is initialized if necessary and its child nodes are created (and initialized too if -// Recursive is True). - -var - Run: PVirtualNode; - -begin - if Assigned(Node) then - begin - if not (vsInitialized in Node.States) then - InitNode(Node); - InvalidateNode(Node); - if (vsHasChildren in Node.States) and (Node.ChildCount = 0) then - InitChildren(Node); - Run := Node.FirstChild; - end - else - Run := FRoot.FirstChild; - - while Assigned(Run) do - begin - InvalidateNode(Run); - if Recursive then - InvalidateChildren(Run, True); - Run := Run.NextSibling; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.InvalidateColumn(Column: TColumnIndex); - -// Invalidates the client area part of a column. - -var - R: TRect; - -begin - if (FUpdateCount = 0) and HandleAllocated and FHeader.FColumns.IsValidColumn(Column) then - begin - R := ClientRect; - FHeader.Columns.GetColumnBounds(Column, R.Left, R.Right); - InvalidateRect(Handle, @R, False); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.InvalidateNode(Node: PVirtualNode): TRect; - -// Initiates repaint of the given node and returns the just invalidated rectangle. - -begin - Assert(Assigned(Node), 'Node must not be nil.'); - Assert(GetCurrentThreadId = MainThreadId, 'UI controls may only be chnaged in UI thread.'); - // Reset height measured flag too to cause a re-issue of the OnMeasureItem event. - Exclude(Node.States, vsHeightMeasured); - if (FUpdateCount = 0) and HandleAllocated then - begin - Result := GetDisplayRect(Node, NoColumn, False); - InvalidateRect(Handle, @Result, False); - end - else - result := Rect(-1,-1,-1,-1); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.InvalidateToBottom(Node: PVirtualNode); - -// Initiates repaint of client area starting at given node. If this node is not visible or not yet initialized -// then nothing happens. - -var - R: TRect; - -begin - if (FUpdateCount = 0) and HandleAllocated then - begin - if (Node = nil) or (Node = FRoot) then - Invalidate - else - if (vsInitialized in Node.States) and IsEffectivelyVisible[Node] then - begin - R := GetDisplayRect(Node, NoColumn, False); - if R.Top < ClientHeight then - begin - if (toChildrenAbove in FOptions.FPaintOptions) and (vsExpanded in Node.States) then - Dec(R.Top, Node.TotalHeight + NodeHeight[Node]); - R.Bottom := ClientHeight; - InvalidateRect(Handle, @R, False); - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.InvertSelection(VisibleOnly: Boolean); - -// Inverts the current selection (so nodes which are selected become unselected and vice versa). -// If VisibleOnly is True then only visible nodes are considered. - -var - Run: PVirtualNode; - NewSize: Integer; - NextFunction: TGetNextNodeProc; - TriggerChange: Boolean; - -begin - if not FSelectionLocked and (toMultiSelect in FOptions.FSelectionOptions) then - begin - Run := FRoot.FirstChild; - ClearTempCache; - if VisibleOnly then - NextFunction := GetNextVisibleNoInit - else - NextFunction := GetNextNoInit; - while Assigned(Run) do - begin - if vsSelected in Run.States then - InternalRemoveFromSelection(Run) - else - InternalCacheNode(Run); - Run := NextFunction(Run); - end; - - // do some housekeeping - // Need to trigger the OnChange event from here if nodes were only deleted but not added. - TriggerChange := False; - NewSize := PackArray(FSelection, FSelectionCount); - if NewSize > -1 then - begin - FSelectionCount := NewSize; - SetLength(FSelection, FSelectionCount); - TriggerChange := True; - end; - if FTempNodeCount > 0 then - begin - AddToSelection(FTempNodeCache, FTempNodeCount); - ClearTempCache; - TriggerChange := False; - end; - Invalidate; - if TriggerChange then - Change(nil); - if Self.SelectedCount = 0 then - FNextNodeToSelect := nil;//Ensure that no other node is selected now - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.IsEditing: Boolean; - -begin - Result := tsEditing in FStates; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.IsMouseSelecting: Boolean; - -begin - Result := (tsDrawSelPending in FStates) or (tsDrawSelecting in FStates); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.IterateSubtree(Node: PVirtualNode; Callback: TVTGetNodeProc; Data: Pointer; - Filter: TVirtualNodeStates = []; DoInit: Boolean = False; ChildNodesOnly: Boolean = False): PVirtualNode; - -// Iterates through the all children and grandchildren etc. of Node (or the entire tree if Node = nil) -// and calls for each node the provided callback method (which must not be empty). -// Filter determines which nodes to consider (an empty set denotes all nodes). -// If DoInit is True then nodes which aren't initialized yet will be initialized. -// Note: During execution of the callback the application can set Abort to True. In this case the iteration is stopped -// and the last accessed node (the one on which the callback set Abort to True) is returned to the caller. -// Otherwise (no abort) nil is returned. - -var - Stop: PVirtualNode; - Abort: Boolean; - GetNextNode: TGetNextNodeProc; - WasIterating: Boolean; - -begin - Assert(Node <> FRoot, 'Node must not be the hidden root node.'); - - WasIterating := tsIterating in FStates; - DoStateChange([tsIterating]); - try - // prepare function to be used when advancing - if DoInit then - GetNextNode := GetNext - else - GetNextNode := GetNextNoInit; - - Abort := False; - if Node = nil then - Stop := nil - else - begin - if not (vsInitialized in Node.States) and DoInit then - InitNode(Node); - - // The stopper does not need to be initialized since it is not taken into the enumeration. - Stop := Node.NextSibling; - if Stop = nil then - begin - Stop := Node; - repeat - Stop := Stop.Parent; - until (Stop = FRoot) or Assigned(Stop.NextSibling); - if Stop = FRoot then - Stop := nil - else - Stop := Stop.NextSibling; - end; - end; - - // Use first node if we start with the root. - if Node = nil then - Node := GetFirstNoInit; - - if Assigned(Node) then - begin - if not (vsInitialized in Node.States) and DoInit then - InitNode(Node); - - // Skip given node if only the child nodes are requested. - if ChildNodesOnly then - begin - if Node.ChildCount = 0 then - Node := nil - else - Node := GetNextNode(Node); - end; - - if Filter = [] then - begin - // unfiltered loop - while Assigned(Node) and (Node <> Stop) do - begin - Callback(Self, Node, Data, Abort); - if Abort then - Break; - Node := GetNextNode(Node); - end; - end - else - begin - // filtered loop - while Assigned(Node) and (Node <> Stop) do - begin - if Node.States * Filter = Filter then - Callback(Self, Node, Data, Abort); - if Abort then - Break; - Node := GetNextNode(Node); - end; - end; - end; - - if Abort then - Result := Node - else - Result := nil; - finally - if not WasIterating then - DoStateChange([], [tsIterating]); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.LoadFromFile(const FileName: TFileName); - -var - FileStream: TFileStream; - -begin - FileStream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); - try - LoadFromStream(FileStream); - finally - FileStream.Free; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.LoadFromStream(Stream: TStream); - -// Clears the current content of the tree and loads a new structure from the given stream. - -var - ThisID: TMagicID; - Version, - Count: Cardinal; - Node: PVirtualNode; - -begin - if not (toReadOnly in FOptions.FMiscOptions) then - begin - Clear; - // Check first whether this is a stream we can read. - if Stream.Read(ThisID, SizeOf(TMagicID)) < SizeOf(TMagicID) then - ShowError(SStreamTooSmall, hcTFStreamTooSmall); - - if (ThisID[0] = MagicID[0]) and - (ThisID[1] = MagicID[1]) and - (ThisID[2] = MagicID[2]) and - (ThisID[5] = MagicID[5]) then - begin - Version := Word(ThisID[3]); - if Version <= VTTreeStreamVersion then - begin - BeginUpdate; - try - if Version < 2 then - Count := MaxInt - else - Stream.ReadBuffer(Count, SizeOf(Count)); - - while (Stream.Position < Stream.Size) and (Count > 0) do - begin - Dec(Count); - Node := MakeNewNode; - InternalConnectNode(Node, FRoot, Self, amAddChildLast); - InternalAddFromStream(Stream, Version, Node); - end; - DoNodeCopied(nil); - if Assigned(FOnLoadTree) then - FOnLoadTree(Self, Stream); - finally - EndUpdate; - end; - end - else - ShowError(SWrongStreamVersion, hcTFWrongStreamVersion); - end - else - ShowError(SWrongStreamFormat, hcTFWrongStreamFormat); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.MeasureItemHeight(const Canvas: TCanvas; Node: PVirtualNode); - -// If the height of the given node has not yet been measured then do it now. - -var - NewNodeHeight: Integer; - -begin - if not (vsHeightMeasured in Node.States) then - begin - Include(Node.States, vsHeightMeasured); - if (toVariableNodeHeight in FOptions.FMiscOptions) then - begin - NewNodeHeight := Node.NodeHeight; - // Anonymous methods help to make this thread safe easily. - if (MainThreadId <> GetCurrentThreadId) then - TThread.Synchronize(nil, - procedure - begin - DoMeasureItem(Canvas, Node, NewNodeHeight); - SetNodeHeight(Node, NewNodeHeight); - end - ) - else - begin - DoMeasureItem(Canvas, Node, NewNodeHeight); - SetNodeHeight(Node, NewNodeHeight); - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.MoveTo(Node: PVirtualNode; Tree: TBaseVirtualTree; Mode: TVTNodeAttachMode; - ChildrenOnly: Boolean); - -// A simplified method to allow to move nodes to the root of another tree. - -begin - MoveTo(Node, Tree.FRoot, Mode, ChildrenOnly); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.MoveTo(Source, Target: PVirtualNode; Mode: TVTNodeAttachMode; ChildrenOnly: Boolean); - -// Moves the given node (and all its children) to Target. Source must belong to the tree instance which calls this -// MoveTo method. Mode determines how to connect Source to Target. -// This method might involve a change of the tree if Target belongs to a different tree than Source. - -var - TargetTree: TBaseVirtualTree; - Allowed: Boolean; - NewNode: PVirtualNode; - Stream: TMemoryStream; - -begin - Assert(TreeFromNode(Source) = Self, 'The source tree must contain the source node.'); - - // When moving nodes then source and target must not be the same node unless only the source's children are - // moved and they are inserted before or after the node itself. - Allowed := (Source <> Target) or ((Mode in [amInsertBefore, amInsertAfter]) and ChildrenOnly); - - if Allowed and (Mode <> amNoWhere) and Assigned(Source) and (Source <> FRoot) and - not (toReadOnly in FOptions.FMiscOptions) then - begin - // Assume that an empty destination means the root in this (the source) tree. - if Target = nil then - begin - TargetTree := Self; - Target := FRoot; - Mode := amAddChildFirst; - end - else - TargetTree := TreeFromNode(Target); - - if Target = TargetTree.FRoot then - begin - case Mode of - amInsertBefore: - Mode := amAddChildFirst; - amInsertAfter: - Mode := amAddChildLast; - end; - end; - - // Make sure the target node is initialized. - if not (vsInitialized in Target.States) then - TargetTree.InitNode(Target) - else - if (vsHasChildren in Target.States) and (Target.ChildCount = 0) then - TargetTree.InitChildren(Target); - - if TargetTree = Self then - begin - // Simple case: move node(s) within the same tree. - if Target = FRoot then - Allowed := DoNodeMoving(Source, nil) - else - Allowed := DoNodeMoving(Source, Target); - if Allowed then - begin - // Check first that Source is not added as new child to a target node which - // is already a child of Source. - // Consider the case Source and Target are the same node, but only child nodes are moved. - if (Source <> Target) and HasAsParent(Target, Source) then - ShowError(SWrongMoveError, hcTFWrongMoveError); - - if not ChildrenOnly then - begin - // Disconnect from old location. - InternalDisconnectNode(Source, True); - // Connect to new location. - InternalConnectNode(Source, Target, Self, Mode); - DoNodeMoved(Source); - end - else - begin - // Only child nodes should be moved. Insertion order depends on move mode. - if Mode = amAddChildFirst then - begin - Source := Source.LastChild; - while Assigned(Source) do - begin - NewNode := Source.PrevSibling; - // Disconnect from old location. - InternalDisconnectNode(Source, True, False); - // Connect to new location. - InternalConnectNode(Source, Target, Self, Mode); - DoNodeMoved(Source); - Source := NewNode; - end; - end - else - begin - Source := Source.FirstChild; - while Assigned(Source) do - begin - NewNode := Source.NextSibling; - // Disconnect from old location. - InternalDisconnectNode(Source, True, False); - // Connect to new location. - InternalConnectNode(Source, Target, Self, Mode); - DoNodeMoved(Source); - Source := NewNode; - end; - end; - end; - end; - end - else - begin - // Difficult case: move node(s) to another tree. - // In opposition to node copying we ask only once if moving is allowed because - // we cannot take back a move once done. - if Target = TargetTree.FRoot then - Allowed := DoNodeMoving(Source, nil) - else - Allowed := DoNodeMoving(Source, Target); - - if Allowed then - begin - Stream := TMemoryStream.Create; - try - // Write all nodes into a temporary stream depending on the ChildrenOnly flag. - if not ChildrenOnly then - WriteNode(Stream, Source) - else - begin - Source := Source.FirstChild; - while Assigned(Source) do - begin - WriteNode(Stream, Source); - Source := Source.NextSibling; - end; - end; - // Now load the serialized nodes into the target node (tree). - TargetTree.BeginUpdate; - try - Stream.Position := 0; - while Stream.Position < Stream.Size do - begin - NewNode := TargetTree.MakeNewNode; - InternalConnectNode(NewNode, Target, TargetTree, Mode); - TargetTree.InternalAddFromStream(Stream, VTTreeStreamVersion, NewNode); - DoNodeMoved(NewNode); - end; - finally - TargetTree.EndUpdate; - end; - finally - Stream.Free; - end; - // finally delete original nodes - BeginUpdate; - try - if ChildrenOnly then - DeleteChildren(Source) - else - DeleteNode(Source); - finally - EndUpdate; - end; - end; - end; - - InvalidateCache; - if (FUpdateCount = 0) and Allowed then - begin - ValidateCache; - UpdateScrollBars(True); - Invalidate; - if TargetTree <> Self then - TargetTree.Invalidate; - end; - StructureChange(Source, crNodeMoved); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.PaintTree(TargetCanvas: TCanvas; Window: TRect; Target: TPoint; - PaintOptions: TVTInternalPaintOptions; PixelFormat: TPixelFormat); - -// This is the core paint routine of the tree. It is responsible for maintaining the paint cycles per node as well -// as coordinating drawing of the various parts of the tree image. -// TargetCanvas is the canvas to which to draw the tree image. This is usually the tree window itself but could well -// be a bitmap or printer canvas. -// Window determines which part of the entire tree image to draw. The full size of the virtual image is determined -// by GetTreeRect. -// Target is the position in TargetCanvas where to draw the tree part specified by Window. -// PaintOptions determines what of the tree to draw. For different tasks usually different parts need to be drawn, with -// a full image in the window, selected only nodes for a drag image etc. - -const - ImageKind: array[Boolean] of TVTImageKind = (ikNormal, ikSelected); - -var - DrawSelectionRect, - UseBackground, - ShowCheckImages, - UseColumns, - IsMainColumn: Boolean; - - IndentSize, - ButtonY: Integer; // Y position of toggle button within the node's rect - LineImage: TLineImage; - PaintInfo: TVTPaintInfo; // all necessary information about a node to pass to the paint routines - - R, // the area of an entire node in its local coordinate - TargetRect, // the area of a node (part) in the target canvas - SelectionRect, // ordered rectangle used for drawing the selection focus rect - ClipRect: TRect; // area to which the canvas will be clipped when painting a node's content - NextColumn: TColumnIndex; - BaseOffset: Integer; // top position of the top node to draw given in absolute tree coordinates - NodeBitmap: TBitmap; // small buffer to draw flicker free - MaximumRight, // maximum horizontal target position - MaximumBottom: Integer; // maximum vertical target position - SelectLevel: Integer; // > 0 if current node is selected or child/grandchild etc. of a selected node - FirstColumn: TColumnIndex; // index of first column which is at least partially visible in the given window - - MaxRight, - ColLeft, - ColRight: Integer; - - SavedTargetDC: Integer; - PaintWidth: Integer; - CurrentNodeHeight: Integer; - lUseSelectedBkColor: Boolean; // determines if the dotted grid lines need to be painted in selection color of background color - - CellIsTouchingClientRight: Boolean; - CellIsInLastColumn: Boolean; - ColumnIsFixed: Boolean; - -begin - if not (tsPainting in FStates) then - begin - DoStateChange([tsPainting]); - try - DoBeforePaint(TargetCanvas); - - if poUnbuffered in PaintOptions then - SavedTargetDC := SaveDC(TargetCanvas.Handle) - else - SavedTargetDC := 0; - - // Prepare paint info structure. - ZeroMemory(@PaintInfo, SizeOf(PaintInfo)); - - PaintWidth := Window.Right - Window.Left; - - if not (poUnbuffered in PaintOptions) then - begin - // Create small bitmaps and initialize default values. - // The bitmaps are used to paint one node at a time and to draw the result to the target (e.g. screen) in one step, - // to prevent flickering. - NodeBitmap := TBitmap.Create; - // For alpha blending we need the 32 bit pixel format. For other targets there might be a need for a certain - // pixel format (e.g. printing). - if ((FDrawSelectionMode = smBlendedRectangle) or (tsUseThemes in FStates) or - (toUseBlendedSelection in FOptions.PaintOptions)) then - NodeBitmap.PixelFormat := pf32Bit - else - NodeBitmap.PixelFormat := PixelFormat; - - NodeBitmap.Width := PaintWidth; - - // Make sure the buffer bitmap and target bitmap use the same transformation mode. - SetMapMode(NodeBitmap.Canvas.Handle, GetMapMode(TargetCanvas.Handle)); - PaintInfo.Canvas := NodeBitmap.Canvas; - end - else - begin - PaintInfo.Canvas := TargetCanvas; - NodeBitmap := nil; - end; - - // Lock the canvas to avoid that it gets freed on the way. - PaintInfo.Canvas.Lock; - try - // Prepare the current selection rectangle once. The corner points are absolute tree coordinates. - SelectionRect := OrderRect(FNewSelRect); - DrawSelectionRect := IsMouseSelecting and not IsRectEmpty(SelectionRect) and (GetKeyState(VK_LBUTTON) < 0); - - // R represents an entire node (all columns), but is a bit unprecise when it comes to - // trees without any column defined, because FRangeX only represents the maximum width of all - // nodes in the client area (not all defined nodes). There might be, however, wider nodes somewhere. Without full - // validation I cannot better determine the width, though. By using at least the control's width it is ensured - // that the tree is fully displayed on screen. - R := Rect(0, 0, Max(FRangeX, ClientWidth), 0); - - // For quick checks some intermediate variables are used. - UseBackground := (toShowBackground in FOptions.FPaintOptions) and Assigned(FBackground.Graphic) and - (poBackground in PaintOptions); - ShowCheckImages := Assigned(FCheckImages) and (toCheckSupport in FOptions.FMiscOptions); - UseColumns := FHeader.UseColumns; - - // Adjust paint options to tree settings. Hide selection if told so or the tree is unfocused. - if (toAlwaysHideSelection in FOptions.FPaintOptions) or - (not Focused and (toHideSelection in FOptions.FPaintOptions)) then - Exclude(PaintOptions, poDrawSelection); - if toHideFocusRect in FOptions.FPaintOptions then - Exclude(PaintOptions, poDrawFocusRect); - - // Determine node to start drawing with. - BaseOffset := 0; - PaintInfo.Node := GetNodeAt(0, Window.Top, False, BaseOffset); - if PaintInfo.Node = nil then - BaseOffset := Window.Top; - - // Transform selection rectangle into node bitmap coordinates. - if DrawSelectionRect then - OffsetRect(SelectionRect, 0, -BaseOffset); - - // The target rectangle holds the coordinates of the exact area to blit in target canvas coordinates. - // It is usually smaller than an entire node and wanders while the paint loop advances. - MaximumRight := Target.X + (Window.Right - Window.Left); - MaximumBottom := Target.Y + (Window.Bottom - Window.Top); - - TargetRect := Rect(Target.X, Target.Y - (Window.Top - BaseOffset), MaximumRight, 0); - TargetRect.Bottom := TargetRect.Top; - TargetCanvas.Font := Self.Font; - - // This marker gets the index of the first column which is visible in the given window. - // This is needed for column based background colors. - FirstColumn := InvalidColumn; - - if Assigned(PaintInfo.Node) then - begin - - // ----- main node paint loop - while Assigned(PaintInfo.Node) do - begin - // Determine LineImage, SelectionLevel and IndentSize - SelectLevel := DetermineLineImageAndSelectLevel(PaintInfo.Node, LineImage); - IndentSize := Length(LineImage); - - // Initialize node if not already done. - if not (vsInitialized in PaintInfo.Node.States) then - InitNode(PaintInfo.Node); - if (vsSelected in PaintInfo.Node.States) and not (toChildrenAbove in FOptions.FPaintOptions) then - Inc(SelectLevel); - - // Ensure the node's height is determined. - MeasureItemHeight(PaintInfo.Canvas, PaintInfo.Node); - - // Adjust the brush origin for dotted lines depending on the current source position. - // It is applied some lines later, as the canvas might get reallocated, when changing the node bitmap. - PaintInfo.BrushOrigin := Point(Window.Left and 1, BaseOffset and 1); - Inc(BaseOffset, PaintInfo.Node.NodeHeight); - - TargetRect.Bottom := TargetRect.Top + PaintInfo.Node.NodeHeight; - - // If poSelectedOnly is active then do the following stuff only for selected nodes or nodes - // which are children of selected nodes. - if (SelectLevel > 0) or not (poSelectedOnly in PaintOptions) then - begin - if not (poUnbuffered in PaintOptions) then - begin - // Adjust height of temporary node bitmap. - with NodeBitmap do - begin - if Height <> PaintInfo.Node.NodeHeight then - begin - // Avoid that the VCL copies the bitmap while changing its height. - Height := 0; - Height := PaintInfo.Node.NodeHeight; - SetCanvasOrigin(Canvas, Window.Left, 0); - end; - end; - end - else - begin - SetCanvasOrigin(PaintInfo.Canvas, -TargetRect.Left + Window.Left, -TargetRect.Top); - ClipCanvas(PaintInfo.Canvas, Rect(0, 0, TargetRect.Right - TargetRect.Left, - Min(TargetRect.Bottom - TargetRect.Top, MaximumBottom - TargetRect.Top))); // See issue #579 - end; - - // Set the origin of the canvas' brush. This depends on the node heights. - with PaintInfo do - SetBrushOrigin(Canvas, BrushOrigin.X, BrushOrigin.Y); - - CurrentNodeHeight := PaintInfo.Node.NodeHeight; - R.Bottom := CurrentNodeHeight; - - // Let application decide whether the node should normally be drawn or by the application itself. - if not DoBeforeItemPaint(PaintInfo.Canvas, PaintInfo.Node, R) then - begin - // Init paint options for the background painting. - PaintInfo.PaintOptions := PaintOptions; - - // The node background can contain a single color, a bitmap or can be drawn by the application. - ClearNodeBackground(PaintInfo, UseBackground, True, Rect(Window.Left, TargetRect.Top, Window.Right, - TargetRect.Bottom)); - - // Prepare column, position and node clipping rectangle. - PaintInfo.CellRect := R; - if UseColumns then - InitializeFirstColumnValues(PaintInfo); - - // Now go through all visible columns (there's still one run if columns aren't used). - with FHeader.FColumns do - begin - while ((PaintInfo.Column > InvalidColumn) or not UseColumns) - and (PaintInfo.CellRect.Left < Window.Right) do - begin - if UseColumns then - begin - PaintInfo.Column := FPositionToIndex[PaintInfo.Position]; - if FirstColumn = InvalidColumn then - FirstColumn := PaintInfo.Column; - PaintInfo.BidiMode := Items[PaintInfo.Column].FBiDiMode; - PaintInfo.Alignment := Items[PaintInfo.Column].FAlignment; - end - else - begin - PaintInfo.Column := NoColumn; - PaintInfo.BidiMode := BidiMode; - PaintInfo.Alignment := FAlignment; - end; - GetOffSets(PaintInfo.Node, PaintInfo.Offsets, TVTElement.ofsText, PaintInfo.Column); - - PaintInfo.PaintOptions := PaintOptions; - with PaintInfo do - begin - if (tsEditing in FStates) and (Node = FFocusedNode) and - ((Column = FEditColumn) or not UseColumns) then - Exclude(PaintOptions, poDrawSelection); - if not UseColumns or - ((vsSelected in Node.States) and (toFullRowSelect in FOptions.FSelectionOptions) and - (poDrawSelection in PaintOptions)) or - (coParentColor in Items[PaintInfo.Column].Options) or - ((coStyleColor in Items[PaintInfo.Column].Options) and VclStyleEnabled) - then - Exclude(PaintOptions, poColumnColor); - end; - IsMainColumn := PaintInfo.Column = FHeader.MainColumn; - - // Consider bidi mode here. In RTL context means left alignment actually right alignment and vice versa. - if PaintInfo.BidiMode <> bdLeftToRight then - ChangeBiDiModeAlignment(PaintInfo.Alignment); - - // Paint the current cell if it is marked as being visible or columns aren't used and - // if this cell belongs to the main column if only the main column should be drawn. - if (not UseColumns or (coVisible in Items[PaintInfo.Column].FOptions)) and - (not (poMainOnly in PaintOptions) or IsMainColumn) then - begin - AdjustPaintCellRect(PaintInfo, NextColumn); - - // Paint the cell only if it is in the current window. - if PaintInfo.CellRect.Right > Window.Left then - begin - with PaintInfo do - begin - // Fill in remaining values in the paint info structure. - NodeWidth := DoGetNodeWidth(Node, Column, Canvas); - - if ShowCheckImages and IsMainColumn then - begin - ImageInfo[iiCheck].Index := GetCheckImage(Node); - ImageInfo[iiCheck].Images := FCheckImages; - ImageInfo[iiCheck].Ghosted := False; - end - else - ImageInfo[iiCheck].Index := -1; - GetImageIndex(PaintInfo, ikState, iiState); - GetImageIndex(PaintInfo, ImageKind[vsSelected in Node.States], iiNormal); - - CalculateVerticalAlignments(PaintInfo, ButtonY); - // Take the space for the tree lines into account. - PaintInfo.AdjustImageCoordinates(); - if UseColumns then - begin - ClipRect := CellRect; - if poUnbuffered in PaintOptions then - begin - ClipRect.Left := Max(ClipRect.Left, Window.Left); - ClipRect.Right := Min(ClipRect.Right, Window.Right); - ClipRect.Top := Max(ClipRect.Top, Window.Top - (BaseOffset - CurrentNodeHeight)); - ClipRect.Bottom := ClipRect.Bottom - Max(TargetRect.Bottom - MaximumBottom, 0); - end; - ClipCanvas(Canvas, ClipRect); - end; - - // Paint the horizontal grid line. - if (poGridLines in PaintOptions) and (toShowHorzGridLines in FOptions.FPaintOptions) then - begin - Canvas.Font.Color := FColors.GridLineColor; - if IsMainColumn and (FLineMode = lmBands) then - begin - if BidiMode = bdLeftToRight then - begin - DrawDottedHLine(PaintInfo, CellRect.Left + IfThen(toFixedIndent in FOptions.FPaintOptions, 1, IndentSize) * Integer(FIndent), CellRect.Right - 1, - CellRect.Bottom - 1); - end - else - begin - DrawDottedHLine(PaintInfo, CellRect.Left, CellRect.Right - IfThen(toFixedIndent in FOptions.FPaintOptions, 1, IndentSize) * Integer(FIndent) - 1, - CellRect.Bottom - 1); - end; - end - else - DrawDottedHLine(PaintInfo, CellRect.Left, CellRect.Right, CellRect.Bottom - 1); - - Dec(CellRect.Bottom); - Dec(ContentRect.Bottom); - end; - - if UseColumns then - begin - // Paint vertical grid line. - if (poGridLines in PaintOptions) and (toShowVertGridLines in FOptions.FPaintOptions) then - begin - // These variables and the nested if conditions shall make the logic - // easier to understand. - CellIsTouchingClientRight := PaintInfo.CellRect.Right = ClientRect.Right; - CellIsInLastColumn := Position = TColumnPosition(Count - 1); - ColumnIsFixed := coFixed in FHeader.FColumns[Column].Options; - - // Don't draw if this is the last column and the header is in autosize mode. - if not ((hoAutoResize in FHeader.FOptions) and CellIsInLastColumn) then - begin - // We have to take spanned cells into account which we determine - // by checking if CellRect.Right equals the Window.Right. - // But since the PaintTree procedure is called twice in - // TBaseVirtualTree.Paint (i.e. for fixed columns and other columns. - // CellIsTouchingClientRight does not work for fixed columns.) - // we have to paint fixed column grid line anyway. - if not CellIsTouchingClientRight or ColumnIsFixed then - begin - if (BidiMode = bdLeftToRight) or not ColumnIsEmpty(Node, Column) then - begin - Canvas.Font.Color := FColors.GridLineColor; - lUseSelectedBkColor := (poDrawSelection in PaintOptions) and (toFullRowSelect in FOptions.FSelectionOptions) and - (vsSelected in Node.States) and not (toUseBlendedSelection in FOptions.PaintOptions) and not - (tsUseExplorerTheme in FStates); - DrawDottedVLine(PaintInfo, CellRect.Top, CellRect.Bottom, CellRect.Right - 1, lUseSelectedBkColor); - end; - - Dec(CellRect.Right); - Dec(ContentRect.Right); - end; - end; - end; - end; - - // Prepare background and focus rect for the current cell. - PrepareCell(PaintInfo, Window.Left, PaintWidth); - - // Some parts are only drawn for the main column. - if IsMainColumn then - begin - if (toShowTreeLines in FOptions.FPaintOptions) and - (not (toHideTreeLinesIfThemed in FOptions.FPaintOptions) or - not (tsUseThemes in FStates)) then - PaintTreeLines(PaintInfo, IfThen(toFixedIndent in FOptions.FPaintOptions, 1, - IndentSize), LineImage); - // Show node button if allowed, if there child nodes and at least one of the child - // nodes is visible or auto button hiding is disabled. - if (toShowButtons in FOptions.FPaintOptions) and (vsHasChildren in Node.States) and - not ((vsAllChildrenHidden in Node.States) and - (toAutoHideButtons in TreeOptions.FAutoOptions)) and - ((toShowRoot in TreeOptions.PaintOptions) or (GetNodeLevel(Node) > 0)) - then - PaintNodeButton(Canvas, Node, Column, CellRect, Offsets[ofsToggleButton], ButtonY, BidiMode); // Relative X position of toggle button is needed for proper BiDi calculation - - if ImageInfo[iiCheck].Index > -1 then - PaintCheckImage(Canvas, PaintInfo.ImageInfo[iiCheck], vsSelected in PaintInfo.Node.States); - end; - - if ImageInfo[iiState].Index > -1 then - PaintImage(PaintInfo, iiState, False); - if ImageInfo[iiNormal].Index > -1 then - PaintImage(PaintInfo, iiNormal, True); - - // Now let descendants or applications draw whatever they want, - // but don't draw the node if it is currently being edited. - if not ((tsEditing in FStates) and (Node = FFocusedNode) and - ((Column = FEditColumn) or not UseColumns)) then - DoPaintNode(PaintInfo); - - DoAfterCellPaint(Canvas, Node, Column, CellRect); - end; - end; - - // leave after first run if columns aren't used - if not UseColumns then - Break; - end - else - NextColumn := GetNextVisibleColumn(PaintInfo.Column); - - SelectClipRgn(PaintInfo.Canvas.Handle, 0); - // Stop column loop if there are no further columns in the given window. - if (PaintInfo.CellRect.Left >= Window.Right) or (NextColumn = InvalidColumn) then - Break; - - // Move on to next column which might not be the one immediately following the current one - // because of auto span feature. - PaintInfo.Position := Items[NextColumn].Position; - - // Move clip rectangle and continue. - if coVisible in Items[NextColumn].FOptions then - with PaintInfo do - begin - Items[NextColumn].GetAbsoluteBounds(CellRect.Left, CellRect.Right); - CellRect.Bottom := Node.NodeHeight; - ContentRect.Bottom := Node.NodeHeight; - end; - end; - end; - - // This node is finished, notify descendants/application. - with PaintInfo do - begin - DoAfterItemPaint(Canvas, Node, R); - - // Final touch for this node: mark it if it is the current drop target node. - if (Node = FDropTargetNode) and (toShowDropmark in FOptions.FPaintOptions) and - (poDrawDropMark in PaintOptions) then - DoPaintDropMark(Canvas, Node, R); - end; - end; // if not DoBeforeItemPaint() (no custom drawing) - - - with PaintInfo.Canvas do - begin - if DrawSelectionRect then - begin - PaintSelectionRectangle(PaintInfo.Canvas, Window.Left, SelectionRect, Rect(0, 0, PaintWidth, - CurrentNodeHeight)); - end; - - // Put the constructed node image onto the target canvas. - if not (poUnbuffered in PaintOptions) then - with TWithSafeRect(TargetRect), NodeBitmap do - BitBlt(TargetCanvas.Handle, Left, Top, Width, Height, Canvas.Handle, Window.Left, 0, SRCCOPY); - end; - end; - - Inc(TargetRect.Top, PaintInfo.Node.NodeHeight); - if TargetRect.Top >= MaximumBottom then - Break; - - // Keep selection rectangle coordinates in sync. - if DrawSelectionRect then - OffsetRect(SelectionRect, 0, -PaintInfo.Node.NodeHeight); - - // Advance to next visible node. - PaintInfo.Node := GetNextVisible(PaintInfo.Node, True); - end; - end; - - // Erase rest of window not covered by a node. - if TargetRect.Top < MaximumBottom then - begin - // Keep the horizontal target position to determine the selection rectangle offset later (if necessary). - BaseOffset := Target.X; - Target := TargetRect.TopLeft; - R := Rect(TargetRect.Left, 0, TargetRect.Left, MaximumBottom - Target.Y); - TargetRect := Rect(0, 0, MaximumRight - Target.X, MaximumBottom - Target.Y); - - if not (poUnbuffered in PaintOptions) then - begin - // Avoid unnecessary copying of bitmap content. This will destroy the DC handle too. - NodeBitmap.Height := 0; - NodeBitmap.PixelFormat := pf32Bit; - NodeBitmap.SetSize(TargetRect.Right - TargetRect.Left, TargetRect.Bottom - TargetRect.Top); - end; - - // Call back application/descendants whether they want to erase this area. - if not DoPaintBackground(PaintInfo.Canvas, TargetRect) then - begin - if UseBackground then - begin - SetCanvasOrigin(PaintInfo.Canvas, 0, 0); - if toStaticBackground in TreeOptions.PaintOptions then - StaticBackground(FBackground, PaintInfo.Canvas, Target, TargetRect, FColors.BackGroundColor) - else - TileBackground(FBackground, PaintInfo.Canvas, Target, TargetRect, FColors.BackGroundColor); - end - else - begin - // Consider here also colors of the columns. - SetCanvasOrigin(PaintInfo.Canvas, Target.X, 0); // This line caused issue #313 when it was placed above the if-statement - if UseColumns then - begin - with FHeader.FColumns do - begin - // If there is no content in the tree then the first column has not yet been determined. - if FirstColumn = InvalidColumn then - begin - FirstColumn := GetFirstVisibleColumn; - repeat - if FirstColumn <> InvalidColumn then - begin - R.Left := Items[FirstColumn].Left; - R.Right := R.Left + Items[FirstColumn].FWidth; - if R.Right > TargetRect.Left then - Break; - FirstColumn := GetNextVisibleColumn(FirstColumn); - end; - until FirstColumn = InvalidColumn; - end - else - begin - R.Left := Items[FirstColumn].Left; - R.Right := R.Left + Items[FirstColumn].FWidth; - end; - - // Initialize MaxRight. - MaxRight := Target.X - 1; - - PaintInfo.Canvas.Font.Color := FColors.GridLineColor; - while (FirstColumn <> InvalidColumn) and (MaxRight < TargetRect.Right + Target.X) do - begin - // Determine left and right coordinate of the current column - ColLeft := Items[FirstColumn].Left; - ColRight := (ColLeft + Items[FirstColumn].FWidth); - - // Check wether this column needs to be painted at all. - if (ColRight >= MaxRight) then - begin - R.Left := MaxRight; // Continue where we left off - R.Right := ColRight; // Paint to the right of the column - MaxRight := ColRight; // And record were to start the next column. - - if (poGridLines in PaintOptions) and - (toFullVertGridLines in FOptions.FPaintOptions) and - (toShowVertGridLines in FOptions.FPaintOptions) and - (not (hoAutoResize in FHeader.FOptions) or (Cardinal(FirstColumn) < TColumnPosition(Count - 1))) then - begin - DrawDottedVLine(PaintInfo, R.Top, R.Bottom, R.Right - 1); - Dec(R.Right); - end; - - if not (coParentColor in Items[FirstColumn].FOptions) then - PaintInfo.Canvas.Brush.Color := Items[FirstColumn].FColor - else - PaintInfo.Canvas.Brush.Color := FColors.BackGroundColor; - PaintInfo.Canvas.FillRect(R); - end; - FirstColumn := GetNextVisibleColumn(FirstColumn); - end; - - // Erase also the part of the tree not covert by a column. - if R.Right < TargetRect.Right + Target.X then - begin - R.Left := R.Right; - R.Right := TargetRect.Right + Target.X; - // Prevent erasing the last vertical grid line. - if (poGridLines in PaintOptions) and - (toFullVertGridLines in FOptions.FPaintOptions) and (toShowVertGridLines in FOptions.FPaintOptions) and - (not (hoAutoResize in FHeader.FOptions)) then - Inc(R.Left); - PaintInfo.Canvas.Brush.Color := FColors.BackGroundColor; - PaintInfo.Canvas.FillRect(R); - end; - end; - SetCanvasOrigin(PaintInfo.Canvas, 0, 0); - end - else - begin - // No columns nor bitmap background. Simply erase it with the tree color. - SetCanvasOrigin(PaintInfo.Canvas, 0, 0); - PaintInfo.Canvas.Brush.Color := FColors.BackGroundColor; - PaintInfo.Canvas.FillRect(TargetRect); - end; - end; - end; - SetCanvasOrigin(PaintInfo.Canvas, 0, 0); - - if DrawSelectionRect then - begin - R := OrderRect(FNewSelRect); - // Remap the selection rectangle to the current window of the tree. - // Since Target has been used for other tasks BaseOffset got the left extent of the target position here. - OffsetRect(R, -Target.X + BaseOffset - Window.Left, -Target.Y + FOffsetY); - SetBrushOrigin(PaintInfo.Canvas, 0, Target.X and 1); - PaintSelectionRectangle(PaintInfo.Canvas, 0, R, TargetRect); - end; - - if not (poUnBuffered in PaintOptions) then - with Target, NodeBitmap do - BitBlt(TargetCanvas.Handle, X, Y, Width, Height, Canvas.Handle, 0, 0, SRCCOPY); - end; - finally - PaintInfo.Canvas.Unlock; - if poUnbuffered in PaintOptions then - RestoreDC(TargetCanvas.Handle, SavedTargetDC) - else - NodeBitmap.Free; - end;//try..finally - - if (FEmptyListMessage <> '') and ((ChildCount[nil] = 0) or (GetFirstVisible = nil)) then - begin - // output a message if no items are to display - Canvas.Font := Self.Font; - SetBkMode(TargetCanvas.Handle, TRANSPARENT); - R.Left := OffSetX + 2; - R.Top := 2; - R.Right := R.Left + Width - 2; - R.Bottom := Height -2; - TargetCanvas.Font.Color := clGrayText; - TargetCanvas.TextRect(R, FEmptyListMessage, [tfNoClip, tfLeft, tfWordBreak, tfExpandTabs]); - end; - - DoAfterPaint(TargetCanvas); - finally - DoStateChange([], [tsPainting]); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.PasteFromClipboard: Boolean; - -// Reads what is currently on the clipboard into the tree (if the format is supported). -// Note: If the application wants to have text or special formats to be inserted then it must implement -// its own code (OLE). Here only the native tree format is accepted. - -var - Data: IDataObject; - Source: TBaseVirtualTree; - -begin - Result := False; - if not (toReadOnly in FOptions.FMiscOptions) then - begin - if OleGetClipboard(Data) <> S_OK then - ShowError(SClipboardFailed, hcTFClipboardFailed) - else - begin - // Try to get the source tree of the operation to optimize the operation. - Source := GetTreeFromDataObject(Data); - Result := ProcessOLEData(Source, Data, FFocusedNode, FDefaultPasteMode, Assigned(Source) and - (tsCutPending in Source.FStates)); - if Assigned(Source) then - begin - if Source <> Self then - Source.FinishCutOrCopy - else - DoStateChange([], [tsCutPending]); - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.PrepareDragImage(HotSpot: TPoint; const DataObject: IDataObject); - -// Initiates an image drag operation. HotSpot is the position of the mouse in client coordinates. - -var - PaintOptions: TVTInternalPaintOptions; - TreeRect, - PaintRect: TRect; - LocalSpot, - ImagePos, - PaintTarget: TPoint; - Image: TBitmap; - -begin - if CanShowDragImage then - begin - // Determine the drag rectangle which is a square around the hot spot. Operate in virtual tree space. - LocalSpot := HotSpot; - Dec(LocalSpot.X, -FEffectiveOffsetX); - Dec(LocalSpot.Y, FOffsetY); - TreeRect := Rect(LocalSpot.X - FDragWidth div 2, LocalSpot.Y - FDragHeight div 2, LocalSpot.X + FDragWidth div 2, - LocalSpot.Y + FDragHeight div 2); - - // Check that we have a valid rectangle. - PaintRect := TreeRect; - with TWithSafeRect(TreeRect) do - begin - if Left < 0 then - begin - PaintTarget.X := -Left; - PaintRect.Left := 0; - end - else - PaintTarget.X := 0; - if Top < 0 then - begin - PaintTarget.Y := -Top; - PaintRect.Top := 0; - end - else - PaintTarget.Y := 0; - end; - - Image := TBitmap.Create; - with Image do - try - PixelFormat := pf32Bit; - SetSize(TreeRect.Right - TreeRect.Left, TreeRect.Bottom - TreeRect.Top); - // Erase the entire image with the color key value, for the case not everything - // in the image is covered by the tree image. - Canvas.Brush.Color := FColors.BackGroundColor; - Canvas.FillRect(Rect(0, 0, Width, Height)); - - PaintOptions := [poDrawSelection, poSelectedOnly]; - if FDragImageKind = diMainColumnOnly then - Include(PaintOptions, poMainOnly); - PaintTree(Image.Canvas, PaintRect, PaintTarget, PaintOptions); - - // Once we have got the drag image we can convert all necessary coordinates into screen space. - OffsetRect(TreeRect, -FEffectiveOffsetX, FOffsetY); - ImagePos := ClientToScreen(TreeRect.TopLeft); - HotSpot := ClientToScreen(HotSpot); - - FDragImage.ColorKey := FColors.BackGroundColor; - FDragImage.PrepareDrag(Image, ImagePos, HotSpot, DataObject); - finally - Image.Free; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.Print(Printer: TPrinter; PrintHeader: Boolean); - -var - SaveTreeFont: TFont; // Remembers the tree's current font. - SaveHeaderFont: TFont; // Remembers the header's current font. - ImgRect, // Describes the dimensions of Image. - TreeRect, // The total VTree dimensions. - DestRect, // Dimensions of PrinterImage. - SrcRect: TRect; // Clip dimensions from Image -> PrinterImage - P: TPoint; // Used by PaintTree. - Options: TVTInternalPaintOptions; // Used by PaintTree. - Image, // Complete Tree is drawn to this image. - PrinterImage: TBitmap; // This is the image that gets printed. - SaveColor: TColor; // Remembers the VTree Color. - pTxtHeight, // Height of font in the TPrinter.Canvas - vTxtHeight, // Height of font in the VTree Canvas - vPageWidth, - vPageHeight, // Printer height in VTree resolution - xPageNum, yPageNum, // # of pages (except the occasional last one) - xPage, yPage: Integer; // Loop counter - Scale: Extended; // Scale factor between Printer Canvas and VTree Canvas - LogFont: TLogFont; - -begin - if Assigned(Printer) then - begin - BeginUpdate; - - // Grid lines are the only parts which are desirable when printing. - Options := [poGridLines]; - - // Remember the tree font. - SaveTreeFont := TFont.Create; - SaveTreeFont.Assign(Font); - // Create a new font for printing which does not use clear type output (but is antialiased, if possible) - // and which has the highest possible quality. - GetObject(Font.Handle, SizeOf(TLogFont), @LogFont); - LogFont.lfQuality := ANTIALIASED_QUALITY; - Font.Handle := CreateFontIndirect(LogFont); - - // Create an image that will hold the complete VTree - Image := TBitmap.Create; - Image.PixelFormat := pf32Bit; - PrinterImage := nil; - try - TreeRect := GetTreeRect; - - Image.Width := TreeRect.Right - TreeRect.Left; - P := Point(0, 0); - if (hoVisible in FHeader.Options) and PrintHeader then - begin - Inc(TreeRect.Bottom, FHeader.Height); - Inc(P.Y, FHeader.Height); - end; - Image.Height := TreeRect.Bottom - TreeRect.Top; - - ImgRect.Left := 0; - ImgRect.Top := 0; - ImgRect.Right := Image.Width; - - // Force the background to white color during the rendering. - SaveColor := FColors.BackGroundColor; - Color := clWhite; - // Print header if it is visible. - if (hoVisible in FHeader.Options) and PrintHeader then - begin - SaveHeaderFont := TFont.Create; - try - SaveHeaderFont.Assign(FHeader.Font); - // Create a new font for printing which does not use clear type output (but is antialiased, if possible) - // and which has the highest possible quality. - GetObject(FHeader.Font.Handle, SizeOf(TLogFont), @LogFont); - LogFont.lfQuality := ANTIALIASED_QUALITY; - FHeader.Font.Handle := CreateFontIndirect(LogFont); - ImgRect.Bottom := FHeader.Height; - FHeader.FColumns.PaintHeader(Image.Canvas.Handle, ImgRect, 0); - FHeader.Font := SaveHeaderFont; - finally - SaveHeaderFont.Free; - end; - end; - // The image's height is already adjusted for the header if it is visible. - ImgRect.Bottom := Image.Height; - - PaintTree(Image.Canvas, ImgRect, P, Options, pf32Bit); - Color := SaveColor; - - // Activate the printer - Printer.BeginDoc; - Printer.Canvas.Font := Font; - - // Now we can calculate the scaling : - pTxtHeight := Printer.Canvas.TextHeight('Tj'); - vTxtHeight := Canvas.TextHeight('Tj'); - - Scale := pTxtHeight / vTxtHeight; - - // Create an Image that has the same dimensions as the printer canvas but - // scaled to the VTree resolution: - PrinterImage := TBitmap.Create; - - vPageHeight := Round(Printer.PageHeight / Scale); - vPageWidth := Round(Printer.PageWidth / Scale); - - // We do a minumum of one page. - xPageNum := Trunc(Image.Width / vPageWidth); - yPageNum := Trunc(Image.Height / vPageHeight); - - PrinterImage.SetSize(vPageWidth, vPageHeight); - - // Split vertically: - for yPage := 0 to yPageNum do - begin - DestRect.Left := 0; - DestRect.Top := 0; - DestRect.Right := PrinterImage.Width; - DestRect.Bottom := PrinterImage.Height; - - // Split horizontally: - for xPage := 0 to xPageNum do - begin - SrcRect.Left := vPageWidth * xPage; - SrcRect.Top := vPageHeight * yPage; - SrcRect.Right := vPageWidth * xPage + PrinterImage.Width; - SrcRect.Bottom := SrcRect.Top + vPageHeight; - - // Clear the image - PrinterImage.Canvas.Brush.Color := clWhite; - PrinterImage.Canvas.FillRect(Rect(0, 0, PrinterImage.Width, PrinterImage.Height)); - PrinterImage.Canvas.CopyRect(DestRect, Image.Canvas, SrcRect); - PrtStretchDrawDIB(Printer.Canvas, Rect(0, 0, Printer.PageWidth, Printer.PageHeight - 1), PrinterImage); - if xPage <> xPageNum then - Printer.NewPage; - end; - if yPage <> yPageNum then - Printer.NewPage; - end; - - // Restore tree font. - Font := SaveTreeFont; - SaveTreeFont.Free; - Printer.EndDoc; - finally - PrinterImage.Free; - Image.Free; - EndUpdate; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.ProcessDrop(const DataObject: IDataObject; TargetNode: PVirtualNode; var Effect: Integer; - Mode: TVTNodeAttachMode): Boolean; - -// Recreates the (sub) tree structure serialized into memory and provided by DataObject. The new nodes are attached to -// the passed node or FRoot if TargetNode is nil. -// Returns True on success, i.e. the CF_VIRTUALTREE format is supported by the data object and the structure could be -// recreated, otherwise False. - -var - Source: TBaseVirtualTree; - -begin - Result := False; - if Mode = amNoWhere then - Effect := DROPEFFECT_NONE - else - begin - BeginUpdate; - // try to get the source tree of the operation - Source := GetTreeFromDataObject(DataObject); - if Assigned(Source) then - Source.BeginUpdate; - try - try - // Before adding the new nodes try to optimize the operation if source and target tree reside in - // the same application and operation is a move. - if ((Effect and DROPEFFECT_MOVE) <> 0) and Assigned(Source) then - begin - // If both copy and move are specified then prefer a copy because this is not destructing. - Result := ProcessOLEData(Source, DataObject, TargetNode, Mode, (Effect and DROPEFFECT_COPY) = 0); - // Since we made an optimized move or a copy there's no reason to act further after DoDragging returns. - Effect := DROPEFFECT_NONE; - end - else - // Act only if move or copy operation is requested. - if (Effect and (DROPEFFECT_MOVE or DROPEFFECT_COPY)) <> 0 then - Result := ProcessOLEData(Source, DataObject, TargetNode, Mode, False) - else - Result := False; - except - Effect := DROPEFFECT_NONE; - end; - finally - if Assigned(Source) then - Source.EndUpdate; - EndUpdate; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -type - // needed to handle OLE global memory objects - TOLEMemoryStream = class(TCustomMemoryStream) - public - function Write(const Buffer; Count: Integer): Integer; override; - end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TOLEMemoryStream.Write(const Buffer; Count: Integer): Integer; - -begin - raise EStreamError.CreateRes(PResStringRec(@SCantWriteResourceStreamError)); -end; - -//----------------- TBaseVirtualTree ----------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoDrawHint(Canvas: TCanvas; Node: PVirtualNode; R: - TRect; Column: TColumnIndex); - -begin - if Assigned(FOnDrawHint) then - FOnDrawHint(Self, Canvas, Node, R, Column); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoGetHintSize(Node: PVirtualNode; Column: - TColumnIndex; var R: TRect); - -begin - if Assigned(FOnGetHintSize) then - FOnGetHintSize(Self, Node, Column, R); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoGetHintKind(Node: PVirtualNode; Column: - TColumnIndex; var Kind: TVTHintKind); - -begin - if Assigned(FOnGetHintKind) then - FOnGetHintKind(Self, Node, Column, Kind) - else - Kind := DefaultHintKind; -end; - -function TBaseVirtualTree.GetDefaultHintKind: TVTHintKind; - -begin - Result := vhkText; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.ProcessOLEData(Source: TBaseVirtualTree; const DataObject: IDataObject; TargetNode: PVirtualNode; - Mode: TVTNodeAttachMode; Optimized: Boolean): Boolean; - -// Recreates the (sub) tree structure serialized into memory and provided by DataObject. The new nodes are attached to -// the passed node or FRoot if TargetNode is nil according to Mode. Optimized can be set to True if the entire operation -// happens within the same process (i.e. sender and receiver of the OLE operation are located in the same process). -// Optimize = True makes only sense if the operation to carry out is a move hence it is also the indication of the -// operation to be done here. Source is the source of the OLE data and only of use (and usually assigned) when -// an OLE operation takes place in the same application. -// Returns True on success, i.e. the CF_VIRTUALTREE format is supported by the data object and the structure could be -// recreated, otherwise False. - -var - Medium: TStgMedium; - Stream: TStream; - Data: Pointer; - Node: PVirtualNode; - Nodes: TNodeArray; - I: Integer; - Res: HRESULT; - ChangeReason: TChangeReason; - -begin - Nodes := nil; - // Check the data format available by the data object. - with StandardOLEFormat do - begin - // Read best format. - cfFormat := CF_VIRTUALTREE; - end; - Result := DataObject.QueryGetData(StandardOLEFormat) = S_OK; - if Result and not (toReadOnly in FOptions.FMiscOptions) then - begin - BeginUpdate; - Result := False; - try - if TargetNode = nil then - TargetNode := FRoot; - if TargetNode = FRoot then - begin - case Mode of - amInsertBefore: - Mode := amAddChildFirst; - amInsertAfter: - Mode := amAddChildLast; - end; - end; - - // Optimized means source is known and in the same process so we can access its pointers, which avoids duplicating - // the data while doing a serialization. Can only be used with cut'n paste and drag'n drop with move effect. - if Optimized then - begin - if tsOLEDragging in Source.FStates then - Nodes := Source.FDragSelection - else - Nodes := Source.GetSortedCutCopySet(True); - - if Mode in [amInsertBefore,amAddChildLast] then - begin - for I := 0 to High(Nodes) do - if not HasAsParent(TargetNode, Nodes[I]) then - Source.MoveTo(Nodes[I], TargetNode, Mode, False); - end - else - begin - for I := High(Nodes) downto 0 do - if not HasAsParent(TargetNode, Nodes[I]) then - Source.MoveTo(Nodes[I], TargetNode, Mode, False); - end; - Result := True; - end - else - begin - if Source = Self then - ChangeReason := crNodeCopied - else - ChangeReason := crNodeAdded; - Res := DataObject.GetData(StandardOLEFormat, Medium); - if Res = S_OK then - begin - case Medium.tymed of - TYMED_ISTREAM, // IStream interface - TYMED_HGLOBAL: // global memory block - begin - Stream := nil; - if Medium.tymed = TYMED_ISTREAM then - Stream := TOLEStream.Create(IUnknown(Medium.stm) as IStream) - else - begin - Data := GlobalLock(Medium.hGlobal); - if Assigned(Data) then - begin - // Get the total size of data to retrieve. - I := PCardinal(Data)^; - Inc(PCardinal(Data)); - Stream := TOLEMemoryStream.Create; - TOLEMemoryStream(Stream).SetPointer(Data, I); - end; - end; - - if Assigned(Stream) then - try - while Stream.Position < Stream.Size do - begin - Node := MakeNewNode; - InternalConnectNode(Node, TargetNode, Self, Mode); - InternalAddFromStream(Stream, VTTreeStreamVersion, Node); - // This seems a bit strange because of the callback for granting to add the node - // which actually comes after the node has been added. The reason is that the node must - // contain valid data otherwise I don't see how the application can make a funded decision. - if not DoNodeCopying(Node, TargetNode) then - begin - DeleteNode(Node); - end - else - begin - DoNodeCopied(Node); - StructureChange(Node, ChangeReason); - // In order to maintain the same node order when restoring nodes in the case of amInsertAfter - // we have to move the reference node continously. Othwise we would end up with reversed node order. - if Mode = amInsertAfter then - TargetNode := Node; - end; - end; - Result := True; - finally - Stream.Free; - if Medium.tymed = TYMED_HGLOBAL then - GlobalUnlock(Medium.hGlobal); - end; - end; - end; - ReleaseStgMedium(Medium); - end; - end; - finally - EndUpdate; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.ReinitChildren(Node: PVirtualNode; Recursive: Boolean); - -// Forces all child nodes of Node to be reinitialized. -// If Recursive is True then also the grandchildren are reinitialized. - -var - Run: PVirtualNode; - -begin - if Assigned(Node) then - begin - InitChildren(Node); - Run := Node.FirstChild; - end - else - begin - InitChildren(FRoot); - Run := FRoot.FirstChild; - end; - - while Assigned(Run) do - begin - ReinitNode(Run, Recursive); - Run := Run.NextSibling; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.ReinitNode(Node: PVirtualNode; Recursive: Boolean); - -// Forces the given node and all its children (if recursive is True) to be initialized again without -// modifying any data in the nodes nor deleting children (unless the application requests a different amount). - -begin - if Assigned(Node) and (Node <> FRoot) then - begin - // Remove dynamic styles. - Node.States := Node.States - [vsChecking, vsCutOrCopy, vsDeleting, vsHeightMeasured]; - if vsInitialized in Node.States then - InitNode(Node); - end; - - if Recursive then - ReinitChildren(Node, True); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.RepaintNode(Node: PVirtualNode); - -// Causes an immediate repaint of the given node. - -var - R: Trect; - -begin - if Assigned(Node) and (Node <> FRoot) then - begin - R := GetDisplayRect(Node, NoColumn, False); - RedrawWindow(Handle, @R, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE or RDW_VALIDATE or RDW_NOCHILDREN); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.ResetNode(Node: PVirtualNode); - -// Deletes all children of the given node and marks it as being uninitialized. - -begin - DoCancelEdit; - if (Node = nil) or (Node = FRoot) then - Clear - else - begin - DoReset(Node); - DeleteChildren(Node); - // Remove initialized and other dynamic styles, keep persistent styles. - Node.States := Node.States - [vsInitialized, vsChecking, vsCutOrCopy, vsDeleting, vsHasChildren, vsExpanded, - vsHeightMeasured]; - InvalidateNode(Node); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SaveToFile(const FileName: TFileName); - -// Saves the entire content of the tree into a file (see further notes in SaveToStream). - -var - FileStream: TFileStream; - -begin - FileStream := TFileStream.Create(FileName, fmCreate); - try - SaveToStream(FileStream); - finally - FileStream.Free; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SaveToStream(Stream: TStream; Node: PVirtualNode = nil); - -// Saves Node and all its children to Stream. If Node is nil then all top level nodes will be stored. -// Note: You should be careful about assuming what is actually saved. The problem here is that we are dealing with -// virtual data. The tree can so not know what it has to save. The only fact we reliably know is the tree's -// structure. To be flexible for future enhancements as well as unknown content (unknown to the tree class which -// is saving/loading the stream) a chunk based approach is used here. Every tree class handles only those -// chunks which are not handled by an anchestor class and are known by the class. -// -// The base tree class saves only the structure of the tree along with application provided data. descendants may -// optionally add their own chunks to store additional information. See: WriteChunks. - -var - Count: Cardinal; - -begin - Stream.Write(MagicID, SizeOf(MagicID)); - if Node = nil then - begin - // Keep number of top level nodes for easy restauration. - Count := FRoot.ChildCount; - Stream.WriteBuffer(Count, SizeOf(Count)); - - // Save entire tree here. - Node := FRoot.FirstChild; - while Assigned(Node) do - begin - WriteNode(Stream, Node); - Node := Node.NextSibling; - end; - end - else - begin - Count := 1; - Stream.WriteBuffer(Count, SizeOf(Count)); - WriteNode(Stream, Node); - end; - if Assigned(FOnSaveTree) then - FOnSaveTree(Self, Stream); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.ScrollIntoView(Node: PVirtualNode; Center: Boolean; Horizontally: Boolean = False): Boolean; - -// Scrolls the tree so that the given node is in the client area and returns True if the tree really has been -// scrolled (e.g. to avoid further updates) else returns False. If extened focus is enabled then the tree will also -// be horizontally scrolled if needed. -// Note: All collapsed parents of the node are expanded. - -var - R: TRect; - Run: PVirtualNode; - UseColumns, - HScrollBarVisible: Boolean; - ScrolledVertically, - ScrolledHorizontally: Boolean; - -begin - ScrolledVertically := False; - ScrolledHorizontally := False; - - if Assigned(Node) and (Node <> FRoot) and HandleAllocated then // We don't want to create the handle if it has not yet been created, see issue #897 - begin - // Make sure all parents of the node are expanded. - Run := Node.Parent; - while Run <> FRoot do - begin - if not (vsExpanded in Run.States) then - ToggleNode(Run); - Run := Run.Parent; - end; - UseColumns := FHeader.UseColumns; - if UseColumns and FHeader.FColumns.IsValidColumn(FFocusedColumn) then - R := GetDisplayRect(Node, FFocusedColumn, not (toGridExtensions in FOptions.FMiscOptions)) - else - R := GetDisplayRect(Node, NoColumn, not (toGridExtensions in FOptions.FMiscOptions)); - - // The returned rectangle can never be empty after the expand code above. - // 1) scroll vertically - if R.Top < 0 then - begin - if Center then - SetOffsetY(FOffsetY - R.Top + ClientHeight div 2) - else - SetOffsetY(FOffsetY - R.Top); - ScrolledVertically := True; - end - else - if (R.Bottom > ClientHeight) or Center then - begin - HScrollBarVisible := (ScrollBarOptions.ScrollBars in [System.UITypes.TScrollStyle.ssBoth, System.UITypes.TScrollStyle.ssHorizontal]) and - (ScrollBarOptions.AlwaysVisible or (Integer(FRangeX) > ClientWidth)); - if Center then - SetOffsetY(FOffsetY - R.Bottom + ClientHeight div 2) - else - SetOffsetY(FOffsetY - R.Bottom + ClientHeight); - // When scrolling up and the horizontal scroll appears because of the operation - // then we have to move up the node the horizontal scrollbar's height too - // in order to avoid that the scroll bar hides the node which we wanted to have in view. - if not UseColumns and not HScrollBarVisible and (Integer(FRangeX) > ClientWidth) then - SetOffsetY(FOffsetY - GetSystemMetrics(SM_CYHSCROLL)); - ScrolledVertically := True; - end; - - if Horizontally then - // 2) scroll horizontally - // Center only if there is enough space for the focused column, otherwise left align, see issue #397. - ScrolledHorizontally := ScrollIntoView(FFocusedColumn, Center and (R.Width <= (ClientWidth - Header.Columns.GetVisibleFixedWidth)), Node); - end; - - Result := ScrolledVertically or ScrolledHorizontally; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.ScaledPixels(pPixels: Integer): Integer; - - /// Returns the given pixels scaled to the current dpi assuming that we designed at 96dpi (100%) -begin - Result := MulDiv(pPixels, {$if CompilerVersion > 31}Self.FCurrentPPI{$else}Screen.PixelsPerInch{$ifend}, 96); -end; - -function TBaseVirtualTree.ScrollIntoView(Column: TColumnIndex; Center: Boolean; Node: PVirtualNode = nil): Boolean; - -// Scrolls the columns so that the given column is in the client area and returns True if the columns really have been -// scrolled (e.g. to avoid further updates) else returns False. - -var - ColumnLeft, - ColumnRight: Integer; - NewOffset: Integer; - R: TRect; - -begin - Result := False; - - if FHeader.UseColumns and FHeader.Columns.IsValidColumn(Column) then begin - ColumnLeft := Header.Columns.Items[Column].Left; - ColumnRight := ColumnLeft + Header.Columns.Items[Column].Width; - end else if Assigned(Node) and (toCenterScrollIntoView in FOptions.SelectionOptions) then begin - Center := False; - R := GetDisplayRect(Node, NoColumn, not (toGridExtensions in FOptions.FMiscOptions)); - ColumnLeft := R.Left; - ColumnRight := R.Right; - end else - Exit; - - NewOffset := FEffectiveOffsetX; - if not (FHeader.UseColumns and (coFixed in Header.Columns[Column].Options)) and (not Center) then - begin - if ColumnRight > ClientWidth then - NewOffset := FEffectiveOffsetX + Min(ColumnRight - ClientWidth, - - (Header.Columns.GetVisibleFixedWidth - ColumnLeft)) - else if ColumnLeft < Header.Columns.GetVisibleFixedWidth then - NewOffset := FEffectiveOffsetX - (Header.Columns.GetVisibleFixedWidth - ColumnLeft); - if NewOffset <> FEffectiveOffsetX then - begin - if UseRightToLeftAlignment then - SetOffsetX(-Integer(FRangeX) + ClientWidth + NewOffset) - else - SetOffsetX(-NewOffset); - end; - Result := True; - end - else if Center then - begin - NewOffset := FEffectiveOffsetX + ColumnLeft - (Header.Columns.GetVisibleFixedWidth div 2) - (ClientWidth div 2) + ((ColumnRight - ColumnLeft) div 2); - if NewOffset <> FEffectiveOffsetX then - begin - if UseRightToLeftAlignment then - SetOffsetX(-Integer(FRangeX) + ClientWidth + NewOffset) - else - SetOffsetX(-NewOffset); - end; - Result := True; - end -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SelectAll(VisibleOnly: Boolean); - -// Select all nodes in the tree. -// If VisibleOnly is True then only visible nodes are selected. - -var - Run: PVirtualNode; - NextFunction: TGetNextNodeProc; -begin - if not FSelectionLocked and (toMultiSelect in FOptions.FSelectionOptions) then - begin - ClearTempCache; - if VisibleOnly then - begin - Run := GetFirstVisible(nil, True); - NextFunction := GetNextVisible; - end - else - begin - Run := GetFirst; - NextFunction := GetNext; - end; - BeginUpdate(); // Improve performance, see issue #690 - try - while Assigned(Run) do - begin - if not(vsSelected in Run.States) then - InternalCacheNode(Run); - Run := NextFunction(Run); - end;//while - if FTempNodeCount > 0 then - AddToSelection(FTempNodeCache, FTempNodeCount); - ClearTempCache; - finally - EndUpdate(); - end;//try..finally - Invalidate; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.Sort(Node: PVirtualNode; Column: TColumnIndex; Direction: TSortDirection; DoInit: Boolean = True); - -// Sorts the given node. The application is queried about how to sort via the OnCompareNodes event. -// Column is simply passed to the the compare function so the application can also sort in a particular column. -// In order to free the application from taking care about the sort direction the parameter Direction is used. -// This way the application can always sort in increasing order, while this method reorders nodes according to this flag. - - //--------------- local functions ------------------------------------------- - - function MergeAscending(A, B: PVirtualNode): PVirtualNode; - - // Merges A and B (which both must be sorted via Compare) into one list. - - var - Dummy: TVirtualNode; - CompareResult: Integer; - begin - // This avoids checking for Result = nil in the loops. - Result := @Dummy; - while Assigned(A) and Assigned(B) do - begin - if OperationCanceled then - CompareResult := 0 - else - CompareResult := DoCompare(A, B, Column); - - if CompareResult <= 0 then - begin - Result.NextSibling := A; - Result := A; - A := A.NextSibling; - end - else - begin - Result.NextSibling := B; - Result := B; - B := B.NextSibling; - end; - end; - - // Just append the list which is not nil (or set end of result list to nil if both lists are nil). - if Assigned(A) then - Result.NextSibling := A - else - Result.NextSibling := B; - // return start of the new merged list - Result := Dummy.NextSibling; - end; - - //--------------------------------------------------------------------------- - - function MergeDescending(A, B: PVirtualNode): PVirtualNode; - - // Merges A and B (which both must be sorted via Compare) into one list. - - var - Dummy: TVirtualNode; - CompareResult: Integer; - - begin - // this avoids checking for Result = nil in the loops - Result := @Dummy; - while Assigned(A) and Assigned(B) do - begin - if OperationCanceled then - CompareResult := 0 - else - CompareResult := DoCompare(A, B, Column); - - if CompareResult >= 0 then - begin - Result.NextSibling := A; - Result := A; - A := A.NextSibling; - end - else - begin - Result.NextSibling := B; - Result := B; - B := B.NextSibling; - end; - end; - - // Just append the list which is not nil (or set end of result list to nil if both lists are nil). - if Assigned(A) then - Result.NextSibling := A - else - Result.NextSibling := B; - // Return start of the newly merged list. - Result := Dummy.NextSibling; - end; - - //--------------------------------------------------------------------------- - - function MergeSortAscending(var Node: PVirtualNode; N: Cardinal): PVirtualNode; - - // Sorts the list of nodes given by Node (which must not be nil). - - var - A, B: PVirtualNode; - - begin - if N > 1 then - begin - A := MergeSortAscending(Node, N div 2); - B := MergeSortAscending(Node, (N + 1) div 2); - Result := MergeAscending(A, B); - end - else - begin - Result := Node; - Node := Node.NextSibling; - Result.NextSibling := nil; - end; - end; - - //--------------------------------------------------------------------------- - - function MergeSortDescending(var Node: PVirtualNode; N: Cardinal): PVirtualNode; - - // Sorts the list of nodes given by Node (which must not be nil). - - var - A, B: PVirtualNode; - - begin - if N > 1 then - begin - A := MergeSortDescending(Node, N div 2); - B := MergeSortDescending(Node, (N + 1) div 2); - Result := MergeDescending(A, B); - end - else - begin - Result := Node; - Node := Node.NextSibling; - Result.NextSibling := nil; - end; - end; - - //--------------- end local functions --------------------------------------- - -var - Run: PVirtualNode; - Index: Cardinal; - -begin - InterruptValidation; - if tsEditPending in FStates then - begin - StopTimer(EditTimer); - DoStateChange([], [tsEditPending]); - end; - - if not (tsEditing in FStates) or DoEndEdit then - begin - if Node = nil then - Node := FRoot; - if vsHasChildren in Node.States then - begin - if (Node.ChildCount = 0) and DoInit then - InitChildren(Node); - // Make sure the children are valid, so they can be sorted at all. - if DoInit and (Node.ChildCount > 0) then - ValidateChildren(Node, False); - // Child count might have changed. - if Node.ChildCount > 1 then - begin - StartOperation(okSortNode); - try - // Sort the linked list, check direction flag only once. - if Direction = sdAscending then - Node.FirstChild := MergeSortAscending(Node.FirstChild, Node.ChildCount) - else - Node.FirstChild := MergeSortDescending(Node.FirstChild, Node.ChildCount); - finally - EndOperation(okSortNode); - end; - // Consolidate the child list finally. - Run := Node.FirstChild; - Run.PrevSibling := nil; - Index := 0; - repeat - Run.Index := Index; - Inc(Index); - if Run.NextSibling = nil then - Break; - Run.NextSibling.PrevSibling := Run; - Run := Run.NextSibling; - until False; - Node.LastChild := Run; - - InvalidateCache; - end; - if FUpdateCount = 0 then - begin - ValidateCache; - Invalidate; - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SortTree(Column: TColumnIndex; Direction: TSortDirection; DoInit: Boolean = True); - - //--------------- local function -------------------------------------------- - - procedure DoSort(Node: PVirtualNode); - - // Recursively sorts Node and its child nodes. - - var - Run: PVirtualNode; - - begin - Sort(Node, Column, Direction, DoInit); - // Recurse to next level - Run := Node.FirstChild; - while Assigned(Run) and not FOperationCanceled do - begin - if DoInit and not (vsInitialized in Run.States) then - InitNode(Run); - if (vsInitialized in Run.States) and (not (toAutoSort in TreeOptions.AutoOptions) or Expanded[Run]) then // There is no need to sort collapsed branches - DoSort(Run); - Run := Run.NextSibling; - end; - end; - - //--------------- end local function ---------------------------------------- - -begin - if RootNode.TotalCount <= 2 then - Exit;//Nothing to do if there are one or zero nodes. RootNode.TotalCount is 1 if there are no nodes in the treee as the root node counts too here. - // Instead of wrapping the sort using BeginUpdate/EndUpdate simply the update counter - // is modified. Otherwise the EndUpdate call will recurse here. - Inc(FUpdateCount); - try - if Column > InvalidColumn then - begin - StartOperation(okSortTree); - try - DoSort(FRoot); - finally - EndOperation(okSortTree); - end; - end; - InvalidateCache; - finally - if FUpdateCount > 0 then - Dec(FUpdateCount); - if FUpdateCount = 0 then - begin - ValidateCache; - Invalidate; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.ToggleNode(Node: PVirtualNode); - -// Changes a node's expand state to the opposite state. - -var - Child, - FirstVisible: PVirtualNode; - HeightDelta, - StepsR1, - StepsR2, - Steps: Integer; - TogglingTree, - ChildrenInView, - NeedFullInvalidate, - NeedUpdate, - NodeInView, - PosHoldable, - TotalFit: Boolean; - ToggleData: TToggleAnimationData; - - //--------------- local function -------------------------------------------- - - procedure PrepareAnimation; - - // Prepares ToggleData. - - var - R: TRect; - S: Integer; - M: TToggleAnimationMode; - - begin - with ToggleData do - begin - Window := Handle; - DC := GetDC(Handle); - - if (toShowBackground in FOptions.FPaintOptions) and Assigned(FBackground.Graphic) then - Self.Brush.Style := bsClear - else - begin - Self.Brush.Style := bsSolid; - Self.Brush.Color := FColors.BackGroundColor; - end; - - Brush := Self.Brush.Handle; - - if (Mode1 <> tamNoScroll) and (Mode2 <> tamNoScroll) then - begin - if StepsR1 < StepsR2 then - begin - // As the primary rectangle is always R1 we will get a much smoother - // animation if R1 is the one that will be scrolled more. - R := R2; - R2 := R1; - R1 := R; - - M := Mode2; - Mode2 := Mode1; - Mode1 := M; - - S := StepsR2; - StepsR2 := StepsR1; - StepsR1 := S; - end; - ScaleFactor := StepsR2 / StepsR1; - MissedSteps := 0; - end; - - if Mode1 <> tamNoScroll then - Steps := StepsR1 - else - Steps := StepsR2; - end; - end; - - //--------------- end local function ---------------------------------------- - -begin - Assert(Assigned(Node), 'Node must not be nil.'); - - TogglingTree := tsToggling in FStates; - ChildrenInView := False; - HeightDelta := 0; - NeedFullInvalidate := False; - NeedUpdate := False; - NodeInView := False; - PosHoldable := False; - TotalFit := False; - - // We don't need to switch the expand state if the node is being deleted otherwise some - // updates (e.g. visible node count) are done twice with disasterous results). - if [vsDeleting, vsToggling] * Node.States = [] then - begin - try - DoStateChange([tsToggling]); - Include(Node.States, vsToggling); - - if vsExpanded in Node.States then - begin - if DoCollapsing(Node) then - begin - NeedUpdate := True; - - // Calculate the height delta right now as we need it for toChildrenAbove anyway. - HeightDelta := -Integer(Node.TotalHeight) + Integer(NodeHeight[Node]); - if (FUpdateCount = 0) and (toAnimatedToggle in FOptions.FAnimationOptions) and not - (tsCollapsing in FStates) then - begin - if tsHint in Self.FStates then - Application.CancelHint; - UpdateWindow(Handle); - - // animated collapsing - with ToggleData do - begin - // Determine the animation behaviour and rectangle. If toChildrenAbove is set, the behaviour is depending - // on the position of the node to be collapsed. - R1 := GetDisplayRect(Node, NoColumn, False); - Mode2 := tamNoScroll; - if toChildrenAbove in FOptions.FPaintOptions then - begin - PosHoldable := (FOffsetY + (Integer(Node.TotalHeight) - Integer(NodeHeight[Node]))) <= 0; - NodeInView := R1.Top < ClientHeight; - - StepsR1 := 0; - if NodeInView then - begin - if PosHoldable or not (toAdvancedAnimatedToggle in FOptions.FAnimationOptions) then - begin - // Scroll the child nodes down. - Mode1 := tamScrollDown; - R1.Bottom := R1.Top; - R1.Top := 0; - StepsR1 := Min(R1.Bottom - R1.Top + 1, Integer(Node.TotalHeight) - Integer(NodeHeight[Node])); - end - else - begin - // The position cannot be kept. So scroll the node up to its future position. - Mode1 := tamScrollUp; - R1.Top := Max(0, R1.Top + HeightDelta); - R1.Bottom := ClientHeight; - StepsR1 := FOffsetY - HeightDelta; - end; - end; - end - else - begin - if (Integer(FRangeY) + FOffsetY - R1.Bottom + HeightDelta >= ClientHeight - R1.Bottom) or - (Integer(FRangeY) <= ClientHeight) or (FOffsetY = 0) or not - (toAdvancedAnimatedToggle in FOptions.FAnimationOptions) then - begin - // Do a simple scroll up over the child nodes. - Mode1 := tamScrollUp; - Inc(R1.Top, NodeHeight[Node]); - R1.Bottom := ClientHeight; - StepsR1 := Min(R1.Bottom - R1.Top + 1, -HeightDelta); - end - else - begin - // Scroll the node down to its future position. As FOffsetY will change we need to invalidate the - // whole tree. - Mode1 := tamScrollDown; - StepsR1 := Min(-FOffsetY, ClientHeight - Integer(FRangeY) -FOffsetY - HeightDelta); - R1.Top := 0; - R1.Bottom := Min(ClientHeight, R1.Bottom + Steps); - NeedFullInvalidate := True; - end; - end; - - // No animation necessary if the node is below the current client height. - if R1.Top < ClientHeight then - begin - PrepareAnimation; - try - Animate(Steps, FAnimationDuration, ToggleCallback, @ToggleData); - finally - ReleaseDC(Window, DC); - end; - end; - end; - end; - - // collapse the node - AdjustTotalHeight(Node, IfThen(IsEffectivelyFiltered[Node], 0, NodeHeight[Node])); - if FullyVisible[Node] then - Dec(FVisibleCount, CountVisibleChildren(Node)); - Exclude(Node.States, vsExpanded); - DoCollapsed(Node); - - // Remove child nodes now, if enabled. - if (toAutoFreeOnCollapse in FOptions.FAutoOptions) and (Node.ChildCount > 0) then - begin - DeleteChildren(Node); - Include(Node.States, vsHasChildren); - end; - end; - end - else - if DoExpanding(Node) then - begin - NeedUpdate := True; - // expand the node, need to adjust the height - if not (vsInitialized in Node.States) then - InitNode(Node); - if (vsHasChildren in Node.States) and (Node.ChildCount = 0) then - InitChildren(Node); - - // Avoid setting the vsExpanded style if there are no child nodes. - if Node.ChildCount > 0 then - begin - // Iterate through the child nodes without initializing them. We have to determine the entire height. - Child := Node.FirstChild; - repeat - if vsVisible in Child.States then - begin - // Ensure the item height is measured - MeasureItemHeight(Canvas, Child); - - Inc(HeightDelta, Child.TotalHeight); - end; - Child := Child.NextSibling; - until Child = nil; - - // Getting the display rectangle is already done here as it is needed for toChildrenAbove in any case. - if (toChildrenAbove in FOptions.FPaintOptions) or (FUpdateCount = 0) then - begin - with ToggleData do - begin - R1 := GetDisplayRect(Node, NoColumn, False); - Mode2 := tamNoScroll; - TotalFit := HeightDelta + Integer(NodeHeight[Node]) <= ClientHeight; - - if toChildrenAbove in FOptions.FPaintOptions then - begin - // The main goal with toChildrenAbove being set is to keep the nodes visual position so the user does - // not get confused. Therefore we need to scroll the view when the expanding is done. - PosHoldable := TotalFit and (Integer(FRangeY) - ClientHeight >= 0) ; - ChildrenInView := (R1.Top - HeightDelta) >= 0; - NodeInView := R1.Bottom <= ClientHeight; - end - else - begin - PosHoldable := TotalFit; - ChildrenInView := R1.Bottom + HeightDelta <= ClientHeight; - end; - - R1.Bottom := ClientHeight; - end; - end; - - if FUpdateCount = 0 then - begin - // Do animated expanding if enabled. - if (ToggleData.R1.Top < ClientHeight) and ([tsPainting, tsExpanding] * FStates = []) and - (toAnimatedToggle in FOptions.FAnimationOptions)then - begin - if tsHint in Self.FStates then - Application.CancelHint; - UpdateWindow(Handle); - // animated expanding - with ToggleData do - begin - if toChildrenAbove in FOptions.FPaintOptions then - begin - // At first check if we hold the position, which is the most common case. - if not (toAdvancedAnimatedToggle in FOptions.FAnimationOptions) or - (PosHoldable and ( (NodeInView and ChildrenInView) or not - (toAutoScrollOnExpand in FOptions.FAutoOptions) )) then - begin - Mode1 := tamScrollUp; - R1 := Rect(R1.Left, 0, R1.Right, R1.Top); - StepsR1 := Min(HeightDelta, R1.Bottom); - end - else - begin - // If we will not hold the node's visual position we mostly scroll in both directions. - Mode1 := tamScrollDown; - Mode2 := tamScrollUp; - R2 := Rect(R1.Left, 0, R1.Right, R1.Top); - if not (toAutoScrollOnExpand in FOptions.FAutoOptions) then - begin - // If we shall not or cannot scroll to the desired extent we calculate the new position (with - // max FOffsetY applied) and animate it that way. - StepsR1 := -FOffsetY - Max(Integer(FRangeY) + HeightDelta - ClientHeight, 0) + HeightDelta; - if (Integer(FRangeY) + HeightDelta - ClientHeight) <= 0 then - Mode2 := tamNoScroll - else - StepsR2 := Min(Integer(FRangeY) + HeightDelta - ClientHeight, R2.Bottom); - end - else - begin - if TotalFit and NodeInView and (Integer(FRangeY) + HeightDelta > ClientHeight) then - begin - // If the whole subtree will fit into the client area and the node is currently fully visible, - // the first child will be made the top node if possible. - if HeightDelta >= R1.Top then - StepsR1 := Abs(R1.Top - HeightDelta) - else - StepsR1 := ClientHeight - Integer(FRangeY); - end - else - if Integer(FRangeY) + HeightDelta <= ClientHeight then - begin - // We cannot make the first child the top node as we cannot scroll to that extent, - // so we do a simple scroll down. - Mode2 := tamNoScroll; - StepsR1 := HeightDelta; - end - else - // If the subtree does not fit into the client area at once, the expanded node will - // be made the bottom node. - StepsR1 := ClientHeight - R1.Top - Integer(NodeHeight[Node]); - - if Mode2 <> tamNoScroll then - begin - if StepsR1 > 0 then - StepsR2 := Min(R1.Top, HeightDelta - StepsR1) - else - begin - // If the node is already at the bottom scrolling is needed. - Mode1 := tamNoScroll; - StepsR2 := Min(HeightDelta, R1.Bottom); - end; - end; - end; - end; - end - else - begin - // toChildrenAbove is not set. - if (PosHoldable and ChildrenInView) or not (toAutoScrollOnExpand in FOptions.FAutoOptions) or not - (toAdvancedAnimatedToggle in FOptions.FAnimationOptions) or (R1.Top <= 0) then - begin - // If the node will stay at its visual position, do a simple down-scroll. - Mode1 := tamScrollDown; - Inc(R1.Top, NodeHeight[Node]); - StepsR1 := Min(R1.Bottom - R1.Top, HeightDelta); - end - else - begin - // We will not hold the nodes visual position so perform a double scroll. - Mode1 := tamScrollUp; - Mode2 := tamScrollDown; - - R1.Bottom := R1.Top + Integer(NodeHeight[Node]) + 1; - R1.Top := 0; - R2 := Rect(R1.Left, R1.Bottom, R1.Right, ClientHeight); - - StepsR1 := Min(HeightDelta - (ClientHeight - R2.Top), R1.Bottom - Integer(NodeHeight[Node])); - StepsR2 := ClientHeight - R2.Top; - end; - end; - - if ClientHeight >= R1.Top then - begin - PrepareAnimation; - try - Animate(Steps, FAnimationDuration, ToggleCallback, @ToggleData); - finally - ReleaseDC(Window, DC); - end; - end; - end; - end; - if toAutoSort in FOptions.FAutoOptions then - Sort(Node, FHeader.FSortColumn, FHeader.FSortDirection, False); - end;// if UpdateCount = 0 - - Include(Node.States, vsExpanded); - AdjustTotalHeight(Node, HeightDelta, True); - if FullyVisible[Node] then - Inc(FVisibleCount, CountVisibleChildren(Node)); - - DoExpanded(Node); - end; - end; - - if NeedUpdate then - begin - InvalidateCache; - if FUpdateCount = 0 then - begin - ValidateCache; - if Node.ChildCount > 0 then - begin - UpdateRanges; - UpdateScrollBars(True); - if [tsPainting, tsExpanding] * FStates = [] then - begin - if (vsExpanded in Node.States) and ((toAutoScrollOnExpand in FOptions.FAutoOptions) or - (toChildrenAbove in FOptions.FPaintOptions)) then - begin - if toChildrenAbove in FOptions.FPaintOptions then - begin - NeedFullInvalidate := True; - if (PosHoldable and ChildrenInView and NodeInView) or not - (toAutoScrollOnExpand in FOptions.FAutoOptions) then - SetOffsetY(FOffsetY - Integer(HeightDelta)) - else - if TotalFit and NodeInView then - begin - FirstVisible := GetFirstVisible(Node, True); - if Assigned(FirstVisible) then // otherwise there is no visible child at all - SetOffsetY(FOffsetY - GetDisplayRect(FirstVisible, NoColumn, False).Top); - end - else - BottomNode := Node; - end - else - begin - // Scroll as much child nodes into view as possible if the node has been expanded. - if PosHoldable then - NeedFullInvalidate := ScrollIntoView(GetLastVisible(Node, True), False) - else - begin - TopNode := Node; - NeedFullInvalidate := True; - end; - end; - end - else - begin - // If we have collapsed the node or toAutoScrollOnExpand is not set, we try to keep the nodes - // visual position. - if toChildrenAbove in FOptions.FPaintOptions then - SetOffsetY(FOffsetY - Integer(HeightDelta)); - NeedFullInvalidate := True; - end; - end; - - //UpdateScrollBars(True); Moved up - - // Check for automatically scrolled tree. - if NeedFullInvalidate then - Invalidate - else - InvalidateToBottom(Node); - end - else - InvalidateNode(Node); - end - else - begin - UpdateRanges; - UpdateScrollBars(True); - end; - end; - - finally - Exclude(Node.States, vsToggling); - if not TogglingTree then - DoStateChange([], [tsToggling]); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.UpdateHorizontalRange; - -begin - if FHeader.UseColumns then - SetRangeX(FHeader.FColumns.TotalWidth) - else - SetRangeX(GetMaxRightExtend); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.UpdateHorizontalScrollBar(DoRepaint: Boolean); - -var - ScrollInfo: TScrollInfo; - -begin - UpdateHorizontalRange; - - if (tsUpdating in FStates) or not HandleAllocated then - Exit; - - // Adjust effect scroll offset depending on bidi mode. - if UseRightToLeftAlignment then - FEffectiveOffsetX := Integer(FRangeX) - ClientWidth + FOffsetX - else - FEffectiveOffsetX := -FOffsetX; - - if FScrollBarOptions.ScrollBars in [System.UITypes.TScrollStyle.ssHorizontal, System.UITypes.TScrollStyle.ssBoth] then - begin - ZeroMemory (@ScrollInfo, SizeOf(ScrollInfo)); - ScrollInfo.cbSize := SizeOf(ScrollInfo); - ScrollInfo.fMask := SIF_ALL; - GetScrollInfo(Handle, SB_HORZ, ScrollInfo); - - if (Integer(FRangeX) > ClientWidth) or FScrollBarOptions.AlwaysVisible then - begin - DoShowScrollBar(SB_HORZ, True); - - ScrollInfo.nMin := 0; - ScrollInfo.nMax := FRangeX; - ScrollInfo.nPos := FEffectiveOffsetX; - ScrollInfo.nPage := Max(0, ClientWidth + 1); - - ScrollInfo.fMask := SIF_ALL or ScrollMasks[FScrollBarOptions.AlwaysVisible]; - SetScrollInfo(Handle, SB_HORZ, ScrollInfo, DoRepaint); - if DoRepaint then - RedrawWindow(Handle, nil, 0, RDW_FRAME or RDW_INVALIDATE); // Fixes issue #698 - end - else - begin - ScrollInfo.nMin := 0; - ScrollInfo.nMax := 0; - ScrollInfo.nPos := 0; - ScrollInfo.nPage := 0; - DoShowScrollBar(SB_HORZ, False); - SetScrollInfo(Handle, SB_HORZ, ScrollInfo, False); - end; - - // Since the position is automatically changed if it doesn't meet the range - // we better read the current position back to stay synchronized. - FEffectiveOffsetX := GetScrollPos(Handle, SB_HORZ); - if UseRightToLeftAlignment then - SetOffsetX(-Integer(FRangeX) + ClientWidth + FEffectiveOffsetX) - else - SetOffsetX(-FEffectiveOffsetX); - end - else - begin - DoShowScrollBar(SB_HORZ, False); - - // Reset the current horizontal offset to account for window resize etc. - SetOffsetX(FOffsetX); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.UpdateRanges; - -begin - UpdateVerticalRange; - UpdateHorizontalRange; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.UpdateScrollBars(DoRepaint: Boolean); - -// adjusts scrollbars to reflect current size and paint offset of the tree - -begin - if HandleAllocated then - begin - UpdateVerticalScrollBar(DoRepaint); - UpdateHorizontalScrollBar(DoRepaint); - Perform(CM_UPDATE_VCLSTYLE_SCROLLBARS,0,0); - end; -end; - -procedure TBaseVirtualTree.UpdateStyleElements; -begin - inherited; - UpdateHeaderRect; - FHeader.Columns.PaintHeader(Canvas, FHeaderRect, Point(0,0)); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.UpdateVerticalRange; - -begin - // Total node height includes the height of the invisible root node. - FRangeY := Cardinal(Int64(FRoot.TotalHeight) - FRoot.NodeHeight + FBottomSpace); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.UpdateVerticalScrollBar(DoRepaint: Boolean); - -var - ScrollInfo: TScrollInfo; - -begin - UpdateVerticalRange; - - if tsUpdating in FStates then - Exit; - Assert(GetCurrentThreadId = MainThreadId, 'UI controls like ' + Classname + ' and its scrollbars should only be manipulated through the main thread.'); - - if FScrollBarOptions.ScrollBars in [ssVertical, ssBoth] then - begin - ScrollInfo.cbSize := SizeOf(ScrollInfo); - ScrollInfo.fMask := SIF_ALL; - GetScrollInfo(Handle, SB_VERT, ScrollInfo); - - if (Integer(FRangeY) > ClientHeight) or FScrollBarOptions.AlwaysVisible then - begin - DoShowScrollBar(SB_VERT, True); - - ScrollInfo.nMin := 0; - ScrollInfo.nMax := FRangeY; - ScrollInfo.nPos := -FOffsetY; - ScrollInfo.nPage := Max(0, ClientHeight + 1); - - ScrollInfo.fMask := SIF_ALL or ScrollMasks[FScrollBarOptions.AlwaysVisible]; - SetScrollInfo(Handle, SB_VERT, ScrollInfo, DoRepaint); - end - else - begin - ScrollInfo.nMin := 0; - ScrollInfo.nMax := 0; - ScrollInfo.nPos := 0; - ScrollInfo.nPage := 0; - DoShowScrollBar(SB_VERT, False); - SetScrollInfo(Handle, SB_VERT, ScrollInfo, False); - end; - - // Since the position is automatically changed if it doesn't meet the range - // we better read the current position back to stay synchronized. - SetOffsetY(-GetScrollPos(Handle, SB_VERT)); - end - else - begin - DoShowScrollBar(SB_VERT, False); - - // Reset the current vertical offset to account for window resize etc. - SetOffsetY(FOffsetY); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.UseRightToLeftReading: Boolean; - -// The tree can handle right-to-left reading also on non-middle-east systems, so we cannot use the same function as -// it is implemented in TControl. - -begin - Result := BiDiMode <> bdLeftToRight; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.ValidateChildren(Node: PVirtualNode; Recursive: Boolean); - -// Ensures that the children of the given node (and all their children, if Recursive is True) are initialized. -// Node must already be initialized - -var - Child: PVirtualNode; - -begin - if Node = nil then - Node := FRoot; - - if (vsHasChildren in Node.States) and (Node.ChildCount = 0) then - InitChildren(Node); - Child := Node.FirstChild; - while Assigned(Child) do - begin - ValidateNode(Child, Recursive); - Child := Child.NextSibling; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.ValidateNode(Node: PVirtualNode; Recursive: Boolean); - -// Ensures that the given node (and all its children, if Recursive is True) are initialized. - -var - Child: PVirtualNode; - -begin - if Node = nil then - Node := FRoot - else - if not (vsInitialized in Node.States) then - InitNode(Node); - - if Recursive then - begin - if (vsHasChildren in Node.States) and (Node.ChildCount = 0) then - InitChildren(Node); - Child := Node.FirstChild; - while Assigned(Child) do - begin - ValidateNode(Child, Recursive); - Child := Child.NextSibling; - end; - end; -end; - -//----------------- TCustomStringTreeOptions --------------------------------------------------------------------------- - -constructor TCustomStringTreeOptions.Create(AOwner: TBaseVirtualTree); - -begin - inherited; - - FStringOptions := DefaultStringOptions; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TCustomStringTreeOptions.SetStringOptions(const Value: TVTStringOptions); - -var - ChangedOptions: TVTStringOptions; - -begin - if FStringOptions <> Value then - begin - // Exclusive ORing to get all entries wich are in either set but not in both. - ChangedOptions := FStringOptions + Value - (FStringOptions * Value); - FStringOptions := Value; - with FOwner do - if (toShowStaticText in ChangedOptions) and not (csLoading in ComponentState) and HandleAllocated then - Invalidate; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TCustomStringTreeOptions.AssignTo(Dest: TPersistent); - -begin - if Dest is TCustomStringTreeOptions then - begin - with Dest as TCustomStringTreeOptions do - begin - StringOptions := Self.StringOptions; - EditOptions := Self.EditOptions; - end; - end; - - // Let ancestors assign their options to the destination class. - inherited; -end; - -//----------------- TVTEdit -------------------------------------------------------------------------------------------- - -// Implementation of a generic node caption editor. - -constructor TVTEdit.Create(Link: TStringEditLink); - -begin - inherited Create(nil); - ShowHint := False; - ParentShowHint := False; - // This assignment increases the reference count for the interface. - FRefLink := Link; - // This reference is used to access the link. - FLink := Link; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTEdit.CalcMinHeight: Integer; -var - textHeight : Integer; -begin - // Get the actual text height. - textHeight := GetTextSize.cy; - // The minimal height is the actual text height in pixels plus the the non client area. - Result := textHeight + (Height - ClientHeight); - // Also, proportionally to the text size, additional pixel(s) needs to be added for the caret. - Result := Result + Trunc(textHeight * 0.05); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTEdit.CMAutoAdjust(var Message: TMessage); - -begin - AutoAdjustSize; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTEdit.CMExit(var Message: TMessage); - -begin - if Assigned(FLink) and not FLink.FStopping then - with FLink, FTree do - begin - if (toAutoAcceptEditChange in TreeOptions.StringOptions) then - DoEndEdit - else - DoCancelEdit; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTEdit.CMRelease(var Message: TMessage); - -begin - Free; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTEdit.CNCommand(var Message: TWMCommand); - -begin - if Assigned(FLink) and Assigned(FLink.FTree) and (Message.NotifyCode = EN_UPDATE) and - not (vsMultiline in FLink.FNode.States) then - // Instead directly calling AutoAdjustSize it is necessary on Win9x/Me to decouple this notification message - // and eventual resizing. Hence we use a message to accomplish that. - AutoAdjustSize() - else - inherited; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTEdit.WMChar(var Message: TWMChar); - -begin - if not (Message.CharCode in [VK_ESCAPE, VK_TAB]) then - inherited; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTEdit.WMDestroy(var Message: TWMDestroy); - -begin - // If editing stopped by other means than accept or cancel then we have to do default processing for - // pending changes. - if Assigned(FLink) and not FLink.FStopping then - begin - with FLink, FTree do - begin - if (toAutoAcceptEditChange in TreeOptions.StringOptions) and Modified then - Text[FNode, FColumn] := FEdit.Text; - end; - FLink := nil; - FRefLink := nil; - end; - - inherited; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTEdit.WMGetDlgCode(var Message: TWMGetDlgCode); - -begin - inherited; - - Message.Result := Message.Result or DLGC_WANTALLKEYS or DLGC_WANTTAB or DLGC_WANTARROWS; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTEdit.WMKeyDown(var Message: TWMKeyDown); - -// Handles some control keys. - -var - Shift: TShiftState; - EndEdit: Boolean; - Tree: TBaseVirtualTree; - NextNode: PVirtualNode; - ColumnCandidate: Integer; - EditOptions: TVTEditOptions; - Column: TVirtualTreeColumn; -begin - Tree := FLink.FTree; - case Message.CharCode of - VK_ESCAPE: - begin - Tree.DoCancelEdit; - end; - VK_RETURN: - begin - EndEdit := not (vsMultiline in FLink.FNode.States); - if not EndEdit then - begin - // If a multiline node is being edited the finish editing only if Ctrl+Enter was pressed, - // otherwise allow to insert line breaks into the text. - Shift := KeyDataToShiftState(Message.KeyData); - EndEdit := ssCtrl in Shift; - end; - if EndEdit then - begin - Tree := FLink.FTree; - FLink.FTree.InvalidateNode(FLink.FNode); - NextNode := Tree.GetNextVisible(FLink.FNode, True); - FLink.FTree.DoEndEdit; - - // get edit options for column as priority. If column has toDefaultEdit - // use global edit options for tree - EditOptions := Tree.TreeOptions.EditOptions; // default - ColumnCandidate := -1; - if Tree.Header.Columns.Count > 0 then // are there any columns? - begin - Column := Tree.Header.Columns[Tree.FocusedColumn]; - if Column.EditOptions <> toDefaultEdit then - EditOptions := Column.EditOptions; - - // next column candidate for toVerticalEdit and toHorizontalEdit - if Column.EditNextColumn <> -1 then - ColumnCandidate := Column.EditNextColumn; - end; - - case EditOptions of - toDefaultEdit: Tree.SetFocus; - toVerticalEdit: - if NextNode <> nil then - begin - Tree.FocusedNode := NextNode; - - // for toVerticalEdit ColumnCandidate is also proper, - // select ColumnCandidate column in row below - if ColumnCandidate <> -1 then - begin - Tree.FocusedColumn := ColumnCandidate; - Tree.EditColumn := ColumnCandidate; - end; - - if Tree.CanEdit(Tree.FocusedNode, Tree.FocusedColumn) then - Tree.DoEdit; - end; - toHorizontalEdit: - begin - if ColumnCandidate = -1 then - begin - // for toHorizontalEdit if property EditNextColumn is not used - // try to use just next column - ColumnCandidate := Tree.FocusedColumn+1; - while (ColumnCandidate < Tree.Header.Columns.Count) - and not Tree.CanEdit(Tree.FocusedNode, ColumnCandidate) - do - Inc(ColumnCandidate); - end - else - if not Tree.CanEdit(Tree.FocusedNode, ColumnCandidate) then - ColumnCandidate := Tree.Header.Columns.Count; // omit "focus/edit column" (see below) - - if ColumnCandidate < Tree.Header.Columns.Count then - begin - Tree.FocusedColumn := ColumnCandidate; - Tree.EditColumn := ColumnCandidate; - Tree.DoEdit; - end; - end; - end; - end; - end; - VK_UP: - begin - if not (vsMultiline in FLink.FNode.States) then - Message.CharCode := VK_LEFT; - inherited; - end; - VK_DOWN: - begin - if not (vsMultiline in FLink.FNode.States) then - Message.CharCode := VK_RIGHT; - inherited; - end; - VK_TAB: - begin - if Tree.IsEditing then - begin - Tree.InvalidateNode(FLink.FNode); - if ssShift in KeyDataToShiftState(Message.KeyData) then - NextNode := Tree.GetPreviousVisible(FLink.FNode, True) // Shift+Tab goes to previous mode - else - NextNode := Tree.GetNextVisible(FLink.FNode, True); - Tree.EndEditNode; - // check NextNode, otherwise we got AV - if NextNode <> nil then - begin - // Continue editing next node - Tree.ClearSelection(); - Tree.Selected[NextNode] := True; - if Tree.CanEdit(Tree.FocusedNode, Tree.FocusedColumn) then - Tree.DoEdit; - end; - end; - end; - Ord('A'): - begin - if Tree.IsEditing and ([ssCtrl] = KeyboardStateToShiftState) then - begin - Self.SelectAll(); - Message.CharCode := 0; - end; - end; - else - inherited; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTEdit.AutoAdjustSize; - -// Changes the size of the edit to accomodate as much as possible of its text within its container window. -// NewChar describes the next character which will be added to the edit's text. - -var - Size: TSize; -begin - if not (vsMultiline in FLink.FNode.States) and not (toGridExtensions in FLink.FTree.FOptions.FMiscOptions{see issue #252}) then - begin - // avoid flicker - SendMessage(Handle, WM_SETREDRAW, 0, 0); - try - Size := GetTextSize; - Inc(Size.cx, 2 * FLink.FTree.FTextMargin); - // Repaint associated node if the edit becomes smaller. - if Size.cx < Width then - FLink.FTree.Invalidate(); - - if FLink.FAlignment = taRightJustify then - FLink.SetBounds(Rect(Left + Width - Size.cx, Top, Left + Width, Top + Max(Size.cy, Height))) - else - FLink.SetBounds(Rect(Left, Top, Left + Size.cx, Top + Max(Size.cy, Height))); - finally - SendMessage(Handle, WM_SETREDRAW, 1, 0); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTEdit.CreateParams(var Params: TCreateParams); - -begin - inherited; - - // Only with multiline style we can use the text formatting rectangle. - // This does not harm formatting as single line control, if we don't use word wrapping. - with Params do - begin - Style := Style or ES_MULTILINE; - if vsMultiline in FLink.FNode.States then - Style := Style and not (ES_AUTOHSCROLL or WS_HSCROLL) or WS_VSCROLL or ES_AUTOVSCROLL; - if tsUseThemes in FLink.FTree.FStates then - begin - Style := Style and not WS_BORDER; - ExStyle := ExStyle or WS_EX_CLIENTEDGE; - end - else - begin - Style := Style or WS_BORDER; - ExStyle := ExStyle and not WS_EX_CLIENTEDGE; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTEdit.GetTextSize: TSize; -var - DC: HDC; - LastFont: THandle; -begin - DC := GetDC(Handle); - LastFont := SelectObject(DC, Font.Handle); - try - // Read needed space for the current text. - GetTextExtentPoint32(DC, PChar(Text+'yG'), Length(Text)+2, Result); - finally - SelectObject(DC, LastFont); - ReleaseDC(Handle, DC); - end; -end; - -procedure TVTEdit.KeyPress(var Key: Char); -begin - if (Key = #13) and Assigned(FLink) and not (vsMultiline in FLink.FNode.States) then - Key := #0; // Filter out return keys as they will be added to the text, avoids #895 - inherited; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTEdit.Release; - -begin - if HandleAllocated then - PostMessage(Handle, CM_RELEASE, 0, 0); -end; - -//----------------- TStringEditLink ------------------------------------------------------------------------------------ - -constructor TStringEditLink.Create; - -begin - inherited; - FEdit := TVTEdit.Create(Self); - with FEdit do - begin - Visible := False; - BorderStyle := bsSingle; - AutoSize := False; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -destructor TStringEditLink.Destroy; - -begin - if Assigned(FEdit) then - FEdit.Release; - inherited; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TStringEditLink.BeginEdit: Boolean; - -// Notifies the edit link that editing can start now. descendants may cancel node edit -// by returning False. - -begin - Result := not FStopping; - if Result then - begin - FEdit.Show; - FEdit.SelectAll; - FEdit.SetFocus; - FEdit.AutoAdjustSize; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TStringEditLink.SetEdit(const Value: TVTEdit); - -begin - if Assigned(FEdit) then - FEdit.Free; - FEdit := Value; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TStringEditLink.CancelEdit: Boolean; - -begin - Result := not FStopping; - if Result then - begin - FStopping := True; - FEdit.Hide; - FTree.CancelEditNode; - FEdit.FLink := nil; - FEdit.FRefLink := nil; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TStringEditLink.EndEdit: Boolean; - -begin - Result := not FStopping; - if Result then - try - FStopping := True; - if FEdit.Modified then - FTree.Text[FNode, FColumn] := FEdit.Text; - FEdit.Hide; - FEdit.FLink := nil; - FEdit.FRefLink := nil; - except - FStopping := False; - raise; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TStringEditLink.GetBounds: TRect; - -begin - Result := FEdit.BoundsRect; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TStringEditLink.PrepareEdit(Tree: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex): Boolean; - -// Retrieves the true text bounds from the owner tree. - -var - Text: string; - -begin - Result := Tree is TCustomVirtualStringTree; - if Result then - begin - if not Assigned(FEdit) then - begin - FEdit := TVTEdit.Create(Self); - FEdit.Visible := False; - FEdit.BorderStyle := bsSingle; - end; - FEdit.AutoSize := True; - FTree := Tree as TCustomVirtualStringTree; - FNode := Node; - FColumn := Column; - FEdit.Parent := Tree; - // Initial size, font and text of the node. - FTree.GetTextInfo(Node, Column, FEdit.Font, FTextBounds, Text); - FEdit.Font.Color := clWindowText; - FEdit.RecreateWnd; - FEdit.AutoSize := False; - FEdit.Text := Text; - - if Column <= NoColumn then - begin - FEdit.BidiMode := FTree.BidiMode; - FAlignment := FTree.Alignment; - end - else - begin - FEdit.BidiMode := FTree.Header.Columns[Column].BidiMode; - FAlignment := FTree.Header.Columns[Column].Alignment; - end; - - if FEdit.BidiMode <> bdLeftToRight then - ChangeBidiModeAlignment(FAlignment); + property OnScroll; + property OnShortenString; + property OnShowScrollBar; + property OnBeforeGetCheckState; + property OnStartDock; + property OnStartDrag; + property OnStartOperation; + property OnStateChange; + property OnStructureChange; + property OnUpdating; + property OnCanResize; + property OnGesture; + property Touch; + property OnColumnHeaderSpanning; end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TStringEditLink.ProcessMessage(var Message: TMessage); - -begin - FEdit.WindowProc(Message); -end; //---------------------------------------------------------------------------------------------------------------------- -procedure TStringEditLink.SetBounds(R: TRect); +implementation +uses + System.TypInfo, // for migration stuff + System.StrUtils, + System.Types, // prevent inline compiler warning + System.UITypes, // prevent inline compiler warning + VirtualTrees.StyleHooks, + VirtualTrees.ClipBoard, + VirtualTrees.Utils, + VirtualTrees.Export, + VirtualTrees.EditLink, + VirtualTrees.BaseAncestorVcl{to eliminate H2443 about inline expanding} + ; -// Sets the outer bounds of the edit control and the actual edit area in the control. +const + cDefaultText = 'Node'; + RTLFlag: array[Boolean] of Integer = (0, ETO_RTLREADING); + AlignmentToDrawFlag: array[TAlignment] of Cardinal = (DT_LEFT, DT_RIGHT, DT_CENTER); + gInitialized: Integer = 0; // >0 if global structures have been initialized; otherwise 0 -var - lOffset, tOffset, height: Integer; - offsets : TVTOffsets; +//// initialization of stuff global to the unit +procedure InitializeGlobalStructures(); begin - if not FStopping then - begin - // Check if the provided rect height is smaller than the edit control height. - height := R.Bottom - R.Top; - if height < FEdit.ClientHeight then - begin - // If the height is smaller than the minimal height we must correct it, otherwise the caret will be invisible. - tOffset := FEdit.CalcMinHeight - height; - if tOffset > 0 then - Inc(R.Bottom, tOffset); - end; - - // Set the edit's bounds but make sure there's a minimum width and the right border does not - // extend beyond the parent's left/right border. - if R.Left < 0 then - R.Left := 0; - if R.Right - R.Left < 30 then - begin - if FAlignment = taRightJustify then - R.Left := R.Right - 30 - else - R.Right := R.Left + 30; - end; - if R.Right > FTree.ClientWidth then - R.Right := FTree.ClientWidth; - FEdit.BoundsRect := R; - - // The selected text shall exclude the text margins and be centered vertically. - // We have to take out the two pixel border of the edit control as well as a one pixel "edit border" the - // control leaves around the (selected) text. - R := FEdit.ClientRect; - - // If toGridExtensions are turned on, we can fine tune the left margin (or the right margin if RTL is on) - // of the text to exactly match the text in the tree cell. - if (toGridExtensions in FTree.TreeOptions.MiscOptions) and - ((FAlignment = taLeftJustify) and (FEdit.BidiMode = bdLeftToRight) or - (FAlignment = taRightJustify) and (FEdit.BidiMode <> bdLeftToRight)) then - begin - // Calculate needed text area offset. - FTree.GetOffsets(FNode, offsets, ofsText, FColumn); - if FColumn = FTree.Header.MainColumn then - begin - if offsets[ofsToggleButton] < 0 then - lOffset := -(offsets[ofsToggleButton] + 2) - else - lOffset := 0; - end - else - lOffset := offsets[ofsText] - offsets[ofsMargin] + 1; - // Apply the offset. - if FEdit.BidiMode = bdLeftToRight then - Inc(R.Left, lOffset) - else - Dec(R.Right, lOffset); - end; + if (gInitialized > 0) or (AtomicIncrement(gInitialized) <> 1) then // Ensure threadsafe that this code is executed only once + exit; - lOffset := IfThen(vsMultiline in FNode.States, 0, 2); - if tsUseThemes in FTree.FStates then - Inc(lOffset); - InflateRect(R, -FTree.FTextMargin + lOffset, lOffset); - if not (vsMultiline in FNode.States) then - begin - tOffset := FTextBounds.Top - FEdit.Top; - // Do not apply a negative offset, the cursor will disappear. - if tOffset > 0 then - OffsetRect(R, 0, tOffset); - end; - R.Top := Max(-1, R.Top); // A value smaller than -1 will prevent the edit cursor from being shown by Windows, see issue #159 - R.Left := Max(-1, R.Left); - SendMessage(FEdit.Handle, EM_SETRECTNP, 0, LPARAM(@R)); - end; + // Clipboard format registration. + // Specialized string tree formats. + CF_HTML := RegisterVTClipboardFormat(CFSTR_HTML, TCustomVirtualStringTree, 80); + CF_VRTFNOOBJS := RegisterVTClipboardFormat(CFSTR_RTFNOOBJS, TCustomVirtualStringTree, 84); + CF_VRTF := RegisterVTClipboardFormat(CFSTR_RTF, TCustomVirtualStringTree, 85); + CF_CSV := RegisterVTClipboardFormat(CFSTR_CSV, TCustomVirtualStringTree, 90); + // Predefined clipboard formats. Just add them to the internal list. + RegisterVTClipboardFormat(CF_TEXT, TCustomVirtualStringTree, 100); + RegisterVTClipboardFormat(CF_UNICODETEXT, TCustomVirtualStringTree, 95); end; + //----------------- TCustomVirtualString ------------------------------------------------------------------------------- constructor TCustomVirtualStringTree.Create(AOwner: TComponent); begin + InitializeGlobalStructures(); inherited; FPreviouslySelected := nil; FDefaultText := cDefaultText; @@ -33455,7 +742,7 @@ function TCustomVirtualStringTree.GetImageText(Node: PVirtualNode; function TCustomVirtualStringTree.GetOptions: TCustomStringTreeOptions; begin - Result := FOptions as TCustomStringTreeOptions; + Result := inherited TreeOptions as TCustomStringTreeOptions; end; //---------------------------------------------------------------------------------------------------------------------- @@ -33498,35 +785,35 @@ procedure TCustomVirtualStringTree.InitializeTextProperties(var PaintInfo: TVTPa with PaintInfo do begin // Set default font values first. - Canvas.Font := Font; + Canvas.Font.Assign(Font); if Enabled then // Otherwise only those colors are used, which are passed from Font to Canvas.Font. - Canvas.Font.Color := FColors.NodeFontColor + Canvas.Font.Color := Colors.NodeFontColor else - Canvas.Font.Color := FColors.DisabledColor; + Canvas.Font.Color := Colors.DisabledColor; - if (toHotTrack in FOptions.FPaintOptions) and (Node = FCurrentHotNode) then + if (toHotTrack in TreeOptions.PaintOptions) and (Node = HotNode) then begin - if not (tsUseExplorerTheme in FStates) then + if not (tsUseExplorerTheme in TreeStates) then begin - Canvas.Font.Style := Canvas.Font.Style + [fsUnderline]; - Canvas.Font.Color := FColors.HotColor; + Canvas.Font.Style := Canvas.Font.Style + [TFontStyle.fsUnderline]; + Canvas.Font.Color := Colors.HotColor; end; end; // Change the font color only if the node also is drawn in selected style. if poDrawSelection in PaintOptions then begin - if (Column = FFocusedColumn) or (toFullRowSelect in FOptions.FSelectionOptions) then + if (Column = FocusedColumn) or (toFullRowSelect in TreeOptions.SelectionOptions) then begin - if Node = FDropTargetNode then + if Node = DropTargetNode then begin - if ((FLastDropMode = dmOnNode) or (vsSelected in Node.States)) then - Canvas.Font.Color := FColors.GetSelectedNodeFontColor(Focused); + if ((LastDropMode = dmOnNode) or (vsSelected in Node.States)) then + Canvas.Font.Color := Colors.GetSelectedNodeFontColor(True); // See #1083, since drop highlight color is chosen independent of the focus state, we need to choose Font color also independent of it. end else if vsSelected in Node.States then begin - Canvas.Font.Color := FColors.GetSelectedNodeFontColor(Focused); + Canvas.Font.Color := Colors.GetSelectedNodeFontColor(Focused or (toPopupMode in TreeOptions.PaintOptions)); end; end; end; @@ -33544,22 +831,21 @@ procedure TCustomVirtualStringTree.PaintNormalText(var PaintInfo: TVTPaintInfo; // the node rectangle. The clipping rectangle comprises the entire node (including tree lines, buttons etc.). var - TripleWidth: Integer; + TripleWidth: TDimension; R: TRect; DrawFormat: Cardinal; - Size: TSize; - Height: Integer; - + Height: TDimension; + lNewNodeWidth: TDimension; begin InitializeTextProperties(PaintInfo); with PaintInfo do begin R := ContentRect; Canvas.TextFlags := 0; - InflateRect(R, -FTextMargin, 0); + InflateRect(R, -TextMargin, 0); if (vsDisabled in Node.States) or not Enabled then - Canvas.Font.Color := FColors.DisabledColor; + Canvas.Font.Color := Colors.DisabledColor; // Multiline nodes don't need special font handling or text manipulation. // Note: multiline support requires the Unicode version of DrawText, which is able to do word breaking. // The emulation in this unit does not support this so we have to use the OS version. However @@ -33578,7 +864,7 @@ procedure TCustomVirtualStringTree.PaintNormalText(var PaintInfo: TVTPaintInfo; // Center the text vertically if it fits entirely into the content rect. if R.Bottom - R.Top > Height then - InflateRect(R, 0, (Height - R.Bottom - R.Top) div 2); + InflateRect(R, 0, Divide(Height - R.Bottom - R.Top, 2)); end else begin @@ -33590,15 +876,19 @@ procedure TCustomVirtualStringTree.PaintNormalText(var PaintInfo: TVTPaintInfo; // If the font has been changed then the ellipsis width must be recalculated. TripleWidth := 0; // Recalculate also the width of the normal text. - GetTextExtentPoint32W(Canvas.Handle, PWideChar(Text), Length(Text), Size); - NodeWidth := Size.cx + 2 * FTextMargin; - end; + lNewNodeWidth := DoTextMeasuring(Canvas, Node, Column, Text).cx + 2 * TextMargin; + if lNewNodeWidth <> NodeWidth then + begin + NodeWidth := lNewNodeWidth; + InvalidateNode(Node); // repaint node and selection as the font chnaged, see #1084 + end;//if + end;// if FFontChanged DrawFormat := DT_NOPREFIX or DT_VCENTER or DT_SINGLELINE; if BidiMode <> bdLeftToRight then DrawFormat := DrawFormat or DT_RTLREADING; // Check if the text must be shortend. - if (Column > NoColumn) and ((NodeWidth - 2 * FTextMargin) > R.Right - R.Left) then + if (Column > NoColumn) and ((NodeWidth - 2 * TextMargin) > R.Width) then begin Text := DoShortenString(Canvas, Node, Column, Text, R.Right - R.Left, TripleWidth); if Alignment = taRightJustify then @@ -33632,23 +922,23 @@ procedure TCustomVirtualStringTree.PaintStaticText(const PaintInfo: TVTPaintInfo begin with PaintInfo do begin - Canvas.Font := Font; - if toFullRowSelect in FOptions.FSelectionOptions then + Canvas.Font.Assign(Font); + if toFullRowSelect in TreeOptions.SelectionOptions then begin - if Node = FDropTargetNode then + if Node = DropTargetNode then begin - if (FLastDropMode = dmOnNode) or (vsSelected in Node.States) then - Canvas.Font.Color := FColors.GetSelectedNodeFontColor(Focused) + if (LastDropMode = dmOnNode) or (vsSelected in Node.States) then + Canvas.Font.Color := Colors.GetSelectedNodeFontColor(Focused or (toPopupMode in TreeOptions.PaintOptions)) else - Canvas.Font.Color := FColors.NodeFontColor; + Canvas.Font.Color := Colors.NodeFontColor; end else if vsSelected in Node.States then begin - if Focused or (toPopupMode in FOptions.FPaintOptions) then - Canvas.Font.Color := FColors.GetSelectedNodeFontColor(Focused) + if Focused or (toPopupMode in TreeOptions.PaintOptions) then + Canvas.Font.Color := Colors.GetSelectedNodeFontColor(Focused or (toPopupMode in TreeOptions.PaintOptions)) else - Canvas.Font.Color := FColors.NodeFontColor; + Canvas.Font.Color := Colors.NodeFontColor; end; end; @@ -33658,18 +948,18 @@ procedure TCustomVirtualStringTree.PaintStaticText(const PaintInfo: TVTPaintInfo // Disabled node color overrides all other variants. if (vsDisabled in Node.States) or not Enabled then - Canvas.Font.Color := FColors.DisabledColor; + Canvas.Font.Color := Colors.DisabledColor; R := ContentRect; if pStaticTextAlignment = taRightJustify then begin DrawFormat := DrawFormat or DT_RIGHT; - Dec(R.Right, FTextMargin); + Dec(R.Right, TextMargin); if PaintInfo.Alignment = taRightJustify then Dec(R.Right, NodeWidth); // room for node text end else begin - Inc(R.Left, FTextMargin); - if PaintInfo.Alignment = taRightJustify then + Inc(R.Left, TextMargin); + if PaintInfo.Alignment = taLeftJustify then Inc(R.Left, NodeWidth); // room for node text end; @@ -33729,7 +1019,7 @@ procedure TCustomVirtualStringTree.SetDefaultText(const Value: string); procedure TCustomVirtualStringTree.SetOptions(const Value: TCustomStringTreeOptions); begin - FOptions.Assign(Value); + inherited TreeOptions.Assign(Value); end; //---------------------------------------------------------------------------------------------------------------------- @@ -33761,7 +1051,7 @@ procedure TCustomVirtualStringTree.WMSetFont(var Msg: TWMSetFont); MemDC := CreateCompatibleDC(0); try SelectObject(MemDC, Msg.Font); - GetTextMetrics(MemDC, TM); + WinApi.Windows.GetTextMetrics(MemDC, TM); FTextHeight := TM.tmHeight; GetTextExtentPoint32W(MemDC, '...', 3, Size); @@ -33771,7 +1061,7 @@ procedure TCustomVirtualStringTree.WMSetFont(var Msg: TWMSetFont); end; // Have to reset all node widths. - Run := FRoot.FirstChild; + Run := RootNode.FirstChild; while Assigned(Run) do begin Data := InternalData(Run); @@ -33792,19 +1082,19 @@ function TCustomVirtualStringTree.AddChild(Parent: PVirtualNode; UserData: Point if (toRestoreSelection in TreeOptions.SelectionOptions) and Assigned(FPreviouslySelected) and Assigned(OnGetText) then begin // See if this was the previously selected node and restore it in this case - Self.OnGetText(Self, Result, 0, ttNormal, NewNodeText); + Self.OnGetText(Self, Result, Header.RestoreSelectionColumnIndex, ttNormal, NewNodeText); if FPreviouslySelected.IndexOf(NewNodeText) >= 0 then begin // Select this node and make sure that the parent node is expanded - Include(FStates, tsPreviouslySelectedLocked); + TreeStates:= TreeStates + [tsPreviouslySelectedLocked]; try Self.Selected[Result] := True; finally - Exclude(FStates, tsPreviouslySelectedLocked); + TreeStates:= TreeStates - [tsPreviouslySelectedLocked]; end; // if a there is a selected node now, then make sure that it is visible if (Self.GetFirstSelected <> nil) then - Self.SetFullyVisible(Self.GetFirstSelected, True); + Self.FullyVisible[Self.GetFirstSelected]:= True; end; end; end; @@ -33817,8 +1107,8 @@ procedure TCustomVirtualStringTree.AdjustPaintCellRect(var PaintInfo: TVTPaintIn // Note: the autospan feature can only be used with left-to-right layout. begin - if (toAutoSpanColumns in FOptions.FAutoOptions) and FHeader.UseColumns and (PaintInfo.BidiMode = bdLeftToRight) then - with FHeader.FColumns, PaintInfo do + if (toAutoSpanColumns in TreeOptions.AutoOptions) and Header.UseColumns and (PaintInfo.BidiMode = bdLeftToRight) then + with Header.Columns, PaintInfo do begin // Start with the directly following column. NextNonEmpty := GetNextVisibleColumn(Column); @@ -33840,7 +1130,7 @@ procedure TCustomVirtualStringTree.AdjustPaintCellRect(var PaintInfo: TVTPaintIn //---------------------------------------------------------------------------------------------------------------------- -function TCustomVirtualStringTree.CalculateStaticTextWidth(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; const Text: string): Integer; +function TCustomVirtualStringTree.CalculateStaticTextWidth(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; const Text: string): TDimension; begin Result := 0; @@ -33849,22 +1139,22 @@ function TCustomVirtualStringTree.CalculateStaticTextWidth(Canvas: TCanvas; Node DoPaintText(Node, Canvas, Column, ttStatic); Inc(Result, DoTextMeasuring(Canvas, Node, Column, Text).cx); - Inc(Result, FTextMargin); + Inc(Result, TextMargin); end; end; //---------------------------------------------------------------------------------------------------------------------- function TCustomVirtualStringTree.CalculateTextWidth(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; - const Text: string): Integer; + const Text: string): TDimension; // Determines the width of the given text. begin - Result := 2 * FTextMargin; + Result := 2 * TextMargin; if Length(Text) > 0 then begin - Canvas.Font := Font; + Canvas.Font.Assign(Font); DoPaintText(Node, Canvas, Column, ttNormal); Inc(Result, DoTextMeasuring(Canvas, Node, Column, Text).cx); @@ -33910,8 +1200,30 @@ destructor TCustomVirtualStringTree.Destroy; //---------------------------------------------------------------------------------------------------------------------- -function TCustomVirtualStringTree.DoCreateEditor(Node: PVirtualNode; Column: TColumnIndex): IVTEditLink; +procedure TCustomVirtualStringTree.DoAddToSelection(Node: PVirtualNode); +var + lSelectedNodeCaption: string; +begin + inherited; + if (toRestoreSelection in TreeOptions.SelectionOptions) and Assigned(Self.OnGetText) and not (tsPreviouslySelectedLocked in TreeStates) then + begin + if not Assigned(FPreviouslySelected) then + begin + FPreviouslySelected := TStringList.Create(); + FPreviouslySelected.Duplicates := dupIgnore; + FPreviouslySelected.Sorted := True; //Improves performance, required to use Find() + FPreviouslySelected.CaseSensitive := False; + end; + if Self.SelectedCount = 1 then + FPreviouslySelected.Clear(); + Self.OnGetText(Self, Node, Header.RestoreSelectionColumnIndex, ttNormal, lSelectedNodeCaption); + FPreviouslySelected.Add(lSelectedNodeCaption); + end;//if +end; + +//---------------------------------------------------------------------------------------------------------------------- +function TCustomVirtualStringTree.DoCreateEditor(Node: PVirtualNode; Column: TColumnIndex): IVTEditLink; begin Result := inherited DoCreateEditor(Node, Column); // Enable generic label editing support if the application does not have own editors. @@ -33946,10 +1258,10 @@ function TCustomVirtualStringTree.DoGetNodeTooltip(Node: PVirtualNode; Column: T //---------------------------------------------------------------------------------------------------------------------- function TCustomVirtualStringTree.DoGetNodeExtraWidth(Node: PVirtualNode; Column: TColumnIndex; - Canvas: TCanvas = nil): Integer; + Canvas: TCanvas = nil): TDimension; begin - if not (toShowStaticText in TreeOptions.FStringOptions) then + if not (toShowStaticText in TreeOptions.StringOptions) then Exit(0); if Canvas = nil then Canvas := Self.Canvas; @@ -33958,23 +1270,23 @@ function TCustomVirtualStringTree.DoGetNodeExtraWidth(Node: PVirtualNode; Column //---------------------------------------------------------------------------------------------------------------------- -function TCustomVirtualStringTree.DoGetNodeWidth(Node: PVirtualNode; Column: TColumnIndex; Canvas: TCanvas = nil): Integer; +function TCustomVirtualStringTree.DoGetNodeWidth(Node: PVirtualNode; Column: TColumnIndex; Canvas: TCanvas = nil): TDimension; // Returns the text width of the given node in pixels. // This width is stored in the node's data member to increase access speed. var - Data: PInteger; + Data: PDimension; begin if (Column > NoColumn) and (vsMultiline in Node.States) then - Result := FHeader.Columns[Column].Width + Result := Header.Columns[Column].Width else begin if Canvas = nil then Canvas := Self.Canvas; - if (Column = FHeader.MainColumn) or (Column = NoColumn) then + if (Column = Header.MainColumn) or (Column = NoColumn) then begin // Primary column or no columns. Data := InternalData(Node); @@ -33982,7 +1294,7 @@ function TCustomVirtualStringTree.DoGetNodeWidth(Node: PVirtualNode; Column: TCo begin Result := Data^; if (Result = 0) - or FHeader.doingAutoFitColumns then + or Header.doingAutoFitColumns then begin Data^ := CalculateTextWidth(Canvas, Node, Column, Text[Node, Column]); Result := Data^; @@ -34024,8 +1336,8 @@ function TCustomVirtualStringTree.DoIncrementalSearch(Node: PVirtualNode; const begin Result := 0; - if Assigned(FOnIncrementalSearch) then - FOnIncrementalSearch(Self, Node, Text, Result) + if Assigned(OnIncrementalSearch) then + OnIncrementalSearch(Self, Node, Text, Result) else // Default behavior is to match the search string with the start of the node text. if not StartsText(Text, GetText(Node, FocusedColumn)) then @@ -34041,7 +1353,7 @@ procedure TCustomVirtualStringTree.DoNewText(Node: PVirtualNode; Column: TColumn FOnNewText(Self, Node, Column, Text); // The width might have changed, so update the scrollbar. - if FUpdateCount = 0 then + if UpdateCount = 0 then UpdateHorizontalScrollBar(True); end; @@ -34075,7 +1387,7 @@ procedure TCustomVirtualStringTree.DoPaintNode(var PaintInfo: TVTPaintInfo); PaintNormalText(PaintInfo, TextOutFlags, lEventArgs.CellText); // ... and afterwards the static text if not centered and the node is not multiline enabled. - if (Alignment <> taCenter) and not (vsMultiline in PaintInfo.Node.States) and (toShowStaticText in TreeOptions.FStringOptions) and not lEventArgs.StaticText.IsEmpty then + if (Alignment <> taCenter) and not (vsMultiline in PaintInfo.Node.States) and (toShowStaticText in TreeOptions.StringOptions) and not lEventArgs.StaticText.IsEmpty then PaintStaticText(PaintInfo, lEventArgs.StaticTextAlignment, lEventArgs.StaticText); finally RestoreFontChangeEvent(PaintInfo.Canvas); @@ -34084,19 +1396,8 @@ procedure TCustomVirtualStringTree.DoPaintNode(var PaintInfo: TVTPaintInfo); //---------------------------------------------------------------------------------------------------------------------- - -procedure TCustomVirtualStringTree.DoPaintText(Node: PVirtualNode; const Canvas: TCanvas; Column: TColumnIndex; - TextType: TVSTTextType); - -begin - if Assigned(FOnPaintText) then - FOnPaintText(Self, Canvas, Node, Column, TextType); -end; - -//---------------------------------------------------------------------------------------------------------------------- - function TCustomVirtualStringTree.DoShortenString(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; - const S: string; Width: Integer; EllipsisWidth: Integer = 0): string; + const S: string; Width: TDimension; EllipsisWidth: TDimension = 0): string; var Done: Boolean; @@ -34116,13 +1417,17 @@ procedure TCustomVirtualStringTree.DoTextDrawing(var PaintInfo: TVTPaintInfo; co var DefaultDraw: Boolean; - + lText: string; begin DefaultDraw := True; if Assigned(FOnDrawText) then FOnDrawText(Self, PaintInfo.Canvas, PaintInfo.Node, PaintInfo.Column, Text, CellRect, DefaultDraw); + if ((DrawFormat and DT_RIGHT) > 0) and (TFontStyle.fsItalic in PaintInfo.Canvas.Font.Style) then + lText := Text + ' ' + else + lText := Text; if DefaultDraw then - Winapi.Windows.DrawTextW(PaintInfo.Canvas.Handle, PWideChar(Text), Length(Text), CellRect, DrawFormat); + Winapi.Windows.DrawTextW(PaintInfo.Canvas.Handle, PWideChar(lText), Length(lText), CellRect, DrawFormat); end; //---------------------------------------------------------------------------------------------------------------------- @@ -34167,6 +1472,8 @@ function TCustomVirtualStringTree.InternalData(Node: PVirtualNode): Pointer; begin if (Node = nil) or (FInternalDataOffset = 0) then Result := nil + else if Node = RootNode then + Result := PByte(Node) + FInternalDataOffset else Result := PByte(Node) + Self.NodeDataSize + FInternalDataOffset; end; @@ -34183,7 +1490,7 @@ procedure TCustomVirtualStringTree.MainColumnChanged; inherited; // Have to reset all node widths. - Run := FRoot.FirstChild; + Run := RootNode.FirstChild; while Assigned(Run) do begin Data := InternalData(Run); @@ -34214,7 +1521,7 @@ function TCustomVirtualStringTree.ReadChunk(Stream: TStream; Version: Integer; N Stream.Read(PWideChar(NewText)^, ChunkSize); end; // Do a new text event regardless of the caption content to allow removing the default string. - Text[Node, FHeader.MainColumn] := NewText; + Text[Node, Header.MainColumn] := NewText; Result := True; end; else @@ -34257,9 +1564,9 @@ procedure TCustomVirtualStringTree.ReadOldStringOptions(Reader: TReader); OldOption := TOldVTStringOption(GetEnumValue(TypeInfo(TOldVTStringOption), EnumName)); case OldOption of soSaveCaptions: - StringOptions := FStringOptions + [toSaveCaptions]; + StringOptions := StringOptions + [toSaveCaptions]; soShowStaticText: - StringOptions := FStringOptions + [toShowStaticText]; + StringOptions := StringOptions + [toShowStaticText]; end; end; end; @@ -34304,25 +1611,25 @@ procedure TCustomVirtualStringTree.WriteChunks(Stream: TStream; Node: PVirtualNo // (take out soSaveCaption from StringOptions). Otherwise the caption is unnecessarily stored twice. var - Header: TChunkHeader; + ChunkHeader: TChunkHeader; S: string; Len: Integer; begin inherited; - if (toSaveCaptions in TreeOptions.FStringOptions) and (Node <> FRoot) and + if (toSaveCaptions in TreeOptions.StringOptions) and (Node <> RootNode) and (vsInitialized in Node.States) then with Stream do begin // Read the node's caption (primary column only). - S := Text[Node, FHeader.MainColumn]; + S := Text[Node, Header.MainColumn]; Len := 2 * Length(S); if Len > 0 then begin // Write a new sub chunk. - Header.ChunkType := CaptionChunk; - Header.ChunkSize := Len; - Write(Header, SizeOf(Header)); + ChunkHeader.ChunkType := CaptionChunk; + ChunkHeader.ChunkSize := Len; + Write(ChunkHeader, SizeOf(ChunkHeader)); Write(PWideChar(S)^, Len); end; end; @@ -34336,7 +1643,7 @@ procedure TCustomVirtualStringTree.WriteText(Writer: TWriter); //---------------------------------------------------------------------------------------------------------------------- function TCustomVirtualStringTree.ComputeNodeHeight(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; - S: string): Integer; + S: string): TDimension; // Default node height calculation for multi line nodes. This method can be used by the application to delegate the // computation to the string tree. @@ -34383,7 +1690,7 @@ function TCustomVirtualStringTree.ComputeNodeHeight(Canvas: TCanvas; Node: PVirt GetOffsets(Node, lOffsets, TVTElement.ofsEndOfClientArea, Column); if Column > NoColumn then begin - PaintInfo.CellRect.Right := FHeader.Columns[Column].Width - 2 * FTextMargin; + PaintInfo.CellRect.Right := Header.Columns[Column].Width - 2 * TextMargin; PaintInfo.CellRect.Left := lOffsets[TVTElement.ofsLabel]; end else @@ -34423,7 +1730,7 @@ function TCustomVirtualStringTree.ContentToHTML(Source: TVSTTextSourceType; cons // Renders the current tree content (depending on Source) as HTML text encoded in UTF-8. // If Caption is not empty then it is used to create and fill the header for the table built here. -// Based on ideas and code from Frank van den Bergh and Andreas Hrstemeier. +// Based on ideas and code from Frank van den Bergh and Andreas Hörstemeier. begin Result := VirtualTrees.Export.ContentToHTML(Self, Source, Caption); @@ -34434,11 +1741,11 @@ function TCustomVirtualStringTree.ContentToHTML(Source: TVSTTextSourceType; cons function TCustomVirtualStringTree.CanExportNode(Node: PVirtualNode): Boolean; begin - case FOptions.ExportMode of + case TreeOptions.ExportMode of emChecked: - Result := GetCheckState(Node) = csCheckedNormal; + Result := CheckState[Node] = csCheckedNormal; emUnchecked: - Result := GetCheckState(Node) = csUncheckedNormal; + Result := CheckState[Node] = csUncheckedNormal; emVisibleDueToExpansion: //Do not export nodes that are not visible because their parent is not expanded Result := not Assigned(Node.Parent) or Self.Expanded[Node.Parent]; emSelected: // export selected nodes only @@ -34450,29 +1757,6 @@ function TCustomVirtualStringTree.CanExportNode(Node: PVirtualNode): Boolean; //---------------------------------------------------------------------------------------------------------------------- -procedure TCustomVirtualStringTree.AddToSelection(Node: PVirtualNode; NotifySynced: Boolean); -var - lSelectedNodeCaption: string; -begin - inherited; - if (toRestoreSelection in TreeOptions.SelectionOptions) and Assigned(Self.OnGetText) and Self.Selected[Node] and not (tsPreviouslySelectedLocked in FStates) then - begin - if not Assigned(FPreviouslySelected) then - begin - FPreviouslySelected := TStringList.Create(); - FPreviouslySelected.Duplicates := dupIgnore; - FPreviouslySelected.Sorted := True; //Improves performance, required to use Find() - FPreviouslySelected.CaseSensitive := False; - end; - if Self.SelectedCount = 1 then - FPreviouslySelected.Clear(); - Self.OnGetText(Self, Node, 0, ttNormal, lSelectedNodeCaption); - FPreviouslySelected.Add(lSelectedNodeCaption); - end;//if -end; - -//---------------------------------------------------------------------------------------------------------------------- - procedure TCustomVirtualStringTree.RemoveFromSelection(Node: PVirtualNode); var lSelectedNodeCaption: string; @@ -34485,7 +1769,7 @@ procedure TCustomVirtualStringTree.RemoveFromSelection(Node: PVirtualNode); FPreviouslySelected.Clear() else begin - Self.OnGetText(Self, Node, 0, ttNormal, lSelectedNodeCaption); + Self.OnGetText(Self, Node, Header.RestoreSelectionColumnIndex, ttNormal, lSelectedNodeCaption); if FPreviouslySelected.Find(lSelectedNodeCaption, lIndex) then FPreviouslySelected.Delete(lIndex); end;//else @@ -34497,7 +1781,7 @@ procedure TCustomVirtualStringTree.RemoveFromSelection(Node: PVirtualNode); function TCustomVirtualStringTree.ContentToRTF(Source: TVSTTextSourceType): RawByteString; // Renders the current tree content (depending on Source) as RTF (rich text). -// Based on ideas and code from Frank van den Bergh and Andreas Hrstemeier. +// Based on ideas and code from Frank van den Bergh and Andreas Hörstemeier. begin Result := VirtualTrees.Export.ContentToRTF(Self, Source); @@ -34550,14 +1834,14 @@ procedure TCustomVirtualStringTree.GetTextInfo(Node: PVirtualNode; Column: TColu // bounding rectangle around Text. var - NewHeight: Integer; + NewHeight: TDimension; TM: TTextMetric; begin // Get default font and initialize the other parameters. inherited GetTextInfo(Node, Column, AFont, R, Text); - Canvas.Font := AFont; + Canvas.Font.Assign(AFont); FFontChanged := False; RedirectFontChangeEvent(Canvas); @@ -34565,7 +1849,7 @@ procedure TCustomVirtualStringTree.GetTextInfo(Node: PVirtualNode; Column: TColu if FFontChanged then begin AFont.Assign(Canvas.Font); - GetTextMetrics(Canvas.Handle, TM); + GetTextMetrics(Canvas, TM); NewHeight := TM.tmHeight; end else // Otherwise the correct font is already there and we only need to set the correct height. @@ -34577,7 +1861,7 @@ procedure TCustomVirtualStringTree.GetTextInfo(Node: PVirtualNode; Column: TColu R := GetDisplayRect(Node, Column, True, not (vsMultiline in Node.States)); if toShowHorzGridLines in TreeOptions.PaintOptions then Dec(R.Bottom); - InflateRect(R, 0, -(R.Bottom - R.Top - NewHeight) div 2); + InflateRect(R, 0, -Divide(R.Bottom - R.Top - NewHeight, 2)); end; //---------------------------------------------------------------------------------------------------------------------- @@ -34608,12 +1892,12 @@ function TCustomVirtualStringTree.Path(Node: PVirtualNode; Column: TColumnIndex; // given delimiter. begin - if (Node = nil) or (Node = FRoot) then + if (Node = nil) or (Node = RootNode) then Result := Delimiter else begin Result := ''; - while Node <> FRoot do + while Node <> RootNode do begin Result := Text[Node, Column] + Delimiter + Result; Node := Node.Parent; @@ -34631,7 +1915,7 @@ procedure TCustomVirtualStringTree.ResetInternalData(Node: PVirtualNode; Recursi begin // Reset node width so changed text attributes are applied correctly. - if Assigned(Node) and (Node <> FRoot) then + if Assigned(Node) and (Node <> RootNode) then begin Data := InternalData(Node); if Assigned(Data) then @@ -34643,7 +1927,7 @@ procedure TCustomVirtualStringTree.ResetInternalData(Node: PVirtualNode; Recursi if Assigned(Node) then Run := Node.FirstChild else - Run := FRoot.FirstChild; + Run := RootNode.FirstChild; while Assigned(Run) do begin @@ -34655,7 +1939,7 @@ procedure TCustomVirtualStringTree.ResetInternalData(Node: PVirtualNode; Recursi //---------------------------------------------------------------------------------------------------------------------- -procedure TCustomVirtualStringTree.ReinitNode(Node: PVirtualNode; Recursive: Boolean); +procedure TCustomVirtualStringTree.ReinitNode(Node: PVirtualNode; Recursive: Boolean; ForceReinit: Boolean = False); begin inherited; @@ -34678,7 +1962,7 @@ procedure TCustomVirtualStringTree.SetChildCount(Node: PVirtualNode; NewChildCou function TVirtualStringTree.GetOptions: TStringTreeOptions; begin - Result := FOptions as TStringTreeOptions; + Result := inherited TreeOptions as TStringTreeOptions; end; //---------------------------------------------------------------------------------------------------------------------- @@ -34686,7 +1970,7 @@ function TVirtualStringTree.GetOptions: TStringTreeOptions; procedure TVirtualStringTree.SetOptions(const Value: TStringTreeOptions); begin - FOptions.Assign(Value); + inherited TreeOptions.Assign(Value); end; //---------------------------------------------------------------------------------------------------------------------- @@ -34697,149 +1981,10 @@ function TVirtualStringTree.GetOptionsClass: TTreeOptionsClass; Result := TStringTreeOptions; end; -//---------------------------------------------------------------------------------------------------------------------- - -function TCustomVirtualDrawTree.DoGetCellContentMargin(Node: PVirtualNode; Column: TColumnIndex; - CellContentMarginType: TVTCellContentMarginType = ccmtAllSides; Canvas: TCanvas = nil): TPoint; - -begin - Result := Point(0, 0); - if Canvas = nil then - Canvas := Self.Canvas; - - if Assigned(FOnGetCellContentMargin) then - FOnGetCellContentMargin(Self, Canvas, Node, Column, CellContentMarginType, Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TCustomVirtualDrawTree.DoGetNodeWidth(Node: PVirtualNode; Column: TColumnIndex; Canvas: TCanvas = nil): Integer; - -begin - Result := 2 * FTextMargin; - if Canvas = nil then - Canvas := Self.Canvas; - - if Assigned(FOnGetNodeWidth) then - FOnGetNodeWidth(Self, Canvas, Node, Column, Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TCustomVirtualDrawTree.DoPaintNode(var PaintInfo: TVTPaintInfo); - -begin - if Assigned(FOnDrawNode) then - FOnDrawNode(Self, PaintInfo); -end; - -function TCustomVirtualDrawTree.GetDefaultHintKind: TVTHintKind; - -begin - Result := vhkOwnerDraw; -end; - -//----------------- TVirtualDrawTree ----------------------------------------------------------------------------------- - -function TVirtualDrawTree.GetOptions: TVirtualTreeOptions; - -begin - Result := FOptions as TVirtualTreeOptions; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualDrawTree.SetOptions(const Value: TVirtualTreeOptions); - -begin - FOptions.Assign(Value); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualDrawTree.GetOptionsClass: TTreeOptionsClass; - -begin - Result := TVirtualTreeOptions; -end; - +{ TVSTGetCellTextEventArgs } //---------------------------------------------------------------------------------------------------------------------- -{ PVirtualNodeHelper } - -function TVirtualNode.GetData(): Pointer; - -// Returns the associated data converted to the class given in the generic part of the function. - -begin - Result := @Self.Data; - Include(States, vsOnFreeNodeCallRequired); -end; - -function TVirtualNode.GetData: T; - -// Returns the associated data converted to the class given in the generic part of the function. - -begin - Result := T(Pointer((PByte(@(Self.Data))))^); - Include(States, vsOnFreeNodeCallRequired); -end; - -function TVirtualNode.IsAssigned: Boolean; - -// Returns False if this node is nil, True otherwise - -begin - Exit(@Self <> nil); -end; - -procedure TVirtualNode.SetData(pUserData: Pointer); - - - // Can be used to set user data of a PVirtualNode with the size of a pointer, useful for setting - // A pointer to a record or a reference to a class instance. -var - NodeData: PPointer; -begin - NodeData := PPointer(@Self.Data); - NodeData^ := pUserData; - Include(Self.States, vsOnFreeNodeCallRequired); -end; - -procedure TVirtualNode.SetData(const pUserData: IInterface); - - - // Can be used to set user data of a PVirtualNode to a class instance, - // will take care about reference counting. - -begin - pUserData._AddRef(); - SetData(Pointer(pUserData)); - Include(Self.States, vsReleaseCallOnUserDataRequired); -end; - -procedure TVirtualNode.SetData(pUserData: T); - -begin - T(Pointer((PByte(@(Self.Data))))^) := pUserData; - if PTypeInfo(TypeInfo(T)).Kind = tkInterface then - Include(Self.States, vsReleaseCallOnUserDataRequired); - Include(Self.States, vsOnFreeNodeCallRequired); -end; - -{ TVTImageInfo } - -function TVTImageInfo.Equals(const pImageInfo2: TVTImageInfo): Boolean; - - // Returns true if both images are the same, does not regard Ghosted and position. - -begin - Result := (Self.Index = pImageInfo2.Index) and (Self.Images = pImageInfo2.Images); -end; - -{ TVSTGetCellTextEventArgs } - constructor TVSTGetCellTextEventArgs.Create(pNode: PVirtualNode; pColumn: TColumnIndex; pExportType: TVTExportType); begin Self.Node := pNode; @@ -34847,115 +1992,10 @@ constructor TVSTGetCellTextEventArgs.Create(pNode: PVirtualNode; pColumn: TColum Self.ExportType := pExportType; end; -{ TCheckStateHelper } - -function TCheckStateHelper.IsDisabled: Boolean; -begin - Result := Self >= TCheckState.csUncheckedDisabled; -end; - -function TCheckStateHelper.IsChecked: Boolean; -begin - Result := Self in [csCheckedNormal, csCheckedPressed, csCheckedDisabled]; -end; - -function TCheckStateHelper.IsUnChecked: Boolean; -begin - Result := Self in [csUnCheckedNormal, csUnCheckedPressed, csUnCheckedDisabled]; -end; - -function TCheckStateHelper.IsMixed: Boolean; -begin - Result := Self in [csMixedNormal, csMixedPressed, csMixedDisabled]; -end; - -function TCheckStateHelper.GetEnabled: TCheckState; -begin - Result := cEnabledState[Self]; -end; - -function TCheckStateHelper.GetPressed(): TCheckState; -begin - Result := cPressedState[Self]; -end; - -function TCheckStateHelper.GetUnpressed(): TCheckState; -begin - Result := cUnpressedState[Self]; -end; - -function TCheckStateHelper.GetToggled(): TCheckState; -begin - Result := cToggledState[Self]; -end; - -{ TSortDirectionHelper } - -function TSortDirectionHelper.ToInt(): Integer; -begin - Result := cSortDirectionToInt[Self]; -end; - - -{ TVTPaintInfo } - -procedure TVTPaintInfo.AdjustImageCoordinates(); -// During painting of the main column some coordinates must be adjusted due to the tree lines. -begin - ContentRect := CellRect; - if BidiMode = bdLeftToRight then - begin - ContentRect.Left := CellRect.Left + Offsets[TVTElement.ofsLabel]; - ImageInfo[iiNormal].XPos := CellRect.Left + Offsets[TVTElement.ofsImage]; - ImageInfo[iiState].XPos := CellRect.Left + Offsets[TVTElement.ofsStateImage]; - ImageInfo[iiCheck].XPos := CellRect.Left + Offsets[TVTElement.ofsCheckBox]; - end - else - begin - /// Since images are still drawn from left to right, we need to substract the image sze as well. - ImageInfo[iiNormal].XPos := CellRect.Right - Offsets[TVTElement.ofsImage] - (Offsets[TVTElement.ofsLabel] - Offsets[TVTElement.ofsImage]); - ImageInfo[iiState].XPos := CellRect.Right - Offsets[TVTElement.ofsStateImage] - (Offsets[TVTElement.ofsImage] - Offsets[TVTElement.ofsStateImage]); - ImageInfo[iiCheck].XPos := CellRect.Right - Offsets[TVTElement.ofsCheckBox] - (Offsets[TVTElement.ofsStateImage] - Offsets[TVTElement.ofsCheckBox]); - ContentRect.Right := CellRect.Right - Offsets[TVTElement.ofsLabel]; - end; - if ImageInfo[iiNormal].Index > -1 then - ImageInfo[iiNormal].YPos := CellRect.Top + VAlign - ImageInfo[iiNormal].Images.Height div 2; - if ImageInfo[iiState].Index > -1 then - ImageInfo[iiState].YPos := CellRect.Top + VAlign - ImageInfo[iiState].Images.Height div 2; - if ImageInfo[iiCheck].Index > -1 then - ImageInfo[iiCheck].YPos := CellRect.Top + VAlign - ImageInfo[iiCheck].Images.Height div 2; -end; - -{ THeaderPaintInfo } - -procedure THeaderPaintInfo.DrawDropMark(); -var - Y: Integer; - lArrowWidth: Integer; -begin - lArrowWidth := Self.Column.Owner.Header.Treeview.ScaledPixels(5); - Y := (PaintRectangle.Top + PaintRectangle.Bottom - 3 * lArrowWidth) div 2; - if DropMark = dmmLeft then - DrawArrow(TargetCanvas, TScrollDirection.sdLeft, Point(PaintRectangle.Left, Y), lArrowWidth) - else - DrawArrow(TargetCanvas, TScrollDirection.sdRight, Point(PaintRectangle.Right - lArrowWidth - (lArrowWidth div 2) {spacing}, Y), lArrowWidth); -end; - -procedure THeaderPaintInfo.DrawSortArrow(pDirection: TSortDirection); -const - cDirection: array[TSortDirection] of TScrollDirection = (TScrollDirection.sdUp, TScrollDirection.sdDown); -var - lOldColor: TColor; -begin - lOldColor := TargetCanvas.Pen.Color; - TargetCanvas.Pen.Color := clDkGray; - DrawArrow(TargetCanvas, cDirection[pDirection], Point(SortGlyphPos.X, SortGlyphPos.Y), SortGlyphSize.cy); - TargetCanvas.Pen.Color := lOldColor; -end; - initialization + TCustomStyleEngine.RegisterStyleHook(TVirtualStringTree, TVclStyleScrollBarsHook); finalization - FinalizeGlobalStructures(); + TCustomStyleEngine.UnRegisterStyleHook(TVirtualStringTree, TVclStyleScrollBarsHook); end. diff --git a/components/virtualtreeview/Source/VirtualTrees.res b/components/virtualtreeview/Source/VirtualTrees.res index deb671eba..558fd1ef1 100644 Binary files a/components/virtualtreeview/Source/VirtualTrees.res and b/components/virtualtreeview/Source/VirtualTrees.res differ diff --git a/components/virtualtreeview/Virtual-TreeView.dspec b/components/virtualtreeview/Virtual-TreeView.dspec new file mode 100644 index 000000000..2927f96c8 --- /dev/null +++ b/components/virtualtreeview/Virtual-TreeView.dspec @@ -0,0 +1,187 @@ +{ + "metadata": { + "id": "JAM.VirtualTreeView", + "version": "8.1.2", + "description": "Virtual TreeView VCL Component", + "authors": "Joachim Marder", + "projectUrl": "https://github.com/JAM-Software/Virtual-TreeView", + "license": "MPL-1.1, LGPL-2.0+", + "copyright": "Various, See project page", + "tags": "VCL, TreeView" + }, + "targetPlatforms": [ + { + "compiler": "10.0", + "platforms": "Win32, Win64", + "template": "default", + "variables" : { + "libsuffix" : "230", + "compiler" : "$compilerNoPoint$" + } + }, + { + "compiler": "10.1", + "platforms": "Win32, Win64", + "template": "default", + "variables" : { + "libsuffix" : "240" + } + }, + { + "compiler": "10.2", + "platforms": "Win32, Win64", + "template": "default", + "variables" : { + "libsuffix" : "250" + } + }, + { + "compiler": "10.3", + "platforms": "Win32, Win64", + "template": "default", + "variables" : { + "libsuffix" : "260" + } + }, + { + "compiler": "10.4", + "platforms": "Win32, Win64", + "template": "10.4+", + "variables" : { + "libsuffix" : "270" + } + }, + { + "compiler": "11.0", + "platforms": "Win32, Win64", + "template": "10.4+", + "variables" : { + "libsuffix" : "280" + } + } + { + "compiler": "12.0", + "platforms": "Win32, Win64", + "template": "10.4+", + "variables" : { + "libsuffix" : "290" + } + } + ], + "templates": [ + { + "comment": "all other compiler versions follow normal folder naming", + "name": "default", + "source": [ + { + "src": ".\\Source\\*.pas", + "dest": "Source" + }, + { + "src": ".\\Source\\*.res", + "dest": "Source" + }, + { + "src": ".\\Design\\*.*", + "dest": "Design" + }, + { + "src": ".\\packages\\Rad Studio $compiler$\\**", + "flatten": false, + "dest": "packages\\Rad Studio $compiler$" + } + ], + "searchPaths": [ + { + "path": "Source", + "source": true + } + ], + "build": [ + { + "id": "VirtualTreesR", + "project": ".\\Packages\\Rad Studio $compiler$\\VirtualTreesR.dproj", + "buildForDesign": true, + "buildForDesignComment" : "when true, will also build win32 if the platform is not win32, so that other packages that need this for design will work" + }, + { + "id": "VirtualTreesD", + "project": ".\\Packages\\Rad Studio $compiler$\\VirtualTreesD.dproj", + "designOnly" : true, + "designOnlyComment" : "designOnly forces compilation with win32 compiler" + } + ], + "runtime": [ + { + "buildId": "VirtualTreesR", + "src": "bin\\VirtualTreesR$libsuffix$.bpl", + "copyLocal": true + } + ], + "design": [ + { + "buildId": "VirtualTreesD", + "src": "bin\\VirtualTreesD$libsuffix$.bpl", + "install": true + } + ] + }, + { + "comment": "10.4+ versions share packages", + "name": "10.4+", + "source": [ + { + "src": ".\\Source\\*.pas", + "dest": "Source" + }, + { + "src": ".\\Source\\*.res", + "dest": "Source" + }, + { + "src": ".\\Design\\*.*", + "dest": "Design" + }, + { + "src": ".\\packages\\Rad Studio 10.4+\\**", + "flatten": false, + "dest": "packages\\Rad Studio $compiler$" + } + ], + "searchPaths": [ + { + "path": "Source", + "source": true + } + ], + "build": [ + { + "id": "VirtualTreesR", + "project": ".\\Packages\\Rad Studio $compiler$\\VirtualTreesR.dproj", + "buildForDesign": true, + "buildForDesignComment" : "when true, will also build win32 if the platform is not win32, so that other packages that need this for design will work" + }, + { + "id": "VirtualTreesD", + "project": ".\\Packages\\Rad Studio $compiler$\\VirtualTreesD.dproj", + "designOnly" : true, + "designOnlyComment" : "designOnly forces compilation with win32 compiler" + } + ], + "runtime": [ + { + "buildId": "VirtualTreesR", + "src": "bin\\VirtualTreesR$libsuffix$.bpl", + "copyLocal": true + } + ], + "design": [ + { + "buildId": "VirtualTreesD", + "src": "bin\\VirtualTreesD$libsuffix$.bpl", + "install": true + } + ] + } + ] +} diff --git a/components/virtualtreeview/packages/Delphi10.4/VirtualTrees.groupproj b/components/virtualtreeview/packages/RAD Studio 10.4+/VirtualTreeView.groupproj similarity index 97% rename from components/virtualtreeview/packages/Delphi10.4/VirtualTrees.groupproj rename to components/virtualtreeview/packages/RAD Studio 10.4+/VirtualTreeView.groupproj index 980342db8..b0f33e510 100644 --- a/components/virtualtreeview/packages/Delphi10.4/VirtualTrees.groupproj +++ b/components/virtualtreeview/packages/RAD Studio 10.4+/VirtualTreeView.groupproj @@ -1,48 +1,48 @@ - - - {CC6A9541-DD5C-4BCD-8914-016D8D2EAB3B} - - - - - - - VirtualTreesR.dproj - - - - Default.Personality.12 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + {CC6A9541-DD5C-4BCD-8914-016D8D2EAB3B} + + + + + + + VirtualTreesR.dproj + + + + Default.Personality.12 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/components/virtualtreeview/packages/Delphi10.4/VirtualTreesD.dpk b/components/virtualtreeview/packages/RAD Studio 10.4+/VirtualTreesD.dpk similarity index 94% rename from components/virtualtreeview/packages/Delphi10.4/VirtualTreesD.dpk rename to components/virtualtreeview/packages/RAD Studio 10.4+/VirtualTreesD.dpk index e3146ac04..fa453e88d 100644 --- a/components/virtualtreeview/packages/Delphi10.4/VirtualTreesD.dpk +++ b/components/virtualtreeview/packages/RAD Studio 10.4+/VirtualTreesD.dpk @@ -1,41 +1,41 @@ -package VirtualTreesD; - -{$R *.res} -{$R '..\..\Design\VirtualTrees.dcr'} -{$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} -{$ALIGN 8} -{$ASSERTIONS ON} -{$BOOLEVAL OFF} -{$DEBUGINFO OFF} -{$EXTENDEDSYNTAX ON} -{$IMPORTEDDATA ON} -{$IOCHECKS ON} -{$LOCALSYMBOLS ON} -{$LONGSTRINGS ON} -{$OPENSTRINGS ON} -{$OPTIMIZATION ON} -{$OVERFLOWCHECKS OFF} -{$RANGECHECKS OFF} -{$REFERENCEINFO ON} -{$SAFEDIVIDE OFF} -{$STACKFRAMES OFF} -{$TYPEDADDRESS OFF} -{$VARSTRINGCHECKS ON} -{$WRITEABLECONST OFF} -{$MINENUMSIZE 1} -{$IMAGEBASE $400000} -{$DEFINE RELEASE} -{$ENDIF IMPLICITBUILDING} -{$DESCRIPTION 'VirtualTreeView Controls'} -{$DESIGNONLY} -{$IMPLICITBUILD OFF} - -requires - DesignIDE, - VirtualTreesR; - -contains - VirtualTreesReg in '..\..\Design\VirtualTreesReg.pas'; - -end. - +package VirtualTreesD; + +{$R *.res} +{$R '..\..\Design\VirtualTrees.dcr'} +{$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO OFF} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DEFINE RELEASE} +{$ENDIF IMPLICITBUILDING} +{$DESCRIPTION 'VirtualTreeView Controls'} +{$LIBSUFFIX AUTO} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + DesignIDE, + VirtualTreesR; + +contains + VirtualTreesReg in '..\..\Design\VirtualTreesReg.pas'; + +end. diff --git a/components/virtualtreeview/packages/Delphi10.4/VirtualTreesD.dproj b/components/virtualtreeview/packages/RAD Studio 10.4+/VirtualTreesD.dproj similarity index 79% rename from components/virtualtreeview/packages/Delphi10.4/VirtualTreesD.dproj rename to components/virtualtreeview/packages/RAD Studio 10.4+/VirtualTreesD.dproj index 05d1061d7..337db6336 100644 --- a/components/virtualtreeview/packages/Delphi10.4/VirtualTreesD.dproj +++ b/components/virtualtreeview/packages/RAD Studio 10.4+/VirtualTreesD.dproj @@ -1,15 +1,16 @@  - {A34BA07B-19B6-4C21-9DEE-65FCA52D00AB} - VirtualTreesD.dpk True - Release Package - VCL + Release DCC32 - 19.0 + VCL + VirtualTreesD.dpk Win32 - 1 + {A34BA07B-19B6-4C21-9DEE-65FCA52D00AB} + 20.3 + 1048577 + VirtualTreesD true @@ -19,6 +20,11 @@ Base true + + true + Base + true + true Base @@ -31,37 +37,41 @@ VirtualTreesD + All + .\$(Platform)\$(Config) + VirtualTreeView Controls ..\..\Source - ..\..\build\$(Platform) + 00400000 + System;Xml;Data;Datasnap;Web;Soap;Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;$(DCC_Namespace) true - VirtualTreeView Controls - All + ..\..\source;.\$(Platform)\$(Config);$(DCC_UnitSearchPath) true - ..\..\source;$(DCC_UnitSearchPath) - System;Xml;Data;Datasnap;Web;Soap;Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;$(DCC_Namespace) - 1053 - false + $(Auto) + true true - 00400000 CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= - false - true - false - false - false + 1053 - $(BDS)\BIN\Bds.exe Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) vcl;VirtualTreesR;$(DCC_UsePackage) + $(BDS)\BIN\Bds.exe + + + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;$(DCC_Namespace) + Debug + true + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProgramID=com.embarcadero.$(MSBuildProjectName);ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments= + 1033 + true RELEASE;$(DCC_Define) DEBUG;$(DCC_Define) - false true + false @@ -71,10 +81,6 @@ - - Cfg_2 - Base - Base @@ -82,6 +88,10 @@ Cfg_1 Base + + Cfg_2 + Base + Delphi.Personality.12 @@ -91,6 +101,7 @@ VirtualTreesD.dpk + True False @@ -118,10 +129,11 @@ 1.0.0.0 - True + False + True 12 diff --git a/components/virtualtreeview/packages/Delphi10.4/VirtualTreesR.dpk b/components/virtualtreeview/packages/RAD Studio 10.4+/VirtualTreesR.dpk similarity index 56% rename from components/virtualtreeview/packages/Delphi10.4/VirtualTreesR.dpk rename to components/virtualtreeview/packages/RAD Studio 10.4+/VirtualTreesR.dpk index ae512a2cb..f65fc3b6e 100644 --- a/components/virtualtreeview/packages/Delphi10.4/VirtualTreesR.dpk +++ b/components/virtualtreeview/packages/RAD Studio 10.4+/VirtualTreesR.dpk @@ -25,6 +25,7 @@ package VirtualTreesR; {$IMAGEBASE $400000} {$DEFINE RELEASE} {$ENDIF IMPLICITBUILDING} +{$LIBSUFFIX AUTO} {$RUNONLY} {$IMPLICITBUILD OFF} @@ -33,18 +34,28 @@ requires vclx; contains - VirtualTrees in '..\..\Source\VirtualTrees.pas', - VirtualTrees.HeaderPopup in '..\..\Source\VirtualTrees.HeaderPopup.pas', - VirtualTrees.AccessibilityFactory in '..\..\Source\VirtualTrees.AccessibilityFactory.pas', VirtualTrees.Accessibility in '..\..\Source\VirtualTrees.Accessibility.pas', - VirtualTrees.StyleHooks in '..\..\Source\VirtualTrees.StyleHooks.pas', + VirtualTrees.AccessibilityFactory in '..\..\Source\VirtualTrees.AccessibilityFactory.pas', + VirtualTrees.Actions in '..\..\Source\VirtualTrees.Actions.pas', VirtualTrees.Classes in '..\..\Source\VirtualTrees.Classes.pas', - VirtualTrees.WorkerThread in '..\..\Source\VirtualTrees.WorkerThread.pas', VirtualTrees.ClipBoard in '..\..\Source\VirtualTrees.ClipBoard.pas', - VirtualTrees.Actions in '..\..\Source\VirtualTrees.Actions.pas', + VirtualTrees.Colors in '..\..\Source\VirtualTrees.Colors.pas', + VirtualTrees.DataObject in '..\..\Source\VirtualTrees.DataObject.pas', + VirtualTrees.DragImage in '..\..\Source\VirtualTrees.DragImage.pas', + VirtualTrees.DragnDrop in '..\..\Source\VirtualTrees.DragnDrop.pas', + VirtualTrees.DrawTree in '..\..\Source\VirtualTrees.DrawTree.pas', + VirtualTrees.EditLink in '..\..\Source\VirtualTrees.EditLink.pas', VirtualTrees.Export in '..\..\Source\VirtualTrees.Export.pas', - VirtualTrees.Utils in '..\..\Source\VirtualTrees.Utils.pas'; + VirtualTrees.Header in '..\..\Source\VirtualTrees.Header.pas', + VirtualTrees.HeaderPopup in '..\..\Source\VirtualTrees.HeaderPopup.pas', + VirtualTrees in '..\..\source\VirtualTrees.pas', + VirtualTrees.BaseTree in '..\..\source\VirtualTrees.BaseTree.pas', + VirtualTrees.AncestorVCL in '..\..\source\VirtualTrees.AncestorVCL.pas', + VirtualTrees.BaseAncestorVCL in '..\..\source\VirtualTrees.BaseAncestorVCL.pas', + VirtualTrees.StyleHooks in '..\..\Source\VirtualTrees.StyleHooks.pas', + VirtualTrees.Types in '..\..\Source\VirtualTrees.Types.pas', + VirtualTrees.Utils in '..\..\Source\VirtualTrees.Utils.pas', + VirtualTrees.WorkerThread in '..\..\Source\VirtualTrees.WorkerThread.pas'; end. - diff --git a/components/virtualtreeview/packages/Delphi10.4/VirtualTreesR.dproj b/components/virtualtreeview/packages/RAD Studio 10.4+/VirtualTreesR.dproj similarity index 73% rename from components/virtualtreeview/packages/Delphi10.4/VirtualTreesR.dproj rename to components/virtualtreeview/packages/RAD Studio 10.4+/VirtualTreesR.dproj index 37d6fbbc5..c0abab669 100644 --- a/components/virtualtreeview/packages/Delphi10.4/VirtualTreesR.dproj +++ b/components/virtualtreeview/packages/RAD Studio 10.4+/VirtualTreesR.dproj @@ -1,15 +1,16 @@  - {B62F3689-96E1-47D5-9FB2-2A2718281FDB} - VirtualTreesR.dpk True - Release Package - VCL + Release DCC32 - 19.0 + VCL + VirtualTreesR.dpk Win64 - 3 + {B62F3689-96E1-47D5-9FB2-2A2718281FDB} + 20.3 + 1048579 + VirtualTreesR true @@ -19,6 +20,11 @@ Base true + + true + Base + true + true Base @@ -29,48 +35,43 @@ Base true - - true - Cfg_2 - true - true - - All VirtualTreesR - ..\..\build\$(Platform) + All + .\$(Platform)\$(Config) ..\..\Source - true - true - ..\..\source;$(DCC_UnitSearchPath) + 00400000 System;Xml;Data;Datasnap;Web;Soap;Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;$(DCC_Namespace) - 1053 - false + true + ..\..\source;.\$(Platform)\$(Config);$(DCC_UnitSearchPath) + $(Auto) + true true - 00400000 + true CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= - false - true - false - false - false + 1053 Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;$(DCC_Namespace) + Debug + true + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProgramID=com.embarcadero.$(MSBuildProjectName);ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments= + 1033 + true + - false + 0 RELEASE;$(DCC_Define) + false 0 - 0 DEBUG;$(DCC_Define) - false true - - - true + false @@ -78,21 +79,28 @@ - - - - + + - - + + + + + + + + + + + + + + - - Cfg_2 - Base - + Base @@ -100,6 +108,10 @@ Cfg_1 Base + + Cfg_2 + Base + Delphi.Personality.12 @@ -109,6 +121,7 @@ VirtualTreesR.dpk + True False @@ -136,15 +149,16 @@ 1.0.0.0 - True True + True 12 + diff --git a/extra/find-unused-translation-strings.php b/extra/find-unused-translation-strings.php new file mode 100644 index 000000000..506b77faa --- /dev/null +++ b/extra/find-unused-translation-strings.php @@ -0,0 +1,74 @@ + '); +} + +$poFile = $argv[1]; +$sourcePath = $argv[2]; + +#var_dump($poFile); +#var_dump($sourcePath); + +if(!file_exists($poFile)) { + die('Error: PO file does not exist: '.$poFile); +} +if(!file_exists($sourcePath)) { + die('Error: Source path does not exist: '.$sourcePath); +} + +$poContents = file_get_contents($poFile); +if(!preg_match_all('#msgid\s"(.+)"#', $poContents, $matches)) { + die('Error: No msgid items found in PO file'); +} +$msgIds = $matches[1]; +#var_dump($msgIds); + +$sourceFiles = glob($sourcePath.'/*.{dfm,pas,inc}', GLOB_BRACE); +#var_dump($sourceFiles); + +// Prefill helper array with 0's +$zeros = array_fill(0, count($msgIds), 0); +$stringsFound = array_combine(array_keys($msgIds), $zeros); + +// Read files and count occurrences +foreach($sourceFiles as $sourceFile) { + $sourceContents = file_get_contents($sourceFile); + $sourceContents = preg_replace("#'\s*\+\s*'#", '', $sourceContents); + foreach ($msgIds as $i=>$msgId) { + // Double quote and backslash in translations are escaped with a backslash + $msgId = str_replace('\"', '"', $msgId); + $msgId = str_replace('\\\\', '\\', $msgId); + // Delphi escapes a single quote with a second single quote + $msgId = str_replace("'", "''", $msgId); + if(str_contains($sourceContents, "'".$msgId."'")) { + $stringsFound[$i]++; + } + } +} +#var_dump($stringsFound); +$unusedNum = 0; +$poContentsNew = $poContents; +foreach($msgIds as $i=>$msgId) { + if($stringsFound[$i] == 0) { + echo "Unused string #".(++$unusedNum).": \"".$msgId."\"\n"; + $poContentsNew = preg_replace("#(\r?\n\#[.:]\s+[^\n]*){0,10}\r?\nmsgid\s\"".preg_quote($msgId,'#')."\"\r?\nmsgstr\s\"".preg_quote($msgId, '#')."\"\r?\n#", '', $poContentsNew); + } +} +#$poContentsNew = preg_replace("/(\r?\n)(\r?\n#[.:]\s+[^\n]*){1,10}\r?\n(\r?\n)/", '\\1\\3', $poContentsNew); +#if(preg_last_error() != PREG_NO_ERROR) { +# throw new Exception(preg_last_error_msg()); +#} + +echo "\n"; +echo "Used translation strings: ".(count($msgIds)-$unusedNum)."\n"; + +if($poContentsNew != $poContents) { + $poFileNew = $poFile.'-without-unused'; + $bytesWritten = file_put_contents($poFileNew, $poContentsNew); + echo "New file written with ".(strlen($poContents)-strlen($poContentsNew))." removed bytes: ".$poFileNew."\n"; +} \ No newline at end of file diff --git a/extra/functions-ini-generator.php b/extra/functions-ini-generator.php new file mode 100644 index 000000000..8123a10f8 --- /dev/null +++ b/extra/functions-ini-generator.php @@ -0,0 +1,287 @@ + '"', + '”' => '"', + '—' => '-', + ' ' => ' ', + ]; + $numVersions = []; + foreach($iniEntries as $iniEntry) { + if(!isset($numVersions[$iniEntry['name']])) + $numVersions[$iniEntry['name']] = 0; + $numVersions[$iniEntry['name']]++; + } + // var_dump($numVersions); + + $sections = $finalEntries = []; + foreach($iniEntries as $iniEntry) { + if($numVersions[$iniEntry['name']] > 1) { + for($i=1; $i<100; $i++) { + $section = $iniEntry['name'] . $i; + if(!in_array($section, $sections)) { + $sections[] = $section; + break; + } + } + } + else { + $section = $iniEntry['name']; + $sections[] = $section; + } + $entry = "[".$section."]".NL; + if($section != $iniEntry['name']) { + $entry .= "name=".$iniEntry['name'].NL; + } + $descr = $iniEntry['description']; + $descr = strtr($descr, $replaceMap); + // Limit description to 50 lines, if the rest is longer than 100 chars + $numLinebreaks = 0; + $lenDescr = strlen($descr); + for($i=0; $i $i + 100) { + $descr = substr($descr, 0, $i+1) . ' ...'; + break; + } + } + //die(); + if($doWordWrap) { + $descr = wordwrap($descr); + } + $descr = str_replace(["\r\n", "\r", "\n"], '\n', $descr); + + $entry .= "declaration=".$iniEntry['declaration'].NL + . "category=".$iniEntry['category'].NL + . "description=".html_entity_decode($descr); + $finalEntries[$section] = $entry; + } + ksort($finalEntries); + //var_dump($finalEntries); + return implode(NL, $finalEntries); +} + + +function gen_sqlite(): string +{ + $urls = [ + 'Aggregate Functions'=>'https://www.sqlite.org/lang_aggfunc.html', + 'Scalar SQL Functions'=>'https://www.sqlite.org/lang_corefunc.html', + 'Window Functions' =>'https://www.sqlite.org/windowfunctions.html', + ]; + + $iniEntries = []; + + foreach($urls as $category=>$url) { + //echo $url."\n"; + $contents = file_get_contents($url); + /* + *

sum(X)
total(X)

+ some text

+

some text

+

some text +

+ */ + preg_match_all('#\(.+)\\s*\(.+)\#isU', $contents, $matches); + //var_dump($matches); + for($i=0; $i', "\n", $matches[1][$i])); + //echo $defs."\n\n"; + $defs = explode("\n", $defs); + foreach($defs as $def) { + if(!preg_match('#^(\w+)\(([^\)]*)\)#', $def, $matchesDef)) { + continue; + } + //var_dump($matchesDef); + $entry = ['name'=>strtoupper($matchesDef[1]), 'declaration'=>$matchesDef[2], 'category'=>$category]; + $descr = $matches[2][$i]; + $descr = preg_replace('#\\s*\#', '\\n', $descr); + $descr = strip_tags($descr); + $descr = preg_replace('#\s+#', ' ', $descr); + $entry['description'] = trim($descr); + //var_dump($entry); + //break(2); + $iniEntries[] = $entry; + } + } + //break; + } + + /* + * non-parsable date functions: + date(time-value, modifier, modifier, ...) + time(time-value, modifier, modifier, ...) + datetime(time-value, modifier, modifier, ...) + julianday(time-value, modifier, modifier, ...) + strftime(format, time-value, modifier, modifier, ...) + */ + $iniEntries[] = [ + 'name'=>'DATE', + 'declaration'=>'time-value, modifier, modifier, ...', + 'category'=>'Date And Time Functions', + 'description'=>'All five date and time functions take a time value as an argument. The time value is followed by zero or more modifiers. The strftime() function also takes a format string as its first argument.', + ]; + $iniEntries[] = [ + 'name'=>'TIME', + 'declaration'=>'time-value, modifier, modifier, ...', + 'category'=>'Date And Time Functions', + 'description'=>'All five date and time functions take a time value as an argument. The time value is followed by zero or more modifiers. The strftime() function also takes a format string as its first argument.', + ]; + $iniEntries[] = [ + 'name'=>'DATETIME', + 'declaration'=>'time-value, modifier, modifier, ...', + 'category'=>'Date And Time Functions', + 'description'=>'All five date and time functions take a time value as an argument. The time value is followed by zero or more modifiers. The strftime() function also takes a format string as its first argument.', + ]; + $iniEntries[] = [ + 'name'=>'JULIANDAY', + 'declaration'=>'time-value, modifier, modifier, ...', + 'category'=>'Date And Time Functions', + 'description'=>'All five date and time functions take a time value as an argument. The time value is followed by zero or more modifiers. The strftime() function also takes a format string as its first argument.', + ]; + $iniEntries[] = [ + 'name'=>'STRFTIME', + 'declaration'=>'format, time-value, modifier, modifier, ...', + 'category'=>'Date And Time Functions', + 'description'=>'All five date and time functions take a time value as an argument. The time value is followed by zero or more modifiers. The strftime() function also takes a format string as its first argument.', + ]; + + return finalizeEntries($iniEntries, true); +} + + +function gen_mysql(int $port) +{ + // Insert your custom password and port + $mysqli = mysqli_connect('localhost', 'root', null, null, $port); + $query = mysqli_query($mysqli, "SELECT t.name, t.description, c.name AS categ + FROM mysql.help_topic t, mysql.help_category c + WHERE + t.help_category_id = c.help_category_id + AND c.name NOT LIKE 'Internal%' + -- and t.name like 'CURRENT_TIMESTAMP' + ORDER BY t.name"); + if(mysqli_errno($mysqli)) { + die ('MySQL connection error: '.mysqli_error($mysqli)); + } + $iniEntries = []; + + while($row = mysqli_fetch_object($query)) { + $name = $row->name; + // Exclude function names with spaces, or other non-word characters: + if(!preg_match('#^\w+$#', $name)) { + //echo "10\n"; + continue; + } + #echo $name."\n"; + $matchCount = preg_match( + '#\b'.preg_quote($row->name).'\s?\[?\(([^\)]*)\)[^\r\n]*[\r\n](.*)$#is', + $row->description, + $matches); + if(!$matchCount) { + //echo "20\n"; + continue; + } + $declaration = trim($matches[1]); + $declaration = preg_replace('#[\r\n]#', ' ', $declaration); + + $description = trim($matches[2]); + if(preg_match('#Description\s+\-+[\r\n](.+)#is', $description, $matchesD)) { + $description = trim($matchesD[1]); + } + //$description = preg_replace('#[\r\n]#', ' ', $description); + #echo $row->name."\n".$matches[2]."\n".$matches[3]."\n\n"; + $iniEntries[] = [ + 'name'=>$row->name, + 'declaration'=>$declaration, + 'category'=>$row->categ, + 'description'=>$description, + ]; + + } + return finalizeEntries($iniEntries, false); +} + + +function gen_pg(): string +{ + /* + * https://www.postgresql.org/docs/current/functions-string.html + * + * + +

ascii ( text ) → integer

+

Returns the numeric code of the first character of the argument. In UTF8 encoding, returns the Unicode code point of the character. In other multibyte encodings, the argument must be an ASCII character.

+

ascii('x') → 120

+ + */ + static $categoryUrls = [ + 'Numeric/Math Functions' => 'https://www.postgresql.org/docs/current/functions-math.html', + 'String Functions' => 'https://www.postgresql.org/docs/current/functions-string.html', + 'Binary String Functions' => 'https://www.postgresql.org/docs/current/functions-binarystring.html', + 'Bit String Functions' => 'https://www.postgresql.org/docs/current/functions-bitstring.html', + 'Date/Time Functions' => 'https://www.postgresql.org/docs/current/functions-datetime.html', + 'Enum Support Functions' => 'https://www.postgresql.org/docs/current/functions-enum.html', + 'Geometric Functions' => 'https://www.postgresql.org/docs/current/functions-geometry.html', + 'Network Address Functions' => 'https://www.postgresql.org/docs/current/functions-net.html', + 'Text Search Functions' => 'https://www.postgresql.org/docs/current/functions-textsearch.html', + 'JSON Functions' => 'https://www.postgresql.org/docs/current/functions-json.html', + 'Sequence Manipulation Functions' => 'https://www.postgresql.org/docs/current/functions-sequence.html', + 'Array Functions' => 'https://www.postgresql.org/docs/current/functions-array.html', + 'Range Functions' => 'https://www.postgresql.org/docs/current/functions-range.html', + 'Aggregate Functions' => 'https://www.postgresql.org/docs/current/functions-aggregate.html', + 'Window Functions' => 'https://www.postgresql.org/docs/current/functions-window.html', + 'Merge Support Functions' => 'https://www.postgresql.org/docs/current/functions-merge-support.html', + 'Session Information Functions' => 'https://www.postgresql.org/docs/current/functions-info.html', + 'System Administration Functions' => 'https://www.postgresql.org/docs/current/functions-admin.html', + 'Trigger Functions' => 'https://www.postgresql.org/docs/current/functions-trigger.html', + 'Statistics Information Functions' => 'https://www.postgresql.org/docs/current/functions-statistics.html', + ]; + + $iniEntries = []; + foreach($categoryUrls as $category => $url) { + $doc = file_get_contents($url); + if(empty($doc)) { + throw new RuntimeException("Could not read $url"); + } + $numMatches = preg_match_all('#

]*>\s*(\w+)\s*\(([^)]*)\).*

\s*

(.+)

#', $doc, $matches); + if($numMatches === false) { + throw new RuntimeException("Regexp error: ".preg_last_error()); + } + #var_dump($matches); + foreach($matches[1] as $i=>$name) { + $iniEntries[] = [ + 'name' => strtoupper($name), + 'declaration' => trim(strip_tags($matches[2][$i])), + 'category' => $category, + 'description' => trim(strip_tags($matches[3][$i])), + ]; + } + #break; + } + return finalizeEntries($iniEntries, true); +} + +// SQLite: +# echo gen_sqlite(); + +// MySQL 5.7: +echo gen_mysql(3334); +// MySQL 8.3: +#echo gen_mysql(3308); +// MariaDB 11.7: +# echo gen_mysql(3317); + +// PostgreSQL: +#echo gen_pg(); \ No newline at end of file diff --git a/extra/internationalization/tx.exe b/extra/internationalization/tx.exe new file mode 100644 index 000000000..87cf4d47d Binary files /dev/null and b/extra/internationalization/tx.exe differ diff --git a/extra/internationalization/tx.py35.exe b/extra/internationalization/tx.py35.exe deleted file mode 100644 index d80153fcb..000000000 Binary files a/extra/internationalization/tx.py35.exe and /dev/null differ diff --git a/extra/keywords-generator.php b/extra/keywords-generator.php new file mode 100644 index 000000000..ad68d9fa0 --- /dev/null +++ b/extra/keywords-generator.php @@ -0,0 +1,31 @@ +

ACCESSIBLE + //$htmlList = strtoupper($htmlList); + preg_match_all('#\]*\>\]*\>\]*\>(\w+)\#i', $htmlList, $matches); + //var_dump($matches); + $keywords = []; + foreach ($matches[1] as $kw) { + $kw = strtoupper($kw); + if(!in_array($kw, $funcs)) { + $keywords[] = $kw; + } + } + $keywords = array_unique($keywords); + asort($keywords); + $keywords = implode(' ', $keywords); + $keywords = wordwrap($keywords, 73, "\r\n"); + $keywords = str_replace(' ', ',', $keywords); + $keywords = str_replace("\r\n", ",' +\r\n '", $keywords); + return $keywords; +} + +echo gen_mysql(); \ No newline at end of file diff --git a/out/LICENSE-openssl b/out/LICENSE-openssl new file mode 100644 index 000000000..9601ab435 --- /dev/null +++ b/out/LICENSE-openssl @@ -0,0 +1,125 @@ + + LICENSE ISSUES + ============== + + The OpenSSL toolkit stays under a double license, i.e. both the conditions of + the OpenSSL License and the original SSLeay license apply to the toolkit. + See below for the actual license texts. + + OpenSSL License + --------------- + +/* ==================================================================== + * Copyright (c) 1998-2019 The OpenSSL Project. All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. 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. + * + * 3. All advertising materials mentioning features or use of this + * software must display the following acknowledgment: + * "This product includes software developed by the OpenSSL Project + * for use in the OpenSSL Toolkit. (http://www.openssl.org/)" + * + * 4. The names "OpenSSL Toolkit" and "OpenSSL Project" must not be used to + * endorse or promote products derived from this software without + * prior written permission. For written permission, please contact + * openssl-core@openssl.org. + * + * 5. Products derived from this software may not be called "OpenSSL" + * nor may "OpenSSL" appear in their names without prior written + * permission of the OpenSSL Project. + * + * 6. Redistributions of any form whatsoever must retain the following + * acknowledgment: + * "This product includes software developed by the OpenSSL Project + * for use in the OpenSSL Toolkit (http://www.openssl.org/)" + * + * THIS SOFTWARE IS PROVIDED BY THE OpenSSL PROJECT ``AS IS'' AND ANY + * EXPRESSED 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 OpenSSL PROJECT OR + * ITS 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. + * ==================================================================== + * + * This product includes cryptographic software written by Eric Young + * (eay@cryptsoft.com). This product includes software written by Tim + * Hudson (tjh@cryptsoft.com). + * + */ + + Original SSLeay License + ----------------------- + +/* Copyright (C) 1995-1998 Eric Young (eay@cryptsoft.com) + * All rights reserved. + * + * This package is an SSL implementation written + * by Eric Young (eay@cryptsoft.com). + * The implementation was written so as to conform with Netscapes SSL. + * + * This library is free for commercial and non-commercial use as long as + * the following conditions are aheared to. The following conditions + * apply to all code found in this distribution, be it the RC4, RSA, + * lhash, DES, etc., code; not just the SSL code. The SSL documentation + * included with this distribution is covered by the same copyright terms + * except that the holder is Tim Hudson (tjh@cryptsoft.com). + * + * Copyright remains Eric Young's, and as such any Copyright notices in + * the code are not to be removed. + * If this package is used in a product, Eric Young should be given attribution + * as the author of the parts of the library used. + * This can be in the form of a textual message at program startup or + * in documentation (online or textual) provided with the package. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * 1. Redistributions of source code must retain the copyright + * notice, this list of conditions and the following disclaimer. + * 2. 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. + * 3. All advertising materials mentioning features or use of this software + * must display the following acknowledgement: + * "This product includes cryptographic software written by + * Eric Young (eay@cryptsoft.com)" + * The word 'cryptographic' can be left out if the rouines from the library + * being used are not cryptographic related :-). + * 4. If you include any Windows specific code (or a derivative thereof) from + * the apps directory (application code) you must include an acknowledgement: + * "This product includes software written by Tim Hudson (tjh@cryptsoft.com)" + * + * THIS SOFTWARE IS PROVIDED BY ERIC YOUNG ``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 AUTHOR 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 licence and distribution terms for any publically available version or + * derivative of this code cannot be changed. i.e. this code cannot simply be + * copied and put under another distribution licence + * [including the GNU Public Licence.] + */ + diff --git a/out/fbclient-4.0-64.dll b/out/fbclient-4.0-64.dll new file mode 100644 index 000000000..c641bfcbf Binary files /dev/null and b/out/fbclient-4.0-64.dll differ diff --git a/out/functions-interbase.ini b/out/functions-interbase.ini new file mode 100644 index 000000000..5ea046336 Binary files /dev/null and b/out/functions-interbase.ini differ diff --git a/out/functions-mariadb.ini b/out/functions-mariadb.ini new file mode 100644 index 000000000..f01db1b6d --- /dev/null +++ b/out/functions-mariadb.ini @@ -0,0 +1,1632 @@ +[ABS] +declaration=X +category=Numeric Functions +description=Returns the absolute (non-negative) value of X. If X is not a number, it is\nconverted to a numeric type.\n\nExamples\n--------\n\nSELECT ABS(42);\n+---------+\n| ABS(42) |\n+---------+\n| 42 |\n+---------+\n\nSELECT ABS(-42);\n+----------+\n| ABS(-42) |\n+----------+\n| 42 |\n+----------+\n\nSELECT ABS(DATE '1994-01-01');\n+------------------------+\n| ABS(DATE '1994-01-01') |\n+------------------------+\n| 19940101 |\n+------------------------+\n\nURL: https://mariadb.com/kb/en/abs/ +[ACOS] +declaration=X +category=Numeric Functions +description=Returns the arc cosine of X, that is, the value whose cosine is X. Returns\nNULL if X is not in the range -1 to 1.\n\nExamples\n--------\n\nSELECT ACOS(1);\n+---------+\n| ACOS(1) |\n+---------+\n| 0 |\n+---------+\n\nSELECT ACOS(1.0001);\n+--------------+\n| ACOS(1.0001) |\n+--------------+\n| NULL |\n+--------------+\n\nSELECT ACOS(0);\n+-----------------+\n| ACOS(0) |\n+-----------------+\n| 1.5707963267949 |\n+-----------------+\n\nSELECT ACOS(0.234);\n+------------------+\n| ACOS(0.234) |\n+------------------+\n| 1.33460644244679 |\n+------------------+\n\nURL: https://mariadb.com/kb/en/acos/ +[ADDDATE] +declaration=date,INTERVAL expr unit +category=Date and Time Functions +description=When invoked with the INTERVAL form of the second argument, ADDDATE() is a\nsynonym for DATE_ADD(). The related function SUBDATE() is a synonym for\nDATE_SUB(). For information on the INTERVAL unit argument, see the discussion\nfor DATE_ADD().\n\nWhen invoked with the days form of the second argument, MariaDB treats it as\nan integer number of days to be added to expr.\n\nExamples\n--------\n\nSELECT DATE_ADD('2008-01-02', INTERVAL 31 DAY);\n+-----------------------------------------+\n| DATE_ADD('2008-01-02', INTERVAL 31 DAY) |\n+-----------------------------------------+\n| 2008-02-02 |\n+-----------------------------------------+\n\nSELECT ADDDATE('2008-01-02', INTERVAL 31 DAY);\n+----------------------------------------+\n| ADDDATE('2008-01-02', INTERVAL 31 DAY) |\n+----------------------------------------+\n| 2008-02-02 |\n+----------------------------------------+\n\nSELECT ADDDATE('2008-01-02', 31);\n+---------------------------+\n| ADDDATE('2008-01-02', 31) |\n+---------------------------+\n| 2008-02-02 |\n+---------------------------+\n\nCREATE TABLE t1 (d DATETIME);\nINSERT INTO t1 VALUES\n ("2007-01-30 21:31:07"),\n ("1983-10-15 06:42:51"),\n ("2011-04-21 12:34:56"),\n ("2011-10-30 06:31:41"),\n ("2011-01-30 14:03:25"),\n ("2004-10-07 11:19:34");\n\nSELECT d, ADDDATE(d, 10) from t1;\n+---------------------+---------------------+\n| d | ADDDATE(d, 10) |\n+---------------------+---------------------+\n| 2007-01-30 21:31:07 | 2007-02-09 21:31:07 |\n| 1983-10-15 06:42:51 | 1983-10-25 06:42:51 |\n| 2011-04-21 12:34:56 | 2011-05-01 12:34:56 |\n| 2011-10-30 06:31:41 | 2011-11-09 06:31:41 |\n| 2011-01-30 14:03:25 | 2011-02-09 14:03:25 |\n ... +[ADDTIME] +declaration=expr1,expr2 +category=Date and Time Functions +description=ADDTIME() adds expr2 to expr1 and returns the result. expr1 is a time or\ndatetime expression, and expr2 is a time expression.\n\nExamples\n--------\n\nSELECT ADDTIME('2007-12-31 23:59:59.999999', '1 1:1:1.000002');\n+---------------------------------------------------------+\n| ADDTIME('2007-12-31 23:59:59.999999', '1 1:1:1.000002') |\n+---------------------------------------------------------+\n| 2008-01-02 01:01:01.000001 |\n+---------------------------------------------------------+\n\nSELECT ADDTIME('01:00:00.999999', '02:00:00.999998');\n+-----------------------------------------------+\n| ADDTIME('01:00:00.999999', '02:00:00.999998') |\n+-----------------------------------------------+\n| 03:00:01.999997 |\n+-----------------------------------------------+\n\nURL: https://mariadb.com/kb/en/addtime/ +[ADD_MONTHS] +declaration=date, months +category=Date and Time Functions +description=ADD_MONTHS adds an integer months to a given date (DATE, DATETIME or\nTIMESTAMP), returning the resulting date.\n\nmonths can be positive or negative. If months is not a whole number, then it\nwill be rounded to the nearest whole number (not truncated).\n\nThe resulting day component will remain the same as that specified in date,\nunless the resulting month has fewer days than the day component of the given\ndate, in which case the day will be the last day of the resulting month.\n\nReturns NULL if given an invalid date, or a NULL argument.\n\nExamples\n--------\n\nSELECT ADD_MONTHS('2012-01-31', 2);\n+-----------------------------+\n| ADD_MONTHS('2012-01-31', 2) |\n+-----------------------------+\n| 2012-03-31 |\n+-----------------------------+\n\nSELECT ADD_MONTHS('2012-01-31', -5);\n+------------------------------+\n| ADD_MONTHS('2012-01-31', -5) |\n+------------------------------+\n| 2011-08-31 |\n+------------------------------+\n\nSELECT ADD_MONTHS('2011-01-31', 1);\n+-----------------------------+\n| ADD_MONTHS('2011-01-31', 1) |\n+-----------------------------+\n| 2011-02-28 |\n+-----------------------------+\n\nSELECT ADD_MONTHS('2012-01-31', 1);\n+-----------------------------+\n| ADD_MONTHS('2012-01-31', 1) |\n+-----------------------------+\n| 2012-02-29 |\n+-----------------------------+\n\nSELECT ADD_MONTHS('2012-01-31', 2);\n+-----------------------------+\n| ADD_MONTHS('2012-01-31', 2) |\n+-----------------------------+\n| 2012-03-31 |\n+-----------------------------+\n\n ... +[AES_DECRYPT] +declaration=crypt_str,key_str +category=Encryption Functions +description=This function allows decryption of data using the official AES (Advanced\nEncryption Standard) algorithm. For more information, see the description of\nAES_ENCRYPT().\n\nMariaDB starting with 11.2\n--------------------------\nFrom MariaDB 11.2, the function supports an initialization vector, and control\nof the block encryption mode. The default mode is specified by the\nblock_encryption_mode system variable, which can be changed when calling the\nfunction with a mode. mode is aes-{128,192,256}-{ecb,cbc,ctr} for example:\n"AES-128-cbc".\n\nFor modes that require it, the initialization_vector iv should be 16 bytes (it\ncan be longer, but the extra bytes are ignored). A shorter iv, where one is\nrequired, results in the function returning NULL. Calling RANDOM_BYTES(16)\nwill generate a random series of bytes that can be used for the iv.\n\nExamples\n--------\n\nFrom MariaDB 11.2.0:\n\nSELECT HEX(AES_ENCRYPT('foo', 'bar', '0123456789abcdef', 'aes-128-ctr')) AS x; \n+--------+\n| x |\n+--------+\n| C57C4B |\n+--------+\n\nSELECT AES_DECRYPT(x'C57C4B', 'bar', '0123456789abcdef', 'aes-128-ctr'); \n+------------------------------------------------------------------+\n| AES_DECRYPT(x'C57C4B', 'bar', '0123456789abcdef', 'aes-128-ctr') |\n+------------------------------------------------------------------+\n| foo |\n+------------------------------------------------------------------+\n\nURL: https://mariadb.com/kb/en/aes_decrypt/ +[AES_ENCRYPT] +declaration=str,key_str +category=Encryption Functions +description=AES_ENCRYPT() and AES_DECRYPT() allow encryption and decryption of data using\nthe official AES (Advanced Encryption Standard) algorithm, previously known as\n"Rijndael." Encoding with a 128-bit key length is used (from MariaDB 11.2.0,\nthis is the default, and can be changed). 128 bits is much faster and is\nsecure enough for most purposes.\n\nAES_ENCRYPT() encrypts a string str using the key key_str, and returns a\nbinary string.\n\nAES_DECRYPT() decrypts the encrypted string and returns the original string.\n\nThe input arguments may be any length. If either argument is NULL, the result\nof this function is also NULL.\n\nBecause AES is a block-level algorithm, padding is used to encode uneven\nlength strings and so the result string length may be calculated using this\nformula:\n\n16 x (trunc(string_length / 16) + 1)\n\nIf AES_DECRYPT() detects invalid data or incorrect padding, it returns NULL.\nHowever, it is possible for AES_DECRYPT() to return a non-NULL value (possibly\ngarbage) if the input data or the key is invalid.\n\nMariaDB starting with 11.2\n--------------------------\nFrom MariaDB 11.2, the function supports an initialization vector, and control\nof the block encryption mode. The default mode is specified by the\nblock_encryption_mode system variable, which can be changed when calling the\nfunction with a mode. mode is aes-{128,192,256}-{ecb,cbc,ctr} for example:\n"AES-128-cbc".\n\nAES_ENCRYPT(str, key) can no longer be used in persistent virtual columns (and\nthe like).\n\nExamples\n--------\n\nINSERT INTO t VALUES (AES_ENCRYPT('text',SHA2('password',512)));\n\nFrom MariaDB 11.2.0:\n\nSELECT HEX(AES_ENCRYPT('foo', 'bar', '0123456789abcdef', 'aes-256-cbc')) AS x;\n+----------------------------------+\n| x |\n+----------------------------------+\n| 42A3EB91E6DFC40A900D278F99E0726E |\n+----------------------------------+\n\nURL: https://mariadb.com/kb/en/aes_encrypt/ +[ASCII] +declaration=str +category=String Functions +description=Returns the numeric ASCII value of the leftmost character of the string\nargument. Returns 0 if the given string is empty and NULL if it is NULL.\n\nASCII() works for 8-bit characters.\n\nExamples\n--------\n\nSELECT ASCII(9);\n+----------+\n| ASCII(9) |\n+----------+\n| 57 |\n+----------+\n\nSELECT ASCII('9');\n+------------+\n| ASCII('9') |\n+------------+\n| 57 |\n+------------+\n\nSELECT ASCII('abc');\n+--------------+\n| ASCII('abc') |\n+--------------+\n| 97 |\n+--------------+\n\nURL: https://mariadb.com/kb/en/ascii/ +[ASIN] +declaration=X +category=Numeric Functions +description=Returns the arc sine of X, that is, the value whose sine is X. Returns NULL if\nX is not in the range -1 to 1.\n\nExamples\n--------\n\nSELECT ASIN(0.2);\n+--------------------+\n| ASIN(0.2) |\n+--------------------+\n| 0.2013579207903308 |\n+--------------------+\n\nSELECT ASIN('foo');\n+-------------+\n| ASIN('foo') |\n+-------------+\n| 0 |\n+-------------+\n\nSHOW WARNINGS;\n+---------+------+-----------------------------------------+\n| Level | Code | Message |\n+---------+------+-----------------------------------------+\n| Warning | 1292 | Truncated incorrect DOUBLE value: 'foo' |\n+---------+------+-----------------------------------------+\n\nURL: https://mariadb.com/kb/en/asin/ +[ATAN] +declaration=X +category=Numeric Functions +description=Returns the arc tangent of X, that is, the value whose tangent is X.\n\nExamples\n--------\n\nSELECT ATAN(2);\n+--------------------+\n| ATAN(2) |\n+--------------------+\n| 1.1071487177940904 |\n+--------------------+\n\nSELECT ATAN(-2);\n+---------------------+\n| ATAN(-2) |\n+---------------------+\n| -1.1071487177940904 |\n+---------------------+\n\nURL: https://mariadb.com/kb/en/atan/ +[ATAN2] +declaration=Y,X +category=Numeric Functions +description=Returns the arc tangent of the two variables X and Y. It is similar to\ncalculating the arc tangent of Y / X, except that the signs of both arguments\nare used to determine the quadrant of the result.\n\nExamples\n--------\n\nSELECT ATAN(-2,2);\n+---------------------+\n| ATAN(-2,2) |\n+---------------------+\n| -0.7853981633974483 |\n+---------------------+\n\nSELECT ATAN2(PI(),0);\n+--------------------+\n| ATAN2(PI(),0) |\n+--------------------+\n| 1.5707963267948966 |\n+--------------------+\n\nURL: https://mariadb.com/kb/en/atan2/ +[AVG] +declaration=[DISTINCT] expr +category=Functions and Modifiers for Use with GROUP BY +description=Returns the average value of expr. The DISTINCT option can be used to return\nthe average of the distinct values of expr. NULL values are ignored. It is an\naggregate function, and so can be used with the GROUP BY clause.\n\nAVG() returns NULL if there were no matching rows.\n\nAVG() can be used as a window function.\n\nExamples\n--------\n\nCREATE TABLE sales (sales_value INT);\n\nINSERT INTO sales VALUES(10),(20),(20),(40);\n\nSELECT AVG(sales_value) FROM sales;\n+------------------+\n| AVG(sales_value) |\n+------------------+\n| 22.5000 |\n+------------------+\n\nSELECT AVG(DISTINCT(sales_value)) FROM sales;\n+----------------------------+\n| AVG(DISTINCT(sales_value)) |\n+----------------------------+\n| 23.3333 |\n+----------------------------+\n\nCommonly, AVG() is used with a GROUP BY clause:\n\nCREATE TABLE student (name CHAR(10), test CHAR(10), score TINYINT);\n\nINSERT INTO student VALUES \n ('Chun', 'SQL', 75), ('Chun', 'Tuning', 73),\n ('Esben', 'SQL', 43), ('Esben', 'Tuning', 31),\n ('Kaolin', 'SQL', 56), ('Kaolin', 'Tuning', 88),\n ('Tatiana', 'SQL', 87), ('Tatiana', 'Tuning', 83);\n\nSELECT name, AVG(score) FROM student GROUP BY name;\n+---------+------------+\n| name | AVG(score) |\n+---------+------------+\n| Chun | 74.0000 |\n| Esben | 37.0000 |\n| Kaolin | 72.0000 |\n| Tatiana | 85.0000 |\n+---------+------------+\n\nBe careful to avoid this common mistake, not grouping correctly and returning\n ... +[BENCHMARK] +declaration=count,expr +category=Information Functions +description=The BENCHMARK() function executes the expression expr repeatedly count times.\nIt may be used to time how quickly MariaDB processes the expression. The\nresult value is always 0. The intended use is from within the mariadb client,\nwhich reports query execution times.\n\nExamples\n--------\n\nSELECT BENCHMARK(1000000,ENCODE('hello','goodbye'));\n+----------------------------------------------+\n| BENCHMARK(1000000,ENCODE('hello','goodbye')) |\n+----------------------------------------------+\n| 0 |\n+----------------------------------------------+\n1 row in set (0.21 sec)\n\nURL: https://mariadb.com/kb/en/benchmark/ +[BIGINT] +declaration=M +category=Data Types +description=A large integer. The signed range is -9223372036854775808 to\n9223372036854775807. The unsigned range is 0 to 18446744073709551615.\n\nIf a column has been set to ZEROFILL, all values will be prepended by zeros so\nthat the BIGINT value contains a number of M digits.\n\nNote: If the ZEROFILL attribute has been specified, the column will\nautomatically become UNSIGNED.\n\nFor more details on the attributes, see Numeric Data Type Overview.\n\nSERIAL is an alias for:\n\nBIGINT UNSIGNED NOT NULL AUTO_INCREMENT UNIQUE\n\nINT8 is a synonym for BIGINT.\n\nExamples\n--------\n\nCREATE TABLE bigints (a BIGINT,b BIGINT UNSIGNED,c BIGINT ZEROFILL);\n\nWith strict_mode set, the default from MariaDB 10.2.4:\n\nINSERT INTO bigints VALUES (-10,-10,-10);\nERROR 1264 (22003): Out of range value for column 'b' at row 1\n\nINSERT INTO bigints VALUES (-10,10,-10);\nERROR 1264 (22003): Out of range value for column 'c' at row 1\n\nINSERT INTO bigints VALUES (-10,10,10);\n\nINSERT INTO bigints VALUES\n(9223372036854775808,9223372036854775808,9223372036854775808);\nERROR 1264 (22003): Out of range value for column 'a' at row 1\n\nINSERT INTO bigints VALUES\n(9223372036854775807,9223372036854775808,9223372036854775808);\n\nSELECT * FROM bigints;\n+---------------------+---------------------+----------------------+\n| a | b | c |\n+---------------------+---------------------+----------------------+\n| -10 | 10 | 00000000000000000010 |\n| 9223372036854775807 | 9223372036854775808 | 09223372036854775808 |\n+---------------------+---------------------+----------------------+\n\nWith strict_mode unset, the default until MariaDB 10.2.3:\n\nINSERT INTO bigints VALUES (-10,-10,-10);\n ... +[BIN] +declaration=N +category=String Functions +description=Returns a string representation of the binary value of the given longlong\n(that is, BIGINT) number. This is equivalent to CONV(N,10,2). The argument\nshould be positive. If it is a FLOAT, it will be truncated. Returns NULL if\nthe argument is NULL.\n\nExamples\n--------\n\nSELECT BIN(12);\n+---------+\n| BIN(12) |\n+---------+\n| 1100 |\n+---------+\n\nURL: https://mariadb.com/kb/en/bin/ +[BINARY] +declaration=M +category=Data Types +description=The BINARY type is similar to the CHAR type, but stores binary byte strings\nrather than non-binary character strings. M represents the column length in\nbytes.\n\nIt contains no character set, and comparison and sorting are based on the\nnumeric value of the bytes.\n\nIf the maximum length is exceeded, and SQL strict mode is not enabled , the\nextra characters will be dropped with a warning. If strict mode is enabled, an\nerror will occur.\n\nBINARY values are right-padded with 0x00 (the zero byte) to the specified\nlength when inserted. The padding is not removed on select, so this needs to\nbe taken into account when sorting and comparing, where all bytes are\nsignificant. The zero byte, 0x00 is less than a space for comparison purposes.\n\nExamples\n--------\n\nInserting too many characters, first with strict mode off, then with it on:\n\nCREATE TABLE bins (a BINARY(10));\n\nINSERT INTO bins VALUES('12345678901');\nQuery OK, 1 row affected, 1 warning (0.04 sec)\n\nSELECT * FROM bins;\n+------------+\n| a |\n+------------+\n| 1234567890 |\n+------------+\n\nSET sql_mode='STRICT_ALL_TABLES';\n\nINSERT INTO bins VALUES('12345678901');\nERROR 1406 (22001): Data too long for column 'a' at row 1\n\nSorting is performed with the byte value:\n\nTRUNCATE bins;\n\nINSERT INTO bins VALUES('A'),('B'),('a'),('b');\n\nSELECT * FROM bins ORDER BY a;\n+------+\n| a |\n+------+\n| A |\n| B |\n ... +[BINLOG_GTID_POS] +declaration=binlog_filename,binlog_offset +category=Information Functions +description=The BINLOG_GTID_POS() function takes as input an old-style binary log position\nin the form of a file name and a file offset. It looks up the position in the\ncurrent binlog, and returns a string representation of the corresponding GTID\nposition. If the position is not found in the current binlog, NULL is returned.\n\nExamples\n--------\n\nSELECT BINLOG_GTID_POS("master-bin.000001", 600);\n\nURL: https://mariadb.com/kb/en/binlog_gtid_pos/ +[BIT] +declaration=M +category=Data Types +description=A bit-field type. M indicates the number of bits per value, from 1 to 64. The\ndefault is 1 if M is omitted.\n\nBit values can be inserted with b'value' notation, where value is the bit\nvalue in 0's and 1's.\n\nBit fields are automatically zero-padded from the left to the full length of\nthe bit, so for example in a BIT(4) field, '10' is equivalent to '0010'.\n\nBits are returned as binary, so to display them, either add 0, or use a\nfunction such as HEX, OCT or BIN to convert them.\n\nExamples\n--------\n\nCREATE TABLE b ( b1 BIT(8) );\n\nWith strict_mode set, the default from MariaDB 10.2.4:\n\nINSERT INTO b VALUES (b'11111111');\n\nINSERT INTO b VALUES (b'01010101');\n\nINSERT INTO b VALUES (b'1111111111111');\nERROR 1406 (22001): Data too long for column 'b1' at row 1\n\nSELECT b1+0, HEX(b1), OCT(b1), BIN(b1) FROM b;\n+------+---------+---------+----------+\n| b1+0 | HEX(b1) | OCT(b1) | BIN(b1) |\n+------+---------+---------+----------+\n| 255 | FF | 377 | 11111111 |\n| 85 | 55 | 125 | 1010101 |\n+------+---------+---------+----------+\n\nWith strict_mode unset, the default until MariaDB 10.2.3:\n\nINSERT INTO b VALUES (b'11111111'),(b'01010101'),(b'1111111111111');\nQuery OK, 3 rows affected, 1 warning (0.10 sec)\nRecords: 3 Duplicates: 0 Warnings: 1\n\nSHOW WARNINGS;\n+---------+------+---------------------------------------------+\n| Level | Code | Message |\n+---------+------+---------------------------------------------+\n| Warning | 1264 | Out of range value for column 'b1' at row 3 |\n+---------+------+---------------------------------------------+\n\nSELECT b1+0, HEX(b1), OCT(b1), BIN(b1) FROM b;\n+------+---------+---------+----------+\n| b1+0 | HEX(b1) | OCT(b1) | BIN(b1) |\n ... +[BIT_AND] +declaration=expr +category=Functions and Modifiers for Use with GROUP BY +description=Returns the bitwise AND of all bits in expr. The calculation is performed with\n64-bit (BIGINT) precision. It is an aggregate function, and so can be used\nwith the GROUP BY clause.\n\nIf no rows match, BIT_AND will return a value with all bits set to 1. NULL\nvalues have no effect on the result unless all results are NULL, which is\ntreated as no match.\n\nBIT_AND can be used as a window function with the addition of the over_clause.\n\nExamples\n--------\n\nCREATE TABLE vals (x INT);\n\nINSERT INTO vals VALUES(111),(110),(100);\n\nSELECT BIT_AND(x), BIT_OR(x), BIT_XOR(x) FROM vals;\n+------------+-----------+------------+\n| BIT_AND(x) | BIT_OR(x) | BIT_XOR(x) |\n+------------+-----------+------------+\n| 100 | 111 | 101 |\n+------------+-----------+------------+\n\nAs an aggregate function:\n\nCREATE TABLE vals2 (category VARCHAR(1), x INT);\n\nINSERT INTO vals2 VALUES\n ('a',111),('a',110),('a',100),\n ('b','000'),('b',001),('b',011);\n\nSELECT category, BIT_AND(x), BIT_OR(x), BIT_XOR(x) \n FROM vals GROUP BY category;\n+----------+------------+-----------+------------+\n| category | BIT_AND(x) | BIT_OR(x) | BIT_XOR(x) |\n+----------+------------+-----------+------------+\n| a | 100 | 111 | 101 |\n| b | 0 | 11 | 10 |\n+----------+------------+-----------+------------+\n\nNo match:\n\nSELECT BIT_AND(NULL);\n+----------------------+\n| BIT_AND(NULL) |\n+----------------------+\n| 18446744073709551615 |\n+----------------------+\n\nURL: https://mariadb.com/kb/en/bit_and/ +[BIT_COUNT] +declaration=N +category=Bit Functions +description=Returns the number of bits that are set in the argument N.\n\nExamples\n--------\n\nSELECT BIT_COUNT(29), BIT_COUNT(b'101010');\n+---------------+----------------------+\n| BIT_COUNT(29) | BIT_COUNT(b'101010') |\n+---------------+----------------------+\n| 4 | 3 |\n+---------------+----------------------+\n\nURL: https://mariadb.com/kb/en/bit_count/ +[BIT_LENGTH] +declaration=str +category=String Functions +description=Returns the length of the given string argument in bits. If the argument is\nnot a string, it will be converted to string. If the argument is NULL, it\nreturns NULL.\n\nExamples\n--------\n\nSELECT BIT_LENGTH('text');\n+--------------------+\n| BIT_LENGTH('text') |\n+--------------------+\n| 32 |\n+--------------------+\n\nSELECT BIT_LENGTH('');\n+----------------+\n| BIT_LENGTH('') |\n+----------------+\n| 0 |\n+----------------+\n\nCompatibility\n-------------\n\nPostgreSQL and Sybase support BIT_LENGTH().\n\nURL: https://mariadb.com/kb/en/bit_length/ +[BIT_OR] +declaration=expr +category=Functions and Modifiers for Use with GROUP BY +description=Returns the bitwise OR of all bits in expr. The calculation is performed with\n64-bit (BIGINT) precision. It is an aggregate function, and so can be used\nwith the GROUP BY clause.\n\nIf no rows match, BIT_OR will return a value with all bits set to 0. NULL\nvalues have no effect on the result unless all results are NULL, which is\ntreated as no match.\n\nBIT_OR can be used as a window function with the addition of the over_clause.\n\nExamples\n--------\n\nCREATE TABLE vals (x INT);\n\nINSERT INTO vals VALUES(111),(110),(100);\n\nSELECT BIT_AND(x), BIT_OR(x), BIT_XOR(x) FROM vals;\n+------------+-----------+------------+\n| BIT_AND(x) | BIT_OR(x) | BIT_XOR(x) |\n+------------+-----------+------------+\n| 100 | 111 | 101 |\n+------------+-----------+------------+\n\nAs an aggregate function:\n\nCREATE TABLE vals2 (category VARCHAR(1), x INT);\n\nINSERT INTO vals2 VALUES\n ('a',111),('a',110),('a',100),\n ('b','000'),('b',001),('b',011);\n\nSELECT category, BIT_AND(x), BIT_OR(x), BIT_XOR(x) \n FROM vals GROUP BY category;\n+----------+------------+-----------+------------+\n| category | BIT_AND(x) | BIT_OR(x) | BIT_XOR(x) |\n+----------+------------+-----------+------------+\n| a | 100 | 111 | 101 |\n| b | 0 | 11 | 10 |\n+----------+------------+-----------+------------+\n\nNo match:\n\nSELECT BIT_OR(NULL);\n+--------------+\n| BIT_OR(NULL) |\n+--------------+\n| 0 |\n+--------------+\n\nURL: https://mariadb.com/kb/en/bit_or/ +[BIT_XOR] +declaration=expr +category=Functions and Modifiers for Use with GROUP BY +description=Returns the bitwise XOR of all bits in expr. The calculation is performed with\n64-bit (BIGINT) precision. It is an aggregate function, and so can be used\nwith the GROUP BY clause.\n\nIf no rows match, BIT_XOR will return a value with all bits set to 0. NULL\nvalues have no effect on the result unless all results are NULL, which is\ntreated as no match.\n\nBIT_XOR can be used as a window function with the addition of the over_clause.\n\nExamples\n--------\n\nCREATE TABLE vals (x INT);\n\nINSERT INTO vals VALUES(111),(110),(100);\n\nSELECT BIT_AND(x), BIT_OR(x), BIT_XOR(x) FROM vals;\n+------------+-----------+------------+\n| BIT_AND(x) | BIT_OR(x) | BIT_XOR(x) |\n+------------+-----------+------------+\n| 100 | 111 | 101 |\n+------------+-----------+------------+\n\nAs an aggregate function:\n\nCREATE TABLE vals2 (category VARCHAR(1), x INT);\n\nINSERT INTO vals2 VALUES\n ('a',111),('a',110),('a',100),\n ('b','000'),('b',001),('b',011);\n\nSELECT category, BIT_AND(x), BIT_OR(x), BIT_XOR(x) \n FROM vals GROUP BY category;\n+----------+------------+-----------+------------+\n| category | BIT_AND(x) | BIT_OR(x) | BIT_XOR(x) |\n+----------+------------+-----------+------------+\n| a | 100 | 111 | 101 |\n| b | 0 | 11 | 10 |\n+----------+------------+-----------+------------+\n\nNo match:\n\nSELECT BIT_XOR(NULL);\n+---------------+\n| BIT_XOR(NULL) |\n+---------------+\n| 0 |\n+---------------+\n\nURL: https://mariadb.com/kb/en/bit_xor/ +[BLOB] +declaration=M +category=Data Types +description=A BLOB column with a maximum length of 65,535 (216 - 1) bytes. Each BLOB value\nis stored using a two-byte length prefix that indicates the number of bytes in\nthe value.\n\nAn optional length M can be given for this type. If this is done, MariaDB\ncreates the column as the smallest BLOB type large enough to hold values M\nbytes long.\n\nBLOBS can also be used to store dynamic columns.\n\nBLOB and TEXT columns can both be assigned a DEFAULT value.\n\nIndexing\n--------\n\nMariaDB starting with 10.4\n--------------------------\nFrom MariaDB 10.4, it is possible to set a unique index on a column that uses\nthe BLOB data type. In previous releases this was not possible, as the index\nwould only guarantee the uniqueness of a fixed number of characters.\n\nOracle Mode\n-----------\n\nIn Oracle mode from MariaDB 10.3, BLOB is a synonym for LONGBLOB.\n\nURL: https://mariadb.com/kb/en/blob/ +[CAST] +declaration=expr AS type +category=String Functions +description=The CAST() function takes a value of one type and produces a value of another\ntype, similar to the CONVERT() function.\n\nThe type can be one of the following values:\n\n* BINARY\n* CHAR\n* DATE\n* DATETIME\n* DECIMAL[(M[,D])]\n* DOUBLE\n* FLOAT (from MariaDB 10.4.5)\n* INTEGER\nShort for SIGNED INTEGER\n\n* SIGNED [INTEGER]\n* UNSIGNED [INTEGER]\n* TIME\n* VARCHAR (in Oracle mode, from MariaDB 10.3)\n\nThe main difference between CAST and CONVERT() is that CONVERT(expr,type) is\nODBC syntax while CAST(expr as type) and CONVERT(... USING ...) are SQL92\nsyntax.\n\nIn MariaDB 10.4 and later, you can use the CAST() function with the INTERVAL\nkeyword.\n\nUntil MariaDB 5.5.31, X'HHHH', the standard SQL syntax for binary string\nliterals, erroneously worked in the same way as 0xHHHH. In 5.5.31 it was\nintentionally changed to behave as a string in all contexts (and never as a\nnumber).\n\nThis introduced an incompatibility with previous versions of MariaDB, and all\nversions of MySQL (see the example below).\n\nExamples\n--------\n\nSimple casts:\n\nSELECT CAST("abc" AS BINARY);\nSELECT CAST("1" AS UNSIGNED INTEGER);\nSELECT CAST(123 AS CHAR CHARACTER SET utf8)\n\nNote that when one casts to CHAR without specifying the character set, the\ncollation_connection character set collation will be used. When used with CHAR\nCHARACTER SET, the default collation for that character set will be used.\n\nSELECT COLLATION(CAST(123 AS CHAR));\n+------------------------------+\n ... +[CEIL] +declaration=X +category=Numeric Functions +description=CEIL() is a synonym for CEILING().\n\nURL: https://mariadb.com/kb/en/ceil/ +[CEILING] +declaration=X +category=Numeric Functions +description=Returns the smallest integer value not less than X.\n\nExamples\n--------\n\nSELECT CEILING(1.23);\n+---------------+\n| CEILING(1.23) |\n+---------------+\n| 2 |\n+---------------+\n\nSELECT CEILING(-1.23);\n+----------------+\n| CEILING(-1.23) |\n+----------------+\n| -1 |\n+----------------+\n\nURL: https://mariadb.com/kb/en/ceiling/ +[CHAR] +declaration=M +category=Data Types +description=A fixed-length string that is always right-padded with spaces to the specified\nlength when stored. M represents the column length in characters. The range of\nM is 0 to 255. If M is omitted, the length is 1.\n\nCHAR(0) columns can contain 2 values: an empty string or NULL. Such columns\ncannot be part of an index. The CONNECT storage engine does not support\nCHAR(0).\n\nNote: Trailing spaces are removed when CHAR values are retrieved unless the\nPAD_CHAR_TO_FULL_LENGTH SQL mode is enabled.\n\nBefore MariaDB 10.2, all collations were of type PADSPACE, meaning that CHAR\n(as well as VARCHAR and TEXT) values are compared without regard for trailing\nspaces. This does not apply to the LIKE pattern-matching operator, which takes\ninto account trailing spaces.\n\nIf a unique index consists of a column where trailing pad characters are\nstripped or ignored, inserts into that column where values differ only by the\nnumber of trailing pad characters will result in a duplicate-key error.\n\nExamples\n--------\n\nTrailing spaces:\n\nCREATE TABLE strtest (c CHAR(10));\nINSERT INTO strtest VALUES('Maria ');\n\nSELECT c='Maria',c='Maria ' FROM strtest;\n+-----------+--------------+\n| c='Maria' | c='Maria ' |\n+-----------+--------------+\n| 1 | 1 |\n+-----------+--------------+\n\nSELECT c LIKE 'Maria',c LIKE 'Maria ' FROM strtest;\n+----------------+-------------------+\n| c LIKE 'Maria' | c LIKE 'Maria ' |\n+----------------+-------------------+\n| 1 | 0 |\n+----------------+-------------------+\n\nNO PAD Collations\n-----------------\n\nNO PAD collations regard trailing spaces as normal characters. You can get a\nlist of all NO PAD collations by querying the Information Schema Collations\ntable, for example:\n\nSELECT collation_name FROM information_schema.collations \n ... +[CHARSET] +declaration=str +category=Information Functions +description=Returns the character set of the string argument. If str is not a string, it\nis considered as a binary string (so the function returns 'binary'). This\napplies to NULL, too. The return value is a string in the utf8 character set.\n\nExamples\n--------\n\nSELECT CHARSET('abc');\n+----------------+\n| CHARSET('abc') |\n+----------------+\n| latin1 |\n+----------------+\n\nSELECT CHARSET(CONVERT('abc' USING utf8));\n+------------------------------------+\n| CHARSET(CONVERT('abc' USING utf8)) |\n+------------------------------------+\n| utf8 |\n+------------------------------------+\n\nSELECT CHARSET(USER());\n+-----------------+\n| CHARSET(USER()) |\n+-----------------+\n| utf8 |\n+-----------------+\n\nURL: https://mariadb.com/kb/en/charset/ +[CHAR_LENGTH] +declaration=str +category=String Functions +description=Returns the length of the given string argument, measured in characters. A\nmulti-byte character counts as a single character. This means that for a\nstring containing five two-byte characters, LENGTH() (or OCTET_LENGTH() in\nOracle mode) returns 10, whereas CHAR_LENGTH() returns 5. If the argument is\nNULL, it returns NULL.\n\nIf the argument is not a string value, it is converted into a string.\n\nIt is synonymous with the CHARACTER_LENGTH() function.\n\nExamples\n--------\n\nSELECT CHAR_LENGTH('MariaDB');\n+------------------------+\n| CHAR_LENGTH('MariaDB') |\n+------------------------+\n| 7 |\n+------------------------+\n\nWhen Oracle mode from MariaDB 10.3 is not set:\n\nSELECT CHAR_LENGTH('π'), LENGTH('π'), LENGTHB('π'), OCTET_LENGTH('π');\n+-------------------+--------------+---------------+--------------------+\n| CHAR_LENGTH('π') | LENGTH('π') | LENGTHB('π') | OCTET_LENGTH('π') |\n+-------------------+--------------+---------------+--------------------+\n| 1 | 2 | 2 | 2 |\n+-------------------+--------------+---------------+--------------------+\n\nIn Oracle mode from MariaDB 10.3:\n\nSELECT CHAR_LENGTH('π'), LENGTH('π'), LENGTHB('π'), OCTET_LENGTH('π');\n+-------------------+--------------+---------------+--------------------+\n| CHAR_LENGTH('π') | LENGTH('π') | LENGTHB('π') | OCTET_LENGTH('π') |\n+-------------------+--------------+---------------+--------------------+\n| 1 | 1 | 2 | 2 |\n+-------------------+--------------+---------------+--------------------+\n\nURL: https://mariadb.com/kb/en/char_length/ +[CHR] +declaration=N +category=String Functions +description=CHR() interprets each argument N as an integer and returns a VARCHAR(1) string\nconsisting of the character given by the code values of the integer. The\ncharacter set and collation of the string are set according to the values of\nthe character_set_database and collation_database system variables.\n\nCHR() is similar to the CHAR() function, but only accepts a single argument.\n\nCHR() is available in all sql_modes.\n\nExamples\n--------\n\nSELECT CHR(67);\n+---------+\n| CHR(67) |\n+---------+\n| C |\n+---------+\n\nSELECT CHR('67');\n+-----------+\n| CHR('67') |\n+-----------+\n| C |\n+-----------+\n\nSELECT CHR('C');\n+----------+\n| CHR('C') |\n+----------+\n| |\n+----------+\n1 row in set, 1 warning (0.000 sec)\n\nSHOW WARNINGS;\n+---------+------+----------------------------------------+\n| Level | Code | Message |\n+---------+------+----------------------------------------+\n| Warning | 1292 | Truncated incorrect INTEGER value: 'C' |\n+---------+------+----------------------------------------+\n\nURL: https://mariadb.com/kb/en/chr/ +[COALESCE] +declaration=value,... +category=Comparison Operators +description=Returns the first non-NULL value in the list, or NULL if there are no non-NULL\nvalues. At least one parameter must be passed.\n\nThe function is useful when substituting a default value for null values when\ndisplaying data.\n\nSee also NULL Values in MariaDB.\n\nExamples\n--------\n\nSELECT COALESCE(NULL,1);\n+------------------+\n| COALESCE(NULL,1) |\n+------------------+\n| 1 |\n+------------------+\n\nSELECT COALESCE(NULL,NULL,NULL);\n+--------------------------+\n| COALESCE(NULL,NULL,NULL) |\n+--------------------------+\n| NULL |\n+--------------------------+\n\nWhen two arguments are given, COALESCE() is the same as IFNULL():\n\nSET @a=NULL, @b=1;\n\nSELECT COALESCE(@a, @b), IFNULL(@a, @b);\n+------------------+----------------+\n| COALESCE(@a, @b) | IFNULL(@a, @b) |\n+------------------+----------------+\n| 1 | 1 |\n+------------------+----------------+\n\nHex type confusion:\n\nCREATE TABLE t1 (a INT, b VARCHAR(10));\nINSERT INTO t1 VALUES (0x31, 0x61),(COALESCE(0x31), COALESCE(0x61));\n\nSELECT * FROM t1;\n+------+------+\n| a | b |\n+------+------+\n| 49 | a |\n| 1 | a |\n+------+------+\n\nThe reason for the differing results above is that when 0x31 is inserted\n ... +[COERCIBILITY] +declaration=str +category=Information Functions +description=Returns the collation coercibility value of the string argument. Coercibility\ndefines what will be converted to what in case of collation conflict, with an\nexpression with higher coercibility being converted to the collation of an\nexpression with lower coercibility.\n\n+-----------------------------+---------------------------+------------------+\n| Coercibility | Description | Example |\n+-----------------------------+---------------------------+------------------+\n| 0 | Explicit | Value using a |\n| | | COLLATE clause |\n+-----------------------------+---------------------------+------------------+\n| 1 | No collation | Concatenated |\n| | | strings using |\n| | | different |\n| | | collations |\n+-----------------------------+---------------------------+------------------+\n| 2 | Implicit | A string data |\n| | | type column |\n| | | value, CAST to |\n| | | a string data |\n| | | type |\n+-----------------------------+---------------------------+------------------+\n| 3 | System constant | DATABASE(), |\n| | | USER() return |\n| | | value |\n+-----------------------------+---------------------------+------------------+\n| 4 | Coercible | Literal string |\n+-----------------------------+---------------------------+------------------+\n| 5 | Numeric | Numeric and |\n| | | temporal values |\n+-----------------------------+---------------------------+------------------+\n| 6 | Ignorable | NULL or derived |\n| | | from NULL |\n+-----------------------------+---------------------------+------------------+\n\nExamples\n--------\n\nSELECT COERCIBILITY('abc' COLLATE latin1_swedish_ci);\n+-----------------------------------------------+\n| COERCIBILITY('abc' COLLATE latin1_swedish_ci) |\n+-----------------------------------------------+\n| 0 |\n+-----------------------------------------------+\n\nSELECT COERCIBILITY(CAST(1 AS CHAR));\n+-------------------------------+\n| COERCIBILITY(CAST(1 AS CHAR)) |\n+-------------------------------+\n| 2 |\n ... +[COLLATION] +declaration=str +category=Information Functions +description=Returns the collation of the string argument. If str is not a string, it is\nconsidered as a binary string (so the function returns 'binary'). This applies\nto NULL, too. The return value is a string in the utf8 character set.\n\nSee Character Sets and Collations.\n\nExamples\n--------\n\nSELECT COLLATION('abc');\n+-------------------+\n| COLLATION('abc') |\n+-------------------+\n| latin1_swedish_ci |\n+-------------------+\n\nSELECT COLLATION(_utf8'abc');\n+-----------------------+\n| COLLATION(_utf8'abc') |\n+-----------------------+\n| utf8_general_ci |\n+-----------------------+\n\nURL: https://mariadb.com/kb/en/collation/ +[COLUMN_ADD] +declaration=dyncol_blob, column_nr, value [as type], [column_nr, value [as type]]... +category=Dynamic Column Functions +description=Adds or updates dynamic columns.\n\n* dyncol_blob must be either a valid dynamic columns blob (for example,\nCOLUMN_CREATE returns such blob), or an empty string.\n* column_name specifies the name of the column to be added. If dyncol_blob\nalready has a column with this name, it will be overwritten.\n* value specifies the new value for the column. Passing a NULL value will\ncause the column to be deleted.\n* as type is optional. See #datatypes section for a discussion about types.\n\nThe return value is a dynamic column blob after the modifications.\n\nExamples\n--------\n\nUPDATE t1 SET dyncol_blob=COLUMN_ADD(dyncol_blob, "column_name", "value")\nWHERE id=1;\n\nNote: COLUMN_ADD() is a regular function (just like CONCAT()), hence, in order\nto update the value in the table you have to use the UPDATE ... SET\ndynamic_col=COLUMN_ADD(dynamic_col, ....) pattern.\n\nURL: https://mariadb.com/kb/en/column_add/ +[COLUMN_CHECK] +declaration=dyncol_blob +category=Dynamic Column Functions +description=Check if dyncol_blob is a valid packed dynamic columns blob. Return value of 1\nmeans the blob is valid, return value of 0 means it is not.\n\nRationale: Normally, one works with valid dynamic column blobs. Functions like\nCOLUMN_CREATE, COLUMN_ADD, COLUMN_DELETE always return valid dynamic column\nblobs. However, if a dynamic column blob is accidentally truncated, or\ntranscoded from one character set to another, it will be corrupted. This\nfunction can be used to check if a value in a blob field is a valid dynamic\ncolumn blob.\n\nURL: https://mariadb.com/kb/en/column_check/ +[COLUMN_CREATE] +declaration=column_nr, value [as type], [column_nr, value [as type]]... +category=Dynamic Column Functions +description=Returns a dynamic columns blob that stores the specified columns with values.\n\nThe return value is suitable for\n\n* storing in a table\n* further modification with other dynamic columns functions\n\nThe as type part allows one to specify the value type. In most cases, this is\nredundant because MariaDB will be able to deduce the type of the value.\nExplicit type specification may be needed when the type of the value is not\napparent. For example, a literal '2012-12-01' has a CHAR type by default, one\nwill need to specify '2012-12-01' AS DATE to have it stored as a date. See\nDynamic Columns:Datatypes for further details.\n\nExamples\n--------\n\nINSERT INTO tbl SET dyncol_blob=COLUMN_CREATE("column_name", "value");\n\nURL: https://mariadb.com/kb/en/column_create/ +[COLUMN_DELETE] +declaration=dyncol_blob, column_nr, column_nr... +category=Dynamic Column Functions +description=Deletes a dynamic column with the specified name. Multiple names can be given.\nThe return value is a dynamic column blob after the modification.\n\nURL: https://mariadb.com/kb/en/column_delete/ +[COLUMN_EXISTS] +declaration=dyncol_blob, column_nr +category=Dynamic Column Functions +description=Checks if a column with name column_name exists in dyncol_blob. If yes, return\n1, otherwise return 0. See dynamic columns for more information.\n\nURL: https://mariadb.com/kb/en/column_exists/ +[COLUMN_GET] +declaration=dyncol_blob, column_nr as type +category=Dynamic Column Functions +description=Gets the value of a dynamic column by its name. If no column with the given\nname exists, NULL will be returned.\n\ncolumn_name as type requires that one specify the datatype of the dynamic\ncolumn they are reading.\n\nThis may seem counter-intuitive: why would one need to specify which datatype\nthey're retrieving? Can't the dynamic columns system figure the datatype from\nthe data being stored?\n\nThe answer is: SQL is a statically-typed language. The SQL interpreter needs\nto know the datatypes of all expressions before the query is run (for example,\nwhen one is using prepared statements and runs "select COLUMN_GET(...)", the\nprepared statement API requires the server to inform the client about the\ndatatype of the column being read before the query is executed and the server\ncan see what datatype the column actually has).\n\nLengths\n-------\n\nIf you're running queries like:\n\nSELECT COLUMN_GET(blob, 'colname' as CHAR) ...\n\nwithout specifying a maximum length (i.e. using as CHAR, not as CHAR(n)),\nMariaDB will report the maximum length of the resultset column to be\n16,777,216. This may cause excessive memory usage in some client libraries,\nbecause they try to pre-allocate a buffer of maximum resultset width. To avoid\nthis problem, use CHAR(n) whenever you're using COLUMN_GET in the select list.\n\nSee Dynamic Columns:Datatypes for more information about datatypes.\n\nURL: https://mariadb.com/kb/en/column_get/ +[COLUMN_JSON] +declaration=dyncol_blob +category=Dynamic Column Functions +description=Returns a JSON representation of data in dyncol_blob. Can also be used to\ndisplay nested columns. See dynamic columns for more information.\n\nExample\n-------\n\nselect item_name, COLUMN_JSON(dynamic_cols) from assets;\n+-----------------+----------------------------------------+\n| item_name | COLUMN_JSON(dynamic_cols) |\n+-----------------+----------------------------------------+\n| MariaDB T-shirt | {"size":"XL","color":"blue"} |\n| Thinkpad Laptop | {"color":"black","warranty":"3 years"} |\n+-----------------+----------------------------------------+\n\nLimitation: COLUMN_JSON will decode nested dynamic columns at a nesting level\nof not more than 10 levels deep. Dynamic columns that are nested deeper than\n10 levels will be shown as BINARY string, without encoding.\n\nURL: https://mariadb.com/kb/en/column_json/ +[COLUMN_LIST] +declaration=dyncol_blob +category=Dynamic Column Functions +description=Returns a comma-separated list of column names. The names are quoted with\nbackticks.\n\nSee dynamic columns for more information.\n\nURL: https://mariadb.com/kb/en/column_list/ +[COMMIT] +declaration=the keyword WORK is simply noise and can be omitted without changing the effect +category=Transactions +description=The optional AND CHAIN clause is a convenience for initiating a new\ntransaction as soon as the old transaction terminates. If AND CHAIN is\nspecified, then there is effectively nothing between the old and new\ntransactions, although they remain separate. The characteristics of the new\ntransaction will be the same as the characteristics of the old one - that is,\nthe new transaction will have the same access mode, isolation level and\ndiagnostics area size (we'll discuss all of these shortly) as the transaction\njust terminated.\n\nRELEASE tells the server to disconnect the client immediately after the\ncurrent transaction.\n\nThere are NO RELEASE and AND NO CHAIN options. By default, commits do not\nRELEASE or CHAIN, but it's possible to change this default behavior with the\ncompletion_type server system variable. In this case, the AND NO CHAIN and NO\nRELEASE options override the server default.\n\nURL: https://mariadb.com/kb/en/commit/ +[COMPRESS] +declaration=string_to_compress +category=Encryption Functions +description=Compresses a string and returns the result as a binary string. This function\nrequires MariaDB to have been compiled with a compression library such as\nzlib. Otherwise, the return value is always NULL. The compressed string can be\nuncompressed with UNCOMPRESS().\n\nThe have_compress server system variable indicates whether a compression\nlibrary is present.\n\nExamples\n--------\n\nSELECT LENGTH(COMPRESS(REPEAT('a',1000)));\n+------------------------------------+\n| LENGTH(COMPRESS(REPEAT('a',1000))) |\n+------------------------------------+\n| 21 |\n+------------------------------------+\n\nSELECT LENGTH(COMPRESS(''));\n+----------------------+\n| LENGTH(COMPRESS('')) |\n+----------------------+\n| 0 |\n+----------------------+\n\nSELECT LENGTH(COMPRESS('a'));\n+-----------------------+\n| LENGTH(COMPRESS('a')) |\n+-----------------------+\n| 13 |\n+-----------------------+\n\nSELECT LENGTH(COMPRESS(REPEAT('a',16)));\n+----------------------------------+\n| LENGTH(COMPRESS(REPEAT('a',16))) |\n+----------------------------------+\n| 15 |\n+----------------------------------+\n\nURL: https://mariadb.com/kb/en/compress/ +[CONCAT] +declaration=str1,str2,... +category=String Functions +description=Returns the string that results from concatenating the arguments. May have one\nor more arguments. If all arguments are non-binary strings, the result is a\nnon-binary string. If the arguments include any binary strings, the result is\na binary string. A numeric argument is converted to its equivalent binary\nstring form; if you want to avoid that, you can use an explicit type cast, as\nin this example:\n\nSELECT CONCAT(CAST(int_col AS CHAR), char_col);\n\nCONCAT() returns NULL if any argument is NULL.\n\nA NULL parameter hides all information contained in other parameters from the\nresult. Sometimes this is not desirable; to avoid this, you can:\n\n* Use the CONCAT_WS() function with an empty separator, because that function\nis NULL-safe.\n* Use IFNULL() to turn NULLs into empty strings.\n\nOracle Mode\n-----------\n\nIn Oracle mode, CONCAT ignores NULL.\n\nExamples\n--------\n\nSELECT CONCAT('Ma', 'ria', 'DB');\n+---------------------------+\n| CONCAT('Ma', 'ria', 'DB') |\n+---------------------------+\n| MariaDB |\n+---------------------------+\n\nSELECT CONCAT('Ma', 'ria', NULL, 'DB');\n+---------------------------------+\n| CONCAT('Ma', 'ria', NULL, 'DB') |\n+---------------------------------+\n| NULL |\n+---------------------------------+\n\nSELECT CONCAT(42.0);\n+--------------+\n| CONCAT(42.0) |\n+--------------+\n| 42.0 |\n+--------------+\n\nUsing IFNULL() to handle NULLs:\n\nSELECT CONCAT('The value of @v is: ', IFNULL(@v, ''));\n ... +[CONCAT_WS] +declaration=separator,str1,str2,... +category=String Functions +description=CONCAT_WS() stands for Concatenate With Separator and is a special form of\nCONCAT(). The first argument is the separator for the rest of the arguments.\nThe separator is added between the strings to be concatenated. The separator\ncan be a string, as can the rest of the arguments.\n\nIf the separator is NULL, the result is NULL; all other NULL values are\nskipped. This makes CONCAT_WS() suitable when you want to concatenate some\nvalues and avoid losing all information if one of them is NULL.\n\nExamples\n--------\n\nSELECT CONCAT_WS(',','First name','Second name','Last Name');\n+-------------------------------------------------------+\n| CONCAT_WS(',','First name','Second name','Last Name') |\n+-------------------------------------------------------+\n| First name,Second name,Last Name |\n+-------------------------------------------------------+\n\nSELECT CONCAT_WS('-','Floor',NULL,'Room');\n+------------------------------------+\n| CONCAT_WS('-','Floor',NULL,'Room') |\n+------------------------------------+\n| Floor-Room |\n+------------------------------------+\n\nIn some cases, remember to include a space in the separator string:\n\nSET @a = 'gnu', @b = 'penguin', @c = 'sea lion';\nQuery OK, 0 rows affected (0.00 sec)\n\nSELECT CONCAT_WS(', ', @a, @b, @c);\n+-----------------------------+\n| CONCAT_WS(', ', @a, @b, @c) |\n+-----------------------------+\n| gnu, penguin, sea lion |\n+-----------------------------+\n\nUsing CONCAT_WS() to handle NULLs:\n\nSET @a = 'a', @b = NULL, @c = 'c';\n\nSELECT CONCAT_WS('', @a, @b, @c);\n+---------------------------+\n| CONCAT_WS('', @a, @b, @c) |\n+---------------------------+\n| ac |\n+---------------------------+\n\nURL: https://mariadb.com/kb/en/concat_ws/ +[CONNECTION_ID] +declaration= +category=Information Functions +description=Returns the connection ID for the connection. Every connection (including\nevents) has an ID that is unique among the set of currently connected clients.\n\nUntil MariaDB 10.3.1, returns MYSQL_TYPE_LONGLONG, or bigint(10), in all\ncases. From MariaDB 10.3.1, returns MYSQL_TYPE_LONG, or int(10), when the\nresult would fit within 32-bits.\n\nExamples\n--------\n\nSELECT CONNECTION_ID();\n+-----------------+\n| CONNECTION_ID() |\n+-----------------+\n| 3 |\n+-----------------+\n\nURL: https://mariadb.com/kb/en/connection_id/ +[CONTAINS] +declaration=g1,g2 +category=Geometry Relations +description=Returns 1 or 0 to indicate whether a geometry g1 completely contains geometry\ng2. CONTAINS() is based on the original MySQL implementation and uses object\nbounding rectangles, while ST_CONTAINS() uses object shapes.\n\nThis tests the opposite relationship to Within().\n\nURL: https://mariadb.com/kb/en/contains/ +[CONV] +declaration=N,from_base,to_base +category=Numeric Functions +description=Converts numbers between different number bases. Returns a string\nrepresentation of the number N, converted from base from_base to base to_base.\n\nReturns NULL if any argument is NULL, or if the second or third argument are\nnot in the allowed range.\n\nThe argument N is interpreted as an integer, but may be specified as an\ninteger or a string. The minimum base is 2 and the maximum base is 36 (prior\nto MariaDB 11.4.0) or 62 (from MariaDB 11.4.0). If to_base is a negative\nnumber, N is regarded as a signed number. Otherwise, N is treated as unsigned.\nCONV() works with 64-bit precision.\n\nSome shortcuts for this function are also available: BIN(), OCT(), HEX(),\nUNHEX(). Also, MariaDB allows binary literal values and hexadecimal literal\nvalues.\n\nExamples\n--------\n\nSELECT CONV('a',16,2);\n+----------------+\n| CONV('a',16,2) |\n+----------------+\n| 1010 |\n+----------------+\n\nSELECT CONV('6E',18,8);\n+-----------------+\n| CONV('6E',18,8) |\n+-----------------+\n| 172 |\n+-----------------+\n\nSELECT CONV(-17,10,-18);\n+------------------+\n| CONV(-17,10,-18) |\n+------------------+\n| -H |\n+------------------+\n\nSELECT CONV(12+'10'+'10'+0xa,10,10);\n+------------------------------+\n| CONV(12+'10'+'10'+0xa,10,10) |\n+------------------------------+\n| 42 |\n+------------------------------+\n\nURL: https://mariadb.com/kb/en/conv/ +[CONVERT] +declaration=expr,type +category=String Functions +description=The CONVERT() and CAST() functions take a value of one type and produce a\nvalue of another type.\n\nThe type can be one of the following values:\n\n* BINARY\n* CHAR\n* DATE\n* DATETIME\n* DECIMAL[(M[,D])]\n* DOUBLE\n* FLOAT (from MariaDB 10.4.5)\n* INTEGER\nShort for SIGNED INTEGER\n\n* SIGNED [INTEGER]\n* UNSIGNED [INTEGER]\n* TIME\n* VARCHAR (in Oracle mode, from MariaDB 10.3)\n\nNote that in MariaDB, INT and INTEGER are the same thing.\n\nBINARY produces a string with the BINARY data type. If the optional length is\ngiven, BINARY(N) causes the cast to use no more than N bytes of the argument.\nValues shorter than the given number in bytes are padded with 0x00 bytes to\nmake them equal the length value.\n\nCHAR(N) causes the cast to use no more than the number of characters given in\nthe argument.\n\nThe main difference between the CAST() and CONVERT() is that\nCONVERT(expr,type) is ODBC syntax while CAST(expr as type) and CONVERT(...\nUSING ...) are SQL92 syntax.\n\nCONVERT() with USING is used to convert data between different character sets.\nIn MariaDB, transcoding names are the same as the corresponding character set\nnames. For example, this statement converts the string 'abc' in the default\ncharacter set to the corresponding string in the utf8 character set:\n\nSELECT CONVERT('abc' USING utf8);\n\nExamples\n--------\n\nSELECT enum_col FROM tbl_name \nORDER BY CAST(enum_col AS CHAR);\n\nConverting a BINARY to string to permit the LOWER function to work:\n\nSET @x = 'AardVark';\n ... +[CONVERT_TZ] +declaration=dt,from_tz,to_tz +category=Date and Time Functions +description=CONVERT_TZ() converts a datetime value dt from the time zone given by from_tz\nto the time zone given by to_tz and returns the resulting value.\n\nIn order to use named time zones, such as GMT, MET or Africa/Johannesburg, the\ntime_zone tables must be loaded (see mysql_tzinfo_to_sql).\n\nNo conversion will take place if the value falls outside of the supported\nTIMESTAMP range ('1970-01-01 00:00:01' to '2038-01-19 05:14:07' UTC) when\nconverted from from_tz to UTC.\n\nThis function returns NULL if the arguments are invalid (or named time zones\nhave not been loaded).\n\nSee time zones for more information.\n\nExamples\n--------\n\nSELECT CONVERT_TZ('2016-01-01 12:00:00','+00:00','+10:00');\n+-----------------------------------------------------+\n| CONVERT_TZ('2016-01-01 12:00:00','+00:00','+10:00') |\n+-----------------------------------------------------+\n| 2016-01-01 22:00:00 |\n+-----------------------------------------------------+\n\nUsing named time zones (with the time zone tables loaded):\n\nSELECT CONVERT_TZ('2016-01-01 12:00:00','GMT','Africa/Johannesburg');\n+---------------------------------------------------------------+\n| CONVERT_TZ('2016-01-01 12:00:00','GMT','Africa/Johannesburg') |\n+---------------------------------------------------------------+\n| 2016-01-01 14:00:00 |\n+---------------------------------------------------------------+\n\nThe value is out of the TIMESTAMP range, so no conversion takes place:\n\nSELECT CONVERT_TZ('1969-12-31 22:00:00','+00:00','+10:00');\n+-----------------------------------------------------+\n| CONVERT_TZ('1969-12-31 22:00:00','+00:00','+10:00') |\n+-----------------------------------------------------+\n| 1969-12-31 22:00:00 |\n+-----------------------------------------------------+\n\nURL: https://mariadb.com/kb/en/convert_tz/ +[COS] +declaration=X +category=Numeric Functions +description=Returns the cosine of X, where X is given in radians.\n\nExamples\n--------\n\nSELECT COS(PI());\n+-----------+\n| COS(PI()) |\n+-----------+\n| -1 |\n+-----------+\n\nURL: https://mariadb.com/kb/en/cos/ +[COT] +declaration=X +category=Numeric Functions +description=Returns the cotangent of X.\n\nExamples\n--------\n\nSELECT COT(42);\n+--------------------+\n| COT(42) |\n+--------------------+\n| 0.4364167060752729 |\n+--------------------+\n\nSELECT COT(12);\n+---------------------+\n| COT(12) |\n+---------------------+\n| -1.5726734063976893 |\n+---------------------+\n\nSELECT COT(0);\nERROR 1690 (22003): DOUBLE value is out of range in 'cot(0)'\n\nURL: https://mariadb.com/kb/en/cot/ +[COUNT] +declaration=expr +category=Functions and Modifiers for Use with GROUP BY +description=Returns a count of the number of non-NULL values of expr in the rows retrieved\nby a SELECT statement. The result is a BIGINT value. It is an aggregate\nfunction, and so can be used with the GROUP BY clause.\n\nCOUNT(*) counts the total number of rows in a table.\n\nCOUNT() returns 0 if there were no matching rows.\n\nCOUNT() can be used as a window function.\n\nExamples\n--------\n\nCREATE TABLE student (name CHAR(10), test CHAR(10), score TINYINT);\n\nINSERT INTO student VALUES \n ('Chun', 'SQL', 75), ('Chun', 'Tuning', 73),\n ('Esben', 'SQL', 43), ('Esben', 'Tuning', 31),\n ('Kaolin', 'SQL', 56), ('Kaolin', 'Tuning', 88),\n ('Tatiana', 'SQL', 87), ('Tatiana', 'Tuning', 83);\n\nSELECT COUNT(*) FROM student;\n+----------+\n| COUNT(*) |\n+----------+\n| 8 |\n+----------+\n\nCOUNT(DISTINCT) example:\n\nSELECT COUNT(DISTINCT (name)) FROM student;\n+------------------------+\n| COUNT(DISTINCT (name)) |\n+------------------------+\n| 4 |\n+------------------------+\n\nAs a window function\n\nCREATE OR REPLACE TABLE student_test (name CHAR(10), test CHAR(10), score\nTINYINT);\n\nINSERT INTO student_test VALUES \n ('Chun', 'SQL', 75), ('Chun', 'Tuning', 73),\n ('Esben', 'SQL', 43), ('Esben', 'Tuning', 31),\n ('Kaolin', 'SQL', 56), ('Kaolin', 'Tuning', 88),\n ('Tatiana', 'SQL', 87);\n\nSELECT name, test, score, COUNT(score) OVER (PARTITION BY name) \n AS tests_written FROM student_test;\n ... +[CRC32] +declaration=expr +category=Numeric Functions +description=Computes a cyclic redundancy check (CRC) value and returns a 32-bit unsigned\nvalue. The result is NULL if the argument is NULL. The argument is expected to\nbe a string and (if possible) is treated as one if it is not.\n\nUses the ISO 3309 polynomial that used by zlib and many others. MariaDB 10.8\nintroduced the CRC32C() function, which uses the alternate Castagnoli\npolynomia.\n\nMariaDB starting with 10.8\n--------------------------\nOften, CRC is computed in pieces. To facilitate this, MariaDB 10.8.0\nintroduced an optional parameter: CRC32('MariaDB')=CRC32(CRC32('Maria'),'DB').\n\nExamples\n--------\n\nSELECT CRC32('MariaDB');\n+------------------+\n| CRC32('MariaDB') |\n+------------------+\n| 4227209140 |\n+------------------+\n\nSELECT CRC32('mariadb');\n+------------------+\n| CRC32('mariadb') |\n+------------------+\n| 2594253378 |\n+------------------+\n\nFrom MariaDB 10.8.0\n\nSELECT CRC32(CRC32('Maria'),'DB');\n+----------------------------+\n| CRC32(CRC32('Maria'),'DB') |\n+----------------------------+\n| 4227209140 |\n+----------------------------+\n\nURL: https://mariadb.com/kb/en/crc32/ +[CRC32C] +declaration=[par,]expr +category=Numeric Functions +description=MariaDB has always included a native unary function CRC32() that computes the\nCRC-32 of a string using the ISO 3309 polynomial that used by zlib and many\nothers.\n\nInnoDB and MyRocks use a different polynomial, which was implemented in SSE4.2\ninstructions that were introduced in the Intel Nehalem microarchitecture. This\nis commonly called CRC-32C (Castagnoli).\n\nThe CRC32C function uses the Castagnoli polynomial.\n\nThis allows SELECT…INTO DUMPFILE to be used for the creation of files with\nvalid checksums, such as a logically empty InnoDB redo log file ib_logfile0\ncorresponding to a particular log sequence number.\n\nThe optional parameter allows the checksum to be computed in pieces:\nCRC32C('MariaDB')=CRC32C(CRC32C('Maria'),'DB').\n\nExamples\n--------\n\nSELECT CRC32C('MariaDB');\n+-------------------+\n| CRC32C('MariaDB') |\n+-------------------+\n| 809606978 |\n+-------------------+\n\nSELECT CRC32C(CRC32C('Maria'),'DB');\n+------------------------------+\n| CRC32C(CRC32C('Maria'),'DB') |\n+------------------------------+\n| 809606978 |\n+------------------------------+\n\nURL: https://mariadb.com/kb/en/crc32c/ +[CROSSES] +declaration=g1,g2 +category=Geometry Relations +description=Returns 1 if g1 spatially crosses g2. Returns NULL if g1 is a Polygon or a\nMultiPolygon, or if g2 is a Point or a MultiPoint. Otherwise, returns 0.\n\nThe term spatially crosses denotes a spatial relation between two given\ngeometries that has the following properties:\n\n* The two geometries intersect\n* Their intersection results in a geometry that has a dimension that is one\n less than the maximum dimension of the two given geometries\n* Their intersection is not equal to either of the two given geometries\n\nCROSSES() is based on the original MySQL implementation, and uses object\nbounding rectangles, while ST_CROSSES() uses object shapes.\n\nURL: https://mariadb.com/kb/en/crosses/ +[CUME_DIST] +declaration= +category=Window Functions +description=CUME_DIST() is a window function that returns the cumulative distribution of a\ngiven row. The following formula is used to calculate the value:\n\n(number of rows <= current row) / (total rows)\n\nExamples\n--------\n\ncreate table t1 (\n pk int primary key,\n a int,\n b int\n);\n\ninsert into t1 values\n( 1 , 0, 10),\n( 2 , 0, 10),\n( 3 , 1, 10),\n( 4 , 1, 10),\n( 8 , 2, 10),\n( 5 , 2, 20),\n( 6 , 2, 20),\n( 7 , 2, 20),\n( 9 , 4, 20),\n(10 , 4, 20);\n\nselect pk, a, b,\n rank() over (order by a) as rank,\n percent_rank() over (order by a) as pct_rank,\n cume_dist() over (order by a) as cume_dist\nfrom t1;\n+----+------+------+------+--------------+--------------+\n| pk | a | b | rank | pct_rank | cume_dist |\n+----+------+------+------+--------------+--------------+\n| 1 | 0 | 10 | 1 | 0.0000000000 | 0.2000000000 |\n| 2 | 0 | 10 | 1 | 0.0000000000 | 0.2000000000 |\n| 3 | 1 | 10 | 3 | 0.2222222222 | 0.4000000000 |\n| 4 | 1 | 10 | 3 | 0.2222222222 | 0.4000000000 |\n| 5 | 2 | 20 | 5 | 0.4444444444 | 0.8000000000 |\n| 6 | 2 | 20 | 5 | 0.4444444444 | 0.8000000000 |\n| 7 | 2 | 20 | 5 | 0.4444444444 | 0.8000000000 |\n| 8 | 2 | 10 | 5 | 0.4444444444 | 0.8000000000 |\n| 9 | 4 | 20 | 9 | 0.8888888889 | 1.0000000000 |\n| 10 | 4 | 20 | 9 | 0.8888888889 | 1.0000000000 |\n+----+------+------+------+--------------+--------------+\n\nselect pk, a, b,\n percent_rank() over (order by pk) as pct_rank,\n cume_dist() over (order by pk) as cume_dist\nfrom t1 order by pk;\n ... +[CURDATE] +declaration= +category=Date and Time Functions +description=CURDATE returns the current date as a value in 'YYYY-MM-DD' or YYYYMMDD\nformat, depending on whether the function is used in a string or numeric\ncontext.\n\nCURRENT_DATE and CURRENT_DATE() are synonyms.\n\nExamples\n--------\n\nSELECT CURDATE();\n+------------+\n| CURDATE() |\n+------------+\n| 2019-03-05 |\n+------------+\n\nIn a numeric context (note this is not performing date calculations):\n\nSELECT CURDATE() +0;\n+--------------+\n| CURDATE() +0 |\n+--------------+\n| 20190305 |\n+--------------+\n\nData calculation:\n\nSELECT CURDATE() - INTERVAL 5 DAY;\n+----------------------------+\n| CURDATE() - INTERVAL 5 DAY |\n+----------------------------+\n| 2019-02-28 |\n+----------------------------+\n\nURL: https://mariadb.com/kb/en/curdate/ +[CURRENT_DATE] +declaration= +category=Date and Time Functions +description=CURRENT_DATE and CURRENT_DATE() are synonyms for CURDATE().\n\nURL: https://mariadb.com/kb/en/current_date/ +[CURRENT_ROLE] +declaration= +category=Information Functions +description=Returns the current role name. This determines your access privileges. The\nreturn value is a string in the utf8 character set.\n\nIf there is no current role, NULL is returned.\n\nThe output of SELECT CURRENT_ROLE is equivalent to the contents of the\nENABLED_ROLES Information Schema table.\n\nUSER() returns the combination of user and host used to login. CURRENT_USER()\nreturns the account used to determine current connection's privileges.\n\nStatements using the CURRENT_ROLE function are not safe for statement-based\nreplication.\n\nExamples\n--------\n\nSELECT CURRENT_ROLE;\n+--------------+\n| CURRENT_ROLE |\n+--------------+\n| NULL |\n+--------------+\n\nSET ROLE staff;\n\nSELECT CURRENT_ROLE;\n+--------------+\n| CURRENT_ROLE |\n+--------------+\n| staff |\n+--------------+\n\nURL: https://mariadb.com/kb/en/current_role/ +[CURRENT_TIME] +declaration=[precision] +category=Date and Time Functions +description=CURRENT_TIME and CURRENT_TIME() are synonyms for CURTIME().\n\nURL: https://mariadb.com/kb/en/current_time/ +[CURRENT_TIMESTAMP] +declaration=[precision] +category=Date and Time Functions +description=CURRENT_TIMESTAMP and CURRENT_TIMESTAMP() are synonyms for NOW().\n\nURL: https://mariadb.com/kb/en/current_timestamp/ +[CURRENT_USER] +declaration= +category=Information Functions +description=Returns the user name and host name combination for the MariaDB account that\nthe server used to authenticate the current client. This account determines\nyour access privileges. The return value is a string in the utf8 character set.\n\nThe value of CURRENT_USER() can differ from the value of USER().\nCURRENT_ROLE() returns the current active role.\n\nStatements using the CURRENT_USER function are not safe for statement-based\nreplication.\n\nExamples\n--------\n\nshell> mysql --user="anonymous"\n\nselect user(),current_user();\n+---------------------+----------------+\n| user() | current_user() |\n+---------------------+----------------+\n| anonymous@localhost | @localhost |\n+---------------------+----------------+\n\nWhen calling CURRENT_USER() in a stored procedure, it returns the owner of the\nstored procedure, as defined with DEFINER.\n\nURL: https://mariadb.com/kb/en/current_user/ +[CURTIME] +declaration=[precision] +category=Date and Time Functions +description=Returns the current time as a value in 'HH:MM:SS' or HHMMSS.uuuuuu format,\ndepending on whether the function is used in a string or numeric context. The\nvalue is expressed in the current time zone.\n\nThe optional precision determines the microsecond precision. See Microseconds\nin MariaDB.\n\nExamples\n--------\n\nSELECT CURTIME();\n+-----------+\n| CURTIME() |\n+-----------+\n| 12:45:39 |\n+-----------+\n\nSELECT CURTIME() + 0;\n+---------------+\n| CURTIME() + 0 |\n+---------------+\n| 124545.000000 |\n+---------------+\n\nWith precision:\n\nSELECT CURTIME(2);\n+-------------+\n| CURTIME(2) |\n+-------------+\n| 09:49:08.09 |\n+-------------+\n\nURL: https://mariadb.com/kb/en/curtime/ +[DATABASE] +declaration= +category=Information Functions +description=Returns the default (current) database name as a string in the utf8 character\nset. If there is no default database, DATABASE() returns NULL. Within a stored\nroutine, the default database is the database that the routine is associated\nwith, which is not necessarily the same as the database that is the default in\nthe calling context.\n\nSCHEMA() is a synonym for DATABASE().\n\nTo select a default database, the USE statement can be run. Another way to set\nthe default database is specifying its name at mariadb command line client\nstartup.\n\nExamples\n--------\n\nSELECT DATABASE();\n+------------+\n| DATABASE() |\n+------------+\n| NULL |\n+------------+\n\nUSE test;\nDatabase changed\n\nSELECT DATABASE();\n+------------+\n| DATABASE() |\n+------------+\n| test |\n+------------+\n\nURL: https://mariadb.com/kb/en/database/ +[DATEDIFF] +declaration=expr1,expr2 +category=Date and Time Functions +description=DATEDIFF() returns (expr1 – expr2) expressed as a value in days from one date\nto the other. expr1 and expr2 are date or date-and-time expressions. Only the\ndate parts of the values are used in the calculation.\n\nExamples\n--------\n\nSELECT DATEDIFF('2007-12-31 23:59:59','2007-12-30');\n+----------------------------------------------+\n| DATEDIFF('2007-12-31 23:59:59','2007-12-30') |\n+----------------------------------------------+\n| 1 |\n+----------------------------------------------+\n\nSELECT DATEDIFF('2010-11-30 23:59:59','2010-12-31');\n+----------------------------------------------+\n| DATEDIFF('2010-11-30 23:59:59','2010-12-31') |\n+----------------------------------------------+\n| -31 |\n+----------------------------------------------+\n\nCREATE TABLE t1 (d DATETIME);\nINSERT INTO t1 VALUES\n ("2007-01-30 21:31:07"),\n ("1983-10-15 06:42:51"),\n ("2011-04-21 12:34:56"),\n ("2011-10-30 06:31:41"),\n ("2011-01-30 14:03:25"),\n ("2004-10-07 11:19:34");\n\nSELECT NOW();\n+---------------------+\n| NOW() |\n+---------------------+\n| 2011-05-23 10:56:05 |\n+---------------------+\n\nSELECT d, DATEDIFF(NOW(),d) FROM t1;\n+---------------------+-------------------+\n| d | DATEDIFF(NOW(),d) |\n+---------------------+-------------------+\n| 2007-01-30 21:31:07 | 1574 |\n| 1983-10-15 06:42:51 | 10082 |\n| 2011-04-21 12:34:56 | 32 |\n| 2011-10-30 06:31:41 | -160 |\n| 2011-01-30 14:03:25 | 113 |\n| 2004-10-07 11:19:34 | 2419 |\n+---------------------+-------------------+\n\nURL: https://mariadb.com/kb/en/datediff/ +[DATETIME] +declaration=microsecond precision +category=Data Types +description=A date and time combination.\n\nMariaDB displays DATETIME values in 'YYYY-MM-DD HH:MM:SS.ffffff' format, but\nallows assignment of values to DATETIME columns using either strings or\nnumbers. For details, see date and time literals.\n\nDATETIME columns also accept CURRENT_TIMESTAMP as the default value.\n\nMariaDB 10.1.2 introduced the --mysql56-temporal-format option, on by default,\nwhich allows MariaDB to store DATETMEs using the same low-level format MySQL\n5.6 uses. For more information, see Internal Format, below.\n\nFor storage requirements, see Data Type Storage Requirements.\n\nSupported Values\n----------------\n\nMariaDB stores values that use the DATETIME data type in a format that\nsupports values between 1000-01-01 00:00:00.000000 and 9999-12-31\n23:59:59.999999.\n\nMariaDB can also store microseconds with a precision between 0 and 6. If no\nmicrosecond precision is specified, then 0 is used by default.\n\nMariaDB also supports '0000-00-00' as a special zero-date value, unless\nNO_ZERO_DATE is specified in the SQL_MODE. Similarly, individual components of\na date can be set to 0 (for example: '2015-00-12'), unless NO_ZERO_IN_DATE is\nspecified in the SQL_MODE. In many cases, the result of en expression\ninvolving a zero-date, or a date with zero-parts, is NULL. If the\nALLOW_INVALID_DATES SQL_MODE is enabled, if the day part is in the range\nbetween 1 and 31, the date does not produce any error, even for months that\nhave less than 31 days.\n\nOracle Mode\n-----------\n\nMariaDB starting with 10.3\n--------------------------\nIn Oracle mode from MariaDB 10.3, DATE with a time portion is a synonym for\nDATETIME. See also mariadb_schema.\n\nInternal Format\n---------------\n\nIn MariaDB 10.1.2 a new temporal format was introduced from MySQL 5.6 that\nalters how the TIME, DATETIME and TIMESTAMP columns operate at lower levels.\nThese changes allow these temporal data types to have fractional parts and\nnegative values. You can disable this feature using the\nmysql56_temporal_format system variable.\n\n ... +[DATE_ADD] +declaration=date,INTERVAL expr unit +category=Date and Time Functions +description=Performs date arithmetic. The date argument specifies the starting date or\ndatetime value. expr is an expression specifying the interval value to be\nadded or subtracted from the starting date. expr is a string; it may start\nwith a "-" for negative intervals. unit is a keyword indicating the units in\nwhich the expression should be interpreted. See Date and Time Units for a\ncomplete list of permitted units.\n\nExamples\n--------\n\nSELECT '2008-12-31 23:59:59' + INTERVAL 1 SECOND;\n+-------------------------------------------+\n| '2008-12-31 23:59:59' + INTERVAL 1 SECOND |\n+-------------------------------------------+\n| 2009-01-01 00:00:00 |\n+-------------------------------------------+\n\nSELECT INTERVAL 1 DAY + '2008-12-31';\n+-------------------------------+\n| INTERVAL 1 DAY + '2008-12-31' |\n+-------------------------------+\n| 2009-01-01 |\n+-------------------------------+\n\nSELECT '2005-01-01' - INTERVAL 1 SECOND;\n+----------------------------------+\n| '2005-01-01' - INTERVAL 1 SECOND |\n+----------------------------------+\n| 2004-12-31 23:59:59 |\n+----------------------------------+\n\nSELECT DATE_ADD('2000-12-31 23:59:59', INTERVAL 1 SECOND);\n+----------------------------------------------------+\n| DATE_ADD('2000-12-31 23:59:59', INTERVAL 1 SECOND) |\n+----------------------------------------------------+\n| 2001-01-01 00:00:00 |\n+----------------------------------------------------+\n\nSELECT DATE_ADD('2010-12-31 23:59:59', INTERVAL 1 DAY);\n+-------------------------------------------------+\n| DATE_ADD('2010-12-31 23:59:59', INTERVAL 1 DAY) |\n+-------------------------------------------------+\n| 2011-01-01 23:59:59 |\n+-------------------------------------------------+\n\nSELECT DATE_ADD('2100-12-31 23:59:59', INTERVAL '1:1' MINUTE_SECOND);\n+---------------------------------------------------------------+\n| DATE_ADD('2100-12-31 23:59:59', INTERVAL '1:1' MINUTE_SECOND) |\n+---------------------------------------------------------------+\n| 2101-01-01 00:01:00 |\n ... +[DATE_FORMAT] +declaration=date, format[, locale] +category=Date and Time Functions +description=Formats the date value according to the format string.\n\nThe language used for the names is controlled by the value of the\nlc_time_names system variable. See server locale for more on the supported\nlocales.\n\nThe options that can be used by DATE_FORMAT(), as well as its inverse\nSTR_TO_DATE() and the FROM_UNIXTIME() function, are:\n\n+---------------------------+------------------------------------------------+\n| Option | Description |\n+---------------------------+------------------------------------------------+\n| %a | Short weekday name in current locale |\n| | (Variable lc_time_names). |\n+---------------------------+------------------------------------------------+\n| %b | Short form month name in current locale. For |\n| | locale en_US this is one of: |\n| | Jan,Feb,Mar,Apr,May,Jun,Jul,Aug,Sep,Oct,Nov |\n| | or Dec. |\n+---------------------------+------------------------------------------------+\n| %c | Month with 1 or 2 digits. |\n+---------------------------+------------------------------------------------+\n| %D | Day with English suffix 'th', 'nd', 'st' or |\n| | 'rd''. (1st, 2nd, 3rd...). |\n+---------------------------+------------------------------------------------+\n| %d | Day with 2 digits. |\n+---------------------------+------------------------------------------------+\n| %e | Day with 1 or 2 digits. |\n+---------------------------+------------------------------------------------+\n| %f | Microseconds 6 digits. |\n+---------------------------+------------------------------------------------+\n| %H | Hour with 2 digits between 00-23. |\n+---------------------------+------------------------------------------------+\n| %h | Hour with 2 digits between 01-12. |\n+---------------------------+------------------------------------------------+\n| %I | Hour with 2 digits between 01-12. |\n+---------------------------+------------------------------------------------+\n| %i | Minute with 2 digits. |\n+---------------------------+------------------------------------------------+\n| %j | Day of the year (001-366) |\n+---------------------------+------------------------------------------------+\n| %k | Hour with 1 digits between 0-23. |\n+---------------------------+------------------------------------------------+\n| %l | Hour with 1 digits between 1-12. |\n+---------------------------+------------------------------------------------+\n| %M | Full month name in current locale (Variable |\n| | lc_time_names). |\n+---------------------------+------------------------------------------------+\n| %m | Month with 2 digits. |\n+---------------------------+------------------------------------------------+\n ... +[DATE_SUB] +declaration=date,INTERVAL expr unit +category=Date and Time Functions +description=Performs date arithmetic. The date argument specifies the starting date or\ndatetime value. expr is an expression specifying the interval value to be\nadded or subtracted from the starting date. expr is a string; it may start\nwith a "-" for negative intervals. unit is a keyword indicating the units in\nwhich the expression should be interpreted. See Date and Time Units for a\ncomplete list of permitted units.\n\nSee also DATE_ADD().\n\nExamples\n--------\n\nSELECT DATE_SUB('1998-01-02', INTERVAL 31 DAY);\n+-----------------------------------------+\n| DATE_SUB('1998-01-02', INTERVAL 31 DAY) |\n+-----------------------------------------+\n| 1997-12-02 |\n+-----------------------------------------+\n\nSELECT DATE_SUB('2005-01-01 00:00:00', INTERVAL '1 1:1:1' DAY_SECOND);\n+----------------------------------------------------------------+\n| DATE_SUB('2005-01-01 00:00:00', INTERVAL '1 1:1:1' DAY_SECOND) |\n+----------------------------------------------------------------+\n| 2004-12-30 22:58:59 |\n+----------------------------------------------------------------+\n\nURL: https://mariadb.com/kb/en/date_sub/ +[DAY] +declaration=date +category=Date and Time Functions +description=DAY() is a synonym for DAYOFMONTH().\n\nURL: https://mariadb.com/kb/en/day/ +[DAYNAME] +declaration=date +category=Date and Time Functions +description=Returns the name of the weekday for date. The language used for the name is\ncontrolled by the value of the lc_time_names system variable. See server\nlocale for more on the supported locales.\n\nExamples\n--------\n\nSELECT DAYNAME('2007-02-03');\n+-----------------------+\n| DAYNAME('2007-02-03') |\n+-----------------------+\n| Saturday |\n+-----------------------+\n\nCREATE TABLE t1 (d DATETIME);\nINSERT INTO t1 VALUES\n ("2007-01-30 21:31:07"),\n ("1983-10-15 06:42:51"),\n ("2011-04-21 12:34:56"),\n ("2011-10-30 06:31:41"),\n ("2011-01-30 14:03:25"),\n ("2004-10-07 11:19:34");\n\nSELECT d, DAYNAME(d) FROM t1;\n+---------------------+------------+\n| d | DAYNAME(d) |\n+---------------------+------------+\n| 2007-01-30 21:31:07 | Tuesday |\n| 1983-10-15 06:42:51 | Saturday |\n| 2011-04-21 12:34:56 | Thursday |\n| 2011-10-30 06:31:41 | Sunday |\n| 2011-01-30 14:03:25 | Sunday |\n| 2004-10-07 11:19:34 | Thursday |\n+---------------------+------------+\n\nChanging the locale:\n\nSET lc_time_names = 'fr_CA';\n\nSELECT DAYNAME('2013-04-01');\n+-----------------------+\n| DAYNAME('2013-04-01') |\n+-----------------------+\n| lundi |\n+-----------------------+\n\nURL: https://mariadb.com/kb/en/dayname/ +[DAYOFMONTH] +declaration=date +category=Date and Time Functions +description=Returns the day of the month for date, in the range 1 to 31, or 0 for dates\nsuch as '0000-00-00' or '2008-00-00' which have a zero day part.\n\nDAY() is a synonym.\n\nExamples\n--------\n\nSELECT DAYOFMONTH('2007-02-03');\n+--------------------------+\n| DAYOFMONTH('2007-02-03') |\n+--------------------------+\n| 3 |\n+--------------------------+\n\nCREATE TABLE t1 (d DATETIME);\nINSERT INTO t1 VALUES\n ("2007-01-30 21:31:07"),\n ("1983-10-15 06:42:51"),\n ("2011-04-21 12:34:56"),\n ("2011-10-30 06:31:41"),\n ("2011-01-30 14:03:25"),\n ("2004-10-07 11:19:34");\n\nSELECT d FROM t1 where DAYOFMONTH(d) = 30;\n+---------------------+\n| d |\n+---------------------+\n| 2007-01-30 21:31:07 |\n| 2011-10-30 06:31:41 |\n| 2011-01-30 14:03:25 |\n+---------------------+\n\nURL: https://mariadb.com/kb/en/dayofmonth/ +[DAYOFWEEK] +declaration=date +category=Date and Time Functions +description=Returns the day of the week index for the date (1 = Sunday, 2 = Monday, ..., 7\n= Saturday). These index values correspond to the ODBC standard.\n\nThis contrasts with WEEKDAY() which follows a different index numbering (0 =\nMonday, 1 = Tuesday, ... 6 = Sunday).\n\nExamples\n--------\n\nSELECT DAYOFWEEK('2007-02-03');\n+-------------------------+\n| DAYOFWEEK('2007-02-03') |\n+-------------------------+\n| 7 |\n+-------------------------+\n\nCREATE TABLE t1 (d DATETIME);\nINSERT INTO t1 VALUES\n ("2007-01-30 21:31:07"),\n ("1983-10-15 06:42:51"),\n ("2011-04-21 12:34:56"),\n ("2011-10-30 06:31:41"),\n ("2011-01-30 14:03:25"),\n ("2004-10-07 11:19:34");\n\nSELECT d, DAYNAME(d), DAYOFWEEK(d), WEEKDAY(d) from t1;\n+---------------------+------------+--------------+------------+\n| d | DAYNAME(d) | DAYOFWEEK(d) | WEEKDAY(d) |\n+---------------------+------------+--------------+------------+\n| 2007-01-30 21:31:07 | Tuesday | 3 | 1 |\n| 1983-10-15 06:42:51 | Saturday | 7 | 5 |\n| 2011-04-21 12:34:56 | Thursday | 5 | 3 |\n| 2011-10-30 06:31:41 | Sunday | 1 | 6 |\n| 2011-01-30 14:03:25 | Sunday | 1 | 6 |\n| 2004-10-07 11:19:34 | Thursday | 5 | 3 |\n+---------------------+------------+--------------+------------+\n\nURL: https://mariadb.com/kb/en/dayofweek/ +[DAYOFYEAR] +declaration=date +category=Date and Time Functions +description=Returns the day of the year for date, in the range 1 to 366.\n\nExamples\n--------\n\nSELECT DAYOFYEAR('2018-02-16');\n+-------------------------+\n| DAYOFYEAR('2018-02-16') |\n+-------------------------+\n| 47 |\n+-------------------------+\n\nURL: https://mariadb.com/kb/en/dayofyear/ +[DECIMAL] +declaration=M[,D] +category=Data Types +description=A packed "exact" fixed-point number. M is the total number of digits (the\nprecision) and D is the number of digits after the decimal point (the scale).\n\n* The decimal point and (for negative numbers) the "-" sign are not\ncounted in M. \n* If D is 0, values have no decimal point or fractional\npart and on INSERT the value will be rounded to the nearest DECIMAL. \n* The maximum number of digits (M) for DECIMAL is 65. \n* The maximum number of supported decimals (D) is 30 before MariadB 10.2.1 and\n38 afterwards. \n* If D is omitted, the default is 0. If M is omitted, the default is 10.\n\nUNSIGNED, if specified, disallows negative values.\n\nZEROFILL, if specified, pads the number with zeros, up to the total number of\ndigits specified by M.\n\nAll basic calculations (+, -, *, /) with DECIMAL columns are done with a\nprecision of 65 digits.\n\nFor more details on the attributes, see Numeric Data Type Overview.\n\nDEC, NUMERIC and FIXED are synonyms, as well as NUMBER in Oracle mode from\nMariaDB 10.3.\n\nExamples\n--------\n\nCREATE TABLE t1 (d DECIMAL UNSIGNED ZEROFILL);\n\nINSERT INTO t1 VALUES (1),(2),(3),(4.0),(5.2),(5.7);\nQuery OK, 6 rows affected, 2 warnings (0.16 sec)\nRecords: 6 Duplicates: 0 Warnings: 2\n\nNote (Code 1265): Data truncated for column 'd' at row 5\nNote (Code 1265): Data truncated for column 'd' at row 6\n\nSELECT * FROM t1;\n+------------+\n| d |\n+------------+\n| 0000000001 |\n| 0000000002 |\n| 0000000003 |\n| 0000000004 |\n| 0000000005 |\n| 0000000006 |\n+------------+\n\nWith strict_mode set, the default from MariaDB 10.2.4:\n ... +[DECODE] +declaration=crypt_str,pass_str +category=Encryption Functions +description=In the default mode, DECODE decrypts the encrypted string crypt_str using\npass_str as the password. crypt_str should be a string returned from ENCODE().\nThe resulting string will be the original string only if pass_str is the same.\n\nIn Oracle mode from MariaDB 10.3.2, DECODE compares expr to the search\nexpressions, in order. If it finds a match, the corresponding result\nexpression is returned. If no matches are found, the default expression is\nreturned, or NULL if no default is provided.\n\nNULLs are treated as equivalent.\n\nDECODE_ORACLE is a synonym for the Oracle-mode version of the function, and is\navailable in all modes.\n\nExamples\n--------\n\nFrom MariaDB 10.3.2:\n\nSELECT DECODE_ORACLE(2+1,3*1,'found1',3*2,'found2','default');\n+--------------------------------------------------------+\n| DECODE_ORACLE(2+1,3*1,'found1',3*2,'found2','default') |\n+--------------------------------------------------------+\n| found1 |\n+--------------------------------------------------------+\n\nSELECT DECODE_ORACLE(2+4,3*1,'found1',3*2,'found2','default');\n+--------------------------------------------------------+\n| DECODE_ORACLE(2+4,3*1,'found1',3*2,'found2','default') |\n+--------------------------------------------------------+\n| found2 |\n+--------------------------------------------------------+\n\nSELECT DECODE_ORACLE(2+2,3*1,'found1',3*2,'found2','default');\n+--------------------------------------------------------+\n| DECODE_ORACLE(2+2,3*1,'found1',3*2,'found2','default') |\n+--------------------------------------------------------+\n| default |\n+--------------------------------------------------------+\n\nNulls are treated as equivalent:\n\nSELECT DECODE_ORACLE(NULL,NULL,'Nulls are equivalent','Nulls are not\nequivalent');\n+----------------------------------------------------------------------------+\n| DECODE_ORACLE(NULL,NULL,'Nulls are equivalent','Nulls are not equivalent') |\n+----------------------------------------------------------------------------+\n| Nulls are equivalent |\n+----------------------------------------------------------------------------+\n\nURL: https://mariadb.com/kb/en/decode/ +[DECODE_HISTOGRAM] +declaration=hist_type,histogram +category=Information Functions +description=Returns a string of comma separated numeric values corresponding to a\nprobability distribution represented by the histogram of type hist_type\n(SINGLE_PREC_HB or DOUBLE_PREC_HB). The hist_type and histogram would be\ncommonly used from the mysql.column_stats table.\n\nSee Histogram Based Statistics for details.\n\nExamples\n--------\n\nCREATE TABLE origin (\n i INT UNSIGNED NOT NULL AUTO_INCREMENT PRIMARY KEY,\n v INT UNSIGNED NOT NULL\n);\n\nINSERT INTO origin(v) VALUES \n (1),(2),(3),(4),(5),(10),(20),\n (30),(40),(50),(60),(70),(80),\n (90),(100),(200),(400),(800);\n\nSET histogram_size=10,histogram_type=SINGLE_PREC_HB;\n\nANALYZE TABLE origin PERSISTENT FOR ALL;\n+-------------+---------+----------+-----------------------------------------+\n| Table | Op | Msg_type | Msg_text |\n+-------------+---------+----------+-----------------------------------------+\n| test.origin | analyze | status | Engine-independent statistics collected |\n| test.origin | analyze | status | OK |\n+-------------+---------+----------+-----------------------------------------+\n\nSELECT db_name,table_name,column_name,hist_type,\n hex(histogram),decode_histogram(hist_type,histogram)\n FROM mysql.column_stats WHERE db_name='test' and table_name='origin';\n+---------+------------+-------------+----------------+----------------------+-\n-----------------------------------------------------------------+\n| db_name | table_name | column_name | hist_type | hex(histogram) |\ndecode_histogram(hist_type,histogram) |\n+---------+------------+-------------+----------------+----------------------+-\n-----------------------------------------------------------------+\n| test | origin | i | SINGLE_PREC_HB | 0F2D3C5A7887A5C3D2F0 |\n0.059,0.118,0.059,0.118,0.118,0.059,0.118,0.118,0.059,0.118,0.059 |\n| test | origin | v | SINGLE_PREC_HB | 000001060C0F161C1F7F |\n0.000,0.000,0.004,0.020,0.024,0.012,0.027,0.024,0.012,0.376,0.502 |\n+---------+------------+-------------+----------------+----------------------+-\n-----------------------------------------------------------------+\n\nSET histogram_size=20,histogram_type=DOUBLE_PREC_HB;\n\nANALYZE TABLE origin PERSISTENT FOR ALL;\n+-------------+---------+----------+-----------------------------------------+\n ... +[DEFAULT] +declaration=col_name +category=Information Functions +description=Returns the default value for a table column. If the column has no default\nvalue (and is not NULLABLE - NULLABLE fields have a NULL default), an error is\nreturned.\n\nFor integer columns using AUTO_INCREMENT, 0 is returned.\n\nWhen using DEFAULT as a value to set in an INSERT or UPDATE statement, you can\nuse the bare keyword DEFAULT without the parentheses and argument to refer to\nthe column in context. You can only use DEFAULT as a bare keyword if you are\nusing it alone without a surrounding expression or function.\n\nExamples\n--------\n\nSelect only non-default values for a column:\n\nSELECT i FROM t WHERE i != DEFAULT(i);\n\nUpdate values to be one greater than the default value:\n\nUPDATE t SET i = DEFAULT(i)+1 WHERE i < 100;\n\nWhen referring to the default value exactly in UPDATE or INSERT, you can omit\nthe argument:\n\nINSERT INTO t (i) VALUES (DEFAULT);\nUPDATE t SET i = DEFAULT WHERE i < 100;\n\nCREATE OR REPLACE TABLE t (\n i INT NOT NULL AUTO_INCREMENT,\n j INT NOT NULL,\n k INT DEFAULT 3,\n l INT NOT NULL DEFAULT 4,\n m INT,\n PRIMARY KEY (i)\n);\n\nDESC t;\n+-------+---------+------+-----+---------+----------------+\n| Field | Type | Null | Key | Default | Extra |\n+-------+---------+------+-----+---------+----------------+\n| i | int(11) | NO | PRI | NULL | auto_increment |\n| j | int(11) | NO | | NULL | |\n| k | int(11) | YES | | 3 | |\n| l | int(11) | NO | | 4 | |\n| m | int(11) | YES | | NULL | |\n+-------+---------+------+-----+---------+----------------+\n\nINSERT INTO t (j) VALUES (1);\nINSERT INTO t (j,m) VALUES (2,2);\n ... +[DEGREES] +declaration=X +category=Numeric Functions +description=Returns the argument X, converted from radians to degrees.\n\nThis is the converse of the RADIANS() function.\n\nExamples\n--------\n\nSELECT DEGREES(PI());\n+---------------+\n| DEGREES(PI()) |\n+---------------+\n| 180 |\n+---------------+\n\nSELECT DEGREES(PI() / 2);\n+-------------------+\n| DEGREES(PI() / 2) |\n+-------------------+\n| 90 |\n+-------------------+\n\nSELECT DEGREES(45);\n+-----------------+\n| DEGREES(45) |\n+-----------------+\n| 2578.3100780887 |\n+-----------------+\n\nURL: https://mariadb.com/kb/en/degrees/ +[DENSE_RANK] +declaration= +category=Window Functions +description=DENSE_RANK() is a window function that displays the number of a given row,\nstarting at one and following the ORDER BY sequence of the window function,\nwith identical values receiving the same result. Unlike the RANK() function,\nthere are no skipped values if the preceding results are identical. It is also\nsimilar to the ROW_NUMBER() function except that in that function, identical\nvalues will receive a different row number for each result.\n\nExamples\n--------\n\nThe distinction between DENSE_RANK(), RANK() and ROW_NUMBER():\n\nCREATE TABLE student(course VARCHAR(10), mark int, name varchar(10));\n\nINSERT INTO student VALUES \n ('Maths', 60, 'Thulile'),\n ('Maths', 60, 'Pritha'),\n ('Maths', 70, 'Voitto'),\n ('Maths', 55, 'Chun'),\n ('Biology', 60, 'Bilal'),\n ('Biology', 70, 'Roger');\n\nSELECT \n RANK() OVER (PARTITION BY course ORDER BY mark DESC) AS rank,\n DENSE_RANK() OVER (PARTITION BY course ORDER BY mark DESC) AS dense_rank,\n ROW_NUMBER() OVER (PARTITION BY course ORDER BY mark DESC) AS row_num,\n course, mark, name\nFROM student ORDER BY course, mark DESC;\n+------+------------+---------+---------+------+---------+\n| rank | dense_rank | row_num | course | mark | name |\n+------+------------+---------+---------+------+---------+\n| 1 | 1 | 1 | Biology | 70 | Roger |\n| 2 | 2 | 2 | Biology | 60 | Bilal |\n| 1 | 1 | 1 | Maths | 70 | Voitto |\n| 2 | 2 | 2 | Maths | 60 | Thulile |\n| 2 | 2 | 3 | Maths | 60 | Pritha |\n| 4 | 3 | 4 | Maths | 55 | Chun |\n+------+------------+---------+---------+------+---------+\n\nURL: https://mariadb.com/kb/en/dense_rank/ +[DES_DECRYPT] +declaration=crypt_str[,key_str] +category=Encryption Functions +description=Decrypts a string encrypted with DES_ENCRYPT(). If an error occurs, this\nfunction returns NULL.\n\nThis function works only if MariaDB has been configured with TLS support.\n\nIf no key_str argument is given, DES_DECRYPT() examines the first byte of the\nencrypted string to determine the DES key number that was used to encrypt the\noriginal string, and then reads the key from the DES key file to decrypt the\nmessage. For this to work, the user must have the SUPER privilege. The key\nfile can be specified with the --des-key-file server option.\n\nIf you pass this function a key_str argument, that string is used as the key\nfor decrypting the message.\n\nIf the crypt_str argument does not appear to be an encrypted string, MariaDB\nreturns the given crypt_str.\n\nURL: https://mariadb.com/kb/en/des_decrypt/ +[DES_ENCRYPT] +declaration=str[,{key_num|key_str}] +category=Encryption Functions +description=Encrypts the string with the given key using the Triple-DES algorithm.\n\nThis function works only if MariaDB has been configured with TLS support.\n\nThe encryption key to use is chosen based on the second argument to\nDES_ENCRYPT(), if one was given. With no argument, the first key from the DES\nkey file is used. With a key_num argument, the given key number (0-9) from the\nDES key file is used. With a key_str argument, the given key string is used to\nencrypt str.\n\nThe key file can be specified with the --des-key-file server option.\n\nThe return string is a binary string where the first character is CHAR(128 |\nkey_num). If an error occurs, DES_ENCRYPT() returns NULL.\n\nThe 128 is added to make it easier to recognize an encrypted key. If you use a\nstring key, key_num is 127.\n\nThe string length for the result is given by this formula:\n\nnew_len = orig_len + (8 - (orig_len % 8)) + 1\n\nEach line in the DES key file has the following format:\n\nkey_num des_key_str\n\nEach key_num value must be a number in the range from 0 to 9. Lines in the\nfile may be in any order. des_key_str is the string that is used to encrypt\nthe message. There should be at least one space between the number and the\nkey. The first key is the default key that is used if you do not specify any\nkey argument to DES_ENCRYPT().\n\nYou can tell MariaDB to read new key values from the key file with the FLUSH\nDES_KEY_FILE statement. This requires the RELOAD privilege.\n\nOne benefit of having a set of default keys is that it gives applications a\nway to check for the existence of encrypted column values, without giving the\nend user the right to decrypt those values.\n\nExamples\n--------\n\nSELECT customer_address FROM customer_table \n WHERE crypted_credit_card = DES_ENCRYPT('credit_card_number');\n\nURL: https://mariadb.com/kb/en/des_encrypt/ +[DISJOINT] +declaration=g1,g2 +category=Geometry Relations +description=Returns 1 or 0 to indicate whether g1 is spatially disjoint from (does not\nintersect) g2.\n\nDISJOINT() tests the opposite relationship to INTERSECTS().\n\nDISJOINT() is based on the original MySQL implementation and uses object\nbounding rectangles, while ST_DISJOINT() uses object shapes.\n\nURL: https://mariadb.com/kb/en/disjoint/ +[DOUBLE] +declaration=M,D +category=Data Types +description=A normal-size (double-precision) floating-point number (see FLOAT for a\nsingle-precision floating-point number).\n\nAllowable values are:\n\n* -1.7976931348623157E+308 to -2.2250738585072014E-308\n* 0\n* 2.2250738585072014E-308 to 1.7976931348623157E+308\n\nThese are the theoretical limits, based on the IEEE standard. The actual range\nmight be slightly smaller depending on your hardware or operating system.\n\nM is the total number of digits and D is the number of digits following the\ndecimal point. If M and D are omitted, values are stored to the limits allowed\nby the hardware. A double-precision floating-point number is accurate to\napproximately 15 decimal places.\n\nUNSIGNED, if specified, disallows negative values.\n\nZEROFILL, if specified, pads the number with zeros, up to the total number of\ndigits specified by M.\n\nREAL and DOUBLE PRECISION are synonyms, unless the REAL_AS_FLOAT SQL mode is\nenabled, in which case REAL is a synonym for FLOAT rather than DOUBLE.\n\nSee Floating Point Accuracy for issues when using floating-point numbers.\n\nFor more details on the attributes, see Numeric Data Type Overview.\n\nExamples\n--------\n\nCREATE TABLE t1 (d DOUBLE(5,0) zerofill);\n\nINSERT INTO t1 VALUES (1),(2),(3),(4);\n\nSELECT * FROM t1;\n+-------+\n| d |\n+-------+\n| 00001 |\n| 00002 |\n| 00003 |\n| 00004 |\n+-------+\n\nURL: https://mariadb.com/kb/en/double/ +[ELT] +declaration=N, str1[, str2, str3,...] +category=String Functions +description=Takes a numeric argument and a series of string arguments. Returns the string\nthat corresponds to the given numeric position. For instance, it returns str1\nif N is 1, str2 if N is 2, and so on. If the numeric argument is a FLOAT,\nMariaDB rounds it to the nearest INTEGER. If the numeric argument is less than\n1, greater than the total number of arguments, or not a number, ELT() returns\nNULL. It must have at least two arguments.\n\nIt is complementary to the FIELD() function.\n\nExamples\n--------\n\nSELECT ELT(1, 'ej', 'Heja', 'hej', 'foo');\n+------------------------------------+\n| ELT(1, 'ej', 'Heja', 'hej', 'foo') |\n+------------------------------------+\n| ej |\n+------------------------------------+\n\nSELECT ELT(4, 'ej', 'Heja', 'hej', 'foo');\n+------------------------------------+\n| ELT(4, 'ej', 'Heja', 'hej', 'foo') |\n+------------------------------------+\n| foo |\n+------------------------------------+\n\nURL: https://mariadb.com/kb/en/elt/ +[ENCODE] +declaration=str,pass_str +category=Encryption Functions +description=ENCODE is not considered cryptographically secure, and should not be used for\npassword encryption.\n\nEncrypt str using pass_str as the password. To decrypt the result, use\nDECODE().\n\nThe result is a binary string of the same length as str.\n\nThe strength of the encryption is based on how good the random generator is.\n\nIt is not recommended to rely on the encryption performed by the ENCODE\nfunction. Using a salt value (changed when a password is updated) will improve\nmatters somewhat, but for storing passwords, consider a more cryptographically\nsecure function, such as SHA2().\n\nExamples\n--------\n\nENCODE('not so secret text', CONCAT('random_salt','password'))\n\nURL: https://mariadb.com/kb/en/encode/ +[ENCRYPT] +declaration=str[,salt] +category=Encryption Functions +description=Encrypts a string using the Unix crypt() system call, returning an encrypted\nbinary string. The salt argument should be a string with at least two\ncharacters or the returned result will be NULL. If no salt argument is given,\na random value of sufficient length is used.\n\nIt is not recommended to use ENCRYPT() with utf16, utf32 or ucs2 multi-byte\ncharacter sets because the crypt() system call expects a string terminated\nwith a zero byte.\n\nNote that the underlying crypt() system call may have some limitations, such\nas ignoring all but the first eight characters.\n\nIf the have_crypt system variable is set to NO (because the crypt() system\ncall is not available), the ENCRYPT function will always return NULL.\n\nExamples\n--------\n\nSELECT ENCRYPT('encrypt me');\n+-----------------------+\n| ENCRYPT('encrypt me') |\n+-----------------------+\n| 4I5BsEx0lqTDk |\n+-----------------------+\n\nURL: https://mariadb.com/kb/en/encrypt/ +[ENUM] +declaration='value1','value2',... +category=Data Types +description=An enumeration. A string object that can have only one value, chosen from the\nlist of values 'value1', 'value2', ..., NULL or the special '' error value. In\ntheory, an ENUM column can have a maximum of 65,535 distinct values; in\npractice, the real maximum depends on many factors. ENUM values are\nrepresented internally as integers.\n\nTrailing spaces are automatically stripped from ENUM values on table creation.\n\nENUMs require relatively little storage space compared to strings, either one\nor two bytes depending on the number of enumeration values.\n\nNULL and empty values\n---------------------\n\nAn ENUM can also contain NULL and empty values. If the ENUM column is declared\nto permit NULL values, NULL becomes a valid value, as well as the default\nvalue (see below). If strict SQL Mode is not enabled, and an invalid value is\ninserted into an ENUM, a special empty string, with an index value of zero\n(see Numeric index, below), is inserted, with a warning. This may be\nconfusing, because the empty string is also a possible value, and the only\ndifference if that is this case its index is not 0. Inserting will fail with\nan error if strict mode is active.\n\nIf a DEFAULT clause is missing, the default value will be:\n\n* NULL if the column is nullable;\n* otherwise, the first value in the enumeration.\n\nNumeric index\n-------------\n\nENUM values are indexed numerically in the order they are defined, and sorting\nwill be performed in this numeric order. We suggest not using ENUM to store\nnumerals, as there is little to no storage space benefit, and it is easy to\nconfuse the enum integer with the enum numeral value by leaving out the quotes.\n\nAn ENUM defined as ENUM('apple','orange','pear') would have the following\nindex values:\n\n+--------------------------------------+--------------------------------------+\n| Index | Value |\n+--------------------------------------+--------------------------------------+\n| NULL | NULL |\n+--------------------------------------+--------------------------------------+\n| 0 | '' |\n+--------------------------------------+--------------------------------------+\n| 1 | 'apple' |\n+--------------------------------------+--------------------------------------+\n| 2 | 'orange' |\n+--------------------------------------+--------------------------------------+\n ... +[EQUALS] +declaration=g1,g2 +category=Geometry Relations +description=Returns 1 or 0 to indicate whether g1 is spatially equal to g2.\n\nEQUALS() is based on the original MySQL implementation and uses object\nbounding rectangles, while ST_EQUALS() uses object shapes.\n\nFrom MariaDB 10.2.3, MBREQUALS is a synonym for Equals.\n\nURL: https://mariadb.com/kb/en/equals/ +[EXCEPT] +declaration=SELECT c_name AS name, email FROM employees +category=Data Manipulation +description=Difference between UNION, EXCEPT and INTERSECT. INTERSECT ALL and EXCEPT ALL\nare available from MariaDB 10.5.0.\n\nCREATE TABLE seqs (i INT);\nINSERT INTO seqs VALUES (1),(2),(2),(3),(3),(4),(5),(6);\n\nSELECT i FROM seqs WHERE i <= 3 UNION SELECT i FROM seqs WHERE i>=3;\n+------+\n| i |\n+------+\n| 1 |\n| 2 |\n| 3 |\n| 4 |\n| 5 |\n| 6 |\n+------+\n\nSELECT i FROM seqs WHERE i <= 3 UNION ALL SELECT i FROM seqs WHERE i>=3;\n+------+\n| i |\n+------+\n| 1 |\n| 2 |\n| 2 |\n| 3 |\n| 3 |\n| 3 |\n| 3 |\n| 4 |\n| 5 |\n| 6 |\n+------+\n\nSELECT i FROM seqs WHERE i <= 3 EXCEPT SELECT i FROM seqs WHERE i>=3;\n+------+\n| i |\n+------+\n| 1 |\n| 2 |\n+------+\n\nSELECT i FROM seqs WHERE i <= 3 EXCEPT ALL SELECT i FROM seqs WHERE i>=3;\n+------+\n| i |\n+------+\n| 1 |\n| 2 |\n| 2 |\n+------+\n ... +[EXP] +declaration=X +category=Numeric Functions +description=Returns the value of e (the base of natural logarithms) raised to the power of\nX. The inverse of this function is LOG() (using a single argument only) or\nLN().\n\nIf X is NULL, this function returns NULL.\n\nExamples\n--------\n\nSELECT EXP(2);\n+------------------+\n| EXP(2) |\n+------------------+\n| 7.38905609893065 |\n+------------------+\n\nSELECT EXP(-2);\n+--------------------+\n| EXP(-2) |\n+--------------------+\n| 0.1353352832366127 |\n+--------------------+\n\nSELECT EXP(0);\n+--------+\n| EXP(0) |\n+--------+\n| 1 |\n+--------+\n\nSELECT EXP(NULL);\n+-----------+\n| EXP(NULL) |\n+-----------+\n| NULL |\n+-----------+\n\nURL: https://mariadb.com/kb/en/exp/ +[EXPORT_SET] +declaration=bits, on, off[, separator[, number_of_bits]] +category=String Functions +description=Takes a minimum of three arguments. Returns a string where each bit in the\ngiven bits argument is returned, with the string values given for on and off.\n\nBits are examined from right to left, (from low-order to high-order bits).\nStrings are added to the result from left to right, separated by a separator\nstring (defaults as ','). You can optionally limit the number of bits the\nEXPORT_SET() function examines using the number_of_bits option.\n\nIf any of the arguments are set as NULL, the function returns NULL.\n\nExamples\n--------\n\nSELECT EXPORT_SET(5,'Y','N',',',4);\n+-----------------------------+\n| EXPORT_SET(5,'Y','N',',',4) |\n+-----------------------------+\n| Y,N,Y,N |\n+-----------------------------+\n\nSELECT EXPORT_SET(6,'1','0',',',10);\n+------------------------------+\n| EXPORT_SET(6,'1','0',',',10) |\n+------------------------------+\n| 0,1,1,0,0,0,0,0,0,0 |\n+------------------------------+\n\nURL: https://mariadb.com/kb/en/export_set/ +[EXTRACT] +declaration=unit FROM date +category=Date and Time Functions +description=The EXTRACT() function extracts the required unit from the date. See Date and\nTime Units for a complete list of permitted units.\n\nIn MariaDB 10.0.7 and MariaDB 5.5.35, EXTRACT (HOUR FROM ...) was changed to\nreturn a value from 0 to 23, adhering to the SQL standard. Until MariaDB\n10.0.6 and MariaDB 5.5.34, and in all versions of MySQL at least as of MySQL\n5.7, it could return a value > 23. HOUR() is not a standard function, so\ncontinues to adhere to the old behaviour inherited from MySQL.\n\nExamples\n--------\n\nSELECT EXTRACT(YEAR FROM '2009-07-02');\n+---------------------------------+\n| EXTRACT(YEAR FROM '2009-07-02') |\n+---------------------------------+\n| 2009 |\n+---------------------------------+\n\nSELECT EXTRACT(YEAR_MONTH FROM '2009-07-02 01:02:03');\n+------------------------------------------------+\n| EXTRACT(YEAR_MONTH FROM '2009-07-02 01:02:03') |\n+------------------------------------------------+\n| 200907 |\n+------------------------------------------------+\n\nSELECT EXTRACT(DAY_MINUTE FROM '2009-07-02 01:02:03');\n+------------------------------------------------+\n| EXTRACT(DAY_MINUTE FROM '2009-07-02 01:02:03') |\n+------------------------------------------------+\n| 20102 |\n+------------------------------------------------+\n\nSELECT EXTRACT(MICROSECOND FROM '2003-01-02 10:30:00.000123');\n+--------------------------------------------------------+\n| EXTRACT(MICROSECOND FROM '2003-01-02 10:30:00.000123') |\n+--------------------------------------------------------+\n| 123 |\n+--------------------------------------------------------+\n\nFrom MariaDB 10.0.7 and MariaDB 5.5.35, EXTRACT (HOUR FROM...) returns a value\nfrom 0 to 23, as per the SQL standard. HOUR is not a standard function, so\ncontinues to adhere to the old behaviour inherited from MySQL.\n\nSELECT EXTRACT(HOUR FROM '26:30:00'), HOUR('26:30:00');\n+-------------------------------+------------------+\n| EXTRACT(HOUR FROM '26:30:00') | HOUR('26:30:00') |\n+-------------------------------+------------------+\n| 2 | 26 |\n+-------------------------------+------------------+\n\nURL: https://mariadb.com/kb/en/extract/ +[EXTRACTVALUE] +declaration=xml_frag, xpath_expr +category=String Functions +description=The EXTRACTVALUE() function takes two string arguments: a fragment of XML\nmarkup and an XPath expression, (also known as a locator). It returns the text\n(That is, CDDATA), of the first text node which is a child of the element or\nelements matching the XPath expression.\n\nIn cases where a valid XPath expression does not match any text nodes in a\nvalid XML fragment, (including the implicit /text() expression), the\nEXTRACTVALUE() function returns an empty string.\n\nInvalid Arguments\n-----------------\n\nWhen either the XML fragment or the XPath expression is NULL, the\nEXTRACTVALUE() function returns NULL. When the XML fragment is invalid, it\nraises a warning Code 1525:\n\nWarning (Code 1525): Incorrect XML value: 'parse error at line 1 pos 11:\nunexpected END-OF-INPUT'\n\nWhen the XPath value is invalid, it generates an Error 1105:\n\nERROR 1105 (HY000): XPATH syntax error: ')'\n\nExplicit text() Expressions\n---------------------------\n\nThis function is the equivalent of performing a match using the XPath\nexpression after appending /text(). In other words:\n\nSELECT\n EXTRACTVALUE('example', '/cases/case')\n AS 'Base Example',\n EXTRACTVALUE('example', '/cases/case/text()')\n AS 'text() Example';\n+--------------+----------------+\n| Base Example | text() Example |\n+--------------+----------------+\n| example | example |\n+--------------+----------------+\n\nCount Matches\n-------------\n\nWhen EXTRACTVALUE() returns multiple matches, it returns the content of the\nfirst child text node of each matching element, in the matched order, as a\nsingle, space-delimited string.\n\nBy design, the EXTRACTVALUE() function makes no distinction between a match on\nan empty element and no match at all. If you need to determine whether no\nmatching element was found in the XML fragment or if an element was found that\n ... +[FIELD] +declaration=pattern, str1[,str2,...] +category=String Functions +description=Returns the index position of the string or number matching the given pattern.\nReturns 0 in the event that none of the arguments match the pattern. Raises an\nError 1582 if not given at least two arguments.\n\nWhen all arguments given to the FIELD() function are strings, they are treated\nas case-insensitive. When all the arguments are numbers, they are treated as\nnumbers. Otherwise, they are treated as doubles.\n\nIf the given pattern occurs more than once, the FIELD() function only returns\nthe index of the first instance. If the given pattern is NULL, the function\nreturns 0, as a NULL pattern always fails to match.\n\nThis function is complementary to the ELT() function.\n\nExamples\n--------\n\nSELECT FIELD('ej', 'Hej', 'ej', 'Heja', 'hej', 'foo') \n AS 'Field Results';\n+---------------+\n| Field Results | \n+---------------+\n| 2 |\n+---------------+\n\nSELECT FIELD('fo', 'Hej', 'ej', 'Heja', 'hej', 'foo')\n AS 'Field Results';\n+---------------+\n| Field Results | \n+---------------+\n| 0 |\n+---------------+\n\nSELECT FIELD(1, 2, 3, 4, 5, 1) AS 'Field Results';\n+---------------+\n| Field Results |\n+---------------+\n| 5 |\n+---------------+\n\nSELECT FIELD(NULL, 2, 3) AS 'Field Results';\n+---------------+\n| Field Results |\n+---------------+\n| 0 |\n+---------------+\n\nSELECT FIELD('fail') AS 'Field Results';\nError 1582 (42000): Incorrect parameter count in call\nto native function 'field'\n\nURL: https://mariadb.com/kb/en/field/ +[FIND_IN_SET] +declaration=pattern, strlist +category=String Functions +description=Returns the index position where the given pattern occurs in a string list.\nThe first argument is the pattern you want to search for. The second argument\nis a string containing comma-separated variables. If the second argument is of\nthe SET data-type, the function is optimized to use bit arithmetic.\n\nIf the pattern does not occur in the string list or if the string list is an\nempty string, the function returns 0. If either argument is NULL, the function\nreturns NULL. The function does not return the correct result if the pattern\ncontains a comma (",") character.\n\nExamples\n--------\n\nSELECT FIND_IN_SET('b','a,b,c,d') AS "Found Results";\n+---------------+\n| Found Results |\n+---------------+\n| 2 |\n+---------------+\n\nURL: https://mariadb.com/kb/en/find_in_set/ +[FIRST_VALUE] +declaration=expr +category=Window Functions +description=FIRST_VALUE returns the first result from an ordered set, or NULL if no such\nresult exists.\n\nExamples\n--------\n\nCREATE TABLE t1 (\n pk int primary key,\n a int,\n b int,\n c char(10),\n d decimal(10, 3),\n e real\n);\n\nINSERT INTO t1 VALUES\n( 1, 0, 1, 'one', 0.1, 0.001),\n( 2, 0, 2, 'two', 0.2, 0.002),\n( 3, 0, 3, 'three', 0.3, 0.003),\n( 4, 1, 2, 'three', 0.4, 0.004),\n( 5, 1, 1, 'two', 0.5, 0.005),\n( 6, 1, 1, 'one', 0.6, 0.006),\n( 7, 2, NULL, 'n_one', 0.5, 0.007),\n( 8, 2, 1, 'n_two', NULL, 0.008),\n( 9, 2, 2, NULL, 0.7, 0.009),\n(10, 2, 0, 'n_four', 0.8, 0.010),\n(11, 2, 10, NULL, 0.9, NULL);\n\nSELECT pk, FIRST_VALUE(pk) OVER (ORDER BY pk) AS first_asc,\n LAST_VALUE(pk) OVER (ORDER BY pk) AS last_asc,\n FIRST_VALUE(pk) OVER (ORDER BY pk DESC) AS first_desc,\n LAST_VALUE(pk) OVER (ORDER BY pk DESC) AS last_desc\nFROM t1\nORDER BY pk DESC;\n\n+----+-----------+----------+------------+-----------+\n| pk | first_asc | last_asc | first_desc | last_desc |\n+----+-----------+----------+------------+-----------+\n| 11 | 1 | 11 | 11 | 11 |\n| 10 | 1 | 10 | 11 | 10 |\n| 9 | 1 | 9 | 11 | 9 |\n| 8 | 1 | 8 | 11 | 8 |\n| 7 | 1 | 7 | 11 | 7 |\n| 6 | 1 | 6 | 11 | 6 |\n| 5 | 1 | 5 | 11 | 5 |\n| 4 | 1 | 4 | 11 | 4 |\n| 3 | 1 | 3 | 11 | 3 |\n| 2 | 1 | 2 | 11 | 2 |\n| 1 | 1 | 1 | 11 | 1 |\n+----+-----------+----------+------------+-----------+\n ... +[FLOAT] +declaration=M,D +category=Data Types +description=A small (single-precision) floating-point number (see DOUBLE for a\nregular-size floating point number). Allowable values are:\n\n* -3.402823466E+38 to -1.175494351E-38\n* 0\n* 1.175494351E-38 to 3.402823466E+38.\n\nThese are the theoretical limits, based on the IEEE standard. The actual range\nmight be slightly smaller depending on your hardware or operating system.\n\nM is the total number of digits and D is the number of digits following the\ndecimal point. If M and D are omitted, values are stored to the limits allowed\nby the hardware. A single-precision floating-point number is accurate to\napproximately 7 decimal places.\n\nUNSIGNED, if specified, disallows negative values.\n\nUsing FLOAT might give you some unexpected problems because all calculations\nin MariaDB are done with double precision. See Floating Point Accuracy.\n\nFor more details on the attributes, see Numeric Data Type Overview.\n\nURL: https://mariadb.com/kb/en/float/ +[FLOOR] +declaration=X +category=Numeric Functions +description=Returns the largest integer value not greater than X.\n\nExamples\n--------\n\nSELECT FLOOR(1.23);\n+-------------+\n| FLOOR(1.23) |\n+-------------+\n| 1 |\n+-------------+\n\nSELECT FLOOR(-1.23);\n+--------------+\n| FLOOR(-1.23) |\n+--------------+\n| -2 |\n+--------------+\n\nURL: https://mariadb.com/kb/en/floor/ +[FORMAT] +declaration=num, decimal_position[, locale] +category=String Functions +description=Formats the given number for display as a string, adding separators to\nappropriate position and rounding the results to the given decimal position.\nFor instance, it would format 15233.345 to 15,233.35.\n\nIf the given decimal position is 0, it rounds to return no decimal point or\nfractional part. You can optionally specify a locale value to format numbers\nto the pattern appropriate for the given region.\n\nExamples\n--------\n\nSELECT FORMAT(1234567890.09876543210, 4) AS 'Format';\n+--------------------+\n| Format |\n+--------------------+\n| 1,234,567,890.0988 |\n+--------------------+\n\nSELECT FORMAT(1234567.89, 4) AS 'Format';\n+----------------+\n| Format |\n+----------------+\n| 1,234,567.8900 |\n+----------------+\n\nSELECT FORMAT(1234567.89, 0) AS 'Format';\n+-----------+\n| Format |\n+-----------+\n| 1,234,568 |\n+-----------+\n\nSELECT FORMAT(123456789,2,'rm_CH') AS 'Format';\n+----------------+\n| Format |\n+----------------+\n| 123'456'789,00 |\n+----------------+\n\nURL: https://mariadb.com/kb/en/format/ +[FORMAT_PICO_TIME] +declaration=time_val +category=Date and Time Functions +description=Given a time in picoseconds, returns a human-readable time value and unit\nindicator. Resulting unit is dependent on the length of the argument, and can\nbe:\n\n* ps - picoseconds\n* ns - nanoseconds\n* us - microseconds\n* ms - milliseconds\n* s - seconds\n* min - minutes\n* h - hours\n* d - days\n\nWith the exception of results under one nanosecond, which are not rounded and\nare represented as whole numbers, the result is rounded to 2 decimal places,\nwith a minimum of 3 significant digits.\n\nReturns NULL if the argument is NULL.\n\nThis function is very similar to the Sys Schema FORMAT_TIME function, but with\nthe following differences:\n\n* Represents minutes as min rather than m.\n* Does not represent weeks.\n\nExamples\n--------\n\nSELECT\n FORMAT_PICO_TIME(43) AS ps,\n FORMAT_PICO_TIME(4321) AS ns,\n FORMAT_PICO_TIME(43211234) AS us,\n FORMAT_PICO_TIME(432112344321) AS ms,\n FORMAT_PICO_TIME(43211234432123) AS s,\n FORMAT_PICO_TIME(432112344321234) AS m,\n FORMAT_PICO_TIME(4321123443212345) AS h,\n FORMAT_PICO_TIME(432112344321234545) AS d;\n+--------+---------+----------+-----------+---------+----------+--------+------\n-+\n| ps | ns | us | ms | s | m | h | d \n |\n+--------+---------+----------+-----------+---------+----------+--------+------\n-+\n| 43 ps | 4.32 ns | 43.21 us | 432.11 ms | 43.21 s | 7.20 min | 1.20 h | 5.00\nd |\n+--------+---------+----------+-----------+---------+----------+--------+------\n-+\n\nURL: https://mariadb.com/kb/en/format_pico_time/ +[FOUND_ROWS] +declaration= +category=Information Functions +description=A SELECT statement may include a LIMIT clause to restrict the number of rows\nthe server returns to the client. In some cases, it is desirable to know how\nmany rows the statement would have returned without the LIMIT, but without\nrunning the statement again. To obtain this row count, include a\nSQL_CALC_FOUND_ROWS option in the SELECT statement, and then invoke\nFOUND_ROWS() afterwards.\n\nYou can also use FOUND_ROWS() to obtain the number of rows returned by a\nSELECT which does not contain a LIMIT clause. In this case you don't need to\nuse the SQL_CALC_FOUND_ROWS option. This can be useful for example in a stored\nprocedure.\n\nAlso, this function works with some other statements which return a resultset,\nincluding SHOW, DESC and HELP. For DELETE ... RETURNING you should use\nROW_COUNT(). It also works as a prepared statement, or after executing a\nprepared statement.\n\nStatements which don't return any results don't affect FOUND_ROWS() - the\nprevious value will still be returned.\n\nWarning: When used after a CALL statement, this function returns the number of\nrows selected by the last query in the procedure, not by the whole procedure.\n\nStatements using the FOUND_ROWS() function are not safe for statement-based\nreplication.\n\nExamples\n--------\n\nSHOW ENGINES\G\n*************************** 1. row ***************************\n Engine: CSV\n Support: YES\n Comment: Stores tables as CSV files\nTransactions: NO\n XA: NO\n Savepoints: NO\n*************************** 2. row ***************************\n Engine: MRG_MyISAM\n Support: YES\n Comment: Collection of identical MyISAM tables\nTransactions: NO\n XA: NO\n Savepoints: NO\n\n...\n\n*************************** 8. row ***************************\n Engine: PERFORMANCE_SCHEMA\n Support: YES\n ... +[FROM_BASE64] +declaration=str +category=String Functions +description=Decodes the given base-64 encode string, returning the result as a binary\nstring. Returns NULL if the given string is NULL or if it's invalid.\n\nIt is the reverse of the TO_BASE64 function.\n\nThere are numerous methods to base-64 encode a string. MariaDB uses the\nfollowing:\n\n* It encodes alphabet value 64 as '+'.\n* It encodes alphabet value 63 as '/'.\n* It codes output in groups of four printable characters. Each three byte of\ndata encoded uses four characters. If the final group is incomplete, it pads\nthe difference with the '=' character.\n* It divides long output, adding a new line very 76 characters.\n* In decoding, it recognizes and ignores newlines, carriage returns, tabs and\nspace whitespace characters.\n\nSELECT TO_BASE64('Maria') AS 'Input';\n+-----------+\n| Input |\n+-----------+\n| TWFyaWE= |\n+-----------+\n\nSELECT FROM_BASE64('TWFyaWE=') AS 'Output';\n+--------+\n| Output |\n+--------+\n| Maria |\n+--------+\n\nURL: https://mariadb.com/kb/en/from_base64/ +[FROM_DAYS] +declaration=N +category=Date and Time Functions +description=Given a day number N, returns a DATE value. The day count is based on the\nnumber of days from the start of the standard calendar (0000-00-00).\n\nThe function is not designed for use with dates before the advent of the\nGregorian calendar in October 1582. Results will not be reliable since it\ndoesn't account for the lost days when the calendar changed from the Julian\ncalendar.\n\nThis is the converse of the TO_DAYS() function.\n\nExamples\n--------\n\nSELECT FROM_DAYS(730669);\n+-------------------+\n| FROM_DAYS(730669) |\n+-------------------+\n| 2000-07-03 |\n+-------------------+\n\nURL: https://mariadb.com/kb/en/from_days/ +[FROM_UNIXTIME] +declaration=unix_timestamp +category=Date and Time Functions +description=Returns a representation of the unix_timestamp argument as a value in\n'YYYY-MM-DD HH:MM:SS' or YYYYMMDDHHMMSS.uuuuuu format, depending on whether\nthe function is used in a string or numeric context. The value is expressed in\nthe current time zone. unix_timestamp is an internal timestamp value such as\nis produced by the UNIX_TIMESTAMP() function.\n\nIf format is given, the result is formatted according to the format string,\nwhich is used the same way as listed in the entry for the DATE_FORMAT()\nfunction.\n\nTimestamps in MariaDB have a maximum value of 2147483647, equivalent to\n2038-01-19 05:14:07. This is due to the underlying 32-bit limitation. Using\nthe function on a timestamp beyond this will result in NULL being returned.\nUse DATETIME as a storage type if you require dates beyond this.\n\nThe options that can be used by FROM_UNIXTIME(), as well as DATE_FORMAT() and\nSTR_TO_DATE(), are:\n\n+---------------------------+------------------------------------------------+\n| Option | Description |\n+---------------------------+------------------------------------------------+\n| %a | Short weekday name in current locale |\n| | (Variable lc_time_names). |\n+---------------------------+------------------------------------------------+\n| %b | Short form month name in current locale. For |\n| | locale en_US this is one of: |\n| | Jan,Feb,Mar,Apr,May,Jun,Jul,Aug,Sep,Oct,Nov |\n| | or Dec. |\n+---------------------------+------------------------------------------------+\n| %c | Month with 1 or 2 digits. |\n+---------------------------+------------------------------------------------+\n| %D | Day with English suffix 'th', 'nd', 'st' or |\n| | 'rd''. (1st, 2nd, 3rd...). |\n+---------------------------+------------------------------------------------+\n| %d | Day with 2 digits. |\n+---------------------------+------------------------------------------------+\n| %e | Day with 1 or 2 digits. |\n+---------------------------+------------------------------------------------+\n| %f | Microseconds 6 digits. |\n+---------------------------+------------------------------------------------+\n| %H | Hour with 2 digits between 00-23. |\n+---------------------------+------------------------------------------------+\n| %h | Hour with 2 digits between 01-12. |\n+---------------------------+------------------------------------------------+\n| %I | Hour with 2 digits between 01-12. |\n+---------------------------+------------------------------------------------+\n| %i | Minute with 2 digits. |\n+---------------------------+------------------------------------------------+\n| %j | Day of the year (001-366) |\n+---------------------------+------------------------------------------------+\n ... +[GEOMETRYCOLLECTION] +declaration=g1,g2,... +category=Geometry Constructors +description=Constructs a WKB GeometryCollection. If any argument is not a well-formed WKB\nrepresentation of a geometry, the return value is NULL.\n\nExamples\n--------\n\nCREATE TABLE gis_geometrycollection (g GEOMETRYCOLLECTION);\nSHOW FIELDS FROM gis_geometrycollection;\nINSERT INTO gis_geometrycollection VALUES\n (GeomCollFromText('GEOMETRYCOLLECTION(POINT(0 0), LINESTRING(0 0,10\n10))')),\n (GeometryFromWKB(AsWKB(GeometryCollection(Point(44, 6),\nLineString(Point(3, 6), Point(7, 9)))))),\n (GeomFromText('GeometryCollection()')),\n (GeomFromText('GeometryCollection EMPTY'));\n\nURL: https://mariadb.com/kb/en/geometrycollection/ +[GET_FORMAT] +declaration={DATE|DATETIME|TIME}, {'EUR'|'USA'|'JIS'|'ISO'|'INTERNAL'} +category=Date and Time Functions +description=Returns a format string. This function is useful in combination with the\nDATE_FORMAT() and the STR_TO_DATE() functions.\n\nPossible result formats are:\n\n+--------------------------------------+--------------------------------------+\n| Function Call | Result Format |\n+--------------------------------------+--------------------------------------+\n| GET_FORMAT(DATE,'EUR') | '%d.%m.%Y' |\n+--------------------------------------+--------------------------------------+\n| GET_FORMAT(DATE,'USA') | '%m.%d.%Y' |\n+--------------------------------------+--------------------------------------+\n| GET_FORMAT(DATE,'JIS') | '%Y-%m-%d' |\n+--------------------------------------+--------------------------------------+\n| GET_FORMAT(DATE,'ISO') | '%Y-%m-%d' |\n+--------------------------------------+--------------------------------------+\n| GET_FORMAT(DATE,'INTERNAL') | '%Y%m%d' |\n+--------------------------------------+--------------------------------------+\n| GET_FORMAT(DATETIME,'EUR') | '%Y-%m-%d %H.%i.%s' |\n+--------------------------------------+--------------------------------------+\n| GET_FORMAT(DATETIME,'USA') | '%Y-%m-%d %H.%i.%s' |\n+--------------------------------------+--------------------------------------+\n| GET_FORMAT(DATETIME,'JIS') | '%Y-%m-%d %H:%i:%s' |\n+--------------------------------------+--------------------------------------+\n| GET_FORMAT(DATETIME,'ISO') | '%Y-%m-%d %H:%i:%s' |\n+--------------------------------------+--------------------------------------+\n| GET_FORMAT(DATETIME,'INTERNAL') | '%Y%m%d%H%i%s' |\n+--------------------------------------+--------------------------------------+\n| GET_FORMAT(TIME,'EUR') | '%H.%i.%s' |\n+--------------------------------------+--------------------------------------+\n| GET_FORMAT(TIME,'USA') | '%h:%i:%s %p' |\n+--------------------------------------+--------------------------------------+\n| GET_FORMAT(TIME,'JIS') | '%H:%i:%s' |\n+--------------------------------------+--------------------------------------+\n| GET_FORMAT(TIME,'ISO') | '%H:%i:%s' |\n+--------------------------------------+--------------------------------------+\n| GET_FORMAT(TIME,'INTERNAL') | '%H%i%s' |\n+--------------------------------------+--------------------------------------+\n\nExamples\n--------\n\nObtaining the string matching to the standard European date format:\n\nSELECT GET_FORMAT(DATE, 'EUR');\n+-------------------------+\n| GET_FORMAT(DATE, 'EUR') |\n+-------------------------+\n| %d.%m.%Y |\n+-------------------------+\n ... +[GET_LOCK] +declaration=str,timeout +category=Miscellaneous Functions +description=Tries to obtain a lock with a name given by the string str, using a timeout of\ntimeout seconds. Returns 1 if the lock was obtained successfully, 0 if the\nattempt timed out (for example, because another client has previously locked\nthe name), or NULL if an error occurred (such as running out of memory or the\nthread was killed with mariadb-admin kill).\n\nA lock is released with RELEASE_LOCK(), when the connection terminates (either\nnormally or abnormally). A connection can hold multiple locks at the same\ntime, so a lock that is no longer needed needs to be explicitly released.\n\nThe IS_FREE_LOCK function returns whether a specified lock a free or not, and\nthe IS_USED_LOCK whether the function is in use or not.\n\nLocks obtained with GET_LOCK() do not interact with transactions. That is,\ncommitting a transaction does not release any such locks obtained during the\ntransaction.\n\nIt is also possible to recursively set the same lock. If a lock with the same\nname is set n times, it needs to be released n times as well.\n\nstr is case insensitive for GET_LOCK() and related functions. If str is an\nempty string or NULL, GET_LOCK() returns NULL and does nothing. timeout\nsupports microseconds.\n\nIf the metadata_lock_info plugin is installed, locks acquired with this\nfunction are visible in the Information Schema METADATA_LOCK_INFO table.\n\nThis function can be used to implement application locks or to simulate record\nlocks. Names are locked on a server-wide basis. If a name has been locked by\none client, GET_LOCK() blocks any request by another client for a lock with\nthe same name. This allows clients that agree on a given lock name to use the\nname to perform cooperative advisory locking. But be aware that it also allows\na client that is not among the set of cooperating clients to lock a name,\neither inadvertently or deliberately, and thus prevent any of the cooperating\nclients from locking that name. One way to reduce the likelihood of this is to\nuse lock names that are database-specific or application-specific. For\nexample, use lock names of the form db_name.str or app_name.str.\n\nStatements using the GET_LOCK function are not safe for statement-based\nreplication.\n\nThe patch to permit multiple locks was contributed by Konstantin "Kostja"\nOsipov (MDEV-3917).\n\nExamples\n--------\n\nSELECT GET_LOCK('lock1',10);\n+----------------------+\n| GET_LOCK('lock1',10) |\n ... +[GLENGTH] +declaration=ls +category=LineString Properties +description=Returns as a double-precision number the length of the LineString value ls in\nits associated spatial reference.\n\nExamples\n--------\n\nSET @ls = 'LineString(1 1,2 2,3 3)';\n\nSELECT GLength(GeomFromText(@ls));\n+----------------------------+\n| GLength(GeomFromText(@ls)) |\n+----------------------------+\n| 2.82842712474619 |\n+----------------------------+\n\nURL: https://mariadb.com/kb/en/glength/ +[GREATEST] +declaration=value1,value2,... +category=Comparison Operators +description=With two or more arguments, returns the largest (maximum-valued) argument. The\narguments are compared using the same rules as for LEAST().\n\nExamples\n--------\n\nSELECT GREATEST(2,0);\n+---------------+\n| GREATEST(2,0) |\n+---------------+\n| 2 |\n+---------------+\n\nSELECT GREATEST(34.0,3.0,5.0,767.0);\n+------------------------------+\n| GREATEST(34.0,3.0,5.0,767.0) |\n+------------------------------+\n| 767.0 |\n+------------------------------+\n\nSELECT GREATEST('B','A','C');\n+-----------------------+\n| GREATEST('B','A','C') |\n+-----------------------+\n| C |\n+-----------------------+\n\nURL: https://mariadb.com/kb/en/greatest/ +[GROUP_CONCAT] +declaration=expr +category=Functions and Modifiers for Use with GROUP BY +description=This function returns a string result with the concatenated non-NULL values\nfrom a group. If any expr in GROUP_CONCAT evaluates to NULL, that tuple is not\npresent in the list returned by GROUP_CONCAT.\n\nIt returns NULL if all arguments are NULL, or there are no matching rows.\n\nThe maximum returned length in bytes is determined by the group_concat_max_len\nserver system variable, which defaults to 1M.\n\nIf group_concat_max_len <= 512, the return type is VARBINARY or VARCHAR;\notherwise, the return type is BLOB or TEXT. The choice between binary or\nnon-binary types depends from the input.\n\nThe full syntax is as follows:\n\nGROUP_CONCAT([DISTINCT] expr [,expr ...]\n [ORDER BY {unsigned_integer | col_name | expr}\n [ASC | DESC] [,col_name ...]]\n [SEPARATOR str_val]\n [LIMIT {[offset,] row_count | row_count OFFSET offset}])\n\nDISTINCT eliminates duplicate values from the output string.\n\nORDER BY determines the order of returned values.\n\nSEPARATOR specifies a separator between the values. The default separator is a\ncomma (,). It is possible to avoid using a separator by specifying an empty\nstring.\n\nLIMIT\n-----\n\nThe LIMIT clause can be used with GROUP_CONCAT. This was not possible prior to\nMariaDB 10.3.3.\n\nExamples\n--------\n\nSELECT student_name,\n GROUP_CONCAT(test_score)\n FROM student\n GROUP BY student_name;\n\nGet a readable list of MariaDB users from the mysql.user table:\n\nSELECT GROUP_CONCAT(DISTINCT User ORDER BY User SEPARATOR '\n')\n FROM mysql.user;\n\nIn the former example, DISTINCT is used because the same user may occur more\nthan once. The new line (\n) used as a SEPARATOR makes the results easier to\n ... +[HEX] +declaration=N_or_S +category=String Functions +description=If N_or_S is a number, returns a string representation of the hexadecimal\nvalue of N, where N is a longlong (BIGINT) number. This is equivalent to\nCONV(N,10,16).\n\nIf N_or_S is a string, returns a hexadecimal string representation of N_or_S\nwhere each byte of each character in N_or_S is converted to two hexadecimal\ndigits. If N_or_S is NULL, returns NULL. The inverse of this operation is\nperformed by the UNHEX() function.\n\nMariaDB starting with 10.5.0\n----------------------------\nHEX() with an INET6 argument returns a hexadecimal representation of the\nunderlying 16-byte binary string.\n\nExamples\n--------\n\nSELECT HEX(255);\n+----------+\n| HEX(255) |\n+----------+\n| FF |\n+----------+\n\nSELECT 0x4D617269614442;\n+------------------+\n| 0x4D617269614442 |\n+------------------+\n| MariaDB |\n+------------------+\n\nSELECT HEX('MariaDB');\n+----------------+\n| HEX('MariaDB') |\n+----------------+\n| 4D617269614442 |\n+----------------+\n\nFrom MariaDB 10.5.0:\n\nSELECT HEX(CAST('2001:db8::ff00:42:8329' AS INET6));\n+----------------------------------------------+\n| HEX(CAST('2001:db8::ff00:42:8329' AS INET6)) |\n+----------------------------------------------+\n| 20010DB8000000000000FF0000428329 |\n+----------------------------------------------+\n\nURL: https://mariadb.com/kb/en/hex/ +[HOUR] +declaration=time +category=Date and Time Functions +description=Returns the hour for time. The range of the return value is 0 to 23 for\ntime-of-day values. However, the range of TIME values actually is much larger,\nso HOUR can return values greater than 23.\n\nThe return value is always positive, even if a negative TIME value is provided.\n\nExamples\n--------\n\nSELECT HOUR('10:05:03');\n+------------------+\n| HOUR('10:05:03') |\n+------------------+\n| 10 |\n+------------------+\n\nSELECT HOUR('272:59:59');\n+-------------------+\n| HOUR('272:59:59') |\n+-------------------+\n| 272 |\n+-------------------+\n\nDifference between EXTRACT (HOUR FROM ...) (>= MariaDB 10.0.7 and MariaDB\n5.5.35) and HOUR:\n\nSELECT EXTRACT(HOUR FROM '26:30:00'), HOUR('26:30:00');\n+-------------------------------+------------------+\n| EXTRACT(HOUR FROM '26:30:00') | HOUR('26:30:00') |\n+-------------------------------+------------------+\n| 2 | 26 |\n+-------------------------------+------------------+\n\nURL: https://mariadb.com/kb/en/hour/ +[IFNULL] +declaration=expr1,expr2 +category=Control Flow Functions +description=If expr1 is not NULL, IFNULL() returns expr1; otherwise it returns expr2.\nIFNULL() returns a numeric or string value, depending on the context in which\nit is used.\n\nFrom MariaDB 10.3, NVL() is an alias for IFNULL().\n\nExamples\n--------\n\nSELECT IFNULL(1,0); \n+-------------+\n| IFNULL(1,0) |\n+-------------+\n| 1 |\n+-------------+\n\nSELECT IFNULL(NULL,10);\n+-----------------+\n| IFNULL(NULL,10) |\n+-----------------+\n| 10 |\n+-----------------+\n\nSELECT IFNULL(1/0,10);\n+----------------+\n| IFNULL(1/0,10) |\n+----------------+\n| 10.0000 |\n+----------------+\n\nSELECT IFNULL(1/0,'yes');\n+-------------------+\n| IFNULL(1/0,'yes') |\n+-------------------+\n| yes |\n+-------------------+\n\nURL: https://mariadb.com/kb/en/ifnull/ +[IN] +declaration=value,... +category=Comparison Operators +description=Returns 1 if expr is equal to any of the values in the IN list, else returns\n0. If all values are constants, they are evaluated according to the type of\nexpr and sorted. The search for the item then is done using a binary search.\nThis means IN is very quick if the IN value list consists entirely of\nconstants. Otherwise, type conversion takes place according to the rules\ndescribed at Type Conversion, but applied to all the arguments.\n\nIf expr is NULL, IN always returns NULL. If at least one of the values in the\nlist is NULL, and one of the comparisons is true, the result is 1. If at least\none of the values in the list is NULL and none of the comparisons is true, the\nresult is NULL.\n\nExamples\n--------\n\nSELECT 2 IN (0,3,5,7);\n+----------------+\n| 2 IN (0,3,5,7) |\n+----------------+\n| 0 |\n+----------------+\n\nSELECT 'wefwf' IN ('wee','wefwf','weg');\n+----------------------------------+\n| 'wefwf' IN ('wee','wefwf','weg') |\n+----------------------------------+\n| 1 |\n+----------------------------------+\n\nType conversion:\n\nSELECT 1 IN ('1', '2', '3');\n+----------------------+\n| 1 IN ('1', '2', '3') |\n+----------------------+\n| 1 |\n+----------------------+\n\nSELECT NULL IN (1, 2, 3);\n+-------------------+\n| NULL IN (1, 2, 3) |\n+-------------------+\n| NULL |\n+-------------------+\n\nSELECT 1 IN (1, 2, NULL);\n+-------------------+\n| 1 IN (1, 2, NULL) |\n+-------------------+\n| 1 |\n ... +[INET6_ATON] +declaration=expr +category=Miscellaneous Functions +description=Given an IPv6 or IPv4 network address as a string, returns a binary string\nthat represents the numeric value of the address.\n\nNo trailing zone ID's or traling network masks are permitted. For IPv4\naddresses, or IPv6 addresses with IPv4 address parts, no classful addresses or\ntrailing port numbers are permitted and octal numbers are not supported.\n\nThe returned binary string will be VARBINARY(16) or VARBINARY(4) for IPv6 and\nIPv4 addresses respectively.\n\nReturns NULL if the argument is not understood.\n\nMariaDB starting with 10.5.0\n----------------------------\nFrom MariaDB 10.5.0, INET6_ATON can take INET6 as an argument.\n\nExamples\n--------\n\nSELECT HEX(INET6_ATON('10.0.1.1'));\n+-----------------------------+\n| HEX(INET6_ATON('10.0.1.1')) |\n+-----------------------------+\n| 0A000101 |\n+-----------------------------+\n\nSELECT HEX(INET6_ATON('48f3::d432:1431:ba23:846f'));\n+----------------------------------------------+\n| HEX(INET6_ATON('48f3::d432:1431:ba23:846f')) |\n+----------------------------------------------+\n| 48F3000000000000D4321431BA23846F |\n+----------------------------------------------+\n\nURL: https://mariadb.com/kb/en/inet6_aton/ +[INET6_NTOA] +declaration=expr +category=Miscellaneous Functions +description=Given an IPv6 or IPv4 network address as a numeric binary string, returns the\naddress as a nonbinary string in the connection character set.\n\nThe return string is lowercase, and is platform independent, since it does not\nuse functions specific to the operating system. It has a maximum length of 39\ncharacters.\n\nReturns NULL if the argument is not understood.\n\nExamples\n--------\n\nSELECT INET6_NTOA(UNHEX('0A000101'));\n+-------------------------------+\n| INET6_NTOA(UNHEX('0A000101')) |\n+-------------------------------+\n| 10.0.1.1 |\n+-------------------------------+\n\nSELECT INET6_NTOA(UNHEX('48F3000000000000D4321431BA23846F'));\n+-------------------------------------------------------+\n| INET6_NTOA(UNHEX('48F3000000000000D4321431BA23846F')) |\n+-------------------------------------------------------+\n| 48f3::d432:1431:ba23:846f |\n+-------------------------------------------------------+\n\nURL: https://mariadb.com/kb/en/inet6_ntoa/ +[INET_ATON] +declaration=expr +category=Miscellaneous Functions +description=Given the dotted-quad representation of an IPv4 network address as a string,\nreturns an integer that represents the numeric value of the address. Addresses\nmay be 4- or 8-byte addresses.\n\nReturns NULL if the argument is not understood.\n\nExamples\n--------\n\nSELECT INET_ATON('192.168.1.1');\n+--------------------------+\n| INET_ATON('192.168.1.1') |\n+--------------------------+\n| 3232235777 |\n+--------------------------+\n\nThis is calculated as follows: 192 x 2563 + 168 x 256 2 + 1 x 256 + 1\n\nURL: https://mariadb.com/kb/en/inet_aton/ +[INET_NTOA] +declaration=expr +category=Miscellaneous Functions +description=Given a numeric IPv4 network address in network byte order (4 or 8 byte),\nreturns the dotted-quad representation of the address as a string.\n\nExamples\n--------\n\nSELECT INET_NTOA(3232235777);\n+-----------------------+\n| INET_NTOA(3232235777) |\n+-----------------------+\n| 192.168.1.1 |\n+-----------------------+\n\n192.168.1.1 corresponds to 3232235777 since 192 x 2563 + 168 x 256 2 + 1 x 256\n+ 1 = 3232235777\n\nURL: https://mariadb.com/kb/en/inet_ntoa/ +[INSTR] +declaration=str,substr +category=String Functions +description=Returns the position of the first occurrence of substring substr in string\nstr. This is the same as the two-argument form of LOCATE(), except that the\norder of the arguments is reversed.\n\nINSTR() performs a case-insensitive search.\n\nIf any argument is NULL, returns NULL.\n\nExamples\n--------\n\nSELECT INSTR('foobarbar', 'bar');\n+---------------------------+\n| INSTR('foobarbar', 'bar') |\n+---------------------------+\n| 4 |\n+---------------------------+\n\nSELECT INSTR('My', 'Maria');\n+----------------------+\n| INSTR('My', 'Maria') |\n+----------------------+\n| 0 |\n+----------------------+\n\nURL: https://mariadb.com/kb/en/instr/ +[INT] +declaration=M +category=Data Types +description=A normal-size integer. When marked UNSIGNED, it ranges from 0 to 4294967295,\notherwise its range is -2147483648 to 2147483647 (SIGNED is the default). If a\ncolumn has been set to ZEROFILL, all values will be prepended by zeros so that\nthe INT value contains a number of M digits. INTEGER is a synonym for INT.\n\nNote: If the ZEROFILL attribute has been specified, the column will\nautomatically become UNSIGNED.\n\nINT4 is a synonym for INT.\n\nFor details on the attributes, see Numeric Data Type Overview.\n\nExamples\n--------\n\nCREATE TABLE ints (a INT,b INT UNSIGNED,c INT ZEROFILL);\n\nWith strict_mode set, the default from MariaDB 10.2.4:\n\nINSERT INTO ints VALUES (-10,-10,-10);\nERROR 1264 (22003): Out of range value for column 'b' at row 1\n\nINSERT INTO ints VALUES (-10,10,-10);\nERROR 1264 (22003): Out of range value for column 'c' at row 1\n\nINSERT INTO ints VALUES (-10,10,10);\n\nINSERT INTO ints VALUES (2147483648,2147483648,2147483648);\nERROR 1264 (22003): Out of range value for column 'a' at row 1\n\nINSERT INTO ints VALUES (2147483647,2147483648,2147483648);\n\nSELECT * FROM ints;\n+------------+------------+------------+\n| a | b | c |\n+------------+------------+------------+\n| -10 | 10 | 0000000010 |\n| 2147483647 | 2147483648 | 2147483648 |\n+------------+------------+------------+\n\nWith strict_mode unset, the default until MariaDB 10.2.3:\n\nINSERT INTO ints VALUES (-10,-10,-10);\nQuery OK, 1 row affected, 2 warnings (0.10 sec)\nWarning (Code 1264): Out of range value for column 'b' at row 1\nWarning (Code 1264): Out of range value for column 'c' at row 1\n\nINSERT INTO ints VALUES (-10,10,-10);\nQuery OK, 1 row affected, 1 warning (0.08 sec)\nWarning (Code 1264): Out of range value for column 'c' at row 1\n ... +[INTERSECT] +declaration=as well as EXCEPT +category=Data Manipulation +description=MariaDB 10.3.\n\nAll behavior for naming columns, ORDER BY and LIMIT is the same as for UNION.\n\nINTERSECT implicitly supposes a DISTINCT operation.\n\nThe result of an intersect is the intersection of right and left SELECT\nresults, i.e. only records that are present in both result sets will be\nincluded in the result of the operation.\n\nINTERSECT has higher precedence than UNION and EXCEPT (unless running running\nin Oracle mode, in which case all three have the same precedence). If possible\nit will be executed linearly but if not it will be translated to a subquery in\nthe FROM clause:\n\n(select a,b from t1)\nunion\n(select c,d from t2)\nintersect\n(select e,f from t3)\nunion\n(select 4,4);\n\nwill be translated to:\n\n(select a,b from t1)\nunion\nselect c,d from\n ((select c,d from t2)\n intersect\n (select e,f from t3)) dummy_subselect\nunion\n(select 4,4)\n\nMariaDB starting with 10.4.0\n----------------------------\n\nParentheses\n-----------\n\nFrom MariaDB 10.4.0, parentheses can be used to specify precedence. Before\nthis, a syntax error would be returned.\n\nMariaDB starting with 10.5.0\n----------------------------\n\nALL/DISTINCT\n------------\n\nINTERSECT ALL and INTERSECT DISTINCT were introduced in MariaDB 10.5.0. The\n ... +[INTERSECTS] +declaration=g1,g2 +category=Geometry Relations +description=Returns 1 or 0 to indicate whether geometry g1 spatially intersects geometry\ng2.\n\nINTERSECTS() is based on the original MySQL implementation and uses object\nbounding rectangles, while ST_INTERSECTS() uses object shapes.\n\nINTERSECTS() tests the opposite relationship to DISJOINT().\n\nURL: https://mariadb.com/kb/en/intersects/ +[INTERVAL] +declaration=N,N1,N2,N3,... +category=Comparison Operators +description=Returns the index of the last argument that is less than the first argument or\nis NULL.\n\nReturns 0 if N < N1, 1 if N < N2, 2 if N < N3 and so on or -1 if N is NULL.\nAll arguments are treated as integers. It is required that N1 < N2 < N3 < ...\n< Nn for this function to work correctly. This is because a fast binary search\nis used.\n\nExamples\n--------\n\nSELECT INTERVAL(23, 1, 15, 17, 30, 44, 200);\n+--------------------------------------+\n| INTERVAL(23, 1, 15, 17, 30, 44, 200) |\n+--------------------------------------+\n| 3 |\n+--------------------------------------+\n\nSELECT INTERVAL(10, 1, 10, 100, 1000);\n+--------------------------------+\n| INTERVAL(10, 1, 10, 100, 1000) |\n+--------------------------------+\n| 2 |\n+--------------------------------+\n\nSELECT INTERVAL(22, 23, 30, 44, 200);\n+-------------------------------+\n| INTERVAL(22, 23, 30, 44, 200) |\n+-------------------------------+\n| 0 |\n+-------------------------------+\n\nSELECT INTERVAL(10, 2, NULL);\n+-----------------------+\n| INTERVAL(10, 2, NULL) |\n+-----------------------+\n| 2 |\n+-----------------------+\n\nURL: https://mariadb.com/kb/en/interval/ +[ISNULL] +declaration=expr +category=Comparison Operators +description=If expr is NULL, ISNULL() returns 1, otherwise it returns 0.\n\nSee also NULL Values in MariaDB.\n\nExamples\n--------\n\nSELECT ISNULL(1+1);\n+-------------+\n| ISNULL(1+1) |\n+-------------+\n| 0 |\n+-------------+\n\nSELECT ISNULL(1/0);\n+-------------+\n| ISNULL(1/0) |\n+-------------+\n| 1 |\n+-------------+\n\nURL: https://mariadb.com/kb/en/isnull/ +[IS_FREE_LOCK] +declaration=str +category=Miscellaneous Functions +description=Checks whether the lock named str is free to use (that is, not locked).\nReturns 1 if the lock is free (no one is using the lock), 0 if the lock is in\nuse, and NULL if an error occurs (such as an incorrect argument, like an empty\nstring or NULL). str is case insensitive.\n\nIf the metadata_lock_info plugin is installed, the Information Schema\nmetadata_lock_info table contains information about locks of this kind (as\nwell as metadata locks).\n\nStatements using the IS_FREE_LOCK function are not safe for statement-based\nreplication.\n\nURL: https://mariadb.com/kb/en/is_free_lock/ +[IS_IPV4] +declaration=expr +category=Miscellaneous Functions +description=If the expression is a valid IPv4 address, returns 1, otherwise returns 0.\n\nIS_IPV4() is stricter than INET_ATON(), but as strict as INET6_ATON(), in\ndetermining the validity of an IPv4 address. This implies that if IS_IPV4\nreturns 1, the same expression will always return a non-NULL result when\npassed to INET_ATON(), but that the reverse may not apply.\n\nExamples\n--------\n\nSELECT IS_IPV4('1110.0.1.1');\n+-----------------------+\n| IS_IPV4('1110.0.1.1') |\n+-----------------------+\n| 0 |\n+-----------------------+\n\nSELECT IS_IPV4('48f3::d432:1431:ba23:846f');\n+--------------------------------------+\n| IS_IPV4('48f3::d432:1431:ba23:846f') |\n+--------------------------------------+\n| 0 |\n+--------------------------------------+\n\nURL: https://mariadb.com/kb/en/is_ipv4/ +[IS_IPV4_COMPAT] +declaration=expr +category=Miscellaneous Functions +description=Returns 1 if a given numeric binary string IPv6 address, such as returned by\nINET6_ATON(), is IPv4-compatible, otherwise returns 0.\n\nMariaDB starting with 10.5.0\n----------------------------\nFrom MariaDB 10.5.0, when the argument is not INET6, automatic implicit CAST\nto INET6 is applied. As a consequence, IS_IPV4_COMPAT now understands\narguments in both text representation and binary(16) representation. Before\nMariaDB 10.5.0, the function understood only binary(16) representation.\n\nExamples\n--------\n\nSELECT IS_IPV4_COMPAT(INET6_ATON('::10.0.1.1'));\n+------------------------------------------+\n| IS_IPV4_COMPAT(INET6_ATON('::10.0.1.1')) |\n+------------------------------------------+\n| 1 |\n+------------------------------------------+\n\nSELECT IS_IPV4_COMPAT(INET6_ATON('::48f3::d432:1431:ba23:846f'));\n+-----------------------------------------------------------+\n| IS_IPV4_COMPAT(INET6_ATON('::48f3::d432:1431:ba23:846f')) |\n+-----------------------------------------------------------+\n| 0 |\n+-----------------------------------------------------------+\n\nURL: https://mariadb.com/kb/en/is_ipv4_compat/ +[IS_IPV4_MAPPED] +declaration=expr +category=Miscellaneous Functions +description=Returns 1 if a given a numeric binary string IPv6 address, such as returned by\nINET6_ATON(), is a valid IPv4-mapped address, otherwise returns 0.\n\nMariaDB starting with 10.5.0\n----------------------------\nFrom MariaDB 10.5.0, when the argument is not INET6, automatic implicit CAST\nto INET6 is applied. As a consequence, IS_IPV4_MAPPED now understands\narguments in both text representation and binary(16) representation. Before\nMariaDB 10.5.0, the function understood only binary(16) representation.\n\nExamples\n--------\n\nSELECT IS_IPV4_MAPPED(INET6_ATON('::10.0.1.1'));\n+------------------------------------------+\n| IS_IPV4_MAPPED(INET6_ATON('::10.0.1.1')) |\n+------------------------------------------+\n| 0 |\n+------------------------------------------+\n\nSELECT IS_IPV4_MAPPED(INET6_ATON('::ffff:10.0.1.1'));\n+-----------------------------------------------+\n| IS_IPV4_MAPPED(INET6_ATON('::ffff:10.0.1.1')) |\n+-----------------------------------------------+\n| 1 |\n+-----------------------------------------------+\n\nURL: https://mariadb.com/kb/en/is_ipv4_mapped/ +[IS_IPV6] +declaration=expr +category=Miscellaneous Functions +description=Returns 1 if the expression is a valid IPv6 address specified as a string,\notherwise returns 0. Does not consider IPv4 addresses to be valid IPv6\naddresses.\n\nExamples\n--------\n\nSELECT IS_IPV6('48f3::d432:1431:ba23:846f');\n+--------------------------------------+\n| IS_IPV6('48f3::d432:1431:ba23:846f') |\n+--------------------------------------+\n| 1 |\n+--------------------------------------+\n1 row in set (0.02 sec)\n\nSELECT IS_IPV6('10.0.1.1');\n+---------------------+\n| IS_IPV6('10.0.1.1') |\n+---------------------+\n| 0 |\n+---------------------+\n\nURL: https://mariadb.com/kb/en/is_ipv6/ +[IS_USED_LOCK] +declaration=str +category=Miscellaneous Functions +description=Checks whether the lock named str is in use (that is, locked). If so, it\nreturns the connection identifier of the client that holds the lock.\nOtherwise, it returns NULL. str is case insensitive.\n\nIf the metadata_lock_info plugin is installed, the Information Schema\nmetadata_lock_info table contains information about locks of this kind (as\nwell as metadata locks).\n\nStatements using the IS_USED_LOCK function are not safe for statement-based\nreplication.\n\nURL: https://mariadb.com/kb/en/is_used_lock/ +[JSON_ARRAY] +declaration=[value[, value2] ...] +category=JSON Functions +description=Returns a JSON array containing the listed values. The list can be empty.\n\nExample\n-------\n\nSELECT Json_Array(56, 3.1416, 'My name is "Foo"', NULL);\n+--------------------------------------------------+\n| Json_Array(56, 3.1416, 'My name is "Foo"', NULL) |\n+--------------------------------------------------+\n| [56, 3.1416, "My name is \"Foo\"", null] |\n+--------------------------------------------------+\n\nURL: https://mariadb.com/kb/en/json_array/ +[JSON_ARRAYAGG] +declaration=column_or_expression +category=JSON Functions +description=JSON_ARRAYAGG returns a JSON array containing an element for each value in a\ngiven set of JSON or SQL values. It acts on a column or an expression that\nevaluates to a single value.\n\nThe maximum returned length in bytes is determined by the group_concat_max_len\nserver system variable.\n\nReturns NULL in the case of an error, or if the result contains no rows.\n\nJSON_ARRAYAGG cannot currently be used as a window function.\n\nThe full syntax is as follows:\n\nJSON_ARRAYAGG([DISTINCT] expr\n [ORDER BY {unsigned_integer | col_name | expr}\n [ASC | DESC] [,col_name ...]]\n [LIMIT {[offset,] row_count | row_count OFFSET offset}])\n\nExamples\n--------\n\nCREATE TABLE t1 (a INT, b INT);\n\nINSERT INTO t1 VALUES (1, 1),(2, 1), (1, 1),(2, 1), (3, 2),(2, 2),(2, 2),(2,\n2);\n\nSELECT JSON_ARRAYAGG(a), JSON_ARRAYAGG(b) FROM t1;\n+-------------------+-------------------+\n| JSON_ARRAYAGG(a) | JSON_ARRAYAGG(b) |\n+-------------------+-------------------+\n| [1,2,1,2,3,2,2,2] | [1,1,1,1,2,2,2,2] |\n+-------------------+-------------------+\n\nSELECT JSON_ARRAYAGG(a), JSON_ARRAYAGG(b) FROM t1 GROUP BY b;\n+------------------+------------------+\n| JSON_ARRAYAGG(a) | JSON_ARRAYAGG(b) |\n+------------------+------------------+\n| [1,2,1,2] | [1,1,1,1] |\n| [3,2,2,2] | [2,2,2,2] |\n+------------------+------------------+\n\nURL: https://mariadb.com/kb/en/json_arrayagg/ +[JSON_ARRAY_APPEND] +declaration=json_doc, path, value[, path, value] ... +category=JSON Functions +description=Appends values to the end of the specified arrays within a JSON document,\nreturning the result, or NULL if any of the arguments are NULL.\n\nEvaluation is performed from left to right, with the resulting document from\nthe previous pair becoming the new value against which the next pair is\nevaluated.\n\nIf the json_doc is not a valid JSON document, or if any of the paths are not\nvalid, or contain a * or ** wildcard, an error is returned.\n\nExamples\n--------\n\nSET @json = '[1, 2, [3, 4]]';\n\nSELECT JSON_ARRAY_APPEND(@json, '$[0]', 5)\n+-------------------------------------+\n| JSON_ARRAY_APPEND(@json, '$[0]', 5) |\n+-------------------------------------+\n| [[1, 5], 2, [3, 4]] |\n+-------------------------------------+\n\nSELECT JSON_ARRAY_APPEND(@json, '$[1]', 6);\n+-------------------------------------+\n| JSON_ARRAY_APPEND(@json, '$[1]', 6) |\n+-------------------------------------+\n| [1, [2, 6], [3, 4]] |\n+-------------------------------------+\n\nSELECT JSON_ARRAY_APPEND(@json, '$[1]', 6, '$[2]', 7);\n+------------------------------------------------+\n| JSON_ARRAY_APPEND(@json, '$[1]', 6, '$[2]', 7) |\n+------------------------------------------------+\n| [1, [2, 6], [3, 4, 7]] |\n+------------------------------------------------+\n\nSELECT JSON_ARRAY_APPEND(@json, '$', 5);\n+----------------------------------+\n| JSON_ARRAY_APPEND(@json, '$', 5) |\n+----------------------------------+\n| [1, 2, [3, 4], 5] |\n+----------------------------------+\n\nSET @json = '{"A": 1, "B": [2], "C": [3, 4]}';\n\nSELECT JSON_ARRAY_APPEND(@json, '$.B', 5);\n+------------------------------------+\n| JSON_ARRAY_APPEND(@json, '$.B', 5) |\n+------------------------------------+\n| {"A": 1, "B": [2, 5], "C": [3, 4]} |\n+------------------------------------+\n\nURL: https://mariadb.com/kb/en/json_array_append/ +[JSON_ARRAY_INSERT] +declaration=json_doc, path, value[, path, value] ... +category=JSON Functions +description=Inserts a value into a JSON document, returning the modified document, or NULL\nif any of the arguments are NULL.\n\nEvaluation is performed from left to right, with the resulting document from\nthe previous pair becoming the new value against which the next pair is\nevaluated.\n\nIf the json_doc is not a valid JSON document, or if any of the paths are not\nvalid, or contain a * or ** wildcard, an error is returned.\n\nExamples\n--------\n\nSET @json = '[1, 2, [3, 4]]';\n\nSELECT JSON_ARRAY_INSERT(@json, '$[0]', 5);\n+-------------------------------------+\n| JSON_ARRAY_INSERT(@json, '$[0]', 5) |\n+-------------------------------------+\n| [5, 1, 2, [3, 4]] |\n+-------------------------------------+\n\nSELECT JSON_ARRAY_INSERT(@json, '$[1]', 6);\n+-------------------------------------+\n| JSON_ARRAY_INSERT(@json, '$[1]', 6) |\n+-------------------------------------+\n| [1, 6, 2, [3, 4]] |\n+-------------------------------------+\n\nSELECT JSON_ARRAY_INSERT(@json, '$[1]', 6, '$[2]', 7);\n+------------------------------------------------+\n| JSON_ARRAY_INSERT(@json, '$[1]', 6, '$[2]', 7) |\n+------------------------------------------------+\n| [1, 6, 7, 2, [3, 4]] |\n+------------------------------------------------+\n\nURL: https://mariadb.com/kb/en/json_array_insert/ +[JSON_ARRAY_INTERSECT] +declaration=arr1, arr2 +category=JSON Functions +description=Finds intersection between two json arrays and returns an array of items found\nin both array.\n\nExamples\n--------\n\nSET @json1= '[1,2,3]';\nSET @json2= '[1,2,4]';\n\nSELECT json_array_intersect(@json1, @json2); \n+--------------------------------------+\n| json_array_intersect(@json1, @json2) |\n+--------------------------------------+\n| [1, 2] |\n+--------------------------------------+\n\nURL: https://mariadb.com/kb/en/json_array_intersect/ +[JSON_COMPACT] +declaration=json_doc +category=JSON Functions +description=Removes all unnecessary spaces so the json document is as short as possible.\n\nExample\n-------\n\nSET @j = '{ "A": 1, "B": [2, 3]}';\n\nSELECT JSON_COMPACT(@j), @j;\n+-------------------+------------------------+\n| JSON_COMPACT(@j) | @j |\n+-------------------+------------------------+\n| {"A":1,"B":[2,3]} | { "A": 1, "B": [2, 3]} |\n+-------------------+------------------------+\n\nURL: https://mariadb.com/kb/en/json_compact/ +[JSON_CONTAINS] +declaration=json_doc, val[, path] +category=JSON Functions +description=Returns whether or not the specified value is found in the given JSON document\nor, optionally, at the specified path within the document. Returns 1 if it\ndoes, 0 if not and NULL if any of the arguments are null. An error occurs if\nthe document or path is not valid, or contains the * or ** wildcards.\n\nExamples\n--------\n\nSET @json = '{"A": 0, "B": {"C": 1}, "D": 2}';\n\nSELECT JSON_CONTAINS(@json, '2', '$.A');\n+----------------------------------+\n| JSON_CONTAINS(@json, '2', '$.A') |\n+----------------------------------+\n| 0 |\n+----------------------------------+\n\nSELECT JSON_CONTAINS(@json, '2', '$.D');\n+----------------------------------+\n| JSON_CONTAINS(@json, '2', '$.D') |\n+----------------------------------+\n| 1 |\n+----------------------------------+\n\nSELECT JSON_CONTAINS(@json, '{"C": 1}', '$.A');\n+-----------------------------------------+\n| JSON_CONTAINS(@json, '{"C": 1}', '$.A') |\n+-----------------------------------------+\n| 0 |\n+-----------------------------------------+\n\nSELECT JSON_CONTAINS(@json, '{"C": 1}', '$.B');\n+-----------------------------------------+\n| JSON_CONTAINS(@json, '{"C": 1}', '$.B') |\n+-----------------------------------------+\n| 1 |\n+-----------------------------------------+\n\nURL: https://mariadb.com/kb/en/json_contains/ +[JSON_CONTAINS_PATH] +declaration=json_doc, return_arg, path[, path] ... +category=JSON Functions +description=Indicates whether the given JSON document contains data at the specified path\nor paths. Returns 1 if it does, 0 if not and NULL if any of the arguments are\nnull.\n\nThe return_arg can be one or all:\n\n* one - Returns 1 if at least one path exists within the JSON document. \n* all - Returns 1 only if all paths exist within the JSON document.\n\nExamples\n--------\n\nSET @json = '{"A": 1, "B": [2], "C": [3, 4]}';\n\nSELECT JSON_CONTAINS_PATH(@json, 'one', '$.A', '$.D');\n+------------------------------------------------+\n| JSON_CONTAINS_PATH(@json, 'one', '$.A', '$.D') |\n+------------------------------------------------+\n| 1 |\n+------------------------------------------------+\n1 row in set (0.00 sec)\n\nSELECT JSON_CONTAINS_PATH(@json, 'all', '$.A', '$.D');\n+------------------------------------------------+\n| JSON_CONTAINS_PATH(@json, 'all', '$.A', '$.D') |\n+------------------------------------------------+\n| 0 |\n+------------------------------------------------+\n\nURL: https://mariadb.com/kb/en/json_contains_path/ +[JSON_DEPTH] +declaration=json_doc +category=JSON Functions +description=Returns the maximum depth of the given JSON document, or NULL if the argument\nis null. An error will occur if the argument is an invalid JSON document.\n\n* Scalar values or empty arrays or objects have a depth of 1.\n* Arrays or objects that are not empty but contain only elements or member\nvalues of depth 1 will have a depth of 2.\n* In other cases, the depth will be greater than 2.\n\nExamples\n--------\n\nSELECT JSON_DEPTH('[]'), JSON_DEPTH('true'), JSON_DEPTH('{}');\n+------------------+--------------------+------------------+\n| JSON_DEPTH('[]') | JSON_DEPTH('true') | JSON_DEPTH('{}') |\n+------------------+--------------------+------------------+\n| 1 | 1 | 1 |\n+------------------+--------------------+------------------+\n\nSELECT JSON_DEPTH('[1, 2, 3]'), JSON_DEPTH('[[], {}, []]');\n+-------------------------+----------------------------+\n| JSON_DEPTH('[1, 2, 3]') | JSON_DEPTH('[[], {}, []]') |\n+-------------------------+----------------------------+\n| 2 | 2 |\n+-------------------------+----------------------------+\n\nSELECT JSON_DEPTH('[1, 2, [3, 4, 5, 6], 7]');\n+---------------------------------------+\n| JSON_DEPTH('[1, 2, [3, 4, 5, 6], 7]') |\n+---------------------------------------+\n| 3 |\n+---------------------------------------+\n\nURL: https://mariadb.com/kb/en/json_depth/ +[JSON_DETAILED] +declaration=json_doc[, tab_size] +category=JSON Functions +description=Represents JSON in the most understandable way emphasizing nested structures.\n\nJSON_PRETTY was added as an alias for JSON_DETAILED in MariaDB 10.10.3,\nMariaDB 10.9.5, MariaDB 10.8.7, MariaDB 10.7.8, MariaDB 10.6.12, MariaDB\n10.5.19 and MariaDB 10.4.28.\n\nExample\n-------\n\nSET @j = '{ "A":1,"B":[2,3]}';\n\nSELECT @j;\n+--------------------+\n| @j |\n+--------------------+\n| { "A":1,"B":[2,3]} |\n+--------------------+\n\nSELECT JSON_DETAILED(@j);\n+------------------------------------------------------------+\n| JSON_DETAILED(@j) |\n+------------------------------------------------------------+\n| {\n "A": 1,\n "B":\n [\n 2,\n 3\n ]\n} |\n+------------------------------------------------------------+\n\nURL: https://mariadb.com/kb/en/json_detailed/ +[JSON_EQUALS] +declaration=json1, json2 +category=JSON Functions +description=Checks if there is equality between two json objects. Returns 1 if it there\nis, 0 if not, or NULL if any of the arguments are null.\n\nExamples\n--------\n\nSELECT JSON_EQUALS('{"a" :[1, 2, 3],"b":[4]}', '{"b":[4],"a":[1, 2, 3.0]}');\n+------------------------------------------------------------------------+\n| JSON_EQUALS('{"a" :[1, 2, 3],"b":[4]}', '{"b":[4],"a":[1, 2, 3.0]}') |\n+------------------------------------------------------------------------+\n| 1 |\n+------------------------------------------------------------------------+\n\nSELECT JSON_EQUALS('{"a":[1, 2, 3]}', '{"a":[1, 2, 3.01]}');\n+------------------------------------------------------+\n| JSON_EQUALS('{"a":[1, 2, 3]}', '{"a":[1, 2, 3.01]}') |\n+------------------------------------------------------+\n| 0 |\n+------------------------------------------------------+\n\nURL: https://mariadb.com/kb/en/json_equals/ +[JSON_EXISTS] +declaration='{"key1":"xxxx", "key2":[1, 2, 3]}', "$.key2" +category=JSON Functions +description=+------------------------------------------------------------+\n| JSON_EXISTS('{"key1":"xxxx", "key2":[1, 2, 3]}', "$.key2") |\n+------------------------------------------------------------+\n| 1 |\n+------------------------------------------------------------+\n\nSELECT JSON_EXISTS('{"key1":"xxxx", "key2":[1, 2, 3]}', "$.key3");\n+------------------------------------------------------------+\n| JSON_EXISTS('{"key1":"xxxx", "key2":[1, 2, 3]}', "$.key3") |\n+------------------------------------------------------------+\n| 0 |\n+------------------------------------------------------------+\n\nSELECT JSON_EXISTS('{"key1":"xxxx", "key2":[1, 2, 3]}', "$.key2[1]");\n+---------------------------------------------------------------+\n| JSON_EXISTS('{"key1":"xxxx", "key2":[1, 2, 3]}', "$.key2[1]") |\n+---------------------------------------------------------------+\n| 1 |\n+---------------------------------------------------------------+\n\nSELECT JSON_EXISTS('{"key1":"xxxx", "key2":[1, 2, 3]}', "$.key2[10]");\n+----------------------------------------------------------------+\n| JSON_EXISTS('{"key1":"xxxx", "key2":[1, 2, 3]}', "$.key2[10]") |\n+----------------------------------------------------------------+\n| 0 |\n+----------------------------------------------------------------+\n\nURL: https://mariadb.com/kb/en/json_exists/ +[JSON_EXTRACT] +declaration=json_doc, path[, path] ... +category=JSON Functions +description=Extracts data from a JSON document. The extracted data is selected from the\nparts matching the path arguments. Returns all matched values; either as a\nsingle matched value, or, if the arguments could return multiple values, a\nresult autowrapped as an array in the matching order.\n\nReturns NULL if no paths match or if any of the arguments are NULL.\n\nAn error will occur if any path argument is not a valid path, or if the\njson_doc argument is not a valid JSON document.\n\nThe path expression be a JSONPath expression as supported by MariaDB\n\nExamples\n--------\n\nSET @json = '[1, 2, [3, 4]]';\n\nSELECT JSON_EXTRACT(@json, '$[1]');\n+-----------------------------+\n| JSON_EXTRACT(@json, '$[1]') |\n+-----------------------------+\n| 2 |\n+-----------------------------+\n\nSELECT JSON_EXTRACT(@json, '$[2]');\n+-----------------------------+\n| JSON_EXTRACT(@json, '$[2]') |\n+-----------------------------+\n| [3, 4] |\n+-----------------------------+\n\nSELECT JSON_EXTRACT(@json, '$[2][1]');\n+--------------------------------+\n| JSON_EXTRACT(@json, '$[2][1]') |\n+--------------------------------+\n| 4 |\n+--------------------------------+\n\nURL: https://mariadb.com/kb/en/json_extract/ +[JSON_INSERT] +declaration=json_doc, path, val[, path, val] ... +category=JSON Functions +description=Inserts data into a JSON document, returning the resulting document or NULL if\neither of the json_doc or path arguments are null.\n\nAn error will occur if the JSON document is invalid, or if any of the paths\nare invalid or contain a * or ** wildcard.\n\nJSON_INSERT can only insert data while JSON_REPLACE can only update. JSON_SET\ncan update or insert data.\n\nExamples\n--------\n\nSET @json = '{ "A": 0, "B": [1, 2]}';\n\nSELECT JSON_INSERT(@json, '$.C', '[3, 4]');\n+--------------------------------------+\n| JSON_INSERT(@json, '$.C', '[3, 4]') |\n+--------------------------------------+\n| { "A": 0, "B": [1, 2], "C":"[3, 4]"} |\n+--------------------------------------+\n\nURL: https://mariadb.com/kb/en/json_insert/ +[JSON_KEYS] +declaration=json_doc[, path] +category=JSON Functions +description=Returns the keys as a JSON array from the top-level value of a JSON object or,\nif the optional path argument is provided, the top-level keys from the path.\n\nExcludes keys from nested sub-objects in the top level value. The resulting\narray will be empty if the selected object is empty.\n\nReturns NULL if any of the arguments are null, a given path does not locate an\nobject, or if the json_doc argument is not an object.\n\nAn error will occur if JSON document is invalid, the path is invalid or if the\npath contains a * or ** wildcard.\n\nExamples\n--------\n\nSELECT JSON_KEYS('{"A": 1, "B": {"C": 2}}');\n+--------------------------------------+\n| JSON_KEYS('{"A": 1, "B": {"C": 2}}') |\n+--------------------------------------+\n| ["A", "B"] |\n+--------------------------------------+\n\nSELECT JSON_KEYS('{"A": 1, "B": 2, "C": {"D": 3}}', '$.C');\n+-----------------------------------------------------+\n| JSON_KEYS('{"A": 1, "B": 2, "C": {"D": 3}}', '$.C') |\n+-----------------------------------------------------+\n| ["D"] |\n+-----------------------------------------------------+\n\nURL: https://mariadb.com/kb/en/json_keys/ +[JSON_LENGTH] +declaration=json_doc[, path] +category=JSON Functions +description=Returns the length of a JSON document, or, if the optional path argument is\ngiven, the length of the value within the document specified by the path.\n\nReturns NULL if any of the arguments argument are null or the path argument\ndoes not identify a value in the document.\n\nAn error will occur if the JSON document is invalid, the path is invalid or if\nthe path contains a * or ** wildcard.\n\nLength will be determined as follow:\n\n* A scalar's length is always 1.\n* If an array, the number of elements in the array.\n* If an object, the number of members in the object.\n\nThe length of nested arrays or objects are not counted.\n\nExamples\n--------\n\nURL: https://mariadb.com/kb/en/json_length/ +[JSON_LOOSE] +declaration=json_doc +category=JSON Functions +description=Adds spaces to a JSON document to make it look more readable.\n\nExample\n-------\n\nSET @j = '{ "A":1,"B":[2,3]}';\n\nSELECT JSON_LOOSE(@j), @j;\n+-----------------------+--------------------+\n| JSON_LOOSE(@j) | @j |\n+-----------------------+--------------------+\n| {"A": 1, "B": [2, 3]} | { "A":1,"B":[2,3]} |\n+-----------------------+--------------------+\n\nURL: https://mariadb.com/kb/en/json_loose/ +[JSON_MERGE] +declaration=json_doc, json_doc[, json_doc] ... +category=JSON Functions +description=Merges the given JSON documents.\n\nReturns the merged result,or NULL if any argument is NULL.\n\nAn error occurs if any of the arguments are not valid JSON documents.\n\nJSON_MERGE has been deprecated since MariaDB 10.2.25, MariaDB 10.3.16 and\nMariaDB 10.4.5. JSON_MERGE_PATCH is an RFC 7396-compliant replacement, and\nJSON_MERGE_PRESERVE is a synonym.\n\nExample\n-------\n\nSET @json1 = '[1, 2]';\nSET @json2 = '[3, 4]';\n\nSELECT JSON_MERGE(@json1,@json2);\n+---------------------------+\n| JSON_MERGE(@json1,@json2) |\n+---------------------------+\n| [1, 2, 3, 4] |\n+---------------------------+\n\nURL: https://mariadb.com/kb/en/json_merge/ +[JSON_MERGE_PATCH] +declaration=json_doc, json_doc[, json_doc] ... +category=JSON Functions +description=Merges the given JSON documents, returning the merged result, or NULL if any\nargument is NULL.\n\nJSON_MERGE_PATCH is an RFC 7396-compliant replacement for JSON_MERGE, which\nhas been deprecated.\n\nUnlike JSON_MERGE_PRESERVE, members with duplicate keys are not preserved.\n\nExample\n-------\n\nSET @json1 = '[1, 2]';\nSET @json2 = '[2, 3]';\nSELECT JSON_MERGE_PATCH(@json1,@json2),JSON_MERGE_PRESERVE(@json1,@json2);\n+---------------------------------+------------------------------------+\n| JSON_MERGE_PATCH(@json1,@json2) | JSON_MERGE_PRESERVE(@json1,@json2) |\n+---------------------------------+------------------------------------+\n| [2, 3] | [1, 2, 2, 3] |\n+---------------------------------+------------------------------------+\n\nURL: https://mariadb.com/kb/en/json_merge_patch/ +[JSON_MERGE_PRESERVE] +declaration=json_doc, json_doc[, json_doc] ... +category=JSON Functions +description=Merges the given JSON documents, returning the merged result, or NULL if any\nargument is NULL.\n\nJSON_MERGE_PRESERVE was introduced as a synonym for JSON_MERGE, which has been\ndeprecated.\n\nUnlike JSON_MERGE_PATCH, members with duplicate keys are preserved.\n\nExample\n-------\n\nSET @json1 = '[1, 2]';\nSET @json2 = '[2, 3]';\nSELECT JSON_MERGE_PATCH(@json1,@json2),JSON_MERGE_PRESERVE(@json1,@json2);\n+---------------------------------+------------------------------------+\n| JSON_MERGE_PATCH(@json1,@json2) | JSON_MERGE_PRESERVE(@json1,@json2) |\n+---------------------------------+------------------------------------+\n| [2, 3] | [1, 2, 2, 3] |\n+---------------------------------+------------------------------------+\n\nURL: https://mariadb.com/kb/en/json_merge_preserve/ +[JSON_NORMALIZE] +declaration=json +category=JSON Functions +description=Recursively sorts keys and removes spaces, allowing comparison of json\ndocuments for equality.\n\nExamples\n--------\n\nWe may wish our application to use the database to enforce a unique constraint\non the JSON contents, and we can do so using the JSON_NORMALIZE function in\ncombination with a unique key.\n\nFor example, if we have a table with a JSON column:\n\nCREATE TABLE t1 (\n id BIGINT UNSIGNED NOT NULL AUTO_INCREMENT,\n val JSON,\n /* other columns here */\n PRIMARY KEY (id)\n);\n\nAdd a unique constraint using JSON_NORMALIZE like this:\n\nALTER TABLE t1\n ADD COLUMN jnorm JSON AS (JSON_NORMALIZE(val)) VIRTUAL,\n ADD UNIQUE KEY (jnorm);\n\nWe can test this by first inserting a row as normal:\n\nINSERT INTO t1 (val) VALUES ('{"name":"alice","color":"blue"}');\n\nAnd then seeing what happens with a different string which would produce the\nsame JSON object:\n\nINSERT INTO t1 (val) VALUES ('{ "color": "blue", "name": "alice" }');\nERROR 1062 (23000): Duplicate entry '{"color":"blue","name":"alice"}' for key\n'jnorm'\n\nURL: https://mariadb.com/kb/en/json_normalize/ +[JSON_OBJECT] +declaration=[key, value[, key, value] ...] +category=JSON Functions +description=Returns a JSON object containing the given key/value pairs. The key/value list\ncan be empty.\n\nAn error will occur if there are an odd number of arguments, or any key name\nis NULL.\n\nExample\n-------\n\nSELECT JSON_OBJECT("id", 1, "name", "Monty");\n+---------------------------------------+\n| JSON_OBJECT("id", 1, "name", "Monty") |\n+---------------------------------------+\n| {"id": 1, "name": "Monty"} |\n+---------------------------------------+\n\nURL: https://mariadb.com/kb/en/json_object/ +[JSON_OBJECTAGG] +declaration=key, value +category=JSON Functions +description=JSON_OBJECTAGG returns a JSON object containing key-value pairs. It takes two\nexpressions that evaluate to a single value, or two column names, as\narguments, the first used as a key, and the second as a value.\n\nThe maximum returned length in bytes is determined by the group_concat_max_len\nserver system variable.\n\nReturns NULL in the case of an error, or if the result contains no rows.\n\nJSON_OBJECTAGG cannot currently be used as a window function.\n\nExamples\n--------\n\nselect * from t1;\n+------+-------+\n| a | b |\n+------+-------+\n| 1 | Hello |\n| 1 | World |\n| 2 | This |\n+------+-------+\n\nSELECT JSON_OBJECTAGG(a, b) FROM t1;\n+----------------------------------------+\n| JSON_OBJECTAGG(a, b) |\n+----------------------------------------+\n| {"1":"Hello", "1":"World", "2":"This"} |\n+----------------------------------------+\n\nURL: https://mariadb.com/kb/en/json_objectagg/ +[JSON_OBJECT_FILTER_KEYS] +declaration=obj, array_keys +category=JSON Functions +description=JSON_OBJECT_FILTER_KEYS returns a JSON object with keys from the object that\nare also present in the array as string. It is used when one wants to get\nkey-value pair such that the keys are common but the values may not be common.\n\nExample\n-------\n\nSET @obj1= '{ "a": 1, "b": 2, "c": 3}';\nSET @obj2= '{"b" : 10, "c": 20, "d": 30}';\nSELECT JSON_OBJECT_FILTER_KEYS (@obj1, JSON_ARRAY_INTERSECT(JSON_KEYS(@obj1),\nJSON_KEYS(@obj2)));\n+------------------------------------------------------------------------------\n------------+\n| JSON_OBJECT_FILTER_KEYS (@obj1, JSON_ARRAY_INTERSECT(JSON_KEYS(@obj1),\nJSON_KEYS(@obj2))) |\n+------------------------------------------------------------------------------\n------------+\n| {"b": 2, "c": 3} \n |\n+------------------------------------------------------------------------------\n------------+\n\nURL: https://mariadb.com/kb/en/json_object_filter_keys/ +[JSON_OBJECT_TO_ARRAY] +declaration=Obj +category=JSON Functions +description=It is used to convert all JSON objects found in a JSON document to JSON arrays\nwhere each item in the outer array represents a single key-value pair from the\nobject. It is used when we want not just common keys, but also common values.\nIt can be used in conjunction with JSON_ARRAY_INTERSECT().\n\nExamples\n--------\n\nSET @obj1= '{ "a": [1, 2, 3], "b": { "key1":"val1", "key2": {"key3":"val3"}\n}}';\n\nSELECT JSON_OBJECT_TO_ARRAY(@obj1);\n+-----------------------------------------------------------------------+\n| JSON_OBJECT_TO_ARRAY(@obj1) |\n+-----------------------------------------------------------------------+\n| [["a", [1, 2, 3]], ["b", {"key1": "val1", "key2": {"key3": "val3"}}]] |\n+-----------------------------------------------------------------------+\n\nURL: https://mariadb.com/kb/en/json_object_to_array/ +[JSON_OVERLAPS] +declaration=json_doc1, json_doc2 +category=JSON Functions +description=JSON_OVERLAPS() compares two json documents and returns true if they have at\nleast one common key-value pair between two objects, array element common\nbetween two arrays, or array element common with scalar if one of the\narguments is a scalar and other is an array. If two json documents are\nscalars, it returns true if they have same type and value.\n\nIf none of the above conditions are satisfied then it returns false.\n\nExamples\n--------\n\nSELECT JSON_OVERLAPS('false', 'false');\n+---------------------------------+\n| JSON_OVERLAPS('false', 'false') |\n+---------------------------------+\n| 1 |\n+---------------------------------+\n\nSELECT JSON_OVERLAPS('true', '["abc", 1, 2, true, false]');\n+----------------------------------------------------+\n| JSON_OVERLAPS('true','["abc", 1, 2, true, false]') |\n+----------------------------------------------------+\n| 1 |\n+----------------------------------------------------+\n\nSELECT JSON_OVERLAPS('{"A": 1, "B": {"C":2}}', '{"A": 2, "B": {"C":2}}') AS\nis_overlap;\n+---------------------+\n| is_overlap |\n+---------------------+\n| 1 |\n+---------------------+\n\nPartial match is considered as no-match.\n\nExamples\n--------\n\nSELECT JSON_OVERLAPS('[1, 2, true, false, null]', '[3, 4, [1]]') AS is_overlap;\n+--------------------- +\n| is_overlap |\n+----------------------+\n| 0 |\n+----------------------+\n\nURL: https://mariadb.com/kb/en/json_overlaps/ +[JSON_QUERY] +declaration=json_doc, path +category=JSON Functions +description=Given a JSON document, returns an object or array specified by the path.\nReturns NULL if not given a valid JSON document, or if there is no match.\n\nExamples\n--------\n\nselect json_query('{"key1":{"a":1, "b":[1,2]}}', '$.key1');\n+-----------------------------------------------------+\n| json_query('{"key1":{"a":1, "b":[1,2]}}', '$.key1') |\n+-----------------------------------------------------+\n| {"a":1, "b":[1,2]} |\n+-----------------------------------------------------+\n\nselect json_query('{"key1":123, "key1": [1,2,3]}', '$.key1');\n+-------------------------------------------------------+\n| json_query('{"key1":123, "key1": [1,2,3]}', '$.key1') |\n+-------------------------------------------------------+\n| [1,2,3] |\n+-------------------------------------------------------+\n\nURL: https://mariadb.com/kb/en/json_query/ +[JSON_QUOTE] +declaration=json_value +category=JSON Functions +description=Quotes a string as a JSON value, usually for producing valid JSON string\nliterals for inclusion in JSON documents. Wraps the string with double quote\ncharacters and escapes interior quotes and other special characters, returning\na utf8mb4 string.\n\nReturns NULL if the argument is NULL.\n\nExamples\n--------\n\nSELECT JSON_QUOTE('A'), JSON_QUOTE("B"), JSON_QUOTE('"C"');\n+-----------------+-----------------+-------------------+\n| JSON_QUOTE('A') | JSON_QUOTE("B") | JSON_QUOTE('"C"') |\n+-----------------+-----------------+-------------------+\n| "A" | "B" | "\"C\"" |\n+-----------------+-----------------+-------------------+\n\nURL: https://mariadb.com/kb/en/json_quote/ +[JSON_REMOVE] +declaration=json_doc, path[, path] ... +category=JSON Functions +description=Removes data from a JSON document returning the result, or NULL if any of the\narguments are null. If the element does not exist in the document, no changes\nare made.\n\nThe function returns NULL and throws a warning if the JSON document is\ninvalid, the path is invalid, contains a range, or contains a * or ** wildcard.\n\nPath arguments are evaluated from left to right, with the result from the\nearlier evaluation being used as the value for the next.\n\nExamples\n--------\n\nSELECT JSON_REMOVE('{"A": 1, "B": 2, "C": {"D": 3}}', '$.C');\n+-------------------------------------------------------+\n| JSON_REMOVE('{"A": 1, "B": 2, "C": {"D": 3}}', '$.C') |\n+-------------------------------------------------------+\n| {"A": 1, "B": 2} |\n+-------------------------------------------------------+\n\nSELECT JSON_REMOVE('["A", "B", ["C", "D"], "E"]', '$[1]');\n+----------------------------------------------------+\n| JSON_REMOVE('["A", "B", ["C", "D"], "E"]', '$[1]') |\n+----------------------------------------------------+\n| ["A", ["C", "D"], "E"] |\n+----------------------------------------------------+\n\nURL: https://mariadb.com/kb/en/json_remove/ +[JSON_REPLACE] +declaration=json_doc, path, val[, path, val] ... +category=JSON Functions +description=Replaces existing values in a JSON document, returning the result, or NULL if\nany of the arguments are NULL.\n\nAn error will occur if the JSON document is invalid, the path is invalid or if\nthe path contains a * or ** wildcard.\n\nPaths and values are evaluated from left to right, with the result from the\nearlier evaluation being used as the value for the next.\n\nJSON_REPLACE can only update data, while JSON_INSERT can only insert. JSON_SET\ncan update or insert data.\n\nExamples\n--------\n\nSELECT JSON_REPLACE('{ "A": 1, "B": [2, 3]}', '$.B[1]', 4);\n+-----------------------------------------------------+\n| JSON_REPLACE('{ "A": 1, "B": [2, 3]}', '$.B[1]', 4) |\n+-----------------------------------------------------+\n| { "A": 1, "B": [2, 4]} |\n+-----------------------------------------------------+\n\nURL: https://mariadb.com/kb/en/json_replace/ +[JSON_SCHEMA_VALID] +declaration=schema, json +category=JSON Functions +description=JSON_SCHEMA_VALID allows MariaDB to support JSON schema validation. If a given\njson is valid against a schema it returns true. When JSON does not validate\nagainst the schema, it does not return a message about which keyword it failed\nagainst and only returns false.\n\nThe function supports JSON Schema Draft 2020 with a few exceptions:\n\n* External resources are not supported\n* Hyper schema keywords are not supported\n* Formats like date, email etc are treated as annotations.\n\nExamples\n--------\n\nTo create validation rules for json field\n\nCREATE TABLE obj_table(val_obj JSON CHECK(JSON_SCHEMA_VALID('{\n "type":"object",\n "properties": {\n "number1":{\n "type":"number",\n "maximum":5,\n "const":4\n },\n "string1":{\n "type":"string",\n "maxLength":5,\n "minLength":3\n },\n "object1":{\n "type":"object",\n "properties":{\n "key1": {"type":"string"},\n "key2":{"type":"array"},\n "key3":{"type":"number", "minimum":3}\n },\n "dependentRequired": { "key1":["key3"] }\n }\n },\n "required":["number1","object1"]\n }', val_obj)));\n\nINSERT INTO obj_table VALUES(\n '{"number1":4, "string1":"abcd",\n "object1":{"key1":"val1", "key2":[1,2,3, "string1"], "key3":4}}'\n);\n\nINSERT INTO obj_table VALUES(\n '{"number1":3, "string1":"abcd",\n "object1":{"key1":"val1", "key2":[1,2,3, "string1"], "key3":4}}'\n ... +[JSON_SEARCH] +declaration=json_doc, return_arg, search_str[, escape_char[, path] ...] +category=JSON Functions +description=Returns the path to the given string within a JSON document, or NULL if any of\njson_doc, search_str or a path argument is NULL; if the search string is not\nfound, or if no path exists within the document.\n\nA warning will occur if the JSON document is not valid, any of the path\narguments are not valid, if return_arg is neither one nor all, or if the\nescape character is not a constant. NULL will be returned.\n\nreturn_arg can be one of two values:\n\n* 'one: Terminates after finding the first match, so will return one path\nstring. If there is more than one match, it is undefined which is considered\nfirst.\n* all: Returns all matching path strings, without duplicates. Multiple strings\nare autowrapped as an array. The order is undefined.\n\nExamples\n--------\n\nSET @json = '["A", [{"B": "1"}], {"C":"AB"}, {"D":"BC"}]';\n\nSELECT JSON_SEARCH(@json, 'one', 'AB');\n+---------------------------------+\n| JSON_SEARCH(@json, 'one', 'AB') |\n+---------------------------------+\n| "$[2].C" |\n+---------------------------------+\n\nURL: https://mariadb.com/kb/en/json_search/ +[JSON_SET] +declaration=json_doc, path, val[, path, val] ... +category=JSON Functions +description=Updates or inserts data into a JSON document, returning the result, or NULL if\nany of the arguments are NULL or the optional path fails to find an object.\n\nAn error will occur if the JSON document is invalid, the path is invalid or if\nthe path contains a * or wildcard.\n\nJSON_SET can update or insert data, while JSON_REPLACE can only update, and\nJSON_INSERT only insert.\n\nExamples\n--------\n\nSELECT JSON_SET(Priv, '$.locked', 'true') FROM mysql.global_priv\n\nURL: https://mariadb.com/kb/en/json_set/ +[JSON_TABLE] +declaration=json_doc, context_path COLUMNS (column_list +category=JSON Functions +description=JSON_TABLE can be used in contexts where a table reference can be used; in the\nFROM clause of a SELECT statement, and in multi-table UPDATE/DELETE statements.\n\njson_doc is the JSON document to extract data from. In the simplest case, it\nis a string literal containing JSON. In more complex cases it can be an\narbitrary expression returning JSON. The expression may have references to\ncolumns of other tables. However, one can only refer to tables that precede\nthis JSON_TABLE invocation. For RIGHT JOIN, it is assumed that its outer side\nprecedes the inner. All tables in outer selects are also considered preceding.\n\ncontext_path is a JSON Path expression pointing to a collection of nodes in\njson_doc that will be used as the source of rows.\n\nThe COLUMNS clause declares the names and types of the columns that JSON_TABLE\nreturns, as well as how the values of the columns are produced.\n\nColumn Definitions\n------------------\n\nThe following types of columns are supported:\n\nPath Columns\n------------\n\nname type PATH path_str [on_empty] [on_error]\n\nLocates the JSON node pointed to by path_str and returns its value. The\npath_str is evaluated using the current row source node as the context node.\n\nset @json='\n[\n {"name":"Laptop", "color":"black", "price":"1000"},\n {"name":"Jeans", "color":"blue"}\n]';\n\nselect * from json_table(@json, '$[*]' \n columns(\n name varchar(10) path '$.name',\n color varchar(10) path '$.color',\n price decimal(8,2) path '$.price' )\n) as jt;\n+--------+-------+---------+\n| name | color | price |\n+--------+-------+---------+\n| Laptop | black | 1000.00 |\n| Jeans | blue | NULL |\n+--------+-------+---------+\n\nThe on_empty and on_error clauses specify the actions to be performed when the\nvalue was not found or there was an error condition. See the ON EMPTY and ON\n ... +[JSON_TYPE] +declaration=json_val +category=JSON Functions +description=Returns the type of a JSON value (as a string), or NULL if the argument is\nnull.\n\nAn error will occur if the argument is an invalid JSON value.\n\nThe following is a complete list of the possible return types:\n\n+-----------------------------------+-----------------+-----------------------+\n| Return type | Value | Example |\n+-----------------------------------+-----------------+-----------------------+\n| ARRAY | JSON array | [1, 2, {"key": |\n| | | "value"}] |\n+-----------------------------------+-----------------+-----------------------+\n| OBJECT | JSON object | {"key":"value"} |\n+-----------------------------------+-----------------+-----------------------+\n| BOOLEAN | JSON | true, false |\n| | true/false | |\n| | literals | |\n+-----------------------------------+-----------------+-----------------------+\n| DOUBLE | A number with | 1.2 |\n| | at least one | |\n| | floating point | |\n| | decimal. | |\n+-----------------------------------+-----------------+-----------------------+\n| INTEGER | A number | 1 |\n| | without a | |\n| | floating point | |\n| | decimal. | |\n+-----------------------------------+-----------------+-----------------------+\n| NULL | JSON null | null |\n| | literal (this | |\n| | is returned as | |\n| | a string, not | |\n| | to be confused | |\n| | with the SQL | |\n| | NULL value!) | |\n+-----------------------------------+-----------------+-----------------------+\n| STRING | JSON String | "a sample string" |\n+-----------------------------------+-----------------+-----------------------+\n\nExamples\n--------\n\nSELECT JSON_TYPE('{"A": 1, "B": 2, "C": 3}');\n+---------------------------------------+\n| JSON_TYPE('{"A": 1, "B": 2, "C": 3}') |\n+---------------------------------------+\n| OBJECT |\n+---------------------------------------+\n\nURL: https://mariadb.com/kb/en/json_type/ +[JSON_UNQUOTE] +declaration=val +category=JSON Functions +description=Unquotes a JSON value, returning a string, or NULL if the argument is null.\n\nAn error will occur if the given value begins and ends with double quotes and\nis an invalid JSON string literal.\n\nIf the given value is not a JSON string, value is passed through unmodified.\n\nCertain character sequences have special meanings within a string. Usually, a\nbackslash is ignored, but the escape sequences in the table below are\nrecognised by MariaDB, unless the SQL Mode is set to NO_BACKSLASH_ESCAPES SQL.\n\n+-----------------------------------------------+-----------------------------+\n| Escape sequence | Character |\n+-----------------------------------------------+-----------------------------+\n| \" | Double quote (") |\n+-----------------------------------------------+-----------------------------+\n| \b | Backslash |\n+-----------------------------------------------+-----------------------------+\n| \f | Formfeed |\n+-----------------------------------------------+-----------------------------+\n| \n | Newline (linefeed) |\n+-----------------------------------------------+-----------------------------+\n| \r | Carriage return |\n+-----------------------------------------------+-----------------------------+\n| \t | Tab |\n+-----------------------------------------------+-----------------------------+\n| \\ | Backslash (\) |\n+-----------------------------------------------+-----------------------------+\n| \uXXXX | UTF-8 bytes for Unicode |\n| | value XXXX |\n+-----------------------------------------------+-----------------------------+\n\nExamples\n--------\n\nSELECT JSON_UNQUOTE('"Monty"');\n+-------------------------+\n| JSON_UNQUOTE('"Monty"') |\n+-------------------------+\n| Monty |\n+-------------------------+\n\nWith the default SQL Mode:\n\nSELECT JSON_UNQUOTE('Si\bng\ting');\n+-----------------------------+\n| JSON_UNQUOTE('Si\bng\ting') |\n+-----------------------------+\n| Sng ing |\n+-----------------------------+\n ... +[JSON_VALID] +declaration=value +category=JSON Functions +description=Indicates whether the given value is a valid JSON document or not. Returns 1\nif valid, 0 if not, and NULL if the argument is NULL.\n\nFrom MariaDB 10.4.3, the JSON_VALID function is automatically used as a CHECK\nconstraint for the JSON data type alias in order to ensure that a valid json\ndocument is inserted.\n\nExamples\n--------\n\nSELECT JSON_VALID('{"id": 1, "name": "Monty"}');\n+------------------------------------------+\n| JSON_VALID('{"id": 1, "name": "Monty"}') |\n+------------------------------------------+\n| 1 |\n+------------------------------------------+\n\nSELECT JSON_VALID('{"id": 1, "name": "Monty", "oddfield"}');\n+------------------------------------------------------+\n| JSON_VALID('{"id": 1, "name": "Monty", "oddfield"}') |\n+------------------------------------------------------+\n| 0 |\n+------------------------------------------------------+\n\nURL: https://mariadb.com/kb/en/json_valid/ +[JSON_VALUE] +declaration=json_doc, path +category=JSON Functions +description=Given a JSON document, returns the scalar specified by the path. Returns NULL\nif not given a valid JSON document, or if there is no match.\n\nExamples\n--------\n\nselect json_value('{"key1":123}', '$.key1');\n+--------------------------------------+\n| json_value('{"key1":123}', '$.key1') |\n+--------------------------------------+\n| 123 |\n+--------------------------------------+\n\nselect json_value('{"key1": [1,2,3], "key1":123}', '$.key1');\n+-------------------------------------------------------+\n| json_value('{"key1": [1,2,3], "key1":123}', '$.key1') |\n+-------------------------------------------------------+\n| 123 |\n+-------------------------------------------------------+\n\nIn the SET statement below, two escape characters are needed, as a single\nescape character would be applied by the SQL parser in the SET statement, and\nthe escaped character would not form part of the saved value.\n\nSET @json = '{"key1":"60\\" Table", "key2":"1"}';\n\nSELECT JSON_VALUE(@json,'$.key1') AS Name , json_value(@json,'$.key2') as ID;\n+-----------+------+\n| Name | ID |\n+-----------+------+\n| 60" Table | 1 |\n+-----------+------+\n\nURL: https://mariadb.com/kb/en/json_value/ +[KDF] +declaration= +category=Encryption Functions +description=KDF is a key derivation function, similar to OpenSSL's EVP_KDF_derive(). The\npurpose of a KDF is to be slow, so if the calculated value is lost/stolen, the\noriginal key_str is not achievable easily with modern GPU. KDFs are therefore\nan ideal replacement for password hashes. KDFs can also pad out a password\nsecret to the number of bits used in encryption algorithms.\n\nFor generating good encryption keys for AES_ENCRYPT a less expensive function,\nbut cryptographically secure function like RANDOM_BYTES is recommended..\n\n* kdf_name is "hkdf" or "pbkdf2_hmac" (default)\n* width (in bits) can be any number divisible by 8, by default it's taken from\n@@block_encryption_mode\n* iterations must be positive, and is 1000 by default\n\nNote that OpenSSL 1.0 doesn't support HKDF, so in this case NULL is returned.\nThis OpenSSL version is still used in SLES 12 and CentOS 7.\n\nExamples\n--------\n\nselect hex(kdf('foo', 'bar', 'infa', 'hkdf')); \n+----------------------------------------+\n| hex(kdf('foo', 'bar', 'infa', 'hkdf')) |\n+----------------------------------------+\n| 612875F859CFB4EE0DFEFF9F2A18E836 |\n+----------------------------------------+\n\nURL: https://mariadb.com/kb/en/kdf/ +[LAG] +declaration=expr[, offset] +category=Window Functions +description=The LAG function accesses data from a previous row according to the ORDER BY\nclause without the need for a self-join. The specific row is determined by the\noffset (default 1), which specifies the number of rows behind the current row\nto use. An offset of 0 is the current row.\n\nExamples\n--------\n\nCREATE TABLE t1 (pk int primary key, a int, b int, c char(10), d decimal(10,\n3), e real);\n\nINSERT INTO t1 VALUES\n ( 1, 0, 1, 'one', 0.1, 0.001),\n ( 2, 0, 2, 'two', 0.2, 0.002),\n ( 3, 0, 3, 'three', 0.3, 0.003),\n ( 4, 1, 2, 'three', 0.4, 0.004),\n ( 5, 1, 1, 'two', 0.5, 0.005),\n ( 6, 1, 1, 'one', 0.6, 0.006),\n ( 7, 2, NULL, 'n_one', 0.5, 0.007),\n ( 8, 2, 1, 'n_two', NULL, 0.008),\n ( 9, 2, 2, NULL, 0.7, 0.009),\n (10, 2, 0, 'n_four', 0.8, 0.010),\n (11, 2, 10, NULL, 0.9, NULL);\n\nSELECT pk, LAG(pk) OVER (ORDER BY pk) AS l,\n LAG(pk,1) OVER (ORDER BY pk) AS l1,\n LAG(pk,2) OVER (ORDER BY pk) AS l2,\n LAG(pk,0) OVER (ORDER BY pk) AS l0,\n LAG(pk,-1) OVER (ORDER BY pk) AS lm1,\n LAG(pk,-2) OVER (ORDER BY pk) AS lm2\nFROM t1;\n+----+------+------+------+------+------+------+\n| pk | l | l1 | l2 | l0 | lm1 | lm2 |\n+----+------+------+------+------+------+------+\n| 1 | NULL | NULL | NULL | 1 | 2 | 3 |\n| 2 | 1 | 1 | NULL | 2 | 3 | 4 |\n| 3 | 2 | 2 | 1 | 3 | 4 | 5 |\n| 4 | 3 | 3 | 2 | 4 | 5 | 6 |\n| 5 | 4 | 4 | 3 | 5 | 6 | 7 |\n| 6 | 5 | 5 | 4 | 6 | 7 | 8 |\n| 7 | 6 | 6 | 5 | 7 | 8 | 9 |\n| 8 | 7 | 7 | 6 | 8 | 9 | 10 |\n| 9 | 8 | 8 | 7 | 9 | 10 | 11 |\n| 10 | 9 | 9 | 8 | 10 | 11 | NULL |\n| 11 | 10 | 10 | 9 | 11 | NULL | NULL |\n+----+------+------+------+------+------+------+\n\nURL: https://mariadb.com/kb/en/lag/ +[LAST_DAY] +declaration=date +category=Date and Time Functions +description=Takes a date or datetime value and returns the corresponding value for the\nlast day of the month. Returns NULL if the argument is invalid.\n\nExamples\n--------\n\nSELECT LAST_DAY('2003-02-05');\n+------------------------+\n| LAST_DAY('2003-02-05') |\n+------------------------+\n| 2003-02-28 |\n+------------------------+\n\nSELECT LAST_DAY('2004-02-05');\n+------------------------+\n| LAST_DAY('2004-02-05') |\n+------------------------+\n| 2004-02-29 |\n+------------------------+\n\nSELECT LAST_DAY('2004-01-01 01:01:01');\n+---------------------------------+\n| LAST_DAY('2004-01-01 01:01:01') |\n+---------------------------------+\n| 2004-01-31 |\n+---------------------------------+\n\nSELECT LAST_DAY('2003-03-32');\n+------------------------+\n| LAST_DAY('2003-03-32') |\n+------------------------+\n| NULL |\n+------------------------+\n1 row in set, 1 warning (0.00 sec)\n\nWarning (Code 1292): Incorrect datetime value: '2003-03-32'\n\nURL: https://mariadb.com/kb/en/last_day/ +[LAST_INSERT_ID] +declaration= +category=Information Functions +description=LAST_INSERT_ID() (no arguments) returns the first automatically generated\nvalue successfully inserted for an AUTO_INCREMENT column as a result of the\nmost recently executed INSERT statement. The value of LAST_INSERT_ID() remains\nunchanged if no rows are successfully inserted.\n\nIf one gives an argument to LAST_INSERT_ID(), then it will return the value of\nthe expression and the next call to LAST_INSERT_ID() will return the same\nvalue. The value will also be sent to the client and can be accessed by the\nmysql_insert_id function.\n\nFor example, after inserting a row that generates an AUTO_INCREMENT value, you\ncan get the value like this:\n\nSELECT LAST_INSERT_ID();\n+------------------+\n| LAST_INSERT_ID() |\n+------------------+\n| 9 |\n+------------------+\n\nYou can also use LAST_INSERT_ID() to delete the last inserted row:\n\nDELETE FROM product WHERE id = LAST_INSERT_ID();\n\nIf no rows were successfully inserted, LAST_INSERT_ID() returns 0.\n\nThe value of LAST_INSERT_ID() will be consistent across all versions if all\nrows in the INSERT or UPDATE statement were successful.\n\nThe currently executing statement does not affect the value of\nLAST_INSERT_ID(). Suppose that you generate an AUTO_INCREMENT value with one\nstatement, and then refer to LAST_INSERT_ID() in a multiple-row INSERT\nstatement that inserts rows into a table with its own AUTO_INCREMENT column.\nThe value of LAST_INSERT_ID() will remain stable in the second statement; its\nvalue for the second and later rows is not affected by the earlier row\ninsertions. (However, if you mix references to LAST_INSERT_ID() and\nLAST_INSERT_ID(expr), the effect is undefined.)\n\nIf the previous statement returned an error, the value of LAST_INSERT_ID() is\nundefined. For transactional tables, if the statement is rolled back due to an\nerror, the value of LAST_INSERT_ID() is left undefined. For manual ROLLBACK,\nthe value of LAST_INSERT_ID() is not restored to that before the transaction;\nit remains as it was at the point of the ROLLBACK.\n\nWithin the body of a stored routine (procedure or function) or a trigger, the\nvalue of LAST_INSERT_ID() changes the same way as for statements executed\noutside the body of these kinds of objects. The effect of a stored routine or\ntrigger upon the value of LAST_INSERT_ID() that is seen by following\nstatements depends on the kind of routine:\n\n ... +[LAST_VALUE] +declaration=expr,[expr,...] +category=Information Functions +description=LAST_VALUE() evaluates all expressions and returns the last.\n\nThis is useful together with setting user variables to a value with\n@var:=expr, for example when you want to get data of rows updated/deleted\nwithout having to do two queries against the table.\n\nLAST_VALUE can be used as a window function.\n\nReturns NULL if no last value exists.\n\nExamples\n--------\n\nCREATE TABLE t1 (a int, b int);\nINSERT INTO t1 VALUES(1,10),(2,20);\nDELETE FROM t1 WHERE a=1 AND last_value(@a:=a,@b:=b,1);\nSELECT @a,@b;\n+------+------+\n| @a | @b |\n+------+------+\n| 1 | 10 |\n+------+------+\n\nAs a window function:\n\nCREATE TABLE t1 (\n pk int primary key,\n a int,\n b int,\n c char(10),\n d decimal(10, 3),\n e real\n);\n\nINSERT INTO t1 VALUES\n( 1, 0, 1, 'one', 0.1, 0.001),\n( 2, 0, 2, 'two', 0.2, 0.002),\n( 3, 0, 3, 'three', 0.3, 0.003),\n( 4, 1, 2, 'three', 0.4, 0.004),\n( 5, 1, 1, 'two', 0.5, 0.005),\n( 6, 1, 1, 'one', 0.6, 0.006),\n( 7, 2, NULL, 'n_one', 0.5, 0.007),\n( 8, 2, 1, 'n_two', NULL, 0.008),\n( 9, 2, 2, NULL, 0.7, 0.009),\n(10, 2, 0, 'n_four', 0.8, 0.010),\n(11, 2, 10, NULL, 0.9, NULL);\n\nSELECT pk, FIRST_VALUE(pk) OVER (ORDER BY pk) AS first_asc,\n LAST_VALUE(pk) OVER (ORDER BY pk) AS last_asc,\n FIRST_VALUE(pk) OVER (ORDER BY pk DESC) AS first_desc,\n ... +[LCASE] +declaration=str +category=String Functions +description=LCASE() is a synonym for LOWER().\n\nURL: https://mariadb.com/kb/en/lcase/ +[LEAD] +declaration=expr[, offset] +category=Window Functions +description=The LEAD function accesses data from a following row in the same result set\nwithout the need for a self-join. The specific row is determined by the offset\n(default 1), which specifies the number of rows ahead the current row to use.\nAn offset of 0 is the current row.\n\nExample\n-------\n\nCREATE TABLE t1 (pk int primary key, a int, b int, c char(10), d decimal(10,\n3), e real);\n\nINSERT INTO t1 VALUES\n ( 1, 0, 1, 'one', 0.1, 0.001),\n ( 2, 0, 2, 'two', 0.2, 0.002),\n ( 3, 0, 3, 'three', 0.3, 0.003),\n ( 4, 1, 2, 'three', 0.4, 0.004),\n ( 5, 1, 1, 'two', 0.5, 0.005),\n ( 6, 1, 1, 'one', 0.6, 0.006),\n ( 7, 2, NULL, 'n_one', 0.5, 0.007),\n ( 8, 2, 1, 'n_two', NULL, 0.008),\n ( 9, 2, 2, NULL, 0.7, 0.009),\n (10, 2, 0, 'n_four', 0.8, 0.010),\n (11, 2, 10, NULL, 0.9, NULL);\n\nSELECT pk, LEAD(pk) OVER (ORDER BY pk) AS l,\n LEAD(pk,1) OVER (ORDER BY pk) AS l1,\n LEAD(pk,2) OVER (ORDER BY pk) AS l2,\n LEAD(pk,0) OVER (ORDER BY pk) AS l0,\n LEAD(pk,-1) OVER (ORDER BY pk) AS lm1,\n LEAD(pk,-2) OVER (ORDER BY pk) AS lm2\nFROM t1;\n+----+------+------+------+------+------+------+\n| pk | l | l1 | l2 | l0 | lm1 | lm2 |\n+----+------+------+------+------+------+------+\n| 1 | 2 | 2 | 3 | 1 | NULL | NULL |\n| 2 | 3 | 3 | 4 | 2 | 1 | NULL |\n| 3 | 4 | 4 | 5 | 3 | 2 | 1 |\n| 4 | 5 | 5 | 6 | 4 | 3 | 2 |\n| 5 | 6 | 6 | 7 | 5 | 4 | 3 |\n| 6 | 7 | 7 | 8 | 6 | 5 | 4 |\n| 7 | 8 | 8 | 9 | 7 | 6 | 5 |\n| 8 | 9 | 9 | 10 | 8 | 7 | 6 |\n| 9 | 10 | 10 | 11 | 9 | 8 | 7 |\n| 10 | 11 | 11 | NULL | 10 | 9 | 8 |\n| 11 | NULL | NULL | NULL | 11 | 10 | 9 |\n+----+------+------+------+------+------+------+\n\nURL: https://mariadb.com/kb/en/lead/ +[LEAST] +declaration=value1,value2,... +category=Comparison Operators +description=With two or more arguments, returns the smallest (minimum-valued) argument.\nThe arguments are compared using the following rules:\n\n* If the return value is used in an INTEGER context or all arguments are\ninteger-valued, they are compared as integers.\n* If the return value is used in a REAL context or all arguments are\nreal-valued, they are compared as reals.\n* If any argument is a case-sensitive string, the arguments are compared as\ncase-sensitive strings.\n* In all other cases, the arguments are compared as case-insensitive strings.\n\nLEAST() returns NULL if any argument is NULL.\n\nExamples\n--------\n\nSELECT LEAST(2,0);\n+------------+\n| LEAST(2,0) |\n+------------+\n| 0 |\n+------------+\n\nSELECT LEAST(34.0,3.0,5.0,767.0);\n+---------------------------+\n| LEAST(34.0,3.0,5.0,767.0) |\n+---------------------------+\n| 3.0 |\n+---------------------------+\n\nSELECT LEAST('B','A','C');\n+--------------------+\n| LEAST('B','A','C') |\n+--------------------+\n| A |\n+--------------------+\n\nURL: https://mariadb.com/kb/en/least/ +[LEFT] +declaration=str,len +category=String Functions +description=Returns the leftmost len characters from the string str, or NULL if any\nargument is NULL.\n\nExamples\n--------\n\nSELECT LEFT('MariaDB', 5);\n+--------------------+\n| LEFT('MariaDB', 5) |\n+--------------------+\n| Maria |\n+--------------------+\n\nURL: https://mariadb.com/kb/en/left/ +[LENGTH] +declaration=str +category=String Functions +description=Returns the length of the string str.\n\nIn the default mode, when Oracle mode from MariaDB 10.3 is not set, the length\nis measured in bytes. In this case, a multi-byte character counts as multiple\nbytes. This means that for a string containing five two-byte characters,\nLENGTH() returns 10, whereas CHAR_LENGTH() returns 5.\n\nWhen running Oracle mode from MariaDB 10.3, the length is measured in\ncharacters, and LENGTH is a synonym for CHAR_LENGTH().\n\nIf str is not a string value, it is converted into a string. If str is NULL,\nthe function returns NULL.\n\nExamples\n--------\n\nSELECT LENGTH('MariaDB');\n+-------------------+\n| LENGTH('MariaDB') |\n+-------------------+\n| 7 |\n+-------------------+\n\nWhen Oracle mode from MariaDB 10.3 is not set:\n\nSELECT CHAR_LENGTH('π'), LENGTH('π'), LENGTHB('π'), OCTET_LENGTH('π');\n+-------------------+--------------+---------------+--------------------+\n| CHAR_LENGTH('π') | LENGTH('π') | LENGTHB('π') | OCTET_LENGTH('π') |\n+-------------------+--------------+---------------+--------------------+\n| 1 | 2 | 2 | 2 |\n+-------------------+--------------+---------------+--------------------+\n\nIn Oracle mode from MariaDB 10.3:\n\nSELECT CHAR_LENGTH('π'), LENGTH('π'), LENGTHB('π'), OCTET_LENGTH('π');\n+-------------------+--------------+---------------+--------------------+\n| CHAR_LENGTH('π') | LENGTH('π') | LENGTHB('π') | OCTET_LENGTH('π') |\n+-------------------+--------------+---------------+--------------------+\n| 1 | 1 | 2 | 2 |\n+-------------------+--------------+---------------+--------------------+\n\nURL: https://mariadb.com/kb/en/length/ +[LENGTHB] +declaration=str +category=String Functions +description=LENGTHB() returns the length of the given string, in bytes. When Oracle mode\nis not set, this is a synonym for LENGTH.\n\nA multi-byte character counts as multiple bytes. This means that for a string\ncontaining five two-byte characters, LENGTHB() returns 10, whereas\nCHAR_LENGTH() returns 5.\n\nIf str is not a string value, it is converted into a string. If str is NULL,\nthe function returns NULL.\n\nExamples\n--------\n\nWhen Oracle mode from MariaDB 10.3 is not set:\n\nSELECT CHAR_LENGTH('π'), LENGTH('π'), LENGTHB('π'), OCTET_LENGTH('π');\n+-------------------+--------------+---------------+--------------------+\n| CHAR_LENGTH('π') | LENGTH('π') | LENGTHB('π') | OCTET_LENGTH('π') |\n+-------------------+--------------+---------------+--------------------+\n| 1 | 2 | 2 | 2 |\n+-------------------+--------------+---------------+--------------------+\n\nIn Oracle mode from MariaDB 10.3:\n\nSELECT CHAR_LENGTH('π'), LENGTH('π'), LENGTHB('π'), OCTET_LENGTH('π');\n+-------------------+--------------+---------------+--------------------+\n| CHAR_LENGTH('π') | LENGTH('π') | LENGTHB('π') | OCTET_LENGTH('π') |\n+-------------------+--------------+---------------+--------------------+\n| 1 | 1 | 2 | 2 |\n+-------------------+--------------+---------------+--------------------+\n\nURL: https://mariadb.com/kb/en/lengthb/ +[LIMIT] +declaration=or ORDER BY +category=Data Manipulation +description=multi-table UPDATE statement. This restriction was lifted in MariaDB 10.3.2.\n\nGROUP_CONCAT\n------------\n\nStarting from MariaDB 10.3.3, it is possible to use LIMIT with GROUP_CONCAT().\n\nExamples\n--------\n\nCREATE TABLE members (name VARCHAR(20));\nINSERT INTO members VALUES('Jagdish'),('Kenny'),('Rokurou'),('Immaculada');\n\nSELECT * FROM members;\n+------------+\n| name |\n+------------+\n| Jagdish |\n| Kenny |\n| Rokurou |\n| Immaculada |\n+------------+\n\nSelect the first two names (no ordering specified):\n\nSELECT * FROM members LIMIT 2;\n+---------+\n| name |\n+---------+\n| Jagdish |\n| Kenny |\n+---------+\n\nAll the names in alphabetical order:\n\nSELECT * FROM members ORDER BY name;\n+------------+\n| name |\n+------------+\n| Immaculada |\n| Jagdish |\n| Kenny |\n| Rokurou |\n+------------+\n\nThe first two names, ordered alphabetically:\n\nSELECT * FROM members ORDER BY name LIMIT 2;\n+------------+\n| name |\n ... +[LINESTRING] +declaration=pt1,pt2,... +category=Geometry Constructors +description=Constructs a WKB LineString value from a number of WKB Point arguments. If any\nargument is not a WKB Point, the return value is NULL. If the number of Point\narguments is less than two, the return value is NULL.\n\nExamples\n--------\n\nSET @ls = 'LineString(1 1,2 2,3 3)';\n\nSELECT AsText(EndPoint(GeomFromText(@ls)));\n+-------------------------------------+\n| AsText(EndPoint(GeomFromText(@ls))) |\n+-------------------------------------+\n| POINT(3 3) |\n+-------------------------------------+\n\nCREATE TABLE gis_line (g LINESTRING);\nINSERT INTO gis_line VALUES\n (LineFromText('LINESTRING(0 0,0 10,10 0)')),\n (LineStringFromText('LINESTRING(10 10,20 10,20 20,10 20,10 10)')),\n (LineStringFromWKB(AsWKB(LineString(Point(10, 10), Point(40, 10)))));\n\nURL: https://mariadb.com/kb/en/linestring/ +[LN] +declaration=X +category=Numeric Functions +description=Returns the natural logarithm of X; that is, the base-e logarithm of X. If X\nis less than or equal to 0, or NULL, then NULL is returned.\n\nThe inverse of this function is EXP().\n\nExamples\n--------\n\nSELECT LN(2);\n+-------------------+\n| LN(2) |\n+-------------------+\n| 0.693147180559945 |\n+-------------------+\n\nSELECT LN(-2);\n+--------+\n| LN(-2) |\n+--------+\n| NULL |\n+--------+\n\nURL: https://mariadb.com/kb/en/ln/ +[LOAD_FILE] +declaration=file_name +category=String Functions +description=Reads the file and returns the file contents as a string. To use this\nfunction, the file must be located on the server host, you must specify the\nfull path name to the file, and you must have the FILE privilege. The file\nmust be readable by all and it must be less than the size, in bytes, of the\nmax_allowed_packet system variable. If the secure_file_priv system variable is\nset to a non-empty directory name, the file to be loaded must be located in\nthat directory.\n\nIf the file does not exist or cannot be read because one of the preceding\nconditions is not satisfied, the function returns NULL.\n\nSince MariaDB 5.1, the character_set_filesystem system variable has controlled\ninterpretation of file names that are given as literal strings.\n\nStatements using the LOAD_FILE() function are not safe for statement based\nreplication. This is because the slave will execute the LOAD_FILE() command\nitself. If the file doesn't exist on the slave, the function will return NULL.\n\nExamples\n--------\n\nUPDATE t SET blob_col=LOAD_FILE('/tmp/picture') WHERE id=1;\n\nURL: https://mariadb.com/kb/en/load_file/ +[LOCALTIME] +declaration=[precision] +category=Date and Time Functions +description=LOCALTIME and LOCALTIME() are synonyms for NOW().\n\nURL: https://mariadb.com/kb/en/localtime/ +[LOCALTIMESTAMP] +declaration=[precision] +category=Date and Time Functions +description=LOCALTIMESTAMP and LOCALTIMESTAMP() are synonyms for NOW().\n\nURL: https://mariadb.com/kb/en/localtimestamp/ +[LOCATE] +declaration=substr,str +category=String Functions +description=The first syntax returns the position of the first occurrence of substring\nsubstr in string str. The second syntax returns the position of the first\noccurrence of substring substr in string str, starting at position pos.\nReturns 0 if substr is not in str.\n\nLOCATE() performs a case-insensitive search.\n\nIf any argument is NULL, returns NULL.\n\nINSTR() is the same as the two-argument form of LOCATE(), except that the\norder of the arguments is reversed.\n\nExamples\n--------\n\nSELECT LOCATE('bar', 'foobarbar');\n+----------------------------+\n| LOCATE('bar', 'foobarbar') |\n+----------------------------+\n| 4 |\n+----------------------------+\n\nSELECT LOCATE('My', 'Maria');\n+-----------------------+\n| LOCATE('My', 'Maria') |\n+-----------------------+\n| 0 |\n+-----------------------+\n\nSELECT LOCATE('bar', 'foobarbar', 5);\n+-------------------------------+\n| LOCATE('bar', 'foobarbar', 5) |\n+-------------------------------+\n| 7 |\n+-------------------------------+\n\nURL: https://mariadb.com/kb/en/locate/ +[LOG] +declaration=X +category=Numeric Functions +description=If called with one parameter, this function returns the natural logarithm of\nX. If X is less than or equal to 0, then NULL is returned.\n\nIf called with two parameters, it returns the logarithm of X to the base B. If\nB is <= 1 or X <= 0, the function returns NULL.\n\nIf any argument is NULL, the function returns NULL.\n\nThe inverse of this function (when called with a single argument) is the EXP()\nfunction.\n\nExamples\n--------\n\nLOG(X):\n\nSELECT LOG(2);\n+-------------------+\n| LOG(2) |\n+-------------------+\n| 0.693147180559945 |\n+-------------------+\n\nSELECT LOG(-2);\n+---------+\n| LOG(-2) |\n+---------+\n| NULL |\n+---------+\n\nLOG(B,X)\n\nSELECT LOG(2,16);\n+-----------+\n| LOG(2,16) |\n+-----------+\n| 4 |\n+-----------+\n\nSELECT LOG(3,27);\n+-----------+\n| LOG(3,27) |\n+-----------+\n| 3 |\n+-----------+\n\nSELECT LOG(3,1);\n+----------+\n| LOG(3,1) |\n+----------+\n ... +[LOG10] +declaration=X +category=Numeric Functions +description=Returns the base-10 logarithm of X.\n\nExamples\n--------\n\nSELECT LOG10(2);\n+-------------------+\n| LOG10(2) |\n+-------------------+\n| 0.301029995663981 |\n+-------------------+\n\nSELECT LOG10(100);\n+------------+\n| LOG10(100) |\n+------------+\n| 2 |\n+------------+\n\nSELECT LOG10(-100);\n+-------------+\n| LOG10(-100) |\n+-------------+\n| NULL |\n+-------------+\n\nURL: https://mariadb.com/kb/en/log10/ +[LOG2] +declaration=X +category=Numeric Functions +description=Returns the base-2 logarithm of X.\n\nExamples\n--------\n\nSELECT LOG2(4398046511104);\n+---------------------+\n| LOG2(4398046511104) |\n+---------------------+\n| 42 |\n+---------------------+\n\nSELECT LOG2(65536);\n+-------------+\n| LOG2(65536) |\n+-------------+\n| 16 |\n+-------------+\n\nSELECT LOG2(-100);\n+------------+\n| LOG2(-100) |\n+------------+\n| NULL |\n+------------+\n\nURL: https://mariadb.com/kb/en/log2/ +[LOWER] +declaration=str +category=String Functions +description=Returns the string str with all characters changed to lowercase according to\nthe current character set mapping. The default is latin1 (cp1252 West\nEuropean).\n\nLCASE is a synonym for LOWER\n\nExamples\n--------\n\nSELECT LOWER('QUADRATICALLY');\n+------------------------+\n| LOWER('QUADRATICALLY') |\n+------------------------+\n| quadratically |\n+------------------------+\n\nLOWER() (and UPPER()) are ineffective when applied to binary strings (BINARY,\nVARBINARY, BLOB). To perform lettercase conversion, CONVERT the string to a\nnon-binary string:\n\nSET @str = BINARY 'North Carolina';\n\nSELECT LOWER(@str), LOWER(CONVERT(@str USING latin1));\n+----------------+-----------------------------------+\n| LOWER(@str) | LOWER(CONVERT(@str USING latin1)) |\n+----------------+-----------------------------------+\n| North Carolina | north carolina |\n+----------------+-----------------------------------+\n\nURL: https://mariadb.com/kb/en/lower/ +[LPAD] +declaration=str, len [,padstr] +category=String Functions +description=Returns the string str, left-padded with the string padstr to a length of len\ncharacters. If str is longer than len, the return value is shortened to len\ncharacters. If padstr is omitted, the LPAD function pads spaces.\n\nPrior to MariaDB 10.3.1, the padstr parameter was mandatory.\n\nReturns NULL if given a NULL argument. If the result is empty (zero length),\nreturns either an empty string or, from MariaDB 10.3.6 with SQL_MODE=Oracle,\nNULL.\n\nThe Oracle mode version of the function can be accessed outside of Oracle mode\nby using LPAD_ORACLE as the function name.\n\nExamples\n--------\n\nSELECT LPAD('hello',10,'.');\n+----------------------+\n| LPAD('hello',10,'.') |\n+----------------------+\n| .....hello |\n+----------------------+\n\nSELECT LPAD('hello',2,'.');\n+---------------------+\n| LPAD('hello',2,'.') |\n+---------------------+\n| he |\n+---------------------+\n\nFrom MariaDB 10.3.1, with the pad string defaulting to space.\n\nSELECT LPAD('hello',10);\n+------------------+\n| LPAD('hello',10) |\n+------------------+\n| hello |\n+------------------+\n\nOracle mode version from MariaDB 10.3.6:\n\nSELECT LPAD('',0),LPAD_ORACLE('',0);\n+------------+-------------------+\n| LPAD('',0) | LPAD_ORACLE('',0) |\n+------------+-------------------+\n| | NULL |\n+------------+-------------------+\n\nURL: https://mariadb.com/kb/en/lpad/ +[LTRIM] +declaration=str +category=String Functions +description=Returns the string str with leading space characters removed.\n\nReturns NULL if given a NULL argument. If the result is empty, returns either\nan empty string, or, from MariaDB 10.3.6 with SQL_MODE=Oracle, NULL.\n\nThe Oracle mode version of the function can be accessed outside of Oracle mode\nby using LTRIM_ORACLE as the function name.\n\nExamples\n--------\n\nSELECT QUOTE(LTRIM(' MariaDB '));\n+-------------------------------+\n| QUOTE(LTRIM(' MariaDB ')) |\n+-------------------------------+\n| 'MariaDB ' |\n+-------------------------------+\n\nOracle mode version from MariaDB 10.3.6:\n\nSELECT LTRIM(''),LTRIM_ORACLE('');\n+-----------+------------------+\n| LTRIM('') | LTRIM_ORACLE('') |\n+-----------+------------------+\n| | NULL |\n+-----------+------------------+\n\nURL: https://mariadb.com/kb/en/ltrim/ +[MAKEDATE] +declaration=year,dayofyear +category=Date and Time Functions +description=Returns a date, given year and day-of-year values. dayofyear must be greater\nthan 0 or the result is NULL.\n\nExamples\n--------\n\nSELECT MAKEDATE(2011,31), MAKEDATE(2011,32);\n+-------------------+-------------------+\n| MAKEDATE(2011,31) | MAKEDATE(2011,32) |\n+-------------------+-------------------+\n| 2011-01-31 | 2011-02-01 |\n+-------------------+-------------------+\n\nSELECT MAKEDATE(2011,365), MAKEDATE(2014,365);\n+--------------------+--------------------+\n| MAKEDATE(2011,365) | MAKEDATE(2014,365) |\n+--------------------+--------------------+\n| 2011-12-31 | 2014-12-31 |\n+--------------------+--------------------+\n\nSELECT MAKEDATE(2011,0);\n+------------------+\n| MAKEDATE(2011,0) |\n+------------------+\n| NULL |\n+------------------+\n\nURL: https://mariadb.com/kb/en/makedate/ +[MAKETIME] +declaration=hour,minute,second +category=Date and Time Functions +description=Returns a time value calculated from the hour, minute, and second arguments.\n\nIf minute or second are out of the range 0 to 60, NULL is returned. The hour\ncan be in the range -838 to 838, outside of which the value is truncated with\na warning.\n\nExamples\n--------\n\nSELECT MAKETIME(13,57,33);\n+--------------------+\n| MAKETIME(13,57,33) |\n+--------------------+\n| 13:57:33 |\n+--------------------+\n\nSELECT MAKETIME(-13,57,33);\n+---------------------+\n| MAKETIME(-13,57,33) |\n+---------------------+\n| -13:57:33 |\n+---------------------+\n\nSELECT MAKETIME(13,67,33);\n+--------------------+\n| MAKETIME(13,67,33) |\n+--------------------+\n| NULL |\n+--------------------+\n\nSELECT MAKETIME(-1000,57,33);\n+-----------------------+\n| MAKETIME(-1000,57,33) |\n+-----------------------+\n| -838:59:59 |\n+-----------------------+\n1 row in set, 1 warning (0.00 sec)\n\nSHOW WARNINGS;\n+---------+------+-----------------------------------------------+\n| Level | Code | Message |\n+---------+------+-----------------------------------------------+\n| Warning | 1292 | Truncated incorrect time value: '-1000:57:33' |\n+---------+------+-----------------------------------------------+\n\nURL: https://mariadb.com/kb/en/maketime/ +[MAKE_SET] +declaration=bits,str1,str2,... +category=String Functions +description=Returns a set value (a string containing substrings separated by ","\ncharacters) consisting of the strings that have the corresponding bit in bits\nset. str1 corresponds to bit 0, str2 to bit 1, and so on. NULL values in str1,\nstr2, ... are not appended to the result.\n\nExamples\n--------\n\nSELECT MAKE_SET(1,'a','b','c');\n+-------------------------+\n| MAKE_SET(1,'a','b','c') |\n+-------------------------+\n| a |\n+-------------------------+\n\nSELECT MAKE_SET(1 | 4,'hello','nice','world');\n+----------------------------------------+\n| MAKE_SET(1 | 4,'hello','nice','world') |\n+----------------------------------------+\n| hello,world |\n+----------------------------------------+\n\nSELECT MAKE_SET(1 | 4,'hello','nice',NULL,'world');\n+---------------------------------------------+\n| MAKE_SET(1 | 4,'hello','nice',NULL,'world') |\n+---------------------------------------------+\n| hello |\n+---------------------------------------------+\n\nSELECT QUOTE(MAKE_SET(0,'a','b','c'));\n+--------------------------------+\n| QUOTE(MAKE_SET(0,'a','b','c')) |\n+--------------------------------+\n| '' |\n+--------------------------------+\n\nURL: https://mariadb.com/kb/en/make_set/ +[MASTER_GTID_WAIT] +declaration=gtid-list[, timeout +category=Miscellaneous Functions +description=This function takes a string containing a comma-separated list of global\ntransaction id's (similar to the value of, for example, gtid_binlog_pos). It\nwaits until the value of gtid_slave_pos has the same or higher seq_no within\nall replication domains specified in the gtid-list; in other words, it waits\nuntil the slave has reached the specified GTID position.\n\nAn optional second argument gives a timeout in seconds. If the timeout expires\nbefore the specified GTID position is reached, then the function returns -1.\nPassing NULL or a negative number for the timeout means no timeout, and the\nfunction will wait indefinitely.\n\nIf the wait completes without a timeout, 0 is returned. Passing NULL for the\ngtid-list makes the function return NULL immediately, without waiting.\n\nThe gtid-list may be the empty string, in which case MASTER_GTID_WAIT()\nreturns immediately. If the gtid-list contains fewer domains than\ngtid_slave_pos, then only those domains are waited upon. If gtid-list contains\na domain that is not present in @@gtid_slave_pos, then MASTER_GTID_WAIT() will\nwait until an event containing such domain_id arrives on the slave (or until\ntimed out or killed).\n\nMASTER_GTID_WAIT() can be useful to ensure that a slave has caught up to a\nmaster. Simply take the value of gtid_binlog_pos on the master, and use it in\na MASTER_GTID_WAIT() call on the slave; when the call completes, the slave\nwill have caught up with that master position.\n\nMASTER_GTID_WAIT() can also be used in client applications together with the\nlast_gtid session variable. This is useful in a read-scaleout replication\nsetup, where the application writes to a single master but divides the reads\nout to a number of slaves to distribute the load. In such a setup, there is a\nrisk that an application could first do an update on the master, and then a\nbit later do a read on a slave, and if the slave is not fast enough, the data\nread from the slave might not include the update just made, possibly confusing\nthe application and/or the end-user. One way to avoid this is to request the\nvalue of last_gtid on the master just after the update. Then before doing the\nread on the slave, do a MASTER_GTID_WAIT() on the value obtained from the\nmaster; this will ensure that the read is not performed until the slave has\nreplicated sufficiently far for the update to have become visible.\n\nNote that MASTER_GTID_WAIT() can be used even if the slave is configured not\nto use GTID for connections (CHANGE MASTER TO master_use_gtid=no). This is\nbecause from MariaDB 10, GTIDs are always logged on the master server, and\nalways recorded on the slave servers.\n\nDifferences to MASTER_POS_WAIT()\n--------------------------------\n\n* MASTER_GTID_WAIT() is global; it waits for any master connection to reach\n the specified GTID position. MASTER_POS_WAIT() works only against a\n specific connection. This also means that while MASTER_POS_WAIT() aborts if\n ... +[MASTER_POS_WAIT] +declaration=log_name,log_pos[,timeout,["connection_name"]] +category=Miscellaneous Functions +description=This function is useful in replication for controlling primary/replica\nsynchronization. It blocks until the replica has read and applied all updates\nup to the specified position (log_name,log_pos) in the primary log. The return\nvalue is the number of log events the replica had to wait for to advance to\nthe specified position. The function returns NULL if the replica SQL thread is\nnot started, the replica's primary information is not initialized, the\narguments are incorrect, or an error occurs. It returns -1 if the timeout has\nbeen exceeded. If the replica SQL thread stops while MASTER_POS_WAIT() is\nwaiting, the function returns NULL. If the replica is past the specified\nposition, the function returns immediately.\n\nIf a timeout value is specified, MASTER_POS_WAIT() stops waiting when timeout\nseconds have elapsed. timeout must be greater than 0; a zero or negative\ntimeout means no timeout.\n\nThe connection_name is used when you are using multi-source-replication. If\nyou don't specify it, it's set to the value of the default_master_connection\nsystem variable.\n\nStatements using the MASTER_POS_WAIT() function are not safe for\nstatement-based replication.\n\nURL: https://mariadb.com/kb/en/master_pos_wait/ +[MAX] +declaration=[DISTINCT] expr +category=Functions and Modifiers for Use with GROUP BY +description=Returns the largest, or maximum, value of expr. MAX() can also take a string\nargument in which case it returns the maximum string value. The DISTINCT\nkeyword can be used to find the maximum of the distinct values of expr,\nhowever, this produces the same result as omitting DISTINCT.\n\nNote that SET and ENUM fields are currently compared by their string value\nrather than their relative position in the set, so MAX() may produce a\ndifferent highest result than ORDER BY DESC.\n\nIt is an aggregate function, and so can be used with the GROUP BY clause.\n\nMAX() can be used as a window function.\n\nMAX() returns NULL if there were no matching rows.\n\nExamples\n--------\n\nCREATE TABLE student (name CHAR(10), test CHAR(10), score TINYINT);\n\nINSERT INTO student VALUES \n ('Chun', 'SQL', 75), ('Chun', 'Tuning', 73),\n ('Esben', 'SQL', 43), ('Esben', 'Tuning', 31),\n ('Kaolin', 'SQL', 56), ('Kaolin', 'Tuning', 88),\n ('Tatiana', 'SQL', 87), ('Tatiana', 'Tuning', 83);\n\nSELECT name, MAX(score) FROM student GROUP BY name;\n+---------+------------+\n| name | MAX(score) |\n+---------+------------+\n| Chun | 75 |\n| Esben | 43 |\n| Kaolin | 88 |\n| Tatiana | 87 |\n+---------+------------+\n\nMAX string:\n\nSELECT MAX(name) FROM student;\n+-----------+\n| MAX(name) |\n+-----------+\n| Tatiana |\n+-----------+\n\nBe careful to avoid this common mistake, not grouping correctly and returning\nmismatched data:\n\nSELECT name,test,MAX(SCORE) FROM student;\n+------+------+------------+\n ... +[MBRContains] +declaration=g1,g2 +category=MBR +description=Returns 1 or 0 to indicate whether the Minimum Bounding Rectangle of g1\ncontains the Minimum Bounding Rectangle of g2. This tests the opposite\nrelationship as MBRWithin().\n\nExamples\n--------\n\nSET @g1 = GeomFromText('Polygon((0 0,0 3,3 3,3 0,0 0))');\n\nSET @g2 = GeomFromText('Point(1 1)');\n\nSELECT MBRContains(@g1,@g2), MBRContains(@g2,@g1);\n+----------------------+----------------------+\n| MBRContains(@g1,@g2) | MBRContains(@g2,@g1) |\n+----------------------+----------------------+\n| 1 | 0 |\n+----------------------+----------------------+\n\nURL: https://mariadb.com/kb/en/mbrcontains/ +[MBRDisjoint] +declaration=g1,g2 +category=MBR +description=Returns 1 or 0 to indicate whether the Minimum Bounding Rectangles of the two\ngeometries g1 and g2 are disjoint. Two geometries are disjoint if they do not\nintersect, that is touch or overlap.\n\nExamples\n--------\n\nSET @g1 = GeomFromText('Polygon((0 0,0 3,3 3,3 0,0 0))');\nSET @g2 = GeomFromText('Polygon((4 4,4 7,7 7,7 4,4 4))');\nSELECTmbrdisjoint(@g1,@g2);\n+----------------------+\n| mbrdisjoint(@g1,@g2) |\n+----------------------+\n| 1 |\n+----------------------+\n\nSET @g1 = GeomFromText('Polygon((0 0,0 3,3 3,3 0,0 0))');\nSET @g2 = GeomFromText('Polygon((3 3,3 6,6 6,6 3,3 3))');\nSELECT mbrdisjoint(@g1,@g2);\n+----------------------+\n| mbrdisjoint(@g1,@g2) |\n+----------------------+\n| 0 |\n+----------------------+\n\nURL: https://mariadb.com/kb/en/mbrdisjoint/ +[MBREqual] +declaration=g1,g2 +category=MBR +description=Returns 1 or 0 to indicate whether the Minimum Bounding Rectangles of the two\ngeometries g1 and g2 are the same.\n\nExamples\n--------\n\nSET @g1=GEOMFROMTEXT('LINESTRING(0 0, 1 2)');\nSET @g2=GEOMFROMTEXT('POLYGON((0 0, 0 2, 1 2, 1 0, 0 0))');\nSELECT MbrEqual(@g1,@g2);\n+-------------------+\n| MbrEqual(@g1,@g2) |\n+-------------------+\n| 1 |\n+-------------------+\n\nSET @g1=GEOMFROMTEXT('LINESTRING(0 0, 1 3)');\nSET @g2=GEOMFROMTEXT('POLYGON((0 0, 0 2, 1 4, 1 0, 0 0))');\nSELECT MbrEqual(@g1,@g2);\n+-------------------+\n| MbrEqual(@g1,@g2) |\n+-------------------+\n| 0 |\n+-------------------+\n\nURL: https://mariadb.com/kb/en/mbrequal/ +[MBRIntersects] +declaration=g1,g2 +category=MBR +description=Returns 1 or 0 to indicate whether the Minimum Bounding Rectangles of the two\ngeometries g1 and g2 intersect.\n\nExamples\n--------\n\nSET @g1 = GeomFromText('Polygon((0 0,0 3,3 3,3 0,0 0))');\nSET @g2 = GeomFromText('Polygon((3 3,3 6,6 6,6 3,3 3))');\nSELECT mbrintersects(@g1,@g2);\n+------------------------+\n| mbrintersects(@g1,@g2) |\n+------------------------+\n| 1 |\n+------------------------+\n\nSET @g1 = GeomFromText('Polygon((0 0,0 3,3 3,3 0,0 0))');\nSET @g2 = GeomFromText('Polygon((4 4,4 7,7 7,7 4,4 4))');\nSELECT mbrintersects(@g1,@g2);\n+------------------------+\n| mbrintersects(@g1,@g2) |\n+------------------------+\n| 0 |\n+------------------------+\n\nURL: https://mariadb.com/kb/en/mbrintersects/ +[MBROverlaps] +declaration=g1,g2 +category=MBR +description=Returns 1 or 0 to indicate whether the Minimum Bounding Rectangles of the two\ngeometries g1 and g2 overlap. The term spatially overlaps is used if two\ngeometries intersect and their intersection results in a geometry of the same\ndimension but not equal to either of the given geometries.\n\nExamples\n--------\n\nSET @g1 = GeomFromText('Polygon((0 0,0 3,3 3,3 0,0 0))');\nSET @g2 = GeomFromText('Polygon((4 4,4 7,7 7,7 4,4 4))');\nSELECT mbroverlaps(@g1,@g2);\n+----------------------+\n| mbroverlaps(@g1,@g2) |\n+----------------------+\n| 0 |\n+----------------------+\n\nSET @g1 = GeomFromText('Polygon((0 0,0 3,3 3,3 0,0 0))');\nSET @g2 = GeomFromText('Polygon((3 3,3 6,6 6,6 3,3 3))');\nSELECT mbroverlaps(@g1,@g2);\n+----------------------+\n| mbroverlaps(@g1,@g2) |\n+----------------------+\n| 0 |\n+----------------------+\n\nSET @g1 = GeomFromText('Polygon((0 0,0 4,4 4,4 0,0 0))');\nSET @g2 = GeomFromText('Polygon((3 3,3 6,6 6,6 3,3 3))');\nSELECT mbroverlaps(@g1,@g2);\n+----------------------+\n| mbroverlaps(@g1,@g2) |\n+----------------------+\n| 1 |\n+----------------------+\n\nURL: https://mariadb.com/kb/en/mbroverlaps/ +[MBRTouches] +declaration=g1,g2 +category=MBR +description=Returns 1 or 0 to indicate whether the Minimum Bounding Rectangles of the two\ngeometries g1 and g2 touch. Two geometries spatially touch if the interiors of\nthe geometries do not intersect, but the boundary of one of the geometries\nintersects either the boundary or the interior of the other.\n\nExamples\n--------\n\nSET @g1 = GeomFromText('Polygon((0 0,0 3,3 3,3 0,0 0))');\nSET @g2 = GeomFromText('Polygon((4 4,4 7,7 7,7 4,4 4))');\nSELECT mbrtouches(@g1,@g2);\n+---------------------+\n| mbrtouches(@g1,@g2) |\n+---------------------+\n| 0 |\n+---------------------+\n\nSET @g1 = GeomFromText('Polygon((0 0,0 3,3 3,3 0,0 0))');\nSET @g2 = GeomFromText('Polygon((3 3,3 6,6 6,6 3,3 3))');\nSELECT mbrtouches(@g1,@g2);\n+---------------------+\n| mbrtouches(@g1,@g2) |\n+---------------------+\n| 1 |\n+---------------------+\n\nSET @g1 = GeomFromText('Polygon((0 0,0 4,4 4,4 0,0 0))');\nSET @g2 = GeomFromText('Polygon((3 3,3 6,6 6,6 3,3 3))');\nSELECT mbrtouches(@g1,@g2);\n+---------------------+\n| mbrtouches(@g1,@g2) |\n+---------------------+\n| 0 |\n+---------------------+\n\nURL: https://mariadb.com/kb/en/mbrtouches/ +[MBRWithin] +declaration=g1,g2 +category=MBR +description=Returns 1 or 0 to indicate whether the Minimum Bounding Rectangle of g1 is\nwithin the Minimum Bounding Rectangle of g2. This tests the opposite\nrelationship as MBRContains().\n\nExamples\n--------\n\nSET @g1 = GeomFromText('Polygon((0 0,0 3,3 3,3 0,0 0))');\nSET @g2 = GeomFromText('Polygon((0 0,0 5,5 5,5 0,0 0))');\nSELECT MBRWithin(@g1,@g2), MBRWithin(@g2,@g1);\n+--------------------+--------------------+\n| MBRWithin(@g1,@g2) | MBRWithin(@g2,@g1) |\n+--------------------+--------------------+\n| 1 | 0 |\n+--------------------+--------------------+\n\nURL: https://mariadb.com/kb/en/mbrwithin/ +[MD5] +declaration=str +category=Encryption Functions +description=Calculates an MD5 128-bit checksum for the string.\n\nThe return value is a 32-hex digit string, and as of MariaDB 5.5, is a\nnonbinary string in the connection character set and collation, determined by\nthe values of the character_set_connection and collation_connection system\nvariables. Before 5.5, the return value was a binary string.\n\nNULL is returned if the argument was NULL.\n\nExamples\n--------\n\nSELECT MD5('testing');\n+----------------------------------+\n| MD5('testing') |\n+----------------------------------+\n| ae2b1fca515949e5d54fb22b8ed95575 |\n+----------------------------------+\n\nURL: https://mariadb.com/kb/en/md5/ +[MEDIUMINT] +declaration=M +category=Data Types +description=A medium-sized integer. The signed range is -8388608 to 8388607. The unsigned\nrange is 0 to 16777215.\n\nZEROFILL pads the integer with zeroes and assumes UNSIGNED (even if UNSIGNED\nis not specified).\n\nINT3 is a synonym for MEDIUMINT.\n\nFor details on the attributes, see Numeric Data Type Overview.\n\nExamples\n--------\n\nCREATE TABLE mediumints (a MEDIUMINT,b MEDIUMINT UNSIGNED,c MEDIUMINT\nZEROFILL);\n\nDESCRIBE mediumints;\n+-------+--------------------------------+------+-----+---------+-------+\n| Field | Type | Null | Key | Default | Extra |\n+-------+--------------------------------+------+-----+---------+-------+\n| a | mediumint(9) | YES | | NULL | |\n| b | mediumint(8) unsigned | YES | | NULL | |\n| c | mediumint(8) unsigned zerofill | YES | | NULL | |\n+-------+--------------------------------+------+-----+---------+-------+\n\nWith strict_mode set, the default from MariaDB 10.2.4:\n\nINSERT INTO mediumints VALUES (-10,-10,-10);\nERROR 1264 (22003): Out of range value for column 'b' at row 1\n\nINSERT INTO mediumints VALUES (-10,10,-10);\nERROR 1264 (22003): Out of range value for column 'c' at row 1\n\nINSERT INTO mediumints VALUES (-10,10,10);\n\nINSERT INTO mediumints VALUES (8388608,8388608,8388608);\nERROR 1264 (22003): Out of range value for column 'a' at row 1\n\nINSERT INTO mediumints VALUES (8388607,8388608,8388608);\n\nSELECT * FROM mediumints;\n+---------+---------+----------+\n| a | b | c |\n+---------+---------+----------+\n| -10 | 10 | 00000010 |\n| 8388607 | 8388608 | 08388608 |\n+---------+---------+----------+\n\nWith strict_mode unset, the default until MariaDB 10.2.3:\n\n ... +[MICROSECOND] +declaration=expr +category=Date and Time Functions +description=Returns the microseconds from the time or datetime expression expr as a number\nin the range from 0 to 999999.\n\nIf expr is a time with no microseconds, zero is returned, while if expr is a\ndate with no time, zero with a warning is returned.\n\nExamples\n--------\n\nSELECT MICROSECOND('12:00:00.123456');\n+--------------------------------+\n| MICROSECOND('12:00:00.123456') |\n+--------------------------------+\n| 123456 |\n+--------------------------------+\n\nSELECT MICROSECOND('2009-12-31 23:59:59.000010');\n+-------------------------------------------+\n| MICROSECOND('2009-12-31 23:59:59.000010') |\n+-------------------------------------------+\n| 10 |\n+-------------------------------------------+\n\nSELECT MICROSECOND('2013-08-07 12:13:14');\n+------------------------------------+\n| MICROSECOND('2013-08-07 12:13:14') |\n+------------------------------------+\n| 0 |\n+------------------------------------+\n\nSELECT MICROSECOND('2013-08-07');\n+---------------------------+\n| MICROSECOND('2013-08-07') |\n+---------------------------+\n| 0 |\n+---------------------------+\n1 row in set, 1 warning (0.00 sec)\n\nSHOW WARNINGS;\n+---------+------+----------------------------------------------+\n| Level | Code | Message |\n+---------+------+----------------------------------------------+\n| Warning | 1292 | Truncated incorrect time value: '2013-08-07' |\n+---------+------+----------------------------------------------+\n\nURL: https://mariadb.com/kb/en/microsecond/ +[MID] +declaration=str,pos,len +category=String Functions +description=MID(str,pos,len) is a synonym for SUBSTRING(str,pos,len).\n\nExamples\n--------\n\nSELECT MID('abcd',4,1);\n+-----------------+\n| MID('abcd',4,1) |\n+-----------------+\n| d |\n+-----------------+\n\nSELECT MID('abcd',2,2);\n+-----------------+\n| MID('abcd',2,2) |\n+-----------------+\n| bc |\n+-----------------+\n\nA negative starting position:\n\nSELECT MID('abcd',-2,4);\n+------------------+\n| MID('abcd',-2,4) |\n+------------------+\n| cd |\n+------------------+\n\nURL: https://mariadb.com/kb/en/mid/ +[MIN] +declaration=[DISTINCT] expr +category=Functions and Modifiers for Use with GROUP BY +description=Returns the minimum value of expr. MIN() may take a string argument, in which\ncase it returns the minimum string value. The DISTINCT keyword can be used to\nfind the minimum of the distinct values of expr, however, this produces the\nsame result as omitting DISTINCT.\n\nNote that SET and ENUM fields are currently compared by their string value\nrather than their relative position in the set, so MIN() may produce a\ndifferent lowest result than ORDER BY ASC.\n\nIt is an aggregate function, and so can be used with the GROUP BY clause.\n\nMIN() can be used as a window function.\n\nMIN() returns NULL if there were no matching rows.\n\nExamples\n--------\n\nCREATE TABLE student (name CHAR(10), test CHAR(10), score TINYINT);\n\nINSERT INTO student VALUES \n ('Chun', 'SQL', 75), ('Chun', 'Tuning', 73),\n ('Esben', 'SQL', 43), ('Esben', 'Tuning', 31),\n ('Kaolin', 'SQL', 56), ('Kaolin', 'Tuning', 88),\n ('Tatiana', 'SQL', 87), ('Tatiana', 'Tuning', 83);\n\nSELECT name, MIN(score) FROM student GROUP BY name;\n+---------+------------+\n| name | MIN(score) |\n+---------+------------+\n| Chun | 73 |\n| Esben | 31 |\n| Kaolin | 56 |\n| Tatiana | 83 |\n+---------+------------+\n\nMIN() with a string:\n\nSELECT MIN(name) FROM student;\n+-----------+\n| MIN(name) |\n+-----------+\n| Chun |\n+-----------+\n\nBe careful to avoid this common mistake, not grouping correctly and returning\nmismatched data:\n\nSELECT name,test,MIN(score) FROM student;\n+------+------+------------+\n ... +[MINUTE] +declaration=time +category=Date and Time Functions +description=Returns the minute for time, in the range 0 to 59.\n\nExamples\n--------\n\nSELECT MINUTE('2013-08-03 11:04:03');\n+-------------------------------+\n| MINUTE('2013-08-03 11:04:03') |\n+-------------------------------+\n| 4 |\n+-------------------------------+\n\nSELECT MINUTE ('23:12:50');\n+---------------------+\n| MINUTE ('23:12:50') |\n+---------------------+\n| 12 |\n+---------------------+\n\nURL: https://mariadb.com/kb/en/minute/ +[MLineFromText] +declaration=wkt[,srid] +category=WKT +description=Constructs a MULTILINESTRING value using its WKT representation and SRID.\n\nMLineFromText() and MultiLineStringFromText() are synonyms.\n\nExamples\n--------\n\nCREATE TABLE gis_multi_line (g MULTILINESTRING);\nSHOW FIELDS FROM gis_multi_line;\nINSERT INTO gis_multi_line VALUES\n (MultiLineStringFromText('MULTILINESTRING((10 48,10 21,10 0),(16 0,16\n23,16 48))')),\n (MLineFromText('MULTILINESTRING((10 48,10 21,10 0))')),\n (MLineFromWKB(AsWKB(MultiLineString(\n LineString(Point(1, 2), Point(3, 5)),\n LineString(Point(2, 5), Point(5, 8), Point(21, 7))))));\n\nURL: https://mariadb.com/kb/en/mlinefromtext/ +[MLineFromWKB] +declaration=wkb[,srid] +category=WKB +description=Constructs a MULTILINESTRING value using its WKB representation and SRID.\n\nMLineFromWKB() and MultiLineStringFromWKB() are synonyms.\n\nExamples\n--------\n\nSET @g = ST_AsBinary(MLineFromText('MULTILINESTRING((10 48,10 21,10 0),(16\n0,16 23,16 48))'));\n\nSELECT ST_AsText(MLineFromWKB(@g));\n+--------------------------------------------------------+\n| ST_AsText(MLineFromWKB(@g)) |\n+--------------------------------------------------------+\n| MULTILINESTRING((10 48,10 21,10 0),(16 0,16 23,16 48)) |\n+--------------------------------------------------------+\n\nURL: https://mariadb.com/kb/en/mlinefromwkb/ +[MOD] +declaration=N,M +category=Numeric Functions +description=Modulo operation. Returns the remainder of N divided by M. See also Modulo\nOperator.\n\nIf the ERROR_ON_DIVISION_BY_ZERO SQL_MODE is used, any number modulus zero\nproduces an error. Otherwise, it returns NULL.\n\nThe integer part of a division can be obtained using DIV.\n\nExamples\n--------\n\nSELECT 1042 % 50;\n+-----------+\n| 1042 % 50 |\n+-----------+\n| 42 |\n+-----------+\n\nSELECT MOD(234, 10);\n+--------------+\n| MOD(234, 10) |\n+--------------+\n| 4 |\n+--------------+\n\nSELECT 253 % 7;\n+---------+\n| 253 % 7 |\n+---------+\n| 1 |\n+---------+\n\nSELECT MOD(29,9);\n+-----------+\n| MOD(29,9) |\n+-----------+\n| 2 |\n+-----------+\n\nSELECT 29 MOD 9;\n+----------+\n| 29 MOD 9 |\n+----------+\n| 2 |\n+----------+\n\nURL: https://mariadb.com/kb/en/mod/ +[MONTH] +declaration=date +category=Date and Time Functions +description=Returns the month for date in the range 1 to 12 for January to December, or 0\nfor dates such as '0000-00-00' or '2008-00-00' that have a zero month part.\n\nExamples\n--------\n\nSELECT MONTH('2019-01-03');\n+---------------------+\n| MONTH('2019-01-03') |\n+---------------------+\n| 1 |\n+---------------------+\n\nSELECT MONTH('2019-00-03');\n+---------------------+\n| MONTH('2019-00-03') |\n+---------------------+\n| 0 |\n+---------------------+\n\nURL: https://mariadb.com/kb/en/month/ +[MONTHNAME] +declaration=date +category=Date and Time Functions +description=Returns the full name of the month for date. The language used for the name is\ncontrolled by the value of the lc_time_names system variable. See server\nlocale for more on the supported locales.\n\nExamples\n--------\n\nSELECT MONTHNAME('2019-02-03');\n+-------------------------+\n| MONTHNAME('2019-02-03') |\n+-------------------------+\n| February |\n+-------------------------+\n\nChanging the locale:\n\nSET lc_time_names = 'fr_CA';\n\nSELECT MONTHNAME('2019-05-21');\n+-------------------------+\n| MONTHNAME('2019-05-21') |\n+-------------------------+\n| mai |\n+-------------------------+\n\nURL: https://mariadb.com/kb/en/monthname/ +[MPointFromText] +declaration=wkt[,srid] +category=WKT +description=Constructs a MULTIPOINT value using its WKT representation and SRID.\n\nMPointFromText() and MultiPointFromText() are synonyms.\n\nExamples\n--------\n\nCREATE TABLE gis_multi_point (g MULTIPOINT);\nSHOW FIELDS FROM gis_multi_point;\nINSERT INTO gis_multi_point VALUES\n (MultiPointFromText('MULTIPOINT(0 0,10 10,10 20,20 20)')),\n (MPointFromText('MULTIPOINT(1 1,11 11,11 21,21 21)')),\n (MPointFromWKB(AsWKB(MultiPoint(Point(3, 6), Point(4, 10)))));\n\nURL: https://mariadb.com/kb/en/mpointfromtext/ +[MPointFromWKB] +declaration=wkb[,srid] +category=WKB +description=Constructs a MULTIPOINT value using its WKB representation and SRID.\n\nMPointFromWKB() and MultiPointFromWKB() are synonyms.\n\nExamples\n--------\n\nSET @g = ST_AsBinary(MPointFromText('MultiPoint( 1 1, 2 2, 5 3, 7 2, 9 3, 8 4,\n6 6, 6 9, 4 9, 1 5 )'));\n\nSELECT ST_AsText(MPointFromWKB(@g));\n+-----------------------------------------------------+\n| ST_AsText(MPointFromWKB(@g)) |\n+-----------------------------------------------------+\n| MULTIPOINT(1 1,2 2,5 3,7 2,9 3,8 4,6 6,6 9,4 9,1 5) |\n+-----------------------------------------------------+\n\nURL: https://mariadb.com/kb/en/mpointfromwkb/ +[MPolyFromText] +declaration=wkt[,srid] +category=WKT +description=Constructs a MULTIPOLYGON value using its WKT representation and SRID.\n\nMPolyFromText() and MultiPolygonFromText() are synonyms.\n\nExamples\n--------\n\nCREATE TABLE gis_multi_polygon (g MULTIPOLYGON);\nSHOW FIELDS FROM gis_multi_polygon;\nINSERT INTO gis_multi_polygon VALUES\n (MultiPolygonFromText('MULTIPOLYGON(\n ((28 26,28 0,84 0,84 42,28 26),(52 18,66 23,73 9,48 6,52 18)),\n ((59 18,67 18,67 13,59 13,59 18)))')),\n (MPolyFromText('MULTIPOLYGON(\n ((28 26,28 0,84 0,84 42,28 26),(52 18,66 23,73 9,48 6,52 18)),\n ((59 18,67 18,67 13,59 13,59 18)))')),\n (MPolyFromWKB(AsWKB(MultiPolygon(Polygon(\n LineString(Point(0, 3), Point(3, 3), Point(3, 0), Point(0, 3)))))));\n\nURL: https://mariadb.com/kb/en/mpolyfromtext/ +[MPolyFromWKB] +declaration=wkb[,srid] +category=WKB +description=Constructs a MULTIPOLYGON value using its WKB representation and SRID.\n\nMPolyFromWKB() and MultiPolygonFromWKB() are synonyms.\n\nExamples\n--------\n\nSET @g = ST_AsBinary(MPointFromText('MULTIPOLYGON(((28 26,28 0,84 0,84 42,28\n26),(52 18,66 23,73 9,48 6,52 18)),((59 18,67 18,67 13,59 13,59 18)))'));\n\nSELECT ST_AsText(MPolyFromWKB(@g))\G\n*************************** 1. row ***************************\nST_AsText(MPolyFromWKB(@g)): MULTIPOLYGON(((28 26,28 0,84 0,84 42,28 26),(52\n18,66 23,73 9,48 6,52 18)),((59 18,67 18,67 13,59 13,59 18)))\n\nURL: https://mariadb.com/kb/en/mpolyfromwkb/ +[MULTILINESTRING] +declaration=ls1,ls2,... +category=Geometry Constructors +description=Constructs a WKB MultiLineString value using WKB LineString arguments. If any\nargument is not a WKB LineString, the return value is NULL.\n\nExample\n-------\n\nCREATE TABLE gis_multi_line (g MULTILINESTRING);\nINSERT INTO gis_multi_line VALUES\n (MultiLineStringFromText('MULTILINESTRING((10 48,10 21,10 0),(16 0,16 23,16\n48))')),\n (MLineFromText('MULTILINESTRING((10 48,10 21,10 0))')),\n (MLineFromWKB(AsWKB(MultiLineString(LineString(Point(1, 2), \n Point(3, 5)), LineString(Point(2, 5),Point(5, 8),Point(21, 7))))));\n\nURL: https://mariadb.com/kb/en/multilinestring/ +[MULTIPOINT] +declaration=pt1,pt2,... +category=Geometry Constructors +description=Constructs a WKB MultiPoint value using WKB Point arguments. If any argument\nis not a WKB Point, the return value is NULL.\n\nExamples\n--------\n\nSET @g = ST_GEOMFROMTEXT('MultiPoint( 1 1, 2 2, 5 3, 7 2, 9 3, 8 4, 6 6, 6 9,\n4 9, 1 5 )');\n\nCREATE TABLE gis_multi_point (g MULTIPOINT);\nINSERT INTO gis_multi_point VALUES\n (MultiPointFromText('MULTIPOINT(0 0,10 10,10 20,20 20)')),\n (MPointFromText('MULTIPOINT(1 1,11 11,11 21,21 21)')),\n (MPointFromWKB(AsWKB(MultiPoint(Point(3, 6), Point(4, 10)))));\n\nURL: https://mariadb.com/kb/en/multipoint/ +[MULTIPOLYGON] +declaration=poly1,poly2,... +category=Geometry Constructors +description=Constructs a WKB MultiPolygon value from a set of WKB Polygon arguments. If\nany argument is not a WKB Polygon, the return value is NULL.\n\nExample\n-------\n\nCREATE TABLE gis_multi_polygon (g MULTIPOLYGON);\nINSERT INTO gis_multi_polygon VALUES\n (MultiPolygonFromText('MULTIPOLYGON(((28 26,28 0,84 0,84 42,28 26),(52\n18,66 23,73 9,48 6,52 18)),\n ((59 18,67 18,67 13,59 13,59 18)))')),\n (MPolyFromText('MULTIPOLYGON(((28 26,28 0,84 0,84 42,28 26),(52 18,66\n23,73 9,48 6,52 18)),\n ((59 18,67 18,67 13,59 13,59 18)))')),\n (MPolyFromWKB(AsWKB(MultiPolygon(Polygon(LineString(\n Point(0, 3), Point(3, 3), Point(3, 0), Point(0, 3)))))));\n\nURL: https://mariadb.com/kb/en/multipolygon/ +[NAME_CONST] +declaration=name,value +category=Miscellaneous Functions +description=Returns the given value. When used to produce a result set column,\nNAME_CONST() causes the column to have the given name. The arguments should be\nconstants.\n\nThis function is used internally when replicating stored procedures. It makes\nlittle sense to use it explicitly in SQL statements, and it was not supposed\nto be used like that.\n\nSELECT NAME_CONST('myname', 14);\n+--------+\n| myname |\n+--------+\n| 14 |\n+--------+\n\nURL: https://mariadb.com/kb/en/name_const/ +[NATURAL_SORT_KEY] +declaration=str +category=String Functions +description=The NATURAL_SORT_KEY function is used for sorting that is closer to natural\nsorting. Strings are sorted in alphabetical order, while numbers are treated\nin a way such that, for example, 10 is greater than 2, whereas in other forms\nof sorting, 2 would be greater than 10, just like z is greater than ya.\n\nThere are multiple natural sort implementations, differing in the way they\nhandle leading zeroes, fractions, i18n, negatives, decimals and so on.\n\nMariaDB's implementation ignores leading zeroes when performing the sort.\n\nYou can use also use NATURAL_SORT_KEY with generated columns. The value is not\nstored permanently in the table. When using a generated column, the virtual\ncolumn must be longer than the base column to cater for embedded numbers in\nthe string and MDEV-24582.\n\nExamples\n--------\n\nStrings and Numbers\n-------------------\n\nCREATE TABLE t1 (c TEXT);\n\nINSERT INTO t1 VALUES ('b1'),('a2'),('a11'),('a1');\n\nSELECT c FROM t1;\n+------+\n| c |\n+------+\n| b1 |\n| a2 |\n| a11 |\n| a1 |\n+------+\n\nSELECT c FROM t1 ORDER BY c;\n+------+\n| c |\n+------+\n| a1 |\n| a11 |\n| a2 |\n| b1 |\n+------+\n\nUnsorted, regular sort and natural sort:\n\nTRUNCATE t1;\n\nINSERT INTO t1 VALUES \n ... +[NOW] +declaration=[precision] +category=Date and Time Functions +description=Returns the current date and time as a value in 'YYYY-MM-DD HH:MM:SS' or\nYYYYMMDDHHMMSS.uuuuuu format, depending on whether the function is used in a\nstring or numeric context. The value is expressed in the current time zone.\n\nThe optional precision determines the microsecond precision. See Microseconds\nin MariaDB.\n\nNOW() (or its synonyms) can be used as the default value for TIMESTAMP columns\nas well as, since MariaDB 10.0.1, DATETIME columns. Before MariaDB 10.0.1, it\nwas only possible for a single TIMESTAMP column per table to contain the\nCURRENT_TIMESTAMP as its default.\n\nWhen displayed in the INFORMATION_SCHEMA.COLUMNS table, a default CURRENT\nTIMESTAMP is displayed as CURRENT_TIMESTAMP up until MariaDB 10.2.2, and as\ncurrent_timestamp() from MariaDB 10.2.3, due to to MariaDB 10.2 accepting\nexpressions in the DEFAULT clause.\n\nChanging the timestamp system variable with a SET timestamp statement affects\nthe value returned by NOW(), but not by SYSDATE().\n\nExamples\n--------\n\nSELECT NOW();\n+---------------------+\n| NOW() |\n+---------------------+\n| 2010-03-27 13:13:25 |\n+---------------------+\n\nSELECT NOW() + 0;\n+-----------------------+\n| NOW() + 0 |\n+-----------------------+\n| 20100327131329.000000 |\n+-----------------------+\n\nWith precision:\n\nSELECT CURRENT_TIMESTAMP(2);\n+------------------------+\n| CURRENT_TIMESTAMP(2) |\n+------------------------+\n| 2018-07-10 09:47:26.24 |\n+------------------------+\n\nUsed as a default TIMESTAMP:\n\nCREATE TABLE t (createdTS TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP);\n\n ... +[NTH_VALUE] +declaration=expr[, num_row] +category=Window Functions +description=The NTH_VALUE function returns the value evaluated at row number num_row of\nthe window frame, starting from 1, or NULL if the row does not exist.\n\nURL: https://mariadb.com/kb/en/nth_value/ +[NTILE] +declaration=expr +category=Window Functions +description=NTILE() is a window function that returns an integer indicating which group a\ngiven row falls into. The number of groups is specified in the argument\n(expr), starting at one. Ordered rows in the partition are divided into the\nspecified number of groups with as equal a size as possible.\n\nExamples\n--------\n\ncreate table t1 (\n pk int primary key,\n a int,\n b int\n );\n\ninsert into t1 values\n (11 , 0, 10),\n (12 , 0, 10),\n (13 , 1, 10),\n (14 , 1, 10),\n (18 , 2, 10),\n (15 , 2, 20),\n (16 , 2, 20),\n (17 , 2, 20),\n (19 , 4, 20),\n (20 , 4, 20);\n\nselect pk, a, b,\n ntile(1) over (order by pk)\n from t1;\n+----+------+------+-----------------------------+\n| pk | a | b | ntile(1) over (order by pk) |\n+----+------+------+-----------------------------+\n| 11 | 0 | 10 | 1 |\n| 12 | 0 | 10 | 1 |\n| 13 | 1 | 10 | 1 |\n| 14 | 1 | 10 | 1 |\n| 15 | 2 | 20 | 1 |\n| 16 | 2 | 20 | 1 |\n| 17 | 2 | 20 | 1 |\n| 18 | 2 | 10 | 1 |\n| 19 | 4 | 20 | 1 |\n| 20 | 4 | 20 | 1 |\n+----+------+------+-----------------------------+\n\nselect pk, a, b,\n ntile(4) over (order by pk)\n from t1;\n+----+------+------+-----------------------------+\n| pk | a | b | ntile(4) over (order by pk) |\n+----+------+------+-----------------------------+\n ... +[NULLIF] +declaration=expr1,expr2 +category=Control Flow Functions +description=Returns NULL if expr1 = expr2 is true, otherwise returns expr1. This is the\nsame as CASE WHEN expr1 = expr2 THEN NULL ELSE expr1 END.\n\nExamples\n--------\n\nSELECT NULLIF(1,1);\n+-------------+\n| NULLIF(1,1) |\n+-------------+\n| NULL |\n+-------------+\n\nSELECT NULLIF(1,2);\n+-------------+\n| NULLIF(1,2) |\n+-------------+\n| 1 |\n+-------------+\n\nURL: https://mariadb.com/kb/en/nullif/ +[NVL2] +declaration=expr1,expr2,expr3 +category=Control Flow Functions +description=The NVL2 function returns a value based on whether a specified expression is\nNULL or not. If expr1 is not NULL, then NVL2 returns expr2. If expr1 is NULL,\nthen NVL2 returns expr3.\n\nExamples\n--------\n\nSELECT NVL2(NULL,1,2);\n+----------------+\n| NVL2(NULL,1,2) |\n+----------------+\n| 2 |\n+----------------+\n\nSELECT NVL2('x',1,2);\n+---------------+\n| NVL2('x',1,2) |\n+---------------+\n| 1 |\n+---------------+\n\nURL: https://mariadb.com/kb/en/nvl2/ +[OCT] +declaration=N +category=Numeric Functions +description=Returns a string representation of the octal value of N, where N is a longlong\n(BIGINT) number. This is equivalent to CONV(N,10,8). Returns NULL if N is NULL.\n\nExamples\n--------\n\nSELECT OCT(34);\n+---------+\n| OCT(34) |\n+---------+\n| 42 |\n+---------+\n\nSELECT OCT(12);\n+---------+\n| OCT(12) |\n+---------+\n| 14 |\n+---------+\n\nURL: https://mariadb.com/kb/en/oct/ +[OCTET_LENGTH] +declaration=str +category=String Functions +description=OCTET_LENGTH() returns the length of the given string, in octets (bytes). This\nis a synonym for LENGTHB(), and, when Oracle mode from MariaDB 10.3 is not\nset, a synonym for LENGTH().\n\nA multi-byte character counts as multiple bytes. This means that for a string\ncontaining five two-byte characters, OCTET_LENGTH() returns 10, whereas\nCHAR_LENGTH() returns 5.\n\nIf str is not a string value, it is converted into a string. If str is NULL,\nthe function returns NULL.\n\nExamples\n--------\n\nWhen Oracle mode from MariaDB 10.3 is not set:\n\nSELECT CHAR_LENGTH('π'), LENGTH('π'), LENGTHB('π'), OCTET_LENGTH('π');\n+-------------------+--------------+---------------+--------------------+\n| CHAR_LENGTH('π') | LENGTH('π') | LENGTHB('π') | OCTET_LENGTH('π') |\n+-------------------+--------------+---------------+--------------------+\n| 1 | 2 | 2 | 2 |\n+-------------------+--------------+---------------+--------------------+\n\nIn Oracle mode from MariaDB 10.3:\n\nSELECT CHAR_LENGTH('π'), LENGTH('π'), LENGTHB('π'), OCTET_LENGTH('π');\n+-------------------+--------------+---------------+--------------------+\n| CHAR_LENGTH('π') | LENGTH('π') | LENGTHB('π') | OCTET_LENGTH('π') |\n+-------------------+--------------+---------------+--------------------+\n| 1 | 1 | 2 | 2 |\n+-------------------+--------------+---------------+--------------------+\n\nURL: https://mariadb.com/kb/en/octet_length/ +[OLD_PASSWORD] +declaration=str +category=Encryption Functions +description=OLD_PASSWORD() was added to MySQL when the implementation of PASSWORD() was\nchanged to improve security. OLD_PASSWORD() returns the value of the old\n(pre-MySQL 4.1) implementation of PASSWORD() as a string, and is intended to\npermit you to reset passwords for any pre-4.1 clients that need to connect to\na more recent MySQL server version, or any version of MariaDB, without locking\nthem out.\n\nAs of MariaDB 5.5, the return value is a nonbinary string in the connection\ncharacter set and collation, determined by the values of the\ncharacter_set_connection and collation_connection system variables. Before\n5.5, the return value was a binary string.\n\nThe return value is 16 bytes in length, or NULL if the argument was NULL.\n\nURL: https://mariadb.com/kb/en/old_password/ +[ORD] +declaration=str +category=String Functions +description=If the leftmost character of the string str is a multi-byte character, returns\nthe code for that character, calculated from the numeric values of its\nconstituent bytes using this formula:\n\n(1st byte code)\n+ (2nd byte code x 256)\n+ (3rd byte code x 256 x 256) ...\n\nIf the leftmost character is not a multi-byte character, ORD() returns the\nsame value as the ASCII() function.\n\nExamples\n--------\n\nSELECT ORD('2');\n+----------+\n| ORD('2') |\n+----------+\n| 50 |\n+----------+\n\nURL: https://mariadb.com/kb/en/ord/ +[OVERLAPS] +declaration=g1,g2 +category=Geometry Relations +description=Returns 1 or 0 to indicate whether g1 spatially overlaps g2. The term\nspatially overlaps is used if two geometries intersect and their intersection\nresults in a geometry of the same dimension but not equal to either of the\ngiven geometries.\n\nOVERLAPS() is based on the original MySQL implementation and uses object\nbounding rectangles, while ST_OVERLAPS() uses object shapes.\n\nURL: https://mariadb.com/kb/en/overlaps/ +[PASSWORD] +declaration=str +category=Encryption Functions +description=The PASSWORD() function is used for hashing passwords for use in\nauthentication by the MariaDB server. It is not intended for use in other\napplications.\n\nCalculates and returns a hashed password string from the plaintext password\nstr. Returns an empty string (>= MariaDB 10.0.4) if the argument was NULL.\n\nThe return value is a nonbinary string in the connection character set and\ncollation, determined by the values of the character_set_connection and\ncollation_connection system variables.\n\nThis is the function that is used for hashing MariaDB passwords for storage in\nthe Password column of the user table (see privileges), usually used with the\nSET PASSWORD statement. It is not intended for use in other applications.\n\nUntil MariaDB 10.3, the return value is 41-bytes in length, and the first\ncharacter is always '*'. From MariaDB 10.4, the function takes into account\nthe authentication plugin where applicable (A CREATE USER or SET PASSWORD\nstatement). For example, when used in conjunction with a user authenticated by\nthe ed25519 plugin, the statement will create a longer hash:\n\nCREATE USER edtest@localhost IDENTIFIED VIA ed25519 USING PASSWORD('secret');\n\nCREATE USER edtest2@localhost IDENTIFIED BY 'secret';\n\nSELECT CONCAT(user, '@', host, ' => ', JSON_DETAILED(priv)) FROM\nmysql.global_priv\n WHERE user LIKE 'edtest%'\G\n*************************** 1. row ***************************\nCONCAT(user, '@', host, ' => ', JSON_DETAILED(priv)): edtest@localhost => {\n...\n "plugin": "ed25519",\n "authentication_string": "ZIgUREUg5PVgQ6LskhXmO+eZLS0nC8be6HPjYWR4YJY",\n...\n}\n*************************** 2. row ***************************\nCONCAT(user, '@', host, ' => ', JSON_DETAILED(priv)): edtest2@localhost => {\n...\n "plugin": "mysql_native_password",\n "authentication_string": "*14E65567ABDB5135D0CFD9A70B3032C179A49EE7",\n...\n}\n\nThe behavior of this function is affected by the value of the old_passwords\nsystem variable. If this is set to 1 (0 is default), MariaDB reverts to using\nthe mysql_old_password authentication plugin by default for newly created\nusers and passwords.\n\nExamples\n--------\n ... +[PERCENTILE_CONT] +declaration= +category=Window Functions +description=PERCENTILE_CONT() (standing for continuous percentile) is a window function\nwhich returns a value which corresponds to the given fraction in the sort\norder. If required, it will interpolate between adjacent input items.\n\nEssentially, the following process is followed to find the value to return:\n\n* Get the number of rows in the partition, denoted by N\n* RN = p*(N-1), where p denotes the argument to the PERCENTILE_CONT function\n* calculate the FRN(floor row number) and CRN(column row number for the group(\nFRN= floor(RN) and CRN = ceil(RN))\n* look up rows FRN and CRN\n* If (CRN = FRN = RN) then the result is (value of expression from row at RN)\n* Otherwise the result is\n* (CRN - RN) * (value of expression for row at FRN) +\n* (RN - FRN) * (value of expression for row at CRN)\n\nThe MEDIAN function is a specific case of PERCENTILE_CONT, equivalent to\nPERCENTILE_CONT(0.5).\n\nExamples\n--------\n\nCREATE TABLE book_rating (name CHAR(30), star_rating TINYINT);\n\nINSERT INTO book_rating VALUES ('Lord of the Ladybirds', 5);\nINSERT INTO book_rating VALUES ('Lord of the Ladybirds', 3);\nINSERT INTO book_rating VALUES ('Lady of the Flies', 1);\nINSERT INTO book_rating VALUES ('Lady of the Flies', 2);\nINSERT INTO book_rating VALUES ('Lady of the Flies', 5);\n\nSELECT name, PERCENTILE_CONT(0.5) WITHIN GROUP (ORDER BY star_rating) \n OVER (PARTITION BY name) AS pc\n FROM book_rating;\n+-----------------------+--------------+\n| name | pc |\n+-----------------------+--------------+\n| Lord of the Ladybirds | 4.0000000000 |\n| Lord of the Ladybirds | 4.0000000000 |\n| Lady of the Flies | 2.0000000000 |\n| Lady of the Flies | 2.0000000000 |\n| Lady of the Flies | 2.0000000000 |\n+-----------------------+--------------+\n\nSELECT name, PERCENTILE_CONT(1) WITHIN GROUP (ORDER BY star_rating) \n OVER (PARTITION BY name) AS pc\n FROM book_rating;\n+-----------------------+--------------+\n| name | pc |\n+-----------------------+--------------+\n| Lord of the Ladybirds | 5.0000000000 |\n ... +[PERCENTILE_DISC] +declaration= +category=Window Functions +description=PERCENTILE_DISC() (standing for discrete percentile) is a window function\nwhich returns the first value in the set whose ordered position is the same or\nmore than the specified fraction.\n\nEssentially, the following process is followed to find the value to return:\n\n* Get the number of rows in the partition.\n* Walk through the partition, in order, until finding the the first row with\nCUME_DIST() >= function_argument.\n\nExamples\n--------\n\nCREATE TABLE book_rating (name CHAR(30), star_rating TINYINT);\n\nINSERT INTO book_rating VALUES ('Lord of the Ladybirds', 5);\nINSERT INTO book_rating VALUES ('Lord of the Ladybirds', 3);\nINSERT INTO book_rating VALUES ('Lady of the Flies', 1);\nINSERT INTO book_rating VALUES ('Lady of the Flies', 2);\nINSERT INTO book_rating VALUES ('Lady of the Flies', 5);\n\nSELECT name, PERCENTILE_DISC(0.5) WITHIN GROUP (ORDER BY star_rating)\n OVER (PARTITION BY name) AS pc FROM book_rating;\n+-----------------------+------+\n| name | pc |\n+-----------------------+------+\n| Lord of the Ladybirds | 3 |\n| Lord of the Ladybirds | 3 |\n| Lady of the Flies | 2 |\n| Lady of the Flies | 2 |\n| Lady of the Flies | 2 |\n+-----------------------+------+\n5 rows in set (0.000 sec)\n\nSELECT name, PERCENTILE_DISC(0) WITHIN GROUP (ORDER BY star_rating) \n OVER (PARTITION BY name) AS pc FROM book_rating;\n+-----------------------+------+\n| name | pc |\n+-----------------------+------+\n| Lord of the Ladybirds | 3 |\n| Lord of the Ladybirds | 3 |\n| Lady of the Flies | 1 |\n| Lady of the Flies | 1 |\n| Lady of the Flies | 1 |\n+-----------------------+------+\n5 rows in set (0.000 sec)\n\nSELECT name, PERCENTILE_DISC(1) WITHIN GROUP (ORDER BY star_rating) \n OVER (PARTITION BY name) AS pc FROM book_rating;\n+-----------------------+------+\n ... +[PERCENT_RANK] +declaration= +category=Window Functions +description=PERCENT_RANK() is a window function that returns the relative percent rank of\na given row. The following formula is used to calculate the percent rank:\n\n(rank - 1) / (number of rows in the window or partition - 1)\n\nExamples\n--------\n\ncreate table t1 (\n pk int primary key,\n a int,\n b int\n);\n\ninsert into t1 values\n( 1 , 0, 10),\n( 2 , 0, 10),\n( 3 , 1, 10),\n( 4 , 1, 10),\n( 8 , 2, 10),\n( 5 , 2, 20),\n( 6 , 2, 20),\n( 7 , 2, 20),\n( 9 , 4, 20),\n(10 , 4, 20);\n\nselect pk, a, b,\n rank() over (order by a) as rank,\n percent_rank() over (order by a) as pct_rank,\n cume_dist() over (order by a) as cume_dist\nfrom t1;\n+----+------+------+------+--------------+--------------+\n| pk | a | b | rank | pct_rank | cume_dist |\n+----+------+------+------+--------------+--------------+\n| 1 | 0 | 10 | 1 | 0.0000000000 | 0.2000000000 |\n| 2 | 0 | 10 | 1 | 0.0000000000 | 0.2000000000 |\n| 3 | 1 | 10 | 3 | 0.2222222222 | 0.4000000000 |\n| 4 | 1 | 10 | 3 | 0.2222222222 | 0.4000000000 |\n| 5 | 2 | 20 | 5 | 0.4444444444 | 0.8000000000 |\n| 6 | 2 | 20 | 5 | 0.4444444444 | 0.8000000000 |\n| 7 | 2 | 20 | 5 | 0.4444444444 | 0.8000000000 |\n| 8 | 2 | 10 | 5 | 0.4444444444 | 0.8000000000 |\n| 9 | 4 | 20 | 9 | 0.8888888889 | 1.0000000000 |\n| 10 | 4 | 20 | 9 | 0.8888888889 | 1.0000000000 |\n+----+------+------+------+--------------+--------------+\n\nselect pk, a, b,\n percent_rank() over (order by pk) as pct_rank,\n cume_dist() over (order by pk) as cume_dist\nfrom t1 order by pk;\n ... +[PERIOD_ADD] +declaration=P,N +category=Date and Time Functions +description=Adds N months to period P. P is in the format YYMM or YYYYMM, and is not a\ndate value. If P contains a two-digit year, values from 00 to 69 are converted\nto from 2000 to 2069, while values from 70 are converted to 1970 upwards.\n\nReturns a value in the format YYYYMM.\n\nExamples\n--------\n\nSELECT PERIOD_ADD(200801,2);\n+----------------------+\n| PERIOD_ADD(200801,2) |\n+----------------------+\n| 200803 |\n+----------------------+\n\nSELECT PERIOD_ADD(6910,2);\n+--------------------+\n| PERIOD_ADD(6910,2) |\n+--------------------+\n| 206912 |\n+--------------------+\n\nSELECT PERIOD_ADD(7010,2);\n+--------------------+\n| PERIOD_ADD(7010,2) |\n+--------------------+\n| 197012 |\n+--------------------+\n\nURL: https://mariadb.com/kb/en/period_add/ +[PERIOD_DIFF] +declaration=P1,P2 +category=Date and Time Functions +description=Returns the number of months between periods P1 and P2. P1 and P2 can be in\nthe format YYMM or YYYYMM, and are not date values.\n\nIf P1 or P2 contains a two-digit year, values from 00 to 69 are converted to\nfrom 2000 to 2069, while values from 70 are converted to 1970 upwards.\n\nExamples\n--------\n\nSELECT PERIOD_DIFF(200802,200703);\n+----------------------------+\n| PERIOD_DIFF(200802,200703) |\n+----------------------------+\n| 11 |\n+----------------------------+\n\nSELECT PERIOD_DIFF(6902,6803);\n+------------------------+\n| PERIOD_DIFF(6902,6803) |\n+------------------------+\n| 11 |\n+------------------------+\n\nSELECT PERIOD_DIFF(7002,6803);\n+------------------------+\n| PERIOD_DIFF(7002,6803) |\n+------------------------+\n| -1177 |\n+------------------------+\n\nURL: https://mariadb.com/kb/en/period_diff/ +[PI] +declaration= +category=Numeric Functions +description=Returns the value of π (pi). The default number of decimal places displayed is\nsix, but MariaDB uses the full double-precision value internally.\n\nExamples\n--------\n\nSELECT PI();\n+----------+\n| PI() |\n+----------+\n| 3.141593 |\n+----------+\n\nSELECT PI()+0.0000000000000000000000;\n+-------------------------------+\n| PI()+0.0000000000000000000000 |\n+-------------------------------+\n| 3.1415926535897931159980 |\n+-------------------------------+\n\nURL: https://mariadb.com/kb/en/pi/ +[POINT] +declaration=x,y +category=Geometry Constructors +description=Constructs a WKB Point using the given coordinates.\n\nExamples\n--------\n\nSET @g = ST_GEOMFROMTEXT('Point(1 1)');\n\nCREATE TABLE gis_point (g POINT);\nINSERT INTO gis_point VALUES\n (PointFromText('POINT(10 10)')),\n (PointFromText('POINT(20 10)')),\n (PointFromText('POINT(20 20)')),\n (PointFromWKB(AsWKB(PointFromText('POINT(10 20)'))));\n\nURL: https://mariadb.com/kb/en/point/ +[POLYGON] +declaration=ls1,ls2,... +category=Geometry Constructors +description=Constructs a WKB Polygon value from a number of WKB LineString arguments. If\nany argument does not represent the WKB of a LinearRing (that is, not a closed\nand simple LineString) the return value is NULL.\n\nNote that according to the OpenGIS standard, a POLYGON should have exactly one\nExteriorRing and all other rings should lie within that ExteriorRing and thus\nbe the InteriorRings. Practically, however, some systems, including MariaDB's,\npermit polygons to have several 'ExteriorRings'. In the case of there being\nmultiple, non-overlapping exterior rings ST_NUMINTERIORRINGS() will return 1.\n\nExamples\n--------\n\nSET @g = ST_GEOMFROMTEXT('POLYGON((1 1,1 5,4 9,6 9,9 3,7 2,1 1))');\n\nCREATE TABLE gis_polygon (g POLYGON);\nINSERT INTO gis_polygon VALUES\n (PolygonFromText('POLYGON((10 10,20 10,20 20,10 20,10 10))')),\n (PolyFromText('POLYGON((0 0,50 0,50 50,0 50,0 0), (10 10,20 10,20 20,10\n20,10 10))')),\n (PolyFromWKB(AsWKB(Polygon(LineString(Point(0, 0), Point(30, 0), Point(30,\n30), Point(0, 0))))));\n\nNon-overlapping 'polygon':\n\nSELECT ST_NumInteriorRings(ST_PolyFromText('POLYGON((0 0,10 0,10 10,0 10,0 0),\n (-1 -1,-5 -1,-5 -5,-1 -5,-1 -1))')) AS NumInteriorRings;\n+------------------+\n| NumInteriorRings |\n+------------------+\n| 1 |\n+------------------+\n\nURL: https://mariadb.com/kb/en/polygon/ +[POSITION] +declaration=substr IN str +category=String Functions +description=POSITION(substr IN str) is a synonym for LOCATE(substr,str).\n\nIt's part of ODBC 3.0.\n\nURL: https://mariadb.com/kb/en/position/ +[POW] +declaration=X,Y +category=Numeric Functions +description=Returns the value of X raised to the power of Y.\n\nPOWER() is a synonym.\n\nExamples\n--------\n\nSELECT POW(2,3);\n+----------+\n| POW(2,3) |\n+----------+\n| 8 |\n+----------+\n\nSELECT POW(2,-2);\n+-----------+\n| POW(2,-2) |\n+-----------+\n| 0.25 |\n+-----------+\n\nURL: https://mariadb.com/kb/en/pow/ +[POWER] +declaration=X,Y +category=Numeric Functions +description=This is a synonym for POW(), which returns the value of X raised to the power\nof Y.\n\nURL: https://mariadb.com/kb/en/power/ +[QUARTER] +declaration=date +category=Date and Time Functions +description=Returns the quarter of the year for date, in the range 1 to 4. Returns 0 if\nmonth contains a zero value, or NULL if the given value is not otherwise a\nvalid date (zero values are accepted).\n\nExamples\n--------\n\nSELECT QUARTER('2008-04-01');\n+-----------------------+\n| QUARTER('2008-04-01') |\n+-----------------------+\n| 2 |\n+-----------------------+\n\nSELECT QUARTER('2019-00-01');\n+-----------------------+\n| QUARTER('2019-00-01') |\n+-----------------------+\n| 0 |\n+-----------------------+\n\nURL: https://mariadb.com/kb/en/quarter/ +[QUOTE] +declaration=str +category=String Functions +description=Quotes a string to produce a result that can be used as a properly escaped\ndata value in an SQL statement. The string is returned enclosed by single\nquotes and with each instance of single quote ("'"), backslash ("\"), ASCII\nNUL, and Control-Z preceded by a backslash. If the argument is NULL, the\nreturn value is the word "NULL" without enclosing single quotes.\n\nExamples\n--------\n\nSELECT QUOTE("Don't!");\n+-----------------+\n| QUOTE("Don't!") |\n+-----------------+\n| 'Don\'t!' |\n+-----------------+\n\nSELECT QUOTE(NULL); \n+-------------+\n| QUOTE(NULL) |\n+-------------+\n| NULL |\n+-------------+\n\nURL: https://mariadb.com/kb/en/quote/ +[RADIANS] +declaration=X +category=Numeric Functions +description=Returns the argument X, converted from degrees to radians. Note that π radians\nequals 180 degrees.\n\nThis is the converse of the DEGREES() function.\n\nExamples\n--------\n\nSELECT RADIANS(45);\n+-------------------+\n| RADIANS(45) |\n+-------------------+\n| 0.785398163397448 |\n+-------------------+\n\nSELECT RADIANS(90);\n+-----------------+\n| RADIANS(90) |\n+-----------------+\n| 1.5707963267949 |\n+-----------------+\n\nSELECT RADIANS(PI());\n+--------------------+\n| RADIANS(PI()) |\n+--------------------+\n| 0.0548311355616075 |\n+--------------------+\n\nSELECT RADIANS(180);\n+------------------+\n| RADIANS(180) |\n+------------------+\n| 3.14159265358979 |\n+------------------+\n\nURL: https://mariadb.com/kb/en/radians/ +[RAND] +declaration= +category=Numeric Functions +description=Returns a random DOUBLE precision floating point value v in the range 0 <= v <\n1.0. If a constant integer argument N is specified, it is used as the seed\nvalue, which produces a repeatable sequence of column values. In the example\nbelow, note that the sequences of values produced by RAND(3) is the same both\nplaces where it occurs.\n\nIn a WHERE clause, RAND() is evaluated each time the WHERE is executed.\n\nStatements using the RAND() function are not safe for statement-based\nreplication.\n\nPractical uses\n--------------\n\nThe expression to get a random integer from a given range is the following:\n\nFLOOR(min_value + RAND() * (max_value - min_value +1))\n\nRAND() is often used to read random rows from a table, as follows:\n\nSELECT * FROM my_table ORDER BY RAND() LIMIT 10;\n\nNote, however, that this technique should never be used on a large table as it\nwill be extremely slow. MariaDB will read all rows in the table, generate a\nrandom value for each of them, order them, and finally will apply the LIMIT\nclause.\n\nExamples\n--------\n\nCREATE TABLE t (i INT);\n\nINSERT INTO t VALUES(1),(2),(3);\n\nSELECT i, RAND() FROM t;\n+------+-------------------+\n| i | RAND() |\n+------+-------------------+\n| 1 | 0.255651095188829 |\n| 2 | 0.833920199269355 |\n| 3 | 0.40264774151393 |\n+------+-------------------+\n\nSELECT i, RAND(3) FROM t;\n+------+-------------------+\n| i | RAND(3) |\n+------+-------------------+\n| 1 | 0.90576975597606 |\n| 2 | 0.373079058130345 |\n| 3 | 0.148086053457191 |\n ... +[RANDOM_BYTES] +declaration=length +category=Encryption Functions +description=Given a length from 1 to 1024, generates a binary string of length consisting\nof random bytes generated by the SSL library's random number generator.\n\nSee the RAND_bytes() function documentation of your SSL library for\ninformation on the random number generator. In the case of OpenSSL, a\ncryptographically secure pseudo random generator (CSPRNG) is used.\n\nStatements containing the RANDOM_BYTES function are unsafe for statement-based\nreplication.\n\nAn error occurs if length is outside the range 1 to 1024.\n\nURL: https://mariadb.com/kb/en/random_bytes/ +[RANK] +declaration= +category=Window Functions +description=RANK() is a window function that displays the number of a given row, starting\nat one and following the ORDER BY sequence of the window function, with\nidentical values receiving the same result. It is similar to the ROW_NUMBER()\nfunction except that in that function, identical values will receive a\ndifferent row number for each result.\n\nExamples\n--------\n\nThe distinction between DENSE_RANK(), RANK() and ROW_NUMBER():\n\nCREATE TABLE student(course VARCHAR(10), mark int, name varchar(10));\n\nINSERT INTO student VALUES \n ('Maths', 60, 'Thulile'),\n ('Maths', 60, 'Pritha'),\n ('Maths', 70, 'Voitto'),\n ('Maths', 55, 'Chun'),\n ('Biology', 60, 'Bilal'),\n ('Biology', 70, 'Roger');\n\nSELECT \n RANK() OVER (PARTITION BY course ORDER BY mark DESC) AS rank,\n DENSE_RANK() OVER (PARTITION BY course ORDER BY mark DESC) AS dense_rank,\n ROW_NUMBER() OVER (PARTITION BY course ORDER BY mark DESC) AS row_num,\n course, mark, name\nFROM student ORDER BY course, mark DESC;\n+------+------------+---------+---------+------+---------+\n| rank | dense_rank | row_num | course | mark | name |\n+------+------------+---------+---------+------+---------+\n| 1 | 1 | 1 | Biology | 70 | Roger |\n| 2 | 2 | 2 | Biology | 60 | Bilal |\n| 1 | 1 | 1 | Maths | 70 | Voitto |\n| 2 | 2 | 2 | Maths | 60 | Thulile |\n| 2 | 2 | 3 | Maths | 60 | Pritha |\n| 4 | 3 | 4 | Maths | 55 | Chun |\n+------+------------+---------+---------+------+---------+\n\nURL: https://mariadb.com/kb/en/rank/ +[REGEXP_INSTR] +declaration=subject, pattern +category=String Functions +description=Returns the position of the first occurrence of the regular expression pattern\nin the string subject, or 0 if pattern was not found.\n\nThe positions start with 1 and are measured in characters (i.e. not in bytes),\nwhich is important for multi-byte character sets. You can cast a multi-byte\ncharacter set to BINARY to get offsets in bytes.\n\nThe function follows the case sensitivity rules of the effective collation.\nMatching is performed case insensitively for case insensitive collations, and\ncase sensitively for case sensitive collations and for binary data.\n\nThe collation case sensitivity can be overwritten using the (?i) and (?-i)\nPCRE flags.\n\nMariaDB uses the PCRE regular expression library for enhanced regular\nexpression performance, and REGEXP_INSTR was introduced as part of this\nenhancement.\n\nExamples\n--------\n\nSELECT REGEXP_INSTR('abc','b');\n-> 2\n\nSELECT REGEXP_INSTR('abc','x');\n-> 0\n\nSELECT REGEXP_INSTR('BJÖRN','N');\n-> 5\n\nCasting a multi-byte character set as BINARY to get offsets in bytes:\n\nSELECT REGEXP_INSTR(BINARY 'BJÖRN','N') AS cast_utf8_to_binary;\n-> 6\n\nCase sensitivity:\n\nSELECT REGEXP_INSTR('ABC','b');\n-> 2\n\nSELECT REGEXP_INSTR('ABC' COLLATE utf8_bin,'b');\n-> 0\n\nSELECT REGEXP_INSTR(BINARY'ABC','b');\n-> 0\n\nSELECT REGEXP_INSTR('ABC','(?-i)b');\n-> 0\n\nSELECT REGEXP_INSTR('ABC' COLLATE utf8_bin,'(?i)b');\n-> 2\n\nURL: https://mariadb.com/kb/en/regexp_instr/ +[REGEXP_REPLACE] +declaration=subject, pattern, replace +category=String Functions +description=REGEXP_REPLACE returns the string subject with all occurrences of the regular\nexpression pattern replaced by the string replace. If no occurrences are\nfound, then subject is returned as is.\n\nThe replace string can have backreferences to the subexpressions in the form\n\N, where N is a number from 1 to 9.\n\nThe function follows the case sensitivity rules of the effective collation.\nMatching is performed case insensitively for case insensitive collations, and\ncase sensitively for case sensitive collations and for binary data.\n\nThe collation case sensitivity can be overwritten using the (?i) and (?-i)\nPCRE flags.\n\nMariaDB uses the PCRE regular expression library for enhanced regular\nexpression performance, and REGEXP_REPLACE was introduced as part of this\nenhancement.\n\nThe default_regex_flags variable addresses the remaining compatibilities\nbetween PCRE and the old regex library.\n\nExamples\n--------\n\nSELECT REGEXP_REPLACE('ab12cd','[0-9]','') AS remove_digits;\n-> abcd\n\nSELECT\nREGEXP_REPLACE('titlebody',\n'<.+?>',' ')\nAS strip_html;\n-> title body\n\nBackreferences to the subexpressions in the form \N, where N is a number from\n1 to 9:\n\nSELECT REGEXP_REPLACE('James Bond','^(.*) (.*)$','\\2, \\1') AS reorder_name;\n-> Bond, James\n\nCase insensitive and case sensitive matches:\n\nSELECT REGEXP_REPLACE('ABC','b','-') AS case_insensitive;\n-> A-C\n\nSELECT REGEXP_REPLACE('ABC' COLLATE utf8_bin,'b','-') AS case_sensitive;\n-> ABC\n\nSELECT REGEXP_REPLACE(BINARY 'ABC','b','-') AS binary_data;\n-> ABC\n\n ... +[REGEXP_SUBSTR] +declaration=subject,pattern +category=String Functions +description=Returns the part of the string subject that matches the regular expression\npattern, or an empty string if pattern was not found.\n\nThe function follows the case sensitivity rules of the effective collation.\nMatching is performed case insensitively for case insensitive collations, and\ncase sensitively for case sensitive collations and for binary data.\n\nThe collation case sensitivity can be overwritten using the (?i) and (?-i)\nPCRE flags.\n\nMariaDB uses the PCRE regular expression library for enhanced regular\nexpression performance, and REGEXP_SUBSTR was introduced as part of this\nenhancement.\n\nThe default_regex_flags variable addresses the remaining compatibilities\nbetween PCRE and the old regex library.\n\nExamples\n--------\n\nSELECT REGEXP_SUBSTR('ab12cd','[0-9]+');\n-> 12\n\nSELECT REGEXP_SUBSTR(\n 'See https://mariadb.org/en/foundation/ for details',\n 'https?://[^/]*');\n-> https://mariadb.org\n\nSELECT REGEXP_SUBSTR('ABC','b');\n-> B\n\nSELECT REGEXP_SUBSTR('ABC' COLLATE utf8_bin,'b');\n->\n\nSELECT REGEXP_SUBSTR(BINARY'ABC','b');\n->\n\nSELECT REGEXP_SUBSTR('ABC','(?i)b');\n-> B\n\nSELECT REGEXP_SUBSTR('ABC' COLLATE utf8_bin,'(?+i)b');\n-> B\n\nURL: https://mariadb.com/kb/en/regexp_substr/ +[RELEASE_ALL_LOCKS] +declaration= +category=Miscellaneous Functions +description=Releases all named locks held by the current session. Returns the number of\nlocks released, or 0 if none were held.\n\nStatements using the RELEASE_ALL_LOCKS function are not safe for\nstatement-based replication.\n\nExamples\n--------\n\nSELECT RELEASE_ALL_LOCKS();\n+---------------------+\n| RELEASE_ALL_LOCKS() | \n+---------------------+\n| 0 |\n+---------------------+\n\nSELECT GET_LOCK('lock1',10);\n+----------------------+\n| GET_LOCK('lock1',10) |\n+----------------------+\n| 1 |\n+----------------------+\n\nSELECT RELEASE_ALL_LOCKS();\n+---------------------+\n| RELEASE_ALL_LOCKS() | \n+---------------------+\n| 1 |\n+---------------------+\n\nURL: https://mariadb.com/kb/en/release_all_locks/ +[RELEASE_LOCK] +declaration=str +category=Miscellaneous Functions +description=Releases the lock named by the string str that was obtained with GET_LOCK().\nReturns 1 if the lock was released, 0 if the lock was not established by this\nthread (in which case the lock is not released), and NULL if the named lock\ndid not exist. The lock does not exist if it was never obtained by a call to\nGET_LOCK() or if it has previously been released.\n\nstr is case insensitive. If str is an empty string or NULL, RELEASE_LOCK()\nreturns NULL and does nothing.\n\nStatements using the RELEASE_LOCK function are not safe for statement-based\nreplication.\n\nThe DO statement is convenient to use with RELEASE_LOCK().\n\nExamples\n--------\n\nConnection1:\n\nSELECT GET_LOCK('lock1',10);\n+----------------------+\n| GET_LOCK('lock1',10) |\n+----------------------+\n| 1 |\n+----------------------+\n\nConnection 2:\n\nSELECT GET_LOCK('lock2',10);\n+----------------------+\n| GET_LOCK('lock2',10) |\n+----------------------+\n| 1 |\n+----------------------+\n\nConnection 1:\n\nSELECT RELEASE_LOCK('lock1'), RELEASE_LOCK('lock2'), RELEASE_LOCK('lock3');\n+-----------------------+-----------------------+-----------------------+\n| RELEASE_LOCK('lock1') | RELEASE_LOCK('lock2') | RELEASE_LOCK('lock3') |\n+-----------------------+-----------------------+-----------------------+\n| 1 | 0 | NULL |\n+-----------------------+-----------------------+-----------------------+\n\nIt is possible to hold the same lock recursively. This example is viewed using\nthe metadata_lock_info plugin:\n\nSELECT GET_LOCK('lock3',10);\n+----------------------+\n| GET_LOCK('lock3',10) |\n ... +[RETURN] +declaration=SELECT COUNT(DISTINCT User +category=Compound Statements +description=END;\n\nURL: https://mariadb.com/kb/en/return/ +[REVERSE] +declaration=str +category=String Functions +description=Returns the string str with the order of the characters reversed.\n\nExamples\n--------\n\nSELECT REVERSE('desserts');\n+---------------------+\n| REVERSE('desserts') |\n+---------------------+\n| stressed |\n+---------------------+\n\nURL: https://mariadb.com/kb/en/reverse/ +[RIGHT] +declaration=str,len +category=String Functions +description=Returns the rightmost len characters from the string str, or NULL if any\nargument is NULL.\n\nExamples\n--------\n\nSELECT RIGHT('MariaDB', 2);\n+---------------------+\n| RIGHT('MariaDB', 2) |\n+---------------------+\n| DB |\n+---------------------+\n\nURL: https://mariadb.com/kb/en/right/ +[ROLLBACK] +declaration=the keyword WORK is simply noise and can be omitted without changing the effect +category=Transactions +description=The optional AND CHAIN clause is a convenience for initiating a new\ntransaction as soon as the old transaction terminates. If AND CHAIN is\nspecified, then there is effectively nothing between the old and new\ntransactions, although they remain separate. The characteristics of the new\ntransaction will be the same as the characteristics of the old one - that is,\nthe new transaction will have the same access mode, isolation level and\ndiagnostics area size (we'll discuss all of these shortly) as the transaction\njust terminated. The AND NO CHAIN option just tells your DBMS to end the\ntransaction - that is, these four SQL statements are equivalent:\n\nROLLBACK; \nROLLBACK WORK; \nROLLBACK AND NO CHAIN; \nROLLBACK WORK AND NO CHAIN;\n\nAll of them end a transaction without saving any transaction characteristics.\nThe only other options, the equivalent statements:\n\nROLLBACK AND CHAIN;\nROLLBACK WORK AND CHAIN;\n\nboth tell your DBMS to end a transaction, but to save that transaction's\ncharacteristics for the next transaction.\n\nROLLBACK is much simpler than COMMIT: it may involve no more than a few\ndeletions (of Cursors, locks, prepared SQL statements and log-file entries).\nIt's usually assumed that ROLLBACK can't fail, although such a thing is\nconceivable (for example, an encompassing transaction might reject an attempt\nto ROLLBACK because it's lining up for a COMMIT).\n\nROLLBACK cancels all effects of a transaction. It does not cancel effects on\nobjects outside the DBMS's control (for example the values in host program\nvariables or the settings made by some SQL/CLI function calls). But in\ngeneral, it is a convenient statement for those situations when you say "oops,\nthis isn't working" or when you simply don't care whether your temporary work\nbecomes permanent or not.\n\nHere is a moot question. If all you've been doing is SELECTs, so that there\nhave been no data changes, should you end the transaction with ROLLBACK or\nCOMMIT? It shouldn't really matter because both ROLLBACK and COMMIT do the\nsame transaction-terminating job. However, the popular conception is that\nROLLBACK implies failure, so after a successful series of SELECT statements\nthe convention is to end the transaction with COMMIT rather than ROLLBACK.\n\nMariaDB (and most other DBMSs) supports rollback of SQL-data change\nstatements, but not of SQL-Schema statements. This means that if you use any\nof CREATE, ALTER, DROP, GRANT, REVOKE, you are implicitly committing at\nexecution time.\n\nINSERT INTO Table_2 VALUES(5); \n ... +[ROUND] +declaration=X +category=Numeric Functions +description=Rounds the argument X to D decimal places. D defaults to 0 if not specified. D\ncan be negative to cause D digits left of the decimal point of the value X to\nbecome zero.\n\nThe rounding algorithm depends on the data type of X:\n\n* for floating point types (FLOAT, DOUBLE) the C libraries rounding function\nis used, so the behavior *may* differ between operating systems\n* for fixed point types (DECIMAL, DEC/NUMBER/FIXED) the "round half up" rule\nis used, meaning that e.g. a value ending in exactly .5 is always rounded up.\n\nExamples\n--------\n\nSELECT ROUND(-1.23);\n+--------------+\n| ROUND(-1.23) |\n+--------------+\n| -1 |\n+--------------+\n\nSELECT ROUND(-1.58);\n+--------------+\n| ROUND(-1.58) |\n+--------------+\n| -2 |\n+--------------+\n\nSELECT ROUND(1.58); \n+-------------+\n| ROUND(1.58) |\n+-------------+\n| 2 |\n+-------------+\n\nSELECT ROUND(1.298, 1);\n+-----------------+\n| ROUND(1.298, 1) |\n+-----------------+\n| 1.3 |\n+-----------------+\n\nSELECT ROUND(1.298, 0);\n+-----------------+\n| ROUND(1.298, 0) |\n+-----------------+\n| 1 |\n+-----------------+\n\nSELECT ROUND(23.298, -1);\n ... +[ROW] +declaration= [{, }... ] +category=Data Types +description=ROW is a data type for stored procedure variables.\n\nFeatures\n--------\n\nROW fields as normal variables\n------------------------------\n\nROW fields (members) act as normal variables, and are able to appear in all\nquery parts where a stored procedure variable is allowed:\n\n* Assignment is using the := operator and the SET command:\n\na.x:= 10;\na.x:= b.x;\nSET a.x= 10, a.y=20, a.z= b.z;\n\n* Passing to functions and operators:\n\nSELECT f1(rec.a), rec.a<10;\n\n* Clauses (select list, WHERE, HAVING, LIMIT, etc...,):\n\nSELECT var.a, t1.b FROM t1 WHERE t1.b=var.b LIMIT var.c;\n\n* INSERT values:\n\nINSERT INTO t1 VALUES (rec.a, rec.b, rec.c);\n\n* SELECT .. INTO targets\n\nSELECT a,b INTO rec.a, rec.b FROM t1 WHERE t1.id=10;\n\n* Dynamic SQL out parameters (EXECUTE and EXECUTE IMMEDIATE)\n\nEXECUTE IMMEDIATE 'CALL proc_with_out_param(?)' USING rec.a;\n\nROW type variables as FETCH targets\n-----------------------------------\n\nROW type variables are allowed as FETCH targets:\n\nFETCH cur INTO rec;\n\nwhere cur is a CURSOR and rec is a ROW type stored procedure variable.\n\nNote, currently an attempt to use FETCH for a ROW type variable returns this\nerror:\n\nERROR 1328 (HY000): Incorrect number of FETCH variables\n ... +[ROWNUM] +declaration= +category=Information Functions +description=ROWNUM() returns the current number of accepted rows in the current context.\nIt main purpose is to emulate the ROWNUM pseudo column in Oracle. For MariaDB\nnative applications, we recommend the usage of LIMIT, as it is easier to use\nand gives more predictable results than the usage of ROWNUM().\n\nThe main difference between using LIMIT and ROWNUM() to limit the rows in the\nresult is that LIMIT works on the result set while ROWNUM works on the number\nof accepted rows (before any ORDER or GROUP BY clauses).\n\nThe following queries will return the same results:\n\nSELECT * from t1 LIMIT 10;\nSELECT * from t1 WHERE ROWNUM() <= 10;\n\nWhile the following may return different results based on in which orders the\nrows are found:\n\nSELECT * from t1 ORDER BY a LIMIT 10;\nSELECT * from t1 ORDER BY a WHERE ROWNUM() <= 10;\n\nThe recommended way to use ROWNUM to limit the number of returned rows and get\npredictable results is to have the query in a subquery and test for ROWNUM()\nin the outer query:\n\nSELECT * FROM (select * from t1 ORDER BY a) WHERE ROWNUM() <= 10;\n\nROWNUM() can be used in the following contexts:\n\n* SELECT\n* INSERT\n* UPDATE\n* DELETE\n* LOAD DATA INFILE\n\nUsed in other contexts, ROWNUM() will return 0.\n\nExamples\n--------\n\nINSERT INTO t1 VALUES (1,ROWNUM()),(2,ROWNUM()),(3,ROWNUM());\n\nINSERT INTO t1 VALUES (1),(2) returning a, ROWNUM();\n\nUPDATE t1 SET row_num_column=ROWNUM();\n\nDELETE FROM t1 WHERE a < 10 AND ROWNUM() < 2;\n\nLOAD DATA INFILE 'filename' into table t1 fields terminated by ',' \n lines terminated by "\r\n" (a,b) set c=ROWNUM();\n\n ... +[ROW_COUNT] +declaration= +category=Information Functions +description=ROW_COUNT() returns the number of rows updated, inserted or deleted by the\npreceding statement. This is the same as the row count that the mariadb client\ndisplays and the value from the mysql_affected_rows() C API function.\n\nGenerally:\n\n* For statements which return a result set (such as SELECT, SHOW, DESC or\nHELP), returns -1, even when the result set is empty. This is also true for\nadministrative statements, such as OPTIMIZE.\n* For DML statements other than SELECT and for ALTER TABLE, returns the number\nof affected rows.\n* For DDL statements (including TRUNCATE) and for other statements which don't\nreturn any result set (such as USE, DO, SIGNAL or DEALLOCATE PREPARE), returns\n0.\n\nFor UPDATE, affected rows is by default the number of rows that were actually\nchanged. If the CLIENT_FOUND_ROWS flag to mysql_real_connect() is specified\nwhen connecting to mysqld, affected rows is instead the number of rows matched\nby the WHERE clause.\n\nFor REPLACE, deleted rows are also counted. So, if REPLACE deletes a row and\nadds a new row, ROW_COUNT() returns 2.\n\nFor INSERT ... ON DUPLICATE KEY, updated rows are counted twice. So, if INSERT\nadds a new rows and modifies another row, ROW_COUNT() returns 3.\n\nROW_COUNT() does not take into account rows that are not directly\ndeleted/updated by the last statement. This means that rows deleted by foreign\nkeys or triggers are not counted.\n\nWarning: You can use ROW_COUNT() with prepared statements, but you need to\ncall it after EXECUTE, not after DEALLOCATE PREPARE, because the row count for\nallocate prepare is always 0.\n\nWarning: When used after a CALL statement, this function returns the number of\nrows affected by the last statement in the procedure, not by the whole\nprocedure.\n\nWarning: After INSERT DELAYED, ROW_COUNT() returns the number of the rows you\ntried to insert, not the number of the successful writes.\n\nThis information can also be found in the diagnostics area.\n\nStatements using the ROW_COUNT() function are not safe for statement-based\nreplication.\n\nExamples\n--------\n\nCREATE TABLE t (A INT);\n ... +[ROW_NUMBER] +declaration= +category=Window Functions +description=ROW_NUMBER() is a window function that displays the number of a given row,\nstarting at one and following the ORDER BY sequence of the window function,\nwith identical values receiving different row numbers. It is similar to the\nRANK() and DENSE_RANK() functions except that in that function, identical\nvalues will receive the same rank for each result.\n\nExamples\n--------\n\nThe distinction between DENSE_RANK(), RANK() and ROW_NUMBER():\n\nCREATE TABLE student(course VARCHAR(10), mark int, name varchar(10));\n\nINSERT INTO student VALUES \n ('Maths', 60, 'Thulile'),\n ('Maths', 60, 'Pritha'),\n ('Maths', 70, 'Voitto'),\n ('Maths', 55, 'Chun'),\n ('Biology', 60, 'Bilal'),\n ('Biology', 70, 'Roger');\n\nSELECT \n RANK() OVER (PARTITION BY course ORDER BY mark DESC) AS rank,\n DENSE_RANK() OVER (PARTITION BY course ORDER BY mark DESC) AS dense_rank,\n ROW_NUMBER() OVER (PARTITION BY course ORDER BY mark DESC) AS row_num,\n course, mark, name\nFROM student ORDER BY course, mark DESC;\n+------+------------+---------+---------+------+---------+\n| rank | dense_rank | row_num | course | mark | name |\n+------+------------+---------+---------+------+---------+\n| 1 | 1 | 1 | Biology | 70 | Roger |\n| 2 | 2 | 2 | Biology | 60 | Bilal |\n| 1 | 1 | 1 | Maths | 70 | Voitto |\n| 2 | 2 | 2 | Maths | 60 | Thulile |\n| 2 | 2 | 3 | Maths | 60 | Pritha |\n| 4 | 3 | 4 | Maths | 55 | Chun |\n+------+------------+---------+---------+------+---------+\n\nURL: https://mariadb.com/kb/en/row_number/ +[RPAD] +declaration=str, len [, padstr] +category=String Functions +description=Returns the string str, right-padded with the string padstr to a length of len\ncharacters. If str is longer than len, the return value is shortened to len\ncharacters. If padstr is omitted, the RPAD function pads spaces.\n\nPrior to MariaDB 10.3.1, the padstr parameter was mandatory.\n\nReturns NULL if given a NULL argument. If the result is empty (a length of\nzero), returns either an empty string, or, from MariaDB 10.3.6 with\nSQL_MODE=Oracle, NULL.\n\nThe Oracle mode version of the function can be accessed outside of Oracle mode\nby using RPAD_ORACLE as the function name.\n\nExamples\n--------\n\nSELECT RPAD('hello',10,'.');\n+----------------------+\n| RPAD('hello',10,'.') |\n+----------------------+\n| hello..... |\n+----------------------+\n\nSELECT RPAD('hello',2,'.');\n+---------------------+\n| RPAD('hello',2,'.') |\n+---------------------+\n| he |\n+---------------------+\n\nFrom MariaDB 10.3.1, with the pad string defaulting to space.\n\nSELECT RPAD('hello',30);\n+--------------------------------+\n| RPAD('hello',30) |\n+--------------------------------+\n| hello |\n+--------------------------------+\n\nOracle mode version from MariaDB 10.3.6:\n\nSELECT RPAD('',0),RPAD_ORACLE('',0);\n+------------+-------------------+\n| RPAD('',0) | RPAD_ORACLE('',0) |\n+------------+-------------------+\n| | NULL |\n+------------+-------------------+\n\nURL: https://mariadb.com/kb/en/rpad/ +[RTRIM] +declaration=str +category=String Functions +description=Returns the string str with trailing space characters removed.\n\nReturns NULL if given a NULL argument. If the result is empty, returns either\nan empty string, or, from MariaDB 10.3.6 with SQL_MODE=Oracle, NULL.\n\nThe Oracle mode version of the function can be accessed outside of Oracle mode\nby using RTRIM_ORACLE as the function name.\n\nExamples\n--------\n\nSELECT QUOTE(RTRIM('MariaDB '));\n+-----------------------------+\n| QUOTE(RTRIM('MariaDB ')) |\n+-----------------------------+\n| 'MariaDB' |\n+-----------------------------+\n\nOracle mode version from MariaDB 10.3.6:\n\nSELECT RTRIM(''),RTRIM_ORACLE('');\n+-----------+------------------+\n| RTRIM('') | RTRIM_ORACLE('') |\n+-----------+------------------+\n| | NULL |\n+-----------+------------------+\n\nURL: https://mariadb.com/kb/en/rtrim/ +[SCHEMA] +declaration= +category=Information Functions +description=This function is a synonym for DATABASE().\n\nURL: https://mariadb.com/kb/en/schema/ +[SECOND] +declaration=time +category=Date and Time Functions +description=Returns the second for a given time (which can include microseconds), in the\nrange 0 to 59, or NULL if not given a valid time value.\n\nExamples\n--------\n\nSELECT SECOND('10:05:03');\n+--------------------+\n| SECOND('10:05:03') |\n+--------------------+\n| 3 |\n+--------------------+\n\nSELECT SECOND('10:05:01.999999');\n+---------------------------+\n| SECOND('10:05:01.999999') |\n+---------------------------+\n| 1 |\n+---------------------------+\n\nURL: https://mariadb.com/kb/en/second/ +[SEC_TO_TIME] +declaration=seconds +category=Date and Time Functions +description=Returns the seconds argument, converted to hours, minutes, and seconds, as a\nTIME value. The range of the result is constrained to that of the TIME data\ntype. A warning occurs if the argument corresponds to a value outside that\nrange.\n\nThe time will be returned in the format hh:mm:ss, or hhmmss if used in a\nnumeric calculation.\n\nExamples\n--------\n\nSELECT SEC_TO_TIME(12414);\n+--------------------+\n| SEC_TO_TIME(12414) |\n+--------------------+\n| 03:26:54 |\n+--------------------+\n\nSELECT SEC_TO_TIME(12414)+0;\n+----------------------+\n| SEC_TO_TIME(12414)+0 |\n+----------------------+\n| 32654 |\n+----------------------+\n\nSELECT SEC_TO_TIME(9999999);\n+----------------------+\n| SEC_TO_TIME(9999999) |\n+----------------------+\n| 838:59:59 |\n+----------------------+\n1 row in set, 1 warning (0.00 sec)\n\nSHOW WARNINGS;\n+---------+------+-------------------------------------------+\n| Level | Code | Message |\n+---------+------+-------------------------------------------+\n| Warning | 1292 | Truncated incorrect time value: '9999999' |\n+---------+------+-------------------------------------------+\n\nURL: https://mariadb.com/kb/en/sec_to_time/ +[SESSION_USER] +declaration= +category=Information Functions +description=SESSION_USER() is a synonym for USER().\n\nURL: https://mariadb.com/kb/en/session_user/ +[SETVAL] +declaration=sequence_name, next_value, [is_used, [round]] +category=Sequences +description=Set the next value to be returned for a SEQUENCE.\n\nThis function is compatible with PostgreSQL syntax, extended with the round\nargument.\n\nIf the is_used argument is not given or is 1 or true, then the next used value\nwill one after the given value. If is_used is 0 or false then the next\ngenerated value will be the given value.\n\nIf round is used then it will set the round value (or the internal cycle\ncount, starting at zero) for the sequence. If round is not used, it's assumed\nto be 0.\n\nnext_value must be an integer literal.\n\nFor SEQUENCE tables defined with CYCLE (see CREATE SEQUENCE) one should use\nboth next_value and round to define the next value. In this case the current\nsequence value is defined to be round, next_value.\n\nThe result returned by SETVAL() is next_value or NULL if the given next_value\nand round is smaller than the current value.\n\nSETVAL() will not set the SEQUENCE value to a something that is less than its\ncurrent value. This is needed to ensure that SETVAL() is replication safe. If\nyou want to set the SEQUENCE to a smaller number use ALTER SEQUENCE.\n\nIf CYCLE is used, first round and then next_value are compared to see if the\nvalue is bigger than the current value.\n\nInternally, in the MariaDB server, SETVAL() is used to inform slaves that a\nSEQUENCE has changed value. The slave may get SETVAL() statements out of\norder, but this is ok as only the biggest one will have an effect.\n\nSETVAL requires the INSERT privilege.\n\nExamples\n--------\n\nSELECT setval(foo, 42); -- Next nextval will return 43\nSELECT setval(foo, 42, true); -- Same as above\nSELECT setval(foo, 42, false); -- Next nextval will return 42\n\nSETVAL setting higher and lower values on a sequence with an increment of 10:\n\nSELECT NEXTVAL(s);\n+------------+\n| NEXTVAL(s) |\n+------------+\n| 50 |\n+------------+\n ... +[SFORMAT] +declaration="The answer is {}.", 42 +category=String Functions +description=+----------------------------------+\n| SFORMAT("The answer is {}.", 42) |\n+----------------------------------+\n| The answer is 42. |\n+----------------------------------+\n\nCREATE TABLE test_sformat(mdb_release char(6), mdev int, feature char(20));\n\nINSERT INTO test_sformat VALUES('10.7.0', 25015, 'Python style sformat'), \n ('10.7.0', 4958, 'UUID');\n\nSELECT * FROM test_sformat;\n+-------------+-------+----------------------+\n| mdb_release | mdev | feature |\n+-------------+-------+----------------------+\n| 10.7.0 | 25015 | Python style sformat |\n| 10.7.0 | 4958 | UUID |\n+-------------+-------+----------------------+\n\nSELECT SFORMAT('MariaDB Server {} has a preview for MDEV-{} which is about\n{}', \n mdb_release, mdev, feature) AS 'Preview Release Examples'\n FROM test_sformat;\n+------------------------------------------------------------------------------\n---------+\n| Preview Release Examples \n |\n+------------------------------------------------------------------------------\n---------+\n| MariaDB Server 10.7.0 has a preview for MDEV-25015 which is about Python\nstyle sformat |\n| MariaDB Server 10.7.0 has a preview for MDEV-4958 which is about UUID \n |\n+------------------------------------------------------------------------------\n---------+\n\nURL: https://mariadb.com/kb/en/sformat/ +[SHA1] +declaration=str +category=Encryption Functions +description=Calculates an SHA-1 160-bit checksum for the string str, as described in RFC\n3174 (Secure Hash Algorithm).\n\nThe value is returned as a string of 40 hex digits, or NULL if the argument\nwas NULL. As of MariaDB 5.5, the return value is a nonbinary string in the\nconnection character set and collation, determined by the values of the\ncharacter_set_connection and collation_connection system variables. Before\n5.5, the return value was a binary string.\n\nExamples\n--------\n\nSELECT SHA1('some boring text');\n+------------------------------------------+\n| SHA1('some boring text') |\n+------------------------------------------+\n| af969fc2085b1bb6d31e517d5c456def5cdd7093 |\n+------------------------------------------+\n\nURL: https://mariadb.com/kb/en/sha1/ +[SHA2] +declaration=str,hash_len +category=Encryption Functions +description=Given a string str, calculates an SHA-2 checksum, which is considered more\ncryptographically secure than its SHA-1 equivalent. The SHA-2 family includes\nSHA-224, SHA-256, SHA-384, and SHA-512, and the hash_len must correspond to\none of these, i.e. 224, 256, 384 or 512. 0 is equivalent to 256.\n\nThe return value is a nonbinary string in the connection character set and\ncollation, determined by the values of the character_set_connection and\ncollation_connection system variables.\n\nNULL is returned if the hash length is not valid, or the string str is NULL.\n\nSHA2 will only work if MariaDB was has been configured with TLS support.\n\nExamples\n--------\n\nSELECT SHA2('Maria',224);\n+----------------------------------------------------------+\n| SHA2('Maria',224) |\n+----------------------------------------------------------+\n| 6cc67add32286412efcab9d0e1675a43a5c2ef3cec8879f81516ff83 |\n+----------------------------------------------------------+\n\nSELECT SHA2('Maria',256);\n+------------------------------------------------------------------+\n| SHA2('Maria',256) |\n+------------------------------------------------------------------+\n| 9ff18ebe7449349f358e3af0b57cf7a032c1c6b2272cb2656ff85eb112232f16 |\n+------------------------------------------------------------------+\n\nSELECT SHA2('Maria',0);\n+------------------------------------------------------------------+\n| SHA2('Maria',0) |\n+------------------------------------------------------------------+\n| 9ff18ebe7449349f358e3af0b57cf7a032c1c6b2272cb2656ff85eb112232f16 |\n+------------------------------------------------------------------+\n\nURL: https://mariadb.com/kb/en/sha2/ +[SIGN] +declaration=X +category=Numeric Functions +description=Returns the sign of the argument as -1, 0, or 1, depending on whether X is\nnegative, zero, or positive.\n\nExamples\n--------\n\nSELECT SIGN(-32);\n+-----------+\n| SIGN(-32) |\n+-----------+\n| -1 |\n+-----------+\n\nSELECT SIGN(0);\n+---------+\n| SIGN(0) |\n+---------+\n| 0 |\n+---------+\n\nSELECT SIGN(234);\n+-----------+\n| SIGN(234) |\n+-----------+\n| 1 |\n+-----------+\n\nURL: https://mariadb.com/kb/en/sign/ +[SIN] +declaration=X +category=Numeric Functions +description=Returns the sine of X, where X is given in radians.\n\nExamples\n--------\n\nSELECT SIN(1.5707963267948966);\n+-------------------------+\n| SIN(1.5707963267948966) |\n+-------------------------+\n| 1 |\n+-------------------------+\n\nSELECT SIN(PI());\n+----------------------+\n| SIN(PI()) |\n+----------------------+\n| 1.22460635382238e-16 |\n+----------------------+\n\nSELECT ROUND(SIN(PI()));\n+------------------+\n| ROUND(SIN(PI())) |\n+------------------+\n| 0 |\n+------------------+\n\nURL: https://mariadb.com/kb/en/sin/ +[SLEEP] +declaration=duration +category=Miscellaneous Functions +description=Sleeps (pauses) for the number of seconds given by the duration argument, then\nreturns 0. If SLEEP() is interrupted, it returns 1. The duration may have a\nfractional part given in microseconds.\n\nStatements using the SLEEP() function are not safe for statement-based\nreplication.\n\nExample\n-------\n\nSELECT SLEEP(5.5);\n+------------+\n| SLEEP(5.5) |\n+------------+\n| 0 |\n+------------+\n1 row in set (5.50 sec)\n\nURL: https://mariadb.com/kb/en/sleep/ +[SMALLINT] +declaration=M +category=Data Types +description=A small integer. The signed range is -32768 to 32767. The unsigned range is 0\nto 65535.\n\nIf a column has been set to ZEROFILL, all values will be prepended by zeros so\nthat the SMALLINT value contains a number of M digits.\n\nNote: If the ZEROFILL attribute has been specified, the column will\nautomatically become UNSIGNED.\n\nINT2 is a synonym for SMALLINT.\n\nFor more details on the attributes, see Numeric Data Type Overview.\n\nExamples\n--------\n\nCREATE TABLE smallints (a SMALLINT,b SMALLINT UNSIGNED,c SMALLINT ZEROFILL);\n\nWith strict_mode set, the default from MariaDB 10.2.4:\n\nINSERT INTO smallints VALUES (-10,-10,-10);\nERROR 1264 (22003): Out of range value for column 'b' at row 1\n\nINSERT INTO smallints VALUES (-10,10,-10);\nERROR 1264 (22003): Out of range value for column 'c' at row 1\n\nINSERT INTO smallints VALUES (-10,10,10);\n\nINSERT INTO smallints VALUES (32768,32768,32768);\nERROR 1264 (22003): Out of range value for column 'a' at row 1\n\nINSERT INTO smallints VALUES (32767,32768,32768);\n\nSELECT * FROM smallints;\n+-------+-------+-------+\n| a | b | c |\n+-------+-------+-------+\n| -10 | 10 | 00010 |\n| 32767 | 32768 | 32768 |\n+-------+-------+-------+\n\nWith strict_mode unset, the default until MariaDB 10.2.3:\n\nINSERT INTO smallints VALUES (-10,-10,-10);\nQuery OK, 1 row affected, 2 warnings (0.09 sec)\nWarning (Code 1264): Out of range value for column 'b' at row 1\nWarning (Code 1264): Out of range value for column 'c' at row 1\n\nINSERT INTO smallints VALUES (-10,10,-10);\nQuery OK, 1 row affected, 1 warning (0.08 sec)\n ... +[SOUNDEX] +declaration=str +category=String Functions +description=Returns a soundex string from str. Two strings that sound almost the same\nshould have identical soundex strings. A standard soundex string is four\ncharacters long, but the SOUNDEX() function returns an arbitrarily long\nstring. You can use SUBSTRING() on the result to get a standard soundex\nstring. All non-alphabetic characters in str are ignored. All international\nalphabetic characters outside the A-Z range are treated as vowels.\n\nImportant: When using SOUNDEX(), you should be aware of the following details:\n\n* This function, as currently implemented, is intended to work well with\n strings that are in the English language only. Strings in other languages may\n not produce reasonable results.\n\n* This function implements the original Soundex algorithm, not the more\npopular enhanced version (also described by D. Knuth). The difference is that\noriginal version discards vowels first and duplicates second, whereas the\nenhanced version discards duplicates first and vowels second.\n\nExamples\n--------\n\nSOUNDEX('Hello');\n+------------------+\n| SOUNDEX('Hello') |\n+------------------+\n| H400 |\n+------------------+\n\nSELECT SOUNDEX('MariaDB');\n+--------------------+\n| SOUNDEX('MariaDB') |\n+--------------------+\n| M631 |\n+--------------------+\n\nSELECT SOUNDEX('Knowledgebase');\n+--------------------------+\n| SOUNDEX('Knowledgebase') |\n+--------------------------+\n| K543212 |\n+--------------------------+\n\nSELECT givenname, surname FROM users WHERE SOUNDEX(givenname) =\nSOUNDEX("robert");\n+-----------+---------+\n| givenname | surname |\n+-----------+---------+\n| Roberto | Castro |\n+-----------+---------+\n\nURL: https://mariadb.com/kb/en/soundex/ +[SPACE] +declaration=N +category=String Functions +description=Returns a string consisting of N space characters. If N is NULL, returns NULL.\n\nExamples\n--------\n\nSELECT QUOTE(SPACE(6));\n+-----------------+\n| QUOTE(SPACE(6)) |\n+-----------------+\n| ' ' |\n+-----------------+\n\nURL: https://mariadb.com/kb/en/space/ +[SPIDER_BG_DIRECT_SQL] +declaration='sql', 'tmp_table_list', 'parameters' +category=Spider Functions +description=Executes the given SQL statement in the background on the remote server, as\ndefined in the parameters listing. If the query returns a result-set, it\nsttores the results in the given temporary table. When the given SQL statement\nexecutes successfully, this function returns the number of called UDF's. It\nreturns 0 when the given SQL statement fails.\n\nThis function is a UDF installed with the Spider storage engine.\n\nExamples\n--------\n\nSELECT SPIDER_BG_DIRECT_SQL('SELECT * FROM example_table', '', \n 'srv "node1", port "8607"') AS "Direct Query";\n+--------------+\n| Direct Query | \n+--------------+\n| 1 |\n+--------------+\n\nParameters\n----------\n\nerror_rw_mode\n-------------\n\n* Description: Returns empty results on network error.\n0 : Return error on getting network error.\n1: Return 0 records on getting network error.\n\n* Default Table Value: 0\n* DSN Parameter Name: erwm\n\nURL: https://mariadb.com/kb/en/spider_bg_direct_sql/ +[SPIDER_COPY_TABLES] +declaration=spider_table_name, source_link_id, destination_link_id_list [,parameters] +category=Spider Functions +description=A UDF installed with the Spider Storage Engine, this function copies table\ndata from source_link_id to destination_link_id_list. The service does not\nneed to be stopped in order to copy.\n\nIf the Spider table is partitioned, the name must be of the format\ntable_name#P#partition_name. The partition name can be viewed in the\nmysql.spider_tables table, for example:\n\nSELECT table_name FROM mysql.spider_tables;\n+-------------+\n| table_name |\n+-------------+\n| spt_a#P#pt1 |\n| spt_a#P#pt2 |\n| spt_a#P#pt3 |\n+-------------+\n\nReturns 1 if the data was copied successfully, or 0 if copying the data failed.\n\nURL: https://mariadb.com/kb/en/spider_copy_tables/ +[SPIDER_DIRECT_SQL] +declaration='sql', 'tmp_table_list', 'parameters' +category=Spider Functions +description=A UDF installed with the Spider Storage Engine, this function is used to\nexecute the SQL string sql on the remote server, as defined in parameters. If\nany resultsets are returned, they are stored in the tmp_table_list.\n\nThe function returns 1 if the SQL executes successfully, or 0 if it fails.\n\nExamples\n--------\n\nSELECT SPIDER_DIRECT_SQL('SELECT * FROM s', '', 'srv "node1", port "8607"');\n+----------------------------------------------------------------------+\n| SPIDER_DIRECT_SQL('SELECT * FROM s', '', 'srv "node1", port "8607"') |\n+----------------------------------------------------------------------+\n| 1 |\n+----------------------------------------------------------------------+\n\nURL: https://mariadb.com/kb/en/spider_direct_sql/ +[SPIDER_FLUSH_TABLE_MON_CACHE] +declaration= +category=Spider Functions +description=A UDF installed with the Spider Storage Engine, this function is used for\nrefreshing monitoring server information. It returns a value of 1.\n\nExamples\n--------\n\nSELECT SPIDER_FLUSH_TABLE_MON_CACHE();\n+--------------------------------+\n| SPIDER_FLUSH_TABLE_MON_CACHE() |\n+--------------------------------+\n| 1 |\n+--------------------------------+\n\nURL: https://mariadb.com/kb/en/spider_flush_table_mon_cache/ +[SQRT] +declaration=X +category=Numeric Functions +description=Returns the square root of X. If X is negative, NULL is returned.\n\nExamples\n--------\n\nSELECT SQRT(4);\n+---------+\n| SQRT(4) |\n+---------+\n| 2 |\n+---------+\n\nSELECT SQRT(20);\n+------------------+\n| SQRT(20) |\n+------------------+\n| 4.47213595499958 |\n+------------------+\n\nSELECT SQRT(-16);\n+-----------+\n| SQRT(-16) |\n+-----------+\n| NULL |\n+-----------+\n\nSELECT SQRT(1764);\n+------------+\n| SQRT(1764) |\n+------------+\n| 42 |\n+------------+\n\nURL: https://mariadb.com/kb/en/sqrt/ +[STD] +declaration=expr +category=Functions and Modifiers for Use with GROUP BY +description=Returns the population standard deviation of expr. This is an extension to\nstandard SQL. The standard SQL function STDDEV_POP() can be used instead.\n\nIt is an aggregate function, and so can be used with the GROUP BY clause.\n\nSTD() can be used as a window function.\n\nThis function returns NULL if there were no matching rows.\n\nExamples\n--------\n\nAs an aggregate function:\n\nCREATE OR REPLACE TABLE stats (category VARCHAR(2), x INT);\n\nINSERT INTO stats VALUES \n ('a',1),('a',2),('a',3),\n ('b',11),('b',12),('b',20),('b',30),('b',60);\n\nSELECT category, STDDEV_POP(x), STDDEV_SAMP(x), VAR_POP(x) \n FROM stats GROUP BY category;\n+----------+---------------+----------------+------------+\n| category | STDDEV_POP(x) | STDDEV_SAMP(x) | VAR_POP(x) |\n+----------+---------------+----------------+------------+\n| a | 0.8165 | 1.0000 | 0.6667 |\n| b | 18.0400 | 20.1693 | 325.4400 |\n+----------+---------------+----------------+------------+\n\nAs a window function:\n\nCREATE OR REPLACE TABLE student_test (name CHAR(10), test CHAR(10), score\nTINYINT);\n\nINSERT INTO student_test VALUES \n ('Chun', 'SQL', 75), ('Chun', 'Tuning', 73),\n ('Esben', 'SQL', 43), ('Esben', 'Tuning', 31),\n ('Kaolin', 'SQL', 56), ('Kaolin', 'Tuning', 88),\n ('Tatiana', 'SQL', 87);\n\nSELECT name, test, score, STDDEV_POP(score) \n OVER (PARTITION BY test) AS stddev_results FROM student_test;\n+---------+--------+-------+----------------+\n| name | test | score | stddev_results |\n+---------+--------+-------+----------------+\n| Chun | SQL | 75 | 16.9466 |\n| Chun | Tuning | 73 | 24.1247 |\n| Esben | SQL | 43 | 16.9466 |\n| Esben | Tuning | 31 | 24.1247 |\n| Kaolin | SQL | 56 | 16.9466 |\n ... +[STDDEV] +declaration=expr +category=Functions and Modifiers for Use with GROUP BY +description=Returns the population standard deviation of expr. This function is provided\nfor compatibility with Oracle. The standard SQL function STDDEV_POP() can be\nused instead.\n\nIt is an aggregate function, and so can be used with the GROUP BY clause.\n\nSTDDEV() can be used as a window function.\n\nThis function returns NULL if there were no matching rows.\n\nExamples\n--------\n\nAs an aggregate function:\n\nCREATE OR REPLACE TABLE stats (category VARCHAR(2), x INT);\n\nINSERT INTO stats VALUES \n ('a',1),('a',2),('a',3),\n ('b',11),('b',12),('b',20),('b',30),('b',60);\n\nSELECT category, STDDEV_POP(x), STDDEV_SAMP(x), VAR_POP(x) \n FROM stats GROUP BY category;\n+----------+---------------+----------------+------------+\n| category | STDDEV_POP(x) | STDDEV_SAMP(x) | VAR_POP(x) |\n+----------+---------------+----------------+------------+\n| a | 0.8165 | 1.0000 | 0.6667 |\n| b | 18.0400 | 20.1693 | 325.4400 |\n+----------+---------------+----------------+------------+\n\nAs a window function:\n\nCREATE OR REPLACE TABLE student_test (name CHAR(10), test CHAR(10), score\nTINYINT);\n\nINSERT INTO student_test VALUES \n ('Chun', 'SQL', 75), ('Chun', 'Tuning', 73),\n ('Esben', 'SQL', 43), ('Esben', 'Tuning', 31),\n ('Kaolin', 'SQL', 56), ('Kaolin', 'Tuning', 88),\n ('Tatiana', 'SQL', 87);\n\nSELECT name, test, score, STDDEV_POP(score) \n OVER (PARTITION BY test) AS stddev_results FROM student_test;\n+---------+--------+-------+----------------+\n| name | test | score | stddev_results |\n+---------+--------+-------+----------------+\n| Chun | SQL | 75 | 16.9466 |\n| Chun | Tuning | 73 | 24.1247 |\n| Esben | SQL | 43 | 16.9466 |\n| Esben | Tuning | 31 | 24.1247 |\n ... +[STDDEV_POP] +declaration=expr +category=Functions and Modifiers for Use with GROUP BY +description=Returns the population standard deviation of expr (the square root of\nVAR_POP()). You can also use STD() or STDDEV(), which are equivalent but not\nstandard SQL.\n\nIt is an aggregate function, and so can be used with the GROUP BY clause.\n\nSTDDEV_POP() can be used as a window function.\n\nSTDDEV_POP() returns NULL if there were no matching rows.\n\nExamples\n--------\n\nAs an aggregate function:\n\nCREATE OR REPLACE TABLE stats (category VARCHAR(2), x INT);\n\nINSERT INTO stats VALUES \n ('a',1),('a',2),('a',3),\n ('b',11),('b',12),('b',20),('b',30),('b',60);\n\nSELECT category, STDDEV_POP(x), STDDEV_SAMP(x), VAR_POP(x) \n FROM stats GROUP BY category;\n+----------+---------------+----------------+------------+\n| category | STDDEV_POP(x) | STDDEV_SAMP(x) | VAR_POP(x) |\n+----------+---------------+----------------+------------+\n| a | 0.8165 | 1.0000 | 0.6667 |\n| b | 18.0400 | 20.1693 | 325.4400 |\n+----------+---------------+----------------+------------+\n\nAs a window function:\n\nCREATE OR REPLACE TABLE student_test (name CHAR(10), test CHAR(10), score\nTINYINT);\n\nINSERT INTO student_test VALUES \n ('Chun', 'SQL', 75), ('Chun', 'Tuning', 73),\n ('Esben', 'SQL', 43), ('Esben', 'Tuning', 31),\n ('Kaolin', 'SQL', 56), ('Kaolin', 'Tuning', 88),\n ('Tatiana', 'SQL', 87);\n\nSELECT name, test, score, STDDEV_POP(score) \n OVER (PARTITION BY test) AS stddev_results FROM student_test;\n+---------+--------+-------+----------------+\n| name | test | score | stddev_results |\n+---------+--------+-------+----------------+\n| Chun | SQL | 75 | 16.9466 |\n| Chun | Tuning | 73 | 24.1247 |\n| Esben | SQL | 43 | 16.9466 |\n| Esben | Tuning | 31 | 24.1247 |\n ... +[STDDEV_SAMP] +declaration=expr +category=Functions and Modifiers for Use with GROUP BY +description=Returns the sample standard deviation of expr (the square root of VAR_SAMP()).\n\nIt is an aggregate function, and so can be used with the GROUP BY clause.\n\nSTDDEV_SAMP() can be used as a window function.\n\nSTDDEV_SAMP() returns NULL if there were no matching rows.\n\nURL: https://mariadb.com/kb/en/stddev_samp/ +[STRCMP] +declaration=expr1,expr2 +category=String Functions +description=STRCMP() returns 0 if the strings are the same, -1 if the first argument is\nsmaller than the second according to the current sort order, and 1 if the\nstrings are otherwise not the same. Returns NULL is either argument is NULL.\n\nExamples\n--------\n\nSELECT STRCMP('text', 'text2');\n+-------------------------+\n| STRCMP('text', 'text2') |\n+-------------------------+\n| -1 |\n+-------------------------+\n\nSELECT STRCMP('text2', 'text');\n+-------------------------+\n| STRCMP('text2', 'text') |\n+-------------------------+\n| 1 |\n+-------------------------+\n\nSELECT STRCMP('text', 'text');\n+------------------------+\n| STRCMP('text', 'text') |\n+------------------------+\n| 0 |\n+------------------------+\n\nURL: https://mariadb.com/kb/en/strcmp/ +[STR_TO_DATE] +declaration=str,format +category=Date and Time Functions +description=This is the inverse of the DATE_FORMAT() function. It takes a string str and a\nformat string format. STR_TO_DATE() returns a DATETIME value if the format\nstring contains both date and time parts, or a DATE or TIME value if the\nstring contains only date or time parts.\n\nThe date, time, or datetime values contained in str should be given in the\nformat indicated by format. If str contains an illegal date, time, or datetime\nvalue, STR_TO_DATE() returns NULL. An illegal value also produces a warning.\n\nUnder specific SQL_MODE settings an error may also be generated if the str\nisn't a valid date:\n\n* ALLOW_INVALID_DATES\n* NO_ZERO_DATE\n* NO_ZERO_IN_DATE\n\nThe options that can be used by STR_TO_DATE(), as well as its inverse\nDATE_FORMAT() and the FROM_UNIXTIME() function, are:\n\n+---------------------------+------------------------------------------------+\n| Option | Description |\n+---------------------------+------------------------------------------------+\n| %a | Short weekday name in current locale |\n| | (Variable lc_time_names). |\n+---------------------------+------------------------------------------------+\n| %b | Short form month name in current locale. For |\n| | locale en_US this is one of: |\n| | Jan,Feb,Mar,Apr,May,Jun,Jul,Aug,Sep,Oct,Nov |\n| | or Dec. |\n+---------------------------+------------------------------------------------+\n| %c | Month with 1 or 2 digits. |\n+---------------------------+------------------------------------------------+\n| %D | Day with English suffix 'th', 'nd', 'st' or |\n| | 'rd''. (1st, 2nd, 3rd...). |\n+---------------------------+------------------------------------------------+\n| %d | Day with 2 digits. |\n+---------------------------+------------------------------------------------+\n| %e | Day with 1 or 2 digits. |\n+---------------------------+------------------------------------------------+\n| %f | Microseconds 6 digits. |\n+---------------------------+------------------------------------------------+\n| %H | Hour with 2 digits between 00-23. |\n+---------------------------+------------------------------------------------+\n| %h | Hour with 2 digits between 01-12. |\n+---------------------------+------------------------------------------------+\n| %I | Hour with 2 digits between 01-12. |\n+---------------------------+------------------------------------------------+\n| %i | Minute with 2 digits. |\n+---------------------------+------------------------------------------------+\n| %j | Day of the year (001-366) |\n ... +[ST_AREA] +declaration=poly +category=Polygon Properties +description=Returns as a double-precision number the area of the Polygon value poly, as\nmeasured in its spatial reference system.\n\nST_Area() and Area() are synonyms.\n\nExamples\n--------\n\nSET @poly = 'Polygon((0 0,0 3,3 0,0 0),(1 1,1 2,2 1,1 1))';\n\nSELECT Area(GeomFromText(@poly));\n+---------------------------+\n| Area(GeomFromText(@poly)) |\n+---------------------------+\n| 4 |\n+---------------------------+\n\nURL: https://mariadb.com/kb/en/st_area/ +[ST_AsBinary] +declaration=g +category=WKB +description=Converts a value in internal geometry format to its WKB representation and\nreturns the binary result.\n\nST_AsBinary(), AsBinary(), ST_AsWKB() and AsWKB() are synonyms,\n\nExamples\n--------\n\nSET @poly = ST_GeomFromText('POLYGON((0 0,0 1,1 1,1 0,0 0))');\nSELECT ST_AsBinary(@poly);\n\nSELECT ST_AsText(ST_GeomFromWKB(ST_AsWKB(@poly)));\n+--------------------------------------------+\n| ST_AsText(ST_GeomFromWKB(ST_AsWKB(@poly))) |\n+--------------------------------------------+\n| POLYGON((0 0,0 1,1 1,1 0,0 0)) |\n+--------------------------------------------+\n\nURL: https://mariadb.com/kb/en/st_asbinary/ +[ST_AsGeoJSON] +declaration=g[, max_decimals[, options]] +category=GeoJSON +description=Returns the given geometry g as a GeoJSON element. The optional max_decimals\nlimits the maximum number of decimals displayed.\n\nThe optional options flag can be set to 1 to add a bounding box to the output.\n\nExamples\n--------\n\nSELECT ST_AsGeoJSON(ST_GeomFromText('POINT(5.3 7.2)'));\n+-------------------------------------------------+\n| ST_AsGeoJSON(ST_GeomFromText('POINT(5.3 7.2)')) |\n+-------------------------------------------------+\n| {"type": "Point", "coordinates": [5.3, 7.2]} |\n+-------------------------------------------------+\n\nURL: https://mariadb.com/kb/en/geojson-st_asgeojson/ +[ST_AsText] +declaration=g +category=WKT +description=Converts a value in internal geometry format to its WKT representation and\nreturns the string result.\n\nST_AsText(), AsText(), ST_AsWKT() and AsWKT() are all synonyms.\n\nExamples\n--------\n\nSET @g = 'LineString(1 1,4 4,6 6)';\n\nSELECT ST_AsText(ST_GeomFromText(@g));\n+--------------------------------+\n| ST_AsText(ST_GeomFromText(@g)) |\n+--------------------------------+\n| LINESTRING(1 1,4 4,6 6) |\n+--------------------------------+\n\nURL: https://mariadb.com/kb/en/st_astext/ +[ST_BOUNDARY] +declaration=g +category=Geometry Properties +description=Returns a geometry that is the closure of the combinatorial boundary of the\ngeometry value g.\n\nBOUNDARY() is a synonym.\n\nExamples\n--------\n\nSELECT ST_AsText(ST_Boundary(ST_GeomFromText('LINESTRING(3 3,0 0, -3 3)')));\n+----------------------------------------------------------------------+\n| ST_AsText(ST_Boundary(ST_GeomFromText('LINESTRING(3 3,0 0, -3 3)'))) |\n+----------------------------------------------------------------------+\n| MULTIPOINT(3 3,-3 3) |\n+----------------------------------------------------------------------+\n\nSELECT ST_AsText(ST_Boundary(ST_GeomFromText('POLYGON((3 3,0 0, -3 3, 3\n3))')));\n+--------------------------------------------------------------------------+\n| ST_AsText(ST_Boundary(ST_GeomFromText('POLYGON((3 3,0 0, -3 3, 3 3))'))) |\n+--------------------------------------------------------------------------+\n| LINESTRING(3 3,0 0,-3 3,3 3) |\n+--------------------------------------------------------------------------+\n\nURL: https://mariadb.com/kb/en/st_boundary/ +[ST_BUFFER] +declaration=g1,r +category=Geometry Constructors +description=Returns a geometry that represents all points whose distance from geometry g1\nis less than or equal to distance, or radius, r.\n\nUses for this function could include creating for example a new geometry\nrepresenting a buffer zone around an island.\n\nBUFFER() is a synonym.\n\nExamples\n--------\n\nDetermining whether a point is within a buffer zone:\n\nSET @g1 = ST_GEOMFROMTEXT('POLYGON((10 10, 10 20, 20 20, 20 10, 10 10))');\n\nSET @g2 = ST_GEOMFROMTEXT('POINT(8 8)');\n\nSELECT ST_WITHIN(@g2,ST_BUFFER(@g1,5));\n+---------------------------------+\n| ST_WITHIN(@g2,ST_BUFFER(@g1,5)) |\n+---------------------------------+\n| 1 |\n+---------------------------------+\n\nSELECT ST_WITHIN(@g2,ST_BUFFER(@g1,1));\n+---------------------------------+\n| ST_WITHIN(@g2,ST_BUFFER(@g1,1)) |\n+---------------------------------+\n| 0 |\n+---------------------------------+\n\nURL: https://mariadb.com/kb/en/st_buffer/ +[ST_CENTROID] +declaration=mpoly +category=Polygon Properties +description=Returns a point reflecting the mathematical centroid (geometric center) for\nthe MultiPolygon mpoly. The resulting point will not necessarily be on the\nMultiPolygon.\n\nST_Centroid() and Centroid() are synonyms.\n\nExamples\n--------\n\nSET @poly = ST_GeomFromText('POLYGON((0 0,20 0,20 20,0 20,0 0))');\nSELECT ST_AsText(ST_Centroid(@poly)) AS center;\n+--------------+\n| center |\n+--------------+\n| POINT(10 10) |\n+--------------+\n\nURL: https://mariadb.com/kb/en/st_centroid/ +[ST_CONTAINS] +declaration=g1,g2 +category=Geometry Relations +description=Returns 1 or 0 to indicate whether a geometry g1 completely contains geometry\ng2.\n\nST_CONTAINS() uses object shapes, while CONTAINS(), based on the original\nMySQL implementation, uses object bounding rectangles.\n\nST_CONTAINS tests the opposite relationship to ST_WITHIN().\n\nExamples\n--------\n\nSET @g1 = ST_GEOMFROMTEXT('POLYGON((175 150, 20 40, 50 60, 125 100, 175\n150))');\n\nSET @g2 = ST_GEOMFROMTEXT('POINT(174 149)');\n\nSELECT ST_CONTAINS(@g1,@g2);\n+----------------------+\n| ST_CONTAINS(@g1,@g2) |\n+----------------------+\n| 1 |\n+----------------------+\n\nSET @g2 = ST_GEOMFROMTEXT('POINT(175 151)');\n\nSELECT ST_CONTAINS(@g1,@g2);\n+----------------------+\n| ST_CONTAINS(@g1,@g2) |\n+----------------------+\n| 0 |\n+----------------------+\n\nURL: https://mariadb.com/kb/en/st-contains/ +[ST_CONVEXHULL] +declaration= +category=Geometry Constructors +description=Given a geometry, returns a geometry that is the minimum convex geometry\nenclosing all geometries within the set. Returns NULL if the geometry value is\nNULL or an empty value.\n\nST_ConvexHull() and ConvexHull() are synonyms.\n\nExamples\n--------\n\nThe ConvexHull of a single point is simply the single point:\n\nSET @g = ST_GEOMFROMTEXT('Point(0 0)');\n\nSELECT ST_ASTEXT(ST_CONVEXHULL(@g));\n+------------------------------+\n| ST_ASTEXT(ST_CONVEXHULL(@g)) |\n+------------------------------+\n| POINT(0 0) |\n+------------------------------+\n\nSET @g = ST_GEOMFROMTEXT('MultiPoint(0 0, 1 2, 2 3)');\n\nSELECT ST_ASTEXT(ST_CONVEXHULL(@g));\n+------------------------------+\n| ST_ASTEXT(ST_CONVEXHULL(@g)) |\n+------------------------------+\n| POLYGON((0 0,1 2,2 3,0 0)) |\n+------------------------------+\n\nSET @g = ST_GEOMFROMTEXT('MultiPoint( 1 1, 2 2, 5 3, 7 2, 9 3, 8 4, 6 6, 6 9,\n4 9, 1 5 )');\n\nSELECT ST_ASTEXT(ST_CONVEXHULL(@g));\n+----------------------------------------+\n| ST_ASTEXT(ST_CONVEXHULL(@g)) |\n+----------------------------------------+\n| POLYGON((1 1,1 5,4 9,6 9,9 3,7 2,1 1)) |\n+----------------------------------------+\n\nURL: https://mariadb.com/kb/en/st_convexhull/ +[ST_CROSSES] +declaration=g1,g2 +category=Geometry Relations +description=Returns 1 if geometry g1 spatially crosses geometry g2. Returns NULL if g1 is\na Polygon or a MultiPolygon, or if g2 is a Point or a MultiPoint. Otherwise,\nreturns 0.\n\nThe term spatially crosses denotes a spatial relation between two given\ngeometries that has the following properties:\n\n* The two geometries intersect\n* Their intersection results in a geometry that has a dimension that is one\n less than the maximum dimension of the two given geometries\n* Their intersection is not equal to either of the two given geometries\n\nST_CROSSES() uses object shapes, while CROSSES(), based on the original MySQL\nimplementation, uses object bounding rectangles.\n\nExamples\n--------\n\nSET @g1 = ST_GEOMFROMTEXT('LINESTRING(174 149, 176 151)');\n\nSET @g2 = ST_GEOMFROMTEXT('POLYGON((175 150, 20 40, 50 60, 125 100, 175\n150))');\n\nSELECT ST_CROSSES(@g1,@g2);\n+---------------------+\n| ST_CROSSES(@g1,@g2) |\n+---------------------+\n| 1 |\n+---------------------+\n\nSET @g1 = ST_GEOMFROMTEXT('LINESTRING(176 149, 176 151)');\n\nSELECT ST_CROSSES(@g1,@g2);\n+---------------------+\n| ST_CROSSES(@g1,@g2) |\n+---------------------+\n| 0 |\n+---------------------+\n\nURL: https://mariadb.com/kb/en/st-crosses/ +[ST_DIFFERENCE] +declaration=g1,g2 +category=Geometry Relations +description=Returns a geometry representing the point set difference of the given geometry\nvalues.\n\nExample\n-------\n\nSET @g1 = POINT(10,10), @g2 = POINT(20,20);\n\nSELECT ST_AsText(ST_Difference(@g1, @g2));\n+------------------------------------+\n| ST_AsText(ST_Difference(@g1, @g2)) |\n+------------------------------------+\n| POINT(10 10) |\n+------------------------------------+\n\nURL: https://mariadb.com/kb/en/st_difference/ +[ST_DIMENSION] +declaration=g +category=Geometry Properties +description=Returns the inherent dimension of the geometry value g. The result can be\n\n+------------------------------------+---------------------------------------+\n| Dimension | Definition |\n+------------------------------------+---------------------------------------+\n| -1 | empty geometry |\n+------------------------------------+---------------------------------------+\n| 0 | geometry with no length or area |\n+------------------------------------+---------------------------------------+\n| 1 | geometry with no area but nonzero |\n| | length |\n+------------------------------------+---------------------------------------+\n| 2 | geometry with nonzero area |\n+------------------------------------+---------------------------------------+\n\nST_Dimension() and Dimension() are synonyms.\n\nExamples\n--------\n\nSELECT Dimension(GeomFromText('LineString(1 1,2 2)'));\n+------------------------------------------------+\n| Dimension(GeomFromText('LineString(1 1,2 2)')) |\n+------------------------------------------------+\n| 1 |\n+------------------------------------------------+\n\nURL: https://mariadb.com/kb/en/st_dimension/ +[ST_DISJOINT] +declaration=g1,g2 +category=Geometry Relations +description=Returns 1 or 0 to indicate whether geometry g1 is spatially disjoint from\n(does not intersect with) geometry g2.\n\nST_DISJOINT() uses object shapes, while DISJOINT(), based on the original\nMySQL implementation, uses object bounding rectangles.\n\nST_DISJOINT() tests the opposite relationship to ST_INTERSECTS().\n\nExamples\n--------\n\nSET @g1 = ST_GEOMFROMTEXT('POINT(0 0)');\n\nSET @g2 = ST_GEOMFROMTEXT('LINESTRING(2 0, 0 2)');\n\nSELECT ST_DISJOINT(@g1,@g2);\n+----------------------+\n| ST_DISJOINT(@g1,@g2) |\n+----------------------+\n| 1 |\n+----------------------+\n\nSET @g2 = ST_GEOMFROMTEXT('LINESTRING(0 0, 0 2)');\n\nSELECT ST_DISJOINT(@g1,@g2);\n+----------------------+\n| ST_DISJOINT(@g1,@g2) |\n+----------------------+\n| 0 |\n+----------------------+\n\nURL: https://mariadb.com/kb/en/st_disjoint/ +[ST_DISTANCE] +declaration=g1,g2 +category=Geometry Relations +description=Returns the distance between two geometries, or null if not given valid inputs.\n\nExample\n-------\n\nSELECT ST_Distance(POINT(1,2),POINT(2,2));\n+------------------------------------+\n| ST_Distance(POINT(1,2),POINT(2,2)) |\n+------------------------------------+\n| 1 |\n+------------------------------------+\n\nURL: https://mariadb.com/kb/en/st_distance/ +[ST_DISTANCE_SPHERE] +declaration=g1,g2,[r] +category=Geometry Relations +description=Returns the spherical distance between two geometries (point or multipoint) on\na sphere with the optional radius r (default is the Earth radius if r is not\nspecified), or NULL if not given valid inputs.\n\nExample\n-------\n\nset @zenica = ST_GeomFromText('POINT(17.907743 44.203438)');\nset @sarajevo = ST_GeomFromText('POINT(18.413076 43.856258)');\nSELECT ST_Distance_Sphere(@zenica, @sarajevo);\n55878.59337591705\n\nURL: https://mariadb.com/kb/en/st_distance_sphere/ +[ST_ENDPOINT] +declaration=ls +category=LineString Properties +description=Returns the Point that is the endpoint of the LineString value ls.\n\nST_EndPoint() and EndPoint() are synonyms.\n\nExamples\n--------\n\nSET @ls = 'LineString(1 1,2 2,3 3)';\n\nSELECT AsText(EndPoint(GeomFromText(@ls)));\n+-------------------------------------+\n| AsText(EndPoint(GeomFromText(@ls))) |\n+-------------------------------------+\n| POINT(3 3) |\n+-------------------------------------+\n\nURL: https://mariadb.com/kb/en/st_endpoint/ +[ST_ENVELOPE] +declaration=g +category=Geometry Properties +description=Returns the Minimum Bounding Rectangle (MBR) for the geometry value g. The\nresult is returned as a Polygon value.\n\nThe polygon is defined by the corner points of the bounding box:\n\nPOLYGON((MINX MINY, MAXX MINY, MAXX MAXY, MINX MAXY, MINX MINY))\n\nST_ENVELOPE() and ENVELOPE() are synonyms.\n\nExamples\n--------\n\nSELECT AsText(ST_ENVELOPE(GeomFromText('LineString(1 1,4 4)')));\n+----------------------------------------------------------+\n| AsText(ST_ENVELOPE(GeomFromText('LineString(1 1,4 4)'))) |\n+----------------------------------------------------------+\n| POLYGON((1 1,4 1,4 4,1 4,1 1)) |\n+----------------------------------------------------------+\n\nURL: https://mariadb.com/kb/en/st_envelope/ +[ST_EQUALS] +declaration=g1,g2 +category=Geometry Relations +description=Returns 1 or 0 to indicate whether geometry g1 is spatially equal to geometry\ng2.\n\nST_EQUALS() uses object shapes, while EQUALS(), based on the original MySQL\nimplementation, uses object bounding rectangles.\n\nExamples\n--------\n\nSET @g1 = ST_GEOMFROMTEXT('LINESTRING(174 149, 176 151)');\n\nSET @g2 = ST_GEOMFROMTEXT('LINESTRING(176 151, 174 149)');\n\nSELECT ST_EQUALS(@g1,@g2);\n+--------------------+\n| ST_EQUALS(@g1,@g2) |\n+--------------------+\n| 1 |\n+--------------------+\n\nSET @g1 = ST_GEOMFROMTEXT('POINT(0 2)');\n\nSET @g1 = ST_GEOMFROMTEXT('POINT(2 0)');\n\nSELECT ST_EQUALS(@g1,@g2);\n+--------------------+\n| ST_EQUALS(@g1,@g2) |\n+--------------------+\n| 0 |\n+--------------------+\n\nURL: https://mariadb.com/kb/en/st-equals/ +[ST_ExteriorRing] +declaration=poly +category=Polygon Properties +description=Returns the exterior ring of the Polygon value poly as a LineString.\n\nST_ExteriorRing() and ExteriorRing() are synonyms.\n\nExamples\n--------\n\nSET @poly = 'Polygon((0 0,0 3,3 3,3 0,0 0),(1 1,1 2,2 2,2 1,1 1))';\n\nSELECT AsText(ExteriorRing(GeomFromText(@poly)));\n+-------------------------------------------+\n| AsText(ExteriorRing(GeomFromText(@poly))) |\n+-------------------------------------------+\n| LINESTRING(0 0,0 3,3 3,3 0,0 0) |\n+-------------------------------------------+\n\nURL: https://mariadb.com/kb/en/st_exteriorring/ +[ST_GEOMETRYN] +declaration=gc,N +category=Geometry Properties +description=Returns the N-th geometry in the GeometryCollection gc. Geometries are\nnumbered beginning with 1.\n\nST_GeometryN() and GeometryN() are synonyms.\n\nExample\n-------\n\nSET @gc = 'GeometryCollection(Point(1 1),LineString(12 14, 9 11))';\n\nSELECT AsText(GeometryN(GeomFromText(@gc),1));\n+----------------------------------------+\n| AsText(GeometryN(GeomFromText(@gc),1)) |\n+----------------------------------------+\n| POINT(1 1) |\n+----------------------------------------+\n\nURL: https://mariadb.com/kb/en/st_geometryn/ +[ST_GEOMETRYTYPE] +declaration=g +category=Geometry Properties +description=Returns as a string the name of the geometry type of which the geometry\ninstance g is a member. The name corresponds to one of the instantiable\nGeometry subclasses.\n\nST_GeometryType() and GeometryType() are synonyms.\n\nExamples\n--------\n\nSELECT GeometryType(GeomFromText('POINT(1 1)'));\n+------------------------------------------+\n| GeometryType(GeomFromText('POINT(1 1)')) |\n+------------------------------------------+\n| POINT |\n+------------------------------------------+\n\nURL: https://mariadb.com/kb/en/st_geometrytype/ +[ST_GeomCollFromText] +declaration=wkt[,srid] +category=WKT +description=Constructs a GEOMETRYCOLLECTION value using its WKT representation and SRID.\n\nST_GeomCollFromText(), ST_GeometryCollectionFromText(), GeomCollFromText() and\nGeometryCollectionFromText() are all synonyms.\n\nExample\n-------\n\nCREATE TABLE gis_geometrycollection (g GEOMETRYCOLLECTION);\nSHOW FIELDS FROM gis_geometrycollection;\nINSERT INTO gis_geometrycollection VALUES\n (GeomCollFromText('GEOMETRYCOLLECTION(POINT(0 0), LINESTRING(0 0,10\n10))')),\n (GeometryFromWKB(AsWKB(GeometryCollection(Point(44, 6),\nLineString(Point(3, 6), Point(7, 9)))))),\n (GeomFromText('GeometryCollection()')),\n (GeomFromText('GeometryCollection EMPTY'));\n\nURL: https://mariadb.com/kb/en/st_geomcollfromtext/ +[ST_GeomCollFromWKB] +declaration=wkb[,srid] +category=WKB +description=Constructs a GEOMETRYCOLLECTION value using its WKB representation and SRID.\n\nST_GeomCollFromWKB(), ST_GeometryCollectionFromWKB(), GeomCollFromWKB() and\nGeometryCollectionFromWKB() are synonyms.\n\nExamples\n--------\n\nSET @g = ST_AsBinary(ST_GeomFromText('GEOMETRYCOLLECTION(\n POLYGON((5 5,10 5,10 10,5 5)),POINT(10 10))'));\n\nSELECT ST_AsText(ST_GeomCollFromWKB(@g));\n+----------------------------------------------------------------+\n| ST_AsText(ST_GeomCollFromWKB(@g)) |\n+----------------------------------------------------------------+\n| GEOMETRYCOLLECTION(POLYGON((5 5,10 5,10 10,5 5)),POINT(10 10)) |\n+----------------------------------------------------------------+\n\nURL: https://mariadb.com/kb/en/st_geomcollfromwkb/ +[ST_GeomFromGeoJSON] +declaration=g[, option] +category=GeoJSON +description=Given a GeoJSON input g, returns a geometry object. The option specifies what\nto do if g contains geometries with coordinate dimensions higher than 2.\n\n+---------------------------+------------------------------------------------+\n| Option | Description |\n+---------------------------+------------------------------------------------+\n| 1 | Return an error (the default) |\n+---------------------------+------------------------------------------------+\n| 2 - 4 | The document is accepted, but the coordinates |\n| | for higher coordinate dimensions are stripped |\n| | off. |\n+---------------------------+------------------------------------------------+\n\nNote that this function did not work correctly before MariaDB 10.2.8 - see\nMDEV-12180.\n\nExamples\n--------\n\nSET @j = '{ "type": "Point", "coordinates": [5.3, 15.0]}';\n\nSELECT ST_AsText(ST_GeomFromGeoJSON(@j));\n+-----------------------------------+\n| ST_AsText(ST_GeomFromGeoJSON(@j)) |\n+-----------------------------------+\n| POINT(5.3 15) |\n+-----------------------------------+\n\nURL: https://mariadb.com/kb/en/st_geomfromgeojson/ +[ST_GeomFromText] +declaration=wkt[,srid] +category=WKT +description=Constructs a geometry value of any type using its WKT representation and SRID.\n\nGeomFromText(), GeometryFromText(), ST_GeomFromText() and\nST_GeometryFromText() are all synonyms.\n\nExample\n-------\n\nSET @g = ST_GEOMFROMTEXT('POLYGON((1 1,1 5,4 9,6 9,9 3,7 2,1 1))');\n\nURL: https://mariadb.com/kb/en/st_geomfromtext/ +[ST_GeomFromWKB] +declaration=wkb[,srid] +category=WKB +description=Constructs a geometry value of any type using its WKB representation and SRID.\n\nST_GeomFromWKB(), ST_GeometryFromWKB(), GeomFromWKB() and GeometryFromWKB()\nare synonyms.\n\nExamples\n--------\n\nSET @g = ST_AsBinary(ST_LineFromText('LINESTRING(0 4, 4 6)'));\n\nSELECT ST_AsText(ST_GeomFromWKB(@g));\n+-------------------------------+\n| ST_AsText(ST_GeomFromWKB(@g)) |\n+-------------------------------+\n| LINESTRING(0 4,4 6) |\n+-------------------------------+\n\nURL: https://mariadb.com/kb/en/st_geomfromwkb/ +[ST_INTERSECTION] +declaration=g1,g2 +category=Geometry Constructors +description=Returns a geometry that is the intersection, or shared portion, of geometry g1\nand geometry g2.\n\nExamples\n--------\n\nSET @g1 = ST_GEOMFROMTEXT('POINT(2 1)');\n\nSET @g2 = ST_GEOMFROMTEXT('LINESTRING(2 1, 0 2)');\n\nSELECT ASTEXT(ST_INTERSECTION(@g1,@g2));\n+----------------------------------+\n| ASTEXT(ST_INTERSECTION(@g1,@g2)) |\n+----------------------------------+\n| POINT(2 1) |\n+----------------------------------+\n\nURL: https://mariadb.com/kb/en/st_intersection/ +[ST_INTERSECTS] +declaration=g1,g2 +category=Geometry Relations +description=Returns 1 or 0 to indicate whether geometry g1 spatially intersects geometry\ng2.\n\nST_INTERSECTS() uses object shapes, while INTERSECTS(), based on the original\nMySQL implementation, uses object bounding rectangles.\n\nST_INTERSECTS() tests the opposite relationship to ST_DISJOINT().\n\nExamples\n--------\n\nSET @g1 = ST_GEOMFROMTEXT('POINT(0 0)');\n\nSET @g2 = ST_GEOMFROMTEXT('LINESTRING(0 0, 0 2)');\n\nSELECT ST_INTERSECTS(@g1,@g2);\n+------------------------+\n| ST_INTERSECTS(@g1,@g2) |\n+------------------------+\n| 1 |\n+------------------------+\n\nSET @g2 = ST_GEOMFROMTEXT('LINESTRING(2 0, 0 2)');\n\nSELECT ST_INTERSECTS(@g1,@g2);\n+------------------------+\n| ST_INTERSECTS(@g1,@g2) |\n+------------------------+\n| 0 |\n+------------------------+\n\nURL: https://mariadb.com/kb/en/st-intersects/ +[ST_ISCLOSED] +declaration=g +category=Geometry Properties +description=Returns 1 if a given LINESTRING's start and end points are the same, or 0 if\nthey are not the same. Before MariaDB 10.1.5, returns NULL if not given a\nLINESTRING. After MariaDB 10.1.5, returns -1.\n\nST_IsClosed() and IsClosed() are synonyms.\n\nExamples\n--------\n\nSET @ls = 'LineString(0 0, 0 4, 4 4, 0 0)';\nSELECT ST_ISCLOSED(GEOMFROMTEXT(@ls));\n+--------------------------------+\n| ST_ISCLOSED(GEOMFROMTEXT(@ls)) |\n+--------------------------------+\n| 1 |\n+--------------------------------+\n\nSET @ls = 'LineString(0 0, 0 4, 4 4, 0 1)';\nSELECT ST_ISCLOSED(GEOMFROMTEXT(@ls));\n+--------------------------------+\n| ST_ISCLOSED(GEOMFROMTEXT(@ls)) |\n+--------------------------------+\n| 0 |\n+--------------------------------+\n\nURL: https://mariadb.com/kb/en/st_isclosed/ +[ST_ISEMPTY] +declaration=g +category=Geometry Properties +description=IsEmpty is a function defined by the OpenGIS specification, but is not fully\nimplemented by MariaDB or MySQL.\n\nSince MariaDB and MySQL do not support GIS EMPTY values such as POINT EMPTY,\nas implemented it simply returns 1 if the geometry value g is invalid, 0 if it\nis valid, and NULL if the argument is NULL.\n\nST_IsEmpty() and IsEmpty() are synonyms.\n\nURL: https://mariadb.com/kb/en/st_isempty/ +[ST_InteriorRingN] +declaration=poly,N +category=Polygon Properties +description=Returns the N-th interior ring for the Polygon value poly as a LineString.\nRings are numbered beginning with 1.\n\nST_InteriorRingN() and InteriorRingN() are synonyms.\n\nExamples\n--------\n\nSET @poly = 'Polygon((0 0,0 3,3 3,3 0,0 0),(1 1,1 2,2 2,2 1,1 1))';\n\nSELECT AsText(InteriorRingN(GeomFromText(@poly),1));\n+----------------------------------------------+\n| AsText(InteriorRingN(GeomFromText(@poly),1)) |\n+----------------------------------------------+\n| LINESTRING(1 1,1 2,2 2,2 1,1 1) |\n+----------------------------------------------+\n\nURL: https://mariadb.com/kb/en/st_interiorringn/ +[ST_IsRing] +declaration=g +category=Geometry Properties +description=Returns true if a given LINESTRING is a ring, that is, both ST_IsClosed and\nST_IsSimple. A simple curve does not pass through the same point more than\nonce. However, see MDEV-7510.\n\nSt_IsRing() and IsRing() are synonyms.\n\nURL: https://mariadb.com/kb/en/st_isring/ +[ST_IsSimple] +declaration=g +category=Geometry Properties +description=Returns true if the given Geometry has no anomalous geometric points, false if\nit does, or NULL if given a NULL value.\n\nST_IsSimple() and IsSimple() are synonyms.\n\nExamples\n--------\n\nA POINT is always simple.\n\nSET @g = 'Point(1 2)';\n\nSELECT ST_ISSIMPLE(GEOMFROMTEXT(@g));\n+-------------------------------+\n| ST_ISSIMPLE(GEOMFROMTEXT(@g)) |\n+-------------------------------+\n| 1 |\n+-------------------------------+\n\nURL: https://mariadb.com/kb/en/st_issimple/ +[ST_LENGTH] +declaration=ls +category=Geometry Relations +description=Returns as a double-precision number the length of the LineString value ls in\nits associated spatial reference.\n\nExamples\n--------\n\nSET @ls = 'LineString(1 1,2 2,3 3)';\n\nSELECT ST_LENGTH(ST_GeomFromText(@ls));\n+---------------------------------+\n| ST_LENGTH(ST_GeomFromText(@ls)) |\n+---------------------------------+\n| 2.82842712474619 |\n+---------------------------------+\n\nURL: https://mariadb.com/kb/en/st_length/ +[ST_LineFromText] +declaration=wkt[,srid] +category=WKT +description=Constructs a LINESTRING value using its WKT representation and SRID.\n\nST_LineFromText(), ST_LineStringFromText(), ST_LineFromText() and\nST_LineStringFromText() are all synonyms.\n\nExamples\n--------\n\nCREATE TABLE gis_line (g LINESTRING);\nSHOW FIELDS FROM gis_line;\nINSERT INTO gis_line VALUES\n (LineFromText('LINESTRING(0 0,0 10,10 0)')),\n (LineStringFromText('LINESTRING(10 10,20 10,20 20,10 20,10 10)')),\n (LineStringFromWKB(AsWKB(LineString(Point(10, 10), Point(40, 10)))));\n\nURL: https://mariadb.com/kb/en/st_linefromtext/ +[ST_LineFromWKB] +declaration=wkb[,srid] +category=WKB +description=Constructs a LINESTRING value using its WKB representation and SRID.\n\nST_LineFromWKB(), LineFromWKB(), ST_LineStringFromWKB(), and\nLineStringFromWKB() are synonyms.\n\nExamples\n--------\n\nSET @g = ST_AsBinary(ST_LineFromText('LineString(0 4,4 6)'));\n\nSELECT ST_AsText(ST_LineFromWKB(@g)) AS l;\n+---------------------+\n| l |\n+---------------------+\n| LINESTRING(0 4,4 6) |\n+---------------------+\n\nURL: https://mariadb.com/kb/en/st_linefromwkb/ +[ST_NUMGEOMETRIES] +declaration=gc +category=Geometry Properties +description=Returns the number of geometries in the GeometryCollection gc.\n\nST_NumGeometries() and NumGeometries() are synonyms.\n\nExample\n-------\n\nSET @gc = 'GeometryCollection(Point(1 1),LineString(2 2, 3 3))';\n\nSELECT NUMGEOMETRIES(GeomFromText(@gc));\n+----------------------------------+\n| NUMGEOMETRIES(GeomFromText(@gc)) |\n+----------------------------------+\n| 2 |\n+----------------------------------+\n\nURL: https://mariadb.com/kb/en/st_numgeometries/ +[ST_NUMPOINTS] +declaration=ls +category=LineString Properties +description=Returns the number of Point objects in the LineString value ls.\n\nST_NumPoints() and NumPoints() are synonyms.\n\nExamples\n--------\n\nSET @ls = 'LineString(1 1,2 2,3 3)';\n\nSELECT NumPoints(GeomFromText(@ls));\n+------------------------------+\n| NumPoints(GeomFromText(@ls)) |\n+------------------------------+\n| 3 |\n+------------------------------+\n\nURL: https://mariadb.com/kb/en/st_numpoints/ +[ST_NumInteriorRings] +declaration=poly +category=Polygon Properties +description=Returns an integer containing the number of interior rings in the Polygon\nvalue poly.\n\nNote that according the the OpenGIS standard, a POLYGON should have exactly\none ExteriorRing and all other rings should lie within that ExteriorRing and\nthus be the InteriorRings. Practically, however, some systems, including\nMariaDB's, permit polygons to have several 'ExteriorRings'. In the case of\nthere being multiple, non-overlapping exterior rings ST_NumInteriorRings()\nwill return 1.\n\nST_NumInteriorRings() and NumInteriorRings() are synonyms.\n\nExamples\n--------\n\nSET @poly = 'Polygon((0 0,0 3,3 3,3 0,0 0),(1 1,1 2,2 2,2 1,1 1))';\n\nSELECT NumInteriorRings(GeomFromText(@poly));\n+---------------------------------------+\n| NumInteriorRings(GeomFromText(@poly)) |\n+---------------------------------------+\n| 1 |\n+---------------------------------------+\n\nNon-overlapping 'polygon':\n\nSELECT ST_NumInteriorRings(ST_PolyFromText('POLYGON((0 0,10 0,10 10,0 10,0 0),\n (-1 -1,-5 -1,-5 -5,-1 -5,-1 -1))')) AS NumInteriorRings;\n+------------------+\n| NumInteriorRings |\n+------------------+\n| 1 |\n+------------------+\n\nURL: https://mariadb.com/kb/en/st_numinteriorrings/ +[ST_OVERLAPS] +declaration=g1,g2 +category=Geometry Relations +description=Returns 1 or 0 to indicate whether geometry g1 spatially overlaps geometry g2.\n\nThe term spatially overlaps is used if two geometries intersect and their\nintersection results in a geometry of the same dimension but not equal to\neither of the given geometries.\n\nST_OVERLAPS() uses object shapes, while OVERLAPS(), based on the original\nMySQL implementation, uses object bounding rectangles.\n\nURL: https://mariadb.com/kb/en/st-overlaps/ +[ST_POINTN] +declaration=ls,N +category=LineString Properties +description=Returns the N-th Point in the LineString value ls. Points are numbered\nbeginning with 1.\n\nST_PointN() and PointN() are synonyms.\n\nExamples\n--------\n\nSET @ls = 'LineString(1 1,2 2,3 3)';\n\nSELECT AsText(PointN(GeomFromText(@ls),2));\n+-------------------------------------+\n| AsText(PointN(GeomFromText(@ls),2)) |\n+-------------------------------------+\n| POINT(2 2) |\n+-------------------------------------+\n\nURL: https://mariadb.com/kb/en/st_pointn/ +[ST_POINTONSURFACE] +declaration= +category=Geometry Constructors +description=Given a geometry, returns a POINT guaranteed to intersect a surface. However,\nsee MDEV-7514.\n\nST_PointOnSurface() and PointOnSurface() are synonyms.\n\nURL: https://mariadb.com/kb/en/st_pointonsurface/ +[ST_PointFromText] +declaration=wkt[,srid] +category=WKT +description=Constructs a POINT value using its WKT representation and SRID.\n\nST_PointFromText() and PointFromText() are synonyms.\n\nExamples\n--------\n\nCREATE TABLE gis_point (g POINT);\nSHOW FIELDS FROM gis_point;\nINSERT INTO gis_point VALUES\n (PointFromText('POINT(10 10)')),\n (PointFromText('POINT(20 10)')),\n (PointFromText('POINT(20 20)')),\n (PointFromWKB(AsWKB(PointFromText('POINT(10 20)'))));\n\nURL: https://mariadb.com/kb/en/st_pointfromtext/ +[ST_PointFromWKB] +declaration=wkb[,srid] +category=WKB +description=Constructs a POINT value using its WKB representation and SRID.\n\nST_PointFromWKB() and PointFromWKB() are synonyms.\n\nExamples\n--------\n\nSET @g = ST_AsBinary(ST_PointFromText('POINT(0 4)'));\n\nSELECT ST_AsText(ST_PointFromWKB(@g)) AS p;\n+------------+\n| p |\n+------------+\n| POINT(0 4) |\n+------------+\n\nURL: https://mariadb.com/kb/en/st_pointfromwkb/ +[ST_PolyFromText] +declaration=wkt[,srid] +category=WKT +description=Constructs a POLYGON value using its WKT representation and SRID.\n\nST_PolyFromText(), ST_PolygonFromText(), PolyFromText() and\nST_PolygonFromText() are all synonyms.\n\nExamples\n--------\n\nCREATE TABLE gis_polygon (g POLYGON);\nINSERT INTO gis_polygon VALUES\n (PolygonFromText('POLYGON((10 10,20 10,20 20,10 20,10 10))')),\n (PolyFromText('POLYGON((0 0,50 0,50 50,0 50,0 0), (10 10,20 10,20 20,10\n20,10 10))'));\n\nURL: https://mariadb.com/kb/en/st_polyfromtext/ +[ST_PolyFromWKB] +declaration=wkb[,srid] +category=WKB +description=Constructs a POLYGON value using its WKB representation and SRID.\n\nST_PolyFromWKB(), ST_PolygonFromWKB(), PolyFromWKB() and PolygonFromWKB() are\nsynonyms.\n\nExamples\n--------\n\nSET @g = ST_AsBinary(ST_PolyFromText('POLYGON((1 1,1 5,4 9,6 9,9 3,7 2,1\n1))'));\n\nSELECT ST_AsText(ST_PolyFromWKB(@g)) AS p;\n+----------------------------------------+\n| p |\n+----------------------------------------+\n| POLYGON((1 1,1 5,4 9,6 9,9 3,7 2,1 1)) |\n+----------------------------------------+\n\nURL: https://mariadb.com/kb/en/st_polyfromwkb/ +[ST_RELATE] +declaration= +category=Geometry Properties +description=Returns true if Geometry g1 is spatially related to Geometryg2 by testing for\nintersections between the interior, boundary and exterior of the two\ngeometries as specified by the values in intersection matrix pattern i.\n\nURL: https://mariadb.com/kb/en/st_relate/ +[ST_SRID] +declaration=g +category=Geometry Properties +description=Returns an integer indicating the Spatial Reference System ID for the geometry\nvalue g.\n\nIn MariaDB, the SRID value is just an integer associated with the geometry\nvalue. All calculations are done assuming Euclidean (planar) geometry.\n\nST_SRID() and SRID() are synonyms.\n\nExamples\n--------\n\nSELECT SRID(GeomFromText('LineString(1 1,2 2)',101));\n+-----------------------------------------------+\n| SRID(GeomFromText('LineString(1 1,2 2)',101)) |\n+-----------------------------------------------+\n| 101 |\n+-----------------------------------------------+\n\nURL: https://mariadb.com/kb/en/st_srid/ +[ST_STARTPOINT] +declaration=ls +category=LineString Properties +description=Returns the Point that is the start point of the LineString value ls.\n\nST_StartPoint() and StartPoint() are synonyms.\n\nExamples\n--------\n\nSET @ls = 'LineString(1 1,2 2,3 3)';\n\nSELECT AsText(StartPoint(GeomFromText(@ls)));\n+---------------------------------------+\n| AsText(StartPoint(GeomFromText(@ls))) |\n+---------------------------------------+\n| POINT(1 1) |\n+---------------------------------------+\n\nURL: https://mariadb.com/kb/en/st_startpoint/ +[ST_SYMDIFFERENCE] +declaration=g1,g2 +category=Geometry Constructors +description=Returns a geometry that represents the portions of geometry g1 and geometry g2\nthat don't intersect.\n\nExamples\n--------\n\nSET @g1 = ST_GEOMFROMTEXT('LINESTRING(10 20, 10 40)');\n\nSET @g2 = ST_GEOMFROMTEXT('LINESTRING(10 15, 10 25)');\n\nSELECT ASTEXT(ST_SYMDIFFERENCE(@g1,@g2));\n+----------------------------------------------+\n| ASTEXT(ST_SYMDIFFERENCE(@g1,@g2)) |\n+----------------------------------------------+\n| MULTILINESTRING((10 15,10 20),(10 25,10 40)) |\n+----------------------------------------------+\n\nSET @g2 = ST_GeomFromText('LINESTRING(10 20, 10 41)');\n\nSELECT ASTEXT(ST_SYMDIFFERENCE(@g1,@g2));\n+-----------------------------------+\n| ASTEXT(ST_SYMDIFFERENCE(@g1,@g2)) |\n+-----------------------------------+\n| LINESTRING(10 40,10 41) |\n+-----------------------------------+\n\nURL: https://mariadb.com/kb/en/st_symdifference/ +[ST_TOUCHES] +declaration=g1,g2 +category=Geometry Relations +description=Returns 1 or 0 to indicate whether geometry g1 spatially touches geometry g2.\nTwo geometries spatially touch if the interiors of the geometries do not\nintersect, but the boundary of one of the geometries intersects either the\nboundary or the interior of the other.\n\nST_TOUCHES() uses object shapes, while TOUCHES(), based on the original MySQL\nimplementation, uses object bounding rectangles.\n\nExamples\n--------\n\nSET @g1 = ST_GEOMFROMTEXT('POINT(2 0)');\n\nSET @g2 = ST_GEOMFROMTEXT('LINESTRING(2 0, 0 2)');\n\nSELECT ST_TOUCHES(@g1,@g2);\n+---------------------+\n| ST_TOUCHES(@g1,@g2) |\n+---------------------+\n| 1 |\n+---------------------+\n\nSET @g1 = ST_GEOMFROMTEXT('POINT(2 1)');\n\nSELECT ST_TOUCHES(@g1,@g2);\n+---------------------+\n| ST_TOUCHES(@g1,@g2) |\n+---------------------+\n| 0 |\n+---------------------+\n\nURL: https://mariadb.com/kb/en/st-touches/ +[ST_UNION] +declaration=g1,g2 +category=Geometry Constructors +description=Returns a geometry that is the union of the geometry g1 and geometry g2.\n\nExamples\n--------\n\nSET @g1 = GEOMFROMTEXT('POINT (0 2)');\n\nSET @g2 = GEOMFROMTEXT('POINT (2 0)');\n\nSELECT ASTEXT(ST_UNION(@g1,@g2));\n+---------------------------+\n| ASTEXT(ST_UNION(@g1,@g2)) |\n+---------------------------+\n| MULTIPOINT(2 0,0 2) |\n+---------------------------+\n\nSET @g1 = GEOMFROMTEXT('POLYGON((0 0,0 3,3 3,3 0,0 0))');\n\nSET @g2 = GEOMFROMTEXT('POLYGON((2 2,4 2,4 4,2 4,2 2))');\n\nSELECT ASTEXT(ST_UNION(@g1,@g2));\n+------------------------------------------------+\n| ASTEXT(ST_UNION(@g1,@g2)) |\n+------------------------------------------------+\n| POLYGON((0 0,0 3,2 3,2 4,4 4,4 2,3 2,3 0,0 0)) |\n+------------------------------------------------+\n\nURL: https://mariadb.com/kb/en/st_union/ +[ST_WITHIN] +declaration=g1,g2 +category=Geometry Relations +description=Returns 1 or 0 to indicate whether geometry g1 is spatially within geometry g2.\n\nThis tests the opposite relationship as ST_CONTAINS().\n\nST_WITHIN() uses object shapes, while WITHIN(), based on the original MySQL\nimplementation, uses object bounding rectangles.\n\nExamples\n--------\n\nSET @g1 = ST_GEOMFROMTEXT('POINT(174 149)');\n\nSET @g2 = ST_GEOMFROMTEXT('POLYGON((175 150, 20 40, 50 60, 125 100, 175\n150))');\n\nSELECT ST_WITHIN(@g1,@g2);\n+--------------------+\n| ST_WITHIN(@g1,@g2) |\n+--------------------+\n| 1 |\n+--------------------+\n\nSET @g1 = ST_GEOMFROMTEXT('POINT(176 151)');\n\nSELECT ST_WITHIN(@g1,@g2);\n+--------------------+\n| ST_WITHIN(@g1,@g2) |\n+--------------------+\n| 0 |\n+--------------------+\n\nURL: https://mariadb.com/kb/en/st-within/ +[ST_X] +declaration=p +category=Point Properties +description=Returns the X-coordinate value for the point p as a double-precision number.\n\nST_X() and X() are synonyms.\n\nExamples\n--------\n\nSET @pt = 'Point(56.7 53.34)';\n\nSELECT X(GeomFromText(@pt));\n+----------------------+\n| X(GeomFromText(@pt)) |\n+----------------------+\n| 56.7 |\n+----------------------+\n\nURL: https://mariadb.com/kb/en/st_x/ +[ST_Y] +declaration=p +category=Point Properties +description=Returns the Y-coordinate value for the point p as a double-precision number.\n\nST_Y() and Y() are synonyms.\n\nExamples\n--------\n\nSET @pt = 'Point(56.7 53.34)';\n\nSELECT Y(GeomFromText(@pt));\n+----------------------+\n| Y(GeomFromText(@pt)) |\n+----------------------+\n| 53.34 |\n+----------------------+\n\nURL: https://mariadb.com/kb/en/st_y/ +[SUBDATE] +declaration=date,INTERVAL expr unit +category=Date and Time Functions +description=When invoked with the INTERVAL form of the second argument, SUBDATE() is a\nsynonym for DATE_SUB(). See Date and Time Units for a complete list of\npermitted units.\n\nThe second form allows the use of an integer value for days. In such cases, it\nis interpreted as the number of days to be subtracted from the date or\ndatetime expression expr.\n\nExamples\n--------\n\nSELECT DATE_SUB('2008-01-02', INTERVAL 31 DAY);\n+-----------------------------------------+\n| DATE_SUB('2008-01-02', INTERVAL 31 DAY) |\n+-----------------------------------------+\n| 2007-12-02 |\n+-----------------------------------------+\n\nSELECT SUBDATE('2008-01-02', INTERVAL 31 DAY);\n+----------------------------------------+\n| SUBDATE('2008-01-02', INTERVAL 31 DAY) |\n+----------------------------------------+\n| 2007-12-02 |\n+----------------------------------------+\n\nSELECT SUBDATE('2008-01-02 12:00:00', 31);\n+------------------------------------+\n| SUBDATE('2008-01-02 12:00:00', 31) |\n+------------------------------------+\n| 2007-12-02 12:00:00 |\n+------------------------------------+\n\nCREATE TABLE t1 (d DATETIME);\nINSERT INTO t1 VALUES\n ("2007-01-30 21:31:07"),\n ("1983-10-15 06:42:51"),\n ("2011-04-21 12:34:56"),\n ("2011-10-30 06:31:41"),\n ("2011-01-30 14:03:25"),\n ("2004-10-07 11:19:34");\n\nSELECT d, SUBDATE(d, 10) from t1;\n+---------------------+---------------------+\n| d | SUBDATE(d, 10) |\n+---------------------+---------------------+\n| 2007-01-30 21:31:07 | 2007-01-20 21:31:07 |\n| 1983-10-15 06:42:51 | 1983-10-05 06:42:51 |\n| 2011-04-21 12:34:56 | 2011-04-11 12:34:56 |\n| 2011-10-30 06:31:41 | 2011-10-20 06:31:41 |\n| 2011-01-30 14:03:25 | 2011-01-20 14:03:25 |\n ... +[SUBSTR] +declaration= +category=String Functions +description=URL: https://mariadb.com/kb/en/substr/ +[SUBSTRING] +declaration=str,pos +category=String Functions +description=The forms without a len argument return a substring from string str starting\nat position pos.\n\nThe forms with a len argument return a substring len characters long from\nstring str, starting at position pos.\n\nThe forms that use FROM are standard SQL syntax.\n\nIt is also possible to use a negative value for pos. In this case, the\nbeginning of the substring is pos characters from the end of the string,\nrather than the beginning. A negative value may be used for pos in any of the\nforms of this function.\n\nBy default, the position of the first character in the string from which the\nsubstring is to be extracted is reckoned as 1. For Oracle-compatibility, from\nMariaDB 10.3.3, when sql_mode is set to 'oracle', position zero is treated as\nposition 1 (although the first character is still reckoned as 1).\n\nIf any argument is NULL, returns NULL.\n\nExamples\n--------\n\nSELECT SUBSTRING('Knowledgebase',5);\n+------------------------------+\n| SUBSTRING('Knowledgebase',5) |\n+------------------------------+\n| ledgebase |\n+------------------------------+\n\nSELECT SUBSTRING('MariaDB' FROM 6);\n+-----------------------------+\n| SUBSTRING('MariaDB' FROM 6) |\n+-----------------------------+\n| DB |\n+-----------------------------+\n\nSELECT SUBSTRING('Knowledgebase',3,7);\n+--------------------------------+\n| SUBSTRING('Knowledgebase',3,7) |\n+--------------------------------+\n| owledge |\n+--------------------------------+\n\nSELECT SUBSTRING('Knowledgebase', -4);\n+--------------------------------+\n| SUBSTRING('Knowledgebase', -4) |\n+--------------------------------+\n| base |\n+--------------------------------+\n ... +[SUBSTRING_INDEX] +declaration=str,delim,count +category=String Functions +description=Returns the substring from string str before count occurrences of the\ndelimiter delim. If count is positive, everything to the left of the final\ndelimiter (counting from the left) is returned. If count is negative,\neverything to the right of the final delimiter (counting from the right) is\nreturned. SUBSTRING_INDEX() performs a case-sensitive match when searching for\ndelim.\n\nIf any argument is NULL, returns NULL.\n\nFor example\n\nSUBSTRING_INDEX('www.mariadb.org', '.', 2)\n\nmeans "Return all of the characters up to the 2nd occurrence of ."\n\nExamples\n--------\n\nSELECT SUBSTRING_INDEX('www.mariadb.org', '.', 2);\n+--------------------------------------------+\n| SUBSTRING_INDEX('www.mariadb.org', '.', 2) |\n+--------------------------------------------+\n| www.mariadb |\n+--------------------------------------------+\n\nSELECT SUBSTRING_INDEX('www.mariadb.org', '.', -2);\n+---------------------------------------------+\n| SUBSTRING_INDEX('www.mariadb.org', '.', -2) |\n+---------------------------------------------+\n| mariadb.org |\n+---------------------------------------------+\n\nURL: https://mariadb.com/kb/en/substring_index/ +[SUBTIME] +declaration=expr1,expr2 +category=Date and Time Functions +description=SUBTIME() returns expr1 - expr2 expressed as a value in the same format as\nexpr1. expr1 is a time or datetime expression, and expr2 is a time expression.\n\nExamples\n--------\n\nSELECT SUBTIME('2007-12-31 23:59:59.999999','1 1:1:1.000002');\n+--------------------------------------------------------+\n| SUBTIME('2007-12-31 23:59:59.999999','1 1:1:1.000002') |\n+--------------------------------------------------------+\n| 2007-12-30 22:58:58.999997 |\n+--------------------------------------------------------+\n\nSELECT SUBTIME('01:00:00.999999', '02:00:00.999998');\n+-----------------------------------------------+\n| SUBTIME('01:00:00.999999', '02:00:00.999998') |\n+-----------------------------------------------+\n| -00:59:59.999999 |\n+-----------------------------------------------+\n\nURL: https://mariadb.com/kb/en/subtime/ +[SUM] +declaration=[DISTINCT] expr +category=Functions and Modifiers for Use with GROUP BY +description=Returns the sum of expr. If the return set has no rows, SUM() returns NULL.\nThe DISTINCT keyword can be used to sum only the distinct values of expr.\n\nSUM() can be used as a window function, although not with the DISTINCT\nspecifier.\n\nExamples\n--------\n\nCREATE TABLE sales (sales_value INT);\nINSERT INTO sales VALUES(10),(20),(20),(40);\n\nSELECT SUM(sales_value) FROM sales;\n+------------------+\n| SUM(sales_value) |\n+------------------+\n| 90 |\n+------------------+\n\nSELECT SUM(DISTINCT(sales_value)) FROM sales;\n+----------------------------+\n| SUM(DISTINCT(sales_value)) |\n+----------------------------+\n| 70 |\n+----------------------------+\n\nCommonly, SUM is used with a GROUP BY clause:\n\nCREATE TABLE sales (name CHAR(10), month CHAR(10), units INT);\n\nINSERT INTO sales VALUES \n ('Chun', 'Jan', 75), ('Chun', 'Feb', 73),\n ('Esben', 'Jan', 43), ('Esben', 'Feb', 31),\n ('Kaolin', 'Jan', 56), ('Kaolin', 'Feb', 88),\n ('Tatiana', 'Jan', 87), ('Tatiana', 'Feb', 83);\n\nSELECT name, SUM(units) FROM sales GROUP BY name;\n+---------+------------+\n| name | SUM(units) |\n+---------+------------+\n| Chun | 148 |\n| Esben | 74 |\n| Kaolin | 144 |\n| Tatiana | 170 |\n+---------+------------+\n\nThe GROUP BY clause is required when using an aggregate function along with\nregular column data, otherwise the result will be a mismatch, as in the\nfollowing common type of mistake:\n\n ... +[SYSDATE] +declaration=[precision] +category=Date and Time Functions +description=Returns the current date and time as a value in 'YYYY-MM-DD HH:MM:SS' or\nYYYYMMDDHHMMSS.uuuuuu format, depending on whether the function is used in a\nstring or numeric context.\n\nThe optional precision determines the microsecond precision. See Microseconds\nin MariaDB.\n\nSYSDATE() returns the time at which it executes. This differs from the\nbehavior for NOW(), which returns a constant time that indicates the time at\nwhich the statement began to execute. (Within a stored routine or trigger,\nNOW() returns the time at which the routine or triggering statement began to\nexecute.)\n\nIn addition, changing the timestamp system variable with a SET timestamp\nstatement affects the value returned by NOW() but not by SYSDATE(). This means\nthat timestamp settings in the binary log have no effect on invocations of\nSYSDATE().\n\nBecause SYSDATE() can return different values even within the same statement,\nand is not affected by SET TIMESTAMP, it is non-deterministic and therefore\nunsafe for replication if statement-based binary logging is used. If that is a\nproblem, you can use row-based logging, or start the server with the mysqld\noption --sysdate-is-now to cause SYSDATE() to be an alias for NOW(). The\nnon-deterministic nature of SYSDATE() also means that indexes cannot be used\nfor evaluating expressions that refer to it, and that statements using the\nSYSDATE() function are unsafe for statement-based replication.\n\nExamples\n--------\n\nDifference between NOW() and SYSDATE():\n\nSELECT NOW(), SLEEP(2), NOW();\n+---------------------+----------+---------------------+\n| NOW() | SLEEP(2) | NOW() |\n+---------------------+----------+---------------------+\n| 2010-03-27 13:23:40 | 0 | 2010-03-27 13:23:40 |\n+---------------------+----------+---------------------+\n\nSELECT SYSDATE(), SLEEP(2), SYSDATE();\n+---------------------+----------+---------------------+\n| SYSDATE() | SLEEP(2) | SYSDATE() |\n+---------------------+----------+---------------------+\n| 2010-03-27 13:23:52 | 0 | 2010-03-27 13:23:54 |\n+---------------------+----------+---------------------+\n\nWith precision:\n\nSELECT SYSDATE(4);\n+--------------------------+\n ... +[SYSTEM_USER] +declaration= +category=Information Functions +description=SYSTEM_USER() is a synonym for USER().\n\nURL: https://mariadb.com/kb/en/system_user/ +[SYS_GUID] +declaration= +category=Miscellaneous Functions +description=Returns a 16-byte globally unique identifier (GUID), similar to the UUID\nfunction, but without the - character.\n\nExample\n-------\n\nSELECT SYS_GUID();\n+----------------------------------+\n| SYS_GUID() |\n+----------------------------------+\n| 2C574E45BA2811EBB265F859713E4BE4 |\n+----------------------------------+\n\nURL: https://mariadb.com/kb/en/sys_guid/ +[TAN] +declaration=X +category=Numeric Functions +description=Returns the tangent of X, where X is given in radians.\n\nExamples\n--------\n\nSELECT TAN(0.7853981633974483);\n+-------------------------+\n| TAN(0.7853981633974483) |\n+-------------------------+\n| 0.9999999999999999 |\n+-------------------------+\n\nSELECT TAN(PI());\n+-----------------------+\n| TAN(PI()) |\n+-----------------------+\n| -1.22460635382238e-16 |\n+-----------------------+\n\nSELECT TAN(PI()+1);\n+-----------------+\n| TAN(PI()+1) |\n+-----------------+\n| 1.5574077246549 |\n+-----------------+\n\nSELECT TAN(RADIANS(PI()));\n+--------------------+\n| TAN(RADIANS(PI())) |\n+--------------------+\n| 0.0548861508080033 |\n+--------------------+\n\nURL: https://mariadb.com/kb/en/tan/ +[TEXT] +declaration=M +category=Data Types +description=A TEXT column with a maximum length of 65,535 (216 - 1) characters. The\neffective maximum length is less if the value contains multi-byte characters.\nEach TEXT value is stored using a two-byte length prefix that indicates the\nnumber of bytes in the value. If you need a bigger storage, consider using\nMEDIUMTEXT instead.\n\nAn optional length M can be given for this type. If this is done, MariaDB\ncreates the column as the smallest TEXT type large enough to hold values M\ncharacters long.\n\nBefore MariaDB 10.2, all MariaDB collations were of type PADSPACE, meaning\nthat TEXT (as well as VARCHAR and CHAR values) are compared without regard for\ntrailing spaces. This does not apply to the LIKE pattern-matching operator,\nwhich takes into account trailing spaces.\n\nBefore MariaDB 10.2.1, BLOB and TEXT columns could not be assigned a DEFAULT\nvalue. This restriction was lifted in MariaDB 10.2.1.\n\nExamples\n--------\n\nTrailing spaces:\n\nCREATE TABLE strtest (d TEXT(10));\nINSERT INTO strtest VALUES('Maria ');\n\nSELECT d='Maria',d='Maria ' FROM strtest;\n+-----------+--------------+\n| d='Maria' | d='Maria ' |\n+-----------+--------------+\n| 1 | 1 |\n+-----------+--------------+\n\nSELECT d LIKE 'Maria',d LIKE 'Maria ' FROM strtest;\n+----------------+-------------------+\n| d LIKE 'Maria' | d LIKE 'Maria ' |\n+----------------+-------------------+\n| 0 | 1 |\n+----------------+-------------------+\n\nIndexing\n--------\n\nTEXT columns can only be indexed over a specified length. This means that they\ncannot be used as the primary key of a table norm until MariaDB 10.4, can a\nunique index be created on them.\n\nMariaDB starting with 10.4\n--------------------------\nStarting with MariaDB 10.4, a unique index can be created on a TEXT column.\n ... +[TIME] +declaration= +category=Data Types +description=A time. The range is '-838:59:59.999999' to '838:59:59.999999'. Microsecond\nprecision can be from 0-6; if not specified 0 is used. Microseconds have been\navailable since MariaDB 5.3.\n\nMariaDB displays TIME values in 'HH:MM:SS.ssssss' format, but allows\nassignment of times in looser formats, including 'D HH:MM:SS', 'HH:MM:SS',\n'HH:MM', 'D HH:MM', 'D HH', 'SS', or 'HHMMSS', as well as permitting dropping\nof any leading zeros when a delimiter is provided, for example '3:9:10'. For\ndetails, see date and time literals.\n\nMariaDB 10.1.2 introduced the --mysql56-temporal-format option, on by default,\nwhich allows MariaDB to store TIMEs using the same low-level format MySQL 5.6\nuses.\n\nInternal Format\n---------------\n\nIn MariaDB 10.1.2 a new temporal format was introduced from MySQL 5.6 that\nalters how the TIME, DATETIME and TIMESTAMP columns operate at lower levels.\nThese changes allow these temporal data types to have fractional parts and\nnegative values. You can disable this feature using the\nmysql56_temporal_format system variable.\n\nTables that include TIMESTAMP values that were created on an older version of\nMariaDB or that were created while the mysql56_temporal_format system variable\nwas disabled continue to store data using the older data type format.\n\nIn order to update table columns from the older format to the newer format,\nexecute an ALTER TABLE... MODIFY COLUMN statement that changes the column to\nthe *same* data type. This change may be needed if you want to export the\ntable's tablespace and import it onto a server that has\nmysql56_temporal_format=ON set (see MDEV-15225).\n\nFor instance, if you have a TIME column in your table:\n\nSHOW VARIABLES LIKE 'mysql56_temporal_format';\n\n+-------------------------+-------+\n| Variable_name | Value |\n+-------------------------+-------+\n| mysql56_temporal_format | ON |\n+-------------------------+-------+\n\nALTER TABLE example_table MODIFY ts_col TIME;\n\nWhen MariaDB executes the ALTER TABLE statement, it converts the data from the\nolder temporal format to the newer one.\n\nIn the event that you have several tables and columns using temporal data\ntypes that you want to switch over to the new format, make sure the system\n ... +[TIMEDIFF] +declaration=expr1,expr2 +category=Date and Time Functions +description=TIMEDIFF() returns expr1 - expr2 expressed as a time value. expr1 and expr2\nare time or date-and-time expressions, but both must be of the same type.\n\nExamples\n--------\n\nSELECT TIMEDIFF('2000:01:01 00:00:00', '2000:01:01 00:00:00.000001');\n+---------------------------------------------------------------+\n| TIMEDIFF('2000:01:01 00:00:00', '2000:01:01 00:00:00.000001') |\n+---------------------------------------------------------------+\n| -00:00:00.000001 |\n+---------------------------------------------------------------+\n\nSELECT TIMEDIFF('2008-12-31 23:59:59.000001', '2008-12-30 01:01:01.000002');\n+----------------------------------------------------------------------+\n| TIMEDIFF('2008-12-31 23:59:59.000001', '2008-12-30 01:01:01.000002') |\n+----------------------------------------------------------------------+\n| 46:58:57.999999 |\n+----------------------------------------------------------------------+\n\nURL: https://mariadb.com/kb/en/timediff/ +[TIMESTAMP] +declaration==3;\n+------+\n| i |\n+------+\n| 1 |\n| 2 |\n| 3 |\n| 4 |\n| 5 |\n| 6 |\n+------+\n\nSELECT i FROM seqs WHERE i <= 3 UNION ALL SELECT i FROM seqs WHERE i>=3;\n+------+\n ... +[UNIX_TIMESTAMP] +declaration= +category=Date and Time Functions +description=If called with no argument, returns a Unix timestamp (seconds since\n'1970-01-01 00:00:00' UTC) as an unsigned integer. If UNIX_TIMESTAMP() is\ncalled with a date argument, it returns the value of the argument as seconds\nsince '1970-01-01 00:00:00' UTC. date may be a DATE string, a DATETIME string,\na TIMESTAMP, or a number in the format YYMMDD or YYYYMMDD. The server\ninterprets date as a value in the current time zone and converts it to an\ninternal value in UTC. Clients can set their time zone as described in time\nzones.\n\nThe inverse function of UNIX_TIMESTAMP() is FROM_UNIXTIME()\n\nUNIX_TIMESTAMP() supports microseconds.\n\nTimestamps in MariaDB have a maximum value of 2147483647, equivalent to\n2038-01-19 05:14:07. This is due to the underlying 32-bit limitation. Using\nthe function on a date beyond this will result in NULL being returned. Use\nDATETIME as a storage type if you require dates beyond this.\n\nError Handling\n--------------\n\nReturns NULL for wrong arguments to UNIX_TIMESTAMP(). In MySQL and MariaDB\nbefore 5.3 wrong arguments to UNIX_TIMESTAMP() returned 0.\n\nCompatibility\n-------------\n\nAs you can see in the examples above, UNIX_TIMESTAMP(constant-date-string)\nreturns a timestamp with 6 decimals while MariaDB 5.2 and before returns it\nwithout decimals. This can cause a problem if you are using UNIX_TIMESTAMP()\nas a partitioning function. You can fix this by using\nFLOOR(UNIX_TIMESTAMP(..)) or changing the date string to a date number, like\n20080101000000.\n\nExamples\n--------\n\nSELECT UNIX_TIMESTAMP();\n+------------------+\n| UNIX_TIMESTAMP() |\n+------------------+\n| 1269711082 |\n+------------------+\n\nSELECT UNIX_TIMESTAMP('2007-11-30 10:30:19');\n+---------------------------------------+\n| UNIX_TIMESTAMP('2007-11-30 10:30:19') |\n+---------------------------------------+\n| 1196436619.000000 |\n+---------------------------------------+\n ... +[UPDATEXML] +declaration=xml_target, xpath_expr, new_xml +category=String Functions +description=This function replaces a single portion of a given fragment of XML markup\nxml_target with a new XML fragment new_xml, and then returns the changed XML.\nThe portion of xml_target that is replaced matches an XPath expression\nxpath_expr supplied by the user. If no expression matching xpath_expr is\nfound, or if multiple matches are found, the function returns the original\nxml_target XML fragment. All three arguments should be strings.\n\nExamples\n--------\n\nSELECT\n UpdateXML('ccc', '/a', 'fff') AS val1,\n UpdateXML('ccc', '/b', 'fff') AS val2,\n UpdateXML('ccc', '//b', 'fff') AS val3,\n UpdateXML('ccc', '/a/d', 'fff') AS val4,\n UpdateXML('ccc', '/a/d', 'fff') AS val5\n \G\n*************************** 1. row ***************************\nval1: fff\nval2: ccc\nval3: fff\nval4: cccfff\nval5: ccc\n1 row in set (0.00 sec)\n\nURL: https://mariadb.com/kb/en/updatexml/ +[UPPER] +declaration=str +category=String Functions +description=Returns the string str with all characters changed to uppercase according to\nthe current character set mapping. The default is latin1 (cp1252 West\nEuropean).\n\nUCASE is a synonym.\n\nSELECT UPPER(surname), givenname FROM users ORDER BY surname;\n+----------------+------------+\n| UPPER(surname) | givenname |\n+----------------+------------+\n| ABEL | Jacinto |\n| CASTRO | Robert |\n| COSTA | Phestos |\n| MOSCHELLA | Hippolytos |\n+----------------+------------+\n\nUPPER() is ineffective when applied to binary strings (BINARY, VARBINARY,\nBLOB). The description of LOWER() shows how to perform lettercase conversion\nof binary strings.\n\nPrior to MariaDB 11.3, the query optimizer did not handle queries of the\nformat UCASE(varchar_col)=.... An optimizer_switch option,\nsargable_casefold=ON, was added in MariaDB 11.3.0 to handle this case.\n(MDEV-31496)\n\nURL: https://mariadb.com/kb/en/upper/ +[USER] +declaration= +category=Information Functions +description=Returns the current MariaDB user name and host name, given when authenticating\nto MariaDB, as a string in the utf8 character set.\n\nNote that the value of USER() may differ from the value of CURRENT_USER(),\nwhich is the user used to authenticate the current client. CURRENT_ROLE()\nreturns the current active role.\n\nSYSTEM_USER() and SESSION_USER are synonyms for USER().\n\nStatements using the USER() function or one of its synonyms are not safe for\nstatement level replication.\n\nExamples\n--------\n\nshell> mysql --user="anonymous"\n\nSELECT USER(),CURRENT_USER();\n+---------------------+----------------+\n| USER() | CURRENT_USER() |\n+---------------------+----------------+\n| anonymous@localhost | @localhost |\n+---------------------+----------------+\n\nTo select only the IP address, use SUBSTRING_INDEX(),\n\nSELECT SUBSTRING_INDEX(USER(), '@', -1);\n+----------------------------------+\n| SUBSTRING_INDEX(USER(), '@', -1) |\n+----------------------------------+\n| 192.168.0.101 |\n+----------------------------------+\n\nURL: https://mariadb.com/kb/en/user/ +[UTC_DATE] +declaration= +category=Date and Time Functions +description=Returns the current UTC date as a value in 'YYYY-MM-DD' or YYYYMMDD format,\ndepending on whether the function is used in a string or numeric context.\n\nExamples\n--------\n\nSELECT UTC_DATE(), UTC_DATE() + 0;\n+------------+----------------+\n| UTC_DATE() | UTC_DATE() + 0 |\n+------------+----------------+\n| 2010-03-27 | 20100327 |\n+------------+----------------+\n\nURL: https://mariadb.com/kb/en/utc_date/ +[UTC_TIME] +declaration=[precision] +category=Date and Time Functions +description=Returns the current UTC time as a value in 'HH:MM:SS' or HHMMSS.uuuuuu format,\ndepending on whether the function is used in a string or numeric context.\n\nThe optional precision determines the microsecond precision. See Microseconds\nin MariaDB.\n\nExamples\n--------\n\nSELECT UTC_TIME(), UTC_TIME() + 0;\n+------------+----------------+\n| UTC_TIME() | UTC_TIME() + 0 |\n+------------+----------------+\n| 17:32:34 | 173234.000000 |\n+------------+----------------+\n\nWith precision:\n\nSELECT UTC_TIME(5);\n+----------------+\n| UTC_TIME(5) |\n+----------------+\n| 07:52:50.78369 |\n+----------------+\n\nURL: https://mariadb.com/kb/en/utc_time/ +[UTC_TIMESTAMP] +declaration=[precision] +category=Date and Time Functions +description=Returns the current UTC date and time as a value in 'YYYY-MM-DD HH:MM:SS' or\nYYYYMMDDHHMMSS.uuuuuu format, depending on whether the function is used in a\nstring or numeric context.\n\nThe optional precision determines the microsecond precision. See Microseconds\nin MariaDB.\n\nExamples\n--------\n\nSELECT UTC_TIMESTAMP(), UTC_TIMESTAMP() + 0;\n+---------------------+-----------------------+\n| UTC_TIMESTAMP() | UTC_TIMESTAMP() + 0 |\n+---------------------+-----------------------+\n| 2010-03-27 17:33:16 | 20100327173316.000000 |\n+---------------------+-----------------------+\n\nWith precision:\n\nSELECT UTC_TIMESTAMP(4);\n+--------------------------+\n| UTC_TIMESTAMP(4) |\n+--------------------------+\n| 2018-07-10 07:51:09.1019 |\n+--------------------------+\n\nURL: https://mariadb.com/kb/en/utc_timestamp/ +[UUID] +declaration= +category=Miscellaneous Functions +description=Returns a Universally Unique Identifier (UUID).\n\nA UUID is designed as a number that is globally unique in space and time. Two\ncalls to UUID() are expected to generate two different values, even if these\ncalls are performed on two separate computers that are not connected to each\nother.\n\nUUID() results are intended to be unique, but cannot always be relied upon to\nbe unpredictable and unguessable.\n\nA UUID is a 128-bit number represented by a utf8 string of five hexadecimal\nnumbers in aaaaaaaa-bbbb-cccc-dddd-eeeeeeeeeeee format:\n\n* The first three numbers are generated from a timestamp.\n* The fourth number preserves temporal uniqueness in case the timestamp value\n loses monotonicity (for example, due to daylight saving time).\n* The fifth number is an IEEE 802 node number that provides spatial uniqueness.\n A random number is substituted if the latter is not available (for example,\n because the host computer has no Ethernet card, or we do not know how to find\n the hardware address of an interface on your operating system). In this case,\n spatial uniqueness cannot be guaranteed. Nevertheless, a collision should\n have very low probability.\n\nCurrently, the MAC address of an interface is taken into account only on\nFreeBSD and Linux. On other operating systems, MariaDB uses a randomly\ngenerated 48-bit number.\n\nStatements using the UUID() function are not safe for statement-based\nreplication.\n\nThe function generates a UUIDv1 and the results are generated according to the\n"DCE 1.1:Remote Procedure Call" (Appendix A) CAE (Common Applications\nEnvironment) Specifications published by The Open Group in October 1997\n(Document Number C706).\n\nExamples\n--------\n\nSELECT UUID();\n+--------------------------------------+\n| UUID() |\n+--------------------------------------+\n| cd41294a-afb0-11df-bc9b-00241dd75637 |\n+--------------------------------------+\n\nURL: https://mariadb.com/kb/en/uuid/ +[UUID_SHORT] +declaration= +category=Miscellaneous Functions +description=Returns a "short" universally unique identifier as a 64-bit unsigned integer\n(rather than a string-form 128-bit identifier as returned by the UUID()\nfunction).\n\nThe value of UUID_SHORT() is guaranteed to be unique if the following\nconditions hold:\n\n* The server_id of the current host is unique among your set of master and\n slave servers\n* server_id is between 0 and 255\n* You don't set back your system time for your server between mysqld restarts\n* You do not invoke UUID_SHORT() on average more than 16\n million times per second between mysqld restarts\n\nThe UUID_SHORT() return value is constructed this way:\n\n(server_id & 255) << 56\n+ (server_startup_time_in_seconds << 24)\n+ incremented_variable++;\n\nStatements using the UUID_SHORT() function are not safe for statement-based\nreplication.\n\nExamples\n--------\n\nSELECT UUID_SHORT();\n+-------------------+\n| UUID_SHORT() |\n+-------------------+\n| 21517162376069120 |\n+-------------------+\n\ncreate table t1 (a bigint unsigned default(uuid_short()) primary key);\ninsert into t1 values(),();\nselect * from t1;\n+-------------------+\n| a |\n+-------------------+\n| 98113699159474176 |\n| 98113699159474177 |\n+-------------------+\n\nURL: https://mariadb.com/kb/en/uuid_short/ +[VARBINARY] +declaration=M +category=Data Types +description=The VARBINARY type is similar to the VARCHAR type, but stores binary byte\nstrings rather than non-binary character strings. M represents the maximum\ncolumn length in bytes.\n\nIt contains no character set, and comparison and sorting are based on the\nnumeric value of the bytes.\n\nIf the maximum length is exceeded, and SQL strict mode is not enabled , the\nextra characters will be dropped with a warning. If strict mode is enabled, an\nerror will occur.\n\nUnlike BINARY values, VARBINARYs are not right-padded when inserting.\n\nOracle Mode\n-----------\n\nIn Oracle mode from MariaDB 10.3, RAW is a synonym for VARBINARY.\n\nExamples\n--------\n\nInserting too many characters, first with strict mode off, then with it on:\n\nCREATE TABLE varbins (a VARBINARY(10));\n\nINSERT INTO varbins VALUES('12345678901');\nQuery OK, 1 row affected, 1 warning (0.04 sec)\n\nSELECT * FROM varbins;\n+------------+\n| a |\n+------------+\n| 1234567890 |\n+------------+\n\nSET sql_mode='STRICT_ALL_TABLES';\n\nINSERT INTO varbins VALUES('12345678901');\nERROR 1406 (22001): Data too long for column 'a' at row 1\n\nSorting is performed with the byte value:\n\nTRUNCATE varbins;\n\nINSERT INTO varbins VALUES('A'),('B'),('a'),('b');\n\nSELECT * FROM varbins ORDER BY a;\n+------+\n| a |\n+------+\n ... +[VARCHAR] +declaration=M +category=Data Types +description=A variable-length string. M represents the maximum column length in\ncharacters. The range of M is 0 to 65,532. The effective maximum length of a\nVARCHAR is subject to the maximum row size and the character set used. For\nexample, utf8 characters can require up to three bytes per character, so a\nVARCHAR column that uses the utf8 character set can be declared to be a\nmaximum of 21,844 characters.\n\nNote: For the ColumnStore engine, M represents the maximum column length in\nbytes.\n\nMariaDB stores VARCHAR values as a one-byte or two-byte length prefix plus\ndata. The length prefix indicates the number of bytes in the value. A VARCHAR\ncolumn uses one length byte if values require no more than 255 bytes, two\nlength bytes if values may require more than 255 bytes.\n\nMariaDB follows the standard SQL specification, and does not remove trailing\nspaces from VARCHAR values.\n\nVARCHAR(0) columns can contain 2 values: an empty string or NULL. Such columns\ncannot be part of an index. The CONNECT storage engine does not support\nVARCHAR(0).\n\nVARCHAR is shorthand for CHARACTER VARYING. NATIONAL VARCHAR is the standard\nSQL way to define that a VARCHAR column should use some predefined character\nset. MariaDB uses utf8 as this predefined character set, as does MySQL 4.1 and\nup. NVARCHAR is shorthand for NATIONAL VARCHAR.\n\nBefore MariaDB 10.2, all MariaDB collations were of type PADSPACE, meaning\nthat VARCHAR (as well as CHAR and TEXT values) are compared without regard for\ntrailing spaces. This does not apply to the LIKE pattern-matching operator,\nwhich takes into account trailing spaces. From MariaDB 10.2, a number of NO\nPAD collations are available.\n\nIf a unique index consists of a column where trailing pad characters are\nstripped or ignored, inserts into that column where values differ only by the\nnumber of trailing pad characters will result in a duplicate-key error.\n\nExamples\n--------\n\nThe following are equivalent:\n\nVARCHAR(30) CHARACTER SET utf8\nNATIONAL VARCHAR(30)\nNVARCHAR(30)\nNCHAR VARCHAR(30)\nNATIONAL CHARACTER VARYING(30)\nNATIONAL CHAR VARYING(30)\n\nTrailing spaces:\n ... +[VARIANCE] +declaration=expr +category=Functions and Modifiers for Use with GROUP BY +description=Returns the population standard variance of expr. This is an extension to\nstandard SQL. The standard SQL function VAR_POP() can be used instead.\n\nVariance is calculated by\n\n* working out the mean for the set\n* for each number, subtracting the mean and squaring the result\n* calculate the average of the resulting differences\n\nIt is an aggregate function, and so can be used with the GROUP BY clause.\n\nVARIANCE() can be used as a window function.\n\nVARIANCE() returns NULL if there were no matching rows.\n\nExamples\n--------\n\nCREATE TABLE v(i tinyint);\n\nINSERT INTO v VALUES(101),(99);\n\nSELECT VARIANCE(i) FROM v;\n+-------------+\n| VARIANCE(i) |\n+-------------+\n| 1.0000 |\n+-------------+\n\nINSERT INTO v VALUES(120),(80);\n\nSELECT VARIANCE(i) FROM v;\n+-------------+\n| VARIANCE(i) |\n+-------------+\n| 200.5000 |\n+-------------+\n\nAs an aggregate function:\n\nCREATE OR REPLACE TABLE stats (category VARCHAR(2), x INT);\n\nINSERT INTO stats VALUES \n ('a',1),('a',2),('a',3),\n ('b',11),('b',12),('b',20),('b',30),('b',60);\n\nSELECT category, STDDEV_POP(x), STDDEV_SAMP(x), VAR_POP(x) \n FROM stats GROUP BY category;\n+----------+---------------+----------------+------------+\n| category | STDDEV_POP(x) | STDDEV_SAMP(x) | VAR_POP(x) |\n ... +[VAR_POP] +declaration=expr +category=Functions and Modifiers for Use with GROUP BY +description=Returns the population standard variance of expr. It considers rows as the\nwhole population, not as a sample, so it has the number of rows as the\ndenominator. You can also use VARIANCE(), which is equivalent but is not\nstandard SQL.\n\nVariance is calculated by\n\n* working out the mean for the set\n* for each number, subtracting the mean and squaring the result\n* calculate the average of the resulting differences\n\nIt is an aggregate function, and so can be used with the GROUP BY clause.\n\nVAR_POP() can be used as a window function.\n\nVAR_POP() returns NULL if there were no matching rows.\n\nExamples\n--------\n\nCREATE TABLE v(i tinyint);\n\nINSERT INTO v VALUES(101),(99);\n\nSELECT VAR_POP(i) FROM v;\n+------------+\n| VAR_POP(i) |\n+------------+\n| 1.0000 |\n+------------+\n\nINSERT INTO v VALUES(120),(80);\n\nSELECT VAR_POP(i) FROM v;\n+------------+\n| VAR_POP(i) |\n+------------+\n| 200.5000 |\n+------------+\n\nAs an aggregate function:\n\nCREATE OR REPLACE TABLE stats (category VARCHAR(2), x INT);\n\nINSERT INTO stats VALUES \n ('a',1),('a',2),('a',3),\n ('b',11),('b',12),('b',20),('b',30),('b',60);\n\nSELECT category, STDDEV_POP(x), STDDEV_SAMP(x), VAR_POP(x) \n FROM stats GROUP BY category;\n ... +[VAR_SAMP] +declaration=expr +category=Functions and Modifiers for Use with GROUP BY +description=Returns the sample variance of expr. That is, the denominator is the number of\nrows minus one.\n\nIt is an aggregate function, and so can be used with the GROUP BY clause.\n\nVAR_SAMP() can be used as a window function.\n\nVAR_SAMP() returns NULL if there were no matching rows.\n\nExamples\n--------\n\nAs an aggregate function:\n\nCREATE OR REPLACE TABLE stats (category VARCHAR(2), x INT);\n\nINSERT INTO stats VALUES \n ('a',1),('a',2),('a',3),\n ('b',11),('b',12),('b',20),('b',30),('b',60);\n\nSELECT category, STDDEV_POP(x), STDDEV_SAMP(x), VAR_POP(x) \n FROM stats GROUP BY category;\n+----------+---------------+----------------+------------+\n| category | STDDEV_POP(x) | STDDEV_SAMP(x) | VAR_POP(x) |\n+----------+---------------+----------------+------------+\n| a | 0.8165 | 1.0000 | 0.6667 |\n| b | 18.0400 | 20.1693 | 325.4400 |\n+----------+---------------+----------------+------------+\n\nAs a window function:\n\nCREATE OR REPLACE TABLE student_test (name CHAR(10), test CHAR(10), score\nTINYINT);\n\nINSERT INTO student_test VALUES \n ('Chun', 'SQL', 75), ('Chun', 'Tuning', 73),\n ('Esben', 'SQL', 43), ('Esben', 'Tuning', 31),\n ('Kaolin', 'SQL', 56), ('Kaolin', 'Tuning', 88),\n ('Tatiana', 'SQL', 87);\n\nSELECT name, test, score, VAR_SAMP(score) \n OVER (PARTITION BY test) AS variance_results FROM student_test;\n+---------+--------+-------+------------------+\n| name | test | score | variance_results |\n+---------+--------+-------+------------------+\n| Chun | SQL | 75 | 382.9167 |\n| Chun | Tuning | 73 | 873.0000 |\n| Esben | SQL | 43 | 382.9167 |\n| Esben | Tuning | 31 | 873.0000 |\n| Kaolin | SQL | 56 | 382.9167 |\n ... +[VERSION] +declaration= +category=Information Functions +description=Returns a string that indicates the MariaDB server version. The string uses\nthe utf8 character set.\n\nExamples\n--------\n\nSELECT VERSION();\n+----------------+\n| VERSION() |\n+----------------+\n| 10.4.7-MariaDB |\n+----------------+\n\nThe VERSION() string may have one or more of the following suffixes:\n\n+---------------------------+------------------------------------------------+\n| Suffix | Description |\n+---------------------------+------------------------------------------------+\n| -embedded | The server is an embedded server |\n| | (libmariadbd). |\n+---------------------------+------------------------------------------------+\n| -log | General logging, slow logging or binary |\n| | (replication) logging is enabled. |\n+---------------------------+------------------------------------------------+\n| -debug | The server is compiled for debugging. |\n+---------------------------+------------------------------------------------+\n| -valgrind | The server is compiled to be instrumented |\n| | with valgrind. |\n+---------------------------+------------------------------------------------+\n\nChanging the Version String\n---------------------------\n\nSome old legacy code may break because they are parsing the VERSION string and\nexpecting a MySQL string or a simple version string like Joomla til API17, see\nMDEV-7780.\n\nOne can fool these applications by setting the version string from the command\nline or the my.cnf files with --version=....\n\nURL: https://mariadb.com/kb/en/version/ +[WEEK] +declaration=date[,mode] +category=Date and Time Functions +description=This function returns the week number for date. The two-argument form of\nWEEK() allows you to specify whether the week starts on Sunday or Monday and\nwhether the return value should be in the range from 0 to 53 or from 1 to 53.\nIf the mode argument is omitted, the value of the default_week_format system\nvariable is used.\n\nModes\n-----\n\n+-------+---------------------+--------+------------------------------------+\n| Mode | 1st day of week | Range | Week 1 is the 1st week with |\n+-------+---------------------+--------+------------------------------------+\n| 0 | Sunday | 0-53 | a Sunday in this year |\n+-------+---------------------+--------+------------------------------------+\n| 1 | Monday | 0-53 | more than 3 days this year |\n+-------+---------------------+--------+------------------------------------+\n| 2 | Sunday | 1-53 | a Sunday in this year |\n+-------+---------------------+--------+------------------------------------+\n| 3 | Monday | 1-53 | more than 3 days this year |\n+-------+---------------------+--------+------------------------------------+\n| 4 | Sunday | 0-53 | more than 3 days this year |\n+-------+---------------------+--------+------------------------------------+\n| 5 | Monday | 0-53 | a Monday in this year |\n+-------+---------------------+--------+------------------------------------+\n| 6 | Sunday | 1-53 | more than 3 days this year |\n+-------+---------------------+--------+------------------------------------+\n| 7 | Monday | 1-53 | a Monday in this year |\n+-------+---------------------+--------+------------------------------------+\n\nWith the mode value of 3, which means 'more than 3 days this year', weeks are\nnumbered according to ISO 8601:1988.\n\nExamples\n--------\n\nSELECT WEEK('2008-02-20');\n+--------------------+\n| WEEK('2008-02-20') |\n+--------------------+\n| 7 |\n+--------------------+\n\nSELECT WEEK('2008-02-20',0);\n+----------------------+\n| WEEK('2008-02-20',0) |\n+----------------------+\n| 7 |\n+----------------------+\n\nSELECT WEEK('2008-02-20',1);\n ... +[WEEKDAY] +declaration=date +category=Date and Time Functions +description=Returns the weekday index for date (0 = Monday, 1 = Tuesday, ... 6 = Sunday).\n\nThis contrasts with DAYOFWEEK() which follows the ODBC standard (1 = Sunday, 2\n= Monday, ..., 7 = Saturday).\n\nExamples\n--------\n\nSELECT WEEKDAY('2008-02-03 22:23:00');\n+--------------------------------+\n| WEEKDAY('2008-02-03 22:23:00') |\n+--------------------------------+\n| 6 |\n+--------------------------------+\n\nSELECT WEEKDAY('2007-11-06');\n+-----------------------+\n| WEEKDAY('2007-11-06') |\n+-----------------------+\n| 1 |\n+-----------------------+\n\nCREATE TABLE t1 (d DATETIME);\nINSERT INTO t1 VALUES\n ("2007-01-30 21:31:07"),\n ("1983-10-15 06:42:51"),\n ("2011-04-21 12:34:56"),\n ("2011-10-30 06:31:41"),\n ("2011-01-30 14:03:25"),\n ("2004-10-07 11:19:34");\n\nSELECT d FROM t1 where WEEKDAY(d) = 6;\n+---------------------+\n| d |\n+---------------------+\n| 2011-10-30 06:31:41 |\n| 2011-01-30 14:03:25 |\n+---------------------+\n\nURL: https://mariadb.com/kb/en/weekday/ +[WEEKOFYEAR] +declaration=date +category=Date and Time Functions +description=Returns the calendar week of the date as a number in the range from 1 to 53.\nWEEKOFYEAR() is a compatibility function that is equivalent to WEEK(date,3).\n\nExamples\n--------\n\nSELECT WEEKOFYEAR('2008-02-20');\n+--------------------------+\n| WEEKOFYEAR('2008-02-20') |\n+--------------------------+\n| 8 |\n+--------------------------+\n\nCREATE TABLE t1 (d DATETIME);\nINSERT INTO t1 VALUES\n ("2007-01-30 21:31:07"),\n ("1983-10-15 06:42:51"),\n ("2011-04-21 12:34:56"),\n ("2011-10-30 06:31:41"),\n ("2011-01-30 14:03:25"),\n ("2004-10-07 11:19:34");\n\nselect * from t1;\n+---------------------+\n| d |\n+---------------------+\n| 2007-01-30 21:31:07 |\n| 1983-10-15 06:42:51 |\n| 2011-04-21 12:34:56 |\n| 2011-10-30 06:31:41 |\n| 2011-01-30 14:03:25 |\n| 2004-10-07 11:19:34 |\n+---------------------+\n\nSELECT d, WEEKOFYEAR(d), WEEK(d,3) from t1;\n+---------------------+---------------+-----------+\n| d | WEEKOFYEAR(d) | WEEK(d,3) |\n+---------------------+---------------+-----------+\n| 2007-01-30 21:31:07 | 5 | 5 |\n| 1983-10-15 06:42:51 | 41 | 41 |\n| 2011-04-21 12:34:56 | 16 | 16 |\n| 2011-10-30 06:31:41 | 43 | 43 |\n| 2011-01-30 14:03:25 | 4 | 4 |\n| 2004-10-07 11:19:34 | 41 | 41 |\n+---------------------+---------------+-----------+\n\nURL: https://mariadb.com/kb/en/weekofyear/ +[WEIGHT_STRING] +declaration=str [AS {CHAR|BINARY}(N +category=String Functions +description=Returns a binary string representing the string's sorting and comparison\nvalue. A string with a lower result means that for sorting purposes the string\nappears before a string with a higher result.\n\nWEIGHT_STRING() is particularly useful when adding new collations, for testing\npurposes.\n\nIf str is a non-binary string (CHAR, VARCHAR or TEXT), WEIGHT_STRING returns\nthe string's collation weight. If str is a binary string (BINARY, VARBINARY or\nBLOB), the return value is simply the input value, since the weight for each\nbyte in a binary string is the byte value.\n\nWEIGHT_STRING() returns NULL if given a NULL input.\n\nThe optional AS clause permits casting the input string to a binary or\nnon-binary string, as well as to a particular length.\n\nAS BINARY(N) measures the length in bytes rather than characters, and right\npads with 0x00 bytes to the desired length.\n\nAS CHAR(N) measures the length in characters, and right pads with spaces to\nthe desired length.\n\nN has a minimum value of 1, and if it is less than the length of the input\nstring, the string is truncated without warning.\n\nThe optional LEVEL clause specifies that the return value should contain\nweights for specific collation levels. The levels specifier can either be a\nsingle integer, a comma-separated list of integers, or a range of integers\nseparated by a dash (whitespace is ignored). Integers can range from 1 to a\nmaximum of 6, dependent on the collation, and need to be listed in ascending\norder.\n\nIf the LEVEL clause is no provided, a default of 1 to the maximum for the\ncollation is assumed.\n\nIf the LEVEL is specified without using a range, an optional modifier is\npermitted.\n\nASC, the default, returns the weights without any modification.\n\nDESC returns bitwise-inverted weights.\n\nREVERSE returns the weights in reverse order.\n\nExamples\n--------\n\nThe examples below use the HEX() function to represent non-printable results\nin hexadecimal format.\n ... +[WITHIN] +declaration=g1,g2 +category=Geometry Relations +description=Returns 1 or 0 to indicate whether g1 is spatially within g2. This tests the\nopposite relationship as Contains().\n\nWITHIN() is based on the original MySQL implementation, and uses object\nbounding rectangles, while ST_WITHIN() uses object shapes.\n\nExamples\n--------\n\nSET @g1 = GEOMFROMTEXT('POINT(174 149)');\nSET @g2 = GEOMFROMTEXT('POINT(176 151)');\nSET @g3 = GEOMFROMTEXT('POLYGON((175 150, 20 40, 50 60, 125 100, 175 150))');\n\nSELECT within(@g1,@g3);\n+-----------------+\n| within(@g1,@g3) |\n+-----------------+\n| 1 |\n+-----------------+\n\nSELECT within(@g2,@g3);\n+-----------------+\n| within(@g2,@g3) |\n+-----------------+\n| 0 |\n+-----------------+\n\nURL: https://mariadb.com/kb/en/within/ +[WSREP_LAST_SEEN_GTID] +declaration= +category=Galera Functions +description=Returns the Global Transaction ID of the most recent write transaction\nobserved by the client.\n\nThe result can be useful to determine the transaction to provide to\nWSREP_SYNC_WAIT_UPTO_GTID for waiting and unblocking purposes.\n\nURL: https://mariadb.com/kb/en/wsrep_last_seen_gtid/ +[WSREP_LAST_WRITTEN_GTID] +declaration= +category=Galera Functions +description=Returns the Global Transaction ID of the most recent write transaction\nperformed by the client.\n\nURL: https://mariadb.com/kb/en/wsrep_last_written_gtid/ +[WSREP_SYNC_WAIT_UPTO_GTID] +declaration=gtid[,timeout] +category=Galera Functions +description=Blocks the client until the transaction specified by the given Global\nTransaction ID is applied and committed by the node.\n\nThe optional timeout argument can be used to specify a block timeout in\nseconds. If not provided, the timeout will be indefinite.\n\nReturns the node that applied and committed the Global Transaction ID,\nER_LOCAL_WAIT_TIMEOUT if the function is timed out before this, or\nER_WRONG_ARGUMENTS if the function is given an invalid GTID.\n\nThe result from WSREP_LAST_SEEN_GTID can be useful to determine the\ntransaction to provide to WSREP_SYNC_WAIT_UPTO_GTID for waiting and unblocking\npurposes.\n\nURL: https://mariadb.com/kb/en/wsrep_sync_wait_upto_gtid/ +[YEAR] +declaration=date +category=Date and Time Functions +description=Returns the year for the given date, in the range 1000 to 9999, or 0 for the\n"zero" date.\n\nExamples\n--------\n\nCREATE TABLE t1 (d DATETIME);\nINSERT INTO t1 VALUES\n ("2007-01-30 21:31:07"),\n ("1983-10-15 06:42:51"),\n ("2011-04-21 12:34:56"),\n ("2011-10-30 06:31:41"),\n ("2011-01-30 14:03:25"),\n ("2004-10-07 11:19:34");\n\nSELECT * FROM t1;\n+---------------------+\n| d |\n+---------------------+\n| 2007-01-30 21:31:07 |\n| 1983-10-15 06:42:51 |\n| 2011-04-21 12:34:56 |\n| 2011-10-30 06:31:41 |\n| 2011-01-30 14:03:25 |\n| 2004-10-07 11:19:34 |\n+---------------------+\n\nSELECT * FROM t1 WHERE YEAR(d) = 2011;\n+---------------------+\n| d |\n+---------------------+\n| 2011-04-21 12:34:56 |\n| 2011-10-30 06:31:41 |\n| 2011-01-30 14:03:25 |\n+---------------------+\n\nSELECT YEAR('1987-01-01');\n+--------------------+\n| YEAR('1987-01-01') |\n+--------------------+\n| 1987 |\n+--------------------+\n\nURL: https://mariadb.com/kb/en/year/ +[YEARWEEK] +declaration=date +category=Date and Time Functions +description=Returns year and week for a date. The mode argument works exactly like the\nmode argument to WEEK(). The year in the result may be different from the year\nin the date argument for the first and the last week of the year.\n\nExamples\n--------\n\nSELECT YEARWEEK('1987-01-01');\n+------------------------+\n| YEARWEEK('1987-01-01') |\n+------------------------+\n| 198652 |\n+------------------------+\n\nCREATE TABLE t1 (d DATETIME);\nINSERT INTO t1 VALUES\n ("2007-01-30 21:31:07"),\n ("1983-10-15 06:42:51"),\n ("2011-04-21 12:34:56"),\n ("2011-10-30 06:31:41"),\n ("2011-01-30 14:03:25"),\n ("2004-10-07 11:19:34");\n\nSELECT * FROM t1;\n+---------------------+\n| d |\n+---------------------+\n| 2007-01-30 21:31:07 |\n| 1983-10-15 06:42:51 |\n| 2011-04-21 12:34:56 |\n| 2011-10-30 06:31:41 |\n| 2011-01-30 14:03:25 |\n| 2004-10-07 11:19:34 |\n+---------------------+\n6 rows in set (0.02 sec)\n\nSELECT YEARWEEK(d) FROM t1 WHERE YEAR(d) = 2011;\n+-------------+\n| YEARWEEK(d) |\n+-------------+\n| 201116 |\n| 201144 |\n| 201105 |\n+-------------+\n3 rows in set (0.03 sec)\n\nURL: https://mariadb.com/kb/en/yearweek/ \ No newline at end of file diff --git a/out/functions-mssql.ini b/out/functions-mssql.ini new file mode 100644 index 000000000..04e5babbc --- /dev/null +++ b/out/functions-mssql.ini @@ -0,0 +1,1140 @@ +[$PARTITION] +declaration=database_name,partition_function_name,expression +category=System +description=Returns the partition number into which a set of partitioning column values would be mapped for any specified partition function in SQL Server 2017. +[@@CONNECTIONS] +declaration= +category=System Statistical +description=This function returns the number of attempted connections - both successful and unsuccessful - since SQL Server was last started +[@@CONNECTIONS] +declaration= +category=System Statistical +description=This function returns the number of attempted connections - both successful and unsuccessful - since SQL Server was last started. +[@@CPU_BUSY] +declaration= +category=System Statistical +description=This function returns the amount of time that SQL Server has spent in active operation since its latest start. @@CPU_BUSY returns a result measured in CPU time increments, or "ticks." This value is cumulative for all CPUs, so it may exceed the actual elapsed time. To convert to microseconds, multiply by @@TIMETICKS. +[@@CURSOR_ROWS] +declaration= +category=Cursor +description=This returns the number of qualifying rows currently in the last cursor opened on the connection. To improve performance, SQL Server can populate large keyset and static cursors asynchronously. @@CURSOR_ROWS can be called to determine that the number of the rows that qualify for a cursor are retrieved at the time of the @@CURSOR_ROWS call. +[@@DATEFIRST] +declaration= +category=Date and time +description=This function returns the current value of SET DATEFIRST, for a specific session. +[@@DBTS] +declaration= +category=Configuration +description=This function returns the value of the current timestamp data type for the current database. The current database will have a guaranteed unique timestamp value. +[@@ERROR] +declaration= +category=System +description=Returns the error number for the last Transact-SQL statement executed. +[@@FETCH_STATUS] +declaration= +category=Cursor +description=This function returns the status of the last cursor FETCH statement issued against any cursor currently opened by the connection. +[@@IDENTITY] +declaration= +category=System +description=Is a system function that returns the last-inserted identity value. +[@@IDLE] +declaration= +category=System Statistical +description=Returns the time that SQL Server has been idle since it was last started. The result is in CPU time increments, or "ticks," and is cumulative for all CPUs, so it may exceed the actual elapsed time. Multiply by @@TIMETICKS to convert to microseconds. +[@@IO_BUSY] +declaration= +category=System Statistical +description=Returns the time that SQL Server has spent performing input and output operations since SQL Server was last started. The result is in CPU time increments ("ticks"), and is cumulative for all CPUs, so it may exceed the actual elapsed time. Multiply by @@TIMETICKS to convert to microseconds. +[@@LANGID] +declaration= +category=Configuration +description=Returns the local language identifier (ID) of the language that is currently being used. +[@@LANGUAGE] +declaration= +category=Configuration +description=Returns the name of the language currently being used. +[@@LOCK_TIMEOUT] +declaration= +category=Configuration +description=Returns the current lock time-out setting in milliseconds for the current session. +[@@MAX_CONNECTIONS] +declaration= +category=Configuration +description=Returns the maximum number of simultaneous user connections allowed on an instance of SQL Server. The number returned is not necessarily the number currently configured. +[@@MAX_PRECISION] +declaration= +category=Configuration +description=Returns the precision level used by decimal and numeric data types as currently set in the server. +[@@NESTLEVEL] +declaration= +category=Configuration +description=Returns the nesting level of the current stored procedure execution (initially 0) on the local server. +[@@OPTIONS] +declaration= +category=Configuration +description=Returns information about the current SET options. +[@@PACKET_ERRORS] +declaration= +category=System Statistical +description=Returns the number of network packet errors that have occurred on SQL Server connections since SQL Server was last started. +[@@PACK_RECEIVED] +declaration= +category=System +description=Returns the number of input packets read from the network by SQL Server since it was last started. +[@@PACK_SENT] +declaration= +category=System Statistical +description=Returns the number of output packets written to the network by SQL Server since it was last started. +[@@PROCID] +declaration= +category=Metadata +description=Returns the object identifier (ID) of the current Transact-SQL module. A Transact-SQL module can be a stored procedure, user-defined function, or trigger. @@PROCID cannot be specified in CLR modules or the in-process data access provider. +[@@REMSERVER] +declaration= +category=Configuration +description=Important This feature will be removed in the next version of Microsoft SQL Server. Do not use this feature in new development work, and modify applications that currently use this feature as soon as possible. Use linked servers and linked server stored procedures instead. +[@@ROWCOUNT] +declaration= +category=System +description=Returns the number of rows affected by the last statement. If the number of rows is more than 2 billion, use ROWCOUNT_BIG. +[@@SERVERNAME] +declaration= +category=Configuration +description=Returns the name of the local server that is running SQL Server. +[@@SERVICENAME] +declaration= +category=Configuration +description=Returns the name of the registry key under which SQL Server is running. @@SERVICENAME returns 'MSSQLSERVER' if the current instance is the default instance; this function returns the instance name if the current instance is a named instance. +[@@SPID] +declaration= +category=Configuration +description=Returns the session ID of the current user process. +[@@TEXTSIZE] +declaration= +category=Configuration +description=Returns the current value of the TEXTSIZE option. +[@@TIMETICKS] +declaration= +category=System Statistical +description=Returns the number of microseconds per tick. +[@@TOTAL_ERRORS] +declaration= +category=System Statistical +description=Returns the number of disk write errors encountered by SQL Server since SQL Server last started. +[@@TOTAL_READ] +declaration= +category=System Statistical +description=Returns the number of disk reads, not cache reads, by SQL Server since SQL Server was last started. +[@@TOTAL_WRITE] +declaration= +category=System Statistical +description=Returns the number of disk writes by SQL Server since SQL Server was last started. +[@@VERSION] +declaration= +category=Configuration +description=Returns system and build information for the current installation of SQL Server. +[ABS] +declaration=numeric_expression +category=Mathematical +description=A mathematical function that returns the absolute (positive) value of the specified numeric expression. (ABS changes negative values to positive values. ABS has no effect on zero or positive values.) +[ACOS] +declaration=float_expression +category=Mathematical +description=A function that returns the angle, in radians, whose cosine is the specified float expression. This is also called arccosine. +[APPLOCK_MODE] +declaration='database_principal','resource_name','lock_owner' +category=Metadata +description=This function returns the lock mode held by the lock owner on a particular application resource. As an application lock function, APPLOCK_MODE operates on the current database. The database is the scope of the application locks. +[APPLOCK_TEST] +declaration=' database_principal ',' resource_name ',' lock_mode ',' lock_owner ' +category=Metadata +description=This function returns information as to whether or not a lock can be granted on a particular application resource, for a specified lock owner, without acquisition of the lock. As an application lock function, APPLOCK_TEST operates on the current database. The database is the scope of the application locks. +[APPROX_COUNT_DISTINCT] +declaration=expression +category=Aggregate +description=This function returns the approximate number of unique non-null values in a group. +[APP_NAME] +declaration= +category=Metadata +description=This function returns the application name for the current session, if the application sets that name value. +[ASCII] +declaration=character_expression +category=String +description=Returns the ASCII code value of the leftmost character of a character expression +[ASIN] +declaration=float_expression +category=Mathematical +description=A function that returns the angle, in radians, whose sine is the specified float expression. This is also called arcsine. +[ASSEMBLYPROPERTY] +declaration=assembly_name,property_name +category=Metadata +description=This function returns information about a property of an assembly. +[ASYMKEYPROPERTY] +declaration=Key_ID,'algorithm_desc','string_sid','sid' +category=Cryptographic +description=This function returns the properties of an asymmetric key. +[ASYMKEY_ID] +declaration=Asym_Key_Name +category=Cryptographic +description=Returns the ID of an asymmetric key. +[ATAN] +declaration=float_expression +category=Mathematical +description=A function that returns the angle, in radians, whose tangent is a specified float expression. This is also called arctangent. +[ATN2] +declaration=float_expression +category=Mathematical +description=Returns the angle, in radians, between the positive x-axis and the ray from the origin to the point (y, x), where x and y are the values of the two specified float expressions. +[AVG] +declaration=all,distinct,expression +category=Aggregate +description=This function returns the average of the values in a group. It ignores null values +[BINARY_CHECKSUM] +declaration=*** +category=System +description=Returns the binary checksum value computed over a row of a table or over a list of expressions. +[CAST AND CONVERT] +declaration=expression,data_type,length,style +category=Conversion +description=These functions convert an expression of one data type to another. +[CEILING] +declaration=numeric_expression +category=Mathematical +description=This function returns the smallest integer greater than, or equal to, the specified numeric expression. +[CERTENCODED] +declaration=cert_id +category=Security +description=This function returns the public portion of a certificate in binary format. This function takes a certificate ID as an argument, and returns the encoded certificate. To create a new certificate, pass the binary result to CREATE CERTIFICATE … WITH BINARY. +[CERTPRIVATEKEY] +declaration=certificate_ID,encryption_password,decryption_password +category=Security +description=This function returns the private key of a certificate in binary format. This function takes three arguments. +[CERTPROPERTY] +declaration=Cert_ID,Expiry_Date,Start_Date,Issuer_Name,Cert_Serial_Number,Subject,SID,String_SID +category=Cryptographic +description=Returns the value of a specified certificate property. +[CERT_ID] +declaration= +category=Cryptographic +description=This function returns the ID value of a certificate. +[CHARINDEX] +declaration=expressionToFind,expressionToSearch,start_location +category=String +description=This function searches for one character expression inside a second character expression, returning the starting position of the first expression if found. +[CHAR] +declaration=integer_expression +category=String +description=This function converts an int ASCII code to a character value. +[CHECKSUM] +declaration=* +category=System +description=The CHECKSUM function returns the checksum value computed over a table row, or over an expression list. Use CHECKSUM to build hash indexes. +[CHECKSUM_AGG] +declaration=ALL,DISTINCT,expression +category=Aggregate +description=This function returns the checksum of the values in a group. CHECKSUM_AGG ignores null values. The OVER clause can follow CHECKSUM_AGG. +[CHOOSE] +declaration=index,val_1 … val_n +category=Logical +description=Returns the item at the specified index from a list of values in SQL Server. +[COLLATIONPROPERTY] +declaration=collation_name,property +category=Collation +description=This function returns the property of a specified collation in SQL Server 2017. +[COLUMNPROPERTY] +declaration=id,column,property +category=Metadata +description=This function returns column or parameter information. +[COLUMNS_UPDATED] +declaration= +category=Trigger +description=This function returns a varbinary bit pattern indicating the inserted or updated columns of a table or view. Use COLUMNS_UPDATED anywhere inside the body of a Transact-SQL INSERT or UPDATE trigger to test whether the trigger should execute certain actions. +[COL_LENGTH] +declaration=' table ',' column ' +category=Metadata +description=This function returns the defined length of a column, in bytes. +[COL_NAME] +declaration=table_id,column_id +category=Metadata +description=This function returns the name of a table column, based on the table identification number and column identification number values of that table column. +[COMPRESS] +declaration=expression +category=System +description=This function compresses the input expression, using the GZIP algorithm. The function returns a byte array of type varbinary(max). +[CONCAT] +declaration=string_value +category=String +description=This function returns a string resulting from the concatenation, or joining, of two or more string values in an end-to-end manner. (To add a separating value during concatenation, see CONCAT_WS.) +[CONCAT_WS] +declaration=separator,argument1, argument2, argumentN +category=String +description=This function returns a string resulting from the concatenation, or joining, of two or more string values in an end-to-end manner. It separates those concatenated string values with the delimiter specified in the first function argument. (CONCAT_WS indicates concatenate with separator.) +[CONNECTIONPROPERTY] +declaration=property +category=System +description=For a request that comes in to the server, this function returns information about the connection properties of the unique connection which supports that request. +[CONTEXT_INFO] +declaration= +category=System +description=This function returns the context_info value either set for the current session or batch, or derived through use of the SET CONTEXT_INFO statement. +[COS] +declaration=float_expression +category=Mathematical +description=A mathematical function that returns the trigonometric cosine of the specified angle - measured in radians - in the specified expression. +[COT] +declaration=float_expression +category=Mathematical +description=A mathematical function that returns the trigonometric cotangent of the specified angle - in radians - in the specified float expression. +[COUNT] +declaration=all,distinct,expression,* +category=Aggregate +description=This function returns the number of items found in a group +[COUNT_BIG] +declaration=ALL,DISTINCT,expression,***,OVER ( [ partition_by_clause ] [ order_by_clause ] ) +category=Aggregate +description=This function returns the number of items found in a group. COUNT_BIG operates like the COUNT function. These functions differ only in the data types of their return values. COUNT_BIG always returns a bigint data type value. COUNT always returns an int data type value. +[CRYPT_GEN_RANDOM] +declaration=length,seed +category=Cryptographic +description=This function returns a cryptographic, randomly-generated number, generated by the Crypto API (CAPI). CRYPT_GEN_RANDOM returns a hexadecimal number with a length of a specified number of bytes. +[CUME_DIST] +declaration= +category=Analytic +description=For SQL Server, this function calculates the cumulative distribution of a value within a group of values. In other words, CUME_DIST calculates the relative position of a specified value in a group of values. Assuming ascending ordering, the CUME_DIST of a value in row r is defined as the number of rows with values less than or equal to that value in row r, divided by the number of rows evaluated in the partition or query result set. CUME_DIST is similar to the PERCENT_RANK function. +[CURRENT_REQUEST_ID] +declaration= +category=System +description=This function returns the ID of the current request within the current session. +[CURRENT_TIMESTAMP] +declaration= +category=Date and time +description=This function returns the current database system timestamp as a datetime value, without the database time zone offset. CURRENT_TIMESTAMP derives this value from the operating system of the computer on which the instance of SQL Server runs. +[CURRENT_TRANSACTION_ID] +declaration= +category=System +description=This function returns the transaction ID of the current transaction in the current session. +[CURRENT_USER] +declaration= +category=Security +description=This function returns the name of the current user. This function is equivalent to USER_NAME(). +[CURSOR_STATUS] +declaration='local','cursor_name','global','variable','cursor_variable' +category=Cursor +description=For a given parameter, CURSOR_STATUS shows whether or not a cursor declaration has returned a cursor and result set. +[DATABASEPROPERTYEX] +declaration=database,property +category=Metadata +description=For a specified database in SQL Server, this function returns the current setting of the specified database option or property. +[DATABASE_PRINCIPAL_ID] +declaration=principal_name +category=Metadata +description=This function returns the ID number of a principal in the current database. See Principals (Database Engine) for more information about principals. +[DATALENGTH] +declaration=expression +category=Data type +description=This function returns the number of bytes used to represent any expression. +[DATEADD] +declaration=datepart +category=Date and time +description=This function adds a specified number value (as a signed integer) to a specified datepart of an input date value, and then returns that modified value. +[DATEDIFF] +declaration=datepart +category=Date and time +description=This function returns the count (as a signed integer value) of the specified datepart boundaries crossed between the specified startdate and enddate. +[DATEDIFF_BIG] +declaration=datepart +category=Date and time +description=This function returns the count (as a signed big integer value) of the specified datepart boundaries crossed between the specified startdate and enddate. +[DATEFROMPARTS] +declaration=year,month,day +category=Date and time +description=This function returns a date value that maps to the specified year, month, and day values. +[DATENAME] +declaration=datepart +category=Date and time +description=This function returns a character string representing the specified datepart of the specified date. +[DATEPART] +declaration=datepart +category=Date and time +description=This function returns an integer representing the specified datepart of the specified date. +[DATETIME2FROMPARTS] +declaration=year,month,day,hour,minute,seconds,fractions,precision +category=Date and time +description=This function returns a datetime2 value for the specified date and time arguments. The returned value has a precision specified by the precision argument. +[DATETIMEFROMPARTS] +declaration=year,month,day,hour,minute,seconds,milliseconds +category=Date and time +description=This function returns a datetime value for the specified date and time arguments. +[DATETIMEOFFSETFROMPARTS] +declaration=year,month,day,hour,minute,seconds,fractions,hour_offset,minute_offset,precision +category=Date and time +description=Returns a datetimeoffset value for the specified date and time arguments. The returned value has a precision specified by the precision argument, and an offset as specified by the offset arguments. +[DAY] +declaration=date +category=Date and time +description=This function returns an integer that represents the day (day of the month) of the specified date. +[DB_ID] +declaration='database_name' +category=Metadata +description=This function returns the database identification (ID) number of a specified database. +[DB_NAME] +declaration= +category=Metadata +description=This function returns the name of a specified database. +[DECOMPRESS] +declaration=expression +category=System +description=This function will decompress an input expression value, using the GZIP algorithm. DECOMPRESS will return a byte array (VARBINARY(MAX) type). +[DECRYPTBYASYMKEY] +declaration=Asym_Key_ID,ciphertext,@ciphertext,Asym_Key_Password +category=Cryptographic +description=This function uses an asymmetric key to decrypt encrypted data. +[DECRYPTBYCERT] +declaration=certificate_ID,ciphertext,@ciphertext,cert_password,@cert_password +category=Cryptographic +description=This function uses the private key of a certificate to decrypt encrypted data. +[DECRYPTBYKEYAUTOASYMKEY] +declaration=akey_ID,akey_password,@ciphertext,add_authenticator,@add_authenticator,authenticator,@authenticator,@add_authenticator,authenticator,@authenticator +category=Cryptographic +description=This function decrypts encrypted data. To do this, it first decrypts a symmetric key with a separate asymmetric key, and then decrypts the encrypted data with the symmetric key extracted in the first "step". +[DECRYPTBYKEYAUTOCERT] +declaration=cert_ID,cert_password,'ciphertext',@ciphertext,add_authenticator,@add_authenticator,authenticator,@authenticator +category=Cryptographic +description=This function decrypts data with a symmetric key. That symmetric key automatically decrypts with a certificate. +[DECRYPTBYKEY] +declaration=ciphertext,@ciphertext,add_authenticator,authenticator,@authenticator +category=Cryptographic +description=This function uses a symmetric key to decrypt data. +[DECRYPTBYPASSPHRASE] +declaration=passphrase,@passphrase +category=Cryptographic +description=This function decrypts data originally encrypted with a passphrase. +[DEGREES] +declaration=numeric_expression +category=Mathematical +description=This function returns the corresponding angle, in degrees, for an angle specified in radians. +[DENSE_RANK] +declaration=<partition_by_clause>,<order_by_clause> +category=Ranking +description=This function returns the rank of each row within a result set partition, with no gaps in the ranking values. The rank of a specific row is one plus the number of distinct rank values that come before that specific row. +[DIFFERENCE] +declaration=character_expression +category=String +description=This function returns an integer value measuring the difference between the SOUNDEX() values of two different character expressions. +[ENCRYPTBYASYMKEY] +declaration=asym_key_ID,cleartext +category=Cryptographic +description=This function encrypts data with an asymmetric key. +[ENCRYPTBYCERT] +declaration=certificate_ID,cleartext,@cleartext +category=Cryptographic +description=Encrypts data with the public key of a certificate. +[ENCRYPTBYKEY] +declaration=key_GUID,'cleartext',@cleartext,add_authenticator,@add_authenticator,authenticator,@authenticator +category=Cryptographic +description=Encrypts data by using a symmetric key. +[ENCRYPTBYPASSPHRASE] +declaration=passphrase,@passphrase,cleartext,@cleartext,add_authenticator,@add_authenticator,authenticator,@authenticator +category=Cryptographic +description=Encrypt data with a passphrase using the TRIPLE DES algorithm with a 128 key bit length. +[EOMONTH] +declaration=start_date,month_to_add +category=Date and time +description=This function returns the last day of the month containing a specified date, with an optional offset. +[ERROR_LINE] +declaration= +category=System +description=This function returns the line number of occurrence of an error that caused the CATCH block of a TRY…CATCH construct to execute. +[ERROR_MESSAGE] +declaration= +category=System +description=This function returns the message text of the error that caused the CATCH block of a TRY…CATCH construct to execute. +[ERROR_NUMBER] +declaration= +category=System +description=This function returns the error number of the error that caused the CATCH block of a TRY…CATCH construct to execute. +[ERROR_PROCEDURE] +declaration= +category=System +description=This function returns the name of the stored procedure or trigger where an error occurs, if that error caused the CATCH block of a TRY…CATCH construct to execute. +[ERROR_SEVERITY] +declaration= +category=System +description=This function returns the severity value of the error where an error occurs, if that error caused the CATCH block of a TRY…CATCH construct to execute. +[ERROR_STATE] +declaration= +category=System +description=Returns the state number of the error that caused the CATCH block of a TRY…CATCH construct to be run. +[EVENTDATA] +declaration= +category=Trigger +description=This function returns information about server or database events. When an event notification fires, and the specified service broker receives the results, EVENTDATA is called. A DDL or logon trigger also support internal use of EVENTDATA. +[EXP] +declaration=float_expression +category=Mathematical +description=Returns the exponential value of the specified float expression. +[FILEGROUPPROPERTY] +declaration=filegroup_name,property +category=Metadata +description=This function returns the filegroup property value for a specified name and filegroup value. +[FILEGROUP_ID] +declaration= +category=Metadata +description=This function returns the filegroup identification (ID) number for a specified filegroup name. +[FILEGROUP_NAME] +declaration= +category=Metadata +description=This function returns the filegroup name for the specified filegroup identification (ID) number. +[FILEPROPERTY] +declaration=file_name,property +category=Metadata +description=Returns the specified file name property value when a file name in the current database and a property name are specified. Returns NULL for files that are not in the current database. +[FILE_IDEX] +declaration=file_name +category=Metadata +description=This function returns the file identification (ID) number for the specified logical name of a data, log, or full-text file of the current database. +[FILE_ID] +declaration=file_name +category=Metadata +description=For the given logical name for a component file of the current database, this function returns the file identification (ID) number. +[FILE_NAME] +declaration=file_id +category=Metadata +description=This function returns the logical file name for a given file identification (ID) number. +[FIRST_VALUE] +declaration=scalar_expression,OVER ( [ partition_by_clause ] order_by_clause [ rows_range_clause ] ) +category=Analytic +description=Returns the first value in an ordered set of values in SQL Server 2017. +[FLOOR] +declaration=numeric_expression +category=Mathematical +description=Returns the largest integer less than or equal to the specified numeric expression. +[FORMATMESSAGE] +declaration=msg_number,msg_string,param_value +category=System +description=Constructs a message from an existing message in sys.messages or from a provided string. The functionality of FORMATMESSAGE resembles that of the RAISERROR statement. However, RAISERROR prints the message immediately, while FORMATMESSAGE returns the formatted message for further processing. +[FORMAT] +declaration=value,format,culture +category=String +description=Returns a value formatted with the specified format and optional culture in SQL Server 2017. Use the FORMAT function for locale-aware formatting of date/time and number values as strings. For general data type conversions, use CAST or CONVERT. +[FULLTEXTCATALOGPROPERTY] +declaration= +category=Metadata +description=Returns information about full-text catalog properties in SQL Server 2017. +[FULLTEXTSERVICEPROPERTY] +declaration=property +category=Metadata +description=Returns information related to the properties of the Full-Text Engine. These properties can be set and retrieved by using sp_fulltext_service. +[GETANSINULL] +declaration='database' +category=System +description=Returns the default nullability for the database for this session. +[GETDATE] +declaration= +category=Date and time +description=Returns the current database system timestamp as a datetime value without the database time zone offset. This value is derived from the operating system of the computer on which the instance of SQL Server is running. +[GETUTCDATE] +declaration= +category=Date and time +description=Returns the current database system timestamp as a datetime value. The database time zone offset is not included. This value represents the current UTC time (Coordinated Universal Time). This value is derived from the operating system of the computer on which the instance of SQL Server is running. +[GET_FILESTREAM_TRANSACTION_CONTEXT] +declaration= +category=System +description=Returns a token that represents the current transaction context of a session. The token is used by an application to bind FILESTREAM file-system streaming operations to the transaction. For a list of FILESTREAM topics, see Binary Large Object (Blob) Data (SQL Server). +[GROUPING] +declaration=<column_expression> +category=Aggregate +description=Indicates whether a specified column expression in a GROUP BY list is aggregated or not. GROUPING returns 1 for aggregated or 0 for not aggregated in the result set. GROUPING can be used only in the SELECT list, HAVING, or ORDER BY clauses when GROUP BY is specified. +[HASHBYTES] +declaration='<algorithm>',@input,' input ' +category=Cryptographic +description=Returns the MD2, MD4, MD5, SHA, SHA1, or SHA2 hash of its input in SQL Server. +[HAS_DBACCESS] +declaration='database_name' +category=Security +description=Returns information about whether the user has access to the specified database. +[HAS_PERMS_BY_NAME] +declaration=securable,securable_class,permission,sub-securable +category=Security +description=Evaluates the effective permission of the current user on a securable. A related function is fn_my_permissions. +[HOST_ID] +declaration= +category=System +description=Returns the workstation identification number. The workstation identification number is the process ID (PID) of the application on the client computer that is connecting to SQL Server. +[HOST_NAME] +declaration= +category=System +description=Returns the workstation name. +[IDENTITY (FUNCTION)] +declaration=data_type,seed,increment,column_name +category=Data type +description=Is used only in a SELECT statement with an INTO table clause to insert an identity column into a new table. Although similar, the IDENTITY function is not the IDENTITY property that is used with CREATE TABLE and ALTER TABLE. +[IDENT_CURRENT] +declaration=table_name +category=Data type +description=Returns the last identity value generated for a specified table or view. The last identity value generated can be for any session and any scope. +[IDENT_INCR] +declaration=' table_or_view ' +category=Data type +description=Returns the increment value (returned as numeric (@@MAXPRECISION,0)) specified during the creation of an identity column in a table or view that has an identity column. +[IDENT_SEED] +declaration=' table_or_view ' +category=Data type +description=Returns the original seed value (returned as numeric(@@MAXPRECISION,0)) that was specified when an identity column in a table or a view was created. Changing the current value of an identity column by using DBCC CHECKIDENT does not change the value returned by this function. +[IIF] +declaration=boolean_expression,true_value,false_value +category=Logical +description=Returns one of two values, depending on whether the Boolean expression evaluates to true or false in SQL Server. +[INDEXKEY_PROPERTY] +declaration=object_ID,index_ID,key_ID,property +category=Metadata +description=Returns information about the index key. Returns NULL for XML indexes. +[INDEXPROPERTY] +declaration=object_ID,index_or_statistics_name,property +category=Metadata +description=Returns the named index or statistics property value of a specified table identification number, index or statistics name, and property name. Returns NULL for XML indexes. +[INDEX_COL] +declaration=database_name,schema_name,table_or_view_name,index_id,key_id +category=Metadata +description=Returns the indexed column name. Returns NULL for XML indexes. +[ISDATE] +declaration=expression +category=Date and time +description=Returns 1 if the expression is a valid date, time, or datetime value; otherwise, 0. +[ISJSON] +declaration=expression +category=JSON +description=Tests whether a string contains valid JSON. +[ISNULL] +declaration=check_expression,replacement_value +category=System +description=Replaces NULL with the specified replacement value. +[ISNUMERIC] +declaration=expression +category=System +description=Determines whether an expression is a valid numeric type. +[IS_MEMBER] +declaration=' group ',' role ' +category=Security +description=Indicates whether the current user is a member of the specified Microsoft Windows group or SQL Server database role. +[IS_OBJECTSIGNED] +declaration='OBJECT',@object_id,@class +category=Cryptographic +description=Indicates whether an object is signed by a specified certificate or asymmetric key. +[IS_ROLEMEMBER] +declaration=' role ',' database_principal ' +category=Security +description=Indicates whether a specified database principle is a member of the specified database role. +[IS_SRVROLEMEMBER] +declaration=' role ' +category=Security +description=Indicates whether a SQL Server login is a member of the specified server role. +[JSON_MODIFY] +declaration=expression,path +category=JSON +description=Updates the value of a property in a JSON string and returns the updated JSON string. +[JSON_QUERY] +declaration=expression,path +category=JSON +description=Extracts an object or an array from a JSON string. +[JSON_VALUE] +declaration=expression,path +category=JSON +description=Extracts a scalar value from a JSON string. +[KEY_GUID] +declaration=' Key_Name ' +category=Cryptographic +description=Returns the GUID of a symmetric key in the database. +[KEY_ID] +declaration=' Key_Name ' +category=Cryptographic +description=Returns the ID of a symmetric key in the current database. +[KEY_NAME] +declaration=ciphertext,key_guid +category=Cryptographic +description=Returns the name of the symmetric key from either a symmetric key GUID or cipher text. +[LAG] +declaration=scalar_expression,offset,default +category=Analytic +description=Accesses data from a previous row in the same result set without the use of a self-join starting with SQL Server 2012 (11.x). +[LAST_VALUE] +declaration=scalar_expression,OVER ( [ partition_by_clause ] order_by_clause [ rows_range_clause ] ) +category=Analytic +description=Returns the last value in an ordered set of values in SQL Server 2017. +[LEAD] +declaration=scalar_expression,offset,default,OVER ( [ partition_by_clause ] order_by_clause) +category=Analytic +description=Accesses data from a subsequent row in the same result set without the use of a self-join starting with SQL Server 2012 (11.x). LEAD provides access to a row at a given physical offset that follows the current row. Use this analytic function in a SELECT statement to compare values in the current row with values in a following row. +[LEFT] +declaration=character_expression,integer_expression +category=String +description=Returns the left part of a character string with the specified number of characters. +[LEN] +declaration=string_expression +category=String +description=Returns the number of characters of the specified string expression, excluding trailing blanks. +[LOG10] +declaration=float_expression +category=Mathematical +description=Returns the base-10 logarithm of the specified float expression. +[LOGINPROPERTY] +declaration=login_name,propertyname +category=Security +description=Returns information about login policy settings. +[LOG] +declaration=float_expression,base +category=Mathematical +description=Returns the natural logarithm of the specified float expression in SQL Server. +[LOWER] +declaration=character_expression +category=String +description=Returns a character expression after converting uppercase character data to lowercase. +[LTRIM] +declaration=character_expression +category=String +description=Returns a character expression after it removes leading blanks. +[MAX] +declaration=ALL,DISTINCT,expression,OVER ( [ partition_by_clause ] order_by_clause) +category=Aggregate +description=Returns the maximum value in the expression. +[MIN] +declaration=ALL,DISTINCT,expression,OVER ( [ partition_by_clause ] order_by_clause) +category=Aggregate +description=Returns the minimum value in the expression. May be followed by the OVER clause. +[MIN_ACTIVE_ROWVERSION] +declaration= +category=System +description=Returns the lowest active rowversion value in the current database. A rowversion value is active if it is used in a transaction that has not yet been committed. For more information, see rowversion (Transact-SQL). +[MONTH] +declaration=date +category=Date and time +description=Returns an integer that represents the month of the specified date. +[NCHAR] +declaration=integer_expression +category=String +description=Returns the Unicode character with the specified integer code, as defined by the Unicode standard. +[NEWID] +declaration= +category=System +description=Creates a unique value of type uniqueidentifier. +[NEWSEQUENTIALID] +declaration= +category=System +description=Creates a GUID that is greater than any GUID previously generated by this function on a specified computer since Windows was started. After restarting Windows, the GUID can start again from a lower range, but is still globally unique. When a GUID column is used as a row identifier, using NEWSEQUENTIALID can be faster than using the NEWID function. This is because the NEWID function causes random activity and uses fewer cached data pages. Using NEWSEQUENTIALID also helps to completely fill the data and index pages. +[NEXT VALUE FOR] +declaration=database_name,schema_name,sequence_name,over_order_by_clause +category=Metadata +description=Generates a sequence number from the specified sequence object. +[NTILE] +declaration=integer_expression,<partition_by_clause>,<order_by_clause> +category=Ranking +description=Distributes the rows in an ordered partition into a specified number of groups. The groups are numbered, starting at one. For each row, NTILE returns the number of the group to which the row belongs. +[OBJECTPROPERTYEX] +declaration=id,property +category=Metadata +description=Returns information about schema-scoped objects in the current database. For a list of these objects, see sys.objects (Transact-SQL). OBJECTPROPERTYEX cannot be used for objects that are not schema-scoped, such as data definition language (DDL) triggers and event notifications. +[OBJECTPROPERTY] +declaration=id,property +category=Metadata +description=Returns information about schema-scoped objects in the current database. For a list of schema-scoped objects, see sys.objects (Transact-SQL). This function cannot be used for objects that are not schema-scoped, such as data definition language (DDL) triggers and event notifications. +[OBJECT_DEFINITION] +declaration=object_id +category=Metadata +description=Returns the Transact-SQL source text of the definition of a specified object. +[OBJECT_ID] +declaration=' object_name ',' object_type ' +category=Metadata +description=Returns the database object identification number of a schema-scoped object. +[OBJECT_NAME] +declaration=object_id,database_id +category=Metadata +description=Returns the database object name for schema-scoped objects. For a list of schema-scoped objects, see sys.objects (Transact-SQL). +[OBJECT_SCHEMA_NAME] +declaration=object_id,database_id +category=Metadata +description=Returns the database schema name for schema-scoped objects. For a list of schema-scoped objects, see sys.objects (Transact-SQL). +[OPENDATASOURCE] +declaration=provider_name,init_string +category=Rowset +description=Provides ad hoc connection information as part of a four-part object name without using a linked server name. +[OPENJSON] +declaration= +category=Rowset +description=OPENJSON is a table-valued function that parses JSON text and returns objects and properties from the JSON input as rows and columns. In other words, OPENJSON provides a rowset view over a JSON document. You can explicitly specify the columns in the rowset and the JSON property paths used to populate the columns. Since OPENJSON returns a set of rows, you can use OPENJSON in the FROM clause of a Transact-SQL statement just as you can use any other table, view, or table-valued function. +[OPENQUERY] +declaration=linked_server,' query ' +category=Rowset +description=Executes the specified pass-through query on the specified linked server. This server is an OLE DB data source. OPENQUERY can be referenced in the FROM clause of a query as if it were a table name. OPENQUERY can also be referenced as the target table of an INSERT, UPDATE, or DELETE statement. This is subject to the capabilities of the OLE DB provider. Although the query may return multiple result sets, OPENQUERY returns only the first one. +[OPENROWSET] +declaration='provider_name','datasource','user_id','password','provider_string',catalog,schema,object,'query',BULK +category=Rowset +description=Includes all connection information that is required to access remote data from an OLE DB data source. This method is an alternative to accessing tables in a linked server and is a one-time, ad hoc method of connecting and accessing remote data by using OLE DB. For more frequent references to OLE DB data sources, use linked servers instead. For more information, see Linked Servers (Database Engine). The OPENROWSET function can be referenced in the FROM clause of a query as if it were a table name. The OPENROWSET function can also be referenced as the target table of an INSERT, UPDATE, or DELETE statement, subject to the capabilities of the OLE DB provider. Although the query might return multiple result sets, OPENROWSET returns only the first one. +[OPENXML] +declaration=idoc,rowpattern,flags +category=Rowset +description=OPENXML provides a rowset view over an XML document +[ORIGINAL_DB_NAME] +declaration= +category=Metadata +description=Returns the database name that is specified by the user in the database connection string. This is the database that is specified by using the sqlcmd-d option (USE database) or the ODBC data source expression (initial catalog =databasename). +[ORIGINAL_LOGIN] +declaration= +category=Security +description=Returns the name of the login that connected to the instance of SQL Server. You can use this function to return the identity of the original login in sessions in which there are many explicit or implicit context switches. +[PARSENAME] +declaration='object_name',object_piece +category=Metadata +description=Returns the specified part of an object name. The parts of an object that can be retrieved are the object name, owner name, database name, and server name. +[PARSE] +declaration=string_value,data_type,culture +category=Conversion +description=Returns the result of an expression, translated to the requested data type in SQL Server. +[PATINDEX] +declaration=pattern,expression +category=String +description=Returns the starting position of the first occurrence of a pattern in a specified expression, or zeros if the pattern is not found, on all valid text and character data types. +[PERCENTILE_CONT] +declaration=numeric_literal,WITHIN GROUP ( ORDER BY order_by_expression [ ASC | DESC ]),OVER ( <partition_by_clause> ) +category=Analytic +description=Calculates a percentile based on a continuous distribution of the column value in SQL Server. The result is interpolated and might not be equal to any of the specific values in the column. +[PERCENTILE_DISC] +declaration=literal,WITHIN GROUP ( ORDER BY order_by_expression [ ASC | DESC ]),OVER ( <partition_by_clause> ) +category=Analytic +description=Computes a specific percentile for sorted values in an entire rowset or within distinct partitions of a rowset in SQL Server. For a given percentile value P, PERCENTILE_DISC sorts the values of the expression in the ORDER BY clause and returns the value with the smallest CUME_DIST value (with respect to the same sort specification) that is greater than or equal to P. For example, PERCENTILE_DISC (0.5) will compute the 50th percentile (that is, the median) of an expression. PERCENTILE_DISC calculates the percentile based on a discrete distribution of the column values; the result is equal to a specific value in the column. +[PERCENT_RANK] +declaration=OVER ( [ partition_by_clause ] order_by_clause) +category=Analytic +description=Calculates the relative rank of a row within a group of rows in SQL Server 2017. Use PERCENT_RANK to evaluate the relative standing of a value within a query result set or partition. PERCENT_RANK is similar to the CUME_DIST function. +[PERMISSIONS] +declaration=objectid,' column ' +category=Security +description=Returns a value containing a bitmap that indicates the statement, object, or column permissions of the current user. +[PI] +declaration= +category=Mathematical +description=Returns the constant value of PI. +[POWER] +declaration=float_expression,y +category=Mathematical +description=Returns the value of the specified expression to the specified power. +[PUBLISHINGSERVERNAME] +declaration= +category=Replication +description=Returns the name of the originating Publisher for a published database participating in a database mirroring session. This function is executed at a Publisher instance of SQL Server on the publication database. Use it to determine the original Publisher of the published database. +[PWDCOMPARE] +declaration=' clear_text_password ',password_hash,version +category=Security +description=Hashes a password and compares the hash to the hash of an existing password. PWDCOMPARE can be used to search for blank SQL Server login passwords or common weak passwords. +[PWDENCRYPT] +declaration=password +category=Security +description=Returns the SQL Server password hash of the input value that uses the current version of the password hashing algorithm. +[QUOTENAME] +declaration='character_string','quote_character' +category=String +description=Returns a Unicode string with the delimiters added to make the input string a valid SQL Server delimited identifier. +[RADIANS] +declaration=numeric_expression +category=Mathematical +description=Returns radians when a numeric expression, in degrees, is entered. +[RAND] +declaration=seed +category=Mathematical +description=Returns a pseudo-random float value from 0 through 1, exclusive. +[RANK] +declaration=OVER ( [ partition_by_clause ] order_by_clause) +category=Ranking +description=Returns the rank of each row within the partition of a result set. The rank of a row is one plus the number of ranks that come before the row in question. +[REPLACE] +declaration=string_expression,string_pattern,string_replacement +category=String +description=Replaces all occurrences of a specified string value with another string value. +[REPLICATE] +declaration=string_expression +category=String +description=Repeats a string value a specified number of times. +[REVERSE] +declaration=string_expression +category=String +description=Returns the reverse order of a string value. +[RIGHT] +declaration=character_expression,integer_expression +category=String +description=Returns the right part of a character string with the specified number of characters. +[ROUND] +declaration=numeric_expression,length,function +category=Mathematical +description=Returns a numeric value, rounded to the specified length or precision. +[ROWCOUNT_BIG] +declaration= +category=System +description=Returns the number of rows affected by the last statement executed. This function operates like @@ROWCOUNT, except the return type of ROWCOUNT_BIG is bigint. +[ROW_NUMBER] +declaration=PARTITION BY value_expression,order_by_clause +category=Ranking +description=Numbers the output of a result set. More specifically, returns the sequential number of a row within a partition of a result set, starting at 1 for the first row in each partition. +[RTRIM] +declaration=character_expression +category=String +description=Returns a character string after truncating all trailing spaces. +[SCHEMA_ID] +declaration= +category=Metadata +description=Returns the schema ID associated with a schema name. +[SCHEMA_NAME] +declaration= +category=Metadata +description=Returns the schema name associated with a schema ID. +[SCOPE_IDENTITY] +declaration= +category=Metadata +description=Returns the last identity value inserted into an identity column in the same scope. A scope is a module: a stored procedure, trigger, function, or batch. Therefore, if two statements are in the same stored procedure, function, or batch, they are in the same scope. +[SERVERPROPERTY] +declaration=propertyname +category=Metadata +description=Returns property information about the server instance. +[SESSIONPROPERTY] +declaration=option +category=Security +description=Returns the SET options settings of a session. +[SESSION_CONTEXT] +declaration='key' +category=System +description=Returns the value of the specified key in the current session context. The value is set by using the sp_set_session_context (Transact-SQL) procedure. +[SESSION_USER] +declaration= +category=Security +description=SESSION_USER returns the user name of the current context in the current database. +[SIGNBYASYMKEY] +declaration=Asym_Key_ID,@plaintext,password +category=Cryptographic +description=Signs plaintext with an asymmetric key +[SIGNBYCERT] +declaration=certificate_ID,@cleartext,' password ' +category=Cryptographic +description=Signs text with a certificate and returns the signature. +[SIGN] +declaration=numeric_expression +category=Mathematical +description=Returns the positive (+1), zero (0), or negative (-1) sign of the specified expression. +[SIN] +declaration=float_expression +category=Mathematical +description=Returns the trigonometric sine of the specified angle, in radians, and in an approximate numeric, float, expression. +[SMALLDATETIMEFROMPARTS] +declaration=year,month,day,hour,minute +category=Date and time +description=Returns a smalldatetime value for the specified date and time. +[SOUNDEX] +declaration=character_expression +category=String +description=Returns a four-character (SOUNDEX) code to evaluate the similarity of two strings. +[SPACE] +declaration=integer_expression +category=String +description=Returns a string of repeated spaces. +[SQL_VARIANT_PROPERTY] +declaration=expression,property +category=Data type +description=Returns the base data type and other information about a sql_variant value. +[SQRT] +declaration=float_expression +category=Mathematical +description=Returns the square root of the specified float value. +[SQUARE] +declaration=float_expression +category=Mathematical +description=Returns the square of the specified float value. +[STATS_DATE] +declaration=object_id,stats_id +category=Metadata +description=Returns the date of the most recent update for statistics on a table or indexed view. +[STDEVP] +declaration=ALL,DISTINCT,expression,OVER ( [ partition_by_clause ] order_by_clause) +category=Aggregate +description=Returns the statistical standard deviation for the population for all values in the specified expression. +[STDEV] +declaration=ALL,DISTINCT,expression,OVER ( [ partition_by_clause ] order_by_clause) +category=Aggregate +description=Returns the statistical standard deviation of all values in the specified expression. +[STRING_AGG] +declaration=expression,separator,<order_clause> +category=String +description=Concatenates the values of string expressions and places separator values between them. The separator is not added at the end of string. +[STRING_ESCAPE] +declaration=text,type +category=String +description=Escapes special characters in texts and returns text with escaped characters. STRING_ESCAPE is a deterministic function. +[STRING_SPLIT] +declaration=string,separator +category=String +description=Splits the character expression using specified separator. +[STR] +declaration=float_expression,length,decimal +category=String +description=Returns character data converted from numeric data. +[STUFF] +declaration=character_expression,start,length,replaceWith_expression +category=String +description=The STUFF function inserts a string into another string. It deletes a specified length of characters in the first string at the start position and then inserts the second string into the first string at the start position. +[SUBSTRING] +declaration=expression,start,length +category=String +description=Returns part of a character, binary, text, or image expression in SQL Server. +[SUM] +declaration=ALL,DISTINCT,expression,OVER ( [ partition_by_clause ] order_by_clause) +category=Aggregate +description=Returns the sum of all the values, or only the DISTINCT values, in the expression. SUM can be used with numeric columns only. Null values are ignored. +[SUSER_ID] +declaration=' login ' +category=Security +description=Returns the login identification number of the user. +[SUSER_NAME] +declaration=server_user_id +category=Security +description=Returns the login identification name of the user. +[SUSER_SID] +declaration=' login ',Param2 +category=Security +description=Returns the security identification number (SID) for the specified login name. +[SUSER_SNAME] +declaration=server_user_sid +category=Security +description=Returns the login name associated with a security identification number (SID). +[SWITCHOFFSET] +declaration=DATETIMEOFFSET,time_zone +category=Date and time +description=Returns a datetimeoffset value that is changed from the stored time zone offset to a specified new time zone offset. +[SYMKEYPROPERTY] +declaration=Key_ID,'algorithm_desc' +category=Cryptographic +description=Returns the algorithm of a symmetric key created from an EKM module. +[SYSDATETIMEOFFSET] +declaration= +category=Date and time +description=Returns a datetimeoffset(7) value that contains the date and time of the computer on which the instance of SQL Server is running. The time zone offset is included. +[SYSDATETIME] +declaration= +category=Date and time +description=Returns a datetime2(7) value that contains the date and time of the computer on which the instance of SQL Server is running. +[SYSTEM_USER] +declaration= +category=Security +description=Allows a system-supplied value for the current login to be inserted into a table when no default value is specified. +[SYSUTCDATETIME] +declaration= +category=Date and time +description=Returns a datetime2 value that contains the date and time of the computer on which the instance of SQL Server is running. The date and time is returned as UTC time (Coordinated Universal Time). The fractional second precision specification has a range from 1 to 7 digits. The default precision is 7 digits. +[TAN] +declaration=float_expression +category=Mathematical +description=Returns the tangent of the input expression. +[TERTIARY_WEIGHTS] +declaration=non_Unicode_character_string_expression +category=Collation +description=For each character in a non-Unicode string expression - defined with a SQL tertiary collation - this function returns a binary string of weights. +[TEXTPTR] +declaration=column +category=Text and Image +description=Returns the text-pointer value that corresponds to a text, ntext, or image column in varbinary format. The retrieved text pointer value can be used in READTEXT, WRITETEXT, and UPDATETEXT statements. +[TEXTVALID] +declaration=table,column,text_ptr +category=Text and Image +description=A text, ntext, or image function that checks whether a specific text pointer is valid. +[TIMEFROMPARTS] +declaration=hour,minute,seconds,fractions,precision +category=Date and time +description=Returns a time value for the specified time and with the specified precision. +[TODATETIMEOFFSET] +declaration=expression +category=Date and time +description=Returns a datetimeoffset value that is translated from a datetime2 expression. +[TRANSLATE] +declaration=inputString,characters,translations +category=String +description=Returns the string provided as a first argument after some characters specified in the second argument are translated into a destination set of characters. +[TRIGGER_NESTLEVEL] +declaration=object_id,' trigger_type ',' trigger_event_category ' +category=Trigger +description=Returns the number of triggers executed for the statement that fired the trigger. TRIGGER_NESTLEVEL is used in DML and DDL triggers to determine the current level of nesting. +[TRIM] +declaration=characters,string +category=String +description=Removes the space character char(32) or other specified characters from the start or end of a string. +[TRY_CAST] +declaration=expression,data_type,length +category=Conversion +description=Returns a value cast to the specified data type if the cast succeeds; otherwise, returns null. +[TRY_CONVERT] +declaration=data_type [ ( length ) ],expression,style +category=Conversion +description=Returns a value cast to the specified data type if the cast succeeds; otherwise, returns null. +[TRY_PARSE] +declaration=string_value,data_type,culture +category=Conversion +description=Returns the result of an expression, translated to the requested data type, or null if the cast fails in SQL Server. Use TRY_PARSE only for converting from string to date/time and number types. +[TYPEPROPERTY] +declaration=type,property +category=Metadata +description=Returns information about a data type. +[TYPE_ID] +declaration=type_name +category=Metadata +description=Returns the ID for a specified data type name. +[TYPE_NAME] +declaration=type_id +category=Metadata +description=Returns the unqualified type name of a specified type ID. +[UNICODE] +declaration=' ncharacter_expression ' +category=String +description=Returns the integer value, as defined by the Unicode standard, for the first character of the input expression. +[UPDATE] +declaration=column +category=Trigger +description=Returns a Boolean value that indicates whether an INSERT or UPDATE attempt was made on a specified column of a table or view. UPDATE() is used anywhere inside the body of a Transact-SQL INSERT or UPDATE trigger to test whether the trigger should execute certain actions. +[UPPER] +declaration=character_expression +category=String +description=Returns a character expression with lowercase character data converted to uppercase. +[USER] +declaration= +category=Security +description=Allows a system-supplied value for the database user name of the current user to be inserted into a table when no default value is specified. +[USER_ID] +declaration=user +category=Security +description=Returns the identification number for a database user. +[USER_NAME] +declaration=id +category=Security +description=Returns a database user name from a specified identification number. +[VARP] +declaration=ALL,DISTINCT,expression,OVER ( [ partition_by_clause ] order_by_clause) +category=Aggregate +description=Returns the statistical variance for the population for all values in the specified expression. +[VAR] +declaration=ALL,DISTINCT,expression,OVER ( [ partition_by_clause ] order_by_clause) +category=Aggregate +description=Returns the statistical variance of all values in the specified expression. May be followed by the OVER clause. +[VERIFYSIGNEDBYASYMKEY] +declaration=Asym_Key_ID,clear_text,signature +category=Cryptographic +description=Tests whether digitally signed data has been changed since it was signed. +[VERIFYSIGNEDBYCERT] +declaration=Cert_ID,signed_data,signature +category=Cryptographic +description=Tests whether digitally signed data has been changed since it was signed. +[XACT_STATE] +declaration= +category=System +description=Is a scalar function that reports the user transaction state of a current running request. XACT_STATE indicates whether the request has an active user transaction, and whether the transaction is capable of being committed. +[YEAR] +declaration=date +category=Date and time +description=Returns an integer that represents the year of the specified date. \ No newline at end of file diff --git a/out/functions-mysql.ini b/out/functions-mysql.ini new file mode 100644 index 000000000..9a47ab288 --- /dev/null +++ b/out/functions-mysql.ini @@ -0,0 +1,1340 @@ +[ABS] +declaration=X +category=Numeric Functions +description=Returns the absolute value of X.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/mathematical-functions.html +[ACOS] +declaration=X +category=Numeric Functions +description=Returns the arc cosine of X, that is, the value whose cosine is X.\nReturns NULL if X is not in the range -1 to 1.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/mathematical-functions.html +[ADDDATE] +declaration=date,INTERVAL expr unit +category=Date and Time Functions +description=When invoked with the INTERVAL form of the second argument, ADDDATE()\nis a synonym for DATE_ADD(). The related function SUBDATE() is a\nsynonym for DATE_SUB(). For information on the INTERVAL unit argument,\nsee the discussion for DATE_ADD().\n\nmysql> SELECT DATE_ADD('2008-01-02', INTERVAL 31 DAY);\n -> '2008-02-02'\nmysql> SELECT ADDDATE('2008-01-02', INTERVAL 31 DAY);\n -> '2008-02-02'\n\nWhen invoked with the days form of the second argument, MySQL treats it\nas an integer number of days to be added to expr.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/date-and-time-functions.html +[ADDTIME] +declaration=expr1,expr2 +category=Date and Time Functions +description=ADDTIME() adds expr2 to expr1 and returns the result. expr1 is a time\nor datetime expression, and expr2 is a time expression.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/date-and-time-functions.html +[AES_DECRYPT] +declaration=crypt_str,key_str[,init_vector] +category=Encryption Functions +description=This function decrypts data using the official AES (Advanced Encryption\nStandard) algorithm. For more information, see the description of\nAES_ENCRYPT().\n\nThe optional initialization vector argument, init_vector, is available\nas of MySQL 5.7.4. As of that version, statements that use\nAES_DECRYPT() are unsafe for statement-based replication and cannot be\nstored in the query cache.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/encryption-functions.html +[AES_ENCRYPT] +declaration=str,key_str[,init_vector] +category=Encryption Functions +description=AES_ENCRYPT() and AES_DECRYPT() implement encryption and decryption of\ndata using the official AES (Advanced Encryption Standard) algorithm,\npreviously known as "Rijndael." The AES standard permits various key\nlengths. By default these functions implement AES with a 128-bit key\nlength. As of MySQL 5.7.4, key lengths of 196 or 256 bits can be used,\nas described later. The key length is a trade off between performance\nand security.\n\nAES_ENCRYPT() encrypts the string str using the key string key_str and\nreturns a binary string containing the encrypted output. AES_DECRYPT()\ndecrypts the encrypted string crypt_str using the key string key_str\nand returns the original plaintext string. If either function argument\nis NULL, the function returns NULL.\n\nThe str and crypt_str arguments can be any length, and padding is\nautomatically added to str so it is a multiple of a block as required\nby block-based algorithms such as AES. This padding is automatically\nremoved by the AES_DECRYPT() function. The length of crypt_str can be\ncalculated using this formula:\n\n16 * (trunc(string_length / 16) + 1)\n\nFor a key length of 128 bits, the most secure way to pass a key to the\nkey_str argument is to create a truly random 128-bit value and pass it\nas a binary value. For example:\n\nINSERT INTO t\nVALUES (1,AES_ENCRYPT('text',UNHEX('F3229A0B371ED2D9441B830D21A390C3')));\n\nA passphrase can be used to generate an AES key by hashing the\npassphrase. For example:\n\nINSERT INTO t VALUES (1,AES_ENCRYPT('text', SHA2('My secret passphrase',512)));\n\nDo not pass a password or passphrase directly to crypt_str, hash it\nfirst. Previous versions of this documentation suggested the former\napproach, but it is no longer recommended as the examples shown here\nare more secure.\n\nIf AES_DECRYPT() detects invalid data or incorrect padding, it returns\nNULL. However, it is possible for AES_DECRYPT() to return a non-NULL\nvalue (possibly garbage) if the input data or the key is invalid.\n\nAs of MySQL 5.7.4, AES_ENCRYPT() and AES_DECRYPT() permit control of\nthe block encryption mode and take an optional init_vector\ninitialization vector argument:\n\no The block_encryption_mode system variable controls the mode for\n block-based encryption algorithms. Its default value is aes-128-ecb,\n which signifies encryption using a key length of 128 bits and ECB\n ... +[ANY_VALUE] +declaration=arg +category=Miscellaneous Functions +description=This function is useful for GROUP BY queries when the\nONLY_FULL_GROUP_BY SQL mode is enabled, for cases when MySQL rejects a\nquery that you know is valid for reasons that MySQL cannot determine.\nThe function return value and type are the same as the return value and\ntype of its argument, but the function result is not checked for the\nONLY_FULL_GROUP_BY SQL mode.\n\nFor example, if name is a nonindexed column, the following query fails\nwith ONLY_FULL_GROUP_BY enabled:\n\nmysql> SELECT name, address, MAX(age) FROM t GROUP BY name;\nERROR 1055 (42000): Expression #2 of SELECT list is not in GROUP\nBY clause and contains nonaggregated column 'mydb.t.address' which\nis not functionally dependent on columns in GROUP BY clause; this\nis incompatible with sql_mode=only_full_group_by\n\nThe failure occurs because address is a nonaggregated column that is\nneither named among GROUP BY columns nor functionally dependent on\nthem. As a result, the address value for rows within each name group is\nnondeterministic. There are multiple ways to cause MySQL to accept the\nquery:\n\no Alter the table to make name a primary key or a unique NOT NULL\n column. This enables MySQL to determine that address is functionally\n dependent on name; that is, address is uniquely determined by name.\n (This technique is inapplicable if NULL must be permitted as a valid\n name value.)\n\no Use ANY_VALUE() to refer to address:\n\nSELECT name, ANY_VALUE(address), MAX(age) FROM t GROUP BY name;\n\n In this case, MySQL ignores the nondeterminism of address values\n within each name group and accepts the query. This may be useful if\n you simply do not care which value of a nonaggregated column is\n chosen for each group. ANY_VALUE() is not an aggregate function,\n unlike functions such as SUM() or COUNT(). It simply acts to suppress\n the test for nondeterminism.\n\no Disable ONLY_FULL_GROUP_BY. This is equivalent to using ANY_VALUE()\n with ONLY_FULL_GROUP_BY enabled, as described in the previous item.\n\nANY_VALUE() is also useful if functional dependence exists between\ncolumns but MySQL cannot determine it. The following query is valid\nbecause age is functionally dependent on the grouping column age-1, but\nMySQL cannot tell that and rejects the query with ONLY_FULL_GROUP_BY\nenabled:\n\nSELECT age FROM t GROUP BY age-1;\n\n ... +[AREA] +declaration=poly +category=Polygon properties +description=ST_Area() and Area() are synonyms. For more information, see the\ndescription of ST_Area().\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/gis-polygon-property-functions.html +[ASBINARY] +declaration=g +category=WKB +description=Converts a value in internal geometry format to its WKB representation\nand returns the binary result.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/gis-format-conversion-functions.html +[ASCII] +declaration=str +category=String Functions +description=Returns the numeric value of the leftmost character of the string str.\nReturns 0 if str is the empty string. Returns NULL if str is NULL.\nASCII() works for 8-bit characters.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/string-functions.html +[ASIN] +declaration=X +category=Numeric Functions +description=Returns the arc sine of X, that is, the value whose sine is X. Returns\nNULL if X is not in the range -1 to 1.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/mathematical-functions.html +[ASTEXT] +declaration=g +category=WKT +description=Converts a value in internal geometry format to its WKT representation\nand returns the string result.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/gis-format-conversion-functions.html +[ATAN] +declaration=X +category=Numeric Functions +description=Returns the arc tangent of X, that is, the value whose tangent is X.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/mathematical-functions.html +[ATAN2] +declaration=Y,X +category=Numeric Functions +description=Returns the arc tangent of the two variables X and Y. It is similar to\ncalculating the arc tangent of Y / X, except that the signs of both\narguments are used to determine the quadrant of the result.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/mathematical-functions.html +[AVG] +declaration=[DISTINCT] expr +category=Functions and Modifiers for Use with GROUP BY +description=Returns the average value of expr. The DISTINCT option can be used to\nreturn the average of the distinct values of expr.\n\nAVG() returns NULL if there were no matching rows.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/group-by-functions.html +[BENCHMARK] +declaration=count,expr +category=Information Functions +description=The BENCHMARK() function executes the expression expr repeatedly count\ntimes. It may be used to time how quickly MySQL processes the\nexpression. The result value is always 0. The intended use is from\nwithin the mysql client, which reports query execution times:\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/information-functions.html +[BIGINT] +declaration=M +category=Data Types +description=A large integer. The signed range is -9223372036854775808 to\n9223372036854775807. The unsigned range is 0 to 18446744073709551615.\n\nSERIAL is an alias for BIGINT UNSIGNED NOT NULL AUTO_INCREMENT UNIQUE.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/numeric-type-overview.html +[BIN] +declaration=N +category=String Functions +description=Returns a string representation of the binary value of N, where N is a\nlonglong (BIGINT) number. This is equivalent to CONV(N,10,2). Returns\nNULL if N is NULL.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/string-functions.html +[BINARY] +declaration=M +category=Data Types +description=The BINARY type is similar to the CHAR type, but stores binary byte\nstrings rather than nonbinary character strings. M represents the\ncolumn length in bytes.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/string-type-overview.html +[BIT] +declaration=M +category=Data Types +description=A bit-field type. M indicates the number of bits per value, from 1 to\n64. The default is 1 if M is omitted.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/numeric-type-overview.html +[BIT_AND] +declaration=expr +category=Functions and Modifiers for Use with GROUP BY +description=Returns the bitwise AND of all bits in expr. The calculation is\nperformed with 64-bit (BIGINT) precision.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/group-by-functions.html +[BIT_COUNT] +declaration=N +category=Bit Functions +description=Returns the number of bits that are set in the argument N.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/bit-functions.html +[BIT_LENGTH] +declaration=str +category=String Functions +description=Returns the length of the string str in bits.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/string-functions.html +[BIT_OR] +declaration=expr +category=Functions and Modifiers for Use with GROUP BY +description=Returns the bitwise OR of all bits in expr. The calculation is\nperformed with 64-bit (BIGINT) precision.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/group-by-functions.html +[BIT_XOR] +declaration=expr +category=Functions and Modifiers for Use with GROUP BY +description=Returns the bitwise XOR of all bits in expr. The calculation is\nperformed with 64-bit (BIGINT) precision.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/group-by-functions.html +[BLOB] +declaration=M +category=Data Types +description=A BLOB column with a maximum length of 65,535 (216 - 1) bytes. Each\nBLOB value is stored using a 2-byte length prefix that indicates the\nnumber of bytes in the value.\n\nAn optional length M can be given for this type. If this is done, MySQL\ncreates the column as the smallest BLOB type large enough to hold\nvalues M bytes long.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/string-type-overview.html +[BUFFER] +declaration=g,d +category=GeometryCollection properties +description=Returns a geometry that represents all points whose distance from the\ngeometry value g is less than or equal to a distance of d.\n\nBuffer() supports negative distances for polygons, multipolygons, and\ngeometry collections containing polygons or multipolygons. For point,\nmultipoint, linestring, multilinestring, and geometry collections not\ncontaining any polygons or multipolygons, Buffer() with a negative\ndistance returns NULL.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/spatial-operator-functions.html +[CAST] +declaration=expr AS type +category=String Functions +description=The CAST() function takes an expression of any type and produces a\nresult value of a specified type, similar to CONVERT(). See the\ndescription of CONVERT() for more information.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/cast-functions.html +[CEIL] +declaration=X +category=Numeric Functions +description=CEIL() is a synonym for CEILING().\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/mathematical-functions.html +[CEILING] +declaration=X +category=Numeric Functions +description=Returns the smallest integer value not less than X.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/mathematical-functions.html +[CENTROID] +declaration=mpoly +category=Polygon properties +description=ST_Centroid() and Centroid() are synonyms. For more information, see\nthe description of ST_Centroid().\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/gis-multipolygon-property-functions.html +[CHAR] +declaration=M +category=Data Types +description=collation_name]\n\nA fixed-length string that is always right-padded with spaces to the\nspecified length when stored. M represents the column length in\ncharacters. The range of M is 0 to 255. If M is omitted, the length is\n1.\n\n*Note*: Trailing spaces are removed when CHAR values are retrieved\nunless the PAD_CHAR_TO_FULL_LENGTH SQL mode is enabled.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/string-type-overview.html +[CHARACTER_LENGTH] +declaration=str +category=String Functions +description=CHARACTER_LENGTH() is a synonym for CHAR_LENGTH().\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/string-functions.html +[CHARSET] +declaration=str +category=Information Functions +description=Returns the character set of the string argument.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/information-functions.html +[CHAR_LENGTH] +declaration=str +category=String Functions +description=Returns the length of the string str, measured in characters. A\nmultibyte character counts as a single character. This means that for a\nstring containing five 2-byte characters, LENGTH() returns 10, whereas\nCHAR_LENGTH() returns 5.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/string-functions.html +[COALESCE] +declaration=value,... +category=Comparison operators +description=Returns the first non-NULL value in the list, or NULL if there are no\nnon-NULL values.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/comparison-operators.html +[COERCIBILITY] +declaration=str +category=Information Functions +description=Returns the collation coercibility value of the string argument.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/information-functions.html +[COLLATION] +declaration=str +category=Information Functions +description=Returns the collation of the string argument.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/information-functions.html +[COMPRESS] +declaration=string_to_compress +category=Encryption Functions +description=Compresses a string and returns the result as a binary string. This\nfunction requires MySQL to have been compiled with a compression\nlibrary such as zlib. Otherwise, the return value is always NULL. The\ncompressed string can be uncompressed with UNCOMPRESS().\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/encryption-functions.html +[CONCAT] +declaration=str1,str2,... +category=String Functions +description=Returns the string that results from concatenating the arguments. May\nhave one or more arguments. If all arguments are nonbinary strings, the\nresult is a nonbinary string. If the arguments include any binary\nstrings, the result is a binary string. A numeric argument is converted\nto its equivalent nonbinary string form.\n\nCONCAT() returns NULL if any argument is NULL.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/string-functions.html +[CONCAT_WS] +declaration=separator,str1,str2,... +category=String Functions +description=CONCAT_WS() stands for Concatenate With Separator and is a special form\nof CONCAT(). The first argument is the separator for the rest of the\narguments. The separator is added between the strings to be\nconcatenated. The separator can be a string, as can the rest of the\narguments. If the separator is NULL, the result is NULL.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/string-functions.html +[CONNECTION_ID] +declaration= +category=Information Functions +description=Returns the connection ID (thread ID) for the connection. Every\nconnection has an ID that is unique among the set of currently\nconnected clients.\n\nThe value returned by CONNECTION_ID() is the same type of value as\ndisplayed in the ID column of the INFORMATION_SCHEMA.PROCESSLIST table,\nthe Id column of SHOW PROCESSLIST output, and the PROCESSLIST_ID column\nof the Performance Schema threads table.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/information-functions.html +[CONTAINS] +declaration=g1,g2 +category=Geometry relations +description=Returns 1 or 0 to indicate whether g1 completely contains g2. This\ntests the opposite relationship as Within().\n\nThis function is deprecated as of MySQL 5.7.6 and will be removed in a\nfuture MySQL release. Use MBRContains() instead.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/spatial-relation-functions-mbr.html +[CONV] +declaration=N,from_base,to_base +category=Numeric Functions +description=Converts numbers between different number bases. Returns a string\nrepresentation of the number N, converted from base from_base to base\nto_base. Returns NULL if any argument is NULL. The argument N is\ninterpreted as an integer, but may be specified as an integer or a\nstring. The minimum base is 2 and the maximum base is 36. If to_base is\na negative number, N is regarded as a signed number. Otherwise, N is\ntreated as unsigned. CONV() works with 64-bit precision.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/mathematical-functions.html +[CONVERT] +declaration=expr,type +category=String Functions +description=The CONVERT() and CAST() functions take an expression of any type and\nproduce a result value of a specified type.\n\nThe type for the result can be one of the following values:\n\no BINARY[(N)]\n\no CHAR[(N)]\n\no DATE\n\no DATETIME\n\no DECIMAL[(M[,D])]\n\no SIGNED [INTEGER]\n\no TIME\n\no UNSIGNED [INTEGER]\n\nBINARY produces a string with the BINARY data type. See\nhttp://dev.mysql.com/doc/refman/5.7/en/binary-varbinary.html for a\ndescription of how this affects comparisons. If the optional length N\nis given, BINARY(N) causes the cast to use no more than N bytes of the\nargument. Values shorter than N bytes are padded with 0x00 bytes to a\nlength of N.\n\nCHAR(N) causes the cast to use no more than N characters of the\nargument.\n\nCAST() and CONVERT(... USING ...) are standard SQL syntax. The\nnon-USING form of CONVERT() is ODBC syntax.\n\nCONVERT() with USING is used to convert data between different\ncharacter sets. In MySQL, transcoding names are the same as the\ncorresponding character set names. For example, this statement converts\nthe string 'abc' in the default character set to the corresponding\nstring in the utf8 character set:\n\nSELECT CONVERT('abc' USING utf8);\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/cast-functions.html +[CONVERT_TZ] +declaration=dt,from_tz,to_tz +category=Date and Time Functions +description=CONVERT_TZ() converts a datetime value dt from the time zone given by\nfrom_tz to the time zone given by to_tz and returns the resulting\nvalue. Time zones are specified as described in\nhttp://dev.mysql.com/doc/refman/5.7/en/time-zone-support.html. This\nfunction returns NULL if the arguments are invalid.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/date-and-time-functions.html +[CONVEXHULL] +declaration=g +category=GeometryCollection properties +description=ST_ConvexHull() and ConvexHull() are synonyms. For more information,\nsee the description of ST_ConvexHull().\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/spatial-operator-functions.html +[COS] +declaration=X +category=Numeric Functions +description=Returns the cosine of X, where X is given in radians.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/mathematical-functions.html +[COT] +declaration=X +category=Numeric Functions +description=Returns the cotangent of X.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/mathematical-functions.html +[COUNT] +declaration=expr +category=Functions and Modifiers for Use with GROUP BY +description=Returns a count of the number of non-NULL values of expr in the rows\nretrieved by a SELECT statement. The result is a BIGINT value.\n\nCOUNT() returns 0 if there were no matching rows.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/group-by-functions.html +[CRC32] +declaration=expr +category=Numeric Functions +description=Computes a cyclic redundancy check value and returns a 32-bit unsigned\nvalue. The result is NULL if the argument is NULL. The argument is\nexpected to be a string and (if possible) is treated as one if it is\nnot.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/mathematical-functions.html +[CROSSES] +declaration=g1,g2 +category=Geometry relations +description=Returns 1 if g1 spatially crosses g2. Returns NULL if g1 is a Polygon\nor a MultiPolygon, or if g2 is a Point or a MultiPoint. Otherwise,\nreturns 0.\n\nThe term spatially crosses denotes a spatial relation between two given\ngeometries that has the following properties:\n\no The two geometries intersect\n\no Their intersection results in a geometry that has a dimension that is\n one less than the maximum dimension of the two given geometries\n\no Their intersection is not equal to either of the two given geometries\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/spatial-relation-functions-mbr.html +[CURDATE] +declaration= +category=Date and Time Functions +description=Returns the current date as a value in 'YYYY-MM-DD' or YYYYMMDD format,\ndepending on whether the function is used in a string or numeric\ncontext.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/date-and-time-functions.html +[CURRENT_DATE] +declaration= +category=Date and Time Functions +description=CURRENT_DATE and CURRENT_DATE() are synonyms for CURDATE().\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/date-and-time-functions.html +[CURRENT_TIME] +declaration=[fsp] +category=Date and Time Functions +description=CURRENT_TIME and CURRENT_TIME() are synonyms for CURTIME().\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/date-and-time-functions.html +[CURRENT_TIMESTAMP] +declaration=[fsp] +category=Date and Time Functions +description=CURRENT_TIMESTAMP and CURRENT_TIMESTAMP() are synonyms for NOW().\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/date-and-time-functions.html +[CURRENT_USER] +declaration= +category=Information Functions +description=Returns the user name and host name combination for the MySQL account\nthat the server used to authenticate the current client. This account\ndetermines your access privileges. The return value is a string in the\nutf8 character set.\n\nThe value of CURRENT_USER() can differ from the value of USER().\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/information-functions.html +[CURTIME] +declaration=[fsp] +category=Date and Time Functions +description=Returns the current time as a value in 'HH:MM:SS' or HHMMSS format,\ndepending on whether the function is used in a string or numeric\ncontext. The value is expressed in the current time zone.\n\nIf the fsp argument is given to specify a fractional seconds precision\nfrom 0 to 6, the return value includes a fractional seconds part of\nthat many digits.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/date-and-time-functions.html +[DATABASE] +declaration= +category=Information Functions +description=Returns the default (current) database name as a string in the utf8\ncharacter set. If there is no default database, DATABASE() returns\nNULL. Within a stored routine, the default database is the database\nthat the routine is associated with, which is not necessarily the same\nas the database that is the default in the calling context.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/information-functions.html +[DATEDIFF] +declaration=expr1,expr2 +category=Date and Time Functions +description=DATEDIFF() returns expr1 - expr2 expressed as a value in days from one\ndate to the other. expr1 and expr2 are date or date-and-time\nexpressions. Only the date parts of the values are used in the\ncalculation.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/date-and-time-functions.html +[DATETIME] +declaration=fsp +category=Data Types +description=A date and time combination. The supported range is '1000-01-01\n00:00:00.000000' to '9999-12-31 23:59:59.999999'. MySQL displays\nDATETIME values in 'YYYY-MM-DD HH:MM:SS[.fraction]' format, but permits\nassignment of values to DATETIME columns using either strings or\nnumbers.\n\nAn optional fsp value in the range from 0 to 6 may be given to specify\nfractional seconds precision. A value of 0 signifies that there is no\nfractional part. If omitted, the default precision is 0.\n\nAutomatic initialization and updating to the current date and time for\nDATETIME columns can be specified using DEFAULT and ON UPDATE column\ndefinition clauses, as described in\nhttp://dev.mysql.com/doc/refman/5.7/en/timestamp-initialization.html.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/date-and-time-type-overview.html +[DATE_ADD] +declaration=date,INTERVAL expr unit +category=Date and Time Functions +description=These functions perform date arithmetic. The date argument specifies\nthe starting date or datetime value. expr is an expression specifying\nthe interval value to be added or subtracted from the starting date.\nexpr is a string; it may start with a "-" for negative intervals. unit\nis a keyword indicating the units in which the expression should be\ninterpreted.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/date-and-time-functions.html +[DATE_FORMAT] +declaration=date,format +category=Date and Time Functions +description=Formats the date value according to the format string.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/date-and-time-functions.html +[DATE_SUB] +declaration=date,INTERVAL expr unit +category=Date and Time Functions +description=See the description for DATE_ADD().\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/date-and-time-functions.html +[DAY] +declaration=date +category=Date and Time Functions +description=DAY() is a synonym for DAYOFMONTH().\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/date-and-time-functions.html +[DAYNAME] +declaration=date +category=Date and Time Functions +description=Returns the name of the weekday for date. The language used for the\nname is controlled by the value of the lc_time_names system variable\n(http://dev.mysql.com/doc/refman/5.7/en/locale-support.html).\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/date-and-time-functions.html +[DAYOFMONTH] +declaration=date +category=Date and Time Functions +description=Returns the day of the month for date, in the range 1 to 31, or 0 for\ndates such as '0000-00-00' or '2008-00-00' that have a zero day part.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/date-and-time-functions.html +[DAYOFWEEK] +declaration=date +category=Date and Time Functions +description=Returns the weekday index for date (1 = Sunday, 2 = Monday, ..., 7 =\nSaturday). These index values correspond to the ODBC standard.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/date-and-time-functions.html +[DAYOFYEAR] +declaration=date +category=Date and Time Functions +description=Returns the day of the year for date, in the range 1 to 366.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/date-and-time-functions.html +[DEC] +declaration=M[,D] +category=Data Types +description=[ZEROFILL], FIXED[(M[,D])] [UNSIGNED] [ZEROFILL]\n\nThese types are synonyms for DECIMAL. The FIXED synonym is available\nfor compatibility with other database systems.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/numeric-type-overview.html +[DECIMAL] +declaration=M[,D] +category=Data Types +description=A packed "exact" fixed-point number. M is the total number of digits\n(the precision) and D is the number of digits after the decimal point\n(the scale). The decimal point and (for negative numbers) the "-" sign\nare not counted in M. If D is 0, values have no decimal point or\nfractional part. The maximum number of digits (M) for DECIMAL is 65.\nThe maximum number of supported decimals (D) is 30. If D is omitted,\nthe default is 0. If M is omitted, the default is 10.\n\nUNSIGNED, if specified, disallows negative values.\n\nAll basic calculations (+, -, *, /) with DECIMAL columns are done with\na precision of 65 digits.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/numeric-type-overview.html +[DECODE] +declaration=crypt_str,pass_str +category=Encryption Functions +description=DECODE() decrypts the encrypted string crypt_str using pass_str as the\npassword. crypt_str should be a string returned from ENCODE().\n\n*Note*: The ENCODE() and DECODE() functions are deprecated in MySQL\n5.7, will be removed in a future MySQL release, and should no longer be\nused. Consider using AES_ENCRYPT() and AES_DECRYPT() instead.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/encryption-functions.html +[DEFAULT] +declaration=col_name +category=Miscellaneous Functions +description=Returns the default value for a table column. An error results if the\ncolumn has no default value.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/miscellaneous-functions.html +[DEGREES] +declaration=X +category=Numeric Functions +description=Returns the argument X, converted from radians to degrees.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/mathematical-functions.html +[DES_DECRYPT] +declaration=crypt_str[,key_str] +category=Encryption Functions +description=Decrypts a string encrypted with DES_ENCRYPT(). If an error occurs,\nthis function returns NULL.\n\nThis function works only if MySQL has been configured with SSL support.\nSee http://dev.mysql.com/doc/refman/5.7/en/ssl-connections.html.\n\nIf no key_str argument is given, DES_DECRYPT() examines the first byte\nof the encrypted string to determine the DES key number that was used\nto encrypt the original string, and then reads the key from the DES key\nfile to decrypt the message. For this to work, the user must have the\nSUPER privilege. The key file can be specified with the --des-key-file\nserver option.\n\nIf you pass this function a key_str argument, that string is used as\nthe key for decrypting the message.\n\nIf the crypt_str argument does not appear to be an encrypted string,\nMySQL returns the given crypt_str.\n\n*Note*: The DES_ENCRYPT() and DES_DECRYPT() functions are deprecated as\nof MySQL 5.7.6, will be removed in a future MySQL release, and should\nno longer be used. Consider using AES_ENCRYPT() and AES_DECRYPT()\ninstead.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/encryption-functions.html +[DES_ENCRYPT] +declaration=str[,{key_num|key_str}] +category=Encryption Functions +description=Encrypts the string with the given key using the Triple-DES algorithm.\n\nThis function works only if MySQL has been configured with SSL support.\nSee http://dev.mysql.com/doc/refman/5.7/en/ssl-connections.html.\n\nThe encryption key to use is chosen based on the second argument to\nDES_ENCRYPT(), if one was given. With no argument, the first key from\nthe DES key file is used. With a key_num argument, the given key number\n(0 to 9) from the DES key file is used. With a key_str argument, the\ngiven key string is used to encrypt str.\n\nThe key file can be specified with the --des-key-file server option.\n\nThe return string is a binary string where the first character is\nCHAR(128 | key_num). If an error occurs, DES_ENCRYPT() returns NULL.\n\nThe 128 is added to make it easier to recognize an encrypted key. If\nyou use a string key, key_num is 127.\n\nThe string length for the result is given by this formula:\n\nnew_len = orig_len + (8 - (orig_len % 8)) + 1\n\nEach line in the DES key file has the following format:\n\nkey_num des_key_str\n\nEach key_num value must be a number in the range from 0 to 9. Lines in\nthe file may be in any order. des_key_str is the string that is used to\nencrypt the message. There should be at least one space between the\nnumber and the key. The first key is the default key that is used if\nyou do not specify any key argument to DES_ENCRYPT().\n\nYou can tell MySQL to read new key values from the key file with the\nFLUSH DES_KEY_FILE statement. This requires the RELOAD privilege.\n\nOne benefit of having a set of default keys is that it gives\napplications a way to check for the existence of encrypted column\nvalues, without giving the end user the right to decrypt those values.\n\n*Note*: The DES_ENCRYPT() and DES_DECRYPT() functions are deprecated as\nof MySQL 5.7.6, will be removed in a future MySQL release, and should\nno longer be used. Consider using AES_ENCRYPT() and AES_DECRYPT()\ninstead.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/encryption-functions.html +[DIMENSION] +declaration=g +category=Geometry properties +description=Returns the inherent dimension of the geometry value g. The result can\nbe -1, 0, 1, or 2. The meaning of these values is given in\nhttp://dev.mysql.com/doc/refman/5.7/en/gis-class-geometry.html.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/gis-general-property-functions.html +[DISJOINT] +declaration=g1,g2 +category=Geometry relations +description=Returns 1 or 0 to indicate whether g1 is spatially disjoint from (does\nnot intersect) g2.\n\nThis function is deprecated as of MySQL 5.7.6 and will be removed in a\nfuture MySQL release. Use MBRDisjoint() instead.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/spatial-relation-functions-mbr.html +[DISTANCE] +declaration=g1,g2 +category=Geometry relations +description=ST_Distance() and Distance() are synonyms. For more information, see\nthe description of ST_Distance().\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/spatial-relation-functions-mbr.html +[DOUBLE] +declaration=M,D +category=Data Types +description=A normal-size (double-precision) floating-point number. Permissible\nvalues are -1.7976931348623157E+308 to -2.2250738585072014E-308, 0, and\n2.2250738585072014E-308 to 1.7976931348623157E+308. These are the\ntheoretical limits, based on the IEEE standard. The actual range might\nbe slightly smaller depending on your hardware or operating system.\n\nM is the total number of digits and D is the number of digits following\nthe decimal point. If M and D are omitted, values are stored to the\nlimits permitted by the hardware. A double-precision floating-point\nnumber is accurate to approximately 15 decimal places.\n\nUNSIGNED, if specified, disallows negative values.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/numeric-type-overview.html +[ELT] +declaration=N,str1,str2,str3,... +category=String Functions +description=ELT() returns the Nth element of the list of strings: str1 if N = 1,\nstr2 if N = 2, and so on. Returns NULL if N is less than 1 or greater\nthan the number of arguments. ELT() is the complement of FIELD().\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/string-functions.html +[ENCODE] +declaration=str,pass_str +category=Encryption Functions +description=ENCODE() encrypts str using pass_str as the password. The result is a\nbinary string of the same length as str. To decrypt the result, use\nDECODE().\n\n*Note*: The ENCODE() and DECODE() functions are deprecated in MySQL\n5.7, will be removed in a future MySQL release, and should no longer be\nused.\n\nIf you still need to use ENCODE(), a salt value must be used with it to\nreduce risk. For example:\n\nENCODE('plaintext', CONCAT('my_random_salt','my_secret_password'))\n\nA new random salt value must be used whenever a password is updated.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/encryption-functions.html +[ENCRYPT] +declaration=str[,salt] +category=Encryption Functions +description=Encrypts str using the Unix crypt() system call and returns a binary\nstring. The salt argument must be a string with at least two characters\nor the result will be NULL. If no salt argument is given, a random\nvalue is used.\n\n*Note*: The ENCRYPT() function is deprecated as of MySQL 5.7.6, will be\nremoved in a future MySQL release, and should no longer be used.\nConsider using AES_ENCRYPT() instead.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/encryption-functions.html +[ENDPOINT] +declaration=ls +category=LineString properties +description=Returns the Point that is the endpoint of the LineString value ls.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/gis-linestring-property-functions.html +[ENUM] +declaration='value1','value2',... +category=Data Types +description=collation_name]\n\nAn enumeration. A string object that can have only one value, chosen\nfrom the list of values 'value1', 'value2', ..., NULL or the special ''\nerror value. ENUM values are represented internally as integers.\n\nAn ENUM column can have a maximum of 65,535 distinct elements. (The\npractical limit is less than 3000.) A table can have no more than 255\nunique element list definitions among its ENUM and SET columns\nconsidered as a group. For more information on these limits, see\nhttp://dev.mysql.com/doc/refman/5.7/en/limits-frm-file.html.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/string-type-overview.html +[ENVELOPE] +declaration=g +category=Geometry properties +description=ST_Envelope() and Envelope() are synonyms. For more information, see\nthe description of ST_Envelope().\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/gis-general-property-functions.html +[EQUALS] +declaration=g1,g2 +category=Geometry relations +description=Returns 1 or 0 to indicate whether g1 is spatially equal to g2.\n\nThis function is deprecated as of MySQL 5.7.6 and will be removed in a\nfuture MySQL release. Use MBREquals() instead.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/spatial-relation-functions-mbr.html +[EXP] +declaration=X +category=Numeric Functions +description=Returns the value of e (the base of natural logarithms) raised to the\npower of X. The inverse of this function is LOG() (using a single\nargument only) or LN().\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/mathematical-functions.html +[EXPORT_SET] +declaration=bits,on,off[,separator[,number_of_bits]] +category=String Functions +description=Returns a string such that for every bit set in the value bits, you get\nan on string and for every bit not set in the value, you get an off\nstring. Bits in bits are examined from right to left (from low-order to\nhigh-order bits). Strings are added to the result from left to right,\nseparated by the separator string (the default being the comma\ncharacter ","). The number of bits examined is given by number_of_bits,\nwhich has a default of 64 if not specified. number_of_bits is silently\nclipped to 64 if larger than 64. It is treated as an unsigned integer,\nso a value of -1 is effectively the same as 64.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/string-functions.html +[EXTERIORRING] +declaration=poly +category=Polygon properties +description=Returns the exterior ring of the Polygon value poly as a LineString.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/gis-polygon-property-functions.html +[EXTRACT] +declaration=unit FROM date +category=Date and Time Functions +description=The EXTRACT() function uses the same kinds of unit specifiers as\nDATE_ADD() or DATE_SUB(), but extracts parts from the date rather than\nperforming date arithmetic.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/date-and-time-functions.html +[EXTRACTVALUE] +declaration=xml_frag, xpath_expr +category=String Functions +description=ExtractValue() takes two string arguments, a fragment of XML markup\nxml_frag and an XPath expression xpath_expr (also known as a locator);\nit returns the text (CDATA) of the first text node which is a child of\nthe elements or elements matched by the XPath expression.\n\nUsing this function is the equivalent of performing a match using the\nxpath_expr after appending /text(). In other words,\nExtractValue('Sakila', '/a/b') and\nExtractValue('Sakila', '/a/b/text()') produce the same\nresult.\n\nIf multiple matches are found, the content of the first child text node\nof each matching element is returned (in the order matched) as a\nsingle, space-delimited string.\n\nIf no matching text node is found for the expression (including the\nimplicit /text())---for whatever reason, as long as xpath_expr is\nvalid, and xml_frag consists of elements which are properly nested and\nclosed---an empty string is returned. No distinction is made between a\nmatch on an empty element and no match at all. This is by design.\n\nIf you need to determine whether no matching element was found in\nxml_frag or such an element was found but contained no child text\nnodes, you should test the result of an expression that uses the XPath\ncount() function. For example, both of these statements return an empty\nstring, as shown here:\n\nmysql> SELECT ExtractValue('', '/a/b');\n+-------------------------------------+\n| ExtractValue('', '/a/b') |\n+-------------------------------------+\n| |\n+-------------------------------------+\n1 row in set (0.00 sec)\n\nmysql> SELECT ExtractValue('', '/a/b');\n+-------------------------------------+\n| ExtractValue('', '/a/b') |\n+-------------------------------------+\n| |\n+-------------------------------------+\n1 row in set (0.00 sec)\n\nHowever, you can determine whether there was actually a matching\nelement using the following:\n\nmysql> SELECT ExtractValue('', 'count(/a/b)');\n+-------------------------------------+\n| ExtractValue('', 'count(/a/b)') |\n+-------------------------------------+\n ... +[FIELD] +declaration=str,str1,str2,str3,... +category=String Functions +description=Returns the index (position) of str in the str1, str2, str3, ... list.\nReturns 0 if str is not found.\n\nIf all arguments to FIELD() are strings, all arguments are compared as\nstrings. If all arguments are numbers, they are compared as numbers.\nOtherwise, the arguments are compared as double.\n\nIf str is NULL, the return value is 0 because NULL fails equality\ncomparison with any value. FIELD() is the complement of ELT().\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/string-functions.html +[FIND_IN_SET] +declaration=str,strlist +category=String Functions +description=Returns a value in the range of 1 to N if the string str is in the\nstring list strlist consisting of N substrings. A string list is a\nstring composed of substrings separated by "," characters. If the first\nargument is a constant string and the second is a column of type SET,\nthe FIND_IN_SET() function is optimized to use bit arithmetic. Returns\n0 if str is not in strlist or if strlist is the empty string. Returns\nNULL if either argument is NULL. This function does not work properly\nif the first argument contains a comma (",") character.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/string-functions.html +[FLOAT] +declaration=M,D +category=Data Types +description=A small (single-precision) floating-point number. Permissible values\nare -3.402823466E+38 to -1.175494351E-38, 0, and 1.175494351E-38 to\n3.402823466E+38. These are the theoretical limits, based on the IEEE\nstandard. The actual range might be slightly smaller depending on your\nhardware or operating system.\n\nM is the total number of digits and D is the number of digits following\nthe decimal point. If M and D are omitted, values are stored to the\nlimits permitted by the hardware. A single-precision floating-point\nnumber is accurate to approximately 7 decimal places.\n\nUNSIGNED, if specified, disallows negative values.\n\nUsing FLOAT might give you some unexpected problems because all\ncalculations in MySQL are done with double precision. See\nhttp://dev.mysql.com/doc/refman/5.7/en/no-matching-rows.html.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/numeric-type-overview.html +[FLOOR] +declaration=X +category=Numeric Functions +description=Returns the largest integer value not greater than X.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/mathematical-functions.html +[FORMAT] +declaration=X,D[,locale] +category=String Functions +description=Formats the number X to a format like '#,###,###.##', rounded to D\ndecimal places, and returns the result as a string. If D is 0, the\nresult has no decimal point or fractional part.\n\nThe optional third parameter enables a locale to be specified to be\nused for the result number's decimal point, thousands separator, and\ngrouping between separators. Permissible locale values are the same as\nthe legal values for the lc_time_names system variable (see\nhttp://dev.mysql.com/doc/refman/5.7/en/locale-support.html). If no\nlocale is specified, the default is 'en_US'.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/string-functions.html +[FOUND_ROWS] +declaration= +category=Information Functions +description=A SELECT statement may include a LIMIT clause to restrict the number of\nrows the server returns to the client. In some cases, it is desirable\nto know how many rows the statement would have returned without the\nLIMIT, but without running the statement again. To obtain this row\ncount, include a SQL_CALC_FOUND_ROWS option in the SELECT statement,\nand then invoke FOUND_ROWS() afterward:\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/information-functions.html +[FROM_DAYS] +declaration=N +category=Date and Time Functions +description=Given a day number N, returns a DATE value.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/date-and-time-functions.html +[FROM_UNIXTIME] +declaration=unix_timestamp +category=Date and Time Functions +description=Returns a representation of the unix_timestamp argument as a value in\n'YYYY-MM-DD HH:MM:SS' or YYYYMMDDHHMMSS format, depending on whether\nthe function is used in a string or numeric context. The value is\nexpressed in the current time zone. unix_timestamp is an internal\ntimestamp value such as is produced by the UNIX_TIMESTAMP() function.\n\nIf format is given, the result is formatted according to the format\nstring, which is used the same way as listed in the entry for the\nDATE_FORMAT() function.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/date-and-time-functions.html +[GEOMCOLLFROMTEXT] +declaration=wkt[,srid] +category=WKT +description=Constructs a GeometryCollection value using its WKT representation and\nSRID.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/gis-wkt-functions.html +[GEOMCOLLFROMWKB] +declaration=wkb[,srid] +category=WKB +description=Constructs a GeometryCollection value using its WKB representation and\nSRID.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/gis-wkb-functions.html +[GEOMETRYCOLLECTION] +declaration=g1,g2,... +category=Geometry constructors +description=Constructs a GeometryCollection.\n\nAs of MySQL 5.7.5, GeometryCollection() returns all the proper\ngeometries contained in the argument even if a nonsupported geometry is\npresent. Before 5.7.5, if the argument contains a nonsupported\ngeometry, the return value is NULL.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/gis-mysql-specific-functions.html +[GEOMETRYN] +declaration=gc,N +category=GeometryCollection properties +description=Returns the N-th geometry in the GeometryCollection value gc.\nGeometries are numbered beginning with 1.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/gis-geometrycollection-property-functions.html +[GEOMETRYTYPE] +declaration=g +category=Geometry properties +description=Returns a binary string indicating the name of the geometry type of\nwhich the geometry instance g is a member. The name corresponds to one\nof the instantiable Geometry subclasses.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/gis-general-property-functions.html +[GEOMFROMTEXT] +declaration=wkt[,srid] +category=WKT +description=Constructs a geometry value of any type using its WKT representation\nand SRID.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/gis-wkt-functions.html +[GEOMFROMWKB] +declaration=wkb[,srid] +category=WKB +description=Constructs a geometry value of any type using its WKB representation\nand SRID.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/gis-wkb-functions.html +[GET_FORMAT] +declaration={DATE|TIME|DATETIME}, {'EUR'|'USA'|'JIS'|'ISO'|'INTERNAL'} +category=Date and Time Functions +description=Returns a format string. This function is useful in combination with\nthe DATE_FORMAT() and the STR_TO_DATE() functions.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/date-and-time-functions.html +[GET_LOCK] +declaration=str,timeout +category=Miscellaneous Functions +description=Tries to obtain a lock with a name given by the string str, using a\ntimeout of timeout seconds. A negative timeout value means infinite\ntimeout.\n\nReturns 1 if the lock was obtained successfully, 0 if the attempt timed\nout (for example, because another client has previously locked the\nname), or NULL if an error occurred (such as running out of memory or\nthe thread was killed with mysqladmin kill). If you have a lock\nobtained with GET_LOCK(), it is released when you execute\nRELEASE_LOCK() or your connection terminates (either normally or\nabnormally). Lock release may also occur with another call to\nGET_LOCK():\n\no Before 5.7.5, only a single simultaneous lock can be acquired and\n GET_LOCK() releases any existing lock.\n\no In MySQL 5.7.5, GET_LOCK() was reimplemented using the metadata\n locking (MDL) subsystem and its capabilities were extended. Multiple\n simultaneous locks can be acquired and GET_LOCK() does not release\n any existing locks. It is even possible for a given session to\n acquire multiple locks for the same name. Other sessions cannot\n acquire a lock with that name until the acquiring session releases\n all its locks for the name.\n\n As a result of the MDL reimplementation, locks acquired with\n GET_LOCK() appear in the Performance Schema metadata_locks table. The\n OBJECT_TYPE column says USER LEVEL LOCK and the OBJECT_NAME column\n indicates the lock name. Also, the capability of acquiring multiple\n locks introduces the possibility of deadlock among clients. An\n ER_USER_LOCK_DEADLOCK error is returned when this occurs.\n\nThe difference in lock acquisition behavior as of MySQL 5.7.5 can be\nseen by the following example. Suppose that you execute these\nstatements:\n\nSELECT GET_LOCK('lock1',10);\nSELECT GET_LOCK('lock2',10);\nSELECT RELEASE_LOCK('lock2');\nSELECT RELEASE_LOCK('lock1');\n\nIn MySQL 5.7.5 or later, the second GET_LOCK() acquires a second lock\nand both RELEASE_LOCK() calls return 1 (success). Before MySQL 5.7.5,\nthe second GET_LOCK() releases the first lock ('lock1') and the second\nRELEASE_LOCK() returns NULL (failure) because there is no 'lock1' to\nrelease.\n\nMySQL 5.7.5 and later enforces a maximum length on lock names of 64\ncharacters. Previously, no limit was enforced.\n\nLocks obtained with GET_LOCK() do not interact with transactions. That\n ... +[GLENGTH] +declaration=ls +category=LineString properties +description=Returns a double-precision number indicating the length of the\nLineString value ls in its associated spatial reference.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/gis-linestring-property-functions.html +[GREATEST] +declaration=value1,value2,... +category=Comparison operators +description=With two or more arguments, returns the largest (maximum-valued)\nargument. The arguments are compared using the same rules as for\nLEAST().\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/comparison-operators.html +[GROUP_CONCAT] +declaration=expr +category=Functions and Modifiers for Use with GROUP BY +description=This function returns a string result with the concatenated non-NULL\nvalues from a group. It returns NULL if there are no non-NULL values.\nThe full syntax is as follows:\n\nGROUP_CONCAT([DISTINCT] expr [,expr ...]\n [ORDER BY {unsigned_integer | col_name | expr}\n [ASC | DESC] [,col_name ...]]\n [SEPARATOR str_val])\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/group-by-functions.html +[GTID_SUBSET] +declaration=subset,set +category=MBR +description=Given two sets of global transaction IDs subset and set, returns true\nif all GTIDs in subset are also in set. Returns false otherwise.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/gtid-functions.html +[GTID_SUBTRACT] +declaration=set,subset +category=MBR +description=Given two sets of global transaction IDs subset and set, returns only\nthose GTIDs from set that are not in subset.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/gtid-functions.html +[HEX] +declaration=str +category=String Functions +description=For a string argument str, HEX() returns a hexadecimal string\nrepresentation of str where each byte of each character in str is\nconverted to two hexadecimal digits. (Multibyte characters therefore\nbecome more than two digits.) The inverse of this operation is\nperformed by the UNHEX() function.\n\nFor a numeric argument N, HEX() returns a hexadecimal string\nrepresentation of the value of N treated as a longlong (BIGINT) number.\nThis is equivalent to CONV(N,10,16). The inverse of this operation is\nperformed by CONV(HEX(N),16,10).\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/string-functions.html +[HOUR] +declaration=time +category=Date and Time Functions +description=Returns the hour for time. The range of the return value is 0 to 23 for\ntime-of-day values. However, the range of TIME values actually is much\nlarger, so HOUR can return values greater than 23.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/date-and-time-functions.html +[IFNULL] +declaration=expr1,expr2 +category=Control flow functions +description=If expr1 is not NULL, IFNULL() returns expr1; otherwise it returns\nexpr2. IFNULL() returns a numeric or string value, depending on the\ncontext in which it is used.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/control-flow-functions.html +[IN] +declaration=value,... +category=Comparison operators +description=Returns 1 if expr is equal to any of the values in the IN list, else\nreturns 0. If all values are constants, they are evaluated according to\nthe type of expr and sorted. The search for the item then is done using\na binary search. This means IN is very quick if the IN value list\nconsists entirely of constants. Otherwise, type conversion takes place\naccording to the rules described in\nhttp://dev.mysql.com/doc/refman/5.7/en/type-conversion.html, but\napplied to all the arguments.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/comparison-operators.html +[INET6_ATON] +declaration=expr +category=Miscellaneous Functions +description=Given an IPv6 or IPv4 network address as a string, returns a binary\nstring that represents the numeric value of the address in network byte\norder (big endian). Because numeric-format IPv6 addresses require more\nbytes than the largest integer type, the representation returned by\nthis function has the VARBINARY data type: VARBINARY(16) for IPv6\naddresses and VARBINARY(4) for IPv4 addresses. If the argument is not a\nvalid address, INET6_ATON() returns NULL.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/miscellaneous-functions.html +[INET6_NTOA] +declaration=expr +category=Miscellaneous Functions +description=Given an IPv6 or IPv4 network address represented in numeric form as a\nbinary string, returns the string representation of the address as a\nnonbinary string in the connection character set. If the argument is\nnot a valid address, INET6_NTOA() returns NULL.\n\nINET6_NTOA() has these properties:\n\no It does not use operating system functions to perform conversions,\n thus the output string is platform independent.\n\no The return string has a maximum length of 39 (4 x 8 + 7). Given this\n statement:\n\nCREATE TABLE t AS SELECT INET6_NTOA(expr) AS c1;\n\n The resulting table would have this definition:\n\nCREATE TABLE t (c1 VARCHAR(39) CHARACTER SET utf8 DEFAULT NULL);\n\no The return string uses lowercase letters for IPv6 addresses.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/miscellaneous-functions.html +[INET_ATON] +declaration=expr +category=Miscellaneous Functions +description=Given the dotted-quad representation of an IPv4 network address as a\nstring, returns an integer that represents the numeric value of the\naddress in network byte order (big endian). INET_ATON() returns NULL if\nit does not understand its argument.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/miscellaneous-functions.html +[INET_NTOA] +declaration=expr +category=Miscellaneous Functions +description=Given a numeric IPv4 network address in network byte order, returns the\ndotted-quad string representation of the address as a nonbinary string\nin the connection character set. INET_NTOA() returns NULL if it does\nnot understand its argument.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/miscellaneous-functions.html +[INSTR] +declaration=str,substr +category=String Functions +description=Returns the position of the first occurrence of substring substr in\nstring str. This is the same as the two-argument form of LOCATE(),\nexcept that the order of the arguments is reversed.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/string-functions.html +[INT] +declaration=M +category=Data Types +description=A normal-size integer. The signed range is -2147483648 to 2147483647.\nThe unsigned range is 0 to 4294967295.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/numeric-type-overview.html +[INTEGER] +declaration=M +category=Data Types +description=This type is a synonym for INT.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/numeric-type-overview.html +[INTERIORRINGN] +declaration=poly,N +category=Polygon properties +description=Returns the N-th interior ring for the Polygon value poly as a\nLineString. Rings are numbered beginning with 1.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/gis-polygon-property-functions.html +[INTERSECTS] +declaration=g1,g2 +category=Geometry relations +description=Returns 1 or 0 to indicate whether g1 spatially intersects g2.\n\nThis function is deprecated as of MySQL 5.7.6 and will be removed in a\nfuture MySQL release. Use MBRIntersects() instead.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/spatial-relation-functions-mbr.html +[INTERVAL] +declaration=N,N1,N2,N3,... +category=Comparison operators +description=Returns 0 if N < N1, 1 if N < N2 and so on or -1 if N is NULL. All\narguments are treated as integers. It is required that N1 < N2 < N3 <\n... < Nn for this function to work correctly. This is because a binary\nsearch is used (very fast).\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/comparison-operators.html +[ISCLOSED] +declaration=ls +category=LineString properties +description=Returns 1 if the LineString value ls is closed (that is, its\nStartPoint() and EndPoint() values are the same) and is simple (does\nnot pass through the same point more than once). Returns 0 if ls is not\nclosed, and -1 if it is NULL.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/gis-linestring-property-functions.html +[ISEMPTY] +declaration=g +category=Geometry properties +description=This function is a placeholder that returns 0 for any valid geometry\nvalue, 1 for any invalid geometry value or NULL.\n\nMySQL does not support GIS EMPTY values such as POINT EMPTY.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/gis-general-property-functions.html +[ISNULL] +declaration=expr +category=Comparison operators +description=If expr is NULL, ISNULL() returns 1, otherwise it returns 0.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/comparison-operators.html +[ISSIMPLE] +declaration=g +category=Geometry properties +description=Returns 1 if the geometry value g has no anomalous geometric points,\nsuch as self-intersection or self-tangency. IsSimple() returns 0 if the\nargument is not simple, and NULL if it is NULL.\n\nThe description of each instantiable geometric class given earlier in\nthe chapter includes the specific conditions that cause an instance of\nthat class to be classified as not simple. (See [HELP Geometry\nhierarchy].)\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/gis-general-property-functions.html +[IS_FREE_LOCK] +declaration=str +category=Miscellaneous Functions +description=Checks whether the lock named str is free to use (that is, not locked).\nReturns 1 if the lock is free (no one is using the lock), 0 if the lock\nis in use, and NULL if an error occurs (such as an incorrect argument).\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/miscellaneous-functions.html +[IS_IPV4] +declaration=expr +category=Miscellaneous Functions +description=Returns 1 if the argument is a valid IPv4 address specified as a\nstring, 0 otherwise.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/miscellaneous-functions.html +[IS_IPV4_COMPAT] +declaration=expr +category=Miscellaneous Functions +description=This function takes an IPv6 address represented in numeric form as a\nbinary string, as returned by INET6_ATON(). It returns 1 if the\nargument is a valid IPv4-compatible IPv6 address, 0 otherwise.\nIPv4-compatible addresses have the form ::ipv4_address.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/miscellaneous-functions.html +[IS_IPV4_MAPPED] +declaration=expr +category=Miscellaneous Functions +description=This function takes an IPv6 address represented in numeric form as a\nbinary string, as returned by INET6_ATON(). It returns 1 if the\nargument is a valid IPv4-mapped IPv6 address, 0 otherwise. IPv4-mapped\naddresses have the form ::ffff:ipv4_address.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/miscellaneous-functions.html +[IS_IPV6] +declaration=expr +category=Miscellaneous Functions +description=Returns 1 if the argument is a valid IPv6 address specified as a\nstring, 0 otherwise. This function does not consider IPv4 addresses to\nbe valid IPv6 addresses.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/miscellaneous-functions.html +[IS_USED_LOCK] +declaration=str +category=Miscellaneous Functions +description=Checks whether the lock named str is in use (that is, locked). If so,\nit returns the connection identifier of the client that holds the lock.\nOtherwise, it returns NULL.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/miscellaneous-functions.html +[JOIN] +declaration=t2, t3, t4 +category=Data Manipulation +description=ON (t2.a=t1.a AND t3.b=t1.b AND t4.c=t1.c)\n\nis equivalent to:\n\nSELECT * FROM t1 LEFT JOIN (t2 CROSS JOIN t3 CROSS JOIN t4)\n ON (t2.a=t1.a AND t3.b=t1.b AND t4.c=t1.c)\n\nIn MySQL, JOIN, CROSS JOIN, and INNER JOIN are syntactic equivalents\n(they can replace each other). In standard SQL, they are not\nequivalent. INNER JOIN is used with an ON clause, CROSS JOIN is used\notherwise.\n\nIn general, parentheses can be ignored in join expressions containing\nonly inner join operations. MySQL also supports nested joins (see\nhttp://dev.mysql.com/doc/refman/5.7/en/nested-join-optimization.html).\n\nIndex hints can be specified to affect how the MySQL optimizer makes\nuse of indexes. For more information, see\nhttp://dev.mysql.com/doc/refman/5.7/en/index-hints.html.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/join.html +[LAST_DAY] +declaration=date +category=Date and Time Functions +description=Takes a date or datetime value and returns the corresponding value for\nthe last day of the month. Returns NULL if the argument is invalid.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/date-and-time-functions.html +[LAST_INSERT_ID] +declaration= +category=Information Functions +description=With no argument, LAST_INSERT_ID() returns a BIGINT UNSIGNED (64-bit)\nvalue representing the first automatically generated value successfully\ninserted for an AUTO_INCREMENT column as a result of the most recently\nexecuted INSERT statement. The value of LAST_INSERT_ID() remains\nunchanged if no rows are successfully inserted.\n\nWith an argument, LAST_INSERT_ID() returns an unsigned integer.\n\nFor example, after inserting a row that generates an AUTO_INCREMENT\nvalue, you can get the value like this:\n\nmysql> SELECT LAST_INSERT_ID();\n -> 195\n\nThe currently executing statement does not affect the value of\nLAST_INSERT_ID(). Suppose that you generate an AUTO_INCREMENT value\nwith one statement, and then refer to LAST_INSERT_ID() in a\nmultiple-row INSERT statement that inserts rows into a table with its\nown AUTO_INCREMENT column. The value of LAST_INSERT_ID() will remain\nstable in the second statement; its value for the second and later rows\nis not affected by the earlier row insertions. (However, if you mix\nreferences to LAST_INSERT_ID() and LAST_INSERT_ID(expr), the effect is\nundefined.)\n\nIf the previous statement returned an error, the value of\nLAST_INSERT_ID() is undefined. For transactional tables, if the\nstatement is rolled back due to an error, the value of LAST_INSERT_ID()\nis left undefined. For manual ROLLBACK, the value of LAST_INSERT_ID()\nis not restored to that before the transaction; it remains as it was at\nthe point of the ROLLBACK.\n\nPrior to MySQL 5.7.3, this function was not replicated correctly if\nreplication filtering rules were in use. (Bug #17234370, Bug #69861)\n\nWithin the body of a stored routine (procedure or function) or a\ntrigger, the value of LAST_INSERT_ID() changes the same way as for\nstatements executed outside the body of these kinds of objects. The\neffect of a stored routine or trigger upon the value of\nLAST_INSERT_ID() that is seen by following statements depends on the\nkind of routine:\n\no If a stored procedure executes statements that change the value of\n LAST_INSERT_ID(), the changed value is seen by statements that follow\n the procedure call.\n\no For stored functions and triggers that change the value, the value is\n restored when the function or trigger ends, so following statements\n will not see a changed value.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/information-functions.html +[LCASE] +declaration=str +category=String Functions +description=LCASE() is a synonym for LOWER().\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/string-functions.html +[LEAST] +declaration=value1,value2,... +category=Comparison operators +description=With two or more arguments, returns the smallest (minimum-valued)\nargument. The arguments are compared using the following rules:\n\no If any argument is NULL, the result is NULL. No comparison is needed.\n\no If the return value is used in an INTEGER context or all arguments\n are integer-valued, they are compared as integers.\n\no If the return value is used in a REAL context or all arguments are\n real-valued, they are compared as reals.\n\no If the arguments comprise a mix of numbers and strings, they are\n compared as numbers.\n\no If any argument is a nonbinary (character) string, the arguments are\n compared as nonbinary strings.\n\no In all other cases, the arguments are compared as binary strings.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/comparison-operators.html +[LEFT] +declaration=str,len +category=String Functions +description=Returns the leftmost len characters from the string str, or NULL if any\nargument is NULL.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/string-functions.html +[LENGTH] +declaration=str +category=String Functions +description=Returns the length of the string str, measured in bytes. A multibyte\ncharacter counts as multiple bytes. This means that for a string\ncontaining five 2-byte characters, LENGTH() returns 10, whereas\nCHAR_LENGTH() returns 5.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/string-functions.html +[LINEFROMTEXT] +declaration=wkt[,srid] +category=WKT +description=Constructs a LineString value using its WKT representation and SRID.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/gis-wkt-functions.html +[LINEFROMWKB] +declaration=wkb[,srid] +category=WKB +description=Constructs a LineString value using its WKB representation and SRID.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/gis-wkb-functions.html +[LINESTRING] +declaration=pt1,pt2,... +category=Geometry constructors +description=Constructs a LineString value from a number of Point or WKB Point\narguments. If the number of arguments is less than two, the return\nvalue is NULL.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/gis-mysql-specific-functions.html +[LN] +declaration=X +category=Numeric Functions +description=Returns the natural logarithm of X; that is, the base-e logarithm of X.\nAs of MySQL 5.7.4, if X is less than or equal to 0.0E0, the error\n"Invalid argument for logarithm" is reported in strict SQL mode, and\nNULL is returned in non-strict mode. Before MySQL 5.7.4, if X is less\nthan or equal to 0.0E0, NULL is returned.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/mathematical-functions.html +[LOAD_FILE] +declaration=file_name +category=String Functions +description=Reads the file and returns the file contents as a string. To use this\nfunction, the file must be located on the server host, you must specify\nthe full path name to the file, and you must have the FILE privilege.\nThe file must be readable by all and its size less than\nmax_allowed_packet bytes. If the secure_file_priv system variable is\nset to a nonempty directory name, the file to be loaded must be located\nin that directory.\n\nIf the file does not exist or cannot be read because one of the\npreceding conditions is not satisfied, the function returns NULL.\n\nThe character_set_filesystem system variable controls interpretation of\nfile names that are given as literal strings.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/string-functions.html +[LOCALTIME] +declaration=[fsp] +category=Date and Time Functions +description=LOCALTIME and LOCALTIME() are synonyms for NOW().\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/date-and-time-functions.html +[LOCALTIMESTAMP] +declaration=[fsp] +category=Date and Time Functions +description=LOCALTIMESTAMP and LOCALTIMESTAMP() are synonyms for NOW().\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/date-and-time-functions.html +[LOCATE] +declaration=substr,str +category=String Functions +description=The first syntax returns the position of the first occurrence of\nsubstring substr in string str. The second syntax returns the position\nof the first occurrence of substring substr in string str, starting at\nposition pos. Returns 0 if substr is not in str.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/string-functions.html +[LOG] +declaration=X +category=Numeric Functions +description=If called with one parameter, this function returns the natural\nlogarithm of X. As of MySQL 5.7.4, if X is less than or equal to 0.0E0,\nthe error "Invalid argument for logarithm" is reported in strict SQL\nmode, and NULL is returned in non-strict mode. Before MySQL 5.7.4, if X\nis less than or equal to 0.0E0, NULL is returned.\n\nThe inverse of this function (when called with a single argument) is\nthe EXP() function.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/mathematical-functions.html +[LOG10] +declaration=X +category=Numeric Functions +description=Returns the base-10 logarithm of X. As of MySQL 5.7.4, if X is less\nthan or equal to 0.0E0, the error "Invalid argument for logarithm" is\nreported in strict SQL mode, and NULL is returned in non-strict mode.\nBefore MySQL 5.7.4, if X is less than or equal to 0.0E0, NULL is\nreturned.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/mathematical-functions.html +[LOG2] +declaration=X +category=Numeric Functions +description=Returns the base-2 logarithm of X. As of MySQL 5.7.4, if X is less than\nor equal to 0.0E0, the error "Invalid argument for logarithm" is\nreported in strict SQL mode, and NULL is returned in non-strict mode.\nBefore MySQL 5.7.4, if X is less than or equal to 0.0E0, NULL is\nreturned.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/mathematical-functions.html +[LOWER] +declaration=str +category=String Functions +description=Returns the string str with all characters changed to lowercase\naccording to the current character set mapping. The default is latin1\n(cp1252 West European).\n\nmysql> SELECT LOWER('QUADRATICALLY');\n -> 'quadratically'\n\nLOWER() (and UPPER()) are ineffective when applied to binary strings\n(BINARY, VARBINARY, BLOB). To perform lettercase conversion, convert\nthe string to a nonbinary string:\n\nmysql> SET @str = BINARY 'New York';\nmysql> SELECT LOWER(@str), LOWER(CONVERT(@str USING latin1));\n+-------------+-----------------------------------+\n| LOWER(@str) | LOWER(CONVERT(@str USING latin1)) |\n+-------------+-----------------------------------+\n| New York | new york |\n+-------------+-----------------------------------+\n\nFor Unicode character sets, LOWER() and UPPER() work accounting to\nUnicode Collation Algorithm (UCA) 5.2.0 for xxx_unicode_520_ci\ncollations and for language-specific collations that are derived from\nthem. For other Unicode collations, LOWER() and UPPER() work accounting\nto Unicode Collation Algorithm (UCA) 4.0.0. See\nhttp://dev.mysql.com/doc/refman/5.7/en/charset-unicode-sets.html.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/string-functions.html +[LPAD] +declaration=str,len,padstr +category=String Functions +description=Returns the string str, left-padded with the string padstr to a length\nof len characters. If str is longer than len, the return value is\nshortened to len characters.\n\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/string-functions.html +[LTRIM] +declaration=str +category=String Functions +description=Returns the string str with leading space characters removed.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/string-functions.html +[MAKEDATE] +declaration=year,dayofyear +category=Date and Time Functions +description=Returns a date, given year and day-of-year values. dayofyear must be\ngreater than 0 or the result is NULL.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/date-and-time-functions.html +[MAKETIME] +declaration=hour,minute,second +category=Date and Time Functions +description=Returns a time value calculated from the hour, minute, and second\narguments.\n\nThe second argument can have a fractional part.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/date-and-time-functions.html +[MAKE_SET] +declaration=bits,str1,str2,... +category=String Functions +description=Returns a set value (a string containing substrings separated by ","\ncharacters) consisting of the strings that have the corresponding bit\nin bits set. str1 corresponds to bit 0, str2 to bit 1, and so on. NULL\nvalues in str1, str2, ... are not appended to the result.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/string-functions.html +[MASTER_POS_WAIT] +declaration=log_name,log_pos[,timeout] +category=Miscellaneous Functions +description=This function is useful for control of master/slave synchronization. It\nblocks until the slave has read and applied all updates up to the\nspecified position in the master log. The return value is the number of\nlog events the slave had to wait for to advance to the specified\nposition. The function returns NULL if the slave SQL thread is not\nstarted, the slave's master information is not initialized, the\narguments are incorrect, or an error occurs. It returns -1 if the\ntimeout has been exceeded. If the slave SQL thread stops while\nMASTER_POS_WAIT() is waiting, the function returns NULL. If the slave\nis past the specified position, the function returns immediately.\n\nIf a timeout value is specified, MASTER_POS_WAIT() stops waiting when\ntimeout seconds have elapsed. timeout must be greater than 0; a zero or\nnegative timeout means no timeout.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/miscellaneous-functions.html +[MAX] +declaration=[DISTINCT] expr +category=Functions and Modifiers for Use with GROUP BY +description=Returns the maximum value of expr. MAX() may take a string argument; in\nsuch cases, it returns the maximum string value. See\nhttp://dev.mysql.com/doc/refman/5.7/en/mysql-indexes.html. The DISTINCT\nkeyword can be used to find the maximum of the distinct values of expr,\nhowever, this produces the same result as omitting DISTINCT.\n\nMAX() returns NULL if there were no matching rows.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/group-by-functions.html +[MBRCONTAINS] +declaration=g1,g2 +category=MBR +description=Returns 1 or 0 to indicate whether the minimum bounding rectangle of g1\ncontains the minimum bounding rectangle of g2. This tests the opposite\nrelationship as MBRWithin().\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/spatial-relation-functions-mysql-specific.html +[MBRCOVEREDBY] +declaration=g1,g2 +category=MBR +description=Returns 1 or 0 to indicate whether the minimum bounding rectangle of g1\nis covered by the minimum bounding rectangle of g2. This tests the\nopposite relationship as MBRCovers().\n\nMBRCoveredBy() and MBRCovers() handle their arguments and return a\nvalue as follows:\n\no Return NULL if either argument is NULL or an empty geometry\n\no Return ER_GIS_INVALID_DATA if either argument is not a valid geometry\n byte string (SRID plus WKB value)\n\no Otherwise, return non-NULL\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/spatial-relation-functions-mysql-specific.html +[MBRCOVERS] +declaration=g1,g2 +category=MBR +description=Returns 1 or 0 to indicate whether the minimum bounding rectangle of g1\ncovers the minimum bounding rectangle of g2. This tests the opposite\nrelationship as MBRCoveredBy(). See the description of MBRCoveredBy()\nfor examples and information about argument handling.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/spatial-relation-functions-mysql-specific.html +[MBRDISJOINT] +declaration=g1,g2 +category=MBR +description=Returns 1 or 0 to indicate whether the minimum bounding rectangles of\nthe two geometries g1 and g2 are disjoint (do not intersect).\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/spatial-relation-functions-mysql-specific.html +[MBREQUAL] +declaration=g1,g2 +category=MBR +description=Returns 1 or 0 to indicate whether the minimum bounding rectangles of\nthe two geometries g1 and g2 are the same.\n\nThis function is deprecated as of MySQL 5.7.6 and will be removed in a\nfuture MySQL release. Use MBREquals() instead.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/spatial-relation-functions-mysql-specific.html +[MBREQUALS] +declaration=g1,g2 +category=MBR +description=Returns 1 or 0 to indicate whether the minimum bounding rectangles of\nthe two geometries g1 and g2 are the same.\n\nThis function was added in MySQL 5.7.6. It should be used in preference\nto MBREqual().\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/spatial-relation-functions-mysql-specific.html +[MBRINTERSECTS] +declaration=g1,g2 +category=MBR +description=Returns 1 or 0 to indicate whether the minimum bounding rectangles of\nthe two geometries g1 and g2 intersect.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/spatial-relation-functions-mysql-specific.html +[MBROVERLAPS] +declaration=g1,g2 +category=MBR +description=Returns 1 or 0 to indicate whether the minimum bounding rectangles of\nthe two geometries g1 and g2 overlap. The term spatially overlaps is\nused if two geometries intersect and their intersection results in a\ngeometry of the same dimension but not equal to either of the given\ngeometries.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/spatial-relation-functions-mysql-specific.html +[MBRTOUCHES] +declaration=g1,g2 +category=MBR +description=Returns 1 or 0 to indicate whether the minimum bounding rectangles of\nthe two geometries g1 and g2 touch. Two geometries spatially touch if\nthe interiors of the geometries do not intersect, but the boundary of\none of the geometries intersects either the boundary or the interior of\nthe other.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/spatial-relation-functions-mysql-specific.html +[MBRWITHIN] +declaration=g1,g2 +category=MBR +description=Returns 1 or 0 to indicate whether the minimum bounding rectangle of g1\nis within the minimum bounding rectangle of g2. This tests the opposite\nrelationship as MBRContains().\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/spatial-relation-functions-mysql-specific.html +[MD5] +declaration=str +category=Encryption Functions +description=Calculates an MD5 128-bit checksum for the string. The value is\nreturned as a string of 32 hex digits, or NULL if the argument was\nNULL. The return value can, for example, be used as a hash key. See the\nnotes at the beginning of this section about storing hash values\nefficiently.\n\nThe return value is a nonbinary string in the connection character set.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/encryption-functions.html +[MEDIUMINT] +declaration=M +category=Data Types +description=A medium-sized integer. The signed range is -8388608 to 8388607. The\nunsigned range is 0 to 16777215.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/numeric-type-overview.html +[MICROSECOND] +declaration=expr +category=Date and Time Functions +description=Returns the microseconds from the time or datetime expression expr as a\nnumber in the range from 0 to 999999.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/date-and-time-functions.html +[MID] +declaration=str,pos,len +category=String Functions +description=MID(str,pos,len) is a synonym for SUBSTRING(str,pos,len).\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/string-functions.html +[MIN] +declaration=[DISTINCT] expr +category=Functions and Modifiers for Use with GROUP BY +description=Returns the minimum value of expr. MIN() may take a string argument; in\nsuch cases, it returns the minimum string value. See\nhttp://dev.mysql.com/doc/refman/5.7/en/mysql-indexes.html. The DISTINCT\nkeyword can be used to find the minimum of the distinct values of expr,\nhowever, this produces the same result as omitting DISTINCT.\n\nMIN() returns NULL if there were no matching rows.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/group-by-functions.html +[MINUTE] +declaration=time +category=Date and Time Functions +description=Returns the minute for time, in the range 0 to 59.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/date-and-time-functions.html +[MLINEFROMTEXT] +declaration=wkt[,srid] +category=WKT +description=Constructs a MultiLineString value using its WKT representation and\nSRID.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/gis-wkt-functions.html +[MLINEFROMWKB] +declaration=wkb[,srid] +category=WKB +description=Constructs a MultiLineString value using its WKB representation and\nSRID.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/gis-wkb-functions.html +[MOD] +declaration=N,M +category=Numeric Functions +description=Modulo operation. Returns the remainder of N divided by M.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/mathematical-functions.html +[MONTH] +declaration=date +category=Date and Time Functions +description=Returns the month for date, in the range 1 to 12 for January to\nDecember, or 0 for dates such as '0000-00-00' or '2008-00-00' that have\na zero month part.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/date-and-time-functions.html +[MONTHNAME] +declaration=date +category=Date and Time Functions +description=Returns the full name of the month for date. The language used for the\nname is controlled by the value of the lc_time_names system variable\n(http://dev.mysql.com/doc/refman/5.7/en/locale-support.html).\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/date-and-time-functions.html +[MPOINTFROMTEXT] +declaration=wkt[,srid] +category=WKT +description=Constructs a MultiPoint value using its WKT representation and SRID.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/gis-wkt-functions.html +[MPOINTFROMWKB] +declaration=wkb[,srid] +category=WKB +description=Constructs a MultiPoint value using its WKB representation and SRID.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/gis-wkb-functions.html +[MPOLYFROMTEXT] +declaration=wkt[,srid] +category=WKT +description=Constructs a MultiPolygon value using its WKT representation and SRID.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/gis-wkt-functions.html +[MPOLYFROMWKB] +declaration=wkb[,srid] +category=WKB +description=Constructs a MultiPolygon value using its WKB representation and SRID.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/gis-wkb-functions.html +[MULTILINESTRING] +declaration=ls1,ls2,... +category=Geometry constructors +description=Constructs a MultiLineString value using LineString or WKB LineString\narguments.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/gis-mysql-specific-functions.html +[MULTIPOINT] +declaration=pt1,pt2,... +category=Geometry constructors +description=Constructs a MultiPoint value using Point or WKB Point arguments.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/gis-mysql-specific-functions.html +[MULTIPOLYGON] +declaration=poly1,poly2,... +category=Geometry constructors +description=Constructs a MultiPolygon value from a set of Polygon or WKB Polygon\narguments.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/gis-mysql-specific-functions.html +[NAME_CONST] +declaration=name,value +category=Miscellaneous Functions +description=Returns the given value. When used to produce a result set column,\nNAME_CONST() causes the column to have the given name. The arguments\nshould be constants.\n\nmysql> SELECT NAME_CONST('myname', 14);\n+--------+\n| myname |\n+--------+\n| 14 |\n+--------+\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/miscellaneous-functions.html +[NOW] +declaration=[fsp] +category=Date and Time Functions +description=Returns the current date and time as a value in 'YYYY-MM-DD HH:MM:SS'\nor YYYYMMDDHHMMSS format, depending on whether the function is used in\na string or numeric context. The value is expressed in the current time\nzone.\n\nIf the fsp argument is given to specify a fractional seconds precision\nfrom 0 to 6, the return value includes a fractional seconds part of\nthat many digits.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/date-and-time-functions.html +[NULLIF] +declaration=expr1,expr2 +category=Control flow functions +description=Returns NULL if expr1 = expr2 is true, otherwise returns expr1. This is\nthe same as CASE WHEN expr1 = expr2 THEN NULL ELSE expr1 END.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/control-flow-functions.html +[NUMGEOMETRIES] +declaration=gc +category=GeometryCollection properties +description=Returns the number of geometries in the GeometryCollection value gc.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/gis-geometrycollection-property-functions.html +[NUMINTERIORRINGS] +declaration=poly +category=Polygon properties +description=Returns the number of interior rings in the Polygon value poly.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/gis-polygon-property-functions.html +[NUMPOINTS] +declaration=ls +category=LineString properties +description=Returns the number of Point objects in the LineString value ls.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/gis-linestring-property-functions.html +[OCT] +declaration=N +category=String Functions +description=Returns a string representation of the octal value of N, where N is a\nlonglong (BIGINT) number. This is equivalent to CONV(N,10,8). Returns\nNULL if N is NULL.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/string-functions.html +[OCTET_LENGTH] +declaration=str +category=String Functions +description=OCTET_LENGTH() is a synonym for LENGTH().\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/string-functions.html +[OLD_PASSWORD] +declaration=str +category=Encryption Functions +description=OLD_PASSWORD() was added when the implementation of PASSWORD() was\nchanged in MySQL 4.1 to improve security. OLD_PASSWORD() returns the\nvalue of the pre-4.1 implementation of PASSWORD() as a string, and is\nintended to permit you to reset passwords for any pre-4.1 clients that\nneed to connect to your version 5.7 MySQL server without locking them\nout. See http://dev.mysql.com/doc/refman/5.7/en/password-hashing.html.\n\nThe return value is a nonbinary string in the connection character set.\n\n*Note*: Passwords that use the pre-4.1 hashing method are less secure\nthan passwords that use the native password hashing method and should\nbe avoided. Pre-4.1 passwords are deprecated and support for them is\nremoved in MySQL 5.7.5. Consequently, OLD_PASSWORD() is deprecated and\nis removed in MySQL 5.7.5.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/encryption-functions.html +[ORD] +declaration=str +category=String Functions +description=If the leftmost character of the string str is a multibyte character,\nreturns the code for that character, calculated from the numeric values\nof its constituent bytes using this formula:\n\n (1st byte code)\n+ (2nd byte code * 256)\n+ (3rd byte code * 2562) ...\n\nIf the leftmost character is not a multibyte character, ORD() returns\nthe same value as the ASCII() function.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/string-functions.html +[OVERLAPS] +declaration=g1,g2 +category=Geometry relations +description=Returns 1 or 0 to indicate whether g1 spatially overlaps g2. The term\nspatially overlaps is used if two geometries intersect and their\nintersection results in a geometry of the same dimension but not equal\nto either of the given geometries.\n\nThis function is deprecated as of MySQL 5.7.6 and will be removed in a\nfuture MySQL release. Use MBROverlaps() instead.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/spatial-relation-functions-mbr.html +[PASSWORD] +declaration=str +category=Encryption Functions +description=*Note*: This function is deprecated as of MySQL 5.7.6 and will be\nremoved in a future MySQL release.\n\nReturns a hashed password string calculated from the cleartext password\nstr. The return value is a nonbinary string in the connection character\nset, or NULL if the argument is NULL. This function is the SQL\ninterface to the algorithm used by the server to encrypt MySQL\npasswords for storage in the mysql.user grant table.\n\nThe old_passwords system variable controls the password hashing method\nused by the PASSWORD() function. It also influences password hashing\nperformed by CREATE USER and GRANT statements that specify a password\nusing an IDENTIFIED BY clause.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/encryption-functions.html +[PERIOD_ADD] +declaration=P,N +category=Date and Time Functions +description=Adds N months to period P (in the format YYMM or YYYYMM). Returns a\nvalue in the format YYYYMM. Note that the period argument P is not a\ndate value.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/date-and-time-functions.html +[PERIOD_DIFF] +declaration=P1,P2 +category=Date and Time Functions +description=Returns the number of months between periods P1 and P2. P1 and P2\nshould be in the format YYMM or YYYYMM. Note that the period arguments\nP1 and P2 are not date values.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/date-and-time-functions.html +[PI] +declaration= +category=Numeric Functions +description=Returns the value of ? (pi). The default number of decimal places\ndisplayed is seven, but MySQL uses the full double-precision value\ninternally.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/mathematical-functions.html +[POINT] +declaration=x,y +category=Geometry constructors +description=Constructs a Point using its coordinates.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/gis-mysql-specific-functions.html +[POINTFROMTEXT] +declaration=wkt[,srid] +category=WKT +description=Constructs a Point value using its WKT representation and SRID.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/gis-wkt-functions.html +[POINTFROMWKB] +declaration=wkb[,srid] +category=WKB +description=Constructs a Point value using its WKB representation and SRID.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/gis-wkb-functions.html +[POINTN] +declaration=ls,N +category=LineString properties +description=Returns the N-th Point in the Linestring value ls. Points are numbered\nbeginning with 1.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/gis-linestring-property-functions.html +[POLYFROMTEXT] +declaration=wkt[,srid] +category=WKT +description=Constructs a Polygon value using its WKT representation and SRID.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/gis-wkt-functions.html +[POLYFROMWKB] +declaration=wkb[,srid] +category=WKB +description=Constructs a Polygon value using its WKB representation and SRID.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/gis-wkb-functions.html +[POLYGON] +declaration=ls1,ls2,... +category=Geometry constructors +description=Constructs a Polygon value from a number of LineString or WKB\nLineString arguments. If any argument does not represent a LinearRing\n(that is, not a closed and simple LineString), the return value is\nNULL.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/gis-mysql-specific-functions.html +[POSITION] +declaration=substr IN str +category=String Functions +description=POSITION(substr IN str) is a synonym for LOCATE(substr,str).\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/string-functions.html +[POW] +declaration=X,Y +category=Numeric Functions +description=Returns the value of X raised to the power of Y.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/mathematical-functions.html +[POWER] +declaration=X,Y +category=Numeric Functions +description=This is a synonym for POW().\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/mathematical-functions.html +[QUARTER] +declaration=date +category=Date and Time Functions +description=Returns the quarter of the year for date, in the range 1 to 4.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/date-and-time-functions.html +[QUOTE] +declaration=str +category=String Functions +description=Quotes a string to produce a result that can be used as a properly\nescaped data value in an SQL statement. The string is returned enclosed\nby single quotation marks and with each instance of backslash ("\"),\nsingle quote ("'"), ASCII NUL, and Control+Z preceded by a backslash.\nIf the argument is NULL, the return value is the word "NULL" without\nenclosing single quotation marks.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/string-functions.html +[RADIANS] +declaration=X +category=Numeric Functions +description=Returns the argument X, converted from degrees to radians. (Note that\n? radians equals 180 degrees.)\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/mathematical-functions.html +[RAND] +declaration= +category=Numeric Functions +description=Returns a random floating-point value v in the range 0 <= v < 1.0. If a\nconstant integer argument N is specified, it is used as the seed value,\nwhich produces a repeatable sequence of column values. In the following\nexample, note that the sequences of values produced by RAND(3) is the\nsame both places where it occurs.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/mathematical-functions.html +[RANDOM_BYTES] +declaration=len +category=Encryption Functions +description=This function returns a binary string of len random bytes generated\nusing the random number generator of the SSL library (OpenSSL or\nyaSSL). Permitted values of len range from 1 to 1024. For values\noutside that range, RANDOM_BYTES() generates a warning and returns\nNULL.\n\nRANDOM_BYTES() can be used to provide the initialization vector for the\nAES_DECRYPT() and AES_ENCRYPT() functions. For use in that context, len\nmust be at least 16. Larger values are permitted, but bytes in excess\nof 16 are ignored.\n\nRANDOM_BYTES() generates a random value, which makes its result\nnondeterministic. Consequently, statements that use this function are\nunsafe for statement-based replication and cannot be stored in the\nquery cache.\n\nThis function is available as of MySQL 5.7.4.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/encryption-functions.html +[RELEASE_ALL_LOCKS] +declaration= +category=Miscellaneous Functions +description=Releases all named locks held by the current session and returns the\nnumber of locks released (0 if there were none)\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/miscellaneous-functions.html +[RELEASE_LOCK] +declaration=str +category=Miscellaneous Functions +description=Releases the lock named by the string str that was obtained with\nGET_LOCK(). Returns 1 if the lock was released, 0 if the lock was not\nestablished by this thread (in which case the lock is not released),\nand NULL if the named lock did not exist. The lock does not exist if it\nwas never obtained by a call to GET_LOCK() or if it has previously been\nreleased.\n\nThe DO statement is convenient to use with RELEASE_LOCK(). See [HELP\nDO].\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/miscellaneous-functions.html +[REVERSE] +declaration=str +category=String Functions +description=Returns the string str with the order of the characters reversed.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/string-functions.html +[RIGHT] +declaration=str,len +category=String Functions +description=Returns the rightmost len characters from the string str, or NULL if\nany argument is NULL.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/string-functions.html +[ROUND] +declaration=X +category=Numeric Functions +description=Rounds the argument X to D decimal places. The rounding algorithm\ndepends on the data type of X. D defaults to 0 if not specified. D can\nbe negative to cause D digits left of the decimal point of the value X\nto become zero.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/mathematical-functions.html +[ROW_COUNT] +declaration= +category=Information Functions +description=In MySQL 5.7, ROW_COUNT() returns a value as follows:\n\no DDL statements: 0. This applies to statements such as CREATE TABLE or\n DROP TABLE.\n\no DML statements other than SELECT: The number of affected rows. This\n applies to statements such as UPDATE, INSERT, or DELETE (as before),\n but now also to statements such as ALTER TABLE and LOAD DATA INFILE.\n\no SELECT: -1 if the statement returns a result set, or the number of\n rows "affected" if it does not. For example, for SELECT * FROM t1,\n ROW_COUNT() returns -1. For SELECT * FROM t1 INTO OUTFILE\n 'file_name', ROW_COUNT() returns the number of rows written to the\n file.\n\no SIGNAL statements: 0.\n\nFor UPDATE statements, the affected-rows value by default is the number\nof rows actually changed. If you specify the CLIENT_FOUND_ROWS flag to\nmysql_real_connect() when connecting to mysqld, the affected-rows value\nis the number of rows "found"; that is, matched by the WHERE clause.\n\nFor REPLACE statements, the affected-rows value is 2 if the new row\nreplaced an old row, because in this case, one row was inserted after\nthe duplicate was deleted.\n\nFor INSERT ... ON DUPLICATE KEY UPDATE statements, the affected-rows\nvalue per row is 1 if the row is inserted as a new row, 2 if an\nexisting row is updated, and 0 if an existing row is set to its current\nvalues. If you specify the CLIENT_FOUND_ROWS flag, the affected-rows\nvalue is 1 (not 0) if an existing row is set to its current values.\n\nThe ROW_COUNT() value is similar to the value from the\nmysql_affected_rows() C API function and the row count that the mysql\nclient displays following statement execution.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/information-functions.html +[RPAD] +declaration=str,len,padstr +category=String Functions +description=Returns the string str, right-padded with the string padstr to a length\nof len characters. If str is longer than len, the return value is\nshortened to len characters.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/string-functions.html +[RTRIM] +declaration=str +category=String Functions +description=Returns the string str with trailing space characters removed.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/string-functions.html +[SCHEMA] +declaration= +category=Information Functions +description=This function is a synonym for DATABASE().\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/information-functions.html +[SECOND] +declaration=time +category=Date and Time Functions +description=Returns the second for time, in the range 0 to 59.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/date-and-time-functions.html +[SEC_TO_TIME] +declaration=seconds +category=Date and Time Functions +description=Returns the seconds argument, converted to hours, minutes, and seconds,\nas a TIME value. The range of the result is constrained to that of the\nTIME data type. A warning occurs if the argument corresponds to a value\noutside that range.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/date-and-time-functions.html +[SESSION_USER] +declaration= +category=Information Functions +description=SESSION_USER() is a synonym for USER().\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/information-functions.html +[SHA1] +declaration=str +category=Encryption Functions +description=Calculates an SHA-1 160-bit checksum for the string, as described in\nRFC 3174 (Secure Hash Algorithm). The value is returned as a string of\n40 hex digits, or NULL if the argument was NULL. One of the possible\nuses for this function is as a hash key. See the notes at the beginning\nof this section about storing hash values efficiently. You can also use\nSHA1() as a cryptographic function for storing passwords. SHA() is\nsynonymous with SHA1().\n\nThe return value is a nonbinary string in the connection character set.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/encryption-functions.html +[SHA2] +declaration=str, hash_length +category=Encryption Functions +description=Calculates the SHA-2 family of hash functions (SHA-224, SHA-256,\nSHA-384, and SHA-512). The first argument is the cleartext string to be\nhashed. The second argument indicates the desired bit length of the\nresult, which must have a value of 224, 256, 384, 512, or 0 (which is\nequivalent to 256). If either argument is NULL or the hash length is\nnot one of the permitted values, the return value is NULL. Otherwise,\nthe function result is a hash value containing the desired number of\nbits. See the notes at the beginning of this section about storing hash\nvalues efficiently.\n\nThe return value is a nonbinary string in the connection character set.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/encryption-functions.html +[SIGN] +declaration=X +category=Numeric Functions +description=Returns the sign of the argument as -1, 0, or 1, depending on whether X\nis negative, zero, or positive.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/mathematical-functions.html +[SIN] +declaration=X +category=Numeric Functions +description=Returns the sine of X, where X is given in radians.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/mathematical-functions.html +[SLEEP] +declaration=duration +category=Miscellaneous Functions +description=Sleeps (pauses) for the number of seconds given by the duration\nargument, then returns 0. If SLEEP() is interrupted, it returns 1. The\nduration may have a fractional part. If the argument is NULL or\nnegative, SLEEP() produces a warning, or an error in strict SQL mode.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/miscellaneous-functions.html +[SMALLINT] +declaration=M +category=Data Types +description=A small integer. The signed range is -32768 to 32767. The unsigned\nrange is 0 to 65535.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/numeric-type-overview.html +[SOUNDEX] +declaration=str +category=String Functions +description=Returns a soundex string from str. Two strings that sound almost the\nsame should have identical soundex strings. A standard soundex string\nis four characters long, but the SOUNDEX() function returns an\narbitrarily long string. You can use SUBSTRING() on the result to get a\nstandard soundex string. All nonalphabetic characters in str are\nignored. All international alphabetic characters outside the A-Z range\nare treated as vowels.\n\n*Important*: When using SOUNDEX(), you should be aware of the following\nlimitations:\n\no This function, as currently implemented, is intended to work well\n with strings that are in the English language only. Strings in other\n languages may not produce reliable results.\n\no This function is not guaranteed to provide consistent results with\n strings that use multibyte character sets, including utf-8.\n\n We hope to remove these limitations in a future release. See Bug\n #22638 for more information.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/string-functions.html +[SPACE] +declaration=N +category=String Functions +description=Returns a string consisting of N space characters.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/string-functions.html +[SQRT] +declaration=X +category=Numeric Functions +description=Returns the square root of a nonnegative number X.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/mathematical-functions.html +[SRID] +declaration=g +category=Geometry properties +description=Returns an integer indicating the Spatial Reference System ID for the\ngeometry value g.\n\nIn MySQL, the SRID value is just an integer associated with the\ngeometry value. All calculations are done assuming Euclidean (planar)\ngeometry.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/gis-general-property-functions.html +[STARTPOINT] +declaration=ls +category=LineString properties +description=Returns the Point that is the start point of the LineString value ls.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/gis-linestring-property-functions.html +[STD] +declaration=expr +category=Functions and Modifiers for Use with GROUP BY +description=Returns the population standard deviation of expr. This is an extension\nto standard SQL. The standard SQL function STDDEV_POP() can be used\ninstead.\n\nThis function returns NULL if there were no matching rows.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/group-by-functions.html +[STDDEV] +declaration=expr +category=Functions and Modifiers for Use with GROUP BY +description=Returns the population standard deviation of expr. This function is\nprovided for compatibility with Oracle. The standard SQL function\nSTDDEV_POP() can be used instead.\n\nThis function returns NULL if there were no matching rows.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/group-by-functions.html +[STDDEV_POP] +declaration=expr +category=Functions and Modifiers for Use with GROUP BY +description=Returns the population standard deviation of expr (the square root of\nVAR_POP()). You can also use STD() or STDDEV(), which are equivalent\nbut not standard SQL.\n\nSTDDEV_POP() returns NULL if there were no matching rows.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/group-by-functions.html +[STDDEV_SAMP] +declaration=expr +category=Functions and Modifiers for Use with GROUP BY +description=Returns the sample standard deviation of expr (the square root of\nVAR_SAMP().\n\nSTDDEV_SAMP() returns NULL if there were no matching rows.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/group-by-functions.html +[STRCMP] +declaration=expr1,expr2 +category=String Functions +description=STRCMP() returns 0 if the strings are the same, -1 if the first\nargument is smaller than the second according to the current sort\norder, and 1 otherwise.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/string-comparison-functions.html +[STR_TO_DATE] +declaration=str,format +category=Date and Time Functions +description=This is the inverse of the DATE_FORMAT() function. It takes a string\nstr and a format string format. STR_TO_DATE() returns a DATETIME value\nif the format string contains both date and time parts, or a DATE or\nTIME value if the string contains only date or time parts. If the date,\ntime, or datetime value extracted from str is illegal, STR_TO_DATE()\nreturns NULL and produces a warning.\n\nThe server scans str attempting to match format to it. The format\nstring can contain literal characters and format specifiers beginning\nwith %. Literal characters in format must match literally in str.\nFormat specifiers in format must match a date or time part in str. For\nthe specifiers that can be used in format, see the DATE_FORMAT()\nfunction description.\n\nmysql> SELECT STR_TO_DATE('01,5,2013','%d,%m,%Y');\n -> '2013-05-01'\nmysql> SELECT STR_TO_DATE('May 1, 2013','%M %d,%Y');\n -> '2013-05-01'\n\nScanning starts at the beginning of str and fails if format is found\nnot to match. Extra characters at the end of str are ignored.\n\nmysql> SELECT STR_TO_DATE('a09:30:17','a%h:%i:%s');\n -> '09:30:17'\nmysql> SELECT STR_TO_DATE('a09:30:17','%h:%i:%s');\n -> NULL\nmysql> SELECT STR_TO_DATE('09:30:17a','%h:%i:%s');\n -> '09:30:17'\n\nUnspecified date or time parts have a value of 0, so incompletely\nspecified values in str produce a result with some or all parts set to\n0:\n\nmysql> SELECT STR_TO_DATE('abc','abc');\n -> '0000-00-00'\nmysql> SELECT STR_TO_DATE('9','%m');\n -> '0000-09-00'\nmysql> SELECT STR_TO_DATE('9','%s');\n -> '00:00:09'\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/date-and-time-functions.html +[ST_AREA] +declaration=poly +category=Polygon properties +description=Returns a double-precision number indicating the area of the argument,\nas measured in its spatial reference system. For arguments of dimension\n0 or 1, the result is 0.\n\nAdditionally, as of MySQL 5.7.5: The result is the sum of the area\nvalues of all components for a geometry collection. If a geometry\ncollection is empty, its area is returned as 0.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/gis-polygon-property-functions.html +[ST_ASGEOJSON] +declaration=g [, max_dec_digits [, options]] +category=MBR +description=Generates a GeoJSON object from the geometry g. The object string has\nthe connection character set and collation.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/spatial-geojson-functions.html +[ST_CENTROID] +declaration=mpoly +category=Polygon properties +description=Returns the mathematical centroid for the MultiPolygon value mpoly as a\nPoint. The result is not guaranteed to be on the MultiPolygon.\n\nAs of MySQL 5.7.5, this function processes geometry collections by\ncomputing the centroid point for components of highest dimension in the\ncollection. Such components are extracted and made into a single\nMultiPolygon, MultiLineString, or MultiPoint for centroid computation.\nIf the argument is an empty geometry collection, the return value is\nNULL.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/gis-multipolygon-property-functions.html +[ST_CONTAINS] +declaration=g1,g2 +category=Geometry relations +description=Returns 1 or 0 to indicate whether g1 completely contains g2. This\ntests the opposite relationship as ST_Within().\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/spatial-relation-functions-object-shapes.html +[ST_CONVEXHULL] +declaration=g +category=GeometryCollection properties +description=Returns a geometry that represents the convex hull of the geometry\nvalue g.\n\nThis function computes a geometry's convex hull by first checking\nwhether its vertex points are colinear. The function returns a linear\nhull if so, a polygon hull otherwise. This function processes geometry\ncollections by extracting all vertex points of all components of the\ncollection, creating a MultiPoint value from them, and computing its\nconvex hull. If the argument is an empty geometry collection, the\nreturn value is NULL.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/spatial-operator-functions.html +[ST_CROSSES] +declaration=g1,g2 +category=Geometry relations +description=Returns 1 if g1 spatially crosses g2. Returns NULL if g1 is a Polygon\nor a MultiPolygon, or if g2 is a Point or a MultiPoint. Otherwise,\nreturns 0.\n\nAs of MySQL 5.7.5, this function returns 0 if called with an\ninapplicable geometry argument type combination. For example, it\nreturns 0 if the first argument is a Polygon or MultiPolygon and/or the\nsecond argument is a Point or MultiPoint.\n\nThe term spatially crosses denotes a spatial relation between two given\ngeometries that has the following properties:\n\no The two geometries intersect\n\no Their intersection results in a geometry that has a dimension that is\n one less than the maximum dimension of the two given geometries\n\no Their intersection is not equal to either of the two given geometries\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/spatial-relation-functions-object-shapes.html +[ST_DIFFERENCE] +declaration=g1, g2 +category=GeometryCollection properties +description=Returns a geometry that represents the point set difference of the\ngeometry values g1 and g2.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/spatial-operator-functions.html +[ST_DISJOINT] +declaration=g1,g2 +category=Geometry relations +description=Returns 1 or 0 to indicate whether g1 is spatially disjoint from (does\nnot intersect) g2.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/spatial-relation-functions-object-shapes.html +[ST_DISTANCE] +declaration=g1,g2 +category=Geometry relations +description=Returns the distance between g1 and g2.\n\nAs of MySQL 5.7.5, this function processes geometry collections by\nreturning the shortest distance among all combinations of the\ncomponents of the two geometry arguments. If either argument is an\nempty geometry collection, the return value is NULL.\n\nAs of MySQL 5.7.6, if an intermediate or final result produces NaN or a\nnegative number, this function produces a ER_GIS_INVALID_DATA error.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/spatial-relation-functions-object-shapes.html +[ST_DISTANCE_SPHERE] +declaration=g1, g2 [, radius] +category=MBR +description=Returns the mimimum spherical distance between two points and/or\nmultipoints on a sphere, in meters, or NULL if any geometry argument is\nNULL or empty.\n\nCalculations use a spherical earth and a configurable radius. The\noptional radius argument should be given in meters. If omitted, the\ndefault radius is 6,370,986 meters. An ER_WRONG_ARGUMENTS error occurs\nif the radius argument is present but not positive.\n\nThe geometry arguments should consist of points that specify\n(longitude, latitude) coordinate values:\n\no Longitude and latitude are the first and second coordinates of the\n point, respectively.\n\no Both coordinates are in degrees.\n\no Longitude values must be in the range (-180, 180]. Positive values\n are east of the prime meridian.\n\no Latitude values must be in the range [-90, 90]. Positive values are\n north of the equator.\n\nSupported argument combinations are (Point, Point), (Point,\nMultiPoint), and (MultiPoint, Point). An ER_GIS_UNSUPPORTED_ARGUMENT\nerror occurs for other combinations.\n\nAn ER_GIS_INVALID_DATA error occurs if any geometry argument is not a\nvalid geometry byte string.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/spatial-convenience-functions.html +[ST_ENVELOPE] +declaration=g +category=Geometry properties +description=Returns the minimum bounding rectangle (MBR) for the geometry value g.\nThe result is returned as a Polygon value that is defined by the corner\npoints of the bounding box:\n\nPOLYGON((MINX MINY, MAXX MINY, MAXX MAXY, MINX MAXY, MINX MINY))\n\nAs of MySQL 5.7.6, if the argument is a point or a vertical or\nhorizontal line segment, ST_Envelope() returns the point or the line\nsegment as its MBR rather than returning an invalid polygon.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/gis-general-property-functions.html +[ST_EQUALS] +declaration=g1,g2 +category=Geometry relations +description=Returns 1 or 0 to indicate whether g1 is spatially equal to g2.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/spatial-relation-functions-object-shapes.html +[ST_GEOHASH] +declaration=longitude, latitude, max_length +category=MBR +description=max_length)\n\nReturns a geohash string in the connection character set and collation.\nThe result is NULL if any argument is NULL. An error occurs if any\nargument is invalid.\n\nFor the first syntax, the longitude must be a number in the range\n[-180, 180], and the latitude must be a number in the range [-90, 90].\nFor the second syntax, a POINT value is required, where the X and Y\ncoordinates are in the valid ranges for longitude and latitude,\nrespectively.\n\nThe resulting string is no longer than max_length characters, which has\nan upper limit of 100. The string might be shorter than max_length\ncharacters because the algorithm that creates the geohash value\ncontinues until it has created a string that is either an exact\nrepresentation of the location or max_length characters, whichever\ncomes first.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/spatial-geohash-functions.html +[ST_GEOMFROMGEOJSON] +declaration=str [, options [, srid]] +category=MBR +description=Parses a string str representing a GeoJSON object and returns a\ngeometry.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/spatial-geojson-functions.html +[ST_INTERSECTION] +declaration=g1, g2 +category=GeometryCollection properties +description=Returns a geometry that represents the point set intersection of the\ngeometry values g1 and g2.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/spatial-operator-functions.html +[ST_INTERSECTS] +declaration=g1,g2 +category=Geometry relations +description=Returns 1 or 0 to indicate whether g1 spatially intersects g2.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/spatial-relation-functions-object-shapes.html +[ST_ISVALID] +declaration=g +category=MBR +description=Checks whether a geometry is valid, as defined by the OGC\nspecification. ST_IsValid() returns 1 if the argument is a valid\ngeometry byte string and is geometrically valid, 0 if the argument is\nnot a valid geometry byte string or is not geometrically valid, NULL if\nthe argument is NULL.\n\nThe only valid empty geometry is represented in the form of an empty\ngeometry collection value. ST_IsValid() returns 1 in this case.\n\nST_IsValid() works only for the cartesian coordinate system and\nrequires a geometry argument with an SRID of 0. An ER_WRONG_ARGUMENTS\nerror occurs otherwise.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/spatial-convenience-functions.html +[ST_LATFROMGEOHASH] +declaration=geohash_str +category=MBR +description=Returns the latitude from a geohash string value, as a DOUBLE value in\nthe range [-90, 90]. The result is NULL if any argument is NULL. An\nerror occurs if the argument is invalid.\n\nThe ST_LatFromGeoHash() decoding function reads no more than 433\ncharacters from the geohash_str argument. That represents the upper\nlimit on information in the internal representation of coordinate\nvalues. Characters past the 433rd are ignored, even if they are\notherwise illegal and produce an error.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/spatial-geohash-functions.html +[ST_LENGTH] +declaration=ls +category=LineString properties +description=Returns a double-precision number indicating the length of the\nLineString value ls in its associated spatial reference.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/gis-linestring-property-functions.html +[ST_LONGFROMGEOHASH] +declaration=geohash_str +category=MBR +description=Returns the longitude from a geohash string value, as a DOUBLE value in\nthe range [-180, 180]. The result is NULL if any argument is NULL. An\nerror occurs if the argument is invalid.\n\nThe remarks in the description of ST_LatFromGeoHash() regarding the\nmaximum number of characters processed from the geohash_str argument\nalso apply to ST_LongFromGeoHash().\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/spatial-geohash-functions.html +[ST_MAKEENVELOPE] +declaration=pt1, pt2 +category=MBR +description=Returns the rectangle that forms the envelope around two points. The\nreturned geometry is a Point, LineString, or Polygon, or NULL if any\nargument is NULL.\n\nCalculations are done using the cartesian coordinate system rather than\non a sphere, spheroid, or on earth.\n\nGiven two points pt1 and pt2, ST_MakeEnvelope() creates the result\ngeometry on an abstract plane like this:\n\no If pt1 and pt2 are equal, the result is the point pt1.\n\no Otherwise, if (pt1, pt2) is a vertical or horizontal line segment,\n the result is the line segment (pt1, pt2).\n\no Otherwise, the result is a polygon using pt1 and pt2 as diagonal\n points. Either or both of pt1 and pt2 can be vertex points.\n\nThe result geometry has an SRID of 0.\n\nST_MakeEnvelope() requires Point geometry arguments with an SRID of 0.\nAn ER_WRONG_ARGUMENTS error occurs otherwise.\n\nAn ER_GIS_INVALID_DATA occurs if any argument is not a valid geometry\nbyte string, or if any coordinate value of the two points is infinite\n(that is, NaN).\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/spatial-convenience-functions.html +[ST_OVERLAPS] +declaration=g1,g2 +category=Geometry relations +description=Returns 1 or 0 to indicate whether g1 spatially overlaps g2. The term\nspatially overlaps is used if two geometries intersect and their\nintersection results in a geometry of the same dimension but not equal\nto either of the given geometries.\n\nAs of MySQL 5.7.5, this function returns 0 if called with an\ninapplicable geometry argument type combination. For example, it\nreturns 0 if called with geometries of different dimensions or any\nargument is a Point.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/spatial-relation-functions-object-shapes.html +[ST_POINTFROMGEOHASH] +declaration=geohash_str, srid +category=MBR +description=Returns a POINT value containing the decoded geohash value, given a\ngeohash string value. The X and Y coordinates of the point are the\nlongitude in the range [-180, 180] and the latitude in the range [-90,\n90], respectively. The srid value is an unsigned 32-bit integer. The\nresult is NULL if any argument is NULL. An error occurs if any argument\nis invalid.\n\nThe remarks in the description of ST_LatFromGeoHash() regarding the\nmaximum number of characters processed from the geohash_str argument\nalso apply to ST_PointFromGeoHash().\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/spatial-geohash-functions.html +[ST_SIMPLIFY] +declaration=g, max_distance +category=MBR +description=Simplifies a geometry using the Douglas-Peucker algorithm and returns a\nsimplified value of the same type, or NULL if any argument is NULL.\n\nThe geometry may be any geometry type, although the Douglas-Peucker\nalgorithm may not actually process every type. A geometry collection is\nprocessed by giving its components one by one to the simplification\nalgorithm, and the returned geometries are put into a geometry\ncollection as result.\n\nThe max_distance argument is the distance (in units of the input\ncoordinates) of a vertex to other segments to be removed. Vertices\nwithin this distance of the simplified linestring are removed. An\nER_WRONG_ARGUMENTS error occurs if the max_distance argument is not\npositive, or is NaN.\n\nAccording to Boost.Geometry, geometries might become invalid as a\nresult of the simplification process, and the process might create\nself-intersections. If you want to check the validity of the result,\npass it to ST_IsValid().\n\nAn ER_GIS_INVALID_DATA error occurs if the geometry argument is not a\nvalid geometry byte string.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/spatial-convenience-functions.html +[ST_SYMDIFFERENCE] +declaration=g1, g2 +category=GeometryCollection properties +description=Returns a geometry that represents the point set symmetric difference\nof the geometry values g1 and g2, which is defined as:\n\ng1 symdifference g2 := (g1 union g2) difference (g1 intersection g2)\n\nOr, in function call notation:\n\nST_SymDifference(g1, g2) = ST_Difference(ST_Union(g1, g2), ST_Intersection(g1, g2))\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/spatial-operator-functions.html +[ST_TOUCHES] +declaration=g1,g2 +category=Geometry relations +description=Returns 1 or 0 to indicate whether g1 spatially touches g2. Two\ngeometries spatially touch if the interiors of the geometries do not\nintersect, but the boundary of one of the geometries intersects either\nthe boundary or the interior of the other.\n\nAs of MySQL 5.7.5, this function returns 0 if called with an\ninapplicable geometry argument type combination. For example, it\nreturns 0 if either of the arguments is a Point or MultiPoint.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/spatial-relation-functions-object-shapes.html +[ST_UNION] +declaration=g1, g2 +category=GeometryCollection properties +description=Returns a geometry that represents the point set union of the geometry\nvalues g1 and g2.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/spatial-operator-functions.html +[ST_VALIDATE] +declaration=g +category=MBR +description=Validates a geometry according to the OGC specification. ST_Validate()\nreturns the geometry if it is a valid geometry byte string and is\ngeometrically valid, NULL if the argument is not a valid geometry byte\nstring or is not geometrically valid or is NULL.\n\nA geometry can be a valid geometry byte string (WKB value plus SRID)\nbut geometrically invalid. For example, this polygon is geometrically\ninvalid: POLYGON((0 0, 0 0, 0 0, 0 0, 0 0))\n\nST_Validate() can be used to filter out invalid geometry data, although\nat a cost. For applications that require more precise results not\ntainted by invalid data, this penalty may be worthwhile.\n\nIf the geometry argument is valid, it is returned as is, except that if\nan input Polygon or MultiPolygon has clockwise rings, those rings are\nreversed before checking for validity. If the geometry is valid, the\nvalue with the reversed rings is returned.\n\nThe only valid empty geometry is represented in the form of an empty\ngeometry collection value. ST_Validate() returns it directly without\nfurther checks in this case.\n\nST_Validate() works only for the cartesian coordinate system and\nrequires a geometry argument with an SRID of 0. An ER_WRONG_ARGUMENTS\nerror occurs otherwise.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/spatial-convenience-functions.html +[ST_WITHIN] +declaration=g1,g2 +category=Geometry relations +description=Returns 1 or 0 to indicate whether g1 is spatially within g2. This\ntests the opposite relationship as ST_Contains().\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/spatial-relation-functions-object-shapes.html +[SUBDATE] +declaration=date,INTERVAL expr unit +category=Date and Time Functions +description=When invoked with the INTERVAL form of the second argument, SUBDATE()\nis a synonym for DATE_SUB(). For information on the INTERVAL unit\nargument, see the discussion for DATE_ADD().\n\nmysql> SELECT DATE_SUB('2008-01-02', INTERVAL 31 DAY);\n -> '2007-12-02'\nmysql> SELECT SUBDATE('2008-01-02', INTERVAL 31 DAY);\n -> '2007-12-02'\n\nThe second form enables the use of an integer value for days. In such\ncases, it is interpreted as the number of days to be subtracted from\nthe date or datetime expression expr.\n\nmysql> SELECT SUBDATE('2008-01-02 12:00:00', 31);\n -> '2007-12-02 12:00:00'\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/date-and-time-functions.html +[SUBSTR] +declaration=str,pos +category=String Functions +description=FROM pos FOR len)\n\nSUBSTR() is a synonym for SUBSTRING().\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/string-functions.html +[SUBSTRING] +declaration=str,pos +category=String Functions +description=SUBSTRING(str FROM pos FOR len)\n\nThe forms without a len argument return a substring from string str\nstarting at position pos. The forms with a len argument return a\nsubstring len characters long from string str, starting at position\npos. The forms that use FROM are standard SQL syntax. It is also\npossible to use a negative value for pos. In this case, the beginning\nof the substring is pos characters from the end of the string, rather\nthan the beginning. A negative value may be used for pos in any of the\nforms of this function.\n\nFor all forms of SUBSTRING(), the position of the first character in\nthe string from which the substring is to be extracted is reckoned as\n1.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/string-functions.html +[SUBSTRING_INDEX] +declaration=str,delim,count +category=String Functions +description=Returns the substring from string str before count occurrences of the\ndelimiter delim. If count is positive, everything to the left of the\nfinal delimiter (counting from the left) is returned. If count is\nnegative, everything to the right of the final delimiter (counting from\nthe right) is returned. SUBSTRING_INDEX() performs a case-sensitive\nmatch when searching for delim.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/string-functions.html +[SUBTIME] +declaration=expr1,expr2 +category=Date and Time Functions +description=SUBTIME() returns expr1 - expr2 expressed as a value in the same format\nas expr1. expr1 is a time or datetime expression, and expr2 is a time\nexpression.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/date-and-time-functions.html +[SUM] +declaration=[DISTINCT] expr +category=Functions and Modifiers for Use with GROUP BY +description=Returns the sum of expr. If the return set has no rows, SUM() returns\nNULL. The DISTINCT keyword can be used to sum only the distinct values\nof expr.\n\nSUM() returns NULL if there were no matching rows.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/group-by-functions.html +[SYSDATE] +declaration=[fsp] +category=Date and Time Functions +description=Returns the current date and time as a value in 'YYYY-MM-DD HH:MM:SS'\nor YYYYMMDDHHMMSS format, depending on whether the function is used in\na string or numeric context.\n\nIf the fsp argument is given to specify a fractional seconds precision\nfrom 0 to 6, the return value includes a fractional seconds part of\nthat many digits. Before 5.6.4, any argument is ignored.\n\nSYSDATE() returns the time at which it executes. This differs from the\nbehavior for NOW(), which returns a constant time that indicates the\ntime at which the statement began to execute. (Within a stored function\nor trigger, NOW() returns the time at which the function or triggering\nstatement began to execute.)\n\nmysql> SELECT NOW(), SLEEP(2), NOW();\n+---------------------+----------+---------------------+\n| NOW() | SLEEP(2) | NOW() |\n+---------------------+----------+---------------------+\n| 2006-04-12 13:47:36 | 0 | 2006-04-12 13:47:36 |\n+---------------------+----------+---------------------+\n\nmysql> SELECT SYSDATE(), SLEEP(2), SYSDATE();\n+---------------------+----------+---------------------+\n| SYSDATE() | SLEEP(2) | SYSDATE() |\n+---------------------+----------+---------------------+\n| 2006-04-12 13:47:44 | 0 | 2006-04-12 13:47:46 |\n+---------------------+----------+---------------------+\n\nIn addition, the SET TIMESTAMP statement affects the value returned by\nNOW() but not by SYSDATE(). This means that timestamp settings in the\nbinary log have no effect on invocations of SYSDATE().\n\nBecause SYSDATE() can return different values even within the same\nstatement, and is not affected by SET TIMESTAMP, it is nondeterministic\nand therefore unsafe for replication if statement-based binary logging\nis used. If that is a problem, you can use row-based logging.\n\nAlternatively, you can use the --sysdate-is-now option to cause\nSYSDATE() to be an alias for NOW(). This works if the option is used on\nboth the master and the slave.\n\nThe nondeterministic nature of SYSDATE() also means that indexes cannot\nbe used for evaluating expressions that refer to it.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/date-and-time-functions.html +[SYSTEM_USER] +declaration= +category=Information Functions +description=SYSTEM_USER() is a synonym for USER().\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/information-functions.html +[TAN] +declaration=X +category=Numeric Functions +description=Returns the tangent of X, where X is given in radians.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/mathematical-functions.html +[TEXT] +declaration=M +category=Data Types +description=A TEXT column with a maximum length of 65,535 (216 - 1) characters. The\neffective maximum length is less if the value contains multibyte\ncharacters. Each TEXT value is stored using a 2-byte length prefix that\nindicates the number of bytes in the value.\n\nAn optional length M can be given for this type. If this is done, MySQL\ncreates the column as the smallest TEXT type large enough to hold\nvalues M characters long.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/string-type-overview.html +[TIME] +declaration=fsp +category=Data Types +description=A time. The range is '-838:59:59.000000' to '838:59:59.000000'. MySQL\ndisplays TIME values in 'HH:MM:SS[.fraction]' format, but permits\nassignment of values to TIME columns using either strings or numbers.\n\nAn optional fsp value in the range from 0 to 6 may be given to specify\nfractional seconds precision. A value of 0 signifies that there is no\nfractional part. If omitted, the default precision is 0.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/date-and-time-type-overview.html +[TIMEDIFF] +declaration=expr1,expr2 +category=Date and Time Functions +description=TIMEDIFF() returns expr1 - expr2 expressed as a time value. expr1 and\nexpr2 are time or date-and-time expressions, but both must be of the\nsame type.\n\nThe result returned by TIMEDIFF() is limited to the range allowed for\nTIME values. Alternatively, you can use either of the functions\nTIMESTAMPDIFF() and UNIX_TIMESTAMP(), both of which return integers.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/date-and-time-functions.html +[TIMESTAMP] +declaration=fsp +category=Data Types +description=A timestamp. The range is '1970-01-01 00:00:01.000000' UTC to\n'2038-01-19 03:14:07.999999' UTC. TIMESTAMP values are stored as the\nnumber of seconds since the epoch ('1970-01-01 00:00:00' UTC). A\nTIMESTAMP cannot represent the value '1970-01-01 00:00:00' because that\nis equivalent to 0 seconds from the epoch and the value 0 is reserved\nfor representing '0000-00-00 00:00:00', the "zero" TIMESTAMP value.\n\nAn optional fsp value in the range from 0 to 6 may be given to specify\nfractional seconds precision. A value of 0 signifies that there is no\nfractional part. If omitted, the default precision is 0.\n\nThe way the server handles TIMESTAMP definitions depends on the value\nof the explicit_defaults_for_timestamp system variable (see\nhttp://dev.mysql.com/doc/refman/5.7/en/server-system-variables.html).\nBy default, explicit_defaults_for_timestamp is disabled and the server\nhandles TIMESTAMP as follows:\n\nUnless specified otherwise, the first TIMESTAMP column in a table is\ndefined to be automatically set to the date and time of the most recent\nmodification if not explicitly assigned a value. This makes TIMESTAMP\nuseful for recording the timestamp of an INSERT or UPDATE operation.\nYou can also set any TIMESTAMP column to the current date and time by\nassigning it a NULL value, unless it has been defined with the NULL\nattribute to permit NULL values.\n\nAutomatic initialization and updating to the current date and time can\nbe specified using DEFAULT CURRENT_TIMESTAMP and ON UPDATE\nCURRENT_TIMESTAMP column definition clauses. By default, the first\nTIMESTAMP column has these properties, as previously noted. However,\nany TIMESTAMP column in a table can be defined to have these\nproperties.\n\nIf explicit_defaults_for_timestamp is enabled, there is no automatic\nassignment of the DEFAULT CURRENT_TIMESTAMP or ON UPDATE\nCURRENT_TIMESTAMP attributes to any TIMESTAMP column. They must be\nincluded explicitly in the column definition. Also, any TIMESTAMP not\nexplicitly declared as NOT NULL permits NULL values.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/date-and-time-type-overview.html +[TIMESTAMPADD] +declaration=unit,interval,datetime_expr +category=Date and Time Functions +description=Adds the integer expression interval to the date or datetime expression\ndatetime_expr. The unit for interval is given by the unit argument,\nwhich should be one of the following values: MICROSECOND\n(microseconds), SECOND, MINUTE, HOUR, DAY, WEEK, MONTH, QUARTER, or\nYEAR.\n\nThe unit value may be specified using one of keywords as shown, or with\na prefix of SQL_TSI_. For example, DAY and SQL_TSI_DAY both are legal.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/date-and-time-functions.html +[TIMESTAMPDIFF] +declaration=unit,datetime_expr1,datetime_expr2 +category=Date and Time Functions +description=Returns datetime_expr2 - datetime_expr1, where datetime_expr1 and\ndatetime_expr2 are date or datetime expressions. One expression may be\na date and the other a datetime; a date value is treated as a datetime\nhaving the time part '00:00:00' where necessary. The unit for the\nresult (an integer) is given by the unit argument. The legal values for\nunit are the same as those listed in the description of the\nTIMESTAMPADD() function.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/date-and-time-functions.html +[TIME_FORMAT] +declaration=time,format +category=Date and Time Functions +description=This is used like the DATE_FORMAT() function, but the format string may\ncontain format specifiers only for hours, minutes, seconds, and\nmicroseconds. Other specifiers produce a NULL value or 0.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/date-and-time-functions.html +[TIME_TO_SEC] +declaration=time +category=Date and Time Functions +description=Returns the time argument, converted to seconds.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/date-and-time-functions.html +[TINYINT] +declaration=M +category=Data Types +description=A very small integer. The signed range is -128 to 127. The unsigned\nrange is 0 to 255.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/numeric-type-overview.html +[TOUCHES] +declaration=g1,g2 +category=Geometry relations +description=Returns 1 or 0 to indicate whether g1 spatially touches g2. Two\ngeometries spatially touch if the interiors of the geometries do not\nintersect, but the boundary of one of the geometries intersects either\nthe boundary or the interior of the other.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/spatial-relation-functions-mbr.html +[TO_DAYS] +declaration=date +category=Date and Time Functions +description=Given a date date, returns a day number (the number of days since year\n0).\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/date-and-time-functions.html +[TO_SECONDS] +declaration=expr +category=Date and Time Functions +description=Given a date or datetime expr, returns the number of seconds since the\nyear 0. If expr is not a valid date or datetime value, returns NULL.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/date-and-time-functions.html +[TRIM] +declaration=[{BOTH | LEADING | TRAILING} [remstr] FROM] str +category=String Functions +description=FROM] str)\n\nReturns the string str with all remstr prefixes or suffixes removed. If\nnone of the specifiers BOTH, LEADING, or TRAILING is given, BOTH is\nassumed. remstr is optional and, if not specified, spaces are removed.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/string-functions.html +[TRUNCATE] +declaration=X,D +category=Numeric Functions +description=Returns the number X, truncated to D decimal places. If D is 0, the\nresult has no decimal point or fractional part. D can be negative to\ncause D digits left of the decimal point of the value X to become zero.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/mathematical-functions.html +[UCASE] +declaration=str +category=String Functions +description=UCASE() is a synonym for UPPER().\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/string-functions.html +[UNCOMPRESS] +declaration=string_to_uncompress +category=Encryption Functions +description=Uncompresses a string compressed by the COMPRESS() function. If the\nargument is not a compressed value, the result is NULL. This function\nrequires MySQL to have been compiled with a compression library such as\nzlib. Otherwise, the return value is always NULL.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/encryption-functions.html +[UNCOMPRESSED_LENGTH] +declaration=compressed_string +category=Encryption Functions +description=Returns the length that the compressed string had before being\ncompressed.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/encryption-functions.html +[UNHEX] +declaration=str +category=String Functions +description=For a string argument str, UNHEX(str) interprets each pair of\ncharacters in the argument as a hexadecimal number and converts it to\nthe byte represented by the number. The return value is a binary\nstring.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/string-functions.html +[UNIX_TIMESTAMP] +declaration= +category=Date and Time Functions +description=If called with no argument, returns a Unix timestamp (seconds since\n'1970-01-01 00:00:00' UTC) as an unsigned integer. If UNIX_TIMESTAMP()\nis called with a date argument, it returns the value of the argument as\nseconds since '1970-01-01 00:00:00' UTC. date may be a DATE string, a\nDATETIME string, a TIMESTAMP, or a number in the format YYMMDD or\nYYYYMMDD. The server interprets date as a value in the current time\nzone and converts it to an internal value in UTC. Clients can set their\ntime zone as described in\nhttp://dev.mysql.com/doc/refman/5.7/en/time-zone-support.html.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/date-and-time-functions.html +[UPDATEXML] +declaration=xml_target, xpath_expr, new_xml +category=String Functions +description=This function replaces a single portion of a given fragment of XML\nmarkup xml_target with a new XML fragment new_xml, and then returns the\nchanged XML. The portion of xml_target that is replaced matches an\nXPath expression xpath_expr supplied by the user.\n\nIf no expression matching xpath_expr is found, or if multiple matches\nare found, the function returns the original xml_target XML fragment.\nAll three arguments should be strings.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/xml-functions.html +[UPPER] +declaration=str +category=String Functions +description=Returns the string str with all characters changed to uppercase\naccording to the current character set mapping. The default is latin1\n(cp1252 West European).\n\nmysql> SELECT UPPER('Hej');\n -> 'HEJ'\n\nSee the description of LOWER() for information that also applies to\nUPPER(). This included information about how to perform lettercase\nconversion of binary strings (BINARY, VARBINARY, BLOB) for which these\nfunctions are ineffective, and information about case folding for\nUnicode character sets.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/string-functions.html +[USER] +declaration= +category=Information Functions +description=Returns the current MySQL user name and host name as a string in the\nutf8 character set.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/information-functions.html +[UTC_DATE] +declaration= +category=Date and Time Functions +description=Returns the current UTC date as a value in 'YYYY-MM-DD' or YYYYMMDD\nformat, depending on whether the function is used in a string or\nnumeric context.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/date-and-time-functions.html +[UTC_TIME] +declaration=[fsp] +category=Date and Time Functions +description=Returns the current UTC time as a value in 'HH:MM:SS' or HHMMSS format,\ndepending on whether the function is used in a string or numeric\ncontext.\n\nIf the fsp argument is given to specify a fractional seconds precision\nfrom 0 to 6, the return value includes a fractional seconds part of\nthat many digits.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/date-and-time-functions.html +[UTC_TIMESTAMP] +declaration=[fsp] +category=Date and Time Functions +description=Returns the current UTC date and time as a value in 'YYYY-MM-DD\nHH:MM:SS' or YYYYMMDDHHMMSS format, depending on whether the function\nis used in a string or numeric context.\n\nIf the fsp argument is given to specify a fractional seconds precision\nfrom 0 to 6, the return value includes a fractional seconds part of\nthat many digits.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/date-and-time-functions.html +[UUID] +declaration= +category=Miscellaneous Functions +description=Returns a Universal Unique Identifier (UUID) generated according to\n"DCE 1.1: Remote Procedure Call" (Appendix A) CAE (Common Applications\nEnvironment) Specifications published by The Open Group in October 1997\n(Document Number C706,\nhttp://www.opengroup.org/public/pubs/catalog/c706.htm).\n\nA UUID is designed as a number that is globally unique in space and\ntime. Two calls to UUID() are expected to generate two different\nvalues, even if these calls are performed on two separate computers\nthat are not connected to each other.\n\nA UUID is a 128-bit number represented by a utf8 string of five\nhexadecimal numbers in aaaaaaaa-bbbb-cccc-dddd-eeeeeeeeeeee format:\n\no The first three numbers are generated from a timestamp.\n\no The fourth number preserves temporal uniqueness in case the timestamp\n value loses monotonicity (for example, due to daylight saving time).\n\no The fifth number is an IEEE 802 node number that provides spatial\n uniqueness. A random number is substituted if the latter is not\n available (for example, because the host computer has no Ethernet\n card, or we do not know how to find the hardware address of an\n interface on your operating system). In this case, spatial uniqueness\n cannot be guaranteed. Nevertheless, a collision should have very low\n probability.\n\n Currently, the MAC address of an interface is taken into account only\n on FreeBSD and Linux. On other operating systems, MySQL uses a\n randomly generated 48-bit number.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/miscellaneous-functions.html +[UUID_SHORT] +declaration= +category=Miscellaneous Functions +description=Returns a "short" universal identifier as a 64-bit unsigned integer\n(rather than a string-form 128-bit identifier as returned by the UUID()\nfunction).\n\nThe value of UUID_SHORT() is guaranteed to be unique if the following\nconditions hold:\n\no The server_id of the current host is unique among your set of master\n and slave servers\n\no server_id is between 0 and 255\n\no You do not set back your system time for your server between mysqld\n restarts\n\no You do not invoke UUID_SHORT() on average more than 16 million times\n per second between mysqld restarts\n\nThe UUID_SHORT() return value is constructed this way:\n\n (server_id & 255) << 56\n+ (server_startup_time_in_seconds << 24)\n+ incremented_variable++;\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/miscellaneous-functions.html +[VALIDATE_PASSWORD_STRENGTH] +declaration=str +category=Encryption Functions +description=Given an argument representing a cleartext password, this function\nreturns an integer to indicate how strong the password is. The return\nvalue ranges from 0 (weak) to 100 (strong).\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/encryption-functions.html +[VALUES] +declaration=col_name +category=Miscellaneous Functions +description=In an INSERT ... ON DUPLICATE KEY UPDATE statement, you can use the\nVALUES(col_name) function in the UPDATE clause to refer to column\nvalues from the INSERT portion of the statement. In other words,\nVALUES(col_name) in the UPDATE clause refers to the value of col_name\nthat would be inserted, had no duplicate-key conflict occurred. This\nfunction is especially useful in multiple-row inserts. The VALUES()\nfunction is meaningful only in the ON DUPLICATE KEY UPDATE clause of\nINSERT statements and returns NULL otherwise. See\nhttp://dev.mysql.com/doc/refman/5.7/en/insert-on-duplicate.html.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/miscellaneous-functions.html +[VARBINARY] +declaration=M +category=Data Types +description=The VARBINARY type is similar to the VARCHAR type, but stores binary\nbyte strings rather than nonbinary character strings. M represents the\nmaximum column length in bytes.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/string-type-overview.html +[VARCHAR] +declaration=M +category=Data Types +description=collation_name]\n\nA variable-length string. M represents the maximum column length in\ncharacters. The range of M is 0 to 65,535. The effective maximum length\nof a VARCHAR is subject to the maximum row size (65,535 bytes, which is\nshared among all columns) and the character set used. For example, utf8\ncharacters can require up to three bytes per character, so a VARCHAR\ncolumn that uses the utf8 character set can be declared to be a maximum\nof 21,844 characters. See\nhttp://dev.mysql.com/doc/refman/5.7/en/column-count-limit.html.\n\nMySQL stores VARCHAR values as a 1-byte or 2-byte length prefix plus\ndata. The length prefix indicates the number of bytes in the value. A\nVARCHAR column uses one length byte if values require no more than 255\nbytes, two length bytes if values may require more than 255 bytes.\n\n*Note*: MySQL 5.7 follows the standard SQL specification, and does not\nremove trailing spaces from VARCHAR values.\n\nVARCHAR is shorthand for CHARACTER VARYING. NATIONAL VARCHAR is the\nstandard SQL way to define that a VARCHAR column should use some\npredefined character set. MySQL 4.1 and up uses utf8 as this predefined\ncharacter set.\nhttp://dev.mysql.com/doc/refman/5.7/en/charset-national.html. NVARCHAR\nis shorthand for NATIONAL VARCHAR.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/string-type-overview.html +[VARIANCE] +declaration=expr +category=Functions and Modifiers for Use with GROUP BY +description=Returns the population standard variance of expr. This is an extension\nto standard SQL. The standard SQL function VAR_POP() can be used\ninstead.\n\nVARIANCE() returns NULL if there were no matching rows.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/group-by-functions.html +[VAR_POP] +declaration=expr +category=Functions and Modifiers for Use with GROUP BY +description=Returns the population standard variance of expr. It considers rows as\nthe whole population, not as a sample, so it has the number of rows as\nthe denominator. You can also use VARIANCE(), which is equivalent but\nis not standard SQL.\n\nVAR_POP() returns NULL if there were no matching rows.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/group-by-functions.html +[VAR_SAMP] +declaration=expr +category=Functions and Modifiers for Use with GROUP BY +description=Returns the sample variance of expr. That is, the denominator is the\nnumber of rows minus one.\n\nVAR_SAMP() returns NULL if there were no matching rows.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/group-by-functions.html +[VERSION] +declaration= +category=Information Functions +description=Returns a string that indicates the MySQL server version. The string\nuses the utf8 character set. The value might have a suffix in addition\nto the version number. See the description of the version system\nvariable in\nhttp://dev.mysql.com/doc/refman/5.7/en/server-system-variables.html.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/information-functions.html +[WAIT_FOR_EXECUTED_GTID_SET] +declaration=gtid_set[, timeout] +category=MBR +description=Introduced in MySQL 5.7.5, WAIT_FOR_EXECUTED_GTID_SET() is similar to\nWAIT_UNTIL_SQL_THREAD_AFTER_GTIDS() in that it waits until a server has\nexecuted all of the transactions whose global transaction identifiers\nare contained in gtid_set, or until timeout seconds have elapsed,\nwhichever occurs first. Unlike WAIT_UNTIL_SQL_THREAD_AFTER_GTIDS(),\nWAIT_FOR_EXECUTED_GTID_SET() does not take into account whether the\nslave is running or not, and an error is returned if GTID-based\nreplication is not enabled.\n\nIn addition, WAIT_FOR_EXECUTED_GTID_SET() returns only the state of the\nquery, where 0 represents success, 1 represents timeout, and any other\nfailures return the error message.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/gtid-functions.html +[WAIT_UNTIL_SQL_THREAD_AFTER_GTIDS] +declaration=gtid_set[, timeout][,channel] +category=MBR +description=Wait until the slave SQL thread has executed all of the transactions\nwhose global transaction identifiers are contained in gtid_set (see\nhttp://dev.mysql.com/doc/refman/5.7/en/replication-gtids-concepts.html,\nfor a definition of "GTID sets"), or until timeout seconds have\nelapsed, whichever occurs first. timeout is optional; the default\ntimeout is 0 seconds, in which case the function waits until all of the\ntransactions in the GTID set have been executed.\n\nFor more information, see\nhttp://dev.mysql.com/doc/refman/5.7/en/replication-gtids.html.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/gtid-functions.html +[WEEK] +declaration=date[,mode] +category=Date and Time Functions +description=This function returns the week number for date. The two-argument form\nof WEEK() enables you to specify whether the week starts on Sunday or\nMonday and whether the return value should be in the range from 0 to 53\nor from 1 to 53. If the mode argument is omitted, the value of the\ndefault_week_format system variable is used. See\nhttp://dev.mysql.com/doc/refman/5.7/en/server-system-variables.html.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/date-and-time-functions.html +[WEEKDAY] +declaration=date +category=Date and Time Functions +description=Returns the weekday index for date (0 = Monday, 1 = Tuesday, ... 6 =\nSunday).\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/date-and-time-functions.html +[WEEKOFYEAR] +declaration=date +category=Date and Time Functions +description=Returns the calendar week of the date as a number in the range from 1\nto 53. WEEKOFYEAR() is a compatibility function that is equivalent to\nWEEK(date,3).\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/date-and-time-functions.html +[WEIGHT_STRING] +declaration=str [AS {CHAR|BINARY}(N +category=String Functions +description=levels: N [ASC|DESC|REVERSE] [, N [ASC|DESC|REVERSE]] ...\n\nThis function returns the weight string for the input string. The\nreturn value is a binary string that represents the sorting and\ncomparison value of the string. It has these properties:\n\no If WEIGHT_STRING(str1) = WEIGHT_STRING(str2), then str1 = str2 (str1\n and str2 are considered equal)\n\no If WEIGHT_STRING(str1) < WEIGHT_STRING(str2), then str1 < str2 (str1\n sorts before str2)\n\nWEIGHT_STRING() can be used for testing and debugging of collations,\nespecially if you are adding a new collation. See\nhttp://dev.mysql.com/doc/refman/5.7/en/adding-collation.html.\n\nThe input string, str, is a string expression. If the input is a\nnonbinary (character) string such as a CHAR, VARCHAR, or TEXT value,\nthe return value contains the collation weights for the string. If the\ninput is a binary (byte) string such as a BINARY, VARBINARY, or BLOB\nvalue, the return value is the same as the input (the weight for each\nbyte in a binary string is the byte value). If the input is NULL,\nWEIGHT_STRING() returns NULL.\n\nExamples:\n\nmysql> SET @s = _latin1 'AB' COLLATE latin1_swedish_ci;\nmysql> SELECT @s, HEX(@s), HEX(WEIGHT_STRING(@s));\n+------+---------+------------------------+\n| @s | HEX(@s) | HEX(WEIGHT_STRING(@s)) |\n+------+---------+------------------------+\n| AB | 4142 | 4142 |\n+------+---------+------------------------+\n\nmysql> SET @s = _latin1 'ab' COLLATE latin1_swedish_ci;\nmysql> SELECT @s, HEX(@s), HEX(WEIGHT_STRING(@s));\n+------+---------+------------------------+\n| @s | HEX(@s) | HEX(WEIGHT_STRING(@s)) |\n+------+---------+------------------------+\n| ab | 6162 | 4142 |\n+------+---------+------------------------+\n\nmysql> SET @s = CAST('AB' AS BINARY);\nmysql> SELECT @s, HEX(@s), HEX(WEIGHT_STRING(@s));\n+------+---------+------------------------+\n| @s | HEX(@s) | HEX(WEIGHT_STRING(@s)) |\n+------+---------+------------------------+\n| AB | 4142 | 4142 |\n+------+---------+------------------------+\n\n ... +[WITHIN] +declaration=g1,g2 +category=Geometry relations +description=Returns 1 or 0 to indicate whether g1 is spatially within g2. This\ntests the opposite relationship as Contains().\n\nThis function is deprecated as of MySQL 5.7.6 and will be removed in a\nfuture MySQL release. Use MBRWithin() instead.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/spatial-relation-functions-mbr.html +[X] +declaration=p +category=Point properties +description=Returns the X-coordinate value for the Point object p as a\ndouble-precision number.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/gis-point-property-functions.html +[Y] +declaration=p +category=Point properties +description=Returns the Y-coordinate value for the Point object p as a\ndouble-precision number.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/gis-point-property-functions.html +[YEAR] +declaration=date +category=Date and Time Functions +description=Returns the year for date, in the range 1000 to 9999, or 0 for the\n"zero" date.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/date-and-time-functions.html +[YEARWEEK] +declaration=date +category=Date and Time Functions +description=Returns year and week for a date. The mode argument works exactly like\nthe mode argument to WEEK(). The year in the result may be different\nfrom the year in the date argument for the first and the last week of\nthe year.\n\nURL: http://dev.mysql.com/doc/refman/5.7/en/date-and-time-functions.html \ No newline at end of file diff --git a/out/functions-mysql8.ini b/out/functions-mysql8.ini new file mode 100644 index 000000000..1fbca7787 --- /dev/null +++ b/out/functions-mysql8.ini @@ -0,0 +1,1572 @@ +[ABS] +declaration=X +category=Numeric Functions +description=Returns the absolute value of X, or NULL if X is NULL.\n\nThe result type is derived from the argument type. An implication of\nthis is that ABS(-9223372036854775808) produces an error because the\nresult cannot be stored in a signed BIGINT value.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/mathematical-functions.html +[ACOS] +declaration=X +category=Numeric Functions +description=Returns the arc cosine of X, that is, the value whose cosine is X.\nReturns NULL if X is not in the range -1 to 1, or if X is NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/mathematical-functions.html +[ADDDATE] +declaration=date,INTERVAL expr unit +category=Date and Time Functions +description=When invoked with the INTERVAL form of the second argument, ADDDATE()\nis a synonym for DATE_ADD(). The related function SUBDATE() is a\nsynonym for DATE_SUB(). For information on the INTERVAL unit argument,\nsee\nhttps://dev.mysql.com/doc/refman/8.3/en/expressions.html#temporal-inter\nvals.\n\nmysql> SELECT DATE_ADD('2008-01-02', INTERVAL 31 DAY);\n -> '2008-02-02'\nmysql> SELECT ADDDATE('2008-01-02', INTERVAL 31 DAY);\n -> '2008-02-02'\n\nWhen invoked with the days form of the second argument, MySQL treats it\nas an integer number of days to be added to expr.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/date-and-time-functions.html +[ADDTIME] +declaration=expr1,expr2 +category=Date and Time Functions +description=ADDTIME() adds expr2 to expr1 and returns the result. expr1 is a time\nor datetime expression, and expr2 is a time expression. Returns NULL if\nexpr1or expr2 is NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/date-and-time-functions.html +[AES_DECRYPT] +declaration=crypt_str,key_str[,init_vector][,kdf_name][,salt][,info | iterations] +category=Encryption Functions +description=This function decrypts data using the official AES (Advanced Encryption\nStandard) algorithm. For more information, see the description of\nAES_ENCRYPT().\n\nStatements that use AES_DECRYPT() are unsafe for statement-based\nreplication.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/encryption-functions.html +[AES_ENCRYPT] +declaration=str,key_str[,init_vector][,kdf_name][,salt][,info | iterations] +category=Encryption Functions +description=AES_ENCRYPT() and AES_DECRYPT() implement encryption and decryption of\ndata using the official AES (Advanced Encryption Standard) algorithm,\npreviously known as "Rijndael." The AES standard permits various key\nlengths. By default these functions implement AES with a 128-bit key\nlength. Key lengths of 196 or 256 bits can be used, as described later.\nThe key length is a trade off between performance and security.\n\nAES_ENCRYPT() encrypts the string str using the key string key_str, and\nreturns a binary string containing the encrypted output. AES_DECRYPT()\ndecrypts the encrypted string crypt_str using the key string key_str,\nand returns the original (binary) string in hexadecimal format. (To\nobtain the string as plaintext, cast the result to CHAR. Alternatively,\nstart the mysql client with --skip-binary-as-hex to cause all binary\nvalues to be displayed as text.) If either function argument is NULL,\nthe function returns NULL. If AES_DECRYPT() detects invalid data or\nincorrect padding, it returns NULL. However, it is possible for\nAES_DECRYPT() to return a non-NULL value (possibly garbage) if the\ninput data or the key is invalid.\n\nThese functions support the use of a key derivation function (KDF) to\ncreate a cryptographically strong secret key from the information\npassed in key_str. The derived key is used to encrypt and decrypt the\ndata, and it remains in the MySQL Server instance and is not accessible\nto users. Using a KDF is highly recommended, as it provides better\nsecurity than specifying your own premade key or deriving it by a\nsimpler method as you use the function. The functions support HKDF\n(available from OpenSSL 1.1.0), for which you can specify an optional\nsalt and context-specific information to include in the keying\nmaterial, and PBKDF2 (available from OpenSSL 1.0.2), for which you can\nspecify an optional salt and set the number of iterations used to\nproduce the key.\n\nAES_ENCRYPT() and AES_DECRYPT() permit control of the block encryption\nmode. The block_encryption_mode system variable controls the mode for\nblock-based encryption algorithms. Its default value is aes-128-ecb,\nwhich signifies encryption using a key length of 128 bits and ECB mode.\nFor a description of the permitted values of this variable, see\nhttps://dev.mysql.com/doc/refman/8.3/en/server-system-variables.html.\nThe optional init_vector argument is used to provide an initialization\nvector for block encryption modes that require it.\n\nStatements that use AES_ENCRYPT() or AES_DECRYPT() are unsafe for\nstatement-based replication.\n\nIf AES_ENCRYPT() is invoked from within the mysql client, binary\nstrings display using hexadecimal notation, depending on the value of\nthe --binary-as-hex. For more information about that option, see\nhttps://dev.mysql.com/doc/refman/8.3/en/mysql.html.\n\nThe arguments for the AES_ENCRYPT() and AES_DECRYPT() functions are as\n ... +[ANY_VALUE] +declaration=arg +category=Miscellaneous Functions +description=This function is useful for GROUP BY queries when the\nONLY_FULL_GROUP_BY SQL mode is enabled, for cases when MySQL rejects a\nquery that you know is valid for reasons that MySQL cannot determine.\nThe function return value and type are the same as the return value and\ntype of its argument, but the function result is not checked for the\nONLY_FULL_GROUP_BY SQL mode.\n\nFor example, if name is a nonindexed column, the following query fails\nwith ONLY_FULL_GROUP_BY enabled:\n\nmysql> SELECT name, address, MAX(age) FROM t GROUP BY name;\nERROR 1055 (42000): Expression #2 of SELECT list is not in GROUP\nBY clause and contains nonaggregated column 'mydb.t.address' which\nis not functionally dependent on columns in GROUP BY clause; this\nis incompatible with sql_mode=only_full_group_by\n\nThe failure occurs because address is a nonaggregated column that is\nneither named among GROUP BY columns nor functionally dependent on\nthem. As a result, the address value for rows within each name group is\nnondeterministic. There are multiple ways to cause MySQL to accept the\nquery:\n\no Alter the table to make name a primary key or a unique NOT NULL\n column. This enables MySQL to determine that address is functionally\n dependent on name; that is, address is uniquely determined by name.\n (This technique is inapplicable if NULL must be permitted as a valid\n name value.)\n\no Use ANY_VALUE() to refer to address:\n\nSELECT name, ANY_VALUE(address), MAX(age) FROM t GROUP BY name;\n\n In this case, MySQL ignores the nondeterminism of address values\n within each name group and accepts the query. This may be useful if\n you simply do not care which value of a nonaggregated column is\n chosen for each group. ANY_VALUE() is not an aggregate function,\n unlike functions such as SUM() or COUNT(). It simply acts to suppress\n the test for nondeterminism.\n\no Disable ONLY_FULL_GROUP_BY. This is equivalent to using ANY_VALUE()\n with ONLY_FULL_GROUP_BY enabled, as described in the previous item.\n\nANY_VALUE() is also useful if functional dependence exists between\ncolumns but MySQL cannot determine it. The following query is valid\nbecause age is functionally dependent on the grouping column age-1, but\nMySQL cannot tell that and rejects the query with ONLY_FULL_GROUP_BY\nenabled:\n\nSELECT age FROM t GROUP BY age-1;\n\n ... +[ASCII] +declaration=str +category=String Functions +description=Returns the numeric value of the leftmost character of the string str.\nReturns 0 if str is the empty string. Returns NULL if str is NULL.\nASCII() works for 8-bit characters.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/string-functions.html +[ASIN] +declaration=X +category=Numeric Functions +description=Returns the arc sine of X, that is, the value whose sine is X. Returns\nNULL if X is not in the range -1 to 1, or if X is NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/mathematical-functions.html +[ASYMMETRIC_DECRYPT] +declaration=algorithm, data_str, priv_key_str +category=Enterprise Encryption Functions +description=Decrypts an encrypted string using the given algorithm and key string,\nand returns the resulting plaintext as a binary string. If decryption\nfails, the result is NULL.\n\nFor the legacy version of this function in use before MySQL 8.0.29, see\nhttps://dev.mysql.com/doc/refman/8.3/en/enterprise-encryption-functions\n-legacy.html.\n\nBy default, the component_enterprise_encryption function assumes that\nencrypted text uses the RSAES-OAEP padding scheme. The function\nsupports decryption for content encrypted by the legacy openssl_udf\nshared library functions if the system variable\nenterprise_encryption.rsa_support_legacy_padding is set to ON (the\ndefault is OFF). When ON is set, the function also supports the\nRSAES-PKCS1-v1_5 padding scheme, as used by the legacy openssl_udf\nshared library functions. When OFF is set, content encrypted by the\nlegacy functions cannot be decrypted, and the function returns null\noutput for such content.\n\nalgorithm is the encryption algorithm used to create the key. The\nsupported algorithm value is 'RSA'.\n\ndata_str is the encrypted string to decrypt, which was encrypted with\nasymmetric_encrypt().\n\npriv_key_str is a valid PEM encoded RSA private key. For successful\ndecryption, the key string must correspond to the public key string\nused with asymmetric_encrypt() to produce the encrypted string. The\nasymmetric_encrypt() component function only supports encryption using\na public key, so decryption takes place with the corresponding private\nkey.\n\nFor a usage example, see the description of asymmetric_encrypt().\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/enterprise-encryption-functions.html +[ASYMMETRIC_DERIVE] +declaration=pub_key_str, priv_key_str +category=Enterprise Encryption Functions +description=Derives a symmetric key using the private key of one party and the\npublic key of another, and returns the resulting key as a binary\nstring. If key derivation fails, the result is NULL.\n\npub_key_str and priv_key_str are valid PEM encoded key strings that\nwere created using the DH algorithm.\n\nSuppose that you have two pairs of public and private keys:\n\nSET @dhp = create_dh_parameters(1024);\nSET @priv1 = create_asymmetric_priv_key('DH', @dhp);\nSET @pub1 = create_asymmetric_pub_key('DH', @priv1);\nSET @priv2 = create_asymmetric_priv_key('DH', @dhp);\nSET @pub2 = create_asymmetric_pub_key('DH', @priv2);\n\nSuppose further that you use the private key from one pair and the\npublic key from the other pair to create a symmetric key string. Then\nthis symmetric key identity relationship holds:\n\nasymmetric_derive(@pub1, @priv2) = asymmetric_derive(@pub2, @priv1)\n\nThis example requires DH private/public keys as inputs, created using a\nshared symmetric secret. Create the secret by passing the key length to\ncreate_dh_parameters(), then pass the secret as the "key length" to\ncreate_asymmetric_priv_key().\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/enterprise-encryption-functions-legacy.html +[ASYMMETRIC_ENCRYPT] +declaration=algorithm, data_str, pub_key_str +category=Enterprise Encryption Functions +description=Encrypts a string using the given algorithm and key string, and returns\nthe resulting ciphertext as a binary string. If encryption fails, the\nresult is NULL.\n\nFor the legacy version of this function in use before MySQL 8.0.29, see\nhttps://dev.mysql.com/doc/refman/8.3/en/enterprise-encryption-functions\n-legacy.html.\n\nalgorithm is the encryption algorithm used to create the key. The\nsupported algorithm value is 'RSA'.\n\ndata_str is the string to encrypt. The length of this string cannot be\ngreater than the key string length in bytes, minus 42 (to account for\nthe padding).\n\npub_key_str is a valid PEM encoded RSA public key. The\nasymmetric_encrypt() component function only supports encryption using\na public key.\n\nTo recover the original unencrypted string, pass the encrypted string\nto asymmetric_decrypt(), along with the other part of the key pair used\nfor encryption, as in the following example:\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/enterprise-encryption-functions.html +[ASYMMETRIC_SIGN] +declaration=algorithm, text, priv_key_str, digest_type +category=Enterprise Encryption Functions +description=Signs a digest string or data string using a private key, and returns\nthe signature as a binary string. If signing fails, the result is NULL.\n\nFor the legacy version of this function in use before MySQL 8.0.29, see\nhttps://dev.mysql.com/doc/refman/8.3/en/enterprise-encryption-functions\n-legacy.html.\n\nalgorithm is the encryption algorithm used to create the key. The\nsupported algorithm value is 'RSA'.\n\ntext is a data string or digest string. The function accepts digests\nbut does not require them, as it is also capable of handling data\nstrings of an arbitrary length. A digest string can be generated by\ncalling create_digest().\n\npriv_key_str is the private key string to use for signing the digest\nstring. It must be a valid PEM encoded RSA private key.\n\ndigest_type is the algorithm to be used to sign the data. The supported\ndigest_type values are 'SHA224', 'SHA256', 'SHA384', and 'SHA512' when\nOpenSSL 1.0.1 is in use. If OpenSSL 1.1.1 is in use, the additional\ndigest_type values 'SHA3-224', 'SHA3-256', 'SHA3-384', and 'SHA3-512'\nare available.\n\nFor a usage example, see the description of asymmetric_verify().\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/enterprise-encryption-functions.html +[ASYMMETRIC_VERIFY] +declaration=algorithm, text, sig_str, pub_key_str, digest_type +category=Enterprise Encryption Functions +description=Verifies whether the signature string matches the digest string, and\nreturns 1 or 0 to indicate whether verification succeeded or failed. If\nverification fails, the result is NULL.\n\nFor the legacy version of this function in use before MySQL 8.0.29, see\nhttps://dev.mysql.com/doc/refman/8.3/en/enterprise-encryption-functions\n-legacy.html.\n\nBy default, the component_enterprise_encryption function assumes that\nsignatures use the RSASSA-PSS signature scheme. The function supports\nverification for signatures produced by the legacy openssl_udf shared\nlibrary functions if the system variable\nenterprise_encryption.rsa_support_legacy_padding is set to ON (the\ndefault is OFF). When ON is set, the function also supports the\nRSASSA-PKCS1-v1_5 signature scheme, as used by the legacy openssl_udf\nshared library functions. When OFF is set, signatures produced by the\nlegacy functions cannot be verified, and the function returns null\noutput for such content.\n\nalgorithm is the encryption algorithm used to create the key. The\nsupported algorithm value is 'RSA'.\n\ntext is a data string or digest string. The component function accepts\ndigests but does not require them, as it is also capable of handling\ndata strings of an arbitrary length. A digest string can be generated\nby calling create_digest().\n\nsig_str is the signature string to be verified. A signature string can\nbe generated by calling asymmetric_sign().\n\npub_key_str is the public key string of the signer. It corresponds to\nthe private key passed to asymmetric_sign() to generate the signature\nstring. It must be a valid PEM encoded RSA public key.\n\ndigest_type is the algorithm that was used to sign the data. The\nsupported digest_type values are 'SHA224', 'SHA256', 'SHA384', and\n'SHA512' when OpenSSL 1.0.1 is in use. If OpenSSL 1.1.1 is in use, the\nadditional digest_type values 'SHA3-224', 'SHA3-256', 'SHA3-384', and\n'SHA3-512' are available.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/enterprise-encryption-functions.html +[ATAN] +declaration=X +category=Numeric Functions +description=Returns the arc tangent of X, that is, the value whose tangent is X.\nReturns NULL if X is NULL\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/mathematical-functions.html +[ATAN2] +declaration=Y,X +category=Numeric Functions +description=Returns the arc tangent of the two variables X and Y. It is similar to\ncalculating the arc tangent of Y / X, except that the signs of both\narguments are used to determine the quadrant of the result. Returns\nNULL if X or Y is NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/mathematical-functions.html +[AVG] +declaration=[DISTINCT] expr +category=Aggregate Functions and Modifiers +description=Returns the average value of expr. The DISTINCT option can be used to\nreturn the average of the distinct values of expr.\n\nIf there are no matching rows, AVG() returns NULL. The function also\nreturns NULL if expr is NULL.\n\nThis function executes as a window function if over_clause is present.\nover_clause is as described in\nhttps://dev.mysql.com/doc/refman/8.3/en/window-functions-usage.html; it\ncannot be used with DISTINCT.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/aggregate-functions.html +[BENCHMARK] +declaration=count,expr +category=Information Functions +description=The BENCHMARK() function executes the expression expr repeatedly count\ntimes. It may be used to time how quickly MySQL processes the\nexpression. The result value is 0, or NULL for inappropriate arguments\nsuch as a NULL or negative repeat count.\n\nThe intended use is from within the mysql client, which reports query\nexecution times:\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/information-functions.html +[BIGINT] +declaration=M +category=Data Types +description=A large integer. The signed range is -9223372036854775808 to\n9223372036854775807. The unsigned range is 0 to 18446744073709551615.\n\nSERIAL is an alias for BIGINT UNSIGNED NOT NULL AUTO_INCREMENT UNIQUE.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/numeric-type-syntax.html +[BIN] +declaration=N +category=String Functions +description=Returns a string representation of the binary value of N, where N is a\nlonglong (BIGINT) number. This is equivalent to CONV(N,10,2). Returns\nNULL if N is NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/string-functions.html +[BINARY] +declaration=M +category=Data Types +description=The BINARY type is similar to the CHAR type, but stores binary byte\nstrings rather than nonbinary character strings. An optional length M\nrepresents the column length in bytes. If omitted, M defaults to 1.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/string-type-syntax.html +[BIN_TO_UUID] +declaration=binary_uuid +category=Miscellaneous Functions +description=BIN_TO_UUID() is the inverse of UUID_TO_BIN(). It converts a binary\nUUID to a string UUID and returns the result. The binary value should\nbe a UUID as a VARBINARY(16) value. The return value is a string of\nfive hexadecimal numbers separated by dashes. (For details about this\nformat, see the UUID() function description.) If the UUID argument is\nNULL, the return value is NULL. If any argument is invalid, an error\noccurs.\n\nBIN_TO_UUID() takes one or two arguments:\n\no The one-argument form takes a binary UUID value. The UUID value is\n assumed not to have its time-low and time-high parts swapped. The\n string result is in the same order as the binary argument.\n\no The two-argument form takes a binary UUID value and a swap-flag\n value:\n\n o If swap_flag is 0, the two-argument form is equivalent to the\n one-argument form. The string result is in the same order as the\n binary argument.\n\n o If swap_flag is 1, the UUID value is assumed to have its time-low\n and time-high parts swapped. These parts are swapped back to their\n original position in the result value.\n\nFor usage examples and information about time-part swapping, see the\nUUID_TO_BIN() function description.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/miscellaneous-functions.html +[BIT] +declaration=M +category=Data Types +description=A bit-value type. M indicates the number of bits per value, from 1 to\n64. The default is 1 if M is omitted.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/numeric-type-syntax.html +[BIT_AND] +declaration=expr +category=Aggregate Functions and Modifiers +description=Returns the bitwise AND of all bits in expr.\n\nThe result type depends on whether the function argument values are\nevaluated as binary strings or numbers:\n\no Binary-string evaluation occurs when the argument values have a\n binary string type, and the argument is not a hexadecimal literal,\n bit literal, or NULL literal. Numeric evaluation occurs otherwise,\n with argument value conversion to unsigned 64-bit integers as\n necessary.\n\no Binary-string evaluation produces a binary string of the same length\n as the argument values. If argument values have unequal lengths, an\n ER_INVALID_BITWISE_OPERANDS_SIZE\n (https://dev.mysql.com/doc/mysql-errors/8.3/en/server-error-reference\n .html#error_er_invalid_bitwise_operands_size) error occurs. If the\n argument size exceeds 511 bytes, an\n ER_INVALID_BITWISE_AGGREGATE_OPERANDS_SIZE\n (https://dev.mysql.com/doc/mysql-errors/8.3/en/server-error-reference\n .html#error_er_invalid_bitwise_aggregate_operands_size) error occurs.\n Numeric evaluation produces an unsigned 64-bit integer.\n\nIf there are no matching rows, BIT_AND() returns a neutral value (all\nbits set to 1) having the same length as the argument values.\n\nNULL values do not affect the result unless all values are NULL. In\nthat case, the result is a neutral value having the same length as the\nargument values.\n\nFor more information discussion about argument evaluation and result\ntypes, see the introductory discussion in\nhttps://dev.mysql.com/doc/refman/8.3/en/bit-functions.html.\n\nIf BIT_AND() is invoked from within the mysql client, binary string\nresults display using hexadecimal notation, depending on the value of\nthe --binary-as-hex. For more information about that option, see\nhttps://dev.mysql.com/doc/refman/8.3/en/mysql.html.\n\nThis function executes as a window function if over_clause is present.\nover_clause is as described in\nhttps://dev.mysql.com/doc/refman/8.3/en/window-functions-usage.html.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/aggregate-functions.html +[BIT_LENGTH] +declaration=str +category=String Functions +description=Returns the length of the string str in bits. Returns NULL if str is\nNULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/string-functions.html +[BIT_OR] +declaration=expr +category=Aggregate Functions and Modifiers +description=Returns the bitwise OR of all bits in expr.\n\nThe result type depends on whether the function argument values are\nevaluated as binary strings or numbers:\n\no Binary-string evaluation occurs when the argument values have a\n binary string type, and the argument is not a hexadecimal literal,\n bit literal, or NULL literal. Numeric evaluation occurs otherwise,\n with argument value conversion to unsigned 64-bit integers as\n necessary.\n\no Binary-string evaluation produces a binary string of the same length\n as the argument values. If argument values have unequal lengths, an\n ER_INVALID_BITWISE_OPERANDS_SIZE\n (https://dev.mysql.com/doc/mysql-errors/8.3/en/server-error-reference\n .html#error_er_invalid_bitwise_operands_size) error occurs. If the\n argument size exceeds 511 bytes, an\n ER_INVALID_BITWISE_AGGREGATE_OPERANDS_SIZE\n (https://dev.mysql.com/doc/mysql-errors/8.3/en/server-error-reference\n .html#error_er_invalid_bitwise_aggregate_operands_size) error occurs.\n Numeric evaluation produces an unsigned 64-bit integer.\n\nIf there are no matching rows, BIT_OR() returns a neutral value (all\nbits set to 0) having the same length as the argument values.\n\nNULL values do not affect the result unless all values are NULL. In\nthat case, the result is a neutral value having the same length as the\nargument values.\n\nFor more information discussion about argument evaluation and result\ntypes, see the introductory discussion in\nhttps://dev.mysql.com/doc/refman/8.3/en/bit-functions.html.\n\nIf BIT_OR() is invoked from within the mysql client, binary string\nresults display using hexadecimal notation, depending on the value of\nthe --binary-as-hex. For more information about that option, see\nhttps://dev.mysql.com/doc/refman/8.3/en/mysql.html.\n\nThis function executes as a window function if over_clause is present.\nover_clause is as described in\nhttps://dev.mysql.com/doc/refman/8.3/en/window-functions-usage.html.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/aggregate-functions.html +[BIT_XOR] +declaration=expr +category=Aggregate Functions and Modifiers +description=Returns the bitwise XOR of all bits in expr.\n\nThe result type depends on whether the function argument values are\nevaluated as binary strings or numbers:\n\no Binary-string evaluation occurs when the argument values have a\n binary string type, and the argument is not a hexadecimal literal,\n bit literal, or NULL literal. Numeric evaluation occurs otherwise,\n with argument value conversion to unsigned 64-bit integers as\n necessary.\n\no Binary-string evaluation produces a binary string of the same length\n as the argument values. If argument values have unequal lengths, an\n ER_INVALID_BITWISE_OPERANDS_SIZE\n (https://dev.mysql.com/doc/mysql-errors/8.3/en/server-error-reference\n .html#error_er_invalid_bitwise_operands_size) error occurs. If the\n argument size exceeds 511 bytes, an\n ER_INVALID_BITWISE_AGGREGATE_OPERANDS_SIZE\n (https://dev.mysql.com/doc/mysql-errors/8.3/en/server-error-reference\n .html#error_er_invalid_bitwise_aggregate_operands_size) error occurs.\n Numeric evaluation produces an unsigned 64-bit integer.\n\nIf there are no matching rows, BIT_XOR() returns a neutral value (all\nbits set to 0) having the same length as the argument values.\n\nNULL values do not affect the result unless all values are NULL. In\nthat case, the result is a neutral value having the same length as the\nargument values.\n\nFor more information discussion about argument evaluation and result\ntypes, see the introductory discussion in\nhttps://dev.mysql.com/doc/refman/8.3/en/bit-functions.html.\n\nIf BIT_XOR() is invoked from within the mysql client, binary string\nresults display using hexadecimal notation, depending on the value of\nthe --binary-as-hex. For more information about that option, see\nhttps://dev.mysql.com/doc/refman/8.3/en/mysql.html.\n\nThis function executes as a window function if over_clause is present.\nover_clause is as described in\nhttps://dev.mysql.com/doc/refman/8.3/en/window-functions-usage.html.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/aggregate-functions.html +[BLOB] +declaration=M +category=Data Types +description=A BLOB column with a maximum length of 65,535 (216 − 1) bytes. Each\nBLOB value is stored using a 2-byte length prefix that indicates the\nnumber of bytes in the value.\n\nAn optional length M can be given for this type. If this is done, MySQL\ncreates the column as the smallest BLOB type large enough to hold\nvalues M bytes long.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/string-type-syntax.html +[CAST] +declaration=expr AS type [ARRAY] +category=Cast Functions and Operators +description=CAST(timestamp_value AT TIME ZONE timezone_specifier AS\nDATETIME[(precision)])\n\ntimezone_specifier: [INTERVAL] '+00:00' | 'UTC'\n\nWith CAST(expr AS type syntax, the CAST() function takes an expression\nof any type and produces a result value of the specified type. This\noperation may also be expressed as CONVERT(expr, type), which is\nequivalent. If expr is NULL, CAST() returns NULL.\n\nThese type values are permitted:\n\no BINARY[(N)]\n\n Produces a string with the VARBINARY data type, except that when the\n expression expr is empty (zero length), the result type is BINARY(0).\n If the optional length N is given, BINARY(N) causes the cast to use\n no more than N bytes of the argument. Values shorter than N bytes are\n padded with 0x00 bytes to a length of N. If the optional length N is\n not given, MySQL calculates the maximum length from the expression.\n If the supplied or calculated length is greater than an internal\n threshold, the result type is BLOB. If the length is still too long,\n the result type is LONGBLOB.\n\n For a description of how casting to BINARY affects comparisons, see\n https://dev.mysql.com/doc/refman/8.3/en/binary-varbinary.html.\n\no CHAR[(N)] [charset_info]\n\n Produces a string with the VARCHAR data type, unless the expression\n expr is empty (zero length), in which case the result type is\n CHAR(0). If the optional length N is given, CHAR(N) causes the cast\n to use no more than N characters of the argument. No padding occurs\n for values shorter than N characters. If the optional length N is not\n given, MySQL calculates the maximum length from the expression. If\n the supplied or calculated length is greater than an internal\n threshold, the result type is TEXT. If the length is still too long,\n the result type is LONGTEXT.\n\n With no charset_info clause, CHAR produces a string with the default\n character set. To specify the character set explicitly, these\n charset_info values are permitted:\n\n o CHARACTER SET charset_name: Produces a string with the given\n character set.\n\n o ASCII: Shorthand for CHARACTER SET latin1.\n\n o UNICODE: Shorthand for CHARACTER SET ucs2.\n\n ... +[CEIL] +declaration=X +category=Numeric Functions +description=CEIL() is a synonym for CEILING().\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/mathematical-functions.html +[CEILING] +declaration=X +category=Numeric Functions +description=Returns the smallest integer value not less than X. Returns NULL if X\nis NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/mathematical-functions.html +[CHAR] +declaration=M +category=Data Types +description=collation_name]\n\nA fixed-length string that is always right-padded with spaces to the\nspecified length when stored. M represents the column length in\ncharacters. The range of M is 0 to 255. If M is omitted, the length is\n1.\n\n*Note*:\n\nTrailing spaces are removed when CHAR values are retrieved unless the\nPAD_CHAR_TO_FULL_LENGTH SQL mode is enabled.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/string-type-syntax.html +[CHARACTER_LENGTH] +declaration=str +category=String Functions +description=CHARACTER_LENGTH() is a synonym for CHAR_LENGTH().\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/string-functions.html +[CHARSET] +declaration=str +category=Information Functions +description=Returns the character set of the string argument, or NULL if the\nargument is NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/information-functions.html +[CHAR_LENGTH] +declaration=str +category=String Functions +description=Returns the length of the string str, measured in code points. A\nmultibyte character counts as a single code point. This means that, for\na string containing two 3-byte characters, LENGTH() returns 6, whereas\nCHAR_LENGTH() returns 2, as shown here:\n\nmysql> SET @dolphin:='海豚';\nQuery OK, 0 rows affected (0.01 sec)\n\nmysql> SELECT LENGTH(@dolphin), CHAR_LENGTH(@dolphin);\n+------------------+-----------------------+\n| LENGTH(@dolphin) | CHAR_LENGTH(@dolphin) |\n+------------------+-----------------------+\n| 6 | 2 |\n+------------------+-----------------------+\n1 row in set (0.00 sec)\n\nCHAR_LENGTH() returns NULL if str is NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/string-functions.html +[COALESCE] +declaration=value,... +category=Comparison Operators +description=Returns the first non-NULL value in the list, or NULL if there are no\nnon-NULL values.\n\nThe return type of COALESCE() is the aggregated type of the argument\ntypes.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/comparison-operators.html +[COERCIBILITY] +declaration=str +category=Information Functions +description=Returns the collation coercibility value of the string argument.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/information-functions.html +[COLLATION] +declaration=str +category=Information Functions +description=Returns the collation of the string argument.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/information-functions.html +[COMPRESS] +declaration=string_to_compress +category=Encryption Functions +description=Compresses a string and returns the result as a binary string. This\nfunction requires MySQL to have been compiled with a compression\nlibrary such as zlib. Otherwise, the return value is always NULL. The\nreturn value is also NULL if string_to_compress is NULL. The compressed\nstring can be uncompressed with UNCOMPRESS().\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/encryption-functions.html +[CONCAT] +declaration=str1,str2,... +category=String Functions +description=Returns the string that results from concatenating the arguments. May\nhave one or more arguments. If all arguments are nonbinary strings, the\nresult is a nonbinary string. If the arguments include any binary\nstrings, the result is a binary string. A numeric argument is converted\nto its equivalent nonbinary string form.\n\nCONCAT() returns NULL if any argument is NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/string-functions.html +[CONCAT_WS] +declaration=separator,str1,str2,... +category=String Functions +description=CONCAT_WS() stands for Concatenate With Separator and is a special form\nof CONCAT(). The first argument is the separator for the rest of the\narguments. The separator is added between the strings to be\nconcatenated. The separator can be a string, as can the rest of the\narguments. If the separator is NULL, the result is NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/string-functions.html +[CONNECTION_ID] +declaration= +category=Information Functions +description=Returns the connection ID (thread ID) for the connection. Every\nconnection has an ID that is unique among the set of currently\nconnected clients.\n\nThe value returned by CONNECTION_ID() is the same type of value as\ndisplayed in the ID column of the Information Schema PROCESSLIST table,\nthe Id column of SHOW PROCESSLIST output, and the PROCESSLIST_ID column\nof the Performance Schema threads table.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/information-functions.html +[CONV] +declaration=N,from_base,to_base +category=Numeric Functions +description=Converts numbers between different number bases. Returns a string\nrepresentation of the number N, converted from base from_base to base\nto_base. Returns NULL if any argument is NULL. The argument N is\ninterpreted as an integer, but may be specified as an integer or a\nstring. The minimum base is 2 and the maximum base is 36. If from_base\nis a negative number, N is regarded as a signed number. Otherwise, N is\ntreated as unsigned. CONV() works with 64-bit precision.\n\nCONV() returns NULL if any of its arguments are NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/mathematical-functions.html +[CONVERT] +declaration=expr USING transcoding_name +category=Cast Functions and Operators +description=CONVERT(expr,type)\n\nCONVERT(expr USING transcoding_name) is standard SQL syntax. The\nnon-USING form of CONVERT() is ODBC syntax. Regardless of the syntax\nused, the function returns NULL if expr is NULL.\n\nCONVERT(expr USING transcoding_name) converts data between different\ncharacter sets. In MySQL, transcoding names are the same as the\ncorresponding character set names. For example, this statement converts\nthe string 'abc' in the default character set to the corresponding\nstring in the utf8mb4 character set:\n\nSELECT CONVERT('abc' USING utf8mb4);\n\nCONVERT(expr, type) syntax (without USING) takes an expression and a\ntype value specifying a result type, and produces a result value of the\nspecified type. This operation may also be expressed as CAST(expr AS\ntype), which is equivalent. For more information, see the description\nof CAST().\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/cast-functions.html +[CONVERT_TZ] +declaration=dt,from_tz,to_tz +category=Date and Time Functions +description=CONVERT_TZ() converts a datetime value dt from the time zone given by\nfrom_tz to the time zone given by to_tz and returns the resulting\nvalue. Time zones are specified as described in\nhttps://dev.mysql.com/doc/refman/8.3/en/time-zone-support.html. This\nfunction returns NULL if any of the arguments are invalid, or if any of\nthem are NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/date-and-time-functions.html +[COS] +declaration=X +category=Numeric Functions +description=Returns the cosine of X, where X is given in radians. Returns NULL if X\nis NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/mathematical-functions.html +[COT] +declaration=X +category=Numeric Functions +description=Returns the cotangent of X. Returns NULL if X is NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/mathematical-functions.html +[COUNT] +declaration=expr +category=Aggregate Functions and Modifiers +description=Returns a count of the number of non-NULL values of expr in the rows\nretrieved by a SELECT statement. The result is a BIGINT value.\n\nIf there are no matching rows, COUNT() returns 0. COUNT(NULL) returns\n0.\n\nThis function executes as a window function if over_clause is present.\nover_clause is as described in\nhttps://dev.mysql.com/doc/refman/8.3/en/window-functions-usage.html.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/aggregate-functions.html +[CRC32] +declaration=expr +category=Numeric Functions +description=Computes a cyclic redundancy check value and returns a 32-bit unsigned\nvalue. The result is NULL if the argument is NULL. The argument is\nexpected to be a string and (if possible) is treated as one if it is\nnot.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/mathematical-functions.html +[CREATE_ASYMMETRIC_PRIV_KEY] +declaration=algorithm, key_length +category=Enterprise Encryption Functions +description=Creates a private key using the given algorithm and key length, and\nreturns the key as a binary string in PEM format. The key is in PKCS #8\nformat. If key generation fails, the result is NULL.\n\nFor the legacy version of this function in use before MySQL 8.0.29, see\nhttps://dev.mysql.com/doc/refman/8.3/en/enterprise-encryption-functions\n-legacy.html.\n\nalgorithm is the encryption algorithm used to create the key. The\nsupported algorithm value is 'RSA'.\n\nkey_length is the key length in bits. If you exceed the maximum allowed\nkey length or specify less than the minimum, key generation fails and\nthe result is null output. The minimum allowed key length in bits is\n2048. The maximum allowed key length is the value of the\nenterprise_encryption.maximum_rsa_key_size system variable, which\ndefaults to 4096. It has a maximum setting of 16384, which is the\nmaximum key length allowed for the RSA algorithm. See\nhttps://dev.mysql.com/doc/refman/8.3/en/enterprise-encryption-configuri\nng.html.\n\n*Note*:\n\nGenerating longer keys can consume significant CPU resources. Limiting\nthe key length using the enterprise_encryption.maximum_rsa_key_size\nsystem variable lets you provide adequate security for your\nrequirements while balancing this with resource usage.\n\nThis example creates a 2048-bit RSA private key, then derives a public\nkey from the private key:\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/enterprise-encryption-functions.html +[CREATE_ASYMMETRIC_PUB_KEY] +declaration=algorithm, priv_key_str +category=Enterprise Encryption Functions +description=Derives a public key from the given private key using the given\nalgorithm, and returns the key as a binary string in PEM format. The\nkey is in PKCS #8 format. If key derivation fails, the result is NULL.\n\nFor the legacy version of this function in use before MySQL 8.0.29, see\nhttps://dev.mysql.com/doc/refman/8.3/en/enterprise-encryption-functions\n-legacy.html.\n\nalgorithm is the encryption algorithm used to create the key. The\nsupported algorithm value is 'RSA'.\n\npriv_key_str is a valid PEM encoded RSA private key.\n\nFor a usage example, see the description of\ncreate_asymmetric_priv_key().\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/enterprise-encryption-functions.html +[CREATE_DH_PARAMETERS] +declaration=key_len +category=Enterprise Encryption Functions +description=Creates a shared secret for generating a DH private/public key pair and\nreturns a binary string that can be passed to\ncreate_asymmetric_priv_key(). If secret generation fails, the result is\nNULL.\n\nkey_len is the key length. The minimum and maximum key lengths in bits\nare 1,024 and 10,000. These key-length limits are constraints imposed\nby OpenSSL. Server administrators can impose additional limits on\nmaximum key length by setting the MYSQL_OPENSSL_UDF_RSA_BITS_THRESHOLD,\nMYSQL_OPENSSL_UDF_DSA_BITS_THRESHOLD, and\nMYSQL_OPENSSL_UDF_DH_BITS_THRESHOLD environment variables. See\nhttps://dev.mysql.com/doc/refman/8.3/en/enterprise-encryption-configuri\nng.html.\n\nFor an example showing how to use the return value for generating\nsymmetric keys, see the description of asymmetric_derive().\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/enterprise-encryption-functions-legacy.html +[CREATE_DIGEST] +declaration=digest_type, str +category=Enterprise Encryption Functions +description=Creates a digest from the given string using the given digest type, and\nreturns the digest as a binary string. If digest generation fails, the\nresult is NULL.\n\nFor the legacy version of this function in use before MySQL 8.0.29, see\nhttps://dev.mysql.com/doc/refman/8.3/en/enterprise-encryption-functions\n-legacy.html.\n\nThe resulting digest string is suitable for use with asymmetric_sign()\nand asymmetric_verify(). The component versions of these functions\naccept digests but do not require them, as they are capable of handling\ndata of an arbitrary length.\n\ndigest_type is the digest algorithm to be used to generate the digest\nstring. The supported digest_type values are 'SHA224', 'SHA256',\n'SHA384', and 'SHA512' when OpenSSL 1.0.1 is in use. If OpenSSL 1.1.1\nis in use, the additional digest_type values 'SHA3-224', 'SHA3-256',\n'SHA3-384', and 'SHA3-512' are available.\n\nstr is the non-null data string for which the digest is to be\ngenerated.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/enterprise-encryption-functions.html +[CUME_DIST] +declaration= +category=Window Functions +description=Returns the cumulative distribution of a value within a group of\nvalues; that is, the percentage of partition values less than or equal\nto the value in the current row. This represents the number of rows\npreceding or peer with the current row in the window ordering of the\nwindow partition divided by the total number of rows in the window\npartition. Return values range from 0 to 1.\n\nThis function should be used with ORDER BY to sort partition rows into\nthe desired order. Without ORDER BY, all rows are peers and have value\nN/N = 1, where N is the partition size.\n\nover_clause is as described in\nhttps://dev.mysql.com/doc/refman/8.3/en/window-functions-usage.html.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/window-function-descriptions.html +[CURDATE] +declaration= +category=Date and Time Functions +description=Returns the current date as a value in 'YYYY-MM-DD' or YYYYMMDD format,\ndepending on whether the function is used in string or numeric context.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/date-and-time-functions.html +[CURRENT_DATE] +declaration= +category=Date and Time Functions +description=CURRENT_DATE and CURRENT_DATE() are synonyms for CURDATE().\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/date-and-time-functions.html +[CURRENT_ROLE] +declaration= +category=Information Functions +description=Returns a utf8mb3 string containing the current active roles for the\ncurrent session, separated by commas, or NONE if there are none. The\nvalue reflects the setting of the sql_quote_show_create system\nvariable.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/information-functions.html +[CURRENT_TIME] +declaration=[fsp] +category=Date and Time Functions +description=CURRENT_TIME and CURRENT_TIME() are synonyms for CURTIME().\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/date-and-time-functions.html +[CURRENT_TIMESTAMP] +declaration=[fsp] +category=Date and Time Functions +description=CURRENT_TIMESTAMP and CURRENT_TIMESTAMP() are synonyms for NOW().\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/date-and-time-functions.html +[CURRENT_USER] +declaration= +category=Information Functions +description=Returns the user name and host name combination for the MySQL account\nthat the server used to authenticate the current client. This account\ndetermines your access privileges. The return value is a string in the\nutf8mb3 character set.\n\nThe value of CURRENT_USER() can differ from the value of USER().\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/information-functions.html +[CURTIME] +declaration=[fsp] +category=Date and Time Functions +description=Returns the current time as a value in 'hh:mm:ss' or hhmmss format,\ndepending on whether the function is used in string or numeric context.\nThe value is expressed in the session time zone.\n\nIf the fsp argument is given to specify a fractional seconds precision\nfrom 0 to 6, the return value includes a fractional seconds part of\nthat many digits.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/date-and-time-functions.html +[DATABASE] +declaration= +category=Information Functions +description=Returns the default (current) database name as a string in the utf8mb3\ncharacter set. If there is no default database, DATABASE() returns\nNULL. Within a stored routine, the default database is the database\nthat the routine is associated with, which is not necessarily the same\nas the database that is the default in the calling context.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/information-functions.html +[DATEDIFF] +declaration=expr1,expr2 +category=Date and Time Functions +description=DATEDIFF() returns expr1 − expr2 expressed as a value in days from\none date to the other. expr1 and expr2 are date or date-and-time\nexpressions. Only the date parts of the values are used in the\ncalculation.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/date-and-time-functions.html +[DATETIME] +declaration=fsp +category=Data Types +description=A date and time combination. The supported range is '1000-01-01\n00:00:00.000000' to '9999-12-31 23:59:59.499999'. MySQL displays\nDATETIME values in 'YYYY-MM-DD hh:mm:ss[.fraction]' format, but permits\nassignment of values to DATETIME columns using either strings or\nnumbers.\n\nAn optional fsp value in the range from 0 to 6 may be given to specify\nfractional seconds precision. A value of 0 signifies that there is no\nfractional part. If omitted, the default precision is 0.\n\nAutomatic initialization and updating to the current date and time for\nDATETIME columns can be specified using DEFAULT and ON UPDATE column\ndefinition clauses, as described in\nhttps://dev.mysql.com/doc/refman/8.3/en/timestamp-initialization.html.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/date-and-time-type-syntax.html +[DATE_ADD] +declaration=date,INTERVAL expr unit +category=Date and Time Functions +description=These functions perform date arithmetic. The date argument specifies\nthe starting date or datetime value. expr is an expression specifying\nthe interval value to be added or subtracted from the starting date.\nexpr is evaluated as a string; it may start with a - for negative\nintervals. unit is a keyword indicating the units in which the\nexpression should be interpreted.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/date-and-time-functions.html +[DATE_FORMAT] +declaration=date,format +category=Date and Time Functions +description=Formats the date value according to the format string. If either\nargument is NULL, the function returns NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/date-and-time-functions.html +[DATE_SUB] +declaration=date,INTERVAL expr unit +category=Date and Time Functions +description=See the description for DATE_ADD().\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/date-and-time-functions.html +[DAY] +declaration=date +category=Date and Time Functions +description=DAY() is a synonym for DAYOFMONTH().\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/date-and-time-functions.html +[DAYNAME] +declaration=date +category=Date and Time Functions +description=Returns the name of the weekday for date. The language used for the\nname is controlled by the value of the lc_time_names system variable\n(see https://dev.mysql.com/doc/refman/8.3/en/locale-support.html).\nReturns NULL if date is NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/date-and-time-functions.html +[DAYOFMONTH] +declaration=date +category=Date and Time Functions +description=Returns the day of the month for date, in the range 1 to 31, or 0 for\ndates such as '0000-00-00' or '2008-00-00' that have a zero day part.\nReturns NULL if date is NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/date-and-time-functions.html +[DAYOFWEEK] +declaration=date +category=Date and Time Functions +description=Returns the weekday index for date (1 = Sunday, 2 = Monday, ..., 7 =\nSaturday). These index values correspond to the ODBC standard. Returns\nNULL if date is NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/date-and-time-functions.html +[DAYOFYEAR] +declaration=date +category=Date and Time Functions +description=Returns the day of the year for date, in the range 1 to 366. Returns\nNULL if date is NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/date-and-time-functions.html +[DEC] +declaration=M[,D] +category=Data Types +description=[ZEROFILL], FIXED[(M[,D])] [UNSIGNED] [ZEROFILL]\n\nThese types are synonyms for DECIMAL. The FIXED synonym is available\nfor compatibility with other database systems.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/numeric-type-syntax.html +[DECIMAL] +declaration=M[,D] +category=Data Types +description=A packed "exact" fixed-point number. M is the total number of digits\n(the precision) and D is the number of digits after the decimal point\n(the scale). The decimal point and (for negative numbers) the - sign\nare not counted in M. If D is 0, values have no decimal point or\nfractional part. The maximum number of digits (M) for DECIMAL is 65.\nThe maximum number of supported decimals (D) is 30. If D is omitted,\nthe default is 0. If M is omitted, the default is 10. (There is also a\nlimit on how long the text of DECIMAL literals can be; see\nhttps://dev.mysql.com/doc/refman/8.3/en/precision-math-expressions.html\n.)\n\nUNSIGNED, if specified, disallows negative values. The UNSIGNED\nattribute is deprecated for columns of type DECIMAL (and any synonyms);\nyou should expect support for it to be removed in a future version of\nMySQL. Consider using a simple CHECK constraint instead for such\ncolumns.\n\nAll basic calculations (+, -, *, /) with DECIMAL columns are done with\na precision of 65 digits.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/numeric-type-syntax.html +[DEFAULT] +declaration=col_name +category=Miscellaneous Functions +description=Returns the default value for a table column. An error results if the\ncolumn has no default value.\n\nThe use of DEFAULT(col_name) to specify the default value for a named\ncolumn is permitted only for columns that have a literal default value,\nnot for columns that have an expression default value.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/miscellaneous-functions.html +[DEGREES] +declaration=X +category=Numeric Functions +description=Returns the argument X, converted from radians to degrees. Returns NULL\nif X is NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/mathematical-functions.html +[DENSE_RANK] +declaration= +category=Window Functions +description=Returns the rank of the current row within its partition, without gaps.\nPeers are considered ties and receive the same rank. This function\nassigns consecutive ranks to peer groups; the result is that groups of\nsize greater than one do not produce noncontiguous rank numbers. For an\nexample, see the RANK() function description.\n\nThis function should be used with ORDER BY to sort partition rows into\nthe desired order. Without ORDER BY, all rows are peers.\n\nover_clause is as described in\nhttps://dev.mysql.com/doc/refman/8.3/en/window-functions-usage.html.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/window-function-descriptions.html +[DOUBLE] +declaration=M,D +category=Data Types +description=A normal-size (double-precision) floating-point number. Permissible\nvalues are -1.7976931348623157E+308 to -2.2250738585072014E-308, 0, and\n2.2250738585072014E-308 to 1.7976931348623157E+308. These are the\ntheoretical limits, based on the IEEE standard. The actual range might\nbe slightly smaller depending on your hardware or operating system.\n\nM is the total number of digits and D is the number of digits following\nthe decimal point. If M and D are omitted, values are stored to the\nlimits permitted by the hardware. A double-precision floating-point\nnumber is accurate to approximately 15 decimal places.\n\nDOUBLE(M,D) is a nonstandard MySQL extension; and is deprecated. You\nshould expect support for this syntax to be removed in a future version\nof MySQL.\n\nUNSIGNED, if specified, disallows negative values. The UNSIGNED\nattribute is deprecated for columns of type DOUBLE (and any synonyms)\nand you should expect support for it to be removed in a future version\nof MySQL. Consider using a simple CHECK constraint instead for such\ncolumns.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/numeric-type-syntax.html +[ELT] +declaration=N,str1,str2,str3,... +category=String Functions +description=ELT() returns the Nth element of the list of strings: str1 if N = 1,\nstr2 if N = 2, and so on. Returns NULL if N is less than 1, greater\nthan the number of arguments, or NULL. ELT() is the complement of\nFIELD().\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/string-functions.html +[ENUM] +declaration='value1','value2',... +category=Data Types +description=collation_name]\n\nAn enumeration. A string object that can have only one value, chosen\nfrom the list of values 'value1', 'value2', ..., NULL or the special ''\nerror value. ENUM values are represented internally as integers.\n\nAn ENUM column can have a maximum of 65,535 distinct elements.\n\nThe maximum supported length of an individual ENUM element is M <= 255\nand (M x w) <= 1020, where M is the element literal length and w is the\nnumber of bytes required for the maximum-length character in the\ncharacter set.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/string-type-syntax.html +[EXP] +declaration=X +category=Numeric Functions +description=Returns the value of e (the base of natural logarithms) raised to the\npower of X. The inverse of this function is LOG() (using a single\nargument only) or LN().\n\nIf X is NULL, this function returns NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/mathematical-functions.html +[EXPORT_SET] +declaration=bits,on,off[,separator[,number_of_bits]] +category=String Functions +description=Returns a string such that for every bit set in the value bits, you get\nan on string and for every bit not set in the value, you get an off\nstring. Bits in bits are examined from right to left (from low-order to\nhigh-order bits). Strings are added to the result from left to right,\nseparated by the separator string (the default being the comma\ncharacter ,). The number of bits examined is given by number_of_bits,\nwhich has a default of 64 if not specified. number_of_bits is silently\nclipped to 64 if larger than 64. It is treated as an unsigned integer,\nso a value of −1 is effectively the same as 64.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/string-functions.html +[EXTRACT] +declaration=unit FROM date +category=Date and Time Functions +description=The EXTRACT() function uses the same kinds of unit specifiers as\nDATE_ADD() or DATE_SUB(), but extracts parts from the date rather than\nperforming date arithmetic. For information on the unit argument, see\nhttps://dev.mysql.com/doc/refman/8.3/en/expressions.html#temporal-inter\nvals. Returns NULL if date is NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/date-and-time-functions.html +[EXTRACTVALUE] +declaration=xml_frag, xpath_expr +category=XML +description=ExtractValue() takes two string arguments, a fragment of XML markup\nxml_frag and an XPath expression xpath_expr (also known as a locator);\nit returns the text (CDATA) of the first text node which is a child of\nthe element or elements matched by the XPath expression.\n\nUsing this function is the equivalent of performing a match using the\nxpath_expr after appending /text(). In other words,\nExtractValue('Sakila', '/a/b') and\nExtractValue('Sakila', '/a/b/text()') produce the same\nresult. If xml_frag or xpath_expr is NULL, the function returns NULL.\n\nIf multiple matches are found, the content of the first child text node\nof each matching element is returned (in the order matched) as a\nsingle, space-delimited string.\n\nIf no matching text node is found for the expression (including the\nimplicit /text())---for whatever reason, as long as xpath_expr is\nvalid, and xml_frag consists of elements which are properly nested and\nclosed---an empty string is returned. No distinction is made between a\nmatch on an empty element and no match at all. This is by design.\n\nIf you need to determine whether no matching element was found in\nxml_frag or such an element was found but contained no child text\nnodes, you should test the result of an expression that uses the XPath\ncount() function. For example, both of these statements return an empty\nstring, as shown here:\n\nmysql> SELECT ExtractValue('', '/a/b');\n+-------------------------------------+\n| ExtractValue('', '/a/b') |\n+-------------------------------------+\n| |\n+-------------------------------------+\n1 row in set (0.00 sec)\n\nmysql> SELECT ExtractValue('', '/a/b');\n+-------------------------------------+\n| ExtractValue('', '/a/b') |\n+-------------------------------------+\n| |\n+-------------------------------------+\n1 row in set (0.00 sec)\n\nHowever, you can determine whether there was actually a matching\nelement using the following:\n\nmysql> SELECT ExtractValue('', 'count(/a/b)');\n+-------------------------------------+\n| ExtractValue('', 'count(/a/b)') |\n+-------------------------------------+\n ... +[FIELD] +declaration=str,str1,str2,str3,... +category=String Functions +description=Returns the index (position) of str in the str1, str2, str3, ... list.\nReturns 0 if str is not found.\n\nIf all arguments to FIELD() are strings, all arguments are compared as\nstrings. If all arguments are numbers, they are compared as numbers.\nOtherwise, the arguments are compared as double.\n\nIf str is NULL, the return value is 0 because NULL fails equality\ncomparison with any value. FIELD() is the complement of ELT().\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/string-functions.html +[FIND_IN_SET] +declaration=str,strlist +category=String Functions +description=Returns a value in the range of 1 to N if the string str is in the\nstring list strlist consisting of N substrings. A string list is a\nstring composed of substrings separated by , characters. If the first\nargument is a constant string and the second is a column of type SET,\nthe FIND_IN_SET() function is optimized to use bit arithmetic. Returns\n0 if str is not in strlist or if strlist is the empty string. Returns\nNULL if either argument is NULL. This function does not work properly\nif the first argument contains a comma (,) character.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/string-functions.html +[FIRST_VALUE] +declaration=expr +category=Window Functions +description=Returns the value of expr from the first row of the window frame.\n\nover_clause is as described in\nhttps://dev.mysql.com/doc/refman/8.3/en/window-functions-usage.html.\nnull_treatment is as described in the section introduction.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/window-function-descriptions.html +[FLOAT] +declaration=M,D +category=Data Types +description=A small (single-precision) floating-point number. Permissible values\nare -3.402823466E+38 to -1.175494351E-38, 0, and 1.175494351E-38 to\n3.402823466E+38. These are the theoretical limits, based on the IEEE\nstandard. The actual range might be slightly smaller depending on your\nhardware or operating system.\n\nM is the total number of digits and D is the number of digits following\nthe decimal point. If M and D are omitted, values are stored to the\nlimits permitted by the hardware. A single-precision floating-point\nnumber is accurate to approximately 7 decimal places.\n\nFLOAT(M,D) is a nonstandard MySQL extension. This syntax is deprecated,\nand you should expect support for it to be removed in a future version\nof MySQL.\n\nUNSIGNED, if specified, disallows negative values. The UNSIGNED\nattribute is deprecated for columns of type FLOAT (and any synonyms)\nand you should expect support for it to be removed in a future version\nof MySQL. Consider using a simple CHECK constraint instead for such\ncolumns.\n\nUsing FLOAT might give you some unexpected problems because all\ncalculations in MySQL are done with double precision. See\nhttps://dev.mysql.com/doc/refman/8.3/en/no-matching-rows.html.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/numeric-type-syntax.html +[FLOOR] +declaration=X +category=Numeric Functions +description=Returns the largest integer value not greater than X. Returns NULL if X\nis NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/mathematical-functions.html +[FORMAT] +declaration=X,D[,locale] +category=String Functions +description=Formats the number X to a format like '#,###,###.##', rounded to D\ndecimal places, and returns the result as a string. If D is 0, the\nresult has no decimal point or fractional part. If X or D is NULL, the\nfunction returns NULL.\n\nThe optional third parameter enables a locale to be specified to be\nused for the result number's decimal point, thousands separator, and\ngrouping between separators. Permissible locale values are the same as\nthe legal values for the lc_time_names system variable (see\nhttps://dev.mysql.com/doc/refman/8.3/en/locale-support.html). If the\nlocale is NULL or not specified, the default locale is 'en_US'.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/string-functions.html +[FORMAT_BYTES] +declaration=count +category=Performance Schema Functions +description=Given a numeric byte count, converts it to human-readable format and\nreturns a string consisting of a value and a units indicator. The\nstring contains the number of bytes rounded to 2 decimal places and a\nminimum of 3 significant digits. Numbers less than 1024 bytes are\nrepresented as whole numbers and are not rounded. Returns NULL if count\nis NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/performance-schema-functions.html +[FORMAT_PICO_TIME] +declaration=time_val +category=Performance Schema Functions +description=Given a numeric Performance Schema latency or wait time in picoseconds,\nconverts it to human-readable format and returns a string consisting of\na value and a units indicator. The string contains the decimal time\nrounded to 2 decimal places and a minimum of 3 significant digits.\nTimes under 1 nanosecond are represented as whole numbers and are not\nrounded.\n\nIf time_val is NULL, this function returns NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/performance-schema-functions.html +[FOUND_ROWS] +declaration= +category=Information Functions +description=*Note*:\n\nThe SQL_CALC_FOUND_ROWS query modifier and accompanying FOUND_ROWS()\nfunction are deprecated; expect them to be removed in a future version\nof MySQL. Execute the query with LIMIT, and then a second query with\nCOUNT(*) and without LIMIT to determine whether there are additional\nrows. For example, instead of these queries:\n\nSELECT SQL_CALC_FOUND_ROWS * FROM tbl_name WHERE id > 100 LIMIT 10;\nSELECT FOUND_ROWS();\n\nUse these queries instead:\n\nSELECT * FROM tbl_name WHERE id > 100 LIMIT 10;\nSELECT COUNT(*) FROM tbl_name WHERE id > 100;\n\nCOUNT(*) is subject to certain optimizations. SQL_CALC_FOUND_ROWS\ncauses some optimizations to be disabled.\n\nA SELECT statement may include a LIMIT clause to restrict the number of\nrows the server returns to the client. In some cases, it is desirable\nto know how many rows the statement would have returned without the\nLIMIT, but without running the statement again. To obtain this row\ncount, include an SQL_CALC_FOUND_ROWS option in the SELECT statement,\nand then invoke FOUND_ROWS() afterward:\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/information-functions.html +[FROM_BASE64] +declaration=str +category=String Functions +description=Takes a string encoded with the base-64 encoded rules used by\nTO_BASE64() and returns the decoded result as a binary string. The\nresult is NULL if the argument is NULL or not a valid base-64 string.\nSee the description of TO_BASE64() for details about the encoding and\ndecoding rules.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/string-functions.html +[FROM_DAYS] +declaration=N +category=Date and Time Functions +description=Given a day number N, returns a DATE value. Returns NULL if N is NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/date-and-time-functions.html +[FROM_UNIXTIME] +declaration=unix_timestamp[,format] +category=Date and Time Functions +description=Returns a representation of unix_timestamp as a datetime or character\nstring value. The value returned is expressed using the session time\nzone. (Clients can set the session time zone as described in\nhttps://dev.mysql.com/doc/refman/8.3/en/time-zone-support.html.)\nunix_timestamp is an internal timestamp value representing seconds\nsince '1970-01-01 00:00:00' UTC, such as produced by the\nUNIX_TIMESTAMP() function.\n\nIf format is omitted, this function returns a DATETIME value.\n\nIf unix_timestamp or format is NULL, this function returns NULL.\n\nIf unix_timestamp is an integer, the fractional seconds precision of\nthe DATETIME is zero. When unix_timestamp is a decimal value, the\nfractional seconds precision of the DATETIME is the same as the\nprecision of the decimal value, up to a maximum of 6. When\nunix_timestamp is a floating point number, the fractional seconds\nprecision of the datetime is 6.\n\nOn 32-bit platforms, the maximum useful value for unix_timestamp is\n2147483647.999999, which returns '2038-01-19 03:14:07.999999' UTC. On\n64-bit platforms, the effective maximum is 32536771199.999999, which\nreturns '3001-01-18 23:59:59.999999' UTC. Regardless of platform or\nversion, a greater value for unix_timestamp than the effective maximum\nreturns 0.\n\nformat is used to format the result in the same way as the format\nstring used for the DATE_FORMAT() function. If format is supplied, the\nvalue returned is a VARCHAR.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/date-and-time-functions.html +[GEOMCOLLECTION] +declaration=g [, g] ... +category=Geometry Constructors +description=Constructs a GeomCollection value from the geometry arguments.\n\nGeomCollection() returns all the proper geometries contained in the\narguments even if a nonsupported geometry is present.\n\nGeomCollection() with no arguments is permitted as a way to create an\nempty geometry. Also, functions such as ST_GeomFromText() that accept\nWKT geometry collection arguments understand both OpenGIS\n'GEOMETRYCOLLECTION EMPTY' standard syntax and MySQL\n'GEOMETRYCOLLECTION()' nonstandard syntax.\n\nGeomCollection() and GeometryCollection() are synonymous, with\nGeomCollection() the preferred function.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/gis-mysql-specific-functions.html +[GEOMETRYCOLLECTION] +declaration=g [, g] ... +category=Geometry Constructors +description=Constructs a GeomCollection value from the geometry arguments.\n\nGeometryCollection() returns all the proper geometries contained in the\narguments even if a nonsupported geometry is present.\n\nGeometryCollection() with no arguments is permitted as a way to create\nan empty geometry. Also, functions such as ST_GeomFromText() that\naccept WKT geometry collection arguments understand both OpenGIS\n'GEOMETRYCOLLECTION EMPTY' standard syntax and MySQL\n'GEOMETRYCOLLECTION()' nonstandard syntax.\n\nGeomCollection() and GeometryCollection() are synonymous, with\nGeomCollection() the preferred function.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/gis-mysql-specific-functions.html +[GET_FORMAT] +declaration={DATE|TIME|DATETIME}, {'EUR'|'USA'|'JIS'|'ISO'|'INTERNAL'} +category=Date and Time Functions +description=Returns a format string. This function is useful in combination with\nthe DATE_FORMAT() and the STR_TO_DATE() functions.\n\nIf format is NULL, this function returns NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/date-and-time-functions.html +[GET_LOCK] +declaration=str,timeout +category=Locking Functions +description=Tries to obtain a lock with a name given by the string str, using a\ntimeout of timeout seconds. A negative timeout value means infinite\ntimeout. The lock is exclusive. While held by one session, other\nsessions cannot obtain a lock of the same name.\n\nReturns 1 if the lock was obtained successfully, 0 if the attempt timed\nout (for example, because another client has previously locked the\nname), or NULL if an error occurred (such as running out of memory or\nthe thread was killed with mysqladmin kill).\n\nA lock obtained with GET_LOCK() is released explicitly by executing\nRELEASE_LOCK() or implicitly when your session terminates (either\nnormally or abnormally). Locks obtained with GET_LOCK() are not\nreleased when transactions commit or roll back.\n\nGET_LOCK() is implemented using the metadata locking (MDL) subsystem.\nMultiple simultaneous locks can be acquired and GET_LOCK() does not\nrelease any existing locks. For example, suppose that you execute these\nstatements:\n\nSELECT GET_LOCK('lock1',10);\nSELECT GET_LOCK('lock2',10);\nSELECT RELEASE_LOCK('lock2');\nSELECT RELEASE_LOCK('lock1');\n\nThe second GET_LOCK() acquires a second lock and both RELEASE_LOCK()\ncalls return 1 (success).\n\nIt is even possible for a given session to acquire multiple locks for\nthe same name. Other sessions cannot acquire a lock with that name\nuntil the acquiring session releases all its locks for the name.\n\nUniquely named locks acquired with GET_LOCK() appear in the Performance\nSchema metadata_locks table. The OBJECT_TYPE column says USER LEVEL\nLOCK and the OBJECT_NAME column indicates the lock name. In the case\nthat multiple locks are acquired for the same name, only the first lock\nfor the name registers a row in the metadata_locks table. Subsequent\nlocks for the name increment a counter in the lock but do not acquire\nadditional metadata locks. The metadata_locks row for the lock is\ndeleted when the last lock instance on the name is released.\n\nThe capability of acquiring multiple locks means there is the\npossibility of deadlock among clients. When this happens, the server\nchooses a caller and terminates its lock-acquisition request with an\nER_USER_LOCK_DEADLOCK\n(https://dev.mysql.com/doc/mysql-errors/8.3/en/server-error-reference.html\n#error_er_user_lock_deadlock) error. This error does not cause\ntransactions to roll back.\n\nMySQL enforces a maximum length on lock names of 64 characters.\n ... +[GREATEST] +declaration=value1,value2,... +category=Comparison Operators +description=With two or more arguments, returns the largest (maximum-valued)\nargument. The arguments are compared using the same rules as for\nLEAST().\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/comparison-operators.html +[GROUPING] +declaration=expr [, expr] ... +category=Miscellaneous Functions +description=For GROUP BY queries that include a WITH ROLLUP modifier, the ROLLUP\noperation produces super-aggregate output rows where NULL represents\nthe set of all values. The GROUPING() function enables you to\ndistinguish NULL values for super-aggregate rows from NULL values in\nregular grouped rows.\n\nGROUPING() is permitted in the select list, HAVING clause, and ORDER BY\nclause.\n\nEach argument to GROUPING() must be an expression that exactly matches\nan expression in the GROUP BY clause. The expression cannot be a\npositional specifier. For each expression, GROUPING() produces 1 if the\nexpression value in the current row is a NULL representing a\nsuper-aggregate value. Otherwise, GROUPING() produces 0, indicating\nthat the expression value is a NULL for a regular result row or is not\nNULL.\n\nSuppose that table t1 contains these rows, where NULL indicates\nsomething like "other" or "unknown":\n\nmysql> SELECT * FROM t1;\n+------+-------+----------+\n| name | size | quantity |\n+------+-------+----------+\n| ball | small | 10 |\n| ball | large | 20 |\n| ball | NULL | 5 |\n| hoop | small | 15 |\n| hoop | large | 5 |\n| hoop | NULL | 3 |\n+------+-------+----------+\n\nA summary of the table without WITH ROLLUP looks like this:\n\nmysql> SELECT name, size, SUM(quantity) AS quantity\n FROM t1\n GROUP BY name, size;\n+------+-------+----------+\n| name | size | quantity |\n+------+-------+----------+\n| ball | small | 10 |\n| ball | large | 20 |\n| ball | NULL | 5 |\n| hoop | small | 15 |\n| hoop | large | 5 |\n| hoop | NULL | 3 |\n+------+-------+----------+\n\nThe result contains NULL values, but those do not represent\nsuper-aggregate rows because the query does not include WITH ROLLUP.\n ... +[GROUP_CONCAT] +declaration=expr +category=Aggregate Functions and Modifiers +description=This function returns a string result with the concatenated non-NULL\nvalues from a group. It returns NULL if there are no non-NULL values.\nThe full syntax is as follows:\n\nGROUP_CONCAT([DISTINCT] expr [,expr ...]\n [ORDER BY {unsigned_integer | col_name | expr}\n [ASC | DESC] [,col_name ...]]\n [SEPARATOR str_val])\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/aggregate-functions.html +[GTID_SUBSET] +declaration=set1,set2 +category=GTID +description=Given two sets of global transaction identifiers set1 and set2, returns\ntrue if all GTIDs in set1 are also in set2. Returns NULL if set1 or\nset2 is NULL. Returns false otherwise.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/gtid-functions.html +[GTID_SUBTRACT] +declaration=set1,set2 +category=GTID +description=Given two sets of global transaction identifiers set1 and set2, returns\nonly those GTIDs from set1 that are not in set2. Returns NULL if set1\nor set2 is NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/gtid-functions.html +[HEX] +declaration=str +category=String Functions +description=For a string argument str, HEX() returns a hexadecimal string\nrepresentation of str where each byte of each character in str is\nconverted to two hexadecimal digits. (Multibyte characters therefore\nbecome more than two digits.) The inverse of this operation is\nperformed by the UNHEX() function.\n\nFor a numeric argument N, HEX() returns a hexadecimal string\nrepresentation of the value of N treated as a longlong (BIGINT) number.\nThis is equivalent to CONV(N,10,16). The inverse of this operation is\nperformed by CONV(HEX(N),16,10).\n\nFor a NULL argument, this function returns NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/string-functions.html +[HOUR] +declaration=time +category=Date and Time Functions +description=Returns the hour for time. The range of the return value is 0 to 23 for\ntime-of-day values. However, the range of TIME values actually is much\nlarger, so HOUR can return values greater than 23. Returns NULL if time\nis NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/date-and-time-functions.html +[ICU_VERSION] +declaration= +category=Information Functions +description=The version of the International Components for Unicode (ICU) library\nused to support regular expression operations (see\nhttps://dev.mysql.com/doc/refman/8.3/en/regexp.html). This function is\nprimarily intended for use in test cases.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/information-functions.html +[IFNULL] +declaration=expr1,expr2 +category=Flow Control Functions +description=If expr1 is not NULL, IFNULL() returns expr1; otherwise it returns\nexpr2.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/flow-control-functions.html +[IN] +declaration=value,... +category=Comparison Operators +description=Returns 1 (true) if expr is equal to any of the values in the IN()\nlist, else returns 0 (false).\n\nType conversion takes place according to the rules described in\nhttps://dev.mysql.com/doc/refman/8.3/en/type-conversion.html, applied\nto all the arguments. If no type conversion is needed for the values in\nthe IN() list, they are all non-JSON constants of the same type, and\nexpr can be compared to each of them as a value of the same type\n(possibly after type conversion), an optimization takes place. The\nvalues the list are sorted and the search for expr is done using a\nbinary search, which makes the IN() operation very quick.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/comparison-operators.html +[INET6_ATON] +declaration=expr +category=Miscellaneous Functions +description=Given an IPv6 or IPv4 network address as a string, returns a binary\nstring that represents the numeric value of the address in network byte\norder (big endian). Because numeric-format IPv6 addresses require more\nbytes than the largest integer type, the representation returned by\nthis function has the VARBINARY data type: VARBINARY(16) for IPv6\naddresses and VARBINARY(4) for IPv4 addresses. If the argument is not a\nvalid address, or if it is NULL, INET6_ATON() returns NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/miscellaneous-functions.html +[INET6_NTOA] +declaration=expr +category=Miscellaneous Functions +description=Given an IPv6 or IPv4 network address represented in numeric form as a\nbinary string, returns the string representation of the address as a\nstring in the connection character set. If the argument is not a valid\naddress, or if it is NULL, INET6_NTOA() returns NULL.\n\nINET6_NTOA() has these properties:\n\no It does not use operating system functions to perform conversions,\n thus the output string is platform independent.\n\no The return string has a maximum length of 39 (4 x 8 + 7). Given this\n statement:\n\nCREATE TABLE t AS SELECT INET6_NTOA(expr) AS c1;\n\n The resulting table would have this definition:\n\nCREATE TABLE t (c1 VARCHAR(39) CHARACTER SET utf8mb3 DEFAULT NULL);\n\no The return string uses lowercase letters for IPv6 addresses.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/miscellaneous-functions.html +[INET_ATON] +declaration=expr +category=Miscellaneous Functions +description=Given the dotted-quad representation of an IPv4 network address as a\nstring, returns an integer that represents the numeric value of the\naddress in network byte order (big endian). INET_ATON() returns NULL if\nit does not understand its argument, or if expr is NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/miscellaneous-functions.html +[INET_NTOA] +declaration=expr +category=Miscellaneous Functions +description=Given a numeric IPv4 network address in network byte order, returns the\ndotted-quad string representation of the address as a string in the\nconnection character set. INET_NTOA() returns NULL if it does not\nunderstand its argument.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/miscellaneous-functions.html +[INSTR] +declaration=str,substr +category=String Functions +description=Returns the position of the first occurrence of substring substr in\nstring str. This is the same as the two-argument form of LOCATE(),\nexcept that the order of the arguments is reversed.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/string-functions.html +[INT] +declaration=M +category=Data Types +description=A normal-size integer. The signed range is -2147483648 to 2147483647.\nThe unsigned range is 0 to 4294967295.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/numeric-type-syntax.html +[INTEGER] +declaration=M +category=Data Types +description=This type is a synonym for INT.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/numeric-type-syntax.html +[INTERVAL] +declaration=N,N1,N2,N3,... +category=Comparison Operators +description=Returns 0 if N <= N1, 1 if N <= N2 and so on, or -1 if N is NULL. All\narguments are treated as integers. It is required that N1 <= N2 <= N3\n<= ... <= Nn for this function to work correctly. This is because a\nbinary search is used (very fast).\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/comparison-operators.html +[ISNULL] +declaration=expr +category=Comparison Operators +description=If expr is NULL, ISNULL() returns 1, otherwise it returns 0.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/comparison-operators.html +[IS_FREE_LOCK] +declaration=str +category=Locking Functions +description=Checks whether the lock named str is free to use (that is, not locked).\nReturns 1 if the lock is free (no one is using the lock), 0 if the lock\nis in use, and NULL if an error occurs (such as an incorrect argument).\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/locking-functions.html +[IS_IPV4] +declaration=expr +category=Miscellaneous Functions +description=Returns 1 if the argument is a valid IPv4 address specified as a\nstring, 0 otherwise. Returns NULL if expr is NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/miscellaneous-functions.html +[IS_IPV4_COMPAT] +declaration=expr +category=Miscellaneous Functions +description=This function takes an IPv6 address represented in numeric form as a\nbinary string, as returned by INET6_ATON(). It returns 1 if the\nargument is a valid IPv4-compatible IPv6 address, 0 otherwise (unless\nexpr is NULL, in which case the function returns NULL). IPv4-compatible\naddresses have the form ::ipv4_address.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/miscellaneous-functions.html +[IS_IPV4_MAPPED] +declaration=expr +category=Miscellaneous Functions +description=This function takes an IPv6 address represented in numeric form as a\nbinary string, as returned by INET6_ATON(). It returns 1 if the\nargument is a valid IPv4-mapped IPv6 address, 0 otherwise, unless expr\nis NULL, in which case the function returns NULL. IPv4-mapped addresses\nhave the form ::ffff:ipv4_address.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/miscellaneous-functions.html +[IS_IPV6] +declaration=expr +category=Miscellaneous Functions +description=Returns 1 if the argument is a valid IPv6 address specified as a\nstring, 0 otherwise, unless expr is NULL, in which case the function\nreturns NULL. This function does not consider IPv4 addresses to be\nvalid IPv6 addresses.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/miscellaneous-functions.html +[IS_USED_LOCK] +declaration=str +category=Locking Functions +description=Checks whether the lock named str is in use (that is, locked). If so,\nit returns the connection identifier of the client session that holds\nthe lock. Otherwise, it returns NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/locking-functions.html +[IS_UUID] +declaration=string_uuid +category=Miscellaneous Functions +description=Returns 1 if the argument is a valid string-format UUID, 0 if the\nargument is not a valid UUID, and NULL if the argument is NULL.\n\n"Valid" means that the value is in a format that can be parsed. That\nis, it has the correct length and contains only the permitted\ncharacters (hexadecimal digits in any lettercase and, optionally,\ndashes and curly braces). This format is most common:\n\naaaaaaaa-bbbb-cccc-dddd-eeeeeeeeeeee\n\nThese other formats are also permitted:\n\naaaaaaaabbbbccccddddeeeeeeeeeeee\n{aaaaaaaa-bbbb-cccc-dddd-eeeeeeeeeeee}\n\nFor the meanings of fields within the value, see the UUID() function\ndescription.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/miscellaneous-functions.html +[JOIN] +declaration=t2, t3, t4 +category=Data Manipulation +description=ON (t2.a = t1.a AND t3.b = t1.b AND t4.c = t1.c)\n\nis equivalent to:\n\nSELECT * FROM t1 LEFT JOIN (t2 CROSS JOIN t3 CROSS JOIN t4)\n ON (t2.a = t1.a AND t3.b = t1.b AND t4.c = t1.c)\n\nIn MySQL, JOIN, CROSS JOIN, and INNER JOIN are syntactic equivalents\n(they can replace each other). In standard SQL, they are not\nequivalent. INNER JOIN is used with an ON clause, CROSS JOIN is used\notherwise.\n\nIn general, parentheses can be ignored in join expressions containing\nonly inner join operations. MySQL also supports nested joins. See\nhttps://dev.mysql.com/doc/refman/8.3/en/nested-join-optimization.html.\n\nIndex hints can be specified to affect how the MySQL optimizer makes\nuse of indexes. For more information, see\nhttps://dev.mysql.com/doc/refman/8.3/en/index-hints.html. Optimizer\nhints and the optimizer_switch system variable are other ways to\ninfluence optimizer use of indexes. See\nhttps://dev.mysql.com/doc/refman/8.3/en/optimizer-hints.html, and\nhttps://dev.mysql.com/doc/refman/8.3/en/switchable-optimizations.html.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/join.html +[JSON_ARRAY] +declaration=[val[, val] ...] +category=MBR Functions +description=Evaluates a (possibly empty) list of values and returns a JSON array\ncontaining those values.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/json-creation-functions.html +[JSON_ARRAYAGG] +declaration=col_or_expr +category=Aggregate Functions and Modifiers +description=Aggregates a result set as a single JSON array whose elements consist\nof the rows. The order of elements in this array is undefined. The\nfunction acts on a column or an expression that evaluates to a single\nvalue. Returns NULL if the result contains no rows, or in the event of\nan error. If col_or_expr is NULL, the function returns an array of JSON\n[null] elements.\n\nThis function executes as a window function if over_clause is present.\nover_clause is as described in\nhttps://dev.mysql.com/doc/refman/8.3/en/window-functions-usage.html.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/aggregate-functions.html +[JSON_ARRAY_APPEND] +declaration=json_doc, path, val[, path, val] ... +category=MBR Functions +description=Appends values to the end of the indicated arrays within a JSON\ndocument and returns the result. Returns NULL if any argument is NULL.\nAn error occurs if the json_doc argument is not a valid JSON document\nor any path argument is not a valid path expression or contains a * or\n** wildcard.\n\nThe path-value pairs are evaluated left to right. The document produced\nby evaluating one pair becomes the new value against which the next\npair is evaluated.\n\nIf a path selects a scalar or object value, that value is autowrapped\nwithin an array and the new value is added to that array. Pairs for\nwhich the path does not identify any value in the JSON document are\nignored.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/json-modification-functions.html +[JSON_ARRAY_INSERT] +declaration=json_doc, path, val[, path, val] ... +category=MBR Functions +description=Updates a JSON document, inserting into an array within the document\nand returning the modified document. Returns NULL if any argument is\nNULL. An error occurs if the json_doc argument is not a valid JSON\ndocument or any path argument is not a valid path expression or\ncontains a * or ** wildcard or does not end with an array element\nidentifier.\n\nThe path-value pairs are evaluated left to right. The document produced\nby evaluating one pair becomes the new value against which the next\npair is evaluated.\n\nPairs for which the path does not identify any array in the JSON\ndocument are ignored. If a path identifies an array element, the\ncorresponding value is inserted at that element position, shifting any\nfollowing values to the right. If a path identifies an array position\npast the end of an array, the value is inserted at the end of the\narray.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/json-modification-functions.html +[JSON_CONTAINS] +declaration=target, candidate[, path] +category=MBR Functions +description=Indicates by returning 1 or 0 whether a given candidate JSON document\nis contained within a target JSON document, or---if a path argument was\nsupplied---whether the candidate is found at a specific path within the\ntarget. Returns NULL if any argument is NULL, or if the path argument\ndoes not identify a section of the target document. An error occurs if\ntarget or candidate is not a valid JSON document, or if the path\nargument is not a valid path expression or contains a * or ** wildcard.\n\nTo check only whether any data exists at the path, use\nJSON_CONTAINS_PATH() instead.\n\nThe following rules define containment:\n\no A candidate scalar is contained in a target scalar if and only if\n they are comparable and are equal. Two scalar values are comparable\n if they have the same JSON_TYPE() types, with the exception that\n values of types INTEGER and DECIMAL are also comparable to each\n other.\n\no A candidate array is contained in a target array if and only if every\n element in the candidate is contained in some element of the target.\n\no A candidate nonarray is contained in a target array if and only if\n the candidate is contained in some element of the target.\n\no A candidate object is contained in a target object if and only if for\n each key in the candidate there is a key with the same name in the\n target and the value associated with the candidate key is contained\n in the value associated with the target key.\n\nOtherwise, the candidate value is not contained in the target document.\n\nQueries using JSON_CONTAINS() on InnoDB tables can be optimized using\nmulti-valued indexes; see\nhttps://dev.mysql.com/doc/refman/8.3/en/create-index.html#create-index-\nmulti-valued, for more information.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/json-search-functions.html +[JSON_CONTAINS_PATH] +declaration=json_doc, one_or_all, path[, path] ... +category=MBR Functions +description=Returns 0 or 1 to indicate whether a JSON document contains data at a\ngiven path or paths. Returns NULL if any argument is NULL. An error\noccurs if the json_doc argument is not a valid JSON document, any path\nargument is not a valid path expression, or one_or_all is not 'one' or\n'all'.\n\nTo check for a specific value at a path, use JSON_CONTAINS() instead.\n\nThe return value is 0 if no specified path exists within the document.\nOtherwise, the return value depends on the one_or_all argument:\n\no 'one': 1 if at least one path exists within the document, 0\n otherwise.\n\no 'all': 1 if all paths exist within the document, 0 otherwise.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/json-search-functions.html +[JSON_DEPTH] +declaration=json_doc +category=MBR Functions +description=Returns the maximum depth of a JSON document. Returns NULL if the\nargument is NULL. An error occurs if the argument is not a valid JSON\ndocument.\n\nAn empty array, empty object, or scalar value has depth 1. A nonempty\narray containing only elements of depth 1 or nonempty object containing\nonly member values of depth 1 has depth 2. Otherwise, a JSON document\nhas depth greater than 2.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/json-attribute-functions.html +[JSON_EXTRACT] +declaration=json_doc, path[, path] ... +category=MBR Functions +description=Returns data from a JSON document, selected from the parts of the\ndocument matched by the path arguments. Returns NULL if any argument is\nNULL or no paths locate a value in the document. An error occurs if the\njson_doc argument is not a valid JSON document or any path argument is\nnot a valid path expression.\n\nThe return value consists of all values matched by the path arguments.\nIf it is possible that those arguments could return multiple values,\nthe matched values are autowrapped as an array, in the order\ncorresponding to the paths that produced them. Otherwise, the return\nvalue is the single matched value.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/json-search-functions.html +[JSON_INSERT] +declaration=json_doc, path, val[, path, val] ... +category=MBR Functions +description=Inserts data into a JSON document and returns the result. Returns NULL\nif any argument is NULL. An error occurs if the json_doc argument is\nnot a valid JSON document or any path argument is not a valid path\nexpression or contains a * or ** wildcard.\n\nThe path-value pairs are evaluated left to right. The document produced\nby evaluating one pair becomes the new value against which the next\npair is evaluated.\n\nA path-value pair for an existing path in the document is ignored and\ndoes not overwrite the existing document value. A path-value pair for a\nnonexisting path in the document adds the value to the document if the\npath identifies one of these types of values:\n\no A member not present in an existing object. The member is added to\n the object and associated with the new value.\n\no A position past the end of an existing array. The array is extended\n with the new value. If the existing value is not an array, it is\n autowrapped as an array, then extended with the new value.\n\nOtherwise, a path-value pair for a nonexisting path in the document is\nignored and has no effect.\n\nFor a comparison of JSON_INSERT(), JSON_REPLACE(), and JSON_SET(), see\nthe discussion of JSON_SET().\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/json-modification-functions.html +[JSON_KEYS] +declaration=json_doc[, path] +category=MBR Functions +description=Returns the keys from the top-level value of a JSON object as a JSON\narray, or, if a path argument is given, the top-level keys from the\nselected path. Returns NULL if any argument is NULL, the json_doc\nargument is not an object, or path, if given, does not locate an\nobject. An error occurs if the json_doc argument is not a valid JSON\ndocument or the path argument is not a valid path expression or\ncontains a * or ** wildcard.\n\nThe result array is empty if the selected object is empty. If the\ntop-level value has nested subobjects, the return value does not\ninclude keys from those subobjects.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/json-search-functions.html +[JSON_LENGTH] +declaration=json_doc[, path] +category=MBR Functions +description=Returns the length of a JSON document, or, if a path argument is given,\nthe length of the value within the document identified by the path.\nReturns NULL if any argument is NULL or the path argument does not\nidentify a value in the document. An error occurs if the json_doc\nargument is not a valid JSON document or the path argument is not a\nvalid path expression.\n\nThe length of a document is determined as follows:\n\no The length of a scalar is 1.\n\no The length of an array is the number of array elements.\n\no The length of an object is the number of object members.\n\no The length does not count the length of nested arrays or objects.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/json-attribute-functions.html +[JSON_MERGE] +declaration=json_doc, json_doc[, json_doc] ... +category=MBR Functions +description=Deprecated synonym for JSON_MERGE_PRESERVE().\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/json-modification-functions.html +[JSON_OBJECT] +declaration=[key, val[, key, val] ...] +category=MBR Functions +description=Evaluates a (possibly empty) list of key-value pairs and returns a JSON\nobject containing those pairs. An error occurs if any key name is NULL\nor the number of arguments is odd.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/json-creation-functions.html +[JSON_OBJECTAGG] +declaration=key, value +category=Aggregate Functions and Modifiers +description=Takes two column names or expressions as arguments, the first of these\nbeing used as a key and the second as a value, and returns a JSON\nobject containing key-value pairs. Returns NULL if the result contains\nno rows, or in the event of an error. An error occurs if any key name\nis NULL or the number of arguments is not equal to 2.\n\nThis function executes as a window function if over_clause is present.\nover_clause is as described in\nhttps://dev.mysql.com/doc/refman/8.3/en/window-functions-usage.html.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/aggregate-functions.html +[JSON_OVERLAPS] +declaration=json_doc1, json_doc2 +category=MBR Functions +description=Compares two JSON documents. Returns true (1) if the two document have\nany key-value pairs or array elements in common. If both arguments are\nscalars, the function performs a simple equality test. If either\nargument is NULL, the function returns NULL.\n\nThis function serves as counterpart to JSON_CONTAINS(), which requires\nall elements of the array searched for to be present in the array\nsearched in. Thus, JSON_CONTAINS() performs an AND operation on search\nkeys, while JSON_OVERLAPS() performs an OR operation.\n\nQueries on JSON columns of InnoDB tables using JSON_OVERLAPS() in the\nWHERE clause can be optimized using multi-valued indexes.\nhttps://dev.mysql.com/doc/refman/8.3/en/create-index.html#create-index-\nmulti-valued, provides detailed information and examples.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/json-search-functions.html +[JSON_PRETTY] +declaration=json_val +category=MBR Functions +description=Provides pretty-printing of JSON values similar to that implemented in\nPHP and by other languages and database systems. The value supplied\nmust be a JSON value or a valid string representation of a JSON value.\nExtraneous whitespaces and newlines present in this value have no\neffect on the output. For a NULL value, the function returns NULL. If\nthe value is not a JSON document, or if it cannot be parsed as one, the\nfunction fails with an error.\n\nFormatting of the output from this function adheres to the following\nrules:\n\no Each array element or object member appears on a separate line,\n indented by one additional level as compared to its parent.\n\no Each level of indentation adds two leading spaces.\n\no A comma separating individual array elements or object members is\n printed before the newline that separates the two elements or\n members.\n\no The key and the value of an object member are separated by a colon\n followed by a space (': ').\n\no An empty object or array is printed on a single line. No space is\n printed between the opening and closing brace.\n\no Special characters in string scalars and key names are escaped\n employing the same rules used by the JSON_QUOTE() function.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/json-utility-functions.html +[JSON_QUOTE] +declaration=string +category=MBR Functions +description=Quotes a string as a JSON value by wrapping it with double quote\ncharacters and escaping interior quote and other characters, then\nreturning the result as a utf8mb4 string. Returns NULL if the argument\nis NULL.\n\nThis function is typically used to produce a valid JSON string literal\nfor inclusion within a JSON document.\n\nCertain special characters are escaped with backslashes per the escape\nsequences shown in\nhttps://dev.mysql.com/doc/refman/8.3/en/json-modification-functions.html\n#json-unquote-character-escape-sequences.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/json-creation-functions.html +[JSON_REMOVE] +declaration=json_doc, path[, path] ... +category=MBR Functions +description=Removes data from a JSON document and returns the result. Returns NULL\nif any argument is NULL. An error occurs if the json_doc argument is\nnot a valid JSON document or any path argument is not a valid path\nexpression or is $ or contains a * or ** wildcard.\n\nThe path arguments are evaluated left to right. The document produced\nby evaluating one path becomes the new value against which the next\npath is evaluated.\n\nIt is not an error if the element to be removed does not exist in the\ndocument; in that case, the path does not affect the document.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/json-modification-functions.html +[JSON_REPLACE] +declaration=json_doc, path, val[, path, val] ... +category=MBR Functions +description=Replaces existing values in a JSON document and returns the result.\nReturns NULL if any argument is NULL. An error occurs if the json_doc\nargument is not a valid JSON document or any path argument is not a\nvalid path expression or contains a * or ** wildcard.\n\nThe path-value pairs are evaluated left to right. The document produced\nby evaluating one pair becomes the new value against which the next\npair is evaluated.\n\nA path-value pair for an existing path in the document overwrites the\nexisting document value with the new value. A path-value pair for a\nnonexisting path in the document is ignored and has no effect.\n\nThe optimizer can perform a partial, in-place update of a JSON column\ninstead of removing the old document and writing the new document in\nits entirety to the column. This optimization can be performed for an\nupdate statement that uses the JSON_REPLACE() function and meets the\nconditions outlined in\nhttps://dev.mysql.com/doc/refman/8.3/en/json.html#json-partial-updates.\n\nFor a comparison of JSON_INSERT(), JSON_REPLACE(), and JSON_SET(), see\nthe discussion of JSON_SET().\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/json-modification-functions.html +[JSON_SCHEMA_VALID] +declaration=schema,document +category=MBR Functions +description=Validates a JSON document against a JSON schema. Both schema and\ndocument are required. The schema must be a valid JSON object; the\ndocument must be a valid JSON document. Provided that these conditions\nare met: If the document validates against the schema, the function\nreturns true (1); otherwise, it returns false (0).\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/json-validation-functions.html +[JSON_SCHEMA_VALIDATION_REPORT] +declaration=schema,document +category=MBR Functions +description=Validates a JSON document against a JSON schema. Both schema and\ndocument are required. As with JSON_VALID_SCHEMA(), the schema must be\na valid JSON object, and the document must be a valid JSON document.\nProvided that these conditions are met, the function returns a report,\nas a JSON document, on the outcome of the validation. If the JSON\ndocument is considered valid according to the JSON Schema, the function\nreturns a JSON object with one property valid having the value "true".\nIf the JSON document fails validation, the function returns a JSON\nobject which includes the properties listed here:\n\no valid: Always "false" for a failed schema validation\n\no reason: A human-readable string containing the reason for the failure\n\no schema-location: A JSON pointer URI fragment identifier indicating\n where in the JSON schema the validation failed (see Note following\n this list)\n\no document-location: A JSON pointer URI fragment identifier indicating\n where in the JSON document the validation failed (see Note following\n this list)\n\no schema-failed-keyword: A string containing the name of the keyword or\n property in the JSON schema that was violated\n\n*Note*:\n\nJSON pointer URI fragment identifiers are defined in RFC 6901 -\nJavaScript Object Notation (JSON) Pointer\n(https://tools.ietf.org/html/rfc6901#page-5). (These are not the same\nas the JSON path notation used by JSON_EXTRACT() and other MySQL JSON\nfunctions.) In this notation, # represents the entire document, and\n#/myprop represents the portion of the document included in the\ntop-level property named myprop. See the specification just cited and\nthe examples shown later in this section for more information.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/json-validation-functions.html +[JSON_SEARCH] +declaration=json_doc, one_or_all, search_str[, escape_char[, path] ...] +category=MBR Functions +description=Returns the path to the given string within a JSON document. Returns\nNULL if any of the json_doc, search_str, or path arguments are NULL; no\npath exists within the document; or search_str is not found. An error\noccurs if the json_doc argument is not a valid JSON document, any path\nargument is not a valid path expression, one_or_all is not 'one' or\n'all', or escape_char is not a constant expression.\n\nThe one_or_all argument affects the search as follows:\n\no 'one': The search terminates after the first match and returns one\n path string. It is undefined which match is considered first.\n\no 'all': The search returns all matching path strings such that no\n duplicate paths are included. If there are multiple strings, they are\n autowrapped as an array. The order of the array elements is\n undefined.\n\nWithin the search_str search string argument, the % and _ characters\nwork as for the LIKE operator: % matches any number of characters\n(including zero characters), and _ matches exactly one character.\n\nTo specify a literal % or _ character in the search string, precede it\nby the escape character. The default is \ if the escape_char argument\nis missing or NULL. Otherwise, escape_char must be a constant that is\nempty or one character.\n\nFor more information about matching and escape character behavior, see\nthe description of LIKE in\nhttps://dev.mysql.com/doc/refman/8.3/en/string-comparison-functions.html\n. For escape character handling, a difference from the LIKE behavior\nis that the escape character for JSON_SEARCH() must evaluate to a\nconstant at compile time, not just at execution time. For example, if\nJSON_SEARCH() is used in a prepared statement and the escape_char\nargument is supplied using a ? parameter, the parameter value might be\nconstant at execution time, but is not at compile time.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/json-search-functions.html +[JSON_SET] +declaration=json_doc, path, val[, path, val] ... +category=MBR Functions +description=Inserts or updates data in a JSON document and returns the result.\nReturns NULL if json_doc or path is NULL, or if path, when given, does\nnot locate an object. Otherwise, an error occurs if the json_doc\nargument is not a valid JSON document or any path argument is not a\nvalid path expression or contains a * or ** wildcard.\n\nThe path-value pairs are evaluated left to right. The document produced\nby evaluating one pair becomes the new value against which the next\npair is evaluated.\n\nA path-value pair for an existing path in the document overwrites the\nexisting document value with the new value. A path-value pair for a\nnonexisting path in the document adds the value to the document if the\npath identifies one of these types of values:\n\no A member not present in an existing object. The member is added to\n the object and associated with the new value.\n\no A position past the end of an existing array. The array is extended\n with the new value. If the existing value is not an array, it is\n autowrapped as an array, then extended with the new value.\n\nOtherwise, a path-value pair for a nonexisting path in the document is\nignored and has no effect.\n\nThe optimizer can perform a partial, in-place update of a JSON column\ninstead of removing the old document and writing the new document in\nits entirety to the column. This optimization can be performed for an\nupdate statement that uses the JSON_SET() function and meets the\nconditions outlined in\nhttps://dev.mysql.com/doc/refman/8.3/en/json.html#json-partial-updates.\n\nThe JSON_SET(), JSON_INSERT(), and JSON_REPLACE() functions are\nrelated:\n\no JSON_SET() replaces existing values and adds nonexisting values.\n\no JSON_INSERT() inserts values without replacing existing values.\n\no JSON_REPLACE() replaces only existing values.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/json-modification-functions.html +[JSON_STORAGE_FREE] +declaration=json_val +category=MBR Functions +description=For a JSON column value, this function shows how much storage space was\nfreed in its binary representation after it was updated in place using\nJSON_SET(), JSON_REPLACE(), or JSON_REMOVE(). The argument can also be\na valid JSON document or a string which can be parsed as one---either\nas a literal value or as the value of a user variable---in which case\nthe function returns 0. It returns a positive, nonzero value if the\nargument is a JSON column value which has been updated as described\npreviously, such that its binary representation takes up less space\nthan it did prior to the update. For a JSON column which has been\nupdated such that its binary representation is the same as or larger\nthan before, or if the update was not able to take advantage of a\npartial update, it returns 0; it returns NULL if the argument is NULL.\n\nIf json_val is not NULL, and neither is a valid JSON document nor can\nbe successfully parsed as one, an error results.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/json-utility-functions.html +[JSON_STORAGE_SIZE] +declaration=json_val +category=MBR Functions +description=This function returns the number of bytes used to store the binary\nrepresentation of a JSON document. When the argument is a JSON column,\nthis is the space used to store the JSON document as it was inserted\ninto the column, prior to any partial updates that may have been\nperformed on it afterwards. json_val must be a valid JSON document or a\nstring which can be parsed as one. In the case where it is string, the\nfunction returns the amount of storage space in the JSON binary\nrepresentation that is created by parsing the string as JSON and\nconverting it to binary. It returns NULL if the argument is NULL.\n\nAn error results when json_val is not NULL, and is not---or cannot be\nsuccessfully parsed as---a JSON document.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/json-utility-functions.html +[JSON_TABLE] +declaration=expr, path COLUMNS (column_list +category=MBR Functions +description=Extracts data from a JSON document and returns it as a relational table\nhaving the specified columns. The complete syntax for this function is\nshown here:\n\nJSON_TABLE(\n expr,\n path COLUMNS (column_list)\n) [AS] alias\n\ncolumn_list:\n column[, column][, ...]\n\ncolumn:\n name FOR ORDINALITY\n | name type PATH string path [on_empty] [on_error]\n | name type EXISTS PATH string path\n | NESTED [PATH] path COLUMNS (column_list)\n\non_empty:\n {NULL | DEFAULT json_string | ERROR} ON EMPTY\n\non_error:\n {NULL | DEFAULT json_string | ERROR} ON ERROR\n\nexpr: This is an expression that returns JSON data. This can be a\nconstant ('{"a":1}'), a column (t1.json_data, given table t1 specified\nprior to JSON_TABLE() in the FROM clause), or a function call\n(JSON_EXTRACT(t1.json_data,'$.post.comments')).\n\npath: A JSON path expression, which is applied to the data source. We\nrefer to the JSON value matching the path as the row source; this is\nused to generate a row of relational data. The COLUMNS clause evaluates\nthe row source, finds specific JSON values within the row source, and\nreturns those JSON values as SQL values in individual columns of a row\nof relational data.\n\nThe alias is required. The usual rules for table aliases apply (see\nhttps://dev.mysql.com/doc/refman/8.3/en/identifiers.html).\n\nThis function compares column names in case-insensitive fashion.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/json-table-functions.html +[JSON_TYPE] +declaration=json_val +category=MBR Functions +description=Returns a utf8mb4 string indicating the type of a JSON value. This can\nbe an object, an array, or a scalar type, as shown here:\n\nmysql> SET @j = '{"a": [10, true]}';\nmysql> SELECT JSON_TYPE(@j);\n+---------------+\n| JSON_TYPE(@j) |\n+---------------+\n| OBJECT |\n+---------------+\nmysql> SELECT JSON_TYPE(JSON_EXTRACT(@j, '$.a'));\n+------------------------------------+\n| JSON_TYPE(JSON_EXTRACT(@j, '$.a')) |\n+------------------------------------+\n| ARRAY |\n+------------------------------------+\nmysql> SELECT JSON_TYPE(JSON_EXTRACT(@j, '$.a[0]'));\n+---------------------------------------+\n| JSON_TYPE(JSON_EXTRACT(@j, '$.a[0]')) |\n+---------------------------------------+\n| INTEGER |\n+---------------------------------------+\nmysql> SELECT JSON_TYPE(JSON_EXTRACT(@j, '$.a[1]'));\n+---------------------------------------+\n| JSON_TYPE(JSON_EXTRACT(@j, '$.a[1]')) |\n+---------------------------------------+\n| BOOLEAN |\n+---------------------------------------+\n\nJSON_TYPE() returns NULL if the argument is NULL:\n\nmysql> SELECT JSON_TYPE(NULL);\n+-----------------+\n| JSON_TYPE(NULL) |\n+-----------------+\n| NULL |\n+-----------------+\n\nAn error occurs if the argument is not a valid JSON value:\n\nmysql> SELECT JSON_TYPE(1);\nERROR 3146 (22032): Invalid data type for JSON data in argument 1\nto function json_type; a JSON string or JSON type is required.\n\nFor a non-NULL, non-error result, the following list describes the\npossible JSON_TYPE() return values:\n\no Purely JSON types:\n\n o OBJECT: JSON objects\n ... +[JSON_UNQUOTE] +declaration=json_val +category=MBR Functions +description=Unquotes JSON value and returns the result as a utf8mb4 string. Returns\nNULL if the argument is NULL. An error occurs if the value starts and\nends with double quotes but is not a valid JSON string literal.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/json-modification-functions.html +[JSON_VALID] +declaration=val +category=MBR Functions +description=Returns 0 or 1 to indicate whether a value is valid JSON. Returns NULL\nif the argument is NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/json-attribute-functions.html +[JSON_VALUE] +declaration=json_doc, path +category=MBR Functions +description=Extracts a value from a JSON document at the path given in the\nspecified document, and returns the extracted value, optionally\nconverting it to a desired type. The complete syntax is shown here:\n\nJSON_VALUE(json_doc, path [RETURNING type] [on_empty] [on_error])\n\non_empty:\n {NULL | ERROR | DEFAULT value} ON EMPTY\n\non_error:\n {NULL | ERROR | DEFAULT value} ON ERROR\n\njson_doc is a valid JSON document. If this is NULL, the function\nreturns NULL.\n\npath is a JSON path pointing to a location in the document. This must\nbe a string literal value.\n\ntype is one of the following data types:\n\no FLOAT\n\no DOUBLE\n\no DECIMAL\n\no SIGNED\n\no UNSIGNED\n\no DATE\n\no TIME\n\no DATETIME\n\no YEAR\n\n YEAR values of one or two digits are not supported.\n\no CHAR\n\no JSON\n\nThe types just listed are the same as the (non-array) types supported\nby the CAST() function.\n\nIf not specified by a RETURNING clause, the JSON_VALUE() function's\nreturn type is VARCHAR(512). When no character set is specified for the\nreturn type, JSON_VALUE() uses utf8mb4 with the binary collation, which\n ... +[LAG] +declaration=expr [, N[, default]] +category=Window Functions +description=Returns the value of expr from the row that lags (precedes) the current\nrow by N rows within its partition. If there is no such row, the return\nvalue is default. For example, if N is 3, the return value is default\nfor the first three rows. If N or default are missing, the defaults are\n1 and NULL, respectively.\n\nN must be a literal nonnegative integer. If N is 0, expr is evaluated\nfor the current row.\n\nN cannot be NULL, and must be an integer in the range 0 to 263,\ninclusive, in any of the following forms:\n\no an unsigned integer constant literal\n\no a positional parameter marker (?)\n\no a user-defined variable\n\no a local variable in a stored routine\n\nover_clause is as described in\nhttps://dev.mysql.com/doc/refman/8.3/en/window-functions-usage.html.\nnull_treatment is as described in the section introduction.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/window-function-descriptions.html +[LAST_DAY] +declaration=date +category=Date and Time Functions +description=Takes a date or datetime value and returns the corresponding value for\nthe last day of the month. Returns NULL if the argument is invalid or\nNULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/date-and-time-functions.html +[LAST_INSERT_ID] +declaration= +category=Information Functions +description=With no argument, LAST_INSERT_ID() returns a BIGINT UNSIGNED (64-bit)\nvalue representing the first automatically generated value successfully\ninserted for an AUTO_INCREMENT column as a result of the most recently\nexecuted INSERT statement. The value of LAST_INSERT_ID() remains\nunchanged if no rows are successfully inserted.\n\nWith an argument, LAST_INSERT_ID() returns an unsigned integer, or NULL\nif the argument is NULL.\n\nFor example, after inserting a row that generates an AUTO_INCREMENT\nvalue, you can get the value like this:\n\nmysql> SELECT LAST_INSERT_ID();\n -> 195\n\nThe currently executing statement does not affect the value of\nLAST_INSERT_ID(). Suppose that you generate an AUTO_INCREMENT value\nwith one statement, and then refer to LAST_INSERT_ID() in a\nmultiple-row INSERT statement that inserts rows into a table with its\nown AUTO_INCREMENT column. The value of LAST_INSERT_ID() remains stable\nin the second statement; its value for the second and later rows is not\naffected by the earlier row insertions. (You should be aware that, if\nyou mix references to LAST_INSERT_ID() and LAST_INSERT_ID(expr), the\neffect is undefined.)\n\nIf the previous statement returned an error, the value of\nLAST_INSERT_ID() is undefined. For transactional tables, if the\nstatement is rolled back due to an error, the value of LAST_INSERT_ID()\nis left undefined. For manual ROLLBACK, the value of LAST_INSERT_ID()\nis not restored to that before the transaction; it remains as it was at\nthe point of the ROLLBACK.\n\nWithin the body of a stored routine (procedure or function) or a\ntrigger, the value of LAST_INSERT_ID() changes the same way as for\nstatements executed outside the body of these kinds of objects. The\neffect of a stored routine or trigger upon the value of\nLAST_INSERT_ID() that is seen by following statements depends on the\nkind of routine:\n\no If a stored procedure executes statements that change the value of\n LAST_INSERT_ID(), the changed value is seen by statements that follow\n the procedure call.\n\no For stored functions and triggers that change the value, the value is\n restored when the function or trigger ends, so statements coming\n after it do not see a changed value.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/information-functions.html +[LAST_VALUE] +declaration=expr +category=Window Functions +description=Returns the value of expr from the last row of the window frame.\n\nover_clause is as described in\nhttps://dev.mysql.com/doc/refman/8.3/en/window-functions-usage.html.\nnull_treatment is as described in the section introduction.\n\nFor an example, see the FIRST_VALUE() function description.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/window-function-descriptions.html +[LCASE] +declaration=str +category=String Functions +description=LCASE() is a synonym for LOWER().\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/string-functions.html +[LEAD] +declaration=expr [, N[, default]] +category=Window Functions +description=Returns the value of expr from the row that leads (follows) the current\nrow by N rows within its partition. If there is no such row, the return\nvalue is default. For example, if N is 3, the return value is default\nfor the last three rows. If N or default are missing, the defaults are\n1 and NULL, respectively.\n\nN must be a literal nonnegative integer. If N is 0, expr is evaluated\nfor the current row.\n\nN cannot be NULL, and must be an integer in the range 0 to 263,\ninclusive, in any of the following forms:\n\no an unsigned integer constant literal\n\no a positional parameter marker (?)\n\no a user-defined variable\n\no a local variable in a stored routine\n\nover_clause is as described in\nhttps://dev.mysql.com/doc/refman/8.3/en/window-functions-usage.html.\nnull_treatment is as described in the section introduction.\n\nFor an example, see the LAG() function description.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/window-function-descriptions.html +[LEAST] +declaration=value1,value2,... +category=Comparison Operators +description=With two or more arguments, returns the smallest (minimum-valued)\nargument. The arguments are compared using the following rules:\n\no If any argument is NULL, the result is NULL. No comparison is needed.\n\no If all arguments are integer-valued, they are compared as integers.\n\no If at least one argument is double precision, they are compared as\n double-precision values. Otherwise, if at least one argument is a\n DECIMAL value, they are compared as DECIMAL values.\n\no If the arguments comprise a mix of numbers and strings, they are\n compared as strings.\n\no If any argument is a nonbinary (character) string, the arguments are\n compared as nonbinary strings.\n\no In all other cases, the arguments are compared as binary strings.\n\nThe return type of LEAST() is the aggregated type of the comparison\nargument types.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/comparison-operators.html +[LEFT] +declaration=str,len +category=String Functions +description=Returns the leftmost len characters from the string str, or NULL if any\nargument is NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/string-functions.html +[LENGTH] +declaration=str +category=String Functions +description=Returns the length of the string str, measured in bytes. A multibyte\ncharacter counts as multiple bytes. This means that for a string\ncontaining five 2-byte characters, LENGTH() returns 10, whereas\nCHAR_LENGTH() returns 5. Returns NULL if str is NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/string-functions.html +[LINESTRING] +declaration=pt [, pt] ... +category=Geometry Constructors +description=Constructs a LineString value from a number of Point or WKB Point\narguments. If the number of arguments is less than two, the return\nvalue is NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/gis-mysql-specific-functions.html +[LN] +declaration=X +category=Numeric Functions +description=Returns the natural logarithm of X; that is, the base-e logarithm of X.\nIf X is less than or equal to 0.0E0, the function returns NULL and a\nwarning "Invalid argument for logarithm" is reported. Returns NULL if X\nis NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/mathematical-functions.html +[LOAD_FILE] +declaration=file_name +category=String Functions +description=Reads the file and returns the file contents as a string. To use this\nfunction, the file must be located on the server host, you must specify\nthe full path name to the file, and you must have the FILE privilege.\nThe file must be readable by the server and its size less than\nmax_allowed_packet bytes. If the secure_file_priv system variable is\nset to a nonempty directory name, the file to be loaded must be located\nin that directory.\n\nIf the file does not exist or cannot be read because one of the\npreceding conditions is not satisfied, the function returns NULL.\n\nThe character_set_filesystem system variable controls interpretation of\nfile names that are given as literal strings.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/string-functions.html +[LOCALTIME] +declaration=[fsp] +category=Date and Time Functions +description=LOCALTIME and LOCALTIME() are synonyms for NOW().\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/date-and-time-functions.html +[LOCALTIMESTAMP] +declaration=[fsp] +category=Date and Time Functions +description=LOCALTIMESTAMP and LOCALTIMESTAMP() are synonyms for NOW().\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/date-and-time-functions.html +[LOCATE] +declaration=substr,str +category=String Functions +description=The first syntax returns the position of the first occurrence of\nsubstring substr in string str. The second syntax returns the position\nof the first occurrence of substring substr in string str, starting at\nposition pos. Returns 0 if substr is not in str. Returns NULL if any\nargument is NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/string-functions.html +[LOG] +declaration=X +category=Numeric Functions +description=If called with one parameter, this function returns the natural\nlogarithm of X. If X is less than or equal to 0.0E0, the function\nreturns NULL and a warning "Invalid argument for logarithm" is\nreported. Returns NULL if X or B is NULL.\n\nThe inverse of this function (when called with a single argument) is\nthe EXP() function.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/mathematical-functions.html +[LOG10] +declaration=X +category=Numeric Functions +description=Returns the base-10 logarithm of X. If X is less than or equal to\n0.0E0, the function returns NULL and a warning "Invalid argument for\nlogarithm" is reported. Returns NULL if X is NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/mathematical-functions.html +[LOG2] +declaration=X +category=Numeric Functions +description=Returns the base-2 logarithm of X. If X is less than or equal to 0.0E0,\nthe function returns NULL and a warning "Invalid argument for\nlogarithm" is reported. Returns NULL if X is NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/mathematical-functions.html +[LOWER] +declaration=str +category=String Functions +description=Returns the string str with all characters changed to lowercase\naccording to the current character set mapping, or NULL if str is NULL.\nThe default character set is utf8mb4.\n\nmysql> SELECT LOWER('QUADRATICALLY');\n -> 'quadratically'\n\nLOWER() (and UPPER()) are ineffective when applied to binary strings\n(BINARY, VARBINARY, BLOB). To perform lettercase conversion of a binary\nstring, first convert it to a nonbinary string using a character set\nappropriate for the data stored in the string:\n\nmysql> SET @str = BINARY 'New York';\nmysql> SELECT LOWER(@str), LOWER(CONVERT(@str USING utf8mb4));\n+-------------+------------------------------------+\n| LOWER(@str) | LOWER(CONVERT(@str USING utf8mb4)) |\n+-------------+------------------------------------+\n| New York | new york |\n+-------------+------------------------------------+\n\nFor collations of Unicode character sets, LOWER() and UPPER() work\naccording to the Unicode Collation Algorithm (UCA) version in the\ncollation name, if there is one, and UCA 4.0.0 if no version is\nspecified. For example, utf8mb4_0900_ai_ci and utf8mb3_unicode_520_ci\nwork according to UCA 9.0.0 and 5.2.0, respectively, whereas\nutf8mb3_unicode_ci works according to UCA 4.0.0. See\nhttps://dev.mysql.com/doc/refman/8.3/en/charset-unicode-sets.html.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/string-functions.html +[LPAD] +declaration=str,len,padstr +category=String Functions +description=Returns the string str, left-padded with the string padstr to a length\nof len characters. If str is longer than len, the return value is\nshortened to len characters.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/string-functions.html +[LTRIM] +declaration=str +category=String Functions +description=Returns the string str with leading space characters removed. Returns\nNULL if str is NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/string-functions.html +[MAKEDATE] +declaration=year,dayofyear +category=Date and Time Functions +description=Returns a date, given year and day-of-year values. dayofyear must be\ngreater than 0 or the result is NULL. The result is also NULL if either\nargument is NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/date-and-time-functions.html +[MAKETIME] +declaration=hour,minute,second +category=Date and Time Functions +description=Returns a time value calculated from the hour, minute, and second\narguments. Returns NULL if any of its arguments are NULL.\n\nThe second argument can have a fractional part.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/date-and-time-functions.html +[MAKE_SET] +declaration=bits,str1,str2,... +category=String Functions +description=Returns a set value (a string containing substrings separated by ,\ncharacters) consisting of the strings that have the corresponding bit\nin bits set. str1 corresponds to bit 0, str2 to bit 1, and so on. NULL\nvalues in str1, str2, ... are not appended to the result.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/string-functions.html +[MASTER_POS_WAIT] +declaration=log_name,log_pos[,timeout][,channel] +category=GTID +description=Deprecated alias for SOURCE_POS_WAIT().\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/replication-functions-synchronization.html +[MAX] +declaration=[DISTINCT] expr +category=Aggregate Functions and Modifiers +description=Returns the maximum value of expr. MAX() may take a string argument; in\nsuch cases, it returns the maximum string value. See\nhttps://dev.mysql.com/doc/refman/8.3/en/mysql-indexes.html. The\nDISTINCT keyword can be used to find the maximum of the distinct values\nof expr, however, this produces the same result as omitting DISTINCT.\n\nIf there are no matching rows, or if expr is NULL, MAX() returns NULL.\n\nThis function executes as a window function if over_clause is present.\nover_clause is as described in\nhttps://dev.mysql.com/doc/refman/8.3/en/window-functions-usage.html; it\ncannot be used with DISTINCT.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/aggregate-functions.html +[MBRCONTAINS] +declaration=g1, g2 +category=MBR Functions +description=Returns 1 or 0 to indicate whether the minimum bounding rectangle of g1\ncontains the minimum bounding rectangle of g2. This tests the opposite\nrelationship as MBRWithin().\n\nMBRContains() handles its arguments as described in the introduction to\nthis section.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/spatial-relation-functions-mbr.html +[MBRCOVEREDBY] +declaration=g1, g2 +category=MBR Functions +description=Returns 1 or 0 to indicate whether the minimum bounding rectangle of g1\nis covered by the minimum bounding rectangle of g2. This tests the\nopposite relationship as MBRCovers().\n\nMBRCoveredBy() handles its arguments as described in the introduction\nto this section.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/spatial-relation-functions-mbr.html +[MBRCOVERS] +declaration=g1, g2 +category=MBR Functions +description=Returns 1 or 0 to indicate whether the minimum bounding rectangle of g1\ncovers the minimum bounding rectangle of g2. This tests the opposite\nrelationship as MBRCoveredBy(). See the description of MBRCoveredBy()\nfor examples.\n\nMBRCovers() handles its arguments as described in the introduction to\nthis section.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/spatial-relation-functions-mbr.html +[MBRDISJOINT] +declaration=g1, g2 +category=MBR Functions +description=Returns 1 or 0 to indicate whether the minimum bounding rectangles of\nthe two geometries g1 and g2 are disjoint (do not intersect).\n\nMBRDisjoint() handles its arguments as described in the introduction to\nthis section.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/spatial-relation-functions-mbr.html +[MBREQUALS] +declaration=g1, g2 +category=MBR Functions +description=Returns 1 or 0 to indicate whether the minimum bounding rectangles of\nthe two geometries g1 and g2 are the same.\n\nMBREquals() handles its arguments as described in the introduction to\nthis section, except that it does not return NULL for empty geometry\narguments.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/spatial-relation-functions-mbr.html +[MBRINTERSECTS] +declaration=g1, g2 +category=MBR Functions +description=Returns 1 or 0 to indicate whether the minimum bounding rectangles of\nthe two geometries g1 and g2 intersect.\n\nMBRIntersects() handles its arguments as described in the introduction\nto this section.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/spatial-relation-functions-mbr.html +[MBROVERLAPS] +declaration=g1, g2 +category=MBR Functions +description=Two geometries spatially overlap if they intersect and their\nintersection results in a geometry of the same dimension but not equal\nto either of the given geometries.\n\nThis function returns 1 or 0 to indicate whether the minimum bounding\nrectangles of the two geometries g1 and g2 overlap.\n\nMBROverlaps() handles its arguments as described in the introduction to\nthis section.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/spatial-relation-functions-mbr.html +[MBRTOUCHES] +declaration=g1, g2 +category=MBR Functions +description=Two geometries spatially touch if their interiors do not intersect, but\nthe boundary of one of the geometries intersects either the boundary or\nthe interior of the other.\n\nThis function returns 1 or 0 to indicate whether the minimum bounding\nrectangles of the two geometries g1 and g2 touch.\n\nMBRTouches() handles its arguments as described in the introduction to\nthis section.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/spatial-relation-functions-mbr.html +[MBRWITHIN] +declaration=g1, g2 +category=MBR Functions +description=Returns 1 or 0 to indicate whether the minimum bounding rectangle of g1\nis within the minimum bounding rectangle of g2. This tests the opposite\nrelationship as MBRContains().\n\nMBRWithin() handles its arguments as described in the introduction to\nthis section.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/spatial-relation-functions-mbr.html +[MD5] +declaration=str +category=Encryption Functions +description=Calculates an MD5 128-bit checksum for the string. The value is\nreturned as a string of 32 hexadecimal digits, or NULL if the argument\nwas NULL. The return value can, for example, be used as a hash key. See\nthe notes at the beginning of this section about storing hash values\nefficiently.\n\nThe return value is a string in the connection character set.\n\nIf FIPS mode is enabled, MD5() returns NULL. See\nhttps://dev.mysql.com/doc/refman/8.3/en/fips-mode.html.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/encryption-functions.html +[MEDIUMINT] +declaration=M +category=Data Types +description=A medium-sized integer. The signed range is -8388608 to 8388607. The\nunsigned range is 0 to 16777215.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/numeric-type-syntax.html +[MICROSECOND] +declaration=expr +category=Date and Time Functions +description=Returns the microseconds from the time or datetime expression expr as a\nnumber in the range from 0 to 999999. Returns NULL if expr is NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/date-and-time-functions.html +[MID] +declaration=str,pos,len +category=String Functions +description=MID(str,pos,len) is a synonym for SUBSTRING(str,pos,len).\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/string-functions.html +[MIN] +declaration=[DISTINCT] expr +category=Aggregate Functions and Modifiers +description=Returns the minimum value of expr. MIN() may take a string argument; in\nsuch cases, it returns the minimum string value. See\nhttps://dev.mysql.com/doc/refman/8.3/en/mysql-indexes.html. The\nDISTINCT keyword can be used to find the minimum of the distinct values\nof expr, however, this produces the same result as omitting DISTINCT.\n\nIf there are no matching rows, or if expr is NULL, MIN() returns NULL.\n\nThis function executes as a window function if over_clause is present.\nover_clause is as described in\nhttps://dev.mysql.com/doc/refman/8.3/en/window-functions-usage.html; it\ncannot be used with DISTINCT.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/aggregate-functions.html +[MINUTE] +declaration=time +category=Date and Time Functions +description=Returns the minute for time, in the range 0 to 59, or NULL if time is\nNULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/date-and-time-functions.html +[MOD] +declaration=N,M +category=Numeric Functions +description=Modulo operation. Returns the remainder of N divided by M. Returns NULL\nif M or N is NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/mathematical-functions.html +[MONTH] +declaration=date +category=Date and Time Functions +description=Returns the month for date, in the range 1 to 12 for January to\nDecember, or 0 for dates such as '0000-00-00' or '2008-00-00' that have\na zero month part. Returns NULL if date is NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/date-and-time-functions.html +[MONTHNAME] +declaration=date +category=Date and Time Functions +description=Returns the full name of the month for date. The language used for the\nname is controlled by the value of the lc_time_names system variable\n(https://dev.mysql.com/doc/refman/8.3/en/locale-support.html). Returns\nNULL if date is NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/date-and-time-functions.html +[MULTILINESTRING] +declaration=ls [, ls] ... +category=Geometry Constructors +description=Constructs a MultiLineString value using LineString or WKB LineString\narguments.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/gis-mysql-specific-functions.html +[MULTIPOINT] +declaration=pt [, pt2] ... +category=Geometry Constructors +description=Constructs a MultiPoint value using Point or WKB Point arguments.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/gis-mysql-specific-functions.html +[MULTIPOLYGON] +declaration=poly [, poly] ... +category=Geometry Constructors +description=Constructs a MultiPolygon value from a set of Polygon or WKB Polygon\narguments.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/gis-mysql-specific-functions.html +[NAME_CONST] +declaration=name,value +category=Miscellaneous Functions +description=Returns the given value. When used to produce a result set column,\nNAME_CONST() causes the column to have the given name. The arguments\nshould be constants.\n\nmysql> SELECT NAME_CONST('myname', 14);\n+--------+\n| myname |\n+--------+\n| 14 |\n+--------+\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/miscellaneous-functions.html +[NOW] +declaration=[fsp] +category=Date and Time Functions +description=Returns the current date and time as a value in 'YYYY-MM-DD hh:mm:ss'\nor YYYYMMDDhhmmss format, depending on whether the function is used in\nstring or numeric context. The value is expressed in the session time\nzone.\n\nIf the fsp argument is given to specify a fractional seconds precision\nfrom 0 to 6, the return value includes a fractional seconds part of\nthat many digits.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/date-and-time-functions.html +[NTH_VALUE] +declaration=expr, N +category=Window Functions +description=Returns the value of expr from the N-th row of the window frame. If\nthere is no such row, the return value is NULL.\n\nN must be a literal positive integer.\n\nfrom_first_last is part of the SQL standard, but the MySQL\nimplementation permits only FROM FIRST (which is also the default).\nThis means that calculations begin at the first row of the window. FROM\nLAST is parsed, but produces an error. To obtain the same effect as\nFROM LAST (begin calculations at the last row of the window), use ORDER\nBY to sort in reverse order.\n\nover_clause is as described in\nhttps://dev.mysql.com/doc/refman/8.3/en/window-functions-usage.html.\nnull_treatment is as described in the section introduction.\n\nFor an example, see the FIRST_VALUE() function description.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/window-function-descriptions.html +[NTILE] +declaration=N +category=Window Functions +description=Divides a partition into N groups (buckets), assigns each row in the\npartition its bucket number, and returns the bucket number of the\ncurrent row within its partition. For example, if N is 4, NTILE()\ndivides rows into four buckets. If N is 100, NTILE() divides rows into\n100 buckets.\n\nN must be a literal positive integer. Bucket number return values range\nfrom 1 to N.\n\nN cannot be NULL, and must be an integer in the range 0 to 263,\ninclusive, in any of the following forms:\n\no an unsigned integer constant literal\n\no a positional parameter marker (?)\n\no a user-defined variable\n\no a local variable in a stored routine\n\nThis function should be used with ORDER BY to sort partition rows into\nthe desired order.\n\nover_clause is as described in\nhttps://dev.mysql.com/doc/refman/8.3/en/window-functions-usage.html.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/window-function-descriptions.html +[NULLIF] +declaration=expr1,expr2 +category=Flow Control Functions +description=Returns NULL if expr1 = expr2 is true, otherwise returns expr1. This is\nthe same as CASE WHEN expr1 = expr2 THEN NULL ELSE expr1 END.\n\nThe return value has the same type as the first argument.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/flow-control-functions.html +[OCT] +declaration=N +category=String Functions +description=Returns a string representation of the octal value of N, where N is a\nlonglong (BIGINT) number. This is equivalent to CONV(N,10,8). Returns\nNULL if N is NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/string-functions.html +[OCTET_LENGTH] +declaration=str +category=String Functions +description=OCTET_LENGTH() is a synonym for LENGTH().\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/string-functions.html +[ORD] +declaration=str +category=String Functions +description=If the leftmost character of the string str is a multibyte character,\nreturns the code for that character, calculated from the numeric values\nof its constituent bytes using this formula:\n\n (1st byte code)\n+ (2nd byte code * 256)\n+ (3rd byte code * 256^2) ...\n\nIf the leftmost character is not a multibyte character, ORD() returns\nthe same value as the ASCII() function. The function returns NULL if\nstr is NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/string-functions.html +[PERCENT_RANK] +declaration= +category=Window Functions +description=Returns the percentage of partition values less than the value in the\ncurrent row, excluding the highest value. Return values range from 0 to\n1 and represent the row relative rank, calculated as the result of this\nformula, where rank is the row rank and rows is the number of partition\nrows:\n\n(rank - 1) / (rows - 1)\n\nThis function should be used with ORDER BY to sort partition rows into\nthe desired order. Without ORDER BY, all rows are peers.\n\nover_clause is as described in\nhttps://dev.mysql.com/doc/refman/8.3/en/window-functions-usage.html.\n\nFor an example, see the CUME_DIST() function description.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/window-function-descriptions.html +[PERIOD_ADD] +declaration=P,N +category=Date and Time Functions +description=Adds N months to period P (in the format YYMM or YYYYMM). Returns a\nvalue in the format YYYYMM.\n\n*Note*:\n\nThe period argument P is not a date value.\n\nThis function returns NULL if P or N is NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/date-and-time-functions.html +[PERIOD_DIFF] +declaration=P1,P2 +category=Date and Time Functions +description=Returns the number of months between periods P1 and P2. P1 and P2\nshould be in the format YYMM or YYYYMM. Note that the period arguments\nP1 and P2 are not date values.\n\nThis function returns NULL if P1 or P2 is NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/date-and-time-functions.html +[PI] +declaration= +category=Numeric Functions +description=Returns the value of π (pi). The default number of decimal places\ndisplayed is seven, but MySQL uses the full double-precision value\ninternally.\n\nBecause the return value of this function is a double-precision value,\nits exact representation may vary between platforms or implementations.\nThis also applies to any expressions making use of PI(). See\nhttps://dev.mysql.com/doc/refman/8.3/en/floating-point-types.html.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/mathematical-functions.html +[POINT] +declaration=x, y +category=Geometry Constructors +description=Constructs a Point using its coordinates.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/gis-mysql-specific-functions.html +[POLYGON] +declaration=ls [, ls] ... +category=Geometry Constructors +description=Constructs a Polygon value from a number of LineString or WKB\nLineString arguments. If any argument does not represent a LinearRing\n(that is, not a closed and simple LineString), the return value is\nNULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/gis-mysql-specific-functions.html +[POSITION] +declaration=substr IN str +category=String Functions +description=POSITION(substr IN str) is a synonym for LOCATE(substr,str).\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/string-functions.html +[POW] +declaration=X,Y +category=Numeric Functions +description=Returns the value of X raised to the power of Y. Returns NULL if X or Y\nis NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/mathematical-functions.html +[POWER] +declaration=X,Y +category=Numeric Functions +description=This is a synonym for POW().\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/mathematical-functions.html +[PS_CURRENT_THREAD_ID] +declaration= +category=Performance Schema Functions +description=Returns a BIGINT UNSIGNED value representing the Performance Schema\nthread ID assigned to the current connection.\n\nThe thread ID return value is a value of the type given in the\nTHREAD_ID column of Performance Schema tables.\n\nPerformance Schema configuration affects PS_CURRENT_THREAD_ID() the\nsame way as for PS_THREAD_ID(). For details, see the description of\nthat function.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/performance-schema-functions.html +[PS_THREAD_ID] +declaration=connection_id +category=Performance Schema Functions +description=Given a connection ID, returns a BIGINT UNSIGNED value representing the\nPerformance Schema thread ID assigned to the connection ID, or NULL if\nno thread ID exists for the connection ID. The latter can occur for\nthreads that are not instrumented, or if connection_id is NULL.\n\nThe connection ID argument is a value of the type given in the\nPROCESSLIST_ID column of the Performance Schema threads table or the Id\ncolumn of SHOW PROCESSLIST output.\n\nThe thread ID return value is a value of the type given in the\nTHREAD_ID column of Performance Schema tables.\n\nPerformance Schema configuration affects PS_THREAD_ID() operation as\nfollows. (These remarks also apply to PS_CURRENT_THREAD_ID().)\n\no Disabling the thread_instrumentation consumer disables statistics\n from being collected and aggregated at the thread level, but has no\n effect on PS_THREAD_ID().\n\no If performance_schema_max_thread_instances is not 0, the Performance\n Schema allocates memory for thread statistics and assigns an internal\n ID to each thread for which instance memory is available. If there\n are threads for which instance memory is not available,\n PS_THREAD_ID() returns NULL; in this case,\n Performance_schema_thread_instances_lost is nonzero.\n\no If performance_schema_max_thread_instances is 0, the Performance\n Schema allocates no thread memory and PS_THREAD_ID() returns NULL.\n\no If the Performance Schema itself is disabled, PS_THREAD_ID() produces\n an error.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/performance-schema-functions.html +[QUARTER] +declaration=date +category=Date and Time Functions +description=Returns the quarter of the year for date, in the range 1 to 4, or NULL\nif date is NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/date-and-time-functions.html +[QUOTE] +declaration=str +category=String Functions +description=Quotes a string to produce a result that can be used as a properly\nescaped data value in an SQL statement. The string is returned enclosed\nby single quotation marks and with each instance of backslash (\),\nsingle quote ('), ASCII NUL, and Control+Z preceded by a backslash. If\nthe argument is NULL, the return value is the word "NULL" without\nenclosing single quotation marks.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/string-functions.html +[RADIANS] +declaration=X +category=Numeric Functions +description=Returns the argument X, converted from degrees to radians. (Note that\nπ radians equals 180 degrees.) Returns NULL if X is NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/mathematical-functions.html +[RAND] +declaration=[N] +category=Numeric Functions +description=Returns a random floating-point value v in the range 0 <= v < 1.0. To\nobtain a random integer R in the range i <= R < j, use the expression\nFLOOR(i + RAND() * (j − i)). For example, to obtain a random integer\nin the range the range 7 <= R < 12, use the following statement:\n\nSELECT FLOOR(7 + (RAND() * 5));\n\nIf an integer argument N is specified, it is used as the seed value:\n\no With a constant initializer argument, the seed is initialized once\n when the statement is prepared, prior to execution.\n\no With a nonconstant initializer argument (such as a column name), the\n seed is initialized with the value for each invocation of RAND().\n\nOne implication of this behavior is that for equal argument values,\nRAND(N) returns the same value each time, and thus produces a\nrepeatable sequence of column values. In the following example, the\nsequence of values produced by RAND(3) is the same both places it\noccurs.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/mathematical-functions.html +[RANDOM_BYTES] +declaration=len +category=Encryption Functions +description=This function returns a binary string of len random bytes generated\nusing the random number generator of the SSL library. Permitted values\nof len range from 1 to 1024. For values outside that range, an error\noccurs. Returns NULL if len is NULL.\n\nRANDOM_BYTES() can be used to provide the initialization vector for the\nAES_DECRYPT() and AES_ENCRYPT() functions. For use in that context, len\nmust be at least 16. Larger values are permitted, but bytes in excess\nof 16 are ignored.\n\nRANDOM_BYTES() generates a random value, which makes its result\nnondeterministic. Consequently, statements that use this function are\nunsafe for statement-based replication.\n\nIf RANDOM_BYTES() is invoked from within the mysql client, binary\nstrings display using hexadecimal notation, depending on the value of\nthe --binary-as-hex. For more information about that option, see\nhttps://dev.mysql.com/doc/refman/8.3/en/mysql.html.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/encryption-functions.html +[RANK] +declaration= +category=Window Functions +description=Returns the rank of the current row within its partition, with gaps.\nPeers are considered ties and receive the same rank. This function does\nnot assign consecutive ranks to peer groups if groups of size greater\nthan one exist; the result is noncontiguous rank numbers.\n\nThis function should be used with ORDER BY to sort partition rows into\nthe desired order. Without ORDER BY, all rows are peers.\n\nover_clause is as described in\nhttps://dev.mysql.com/doc/refman/8.3/en/window-functions-usage.html.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/window-function-descriptions.html +[REGEXP_INSTR] +declaration=expr, pat[, pos[, occurrence[, return_option[, match_type]]]] +category=String Functions +description=Returns the starting index of the substring of the string expr that\nmatches the regular expression specified by the pattern pat, 0 if there\nis no match. If expr or pat is NULL, the return value is NULL.\nCharacter indexes begin at 1.\n\nREGEXP_INSTR() takes these optional arguments:\n\no pos: The position in expr at which to start the search. If omitted,\n the default is 1.\n\no occurrence: Which occurrence of a match to search for. If omitted,\n the default is 1.\n\no return_option: Which type of position to return. If this value is 0,\n REGEXP_INSTR() returns the position of the matched substring's first\n character. If this value is 1, REGEXP_INSTR() returns the position\n following the matched substring. If omitted, the default is 0.\n\no match_type: A string that specifies how to perform matching. The\n meaning is as described for REGEXP_LIKE().\n\nFor additional information about how matching occurs, see the\ndescription for REGEXP_LIKE().\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/regexp.html +[REGEXP_LIKE] +declaration=expr, pat[, match_type] +category=String Functions +description=Returns 1 if the string expr matches the regular expression specified\nby the pattern pat, 0 otherwise. If expr or pat is NULL, the return\nvalue is NULL.\n\nThe pattern can be an extended regular expression, the syntax for which\nis discussed in\nhttps://dev.mysql.com/doc/refman/8.3/en/regexp.html#regexp-syntax. The\npattern need not be a literal string. For example, it can be specified\nas a string expression or table column.\n\nThe optional match_type argument is a string that may contain any or\nall the following characters specifying how to perform matching:\n\no c: Case-sensitive matching.\n\no i: Case-insensitive matching.\n\no m: Multiple-line mode. Recognize line terminators within the string.\n The default behavior is to match line terminators only at the start\n and end of the string expression.\n\no n: The . character matches line terminators. The default is for .\n matching to stop at the end of a line.\n\no u: Unix-only line endings. Only the newline character is recognized\n as a line ending by the ., ^, and $ match operators.\n\nIf characters specifying contradictory options are specified within\nmatch_type, the rightmost one takes precedence.\n\nBy default, regular expression operations use the character set and\ncollation of the expr and pat arguments when deciding the type of a\ncharacter and performing the comparison. If the arguments have\ndifferent character sets or collations, coercibility rules apply as\ndescribed in\nhttps://dev.mysql.com/doc/refman/8.3/en/charset-collation-coercibility.\nhtml. Arguments may be specified with explicit collation indicators to\nchange comparison behavior.\n\nmysql> SELECT REGEXP_LIKE('CamelCase', 'CAMELCASE');\n+---------------------------------------+\n| REGEXP_LIKE('CamelCase', 'CAMELCASE') |\n+---------------------------------------+\n| 1 |\n+---------------------------------------+\nmysql> SELECT REGEXP_LIKE('CamelCase', 'CAMELCASE' COLLATE utf8mb4_0900_as_cs);\n+------------------------------------------------------------------+\n| REGEXP_LIKE('CamelCase', 'CAMELCASE' COLLATE utf8mb4_0900_as_cs) |\n+------------------------------------------------------------------+\n| 0 |\n ... +[REGEXP_REPLACE] +declaration=expr, pat, repl[, pos[, occurrence[, match_type]]] +category=String Functions +description=Replaces occurrences in the string expr that match the regular\nexpression specified by the pattern pat with the replacement string\nrepl, and returns the resulting string. If expr, pat, or repl is NULL,\nthe return value is NULL.\n\nREGEXP_REPLACE() takes these optional arguments:\n\no pos: The position in expr at which to start the search. If omitted,\n the default is 1.\n\no occurrence: Which occurrence of a match to replace. If omitted, the\n default is 0 (which means "replace all occurrences").\n\no match_type: A string that specifies how to perform matching. The\n meaning is as described for REGEXP_LIKE().\n\nThe result returned by this function uses the character set and\ncollation of the expression searched for matches.\n\nFor additional information about how matching occurs, see the\ndescription for REGEXP_LIKE().\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/regexp.html +[REGEXP_SUBSTR] +declaration=expr, pat[, pos[, occurrence[, match_type]]] +category=String Functions +description=Returns the substring of the string expr that matches the regular\nexpression specified by the pattern pat, NULL if there is no match. If\nexpr or pat is NULL, the return value is NULL.\n\nREGEXP_SUBSTR() takes these optional arguments:\n\no pos: The position in expr at which to start the search. If omitted,\n the default is 1.\n\no occurrence: Which occurrence of a match to search for. If omitted,\n the default is 1.\n\no match_type: A string that specifies how to perform matching. The\n meaning is as described for REGEXP_LIKE().\n\nThe result returned by this function uses the character set and\ncollation of the expression searched for matches.\n\nFor additional information about how matching occurs, see the\ndescription for REGEXP_LIKE().\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/regexp.html +[RELEASE_ALL_LOCKS] +declaration= +category=Locking Functions +description=Releases all named locks held by the current session and returns the\nnumber of locks released (0 if there were none)\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/locking-functions.html +[RELEASE_LOCK] +declaration=str +category=Locking Functions +description=Releases the lock named by the string str that was obtained with\nGET_LOCK(). Returns 1 if the lock was released, 0 if the lock was not\nestablished by this thread (in which case the lock is not released),\nand NULL if the named lock did not exist. The lock does not exist if it\nwas never obtained by a call to GET_LOCK() or if it has previously been\nreleased.\n\nThe DO statement is convenient to use with RELEASE_LOCK(). See [HELP\nDO].\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/locking-functions.html +[REVERSE] +declaration=str +category=String Functions +description=Returns the string str with the order of the characters reversed, or\nNULL if str is NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/string-functions.html +[RIGHT] +declaration=str,len +category=String Functions +description=Returns the rightmost len characters from the string str, or NULL if\nany argument is NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/string-functions.html +[ROLES_GRAPHML] +declaration= +category=Information Functions +description=Returns a utf8mb3 string containing a GraphML document representing\nmemory role subgraphs. The ROLE_ADMIN privilege (or the deprecated\nSUPER privilege) is required to see content in the element.\nOtherwise, the result shows only an empty element:\n\nmysql> SELECT ROLES_GRAPHML();\n+---------------------------------------------------+\n| ROLES_GRAPHML() |\n+---------------------------------------------------+\n| |\n+---------------------------------------------------+\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/information-functions.html +[ROUND] +declaration=X +category=Numeric Functions +description=Rounds the argument X to D decimal places. The rounding algorithm\ndepends on the data type of X. D defaults to 0 if not specified. D can\nbe negative to cause D digits left of the decimal point of the value X\nto become zero. The maximum absolute value for D is 30; any digits in\nexcess of 30 (or -30) are truncated. If X or D is NULL, the function\nreturns NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/mathematical-functions.html +[ROW_COUNT] +declaration= +category=Information Functions +description=ROW_COUNT() returns a value as follows:\n\no DDL statements: 0. This applies to statements such as CREATE TABLE or\n DROP TABLE.\n\no DML statements other than SELECT: The number of affected rows. This\n applies to statements such as UPDATE, INSERT, or DELETE (as before),\n but now also to statements such as ALTER TABLE and LOAD DATA.\n\no SELECT: -1 if the statement returns a result set, or the number of\n rows "affected" if it does not. For example, for SELECT * FROM t1,\n ROW_COUNT() returns -1. For SELECT * FROM t1 INTO OUTFILE\n 'file_name', ROW_COUNT() returns the number of rows written to the\n file.\n\no SIGNAL statements: 0.\n\nFor UPDATE statements, the affected-rows value by default is the number\nof rows actually changed. If you specify the CLIENT_FOUND_ROWS flag to\nmysql_real_connect()\n(https://dev.mysql.com/doc/c-api/8.2/en/mysql-real-connect.html) when\nconnecting to mysqld, the affected-rows value is the number of rows\n"found"; that is, matched by the WHERE clause.\n\nFor REPLACE statements, the affected-rows value is 2 if the new row\nreplaced an old row, because in this case, one row was inserted after\nthe duplicate was deleted.\n\nFor INSERT ... ON DUPLICATE KEY UPDATE statements, the affected-rows\nvalue per row is 1 if the row is inserted as a new row, 2 if an\nexisting row is updated, and 0 if an existing row is set to its current\nvalues. If you specify the CLIENT_FOUND_ROWS flag, the affected-rows\nvalue is 1 (not 0) if an existing row is set to its current values.\n\nThe ROW_COUNT() value is similar to the value from the\nmysql_affected_rows()\n(https://dev.mysql.com/doc/c-api/8.2/en/mysql-affected-rows.html) C API\nfunction and the row count that the mysql client displays following\nstatement execution.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/information-functions.html +[ROW_NUMBER] +declaration= +category=Window Functions +description=Returns the number of the current row within its partition. Rows\nnumbers range from 1 to the number of partition rows.\n\nORDER BY affects the order in which rows are numbered. Without ORDER\nBY, row numbering is nondeterministic.\n\nROW_NUMBER() assigns peers different row numbers. To assign peers the\nsame value, use RANK() or DENSE_RANK(). For an example, see the RANK()\nfunction description.\n\nover_clause is as described in\nhttps://dev.mysql.com/doc/refman/8.3/en/window-functions-usage.html.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/window-function-descriptions.html +[RPAD] +declaration=str,len,padstr +category=String Functions +description=Returns the string str, right-padded with the string padstr to a length\nof len characters. If str is longer than len, the return value is\nshortened to len characters. If str, padstr, or len is NULL, the\nfunction returns NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/string-functions.html +[RTRIM] +declaration=str +category=String Functions +description=Returns the string str with trailing space characters removed.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/string-functions.html +[SCHEMA] +declaration= +category=Information Functions +description=This function is a synonym for DATABASE().\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/information-functions.html +[SECOND] +declaration=time +category=Date and Time Functions +description=Returns the second for time, in the range 0 to 59, or NULL if time is\nNULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/date-and-time-functions.html +[SEC_TO_TIME] +declaration=seconds +category=Date and Time Functions +description=Returns the seconds argument, converted to hours, minutes, and seconds,\nas a TIME value. The range of the result is constrained to that of the\nTIME data type. A warning occurs if the argument corresponds to a value\noutside that range.\n\nThe function returns NULL if seconds is NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/date-and-time-functions.html +[SESSION_USER] +declaration= +category=Information Functions +description=SESSION_USER() is a synonym for USER().\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/information-functions.html +[SHA1] +declaration=str +category=Encryption Functions +description=Calculates an SHA-1 160-bit checksum for the string, as described in\nRFC 3174 (Secure Hash Algorithm). The value is returned as a string of\n40 hexadecimal digits, or NULL if the argument is NULL. One of the\npossible uses for this function is as a hash key. See the notes at the\nbeginning of this section about storing hash values efficiently. SHA()\nis synonymous with SHA1().\n\nThe return value is a string in the connection character set.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/encryption-functions.html +[SHA2] +declaration=str, hash_length +category=Encryption Functions +description=Calculates the SHA-2 family of hash functions (SHA-224, SHA-256,\nSHA-384, and SHA-512). The first argument is the plaintext string to be\nhashed. The second argument indicates the desired bit length of the\nresult, which must have a value of 224, 256, 384, 512, or 0 (which is\nequivalent to 256). If either argument is NULL or the hash length is\nnot one of the permitted values, the return value is NULL. Otherwise,\nthe function result is a hash value containing the desired number of\nbits. See the notes at the beginning of this section about storing hash\nvalues efficiently.\n\nThe return value is a string in the connection character set.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/encryption-functions.html +[SIGN] +declaration=X +category=Numeric Functions +description=Returns the sign of the argument as -1, 0, or 1, depending on whether X\nis negative, zero, or positive. Returns NULL if X is NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/mathematical-functions.html +[SIN] +declaration=X +category=Numeric Functions +description=Returns the sine of X, where X is given in radians. Returns NULL if X\nis NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/mathematical-functions.html +[SLEEP] +declaration=duration +category=Miscellaneous Functions +description=Sleeps (pauses) for the number of seconds given by the duration\nargument, then returns 0. The duration may have a fractional part. If\nthe argument is NULL or negative, SLEEP() produces a warning, or an\nerror in strict SQL mode.\n\nWhen sleep returns normally (without interruption), it returns 0:\n\nmysql> SELECT SLEEP(1000);\n+-------------+\n| SLEEP(1000) |\n+-------------+\n| 0 |\n+-------------+\n\nWhen SLEEP() is the only thing invoked by a query that is interrupted,\nit returns 1 and the query itself returns no error. This is true\nwhether the query is killed or times out:\n\no This statement is interrupted using KILL QUERY from another session:\n\nmysql> SELECT SLEEP(1000);\n+-------------+\n| SLEEP(1000) |\n+-------------+\n| 1 |\n+-------------+\n\no This statement is interrupted by timing out:\n\nmysql> SELECT /*+ MAX_EXECUTION_TIME(1) */ SLEEP(1000);\n+-------------+\n| SLEEP(1000) |\n+-------------+\n| 1 |\n+-------------+\n\nWhen SLEEP() is only part of a query that is interrupted, the query\nreturns an error:\n\no This statement is interrupted using KILL QUERY from another session:\n\nmysql> SELECT 1 FROM t1 WHERE SLEEP(1000);\nERROR 1317 (70100): Query execution was interrupted\n\no This statement is interrupted by timing out:\n\nmysql> SELECT /*+ MAX_EXECUTION_TIME(1000) */ 1 FROM t1 WHERE SLEEP(1000);\nERROR 3024 (HY000): Query execution was interrupted, maximum statement\nexecution time exceeded\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/miscellaneous-functions.html +[SMALLINT] +declaration=M +category=Data Types +description=A small integer. The signed range is -32768 to 32767. The unsigned\nrange is 0 to 65535.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/numeric-type-syntax.html +[SOUNDEX] +declaration=str +category=String Functions +description=Returns a soundex string from str, or NULL if str is NULL. Two strings\nthat sound almost the same should have identical soundex strings. A\nstandard soundex string is four characters long, but the SOUNDEX()\nfunction returns an arbitrarily long string. You can use SUBSTRING() on\nthe result to get a standard soundex string. All nonalphabetic\ncharacters in str are ignored. All international alphabetic characters\noutside the A-Z range are treated as vowels.\n\n*Important*:\n\nWhen using SOUNDEX(), you should be aware of the following limitations:\n\no This function, as currently implemented, is intended to work well\n with strings that are in the English language only. Strings in other\n languages may not produce reliable results.\n\no This function is not guaranteed to provide consistent results with\n strings that use multibyte character sets, including utf-8. See Bug\n #22638 for more information.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/string-functions.html +[SOURCE_POS_WAIT] +declaration=log_name,log_pos[,timeout][,channel] +category=GTID +description=This function is for control of source-replica synchronization. It\nblocks until the replica has read and applied all updates up to the\nspecified position in the source's binary log.\n\nThe return value is the number of log events the replica had to wait\nfor to advance to the specified position. The function returns NULL if\nthe replication SQL thread is not started, the replica's source\ninformation is not initialized, the arguments are incorrect, or an\nerror occurs. It returns -1 if the timeout has been exceeded. If the\nreplication SQL thread stops while SOURCE_POS_WAIT() is waiting, the\nfunction returns NULL. If the replica is past the specified position,\nthe function returns immediately.\n\nIf the binary log file position has been marked as invalid, the\nfunction waits until a valid file position is known. The binary log\nfile position can be marked as invalid when the CHANGE REPLICATION\nSOURCE TO option GTID_ONLY is set for the replication channel, and the\nserver is restarted or replication is stopped. The file position\nbecomes valid after a transaction is successfully applied past the\ngiven file position. If the applier does not reach the stated position,\nthe function waits until the timeout. Use a SHOW REPLICA STATUS\nstatement to check if the binary log file position has been marked as\ninvalid.\n\nOn a multithreaded replica, the function waits until expiry of the\nlimit set by the replica_checkpoint_group or replica_checkpoint_period\nsystem variable, when the checkpoint operation is called to update the\nstatus of the replica. Depending on the setting for the system\nvariables, the function might therefore return some time after the\nspecified position was reached.\n\nIf binary log transaction compression is in use and the transaction\npayload at the specified position is compressed (as a\nTransaction_payload_event), the function waits until the whole\ntransaction has been read and applied, and the positions have updated.\n\nIf a timeout value is specified, SOURCE_POS_WAIT() stops waiting when\ntimeout seconds have elapsed. timeout must be greater than or equal to\n0. (When the server is running in strict SQL mode, a negative timeout\nvalue is immediately rejected with ER_WRONG_ARGUMENTS\n(https://dev.mysql.com/doc/mysql-errors/8.3/en/server-error-reference.html\n#error_er_wrong_arguments); otherwise the function returns NULL, and\nraises a warning.)\n\nThe optional channel value enables you to name which replication\nchannel the function applies to. See\nhttps://dev.mysql.com/doc/refman/8.3/en/replication-channels.html for\nmore information.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/replication-functions-synchronization.html +[SPACE] +declaration=N +category=String Functions +description=Returns a string consisting of N space characters, or NULL if N is\nNULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/string-functions.html +[SQRT] +declaration=X +category=Numeric Functions +description=Returns the square root of a nonnegative number X. If X is NULL, the\nfunction returns NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/mathematical-functions.html +[STATEMENT_DIGEST] +declaration=statement +category=Encryption Functions +description=Given an SQL statement as a string, returns the statement digest hash\nvalue as a string in the connection character set, or NULL if the\nargument is NULL. The related STATEMENT_DIGEST_TEXT() function returns\nthe normalized statement digest. For information about statement\ndigesting, see\nhttps://dev.mysql.com/doc/refman/8.3/en/performance-schema-statement-di\ngests.html.\n\nBoth functions use the MySQL parser to parse the statement. If parsing\nfails, an error occurs. The error message includes the parse error only\nif the statement is provided as a literal string.\n\nThe max_digest_length system variable determines the maximum number of\nbytes available to these functions for computing normalized statement\ndigests.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/encryption-functions.html +[STATEMENT_DIGEST_TEXT] +declaration=statement +category=Encryption Functions +description=Given an SQL statement as a string, returns the normalized statement\ndigest as a string in the connection character set, or NULL if the\nargument is NULL. For additional discussion and examples, see the\ndescription of the related STATEMENT_DIGEST() function.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/encryption-functions.html +[STD] +declaration=expr +category=Aggregate Functions and Modifiers +description=Returns the population standard deviation of expr. STD() is a synonym\nfor the standard SQL function STDDEV_POP(), provided as a MySQL\nextension.\n\nIf there are no matching rows, or if expr is NULL, STD() returns NULL.\n\nThis function executes as a window function if over_clause is present.\nover_clause is as described in\nhttps://dev.mysql.com/doc/refman/8.3/en/window-functions-usage.html.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/aggregate-functions.html +[STDDEV] +declaration=expr +category=Aggregate Functions and Modifiers +description=Returns the population standard deviation of expr. STDDEV() is a\nsynonym for the standard SQL function STDDEV_POP(), provided for\ncompatibility with Oracle.\n\nIf there are no matching rows, or if expr is NULL, STDDEV() returns\nNULL.\n\nThis function executes as a window function if over_clause is present.\nover_clause is as described in\nhttps://dev.mysql.com/doc/refman/8.3/en/window-functions-usage.html.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/aggregate-functions.html +[STDDEV_POP] +declaration=expr +category=Aggregate Functions and Modifiers +description=Returns the population standard deviation of expr (the square root of\nVAR_POP()). You can also use STD() or STDDEV(), which are equivalent\nbut not standard SQL.\n\nIf there are no matching rows, or if expr is NULL, STDDEV_POP() returns\nNULL.\n\nThis function executes as a window function if over_clause is present.\nover_clause is as described in\nhttps://dev.mysql.com/doc/refman/8.3/en/window-functions-usage.html.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/aggregate-functions.html +[STDDEV_SAMP] +declaration=expr +category=Aggregate Functions and Modifiers +description=Returns the sample standard deviation of expr (the square root of\nVAR_SAMP().\n\nIf there are no matching rows, or if expr is NULL, STDDEV_SAMP()\nreturns NULL.\n\nThis function executes as a window function if over_clause is present.\nover_clause is as described in\nhttps://dev.mysql.com/doc/refman/8.3/en/window-functions-usage.html.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/aggregate-functions.html +[STRCMP] +declaration=expr1,expr2 +category=String Functions +description=STRCMP() returns 0 if the strings are the same, -1 if the first\nargument is smaller than the second according to the current sort\norder, and NULL if either argument is NULL. It returns 1 otherwise.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/string-comparison-functions.html +[STR_TO_DATE] +declaration=str,format +category=Date and Time Functions +description=This is the inverse of the DATE_FORMAT() function. It takes a string\nstr and a format string format. STR_TO_DATE() returns a DATETIME value\nif the format string contains both date and time parts, or a DATE or\nTIME value if the string contains only date or time parts. If str or\nformat is NULL, the function returns NULL. If the date, time, or\ndatetime value extracted from str cannot be parsed according to the\nrules followed by the server, STR_TO_DATE() returns NULL and produces a\nwarning.\n\nThe server scans str attempting to match format to it. The format\nstring can contain literal characters and format specifiers beginning\nwith %. Literal characters in format must match literally in str.\nFormat specifiers in format must match a date or time part in str. For\nthe specifiers that can be used in format, see the DATE_FORMAT()\nfunction description.\n\nmysql> SELECT STR_TO_DATE('01,5,2013','%d,%m,%Y');\n -> '2013-05-01'\nmysql> SELECT STR_TO_DATE('May 1, 2013','%M %d,%Y');\n -> '2013-05-01'\n\nScanning starts at the beginning of str and fails if format is found\nnot to match. Extra characters at the end of str are ignored.\n\nmysql> SELECT STR_TO_DATE('a09:30:17','a%h:%i:%s');\n -> '09:30:17'\nmysql> SELECT STR_TO_DATE('a09:30:17','%h:%i:%s');\n -> NULL\nmysql> SELECT STR_TO_DATE('09:30:17a','%h:%i:%s');\n -> '09:30:17'\n\nUnspecified date or time parts have a value of 0, so incompletely\nspecified values in str produce a result with some or all parts set to\n0:\n\nmysql> SELECT STR_TO_DATE('abc','abc');\n -> '0000-00-00'\nmysql> SELECT STR_TO_DATE('9','%m');\n -> '0000-09-00'\nmysql> SELECT STR_TO_DATE('9','%s');\n -> '00:00:09'\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/date-and-time-functions.html +[ST_AREA] +declaration={poly|mpoly} +category=Polygon Property Functions +description=Returns a double-precision number indicating the area of the Polygon or\nMultiPolygon argument, as measured in its spatial reference system.\n\nST_Area() handles its arguments as described in the introduction to\nthis section, with these exceptions:\n\no If the geometry is geometrically invalid, either the result is an\n undefined area (that is, it can be any number), or an error occurs.\n\no If the geometry is valid but is not a Polygon or MultiPolygon object,\n an ER_UNEXPECTED_GEOMETRY_TYPE\n (https://dev.mysql.com/doc/mysql-errors/8.3/en/server-error-reference\n .html#error_er_unexpected_geometry_type) error occurs.\n\no If the geometry is a valid Polygon in a Cartesian SRS, the result is\n the Cartesian area of the polygon.\n\no If the geometry is a valid MultiPolygon in a Cartesian SRS, the\n result is the sum of the Cartesian area of the polygons.\n\no If the geometry is a valid Polygon in a geographic SRS, the result is\n the geodetic area of the polygon in that SRS, in square meters.\n\no If the geometry is a valid MultiPolygon in a geographic SRS, the\n result is the sum of geodetic area of the polygons in that SRS, in\n square meters.\n\no If an area computation results in +inf, an ER_DATA_OUT_OF_RANGE\n (https://dev.mysql.com/doc/mysql-errors/8.3/en/server-error-reference\n .html#error_er_data_out_of_range) error occurs.\n\no If the geometry has a geographic SRS with a longitude or latitude\n that is out of range, an error occurs:\n\n o If a longitude value is not in the range (−180, 180], an\n ER_GEOMETRY_PARAM_LONGITUDE_OUT_OF_RANGE\n (https://dev.mysql.com/doc/mysql-errors/8.3/en/server-error-referen\n ce.html#error_er_geometry_param_longitude_out_of_range) error\n occurs.\n\n o If a latitude value is not in the range [−90, 90], an\n ER_GEOMETRY_PARAM_LATITUDE_OUT_OF_RANGE\n (https://dev.mysql.com/doc/mysql-errors/8.3/en/server-error-referen\n ce.html#error_er_geometry_param_latitude_out_of_range) error\n occurs.\n\n Ranges shown are in degrees. The exact range limits deviate slightly\n due to floating-point arithmetic.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/gis-polygon-property-functions.html +[ST_ASBINARY] +declaration=g [, options] +category=WKB Functions +description=Converts a value in internal geometry format to its WKB representation\nand returns the binary result.\n\nThe function return value has geographic coordinates (latitude,\nlongitude) in the order specified by the spatial reference system that\napplies to the geometry argument. An optional options argument may be\ngiven to override the default axis order.\n\nST_AsBinary() and ST_AsWKB() handle their arguments as described in the\nintroduction to this section.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/gis-format-conversion-functions.html +[ST_ASGEOJSON] +declaration=g [, max_dec_digits [, options]] +category=MBR Functions +description=Generates a GeoJSON object from the geometry g. The object string has\nthe connection character set and collation.\n\nIf any argument is NULL, the return value is NULL. If any non-NULL\nargument is invalid, an error occurs.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/spatial-geojson-functions.html +[ST_ASTEXT] +declaration=g [, options] +category=WKB Functions +description=Converts a value in internal geometry format to its WKT representation\nand returns the string result.\n\nThe function return value has geographic coordinates (latitude,\nlongitude) in the order specified by the spatial reference system that\napplies to the geometry argument. An optional options argument may be\ngiven to override the default axis order.\n\nST_AsText() and ST_AsWKT() handle their arguments as described in the\nintroduction to this section.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/gis-format-conversion-functions.html +[ST_BUFFER] +declaration=g, d [, strategy1 [, strategy2 [, strategy3]]] +category=GeometryCollection Property Functions +description=Returns a geometry that represents all points whose distance from the\ngeometry value g is less than or equal to a distance of d. The result\nis in the same SRS as the geometry argument.\n\nIf the geometry argument is empty, ST_Buffer() returns an empty\ngeometry.\n\nIf the distance is 0, ST_Buffer() returns the geometry argument\nunchanged:\n\nmysql> SET @pt = ST_GeomFromText('POINT(0 0)');\nmysql> SELECT ST_AsText(ST_Buffer(@pt, 0));\n+------------------------------+\n| ST_AsText(ST_Buffer(@pt, 0)) |\n+------------------------------+\n| POINT(0 0) |\n+------------------------------+\n\nIf the geometry argument is in a Cartesian SRS:\n\no ST_Buffer() supports negative distances for Polygon and MultiPolygon\n values, and for geometry collections containing Polygon or\n MultiPolygon values.\n\no If the result is reduced so much that it disappears, the result is an\n empty geometry.\n\no An ER_WRONG_ARGUMENTS\n (https://dev.mysql.com/doc/mysql-errors/8.3/en/server-error-reference\n .html#error_er_wrong_arguments) error occurs for ST_Buffer() with a\n negative distance for Point, MultiPoint, LineString, and\n MultiLineString values, and for geometry collections not containing\n any Polygon or MultiPolygon values.\n\nPoint geometries in a geographic SRS are permitted, subject to the\nfollowing conditions:\n\no If the distance is not negative and no strategies are specified, the\n function returns the geographic buffer of the Point in its SRS. The\n distance argument must be in the SRS distance unit (currently always\n meters).\n\no If the distance is negative or any strategy (except NULL) is\n specified, an ER_WRONG_ARGUMENTS\n (https://dev.mysql.com/doc/mysql-errors/8.3/en/server-error-reference\n .html#error_er_wrong_arguments) error occurs.\n\nFor non-Point geometries, an ER_NOT_IMPLEMENTED_FOR_GEOGRAPHIC_SRS\n(https://dev.mysql.com/doc/mysql-errors/8.3/en/server-error-reference.html\n#error_er_not_implemented_for_geographic_srs) error occurs.\n ... +[ST_BUFFER_STRATEGY] +declaration=strategy [, points_per_circle] +category=GeometryCollection Property Functions +description=This function returns a strategy byte string for use with ST_Buffer()\nto influence buffer computation.\n\nInformation about strategies is available at Boost.org\n(http://www.boost.org).\n\nThe first argument must be a string indicating a strategy option:\n\no For point strategies, permitted values are 'point_circle' and\n 'point_square'.\n\no For join strategies, permitted values are 'join_round' and\n 'join_miter'.\n\no For end strategies, permitted values are 'end_round' and 'end_flat'.\n\nIf the first argument is 'point_circle', 'join_round', 'join_miter', or\n'end_round', the points_per_circle argument must be given as a positive\nnumeric value. The maximum points_per_circle value is the value of the\nmax_points_in_geometry system variable.\n\nFor examples, see the description of ST_Buffer().\n\nST_Buffer_Strategy() handles its arguments as described in the\nintroduction to this section, with these exceptions:\n\no If any argument is invalid, an ER_WRONG_ARGUMENTS\n (https://dev.mysql.com/doc/mysql-errors/8.3/en/server-error-reference\n .html#error_er_wrong_arguments) error occurs.\n\no If the first argument is 'point_square' or 'end_flat', the\n points_per_circle argument must not be given or an ER_WRONG_ARGUMENTS\n (https://dev.mysql.com/doc/mysql-errors/8.3/en/server-error-reference\n .html#error_er_wrong_arguments) error occurs.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/spatial-operator-functions.html +[ST_CENTROID] +declaration={poly|mpoly} +category=Polygon Property Functions +description=Returns the mathematical centroid for the Polygon or MultiPolygon\nargument as a Point. The result is not guaranteed to be on the\nMultiPolygon.\n\nThis function processes geometry collections by computing the centroid\npoint for components of highest dimension in the collection. Such\ncomponents are extracted and made into a single MultiPolygon,\nMultiLineString, or MultiPoint for centroid computation.\n\nST_Centroid() handles its arguments as described in the introduction to\nthis section, with these exceptions:\n\no The return value is NULL for the additional condition that the\n argument is an empty geometry collection.\n\no If the geometry has an SRID value for a geographic spatial reference\n system (SRS), an ER_NOT_IMPLEMENTED_FOR_GEOGRAPHIC_SRS\n (https://dev.mysql.com/doc/mysql-errors/8.3/en/server-error-reference\n .html#error_er_not_implemented_for_geographic_srs) error occurs.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/gis-polygon-property-functions.html +[ST_COLLECT] +declaration=[DISTINCT] g +category=MBR Functions +description=Aggregates geometry values and returns a single geometry collection\nvalue. With the DISTINCT option, returns the aggregation of the\ndistinct geometry arguments.\n\nAs with other aggregate functions, GROUP BY may be used to group\narguments into subsets. ST_Collect() returns an aggregate value for\neach subset.\n\nThis function executes as a window function if over_clause is present.\nover_clause is as described in\nhttps://dev.mysql.com/doc/refman/8.3/en/window-functions-usage.html. In\ncontrast to most aggregate functions that support windowing,\nST_Collect() permits use of over_clause together with DISTINCT.\n\nST_Collect() handles its arguments as follows:\n\no NULL arguments are ignored.\n\no If all arguments are NULL or the aggregate result is empty, the\n return value is NULL.\n\no If any geometry argument is not a syntactically well-formed geometry,\n an ER_GIS_INVALID_DATA\n (https://dev.mysql.com/doc/mysql-errors/8.3/en/server-error-reference\n .html#error_er_gis_invalid_data) error occurs.\n\no If any geometry argument is a syntactically well-formed geometry in\n an undefined spatial reference system (SRS), an ER_SRS_NOT_FOUND\n (https://dev.mysql.com/doc/mysql-errors/8.3/en/server-error-reference\n .html#error_er_srs_not_found) error occurs.\n\no If there are multiple geometry arguments and those arguments are in\n the same SRS, the return value is in that SRS. If those arguments are\n not in the same SRS, an ER_GIS_DIFFERENT_SRIDS_AGGREGATION\n (https://dev.mysql.com/doc/mysql-errors/8.3/en/server-error-reference\n .html#error_er_gis_different_srids_aggregation) error occurs.\n\no The result is the narrowest MultiXxx or GeometryCollection value\n possible, with the result type determined from the non-NULL geometry\n arguments as follows:\n\n o If all arguments are Point values, the result is a MultiPoint\n value.\n\n o If all arguments are LineString values, the result is a\n MultiLineString value.\n\n o If all arguments are Polygon values, the result is a MultiPolygon\n value.\n\n ... +[ST_CONTAINS] +declaration=g1, g2 +category=Geometry Relation Functions +description=Returns 1 or 0 to indicate whether g1 completely contains g2. This\ntests the opposite relationship as ST_Within().\n\nST_Contains() handles its arguments as described in the introduction to\nthis section.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/spatial-relation-functions-object-shapes.html +[ST_CONVEXHULL] +declaration=g +category=GeometryCollection Property Functions +description=Returns a geometry that represents the convex hull of the geometry\nvalue g.\n\nThis function computes a geometry's convex hull by first checking\nwhether its vertex points are colinear. The function returns a linear\nhull if so, a polygon hull otherwise. This function processes geometry\ncollections by extracting all vertex points of all components of the\ncollection, creating a MultiPoint value from them, and computing its\nconvex hull.\n\nST_ConvexHull() handles its arguments as described in the introduction\nto this section, with this exception:\n\no The return value is NULL for the additional condition that the\n argument is an empty geometry collection.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/spatial-operator-functions.html +[ST_CROSSES] +declaration=g1, g2 +category=Geometry Relation Functions +description=Two geometries spatially cross if their spatial relation has the\nfollowing properties:\n\no Unless g1 and g2 are both of dimension 1: g1 crosses g2 if the\n interior of g2 has points in common with the interior of g1, but g2\n does not cover the entire interior of g1.\n\no If both g1 and g2 are of dimension 1: If the lines cross each other\n in a finite number of points (that is, no common line segments, only\n single points in common).\n\nThis function returns 1 or 0 to indicate whether g1 spatially crosses\ng2.\n\nST_Crosses() handles its arguments as described in the introduction to\nthis section except that the return value is NULL for these additional\nconditions:\n\no g1 is of dimension 2 (Polygon or MultiPolygon).\n\no g2 is of dimension 1 (Point or MultiPoint).\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/spatial-relation-functions-object-shapes.html +[ST_DIFFERENCE] +declaration=g1, g2 +category=GeometryCollection Property Functions +description=Returns a geometry that represents the point set difference of the\ngeometry values g1 and g2. The result is in the same SRS as the\ngeometry arguments.\n\nST_Difference() permits arguments in either a Cartesian or a geographic\nSRS, and handles its arguments as described in the introduction to this\nsection.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/spatial-operator-functions.html +[ST_DIMENSION] +declaration=g +category=Geometry Property Functions +description=Returns the inherent dimension of the geometry value g. The dimension\ncan be −1, 0, 1, or 2. The meaning of these values is given in\nhttps://dev.mysql.com/doc/refman/8.3/en/gis-class-geometry.html.\n\nST_Dimension() handles its arguments as described in the introduction\nto this section.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/gis-general-property-functions.html +[ST_DISJOINT] +declaration=g1, g2 +category=Geometry Relation Functions +description=Returns 1 or 0 to indicate whether g1 is spatially disjoint from (does\nnot intersect) g2.\n\nST_Disjoint() handles its arguments as described in the introduction to\nthis section.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/spatial-relation-functions-object-shapes.html +[ST_DISTANCE] +declaration=g1, g2 [, unit] +category=Geometry Relation Functions +description=Returns the distance between g1 and g2, measured in the length unit of\nthe spatial reference system (SRS) of the geometry arguments, or in the\nunit of the optional unit argument if that is specified.\n\nThis function processes geometry collections by returning the shortest\ndistance among all combinations of the components of the two geometry\narguments.\n\nST_Distance() handles its geometry arguments as described in the\nintroduction to this section, with these exceptions:\n\no ST_Distance() detects arguments in a geographic (ellipsoidal) spatial\n reference system and returns the geodetic distance on the ellipsoid.\n ST_Distance() supports distance calculations for geographic SRS\n arguments of all geometry types.\n\no If any argument is geometrically invalid, either the result is an\n undefined distance (that is, it can be any number), or an error\n occurs.\n\no If an intermediate or final result produces NaN or a negative number,\n an ER_GIS_INVALID_DATA\n (https://dev.mysql.com/doc/mysql-errors/8.3/en/server-error-reference\n .html#error_er_gis_invalid_data) error occurs.\n\nST_Distance() permits specifying the linear unit for the returned\ndistance value with an optional unit argument which ST_Distance()\nhandles as described in the introduction to this section.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/spatial-relation-functions-object-shapes.html +[ST_DISTANCE_SPHERE] +declaration=g1, g2 [, radius] +category=MBR Functions +description=Returns the minimum spherical distance between Point or MultiPoint\narguments on a sphere, in meters. (For general-purpose distance\ncalculations, see the ST_Distance() function.) The optional radius\nargument should be given in meters.\n\nIf both geometry parameters are valid Cartesian Point or MultiPoint\nvalues in SRID 0, the return value is shortest distance between the two\ngeometries on a sphere with the provided radius. If omitted, the\ndefault radius is 6,370,986 meters, Point X and Y coordinates are\ninterpreted as longitude and latitude, respectively, in degrees.\n\nIf both geometry parameters are valid Point or MultiPoint values in a\ngeographic spatial reference system (SRS), the return value is the\nshortest distance between the two geometries on a sphere with the\nprovided radius. If omitted, the default radius is equal to the mean\nradius, defined as (2a+b)/3, where a is the semi-major axis and b is\nthe semi-minor axis of the SRS.\n\nST_Distance_Sphere() handles its arguments as described in the\nintroduction to this section, with these exceptions:\n\no Supported geometry argument combinations are Point and Point, or\n Point and MultiPoint (in any argument order). If at least one of the\n geometries is neither Point nor MultiPoint, and its SRID is 0, an\n ER_NOT_IMPLEMENTED_FOR_CARTESIAN_SRS\n (https://dev.mysql.com/doc/mysql-errors/8.3/en/server-error-reference\n .html#error_er_not_implemented_for_cartesian_srs) error occurs. If at\n least one of the geometries is neither Point nor MultiPoint, and its\n SRID refers to a geographic SRS, an\n ER_NOT_IMPLEMENTED_FOR_GEOGRAPHIC_SRS\n (https://dev.mysql.com/doc/mysql-errors/8.3/en/server-error-reference\n .html#error_er_not_implemented_for_geographic_srs) error occurs. If\n any geometry refers to a projected SRS, an\n ER_NOT_IMPLEMENTED_FOR_PROJECTED_SRS\n (https://dev.mysql.com/doc/mysql-errors/8.3/en/server-error-reference\n .html#error_er_not_implemented_for_projected_srs) error occurs.\n\no If any argument has a longitude or latitude that is out of range, an\n error occurs:\n\n o If a longitude value is not in the range (−180, 180], an\n ER_GEOMETRY_PARAM_LONGITUDE_OUT_OF_RANGE\n (https://dev.mysql.com/doc/mysql-errors/8.3/en/server-error-referen\n ce.html#error_er_geometry_param_longitude_out_of_range) error\n occurs.\n\n o If a latitude value is not in the range [−90, 90], an\n ER_GEOMETRY_PARAM_LATITUDE_OUT_OF_RANGE\n (https://dev.mysql.com/doc/mysql-errors/8.3/en/server-error-referen\n ce.html#error_er_geometry_param_latitude_out_of_range) error\n ... +[ST_ENDPOINT] +declaration=ls +category=LineString Property Functions +description=Returns the Point that is the endpoint of the LineString value ls.\n\nST_EndPoint() handles its arguments as described in the introduction to\nthis section.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/gis-linestring-property-functions.html +[ST_ENVELOPE] +declaration=g +category=Geometry Property Functions +description=Returns the minimum bounding rectangle (MBR) for the geometry value g.\nThe result is returned as a Polygon value that is defined by the corner\npoints of the bounding box:\n\nPOLYGON((MINX MINY, MAXX MINY, MAXX MAXY, MINX MAXY, MINX MINY))\n\nmysql> SELECT ST_AsText(ST_Envelope(ST_GeomFromText('LineString(1 1,2 2)')));\n+----------------------------------------------------------------+\n| ST_AsText(ST_Envelope(ST_GeomFromText('LineString(1 1,2 2)'))) |\n+----------------------------------------------------------------+\n| POLYGON((1 1,2 1,2 2,1 2,1 1)) |\n+----------------------------------------------------------------+\n\nIf the argument is a point or a vertical or horizontal line segment,\nST_Envelope() returns the point or the line segment as its MBR rather\nthan returning an invalid polygon:\n\nmysql> SELECT ST_AsText(ST_Envelope(ST_GeomFromText('LineString(1 1,1 2)')));\n+----------------------------------------------------------------+\n| ST_AsText(ST_Envelope(ST_GeomFromText('LineString(1 1,1 2)'))) |\n+----------------------------------------------------------------+\n| LINESTRING(1 1,1 2) |\n+----------------------------------------------------------------+\n\nST_Envelope() handles its arguments as described in the introduction to\nthis section, with this exception:\n\no If the geometry has an SRID value for a geographic spatial reference\n system (SRS), an ER_NOT_IMPLEMENTED_FOR_GEOGRAPHIC_SRS\n (https://dev.mysql.com/doc/mysql-errors/8.3/en/server-error-reference\n .html#error_er_not_implemented_for_geographic_srs) error occurs.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/gis-general-property-functions.html +[ST_EQUALS] +declaration=g1, g2 +category=Geometry Relation Functions +description=Returns 1 or 0 to indicate whether g1 is spatially equal to g2.\n\nST_Equals() handles its arguments as described in the introduction to\nthis section, except that it does not return NULL for empty geometry\narguments.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/spatial-relation-functions-object-shapes.html +[ST_EXTERIORRING] +declaration=poly +category=Polygon Property Functions +description=Returns the exterior ring of the Polygon value poly as a LineString.\n\nST_ExteriorRing() handles its arguments as described in the\nintroduction to this section.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/gis-polygon-property-functions.html +[ST_FRECHETDISTANCE] +declaration=g1, g2 [, unit] +category=Geometry Relation Functions +description=Returns the discrete Fréchet distance between two geometries,\nreflecting how similar the geometries are. The result is a\ndouble-precision number measured in the length unit of the spatial\nreference system (SRS) of the geometry arguments, or in the length unit\nof the unit argument if that argument is given.\n\nThis function implements the discrete Fréchet distance, which means it\nis restricted to distances between the points of the geometries. For\nexample, given two LineString arguments, only the points explicitly\nmentioned in the geometries are considered. Points on the line segments\nbetween these points are not considered.\n\nST_FrechetDistance() handles its geometry arguments as described in the\nintroduction to this section, with these exceptions:\n\no The geometries may have a Cartesian or geographic SRS, but only\n LineString values are supported. If the arguments are in the same\n Cartesian or geographic SRS, but either is not a LineString, an\n ER_NOT_IMPLEMENTED_FOR_CARTESIAN_SRS\n (https://dev.mysql.com/doc/mysql-errors/8.3/en/server-error-reference\n .html#error_er_not_implemented_for_cartesian_srs) or\n ER_NOT_IMPLEMENTED_FOR_GEOGRAPHIC_SRS\n (https://dev.mysql.com/doc/mysql-errors/8.3/en/server-error-reference\n .html#error_er_not_implemented_for_geographic_srs) error occurs,\n depending on the SRS type.\n\nST_FrechetDistance() handles its optional unit argument as described in\nthe introduction to this section.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/spatial-relation-functions-object-shapes.html +[ST_GEOHASH] +declaration=longitude, latitude, max_length +category=MBR Functions +description=max_length)\n\nReturns a geohash string in the connection character set and collation.\n\nFor the first syntax, the longitude must be a number in the range\n[−180, 180], and the latitude must be a number in the range [−90,\n90]. For the second syntax, a POINT value is required, where the X and\nY coordinates are in the valid ranges for longitude and latitude,\nrespectively.\n\nThe resulting string is no longer than max_length characters, which has\nan upper limit of 100. The string might be shorter than max_length\ncharacters because the algorithm that creates the geohash value\ncontinues until it has created a string that is either an exact\nrepresentation of the location or max_length characters, whichever\ncomes first.\n\nST_GeoHash() handles its arguments as described in the introduction to\nthis section.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/spatial-geohash-functions.html +[ST_GEOMCOLLFROMTEXT] +declaration=wkt [, srid [, options]] +category=WKT Functions +description=ST_GeometryCollectionFromText(wkt [, srid [, options]]),\nST_GeomCollFromTxt(wkt [, srid [, options]])\n\nConstructs a GeometryCollection value using its WKT representation and\nSRID.\n\nThese functions handle their arguments as described in the introduction\nto this section.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/gis-wkt-functions.html +[ST_GEOMCOLLFROMWKB] +declaration=wkb [, srid [, options]] +category=WKB Functions +description=ST_GeometryCollectionFromWKB(wkb [, srid [, options]])\n\nConstructs a GeometryCollection value using its WKB representation and\nSRID.\n\nThese functions handle their arguments as described in the introduction\nto this section.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/gis-wkb-functions.html +[ST_GEOMETRYN] +declaration=gc, N +category=GeometryCollection Property Functions +description=Returns the N-th geometry in the GeometryCollection value gc.\nGeometries are numbered beginning with 1.\n\nST_GeometryN() handles its arguments as described in the introduction\nto this section.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/gis-geometrycollection-property-functions.html +[ST_GEOMETRYTYPE] +declaration=g +category=Geometry Property Functions +description=Returns a binary string indicating the name of the geometry type of\nwhich the geometry instance g is a member. The name corresponds to one\nof the instantiable Geometry subclasses.\n\nST_GeometryType() handles its arguments as described in the\nintroduction to this section.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/gis-general-property-functions.html +[ST_GEOMFROMGEOJSON] +declaration=str [, options [, srid]] +category=MBR Functions +description=Parses a string str representing a GeoJSON object and returns a\ngeometry.\n\nIf any argument is NULL, the return value is NULL. If any non-NULL\nargument is invalid, an error occurs.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/spatial-geojson-functions.html +[ST_GEOMFROMTEXT] +declaration=wkt [, srid [, options]] +category=WKT Functions +description=srid [, options]])\n\nConstructs a geometry value of any type using its WKT representation\nand SRID.\n\nThese functions handle their arguments as described in the introduction\nto this section.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/gis-wkt-functions.html +[ST_GEOMFROMWKB] +declaration=wkb [, srid [, options]] +category=WKB Functions +description=srid [, options]])\n\nConstructs a geometry value of any type using its WKB representation\nand SRID.\n\nThese functions handle their arguments as described in the introduction\nto this section.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/gis-wkb-functions.html +[ST_HAUSDORFFDISTANCE] +declaration=g1, g2 [, unit] +category=Geometry Relation Functions +description=Returns the discrete Hausdorff distance between two geometries,\nreflecting how similar the geometries are. The result is a\ndouble-precision number measured in the length unit of the spatial\nreference system (SRS) of the geometry arguments, or in the length unit\nof the unit argument if that argument is given.\n\nThis function implements the discrete Hausdorff distance, which means\nit is restricted to distances between the points of the geometries. For\nexample, given two LineString arguments, only the points explicitly\nmentioned in the geometries are considered. Points on the line segments\nbetween these points are not considered.\n\nST_HausdorffDistance() handles its geometry arguments as described in\nthe introduction to this section, with these exceptions:\n\no If the geometry arguments are in the same Cartesian or geographic\n SRS, but are not in a supported combination, an\n ER_NOT_IMPLEMENTED_FOR_CARTESIAN_SRS\n (https://dev.mysql.com/doc/mysql-errors/8.3/en/server-error-reference\n .html#error_er_not_implemented_for_cartesian_srs) or\n ER_NOT_IMPLEMENTED_FOR_GEOGRAPHIC_SRS\n (https://dev.mysql.com/doc/mysql-errors/8.3/en/server-error-reference\n .html#error_er_not_implemented_for_geographic_srs) error occurs,\n depending on the SRS type. These combinations are supported:\n\n o LineString and LineString\n\n o Point and MultiPoint\n\n o LineString and MultiLineString\n\n o MultiPoint and MultiPoint\n\n o MultiLineString and MultiLineString\n\nST_HausdorffDistance() handles its optional unit argument as described\nin the introduction to this section.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/spatial-relation-functions-object-shapes.html +[ST_INTERIORRINGN] +declaration=poly, N +category=Polygon Property Functions +description=Returns the N-th interior ring for the Polygon value poly as a\nLineString. Rings are numbered beginning with 1.\n\nST_InteriorRingN() handles its arguments as described in the\nintroduction to this section.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/gis-polygon-property-functions.html +[ST_INTERSECTION] +declaration=g1, g2 +category=GeometryCollection Property Functions +description=Returns a geometry that represents the point set intersection of the\ngeometry values g1 and g2. The result is in the same SRS as the\ngeometry arguments.\n\nST_Intersection() permits arguments in either a Cartesian or a\ngeographic SRS, and handles its arguments as described in the\nintroduction to this section.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/spatial-operator-functions.html +[ST_INTERSECTS] +declaration=g1, g2 +category=Geometry Relation Functions +description=Returns 1 or 0 to indicate whether g1 spatially intersects g2.\n\nST_Intersects() handles its arguments as described in the introduction\nto this section.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/spatial-relation-functions-object-shapes.html +[ST_ISCLOSED] +declaration=ls +category=LineString Property Functions +description=For a LineString value ls, ST_IsClosed() returns 1 if ls is closed\n(that is, its ST_StartPoint() and ST_EndPoint() values are the same).\n\nFor a MultiLineString value ls, ST_IsClosed() returns 1 if ls is closed\n(that is, the ST_StartPoint() and ST_EndPoint() values are the same for\neach LineString in ls).\n\nST_IsClosed() returns 0 if ls is not closed, and NULL if ls is NULL.\n\nST_IsClosed() handles its arguments as described in the introduction to\nthis section, with this exception:\n\no If the geometry has an SRID value for a geographic spatial reference\n system (SRS), an ER_NOT_IMPLEMENTED_FOR_GEOGRAPHIC_SRS\n (https://dev.mysql.com/doc/mysql-errors/8.3/en/server-error-reference\n .html#error_er_not_implemented_for_geographic_srs) error occurs.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/gis-linestring-property-functions.html +[ST_ISEMPTY] +declaration=g +category=Geometry Property Functions +description=This function is a placeholder that returns 1 for an empty geometry\ncollection value or 0 otherwise.\n\nThe only valid empty geometry is represented in the form of an empty\ngeometry collection value. MySQL does not support GIS EMPTY values such\nas POINT EMPTY.\n\nST_IsEmpty() handles its arguments as described in the introduction to\nthis section.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/gis-general-property-functions.html +[ST_ISSIMPLE] +declaration=g +category=Geometry Property Functions +description=Returns 1 if the geometry value g is simple according to the ISO SQL/MM\nPart 3: Spatial standard. ST_IsSimple() returns 0 if the argument is\nnot simple.\n\nThe descriptions of the instantiable geometric classes given under\nhttps://dev.mysql.com/doc/refman/8.3/en/opengis-geometry-model.html\ninclude the specific conditions that cause class instances to be\nclassified as not simple.\n\nST_IsSimple() handles its arguments as described in the introduction to\nthis section, with this exception:\n\no If the geometry has a geographic SRS with a longitude or latitude\n that is out of range, an error occurs:\n\n o If a longitude value is not in the range (−180, 180], an\n ER_GEOMETRY_PARAM_LONGITUDE_OUT_OF_RANGE\n (https://dev.mysql.com/doc/mysql-errors/8.3/en/server-error-referen\n ce.html#error_er_geometry_param_longitude_out_of_range) error\n occurs.\n\n o If a latitude value is not in the range [−90, 90], an\n ER_GEOMETRY_PARAM_LATITUDE_OUT_OF_RANGE\n (https://dev.mysql.com/doc/mysql-errors/8.3/en/server-error-referen\n ce.html#error_er_geometry_param_latitude_out_of_range) error\n occurs.\n\n Ranges shown are in degrees. The exact range limits deviate slightly\n due to floating-point arithmetic.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/gis-general-property-functions.html +[ST_ISVALID] +declaration=g +category=MBR Functions +description=Returns 1 if the argument is geometrically valid, 0 if the argument is\nnot geometrically valid. Geometry validity is defined by the OGC\nspecification.\n\nThe only valid empty geometry is represented in the form of an empty\ngeometry collection value. ST_IsValid() returns 1 in this case. MySQL\ndoes not support GIS EMPTY values such as POINT EMPTY.\n\nST_IsValid() handles its arguments as described in the introduction to\nthis section, with this exception:\n\no If the geometry has a geographic SRS with a longitude or latitude\n that is out of range, an error occurs:\n\n o If a longitude value is not in the range (−180, 180], an\n ER_GEOMETRY_PARAM_LONGITUDE_OUT_OF_RANGE\n (https://dev.mysql.com/doc/mysql-errors/8.3/en/server-error-referen\n ce.html#error_er_geometry_param_longitude_out_of_range) error\n occurs.\n\n o If a latitude value is not in the range [−90, 90], an\n ER_GEOMETRY_PARAM_LATITUDE_OUT_OF_RANGE\n (https://dev.mysql.com/doc/mysql-errors/8.3/en/server-error-referen\n ce.html#error_er_geometry_param_latitude_out_of_range) error\n occurs.\n\n Ranges shown are in degrees. If an SRS uses another unit, the range\n uses the corresponding values in its unit. The exact range limits\n deviate slightly due to floating-point arithmetic.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/spatial-convenience-functions.html +[ST_LATFROMGEOHASH] +declaration=geohash_str +category=MBR Functions +description=Returns the latitude from a geohash string value, as a double-precision\nnumber in the range [−90, 90].\n\nThe ST_LatFromGeoHash() decoding function reads no more than 433\ncharacters from the geohash_str argument. That represents the upper\nlimit on information in the internal representation of coordinate\nvalues. Characters past the 433rd are ignored, even if they are\notherwise illegal and produce an error.\n\nST_LatFromGeoHash() handles its arguments as described in the\nintroduction to this section.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/spatial-geohash-functions.html +[ST_LATITUDE] +declaration=p [, new_latitude_val] +category=Point Property Functions +description=With a single argument representing a valid Point object p that has a\ngeographic spatial reference system (SRS), ST_Latitude() returns the\nlatitude value of p as a double-precision number.\n\nWith the optional second argument representing a valid latitude value,\nST_Latitude() returns a Point object like the first argument with its\nlatitude equal to the second argument.\n\nST_Latitude() handles its arguments as described in the introduction to\nthis section, with the addition that if the Point object is valid but\ndoes not have a geographic SRS, an ER_SRS_NOT_GEOGRAPHIC\n(https://dev.mysql.com/doc/mysql-errors/8.3/en/server-error-reference.html\n#error_er_srs_not_geographic) error occurs.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/gis-point-property-functions.html +[ST_LENGTH] +declaration=ls [, unit] +category=LineString Property Functions +description=Returns a double-precision number indicating the length of the\nLineString or MultiLineString value ls in its associated spatial\nreference system. The length of a MultiLineString value is equal to the\nsum of the lengths of its elements.\n\nST_Length() computes a result as follows:\n\no If the geometry is a valid LineString in a Cartesian SRS, the return\n value is the Cartesian length of the geometry.\n\no If the geometry is a valid MultiLineString in a Cartesian SRS, the\n return value is the sum of the Cartesian lengths of its elements.\n\no If the geometry is a valid LineString in a geographic SRS, the return\n value is the geodetic length of the geometry in that SRS, in meters.\n\no If the geometry is a valid MultiLineString in a geographic SRS, the\n return value is the sum of the geodetic lengths of its elements in\n that SRS, in meters.\n\nST_Length() handles its arguments as described in the introduction to\nthis section, with these exceptions:\n\no If the geometry is not a LineString or MultiLineString, the return\n value is NULL.\n\no If the geometry is geometrically invalid, either the result is an\n undefined length (that is, it can be any number), or an error occurs.\n\no If the length computation result is +inf, an ER_DATA_OUT_OF_RANGE\n (https://dev.mysql.com/doc/mysql-errors/8.3/en/server-error-reference\n .html#error_er_data_out_of_range) error occurs.\n\no If the geometry has a geographic SRS with a longitude or latitude\n that is out of range, an error occurs:\n\n o If a longitude value is not in the range (−180, 180], an\n ER_GEOMETRY_PARAM_LONGITUDE_OUT_OF_RANGE\n (https://dev.mysql.com/doc/mysql-errors/8.3/en/server-error-referen\n ce.html#error_er_geometry_param_longitude_out_of_range) error\n occurs.\n\n o If a latitude value is not in the range [−90, 90], an\n ER_GEOMETRY_PARAM_LATITUDE_OUT_OF_RANGE\n (https://dev.mysql.com/doc/mysql-errors/8.3/en/server-error-referen\n ce.html#error_er_geometry_param_latitude_out_of_range) error\n occurs.\n\n Ranges shown are in degrees. The exact range limits deviate slightly\n due to floating-point arithmetic.\n ... +[ST_LINEFROMTEXT] +declaration=wkt [, srid [, options]] +category=WKT Functions +description=srid [, options]])\n\nConstructs a LineString value using its WKT representation and SRID.\n\nThese functions handle their arguments as described in the introduction\nto this section.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/gis-wkt-functions.html +[ST_LINEFROMWKB] +declaration=wkb [, srid [, options]] +category=WKB Functions +description=srid [, options]])\n\nConstructs a LineString value using its WKB representation and SRID.\n\nThese functions handle their arguments as described in the introduction\nto this section.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/gis-wkb-functions.html +[ST_LINEINTERPOLATEPOINT] +declaration=ls, fractional_distance +category=GeometryCollection Property Functions +description=This function takes a LineString geometry and a fractional distance in\nthe range [0.0, 1.0] and returns the Point along the LineString at the\ngiven fraction of the distance from its start point to its endpoint. It\ncan be used to answer questions such as which Point lies halfway along\nthe road described by the geometry argument.\n\nThe function is implemented for LineString geometries in all spatial\nreference systems, both Cartesian and geographic.\n\nIf the fractional_distance argument is 1.0, the result may not be\nexactly the last point of the LineString argument but a point close to\nit due to numerical inaccuracies in approximate-value computations.\n\nA related function, ST_LineInterpolatePoints(), takes similar arguments\nbut returns a MultiPoint consisting of Point values along the\nLineString at each fraction of the distance from its start point to its\nendpoint. For examples of both functions, see the\nST_LineInterpolatePoints() description.\n\nST_LineInterpolatePoint() handles its arguments as described in the\nintroduction to this section, with these exceptions:\n\no If the geometry argument is not a LineString, an\n ER_UNEXPECTED_GEOMETRY_TYPE\n (https://dev.mysql.com/doc/mysql-errors/8.3/en/server-error-reference\n .html#error_er_unexpected_geometry_type) error occurs.\n\no If the fractional distance argument is outside the range [0.0, 1.0],\n an ER_DATA_OUT_OF_RANGE\n (https://dev.mysql.com/doc/mysql-errors/8.3/en/server-error-reference\n .html#error_er_data_out_of_range) error occurs.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/spatial-operator-functions.html +[ST_LINEINTERPOLATEPOINTS] +declaration=ls, fractional_distance +category=GeometryCollection Property Functions +description=This function takes a LineString geometry and a fractional distance in\nthe range (0.0, 1.0] and returns the MultiPoint consisting of the\nLineString start point, plus Point values along the LineString at each\nfraction of the distance from its start point to its endpoint. It can\nbe used to answer questions such as which Point values lie every 10% of\nthe way along the road described by the geometry argument.\n\nThe function is implemented for LineString geometries in all spatial\nreference systems, both Cartesian and geographic.\n\nIf the fractional_distance argument divides 1.0 with zero remainder the\nresult may not contain the last point of the LineString argument but a\npoint close to it due to numerical inaccuracies in approximate-value\ncomputations.\n\nA related function, ST_LineInterpolatePoint(), takes similar arguments\nbut returns the Point along the LineString at the given fraction of the\ndistance from its start point to its endpoint.\n\nST_LineInterpolatePoints() handles its arguments as described in the\nintroduction to this section, with these exceptions:\n\no If the geometry argument is not a LineString, an\n ER_UNEXPECTED_GEOMETRY_TYPE\n (https://dev.mysql.com/doc/mysql-errors/8.3/en/server-error-reference\n .html#error_er_unexpected_geometry_type) error occurs.\n\no If the fractional distance argument is outside the range [0.0, 1.0],\n an ER_DATA_OUT_OF_RANGE\n (https://dev.mysql.com/doc/mysql-errors/8.3/en/server-error-reference\n .html#error_er_data_out_of_range) error occurs.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/spatial-operator-functions.html +[ST_LONGFROMGEOHASH] +declaration=geohash_str +category=MBR Functions +description=Returns the longitude from a geohash string value, as a\ndouble-precision number in the range [−180, 180].\n\nThe remarks in the description of ST_LatFromGeoHash() regarding the\nmaximum number of characters processed from the geohash_str argument\nalso apply to ST_LongFromGeoHash().\n\nST_LongFromGeoHash() handles its arguments as described in the\nintroduction to this section.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/spatial-geohash-functions.html +[ST_LONGITUDE] +declaration=p [, new_longitude_val] +category=Point Property Functions +description=With a single argument representing a valid Point object p that has a\ngeographic spatial reference system (SRS), ST_Longitude() returns the\nlongitude value of p as a double-precision number.\n\nWith the optional second argument representing a valid longitude value,\nST_Longitude() returns a Point object like the first argument with its\nlongitude equal to the second argument.\n\nST_Longitude() handles its arguments as described in the introduction\nto this section, with the addition that if the Point object is valid\nbut does not have a geographic SRS, an ER_SRS_NOT_GEOGRAPHIC\n(https://dev.mysql.com/doc/mysql-errors/8.3/en/server-error-reference.html\n#error_er_srs_not_geographic) error occurs.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/gis-point-property-functions.html +[ST_MAKEENVELOPE] +declaration=pt1, pt2 +category=MBR Functions +description=Returns the rectangle that forms the envelope around two points, as a\nPoint, LineString, or Polygon.\n\nCalculations are done using the Cartesian coordinate system rather than\non a sphere, spheroid, or on earth.\n\nGiven two points pt1 and pt2, ST_MakeEnvelope() creates the result\ngeometry on an abstract plane like this:\n\no If pt1 and pt2 are equal, the result is the point pt1.\n\no Otherwise, if (pt1, pt2) is a vertical or horizontal line segment,\n the result is the line segment (pt1, pt2).\n\no Otherwise, the result is a polygon using pt1 and pt2 as diagonal\n points.\n\nThe result geometry has an SRID of 0.\n\nST_MakeEnvelope() handles its arguments as described in the\nintroduction to this section, with these exceptions:\n\no If the arguments are not Point values, an ER_WRONG_ARGUMENTS\n (https://dev.mysql.com/doc/mysql-errors/8.3/en/server-error-reference\n .html#error_er_wrong_arguments) error occurs.\n\no An ER_GIS_INVALID_DATA\n (https://dev.mysql.com/doc/mysql-errors/8.3/en/server-error-reference\n .html#error_er_gis_invalid_data) error occurs for the additional\n condition that any coordinate value of the two points is infinite or\n NaN.\n\no If any geometry has an SRID value for a geographic spatial reference\n system (SRS), an ER_NOT_IMPLEMENTED_FOR_GEOGRAPHIC_SRS\n (https://dev.mysql.com/doc/mysql-errors/8.3/en/server-error-reference\n .html#error_er_not_implemented_for_geographic_srs) error occurs.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/spatial-convenience-functions.html +[ST_MLINEFROMTEXT] +declaration=wkt [, srid [, options]] +category=WKT Functions +description=ST_MultiLineStringFromText(wkt [, srid [, options]])\n\nConstructs a MultiLineString value using its WKT representation and\nSRID.\n\nThese functions handle their arguments as described in the introduction\nto this section.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/gis-wkt-functions.html +[ST_MLINEFROMWKB] +declaration=wkb [, srid [, options]] +category=WKB Functions +description=ST_MultiLineStringFromWKB(wkb [, srid [, options]])\n\nConstructs a MultiLineString value using its WKB representation and\nSRID.\n\nThese functions handle their arguments as described in the introduction\nto this section.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/gis-wkb-functions.html +[ST_MPOINTFROMTEXT] +declaration=wkt [, srid [, options]] +category=WKT Functions +description=[, srid [, options]])\n\nConstructs a MultiPoint value using its WKT representation and SRID.\n\nThese functions handle their arguments as described in the introduction\nto this section.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/gis-wkt-functions.html +[ST_MPOINTFROMWKB] +declaration=wkb [, srid [, options]] +category=WKB Functions +description=srid [, options]])\n\nConstructs a MultiPoint value using its WKB representation and SRID.\n\nThese functions handle their arguments as described in the introduction\nto this section.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/gis-wkb-functions.html +[ST_MPOLYFROMTEXT] +declaration=wkt [, srid [, options]] +category=WKT Functions +description=[, srid [, options]])\n\nConstructs a MultiPolygon value using its WKT representation and SRID.\n\nThese functions handle their arguments as described in the introduction\nto this section.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/gis-wkt-functions.html +[ST_MPOLYFROMWKB] +declaration=wkb [, srid [, options]] +category=WKB Functions +description=[, srid [, options]])\n\nConstructs a MultiPolygon value using its WKB representation and SRID.\n\nThese functions handle their arguments as described in the introduction\nto this section.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/gis-wkb-functions.html +[ST_NUMGEOMETRIES] +declaration=gc +category=GeometryCollection Property Functions +description=Returns the number of geometries in the GeometryCollection value gc.\n\nST_NumGeometries() handles its arguments as described in the\nintroduction to this section.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/gis-geometrycollection-property-functions.html +[ST_NUMINTERIORRINGS] +declaration=poly +category=Polygon Property Functions +description=Returns the number of interior rings in the Polygon value poly.\n\nST_NumInteriorRing() and ST_NuminteriorRings() handle their arguments\nas described in the introduction to this section.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/gis-polygon-property-functions.html +[ST_NUMPOINTS] +declaration=ls +category=LineString Property Functions +description=Returns the number of Point objects in the LineString value ls.\n\nST_NumPoints() handles its arguments as described in the introduction\nto this section.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/gis-linestring-property-functions.html +[ST_OVERLAPS] +declaration=g1, g2 +category=Geometry Relation Functions +description=Two geometries spatially overlap if they intersect and their\nintersection results in a geometry of the same dimension but not equal\nto either of the given geometries.\n\nThis function returns 1 or 0 to indicate whether g1 spatially overlaps\ng2.\n\nST_Overlaps() handles its arguments as described in the introduction to\nthis section except that the return value is NULL for the additional\ncondition that the dimensions of the two geometries are not equal.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/spatial-relation-functions-object-shapes.html +[ST_POINTATDISTANCE] +declaration=ls, distance +category=GeometryCollection Property Functions +description=This function takes a LineString geometry and a distance in the range\n[0.0, ST_Length(ls)] measured in the unit of the spatial reference\nsystem (SRS) of the LineString, and returns the Point along the\nLineString at that distance from its start point. It can be used to\nanswer questions such as which Point value is 400 meters from the start\nof the road described by the geometry argument.\n\nThe function is implemented for LineString geometries in all spatial\nreference systems, both Cartesian and geographic.\n\nST_PointAtDistance() handles its arguments as described in the\nintroduction to this section, with these exceptions:\n\no If the geometry argument is not a LineString, an\n ER_UNEXPECTED_GEOMETRY_TYPE\n (https://dev.mysql.com/doc/mysql-errors/8.3/en/server-error-reference\n .html#error_er_unexpected_geometry_type) error occurs.\n\no If the fractional distance argument is outside the range [0.0,\n ST_Length(ls)], an ER_DATA_OUT_OF_RANGE\n (https://dev.mysql.com/doc/mysql-errors/8.3/en/server-error-reference\n .html#error_er_data_out_of_range) error occurs.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/spatial-operator-functions.html +[ST_POINTFROMGEOHASH] +declaration=geohash_str, srid +category=MBR Functions +description=Returns a POINT value containing the decoded geohash value, given a\ngeohash string value.\n\nThe X and Y coordinates of the point are the longitude in the range\n[−180, 180] and the latitude in the range [−90, 90], respectively.\n\nThe srid argument is an 32-bit unsigned integer.\n\nThe remarks in the description of ST_LatFromGeoHash() regarding the\nmaximum number of characters processed from the geohash_str argument\nalso apply to ST_PointFromGeoHash().\n\nST_PointFromGeoHash() handles its arguments as described in the\nintroduction to this section.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/spatial-geohash-functions.html +[ST_POINTFROMTEXT] +declaration=wkt [, srid [, options]] +category=WKT Functions +description=Constructs a Point value using its WKT representation and SRID.\n\nST_PointFromText() handles its arguments as described in the\nintroduction to this section.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/gis-wkt-functions.html +[ST_POINTFROMWKB] +declaration=wkb [, srid [, options]] +category=WKB Functions +description=Constructs a Point value using its WKB representation and SRID.\n\nST_PointFromWKB() handles its arguments as described in the\nintroduction to this section.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/gis-wkb-functions.html +[ST_POINTN] +declaration=ls, N +category=LineString Property Functions +description=Returns the N-th Point in the Linestring value ls. Points are numbered\nbeginning with 1.\n\nST_PointN() handles its arguments as described in the introduction to\nthis section.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/gis-linestring-property-functions.html +[ST_POLYFROMTEXT] +declaration=wkt [, srid [, options]] +category=WKT Functions +description=srid [, options]])\n\nConstructs a Polygon value using its WKT representation and SRID.\n\nThese functions handle their arguments as described in the introduction\nto this section.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/gis-wkt-functions.html +[ST_POLYFROMWKB] +declaration=wkb [, srid [, options]] +category=WKB Functions +description=[, options]])\n\nConstructs a Polygon value using its WKB representation and SRID.\n\nThese functions handle their arguments as described in the introduction\nto this section.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/gis-wkb-functions.html +[ST_SIMPLIFY] +declaration=g, max_distance +category=MBR Functions +description=Simplifies a geometry using the Douglas-Peucker algorithm and returns a\nsimplified value of the same type.\n\nThe geometry may be any geometry type, although the Douglas-Peucker\nalgorithm may not actually process every type. A geometry collection is\nprocessed by giving its components one by one to the simplification\nalgorithm, and the returned geometries are put into a geometry\ncollection as result.\n\nThe max_distance argument is the distance (in units of the input\ncoordinates) of a vertex to other segments to be removed. Vertices\nwithin this distance of the simplified linestring are removed.\n\nAccording to Boost.Geometry, geometries might become invalid as a\nresult of the simplification process, and the process might create\nself-intersections. To check the validity of the result, pass it to\nST_IsValid().\n\nST_Simplify() handles its arguments as described in the introduction to\nthis section, with this exception:\n\no If the max_distance argument is not positive, or is NaN, an\n ER_WRONG_ARGUMENTS\n (https://dev.mysql.com/doc/mysql-errors/8.3/en/server-error-reference\n .html#error_er_wrong_arguments) error occurs.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/spatial-convenience-functions.html +[ST_SRID] +declaration=g [, srid] +category=Geometry Property Functions +description=With a single argument representing a valid geometry object g,\nST_SRID() returns an integer indicating the ID of the spatial reference\nsystem (SRS) associated with g.\n\nWith the optional second argument representing a valid SRID value,\nST_SRID() returns an object with the same type as its first argument\nwith an SRID value equal to the second argument. This only sets the\nSRID value of the object; it does not perform any transformation of\ncoordinate values.\n\nST_SRID() handles its arguments as described in the introduction to\nthis section, with this exception:\n\no For the single-argument syntax, ST_SRID() returns the geometry SRID\n even if it refers to an undefined SRS. An ER_SRS_NOT_FOUND\n (https://dev.mysql.com/doc/mysql-errors/8.3/en/server-error-reference\n .html#error_er_srs_not_found) error does not occur.\n\nST_SRID(g, target_srid) and ST_Transform(g, target_srid) differ as\nfollows:\n\no ST_SRID() changes the geometry SRID value without transforming its\n coordinates.\n\no ST_Transform() transforms the geometry coordinates in addition to\n changing its SRID value.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/gis-general-property-functions.html +[ST_STARTPOINT] +declaration=ls +category=LineString Property Functions +description=Returns the Point that is the start point of the LineString value ls.\n\nST_StartPoint() handles its arguments as described in the introduction\nto this section.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/gis-linestring-property-functions.html +[ST_SWAPXY] +declaration=g +category=WKB Functions +description=Accepts an argument in internal geometry format, swaps the X and Y\nvalues of each coordinate pair within the geometry, and returns the\nresult.\n\nST_SwapXY() handles its arguments as described in the introduction to\nthis section.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/gis-format-conversion-functions.html +[ST_SYMDIFFERENCE] +declaration=g1, g2 +category=GeometryCollection Property Functions +description=Returns a geometry that represents the point set symmetric difference\nof the geometry values g1 and g2, which is defined as:\n\ng1 symdifference g2 := (g1 union g2) difference (g1 intersection g2)\n\nOr, in function call notation:\n\nST_SymDifference(g1, g2) = ST_Difference(ST_Union(g1, g2), ST_Intersection(g1, g2))\n\nThe result is in the same SRS as the geometry arguments.\n\nST_SymDifference() permits arguments in either a Cartesian or a\ngeographic SRS, and handles its arguments as described in the\nintroduction to this section.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/spatial-operator-functions.html +[ST_TOUCHES] +declaration=g1, g2 +category=Geometry Relation Functions +description=Two geometries spatially touch if their interiors do not intersect, but\nthe boundary of one of the geometries intersects either the boundary or\nthe interior of the other.\n\nThis function returns 1 or 0 to indicate whether g1 spatially touches\ng2.\n\nST_Touches() handles its arguments as described in the introduction to\nthis section except that the return value is NULL for the additional\ncondition that both geometries are of dimension 0 (Point or\nMultiPoint).\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/spatial-relation-functions-object-shapes.html +[ST_TRANSFORM] +declaration=g, target_srid +category=GeometryCollection Property Functions +description=Transforms a geometry from one spatial reference system (SRS) to\nanother. The return value is a geometry of the same type as the input\ngeometry with all coordinates transformed to the target SRID,\ntarget_srid. MySQL supports all SRSs defined by EPSG except for those\nlisted here:\n\no EPSG 1042 Krovak Modified\n\no EPSG 1043 Krovak Modified (North Orientated)\n\no EPSG 9816 Tunisia Mining Grid\n\no EPSG 9826 Lambert Conic Conformal (West Orientated)\n\nST_Transform() handles its arguments as described in the introduction\nto this section, with these exceptions:\n\no Geometry arguments that have an SRID value for a geographic SRS do\n not produce an error.\n\no If the geometry or target SRID argument has an SRID value that refers\n to an undefined spatial reference system (SRS), an ER_SRS_NOT_FOUND\n (https://dev.mysql.com/doc/mysql-errors/8.3/en/server-error-reference\n .html#error_er_srs_not_found) error occurs.\n\no If the geometry is in an SRS that ST_Transform() cannot transform\n from, an ER_TRANSFORM_SOURCE_SRS_NOT_SUPPORTED\n (https://dev.mysql.com/doc/mysql-errors/8.3/en/server-error-reference\n .html#error_er_transform_source_srs_not_supported) error occurs.\n\no If the target SRID is in an SRS that ST_Transform() cannot transform\n to, an ER_TRANSFORM_TARGET_SRS_NOT_SUPPORTED\n (https://dev.mysql.com/doc/mysql-errors/8.3/en/server-error-reference\n .html#error_er_transform_target_srs_not_supported) error occurs.\n\no If the geometry is in an SRS that is not WGS 84 and has no TOWGS84\n clause, an ER_TRANSFORM_SOURCE_SRS_MISSING_TOWGS84\n (https://dev.mysql.com/doc/mysql-errors/8.3/en/server-error-reference\n .html#error_er_transform_source_srs_missing_towgs84) error occurs.\n\no If the target SRID is in an SRS that is not WGS 84 and has no TOWGS84\n clause, an ER_TRANSFORM_TARGET_SRS_MISSING_TOWGS84\n (https://dev.mysql.com/doc/mysql-errors/8.3/en/server-error-reference\n .html#error_er_transform_target_srs_missing_towgs84) error occurs.\n\nST_SRID(g, target_srid) and ST_Transform(g, target_srid) differ as\nfollows:\n\no ST_SRID() changes the geometry SRID value without transforming its\n coordinates.\n ... +[ST_UNION] +declaration=g1, g2 +category=GeometryCollection Property Functions +description=Returns a geometry that represents the point set union of the geometry\nvalues g1 and g2. The result is in the same SRS as the geometry\narguments.\n\nST_Union() permits arguments in either a Cartesian or a geographic SRS,\nand handles its arguments as described in the introduction to this\nsection.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/spatial-operator-functions.html +[ST_VALIDATE] +declaration=g +category=MBR Functions +description=Validates a geometry according to the OGC specification. A geometry can\nbe syntactically well-formed (WKB value plus SRID) but geometrically\ninvalid. For example, this polygon is geometrically invalid: POLYGON((0\n0, 0 0, 0 0, 0 0, 0 0))\n\nST_Validate() returns the geometry if it is syntactically well-formed\nand is geometrically valid, NULL if the argument is not syntactically\nwell-formed or is not geometrically valid or is NULL.\n\nST_Validate() can be used to filter out invalid geometry data, although\nat a cost. For applications that require more precise results not\ntainted by invalid data, this penalty may be worthwhile.\n\nIf the geometry argument is valid, it is returned as is, except that if\nan input Polygon or MultiPolygon has clockwise rings, those rings are\nreversed before checking for validity. If the geometry is valid, the\nvalue with the reversed rings is returned.\n\nThe only valid empty geometry is represented in the form of an empty\ngeometry collection value. ST_Validate() returns it directly without\nfurther checks in this case.\n\nST_Validate() handles its arguments as described in the introduction to\nthis section, with the exceptions listed here:\n\no If the geometry has a geographic SRS with a longitude or latitude\n that is out of range, an error occurs:\n\n o If a longitude value is not in the range (−180, 180], an\n ER_GEOMETRY_PARAM_LONGITUDE_OUT_OF_RANGE\n (https://dev.mysql.com/doc/mysql-errors/8.3/en/server-error-referen\n ce.html#error_er_geometry_param_longitude_out_of_range) error\n occurs.\n\n o If a latitude value is not in the range [−90, 90], an\n ER_GEOMETRY_PARAM_LATITUDE_OUT_OF_RANGE\n (https://dev.mysql.com/doc/mysql-errors/8.3/en/server-error-referen\n ce.html#error_er_geometry_param_latitude_out_of_range) error\n occurs.\n\n Ranges shown are in degrees. The exact range limits deviate slightly\n due to floating-point arithmetic.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/spatial-convenience-functions.html +[ST_WITHIN] +declaration=g1, g2 +category=Geometry Relation Functions +description=Returns 1 or 0 to indicate whether g1 is spatially within g2. This\ntests the opposite relationship as ST_Contains().\n\nST_Within() handles its arguments as described in the introduction to\nthis section.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/spatial-relation-functions-object-shapes.html +[ST_X] +declaration=p [, new_x_val] +category=Point Property Functions +description=With a single argument representing a valid Point object p, ST_X()\nreturns the X-coordinate value of p as a double-precision number. The X\ncoordinate is considered to refer to the axis that appears first in the\nPoint spatial reference system (SRS) definition.\n\nWith the optional second argument, ST_X() returns a Point object like\nthe first argument with its X coordinate equal to the second argument.\nIf the Point object has a geographic SRS, the second argument must be\nin the proper range for longitude or latitude values.\n\nST_X() handles its arguments as described in the introduction to this\nsection.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/gis-point-property-functions.html +[ST_Y] +declaration=p [, new_y_val] +category=Point Property Functions +description=With a single argument representing a valid Point object p, ST_Y()\nreturns the Y-coordinate value of p as a double-precision number.The Y\ncoordinate is considered to refer to the axis that appears second in\nthe Point spatial reference system (SRS) definition.\n\nWith the optional second argument, ST_Y() returns a Point object like\nthe first argument with its Y coordinate equal to the second argument.\nIf the Point object has a geographic SRS, the second argument must be\nin the proper range for longitude or latitude values.\n\nST_Y() handles its arguments as described in the introduction to this\nsection.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/gis-point-property-functions.html +[SUBDATE] +declaration=date,INTERVAL expr unit +category=Date and Time Functions +description=When invoked with the INTERVAL form of the second argument, SUBDATE()\nis a synonym for DATE_SUB(). For information on the INTERVAL unit\nargument, see the discussion for DATE_ADD().\n\nmysql> SELECT DATE_SUB('2008-01-02', INTERVAL 31 DAY);\n -> '2007-12-02'\nmysql> SELECT SUBDATE('2008-01-02', INTERVAL 31 DAY);\n -> '2007-12-02'\n\nThe second form enables the use of an integer value for days. In such\ncases, it is interpreted as the number of days to be subtracted from\nthe date or datetime expression expr.\n\nmysql> SELECT SUBDATE('2008-01-02 12:00:00', 31);\n -> '2007-12-02 12:00:00'\n\nThis function returns NULL if any of its arguments are NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/date-and-time-functions.html +[SUBSTR] +declaration=str,pos +category=String Functions +description=FROM pos FOR len)\n\nSUBSTR() is a synonym for SUBSTRING().\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/string-functions.html +[SUBSTRING] +declaration=str,pos +category=String Functions +description=SUBSTRING(str FROM pos FOR len)\n\nThe forms without a len argument return a substring from string str\nstarting at position pos. The forms with a len argument return a\nsubstring len characters long from string str, starting at position\npos. The forms that use FROM are standard SQL syntax. It is also\npossible to use a negative value for pos. In this case, the beginning\nof the substring is pos characters from the end of the string, rather\nthan the beginning. A negative value may be used for pos in any of the\nforms of this function. A value of 0 for pos returns an empty string.\n\nFor all forms of SUBSTRING(), the position of the first character in\nthe string from which the substring is to be extracted is reckoned as\n1.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/string-functions.html +[SUBSTRING_INDEX] +declaration=str,delim,count +category=String Functions +description=Returns the substring from string str before count occurrences of the\ndelimiter delim. If count is positive, everything to the left of the\nfinal delimiter (counting from the left) is returned. If count is\nnegative, everything to the right of the final delimiter (counting from\nthe right) is returned. SUBSTRING_INDEX() performs a case-sensitive\nmatch when searching for delim.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/string-functions.html +[SUBTIME] +declaration=expr1,expr2 +category=Date and Time Functions +description=SUBTIME() returns expr1 − expr2 expressed as a value in the same\nformat as expr1. expr1 is a time or datetime expression, and expr2 is a\ntime expression.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/date-and-time-functions.html +[SUM] +declaration=[DISTINCT] expr +category=Aggregate Functions and Modifiers +description=Returns the sum of expr. If the return set has no rows, SUM() returns\nNULL. The DISTINCT keyword can be used to sum only the distinct values\nof expr.\n\nIf there are no matching rows, or if expr is NULL, SUM() returns NULL.\n\nThis function executes as a window function if over_clause is present.\nover_clause is as described in\nhttps://dev.mysql.com/doc/refman/8.3/en/window-functions-usage.html; it\ncannot be used with DISTINCT.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/aggregate-functions.html +[SYSDATE] +declaration=[fsp] +category=Date and Time Functions +description=Returns the current date and time as a value in 'YYYY-MM-DD hh:mm:ss'\nor YYYYMMDDhhmmss format, depending on whether the function is used in\nstring or numeric context.\n\nIf the fsp argument is given to specify a fractional seconds precision\nfrom 0 to 6, the return value includes a fractional seconds part of\nthat many digits.\n\nSYSDATE() returns the time at which it executes. This differs from the\nbehavior for NOW(), which returns a constant time that indicates the\ntime at which the statement began to execute. (Within a stored function\nor trigger, NOW() returns the time at which the function or triggering\nstatement began to execute.)\n\nmysql> SELECT NOW(), SLEEP(2), NOW();\n+---------------------+----------+---------------------+\n| NOW() | SLEEP(2) | NOW() |\n+---------------------+----------+---------------------+\n| 2006-04-12 13:47:36 | 0 | 2006-04-12 13:47:36 |\n+---------------------+----------+---------------------+\n\nmysql> SELECT SYSDATE(), SLEEP(2), SYSDATE();\n+---------------------+----------+---------------------+\n| SYSDATE() | SLEEP(2) | SYSDATE() |\n+---------------------+----------+---------------------+\n| 2006-04-12 13:47:44 | 0 | 2006-04-12 13:47:46 |\n+---------------------+----------+---------------------+\n\nIn addition, the SET TIMESTAMP statement affects the value returned by\nNOW() but not by SYSDATE(). This means that timestamp settings in the\nbinary log have no effect on invocations of SYSDATE().\n\nBecause SYSDATE() can return different values even within the same\nstatement, and is not affected by SET TIMESTAMP, it is nondeterministic\nand therefore unsafe for replication if statement-based binary logging\nis used. If that is a problem, you can use row-based logging.\n\nAlternatively, you can use the --sysdate-is-now option to cause\nSYSDATE() to be an alias for NOW(). This works if the option is used on\nboth the replication source server and the replica.\n\nThe nondeterministic nature of SYSDATE() also means that indexes cannot\nbe used for evaluating expressions that refer to it.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/date-and-time-functions.html +[SYSTEM_USER] +declaration= +category=Information Functions +description=SYSTEM_USER() is a synonym for USER().\n\n*Note*:\n\nThe SYSTEM_USER() function is distinct from the SYSTEM_USER privilege.\nThe former returns the current MySQL account name. The latter\ndistinguishes the system user and regular user account categories (see\nhttps://dev.mysql.com/doc/refman/8.3/en/account-categories.html).\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/information-functions.html +[TAN] +declaration=X +category=Numeric Functions +description=Returns the tangent of X, where X is given in radians. Returns NULL if\nX is NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/mathematical-functions.html +[TEXT] +declaration=M +category=Data Types +description=A TEXT column with a maximum length of 65,535 (216 − 1) characters.\nThe effective maximum length is less if the value contains multibyte\ncharacters. Each TEXT value is stored using a 2-byte length prefix that\nindicates the number of bytes in the value.\n\nAn optional length M can be given for this type. If this is done, MySQL\ncreates the column as the smallest TEXT type large enough to hold\nvalues M characters long.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/string-type-syntax.html +[TIME] +declaration=fsp +category=Data Types +description=A time. The range is '-838:59:59.000000' to '838:59:59.000000'. MySQL\ndisplays TIME values in 'hh:mm:ss[.fraction]' format, but permits\nassignment of values to TIME columns using either strings or numbers.\n\nAn optional fsp value in the range from 0 to 6 may be given to specify\nfractional seconds precision. A value of 0 signifies that there is no\nfractional part. If omitted, the default precision is 0.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/date-and-time-type-syntax.html +[TIMEDIFF] +declaration=expr1,expr2 +category=Date and Time Functions +description=TIMEDIFF() returns expr1 − expr2 expressed as a time value. expr1 and\nexpr2 are strings which are converted to TIME or DATETIME expressions;\nthese must be of the same type following conversion. Returns NULL if\nexpr1 or expr2 is NULL.\n\nThe result returned by TIMEDIFF() is limited to the range allowed for\nTIME values. Alternatively, you can use either of the functions\nTIMESTAMPDIFF() and UNIX_TIMESTAMP(), both of which return integers.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/date-and-time-functions.html +[TIMESTAMP] +declaration=fsp +category=Data Types +description=A timestamp. The range is '1970-01-01 00:00:01.000000' UTC to\n'2038-01-19 03:14:07.499999' UTC. TIMESTAMP values are stored as the\nnumber of seconds since the epoch ('1970-01-01 00:00:00' UTC). A\nTIMESTAMP cannot represent the value '1970-01-01 00:00:00' because that\nis equivalent to 0 seconds from the epoch and the value 0 is reserved\nfor representing '0000-00-00 00:00:00', the "zero" TIMESTAMP value.\n\nAn optional fsp value in the range from 0 to 6 may be given to specify\nfractional seconds precision. A value of 0 signifies that there is no\nfractional part. If omitted, the default precision is 0.\n\nThe way the server handles TIMESTAMP definitions depends on the value\nof the explicit_defaults_for_timestamp system variable (see\nhttps://dev.mysql.com/doc/refman/8.3/en/server-system-variables.html).\n\nIf explicit_defaults_for_timestamp is enabled, there is no automatic\nassignment of the DEFAULT CURRENT_TIMESTAMP or ON UPDATE\nCURRENT_TIMESTAMP attributes to any TIMESTAMP column. They must be\nincluded explicitly in the column definition. Also, any TIMESTAMP not\nexplicitly declared as NOT NULL permits NULL values.\n\nIf explicit_defaults_for_timestamp is disabled, the server handles\nTIMESTAMP as follows:\n\nUnless specified otherwise, the first TIMESTAMP column in a table is\ndefined to be automatically set to the date and time of the most recent\nmodification if not explicitly assigned a value. This makes TIMESTAMP\nuseful for recording the timestamp of an INSERT or UPDATE operation.\nYou can also set any TIMESTAMP column to the current date and time by\nassigning it a NULL value, unless it has been defined with the NULL\nattribute to permit NULL values.\n\nAutomatic initialization and updating to the current date and time can\nbe specified using DEFAULT CURRENT_TIMESTAMP and ON UPDATE\nCURRENT_TIMESTAMP column definition clauses. By default, the first\nTIMESTAMP column has these properties, as previously noted. However,\nany TIMESTAMP column in a table can be defined to have these\nproperties.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/date-and-time-type-syntax.html +[TIMESTAMPADD] +declaration=unit,interval,datetime_expr +category=Date and Time Functions +description=Adds the integer expression interval to the date or datetime expression\ndatetime_expr. The unit for interval is given by the unit argument,\nwhich should be one of the following values: MICROSECOND\n(microseconds), SECOND, MINUTE, HOUR, DAY, WEEK, MONTH, QUARTER, or\nYEAR.\n\nThe unit value may be specified using one of keywords as shown, or with\na prefix of SQL_TSI_. For example, DAY and SQL_TSI_DAY both are legal.\n\nThis function returns NULL if interval or datetime_expr is NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/date-and-time-functions.html +[TIMESTAMPDIFF] +declaration=unit,datetime_expr1,datetime_expr2 +category=Date and Time Functions +description=Returns datetime_expr2 − datetime_expr1, where datetime_expr1 and\ndatetime_expr2 are date or datetime expressions. One expression may be\na date and the other a datetime; a date value is treated as a datetime\nhaving the time part '00:00:00' where necessary. The unit for the\nresult (an integer) is given by the unit argument. The legal values for\nunit are the same as those listed in the description of the\nTIMESTAMPADD() function.\n\nThis function returns NULL if datetime_expr1 or datetime_expr2 is NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/date-and-time-functions.html +[TIME_FORMAT] +declaration=time,format +category=Date and Time Functions +description=This is used like the DATE_FORMAT() function, but the format string may\ncontain format specifiers only for hours, minutes, seconds, and\nmicroseconds. Other specifiers produce a NULL or 0. TIME_FORMAT()\nreturns NULL if time or format is NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/date-and-time-functions.html +[TIME_TO_SEC] +declaration=time +category=Date and Time Functions +description=Returns the time argument, converted to seconds. Returns NULL if time\nis NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/date-and-time-functions.html +[TINYINT] +declaration=M +category=Data Types +description=A very small integer. The signed range is -128 to 127. The unsigned\nrange is 0 to 255.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/numeric-type-syntax.html +[TO_BASE64] +declaration=str +category=String Functions +description=Converts the string argument to base-64 encoded form and returns the\nresult as a character string with the connection character set and\ncollation. If the argument is not a string, it is converted to a string\nbefore conversion takes place. The result is NULL if the argument is\nNULL. Base-64 encoded strings can be decoded using the FROM_BASE64()\nfunction.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/string-functions.html +[TO_DAYS] +declaration=date +category=Date and Time Functions +description=Given a date date, returns a day number (the number of days since year\n0). Returns NULL if date is NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/date-and-time-functions.html +[TO_SECONDS] +declaration=expr +category=Date and Time Functions +description=Given a date or datetime expr, returns the number of seconds since the\nyear 0. If expr is not a valid date or datetime value (including NULL),\nit returns NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/date-and-time-functions.html +[TRIM] +declaration=[{BOTH | LEADING | TRAILING} [remstr] FROM] str +category=String Functions +description=FROM] str)\n\nReturns the string str with all remstr prefixes or suffixes removed. If\nnone of the specifiers BOTH, LEADING, or TRAILING is given, BOTH is\nassumed. remstr is optional and, if not specified, spaces are removed.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/string-functions.html +[TRUNCATE] +declaration=X,D +category=Numeric Functions +description=Returns the number X, truncated to D decimal places. If D is 0, the\nresult has no decimal point or fractional part. D can be negative to\ncause D digits left of the decimal point of the value X to become zero.\nIf X or D is NULL, the function returns NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/mathematical-functions.html +[UCASE] +declaration=str +category=String Functions +description=UCASE() is a synonym for UPPER().\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/string-functions.html +[UNCOMPRESS] +declaration=string_to_uncompress +category=Encryption Functions +description=Uncompresses a string compressed by the COMPRESS() function. If the\nargument is not a compressed value, the result is NULL; if\nstring_to_uncompress is NULL, the result is also NULL. This function\nrequires MySQL to have been compiled with a compression library such as\nzlib. Otherwise, the return value is always NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/encryption-functions.html +[UNCOMPRESSED_LENGTH] +declaration=compressed_string +category=Encryption Functions +description=Returns the length that the compressed string had before being\ncompressed. Returns NULL if compressed_string is NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/encryption-functions.html +[UNHEX] +declaration=str +category=String Functions +description=For a string argument str, UNHEX(str) interprets each pair of\ncharacters in the argument as a hexadecimal number and converts it to\nthe byte represented by the number. The return value is a binary\nstring.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/string-functions.html +[UNIX_TIMESTAMP] +declaration=[date] +category=Date and Time Functions +description=If UNIX_TIMESTAMP() is called with no date argument, it returns a Unix\ntimestamp representing seconds since '1970-01-01 00:00:00' UTC.\n\nIf UNIX_TIMESTAMP() is called with a date argument, it returns the\nvalue of the argument as seconds since '1970-01-01 00:00:00' UTC. The\nserver interprets date as a value in the session time zone and converts\nit to an internal Unix timestamp value in UTC. (Clients can set the\nsession time zone as described in\nhttps://dev.mysql.com/doc/refman/8.3/en/time-zone-support.html.) The\ndate argument may be a DATE, DATETIME, or TIMESTAMP string, or a number\nin YYMMDD, YYMMDDhhmmss, YYYYMMDD, or YYYYMMDDhhmmss format. If the\nargument includes a time part, it may optionally include a fractional\nseconds part.\n\nThe return value is an integer if no argument is given or the argument\ndoes not include a fractional seconds part, or DECIMAL if an argument\nis given that includes a fractional seconds part.\n\nWhen the date argument is a TIMESTAMP column, UNIX_TIMESTAMP() returns\nthe internal timestamp value directly, with no implicit\n"string-to-Unix-timestamp" conversion.\n\nThe valid range of argument values is the same as for the TIMESTAMP\ndata type: '1970-01-01 00:00:01.000000' UTC to '2038-01-19\n03:14:07.999999' UTC for 32-bit platforms; for MySQL running on 64-bit\nplatforms, the valid range of argument values for UNIX_TIMESTAMP() is\n'1970-01-01 00:00:01.000000' UTC to '3001-01-19 03:14:07.999999' UTC\n(corresponding to 32536771199.999999 seconds).\n\nRegardless of MySQL version or platform architecture, if you pass an\nout-of-range date to UNIX_TIMESTAMP(), it returns 0. If date is NULL,\nit returns NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/date-and-time-functions.html +[UPDATEXML] +declaration=xml_target, xpath_expr, new_xml +category=XML +description=This function replaces a single portion of a given fragment of XML\nmarkup xml_target with a new XML fragment new_xml, and then returns the\nchanged XML. The portion of xml_target that is replaced matches an\nXPath expression xpath_expr supplied by the user.\n\nIf no expression matching xpath_expr is found, or if multiple matches\nare found, the function returns the original xml_target XML fragment.\nAll three arguments should be strings. If any of the arguments to\nUpdateXML() are NULL, the function returns NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/xml-functions.html +[UPPER] +declaration=str +category=String Functions +description=Returns the string str with all characters changed to uppercase\naccording to the current character set mapping, or NULL if str is NULL.\nThe default character set is utf8mb4.\n\nmysql> SELECT UPPER('Hej');\n -> 'HEJ'\n\nSee the description of LOWER() for information that also applies to\nUPPER(). This included information about how to perform lettercase\nconversion of binary strings (BINARY, VARBINARY, BLOB) for which these\nfunctions are ineffective, and information about case folding for\nUnicode character sets.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/string-functions.html +[USER] +declaration= +category=Information Functions +description=Returns the current MySQL user name and host name as a string in the\nutf8mb3 character set.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/information-functions.html +[UTC_DATE] +declaration= +category=Date and Time Functions +description=Returns the current UTC date as a value in 'YYYY-MM-DD' or YYYYMMDD\nformat, depending on whether the function is used in string or numeric\ncontext.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/date-and-time-functions.html +[UTC_TIME] +declaration=[fsp] +category=Date and Time Functions +description=Returns the current UTC time as a value in 'hh:mm:ss' or hhmmss format,\ndepending on whether the function is used in string or numeric context.\n\nIf the fsp argument is given to specify a fractional seconds precision\nfrom 0 to 6, the return value includes a fractional seconds part of\nthat many digits.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/date-and-time-functions.html +[UTC_TIMESTAMP] +declaration=[fsp] +category=Date and Time Functions +description=Returns the current UTC date and time as a value in 'YYYY-MM-DD\nhh:mm:ss' or YYYYMMDDhhmmss format, depending on whether the function\nis used in string or numeric context.\n\nIf the fsp argument is given to specify a fractional seconds precision\nfrom 0 to 6, the return value includes a fractional seconds part of\nthat many digits.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/date-and-time-functions.html +[UUID] +declaration= +category=Miscellaneous Functions +description=Returns a Universal Unique Identifier (UUID) generated according to RFC\n4122, "A Universally Unique IDentifier (UUID) URN Namespace"\n(http://www.ietf.org/rfc/rfc4122.txt).\n\nA UUID is designed as a number that is globally unique in space and\ntime. Two calls to UUID() are expected to generate two different\nvalues, even if these calls are performed on two separate devices not\nconnected to each other.\n\n*Warning*:\n\nAlthough UUID() values are intended to be unique, they are not\nnecessarily unguessable or unpredictable. If unpredictability is\nrequired, UUID values should be generated some other way.\n\nUUID() returns a value that conforms to UUID version 1 as described in\nRFC 4122. The value is a 128-bit number represented as a utf8mb3 string\nof five hexadecimal numbers in aaaaaaaa-bbbb-cccc-dddd-eeeeeeeeeeee\nformat:\n\no The first three numbers are generated from the low, middle, and high\n parts of a timestamp. The high part also includes the UUID version\n number.\n\no The fourth number preserves temporal uniqueness in case the timestamp\n value loses monotonicity (for example, due to daylight saving time).\n\no The fifth number is an IEEE 802 node number that provides spatial\n uniqueness. A random number is substituted if the latter is not\n available (for example, because the host device has no Ethernet card,\n or it is unknown how to find the hardware address of an interface on\n the host operating system). In this case, spatial uniqueness cannot\n be guaranteed. Nevertheless, a collision should have very low\n probability.\n\n The MAC address of an interface is taken into account only on\n FreeBSD, Linux, and Windows. On other operating systems, MySQL uses a\n randomly generated 48-bit number.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/miscellaneous-functions.html +[UUID_SHORT] +declaration= +category=Miscellaneous Functions +description=Returns a "short" universal identifier as a 64-bit unsigned integer.\nValues returned by UUID_SHORT() differ from the string-format 128-bit\nidentifiers returned by the UUID() function and have different\nuniqueness properties. The value of UUID_SHORT() is guaranteed to be\nunique if the following conditions hold:\n\no The server_id value of the current server is between 0 and 255 and is\n unique among your set of source and replica servers\n\no You do not set back the system time for your server host between\n mysqld restarts\n\no You invoke UUID_SHORT() on average fewer than 16 million times per\n second between mysqld restarts\n\nThe UUID_SHORT() return value is constructed this way:\n\n (server_id & 255) << 56\n+ (server_startup_time_in_seconds << 24)\n+ incremented_variable++;\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/miscellaneous-functions.html +[UUID_TO_BIN] +declaration=string_uuid +category=Miscellaneous Functions +description=Converts a string UUID to a binary UUID and returns the result. (The\nIS_UUID() function description lists the permitted string UUID\nformats.) The return binary UUID is a VARBINARY(16) value. If the UUID\nargument is NULL, the return value is NULL. If any argument is invalid,\nan error occurs.\n\nUUID_TO_BIN() takes one or two arguments:\n\no The one-argument form takes a string UUID value. The binary result is\n in the same order as the string argument.\n\no The two-argument form takes a string UUID value and a flag value:\n\n o If swap_flag is 0, the two-argument form is equivalent to the\n one-argument form. The binary result is in the same order as the\n string argument.\n\n o If swap_flag is 1, the format of the return value differs: The\n time-low and time-high parts (the first and third groups of\n hexadecimal digits, respectively) are swapped. This moves the more\n rapidly varying part to the right and can improve indexing\n efficiency if the result is stored in an indexed column.\n\nTime-part swapping assumes the use of UUID version 1 values, such as\nare generated by the UUID() function. For UUID values produced by other\nmeans that do not follow version 1 format, time-part swapping provides\nno benefit. For details about version 1 format, see the UUID() function\ndescription.\n\nSuppose that you have the following string UUID value:\n\nmysql> SET @uuid = '6ccd780c-baba-1026-9564-5b8c656024db';\n\nTo convert the string UUID to binary with or without time-part\nswapping, use UUID_TO_BIN():\n\nmysql> SELECT HEX(UUID_TO_BIN(@uuid));\n+----------------------------------+\n| HEX(UUID_TO_BIN(@uuid)) |\n+----------------------------------+\n| 6CCD780CBABA102695645B8C656024DB |\n+----------------------------------+\nmysql> SELECT HEX(UUID_TO_BIN(@uuid, 0));\n+----------------------------------+\n| HEX(UUID_TO_BIN(@uuid, 0)) |\n+----------------------------------+\n| 6CCD780CBABA102695645B8C656024DB |\n+----------------------------------+\nmysql> SELECT HEX(UUID_TO_BIN(@uuid, 1));\n+----------------------------------+\n ... +[VALIDATE_PASSWORD_STRENGTH] +declaration=str +category=Encryption Functions +description=Given an argument representing a plaintext password, this function\nreturns an integer to indicate how strong the password is, or NULL if\nthe argument is NULL. The return value ranges from 0 (weak) to 100\n(strong).\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/encryption-functions.html +[VALUES] +declaration=col_name +category=Miscellaneous Functions +description=In an INSERT ... ON DUPLICATE KEY UPDATE statement, you can use the\nVALUES(col_name) function in the UPDATE clause to refer to column\nvalues from the INSERT portion of the statement. In other words,\nVALUES(col_name) in the UPDATE clause refers to the value of col_name\nthat would be inserted, had no duplicate-key conflict occurred. This\nfunction is especially useful in multiple-row inserts. The VALUES()\nfunction is meaningful only in the ON DUPLICATE KEY UPDATE clause of\nINSERT statements and returns NULL otherwise. See\nhttps://dev.mysql.com/doc/refman/8.3/en/insert-on-duplicate.html.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/miscellaneous-functions.html +[VARBINARY] +declaration=M +category=Data Types +description=The VARBINARY type is similar to the VARCHAR type, but stores binary\nbyte strings rather than nonbinary character strings. M represents the\nmaximum column length in bytes.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/string-type-syntax.html +[VARCHAR] +declaration=M +category=Data Types +description=collation_name]\n\nA variable-length string. M represents the maximum column length in\ncharacters. The range of M is 0 to 65,535. The effective maximum length\nof a VARCHAR is subject to the maximum row size (65,535 bytes, which is\nshared among all columns) and the character set used. For example,\nutf8mb3 characters can require up to three bytes per character, so a\nVARCHAR column that uses the utf8mb3 character set can be declared to\nbe a maximum of 21,844 characters. See\nhttps://dev.mysql.com/doc/refman/8.3/en/column-count-limit.html.\n\nMySQL stores VARCHAR values as a 1-byte or 2-byte length prefix plus\ndata. The length prefix indicates the number of bytes in the value. A\nVARCHAR column uses one length byte if values require no more than 255\nbytes, two length bytes if values may require more than 255 bytes.\n\n*Note*:\n\nMySQL follows the standard SQL specification, and does not remove\ntrailing spaces from VARCHAR values.\n\nVARCHAR is shorthand for CHARACTER VARYING. NATIONAL VARCHAR is the\nstandard SQL way to define that a VARCHAR column should use some\npredefined character set. MySQL uses utf8mb3 as this predefined\ncharacter set.\nhttps://dev.mysql.com/doc/refman/8.3/en/charset-national.html. NVARCHAR\nis shorthand for NATIONAL VARCHAR.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/string-type-syntax.html +[VARIANCE] +declaration=expr +category=Aggregate Functions and Modifiers +description=Returns the population standard variance of expr. VARIANCE() is a\nsynonym for the standard SQL function VAR_POP(), provided as a MySQL\nextension.\n\nIf there are no matching rows, or if expr is NULL, VARIANCE() returns\nNULL.\n\nThis function executes as a window function if over_clause is present.\nover_clause is as described in\nhttps://dev.mysql.com/doc/refman/8.3/en/window-functions-usage.html.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/aggregate-functions.html +[VAR_POP] +declaration=expr +category=Aggregate Functions and Modifiers +description=Returns the population standard variance of expr. It considers rows as\nthe whole population, not as a sample, so it has the number of rows as\nthe denominator. You can also use VARIANCE(), which is equivalent but\nis not standard SQL.\n\nIf there are no matching rows, or if expr is NULL, VAR_POP() returns\nNULL.\n\nThis function executes as a window function if over_clause is present.\nover_clause is as described in\nhttps://dev.mysql.com/doc/refman/8.3/en/window-functions-usage.html.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/aggregate-functions.html +[VAR_SAMP] +declaration=expr +category=Aggregate Functions and Modifiers +description=Returns the sample variance of expr. That is, the denominator is the\nnumber of rows minus one.\n\nIf there are no matching rows, or if expr is NULL, VAR_SAMP() returns\nNULL.\n\nThis function executes as a window function if over_clause is present.\nover_clause is as described in\nhttps://dev.mysql.com/doc/refman/8.3/en/window-functions-usage.html.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/aggregate-functions.html +[VERSION] +declaration= +category=Information Functions +description=Returns a string that indicates the MySQL server version. The string\nuses the utf8mb3 character set. The value might have a suffix in\naddition to the version number. See the description of the version\nsystem variable in\nhttps://dev.mysql.com/doc/refman/8.3/en/server-system-variables.html.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/information-functions.html +[WAIT_FOR_EXECUTED_GTID_SET] +declaration=gtid_set[, timeout] +category=GTID +description=Wait until the server has applied all of the transactions whose global\ntransaction identifiers are contained in gtid_set; that is, until the\ncondition GTID_SUBSET(gtid_subset, @@GLOBAL.gtid_executed) holds. See\nhttps://dev.mysql.com/doc/refman/8.3/en/replication-gtids-concepts.html\nfor a definition of GTID sets.\n\nIf a timeout is specified, and timeout seconds elapse before all of the\ntransactions in the GTID set have been applied, the function stops\nwaiting. timeout is optional, and the default timeout is 0 seconds, in\nwhich case the function always waits until all of the transactions in\nthe GTID set have been applied. timeout must be greater than or equal\nto 0; when running in strict SQL mode, a negative timeout value is\nimmediately rejected with an error (ER_WRONG_ARGUMENTS\n(https://dev.mysql.com/doc/mysql-errors/8.3/en/server-error-reference.html\n#error_er_wrong_arguments)); otherwise the function returns NULL,\nand raises a warning.\n\nWAIT_FOR_EXECUTED_GTID_SET() monitors all the GTIDs that are applied on\nthe server, including transactions that arrive from all replication\nchannels and user clients. It does not take into account whether\nreplication channels have been started or stopped.\n\nFor more information, see\nhttps://dev.mysql.com/doc/refman/8.3/en/replication-gtids.html.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/gtid-functions.html +[WEEK] +declaration=date[,mode] +category=Date and Time Functions +description=This function returns the week number for date. The two-argument form\nof WEEK() enables you to specify whether the week starts on Sunday or\nMonday and whether the return value should be in the range from 0 to 53\nor from 1 to 53. If the mode argument is omitted, the value of the\ndefault_week_format system variable is used. See\nhttps://dev.mysql.com/doc/refman/8.3/en/server-system-variables.html.\nFor a NULL date value, the function returns NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/date-and-time-functions.html +[WEEKDAY] +declaration=date +category=Date and Time Functions +description=Returns the weekday index for date (0 = Monday, 1 = Tuesday, ... 6 =\nSunday). Returns NULL if date is NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/date-and-time-functions.html +[WEEKOFYEAR] +declaration=date +category=Date and Time Functions +description=Returns the calendar week of the date as a number in the range from 1\nto 53. Returns NULL if date is NULL.\n\nWEEKOFYEAR() is a compatibility function that is equivalent to\nWEEK(date,3).\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/date-and-time-functions.html +[WEIGHT_STRING] +declaration=str [AS {CHAR|BINARY}(N +category=String Functions +description=This function returns the weight string for the input string. The\nreturn value is a binary string that represents the comparison and\nsorting value of the string, or NULL if the argument is NULL. It has\nthese properties:\n\no If WEIGHT_STRING(str1) = WEIGHT_STRING(str2), then str1 = str2 (str1\n and str2 are considered equal)\n\no If WEIGHT_STRING(str1) < WEIGHT_STRING(str2), then str1 < str2 (str1\n sorts before str2)\n\nWEIGHT_STRING() is a debugging function intended for internal use. Its\nbehavior can change without notice between MySQL versions. It can be\nused for testing and debugging of collations, especially if you are\nadding a new collation. See\nhttps://dev.mysql.com/doc/refman/8.3/en/adding-collation.html.\n\nThis list briefly summarizes the arguments. More details are given in\nthe discussion following the list.\n\no str: The input string expression.\n\no AS clause: Optional; cast the input string to a given type and\n length.\n\no flags: Optional; unused.\n\nThe input string, str, is a string expression. If the input is a\nnonbinary (character) string such as a CHAR, VARCHAR, or TEXT value,\nthe return value contains the collation weights for the string. If the\ninput is a binary (byte) string such as a BINARY, VARBINARY, or BLOB\nvalue, the return value is the same as the input (the weight for each\nbyte in a binary string is the byte value). If the input is NULL,\nWEIGHT_STRING() returns NULL.\n\nExamples:\n\nmysql> SET @s = _utf8mb4 'AB' COLLATE utf8mb4_0900_ai_ci;\nmysql> SELECT @s, HEX(@s), HEX(WEIGHT_STRING(@s));\n+------+---------+------------------------+\n| @s | HEX(@s) | HEX(WEIGHT_STRING(@s)) |\n+------+---------+------------------------+\n| AB | 4142 | 1C471C60 |\n+------+---------+------------------------+\n\nmysql> SET @s = _utf8mb4 'ab' COLLATE utf8mb4_0900_ai_ci;\nmysql> SELECT @s, HEX(@s), HEX(WEIGHT_STRING(@s));\n+------+---------+------------------------+\n| @s | HEX(@s) | HEX(WEIGHT_STRING(@s)) |\n+------+---------+------------------------+\n ... +[YEAR] +declaration=date +category=Date and Time Functions +description=Returns the year for date, in the range 1000 to 9999, or 0 for the\n"zero" date. Returns NULL if date is NULL.\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/date-and-time-functions.html +[YEARWEEK] +declaration=date +category=Date and Time Functions +description=Returns year and week for a date. The year in the result may be\ndifferent from the year in the date argument for the first and the last\nweek of the year. Returns NULL if date is NULL.\n\nThe mode argument works exactly like the mode argument to WEEK(). For\nthe single-argument syntax, a mode value of 0 is used. Unlike WEEK(),\nthe value of default_week_format does not influence YEARWEEK().\n\nURL: https://dev.mysql.com/doc/refman/8.3/en/date-and-time-functions.html \ No newline at end of file diff --git a/out/functions-postgresql.ini b/out/functions-postgresql.ini new file mode 100644 index 000000000..bf2a8d0b6 --- /dev/null +++ b/out/functions-postgresql.ini @@ -0,0 +1,2244 @@ +[ABBREV] +declaration=inet +category=Network Address Functions +description=Creates an abbreviated display format as text. (The result is the same as\nthe inet output function produces; it is "abbreviated" only in comparison\nto the result of an explicit cast to text, which for historical reasons\nwill never suppress the netmask part.) +[ABS] +declaration=numeric_type +category=Numeric/Math Functions +description=Absolute value +[ACLDEFAULT] +declaration=type "char", ownerId oid +category=Session Information Functions +description=Constructs an aclitem array holding the default access privileges for an\nobject of type type belonging to the role with OID ownerId. This represents\nthe access privileges that will be assumed when an object's ACL entry is\nnull. (The default access privileges are described in Section 5.8.) The\ntype parameter must be one of 'c' for COLUMN, 'r' for TABLE and table-like\nobjects, 's' for SEQUENCE, 'd' for DATABASE, 'f' for FUNCTION or PROCEDURE,\n'l' for LANGUAGE, 'L' for LARGE OBJECT, 'n' for SCHEMA, 'p' for PARAMETER,\n't' for TABLESPACE, 'F' for FOREIGN DATA WRAPPER, 'S' for FOREIGN SERVER,\nor 'T' for TYPE or DOMAIN. +[ACLEXPLODE] +declaration=aclitem[] +category=Session Information Functions +description=Returns the aclitem array as a set of rows. If the grantee is the\npseudo-role PUBLIC, it is represented by zero in the grantee column. Each\ngranted privilege is represented as SELECT, INSERT, etc (see Table 5.1 for\na full list). Note that each privilege is broken out as a separate row, so\nonly one keyword appears in the privilege_type column. +[ACOS] +declaration=double precision +category=Numeric/Math Functions +description=Inverse cosine, result in radians +[ACOSD] +declaration=double precision +category=Numeric/Math Functions +description=Inverse cosine, result in degrees +[ACOSH] +declaration=double precision +category=Numeric/Math Functions +description=Inverse hyperbolic cosine +[AGE1] +name=AGE +declaration=timestamp, timestamp +category=Date/Time Functions +description=Subtract arguments, producing a "symbolic" result that uses years and\nmonths, rather than just days +[AGE2] +name=AGE +declaration=xid +category=Session Information Functions +description=Returns the number of transactions between the supplied transaction id and\nthe current transaction counter. +[ANY_VALUE] +declaration=anyelement +category=Aggregate Functions +description=Returns an arbitrary value from the non-null input values. +[AREA] +declaration=geometric_type +category=Geometric Functions +description=Computes area. Available for box, path, circle. A path input must be\nclosed, else NULL is returned. Also, if the path is self-intersecting, the\nresult may be meaningless. +[ARRAY_AGG] +declaration=anynonarray ORDER BY input_sort_columns +category=Aggregate Functions +description=Collects all the input values, including nulls, into an array. +[ARRAY_APPEND] +declaration=anycompatiblearray, anycompatible +category=Array Functions +description=Appends an element to the end of an array (same as the anycompatiblearray\n|| anycompatible operator). +[ARRAY_CAT] +declaration=anycompatiblearray, anycompatiblearray +category=Array Functions +description=Concatenates two arrays (same as the anycompatiblearray ||\nanycompatiblearray operator). +[ARRAY_DIMS] +declaration=anyarray +category=Array Functions +description=Returns a text representation of the array's dimensions. +[ARRAY_FILL] +declaration=anyelement, integer[] [, integer[] ] +category=Array Functions +description=Returns an array filled with copies of the given value, having dimensions\nof the lengths specified by the second argument. The optional third\nargument supplies lower-bound values for each dimension (which default to\nall 1). +[ARRAY_LENGTH] +declaration=anyarray, integer +category=Array Functions +description=Returns the length of the requested array dimension. (Produces NULL instead\nof 0 for empty or missing array dimensions.) +[ARRAY_LOWER] +declaration=anyarray, integer +category=Array Functions +description=Returns the lower bound of the requested array dimension. +[ARRAY_NDIMS] +declaration=anyarray +category=Array Functions +description=Returns the number of dimensions of the array. +[ARRAY_POSITION] +declaration=anycompatiblearray, anycompatible [, integer ] +category=Array Functions +description=Returns the subscript of the first occurrence of the second argument in the\narray, or NULL if it's not present. If the third argument is given, the\nsearch begins at that subscript. The array must be one-dimensional.\nComparisons are done using IS NOT DISTINCT FROM semantics, so it is\npossible to search for NULL. +[ARRAY_POSITIONS] +declaration=anycompatiblearray, anycompatible +category=Array Functions +description=Returns an array of the subscripts of all occurrences of the second\nargument in the array given as first argument. The array must be\none-dimensional. Comparisons are done using IS NOT DISTINCT FROM semantics,\nso it is possible to search for NULL. NULL is returned only if the array is\nNULL; if the value is not found in the array, an empty array is returned. +[ARRAY_PREPEND] +declaration=anycompatible, anycompatiblearray +category=Array Functions +description=Prepends an element to the beginning of an array (same as the anycompatible\n|| anycompatiblearray operator). +[ARRAY_REMOVE] +declaration=anycompatiblearray, anycompatible +category=Array Functions +description=Removes all elements equal to the given value from the array. The array\nmust be one-dimensional. Comparisons are done using IS NOT DISTINCT FROM\nsemantics, so it is possible to remove NULLs. +[ARRAY_REPLACE] +declaration=anycompatiblearray, anycompatible, anycompatible +category=Array Functions +description=Replaces each array element equal to the second argument with the third\nargument. +[ARRAY_SAMPLE] +declaration=array anyarray, n integer +category=Array Functions +description=Returns an array of n items randomly selected from array. n may not exceed\nthe length of array's first dimension. If array is multi-dimensional, an\n"item" is a slice having a given first subscript. +[ARRAY_SHUFFLE] +declaration=anyarray +category=Array Functions +description=Randomly shuffles the first dimension of the array. +[ARRAY_TO_JSON] +declaration=anyarray [, boolean ] +category=JSON Functions +description=Converts an SQL array to a JSON array. The behavior is the same as to_json\nexcept that line feeds will be added between top-level array elements if\nthe optional boolean parameter is true. +[ARRAY_TO_STRING] +declaration=array anyarray, delimiter text [, null_string text ] +category=Array Functions +description=Converts each array element to its text representation, and concatenates\nthose separated by the delimiter string. If null_string is given and is not\nNULL, then NULL array entries are represented by that string; otherwise,\nthey are omitted. See also string_to_array. +[ARRAY_TO_TSVECTOR] +declaration=text[] +category=Text Search Functions +description=Converts an array of text strings to a tsvector. The given strings are used\nas lexemes as-is, without further processing. Array elements must not be\nempty strings or NULL. +[ARRAY_UPPER] +declaration=anyarray, integer +category=Array Functions +description=Returns the upper bound of the requested array dimension. +[ASCII] +declaration=text +category=String Functions +description=Returns the numeric code of the first character of the argument. In UTF8\nencoding, returns the Unicode code point of the character. In other\nmultibyte encodings, the argument must be an ASCII character. +[ASIN] +declaration=double precision +category=Numeric/Math Functions +description=Inverse sine, result in radians +[ASIND] +declaration=double precision +category=Numeric/Math Functions +description=Inverse sine, result in degrees +[ASINH] +declaration=double precision +category=Numeric/Math Functions +description=Inverse hyperbolic sine +[ATAN] +declaration=double precision +category=Numeric/Math Functions +description=Inverse tangent, result in radians +[ATAN2] +declaration=y double precision, x double precision +category=Numeric/Math Functions +description=Inverse tangent of y/x, result in radians +[ATAN2D] +declaration=y double precision, x double precision +category=Numeric/Math Functions +description=Inverse tangent of y/x, result in degrees +[ATAND] +declaration=double precision +category=Numeric/Math Functions +description=Inverse tangent, result in degrees +[ATANH] +declaration=double precision +category=Numeric/Math Functions +description=Inverse hyperbolic tangent +[BIT_COUNT] +declaration=bit +category=Bit String Functions +description=Returns the number of bits set in the bit string (also known as\n"popcount"). +[BIT_LENGTH1] +name=BIT_LENGTH +declaration=text +category=String Functions +description=Returns number of bits in the string (8 times the octet_length). +[BIT_LENGTH2] +name=BIT_LENGTH +declaration=bytea +category=Binary String Functions +description=Returns number of bits in the binary string (8 times the octet_length). +[BIT_LENGTH3] +name=BIT_LENGTH +declaration=bit +category=Bit String Functions +description=Returns number of bits in the bit string. +[BOOL_AND] +declaration=boolean +category=Aggregate Functions +description=Returns true if all non-null input values are true, otherwise false. +[BOOL_OR] +declaration=boolean +category=Aggregate Functions +description=Returns true if any non-null input value is true, otherwise false. +[BOUND_BOX] +declaration=box, box +category=Geometric Functions +description=Computes bounding box of two boxes. +[BOX] +declaration=circle +category=Geometric Functions +description=Computes box inscribed within the circle. +[BRIN_DESUMMARIZE_RANGE] +declaration=index regclass, blockNumber bigint +category=System Administration Functions +description=Removes the BRIN index tuple that summarizes the page range covering the\ngiven table block, if there is one. +[BRIN_SUMMARIZE_NEW_VALUES] +declaration=index regclass +category=System Administration Functions +description=Scans the specified BRIN index to find page ranges in the base table that\nare not currently summarized by the index; for any such range it creates a\nnew summary index tuple by scanning those table pages. Returns the number\nof new page range summaries that were inserted into the index. +[BRIN_SUMMARIZE_RANGE] +declaration=index regclass, blockNumber bigint +category=System Administration Functions +description=Summarizes the page range covering the given block, if not already\nsummarized. This is like brin_summarize_new_values except that it only\nprocesses the page range that covers the given table block number. +[BROADCAST] +declaration=inet +category=Network Address Functions +description=Computes the broadcast address for the address's network. +[BTRIM1] +name=BTRIM +declaration=string text [, characters text ] +category=String Functions +description=Removes the longest string containing only characters in characters (a\nspace by default) from the start and end of string. +[BTRIM2] +name=BTRIM +declaration=bytes bytea, bytesremoved bytea +category=Binary String Functions +description=Removes the longest string containing only bytes appearing in bytesremoved\nfrom the start and end of bytes. +[CARDINALITY] +declaration=anyarray +category=Array Functions +description=Returns the total number of elements in the array, or 0 if the array is\nempty. +[CBRT] +declaration=double precision +category=Numeric/Math Functions +description=Cube root +[CENTER] +declaration=geometric_type +category=Geometric Functions +description=Computes center point. Available for box, circle. +[CHARACTER_LENGTH] +declaration=text +category=String Functions +description=Returns number of characters in the string. +[CHR] +declaration=integer +category=String Functions +description=Returns the character with the given code. In UTF8 encoding the argument is\ntreated as a Unicode code point. In other multibyte encodings the argument\nmust designate an ASCII character. chr(0) is disallowed because text data\ntypes cannot store that character. +[CIRCLE] +declaration=box +category=Geometric Functions +description=Computes smallest circle enclosing box. +[CLOCK_TIMESTAMP] +declaration= +category=Date/Time Functions +description=Current date and time (changes during statement execution); see Section\n9.9.5 +[COL_DESCRIPTION] +declaration=table oid, column integer +category=Session Information Functions +description=Returns the comment for a table column, which is specified by the OID of\nits table and its column number. (obj_description cannot be used for table\ncolumns, since columns do not have OIDs of their own.) +[CONCAT] +declaration=val1 "any" [, val2 "any" [, ...] ] +category=String Functions +description=Concatenates the text representations of all the arguments. NULL arguments\nare ignored. +[CONCAT_WS] +declaration=sep text, val1 "any" [, val2 "any" [, ...] ] +category=String Functions +description=Concatenates all but the first argument, with separators. The first\nargument is used as the separator string, and should not be NULL. Other\nNULL arguments are ignored. +[CONVERT] +declaration=bytes bytea, src_encoding name, dest_encoding name +category=Binary String Functions +description=Converts a binary string representing text in encoding src_encoding to a\nbinary string in encoding dest_encoding (see Section 23.3.4 for available\nconversions). +[CONVERT_FROM] +declaration=bytes bytea, src_encoding name +category=Binary String Functions +description=Converts a binary string representing text in encoding src_encoding to text\nin the database encoding (see Section 23.3.4 for available conversions). +[CONVERT_TO] +declaration=string text, dest_encoding name +category=Binary String Functions +description=Converts a text string (in the database encoding) to a binary string\nencoded in encoding dest_encoding (see Section 23.3.4 for available\nconversions). +[COS] +declaration=double precision +category=Numeric/Math Functions +description=Cosine, argument in radians +[COSD] +declaration=double precision +category=Numeric/Math Functions +description=Cosine, argument in degrees +[COSH] +declaration=double precision +category=Numeric/Math Functions +description=Hyperbolic cosine +[COT] +declaration=double precision +category=Numeric/Math Functions +description=Cotangent, argument in radians +[COTD] +declaration=double precision +category=Numeric/Math Functions +description=Cotangent, argument in degrees +[COUNT] +declaration=* +category=Aggregate Functions +description=Computes the number of input rows. +[CUME_DIST1] +name=CUME_DIST +declaration=args +category=Aggregate Functions +description=Computes the cumulative distribution, that is (number of rows preceding or\npeers with hypothetical row) / (total rows). The value thus ranges from 1/N\nto 1. +[CUME_DIST2] +name=CUME_DIST +declaration= +category=Window Functions +description=Returns the cumulative distribution, that is (number of partition rows\npreceding or peers with current row) / (total partition rows). The value\nthus ranges from 1/N to 1. +[CURRENT_DATABASE] +declaration= +category=Session Information Functions +description=Returns the name of the current database. (Databases are called "catalogs"\nin the SQL standard, so current_catalog is the standard's spelling.) +[CURRENT_QUERY] +declaration= +category=Session Information Functions +description=Returns the text of the currently executing query, as submitted by the\nclient (which might contain more than one statement). +[CURRENT_SETTING] +declaration=setting_name text [, missing_ok boolean ] +category=System Administration Functions +description=Returns the current value of the setting setting_name. If there is no such\nsetting, current_setting throws an error unless missing_ok is supplied and\nis true (in which case NULL is returned). This function corresponds to the\nSQL command SHOW. +[CURRVAL] +declaration=regclass +category=Sequence Manipulation Functions +description=Returns the value most recently obtained by nextval for this sequence in\nthe current session. (An error is reported if nextval has never been called\nfor this sequence in this session.) Because this is returning a\nsession-local value, it gives a predictable answer whether or not other\nsessions have executed nextval since the current session did. +[DATE_ADD] +declaration=timestamp with time zone, interval [, text ] +category=Date/Time Functions +description=Add an interval to a timestamp with time zone, computing times of day and\ndaylight-savings adjustments according to the time zone named by the third\nargument, or the current TimeZone setting if that is omitted. The form with\ntwo arguments is equivalent to the timestamp with time zone + interval\noperator. +[DATE_PART] +declaration=text, timestamp +category=Date/Time Functions +description=Get timestamp subfield (equivalent to extract); see Section 9.9.1 +[DATE_SUBTRACT] +declaration=timestamp with time zone, interval [, text ] +category=Date/Time Functions +description=Subtract an interval from a timestamp with time zone, computing times of\nday and daylight-savings adjustments according to the time zone named by\nthe third argument, or the current TimeZone setting if that is omitted. The\nform with two arguments is equivalent to the timestamp with time zone -\ninterval operator. +[DATE_TRUNC] +declaration=text, timestamp +category=Date/Time Functions +description=Truncate to specified precision; see Section 9.9.2 +[DECODE] +declaration=string text, format text +category=Binary String Functions +description=Decodes binary data from a textual representation; supported format values\nare the same as for encode. +[DEGREES] +declaration=double precision +category=Numeric/Math Functions +description=Converts radians to degrees +[DENSE_RANK1] +name=DENSE_RANK +declaration=args +category=Aggregate Functions +description=Computes the rank of the hypothetical row, without gaps; this function\neffectively counts peer groups. +[DENSE_RANK2] +name=DENSE_RANK +declaration= +category=Window Functions +description=Returns the rank of the current row, without gaps; this function\neffectively counts peer groups. +[DIAGONAL] +declaration=box +category=Geometric Functions +description=Extracts box's diagonal as a line segment (same as lseg(box)). +[DIAMETER] +declaration=circle +category=Geometric Functions +description=Computes diameter of circle. +[DIV] +declaration=y numeric, x numeric +category=Numeric/Math Functions +description=Integer quotient of y/x (truncates towards zero) +[ENCODE] +declaration=bytes bytea, format text +category=Binary String Functions +description=Encodes binary data into a textual representation; supported format values\nare: base64, escape, hex. +[ENUM_FIRST] +declaration=anyenum +category=Enum Support Functions +description=Returns the first value of the input enum type. +[ENUM_LAST] +declaration=anyenum +category=Enum Support Functions +description=Returns the last value of the input enum type. +[ENUM_RANGE] +declaration=anyenum +category=Enum Support Functions +description=Returns all values of the input enum type in an ordered array. +[ERF] +declaration=double precision +category=Numeric/Math Functions +description=Error function +[ERFC] +declaration=double precision +category=Numeric/Math Functions +description=Complementary error function (1 - erf(x), without loss of precision for\nlarge inputs) +[EVERY] +declaration=boolean +category=Aggregate Functions +description=This is the SQL standard's equivalent to bool_and. +[EXTRACT] +declaration=field from timestamp +category=Date/Time Functions +description=Get timestamp subfield; see Section 9.9.1 +[FACTORIAL] +declaration=bigint +category=Numeric/Math Functions +description=Factorial +[FAMILY] +declaration=inet +category=Network Address Functions +description=Returns the address's family: 4 for IPv4, 6 for IPv6. +[FIRST_VALUE] +declaration=value anyelement +category=Window Functions +description=Returns value evaluated at the row that is the first row of the window\nframe. +[FORMAT] +declaration=formatstr text [, formatarg "any" [, ...] ] +category=String Functions +description=Formats arguments according to a format string; see Section 9.4.1. This\nfunction is similar to the C function sprintf. +[FORMAT_TYPE] +declaration=type oid, typemod integer +category=Session Information Functions +description=Returns the SQL name for a data type that is identified by its type OID and\npossibly a type modifier. Pass NULL for the type modifier if no specific\nmodifier is known. +[GCD] +declaration=numeric_type, numeric_type +category=Numeric/Math Functions +description=Greatest common divisor (the largest positive number that divides both\ninputs with no remainder); returns 0 if both inputs are zero; available for\ninteger, bigint, and numeric +[GET_BIT1] +name=GET_BIT +declaration=bytes bytea, n bigint +category=Binary String Functions +description=Extracts n'th bit from binary string. +[GET_BIT2] +name=GET_BIT +declaration=bits bit, n integer +category=Bit String Functions +description=Extracts n'th bit from bit string; the first (leftmost) bit is bit 0. +[GET_BYTE] +declaration=bytes bytea, n integer +category=Binary String Functions +description=Extracts n'th byte from binary string. +[GET_CURRENT_TS_CONFIG] +declaration= +category=Text Search Functions +description=Returns the OID of the current default text search configuration (as set by\ndefault_text_search_config). +[GIN_CLEAN_PENDING_LIST] +declaration=index regclass +category=System Administration Functions +description=Cleans up the "pending" list of the specified GIN index by moving entries\nin it, in bulk, to the main GIN data structure. Returns the number of pages\nremoved from the pending list. If the argument is a GIN index built with\nthe fastupdate option disabled, no cleanup happens and the result is zero,\nbecause the index doesn't have a pending list. See Section 64.4.4.1 and\nSection 64.4.5 for details about the pending list and fastupdate option. +[GROUPING] +declaration=group_by_expression(s +category=Aggregate Functions +description=Returns a bit mask indicating which GROUP BY expressions are not included\nin the current grouping set. Bits are assigned with the rightmost argument\ncorresponding to the least-significant bit; each bit is 0 if the\ncorresponding expression is included in the grouping criteria of the\ngrouping set generating the current result row, and 1 if it is not\nincluded. +[HAS_ANY_COLUMN_PRIVILEGE] +declaration=[ user name or oid, ] table text or oid, privilege text +category=Session Information Functions +description=Does user have privilege for any column of table? This succeeds either if\nthe privilege is held for the whole table, or if there is a column-level\ngrant of the privilege for at least one column. Allowable privilege types\nare SELECT, INSERT, UPDATE, and REFERENCES. +[HAS_COLUMN_PRIVILEGE] +declaration=[ user name or oid, ] table text or oid, column text or smallint, privilege text +category=Session Information Functions +description=Does user have privilege for the specified table column? This succeeds\neither if the privilege is held for the whole table, or if there is a\ncolumn-level grant of the privilege for the column. The column can be\nspecified by name or by attribute number (pg_attribute.attnum). Allowable\nprivilege types are SELECT, INSERT, UPDATE, and REFERENCES. +[HAS_DATABASE_PRIVILEGE] +declaration=[ user name or oid, ] database text or oid, privilege text +category=Session Information Functions +description=Does user have privilege for database? Allowable privilege types are\nCREATE, CONNECT, TEMPORARY, and TEMP (which is equivalent to TEMPORARY). +[HAS_FOREIGN_DATA_WRAPPER_PRIVILEGE] +declaration=[ user name or oid, ] fdw text or oid, privilege text +category=Session Information Functions +description=Does user have privilege for foreign-data wrapper? The only allowable\nprivilege type is USAGE. +[HAS_FUNCTION_PRIVILEGE] +declaration=[ user name or oid, ] function text or oid, privilege text +category=Session Information Functions +description=Does user have privilege for function? The only allowable privilege type is\nEXECUTE. +[HAS_LANGUAGE_PRIVILEGE] +declaration=[ user name or oid, ] language text or oid, privilege text +category=Session Information Functions +description=Does user have privilege for language? The only allowable privilege type is\nUSAGE. +[HAS_PARAMETER_PRIVILEGE] +declaration=[ user name or oid, ] parameter text, privilege text +category=Session Information Functions +description=Does user have privilege for configuration parameter? The parameter name is\ncase-insensitive. Allowable privilege types are SET and ALTER SYSTEM. +[HAS_SCHEMA_PRIVILEGE] +declaration=[ user name or oid, ] schema text or oid, privilege text +category=Session Information Functions +description=Does user have privilege for schema? Allowable privilege types are CREATE\nand USAGE. +[HAS_SEQUENCE_PRIVILEGE] +declaration=[ user name or oid, ] sequence text or oid, privilege text +category=Session Information Functions +description=Does user have privilege for sequence? Allowable privilege types are USAGE,\nSELECT, and UPDATE. +[HAS_SERVER_PRIVILEGE] +declaration=[ user name or oid, ] server text or oid, privilege text +category=Session Information Functions +description=Does user have privilege for foreign server? The only allowable privilege\ntype is USAGE. +[HAS_TABLESPACE_PRIVILEGE] +declaration=[ user name or oid, ] tablespace text or oid, privilege text +category=Session Information Functions +description=Does user have privilege for tablespace? The only allowable privilege type\nis CREATE. +[HAS_TABLE_PRIVILEGE] +declaration=[ user name or oid, ] table text or oid, privilege text +category=Session Information Functions +description=Does user have privilege for table? Allowable privilege types are SELECT,\nINSERT, UPDATE, DELETE, TRUNCATE, REFERENCES, TRIGGER, and MAINTAIN. +[HAS_TYPE_PRIVILEGE] +declaration=[ user name or oid, ] type text or oid, privilege text +category=Session Information Functions +description=Does user have privilege for data type? The only allowable privilege type\nis USAGE. When specifying a type by name rather than by OID, the allowed\ninput is the same as for the regtype data type (see Section 8.19). +[HEIGHT] +declaration=box +category=Geometric Functions +description=Computes vertical size of box. +[HOST] +declaration=inet +category=Network Address Functions +description=Returns the IP address as text, ignoring the netmask. +[HOSTMASK] +declaration=inet +category=Network Address Functions +description=Computes the host mask for the address's network. +[ICU_UNICODE_VERSION] +declaration= +category=Session Information Functions +description=Returns a string representing the version of Unicode used by ICU, if the\nserver was built with ICU support; otherwise returns NULL +[INET_CLIENT_ADDR] +declaration= +category=Session Information Functions +description=Returns the IP address of the current client, or NULL if the current\nconnection is via a Unix-domain socket. +[INET_CLIENT_PORT] +declaration= +category=Session Information Functions +description=Returns the IP port number of the current client, or NULL if the current\nconnection is via a Unix-domain socket. +[INET_MERGE] +declaration=inet, inet +category=Network Address Functions +description=Computes the smallest network that includes both of the given networks. +[INET_SAME_FAMILY] +declaration=inet, inet +category=Network Address Functions +description=Tests whether the addresses belong to the same IP family. +[INET_SERVER_ADDR] +declaration= +category=Session Information Functions +description=Returns the IP address on which the server accepted the current connection,\nor NULL if the current connection is via a Unix-domain socket. +[INET_SERVER_PORT] +declaration= +category=Session Information Functions +description=Returns the IP port number on which the server accepted the current\nconnection, or NULL if the current connection is via a Unix-domain socket. +[INITCAP] +declaration=text +category=String Functions +description=Converts the first letter of each word to upper case and the rest to lower\ncase. Words are sequences of alphanumeric characters separated by\nnon-alphanumeric characters. +[ISCLOSED] +declaration=path +category=Geometric Functions +description=Is path closed? +[ISEMPTY1] +name=ISEMPTY +declaration=anyrange +category=Range Functions +description=Is the range empty? +[ISEMPTY2] +name=ISEMPTY +declaration=anymultirange +category=Range Functions +description=Is the multirange empty? +[ISFINITE] +declaration=date +category=Date/Time Functions +description=Test for finite date (not +/-infinity) +[ISOPEN] +declaration=path +category=Geometric Functions +description=Is path open? +[JSON] +declaration=expression [ FORMAT JSON [ ENCODING UTF8 ]] [ { WITH | WITHOUT } UNIQUE [ KEYS ]] +category=JSON Functions +description=Converts a given expression specified as text or bytea string (in UTF8\nencoding) into a JSON value. If expression is NULL, an SQL null value is\nreturned. If WITH UNIQUE is specified, the expression must not contain any\nduplicate object keys. +[JSONB_AGG] +declaration=anyelement ORDER BY input_sort_columns +category=Aggregate Functions +description=Collects all the input values, including nulls, into a JSON array. Values\nare converted to JSON as per to_json or to_jsonb. +[JSONB_AGG_STRICT] +declaration=anyelement +category=Aggregate Functions +description=Collects all the input values, skipping nulls, into a JSON array. Values\nare converted to JSON as per to_json or to_jsonb. +[JSONB_ARRAY_ELEMENTS] +declaration=jsonb +category=JSON Functions +description=Expands the top-level JSON array into a set of JSON values. +[JSONB_ARRAY_ELEMENTS_TEXT] +declaration=jsonb +category=JSON Functions +description=Expands the top-level JSON array into a set of text values. +[JSONB_ARRAY_LENGTH] +declaration=jsonb +category=JSON Functions +description=Returns the number of elements in the top-level JSON array. +[JSONB_BUILD_ARRAY] +declaration=VARIADIC "any" +category=JSON Functions +description=Builds a possibly-heterogeneously-typed JSON array out of a variadic\nargument list. Each argument is converted as per to_json or to_jsonb. +[JSONB_BUILD_OBJECT] +declaration=VARIADIC "any" +category=JSON Functions +description=Builds a JSON object out of a variadic argument list. By convention, the\nargument list consists of alternating keys and values. Key arguments are\ncoerced to text; value arguments are converted as per to_json or to_jsonb. +[JSONB_EACH] +declaration=jsonb +category=JSON Functions +description=Expands the top-level JSON object into a set of key/value pairs. +[JSONB_EACH_TEXT] +declaration=jsonb +category=JSON Functions +description=Expands the top-level JSON object into a set of key/value pairs. The\nreturned values will be of type text. +[JSONB_EXTRACT_PATH] +declaration=from_json jsonb, VARIADIC path_elems text[] +category=JSON Functions +description=Extracts JSON sub-object at the specified path. (This is functionally\nequivalent to the #> operator, but writing the path out as a variadic\nlist can be more convenient in some cases.) +[JSONB_EXTRACT_PATH_TEXT] +declaration=from_json jsonb, VARIADIC path_elems text[] +category=JSON Functions +description=Extracts JSON sub-object at the specified path as text. (This is\nfunctionally equivalent to the #>> operator.) +[JSONB_INSERT] +declaration=target jsonb, path text[], new_value jsonb [, insert_after boolean ] +category=JSON Functions +description=Returns target with new_value inserted. If the item designated by the path\nis an array element, new_value will be inserted before that item if\ninsert_after is false (which is the default), or after it if insert_after\nis true. If the item designated by the path is an object field, new_value\nwill be inserted only if the object does not already contain that key. All\nearlier steps in the path must exist, or the target is returned unchanged.\nAs with the path oriented operators, negative integers that appear in the\npath count from the end of JSON arrays. If the last path step is an array\nindex that is out of range, the new value is added at the beginning of the\narray if the index is negative, or at the end of the array if it is\npositive. +[JSONB_OBJECT] +declaration=text[] +category=JSON Functions +description=Builds a JSON object out of a text array. The array must have either\nexactly one dimension with an even number of members, in which case they\nare taken as alternating key/value pairs, or two dimensions such that each\ninner array has exactly two elements, which are taken as a key/value pair.\nAll values are converted to JSON strings. +[JSONB_OBJECT_AGG] +declaration=key "any", value "any" ORDER BY input_sort_columns +category=Aggregate Functions +description=Collects all the key/value pairs into a JSON object. Key arguments are\ncoerced to text; value arguments are converted as per to_json or to_jsonb.\nValues can be null, but keys cannot. +[JSONB_OBJECT_AGG_STRICT] +declaration=key "any", value "any" +category=Aggregate Functions +description=Collects all the key/value pairs into a JSON object. Key arguments are\ncoerced to text; value arguments are converted as per to_json or to_jsonb.\nThe key can not be null. If the value is null then the entry is skipped, +[JSONB_OBJECT_AGG_UNIQUE] +declaration=key "any", value "any" +category=Aggregate Functions +description=Collects all the key/value pairs into a JSON object. Key arguments are\ncoerced to text; value arguments are converted as per to_json or to_jsonb.\nValues can be null, but keys cannot. If there is a duplicate key an error\nis thrown. +[JSONB_OBJECT_AGG_UNIQUE_STRICT] +declaration=key "any", value "any" +category=Aggregate Functions +description=Collects all the key/value pairs into a JSON object. Key arguments are\ncoerced to text; value arguments are converted as per to_json or to_jsonb.\nThe key can not be null. If the value is null then the entry is skipped. If\nthere is a duplicate key an error is thrown. +[JSONB_OBJECT_KEYS] +declaration=jsonb +category=JSON Functions +description=Returns the set of keys in the top-level JSON object. +[JSONB_PATH_EXISTS] +declaration=target jsonb, path jsonpath [, vars jsonb [, silent boolean ]] +category=JSON Functions +description=Checks whether the JSON path returns any item for the specified JSON value.\n(This is useful only with SQL-standard JSON path expressions, not predicate\ncheck expressions, since those always return a value.) If the vars argument\nis specified, it must be a JSON object, and its fields provide named values\nto be substituted into the jsonpath expression. If the silent argument is\nspecified and is true, the function suppresses the same errors as the @?\nand @@ operators do. +[JSONB_PATH_MATCH] +declaration=target jsonb, path jsonpath [, vars jsonb [, silent boolean ]] +category=JSON Functions +description=Returns the result of a JSON path predicate check for the specified JSON\nvalue. (This is useful only with predicate check expressions, not\nSQL-standard JSON path expressions, since it will either fail or return\nNULL if the path result is not a single boolean value.) The optional vars\nand silent arguments act the same as for jsonb_path_exists. +[JSONB_PATH_QUERY] +declaration=target jsonb, path jsonpath [, vars jsonb [, silent boolean ]] +category=JSON Functions +description=Returns all JSON items returned by the JSON path for the specified JSON\nvalue. For SQL-standard JSON path expressions it returns the JSON values\nselected from target. For predicate check expressions it returns the result\nof the predicate check: true, false, or null. The optional vars and silent\narguments act the same as for jsonb_path_exists. +[JSONB_PATH_QUERY_ARRAY] +declaration=target jsonb, path jsonpath [, vars jsonb [, silent boolean ]] +category=JSON Functions +description=Returns all JSON items returned by the JSON path for the specified JSON\nvalue, as a JSON array. The parameters are the same as for\njsonb_path_query. +[JSONB_PATH_QUERY_FIRST] +declaration=target jsonb, path jsonpath [, vars jsonb [, silent boolean ]] +category=JSON Functions +description=Returns the first JSON item returned by the JSON path for the specified\nJSON value, or NULL if there are no results. The parameters are the same as\nfor jsonb_path_query. +[JSONB_PATH_QUERY_FIRST_TZ] +declaration=target jsonb, path jsonpath [, vars jsonb [, silent boolean ]] +category=JSON Functions +description=These functions act like their counterparts described above without the _tz\nsuffix, except that these functions support comparisons of date/time values\nthat require timezone-aware conversions. The example below requires\ninterpretation of the date-only value 2015-08-02 as a timestamp with time\nzone, so the result depends on the current TimeZone setting. Due to this\ndependency, these functions are marked as stable, which means these\nfunctions cannot be used in indexes. Their counterparts are immutable, and\nso can be used in indexes; but they will throw errors if asked to make such\ncomparisons. +[JSONB_POPULATE_RECORD] +declaration=base anyelement, from_json jsonb +category=JSON Functions +description=Expands the top-level JSON object to a row having the composite type of the\nbase argument. The JSON object is scanned for fields whose names match\ncolumn names of the output row type, and their values are inserted into\nthose columns of the output. (Fields that do not correspond to any output\ncolumn name are ignored.) In typical use, the value of base is just NULL,\nwhich means that any output columns that do not match any object field will\nbe filled with nulls. However, if base isn't NULL then the values it\ncontains will be used for unmatched columns. +[JSONB_POPULATE_RECORDSET] +declaration=base anyelement, from_json jsonb +category=JSON Functions +description=Expands the top-level JSON array of objects to a set of rows having the\ncomposite type of the base argument. Each element of the JSON array is\nprocessed as described above for json[b]_populate_record. +[JSONB_POPULATE_RECORD_VALID] +declaration=base anyelement, from_json json +category=JSON Functions +description=Function for testing jsonb_populate_record. Returns true if the input\njsonb_populate_record would finish without an error for the given input\nJSON object; that is, it's valid input, false otherwise. +[JSONB_PRETTY] +declaration=jsonb +category=JSON Functions +description=Converts the given JSON value to pretty-printed, indented text. +[JSONB_SET] +declaration=target jsonb, path text[], new_value jsonb [, create_if_missing boolean ] +category=JSON Functions +description=Returns target with the item designated by path replaced by new_value, or\nwith new_value added if create_if_missing is true (which is the default)\nand the item designated by path does not exist. All earlier steps in the\npath must exist, or the target is returned unchanged. As with the path\noriented operators, negative integers that appear in the path count from\nthe end of JSON arrays. If the last path step is an array index that is out\nof range, and create_if_missing is true, the new value is added at the\nbeginning of the array if the index is negative, or at the end of the array\nif it is positive. +[JSONB_SET_LAX] +declaration=target jsonb, path text[], new_value jsonb [, create_if_missing boolean [, null_value_treatment text ]] +category=JSON Functions +description=If new_value is not NULL, behaves identically to jsonb_set. Otherwise\nbehaves according to the value of null_value_treatment which must be one of\n'raise_exception', 'use_json_null', 'delete_key', or 'return_target'. The\ndefault is 'use_json_null'. +[JSONB_STRIP_NULLS] +declaration=jsonb +category=JSON Functions +description=Deletes all object fields that have null values from the given JSON value,\nrecursively. Null values that are not object fields are untouched. +[JSONB_TO_RECORD] +declaration=jsonb +category=JSON Functions +description=Expands the top-level JSON object to a row having the composite type\ndefined by an AS clause. (As with all functions returning record, the\ncalling query must explicitly define the structure of the record with an AS\nclause.) The output record is filled from fields of the JSON object, in the\nsame way as described above for json[b]_populate_record. Since there is no\ninput record value, unmatched columns are always filled with nulls. +[JSONB_TO_RECORDSET] +declaration=jsonb +category=JSON Functions +description=Expands the top-level JSON array of objects to a set of rows having the\ncomposite type defined by an AS clause. (As with all functions returning\nrecord, the calling query must explicitly define the structure of the\nrecord with an AS clause.) Each element of the JSON array is processed as\ndescribed above for json[b]_populate_record. +[JSONB_TO_TSVECTOR] +declaration=[ config regconfig, ] document jsonb, filter jsonb +category=Text Search Functions +description=Selects each item in the JSON document that is requested by the filter and\nconverts each one to a tsvector, normalizing words according to the\nspecified or default configuration. The results are then concatenated in\ndocument order to produce the output. Position information is generated as\nthough one stopword exists between each pair of selected items. (Beware\nthat "document order" of the fields of a JSON object is\nimplementation-dependent when the input is jsonb.) The filter must be a\njsonb array containing zero or more of these keywords: "string" (to include\nall string values), "numeric" (to include all numeric values), "boolean"\n(to include all boolean values), "key" (to include all keys), or "all" (to\ninclude all the above). As a special case, the filter can also be a simple\nJSON value that is one of these keywords. +[JSONB_TYPEOF] +declaration=jsonb +category=JSON Functions +description=Returns the type of the top-level JSON value as a text string. Possible\ntypes are object, array, string, number, boolean, and null. (The null\nresult should not be confused with an SQL NULL; see the examples.) +[JSON_ARRAYAGG] +declaration=[ value_expression ] [ ORDER BY sort_expression ] [ { NULL | ABSENT } ON NULL ] [ RETURNING data_type [ FORMAT JSON [ ENCODING UTF8 ] ] ] +category=Aggregate Functions +description=Behaves in the same way as json_array but as an aggregate function so it\nonly takes one value_expression parameter. If ABSENT ON NULL is specified,\nany NULL values are omitted. If ORDER BY is specified, the elements will\nappear in the array in that order rather than in the input order. +[JSON_OBJECT] +declaration=[ { key_expression { VALUE | ':' } value_expression [ FORMAT JSON [ ENCODING UTF8 ] ] }[, ...] ] [ { NULL | ABSENT } ON NULL ] [ { WITH | WITHOUT } UNIQUE [ KEYS ] ] [ RETURNING data_type [ FORMAT JSON [ ENCODING UTF8 ] ] ] +category=JSON Functions +description=Constructs a JSON object of all the key/value pairs given, or an empty\nobject if none are given. key_expression is a scalar expression defining\nthe JSON key, which is converted to the text type. It cannot be NULL nor\ncan it belong to a type that has a cast to the json type. If WITH UNIQUE\nKEYS is specified, there must not be any duplicate key_expression. Any pair\nfor which the value_expression evaluates to NULL is omitted from the output\nif ABSENT ON NULL is specified; if NULL ON NULL is specified or the clause\nomitted, the key is included with value NULL. +[JSON_OBJECTAGG] +declaration=[ { key_expression { VALUE | ':' } value_expression } ] [ { NULL | ABSENT } ON NULL ] [ { WITH | WITHOUT } UNIQUE [ KEYS ] ] [ RETURNING data_type [ FORMAT JSON [ ENCODING UTF8 ] ] ] +category=Aggregate Functions +description=Behaves like json_object, but as an aggregate function, so it only takes\none key_expression and one value_expression parameter. +[JSON_SCALAR] +declaration=expression +category=JSON Functions +description=Converts a given SQL scalar value into a JSON scalar value. If the input is\nNULL, an SQL null is returned. If the input is number or a boolean value, a\ncorresponding JSON number or boolean value is returned. For any other\nvalue, a JSON string is returned. +[JUSTIFY_DAYS] +declaration=interval +category=Date/Time Functions +description=Adjust interval, converting 30-day time periods to months +[JUSTIFY_HOURS] +declaration=interval +category=Date/Time Functions +description=Adjust interval, converting 24-hour time periods to days +[JUSTIFY_INTERVAL] +declaration=interval +category=Date/Time Functions +description=Adjust interval using justify_days and justify_hours, with additional sign\nadjustments +[LAG] +declaration=value anycompatible [, offset integer [, default anycompatible ]] +category=Window Functions +description=Returns value evaluated at the row that is offset rows before the current\nrow within the partition; if there is no such row, instead returns default\n(which must be of a type compatible with value). Both offset and default\nare evaluated with respect to the current row. If omitted, offset defaults\nto 1 and default to NULL. +[LASTVAL] +declaration= +category=Sequence Manipulation Functions +description=Returns the value most recently returned by nextval in the current session.\nThis function is identical to currval, except that instead of taking the\nsequence name as an argument it refers to whichever sequence nextval was\nmost recently applied to in the current session. It is an error to call\nlastval if nextval has not yet been called in the current session. +[LAST_VALUE] +declaration=value anyelement +category=Window Functions +description=Returns value evaluated at the row that is the last row of the window\nframe. +[LCM] +declaration=numeric_type, numeric_type +category=Numeric/Math Functions +description=Least common multiple (the smallest strictly positive number that is an\nintegral multiple of both inputs); returns 0 if either input is zero;\navailable for integer, bigint, and numeric +[LEAD] +declaration=value anycompatible [, offset integer [, default anycompatible ]] +category=Window Functions +description=Returns value evaluated at the row that is offset rows after the current\nrow within the partition; if there is no such row, instead returns default\n(which must be of a type compatible with value). Both offset and default\nare evaluated with respect to the current row. If omitted, offset defaults\nto 1 and default to NULL. +[LEFT] +declaration=string text, n integer +category=String Functions +description=Returns first n characters in the string, or when n is negative, returns\nall but last |n| characters. +[LENGTH1] +name=LENGTH +declaration=text +category=String Functions +description=Returns the number of characters in the string. +[LENGTH2] +name=LENGTH +declaration=geometric_type +category=Geometric Functions +description=Computes the total length. Available for lseg, path. +[LENGTH3] +name=LENGTH +declaration=tsvector +category=Text Search Functions +description=Returns the number of lexemes in the tsvector. +[LINE] +declaration=point, point +category=Geometric Functions +description=Converts two points to the line through them. +[LOWER1] +name=LOWER +declaration=text +category=String Functions +description=Converts the string to all lower case, according to the rules of the\ndatabase's locale. +[LOWER2] +name=LOWER +declaration=anyrange +category=Range Functions +description=Extracts the lower bound of the range (NULL if the range is empty or has no\nlower bound). +[LOWER3] +name=LOWER +declaration=anymultirange +category=Range Functions +description=Extracts the lower bound of the multirange (NULL if the multirange is empty\nhas no lower bound). +[LOWER_INC1] +name=LOWER_INC +declaration=anyrange +category=Range Functions +description=Is the range's lower bound inclusive? +[LOWER_INC2] +name=LOWER_INC +declaration=anymultirange +category=Range Functions +description=Is the multirange's lower bound inclusive? +[LOWER_INF1] +name=LOWER_INF +declaration=anyrange +category=Range Functions +description=Does the range have no lower bound? (A lower bound of -Infinity returns\nfalse.) +[LOWER_INF2] +name=LOWER_INF +declaration=anymultirange +category=Range Functions +description=Does the multirange have no lower bound? (A lower bound of -Infinity\nreturns false.) +[LPAD] +declaration=string text, length integer [, fill text ] +category=String Functions +description=Extends the string to length length by prepending the characters fill (a\nspace by default). If the string is already longer than length then it is\ntruncated (on the right). +[LSEG] +declaration=box +category=Geometric Functions +description=Extracts box's diagonal as a line segment. +[LTRIM1] +name=LTRIM +declaration=string text [, characters text ] +category=String Functions +description=Removes the longest string containing only characters in characters (a\nspace by default) from the start of string. +[LTRIM2] +name=LTRIM +declaration=bytes bytea, bytesremoved bytea +category=Binary String Functions +description=Removes the longest string containing only bytes appearing in bytesremoved\nfrom the start of bytes. +[MACADDR8_SET7BIT] +declaration=macaddr8 +category=Network Address Functions +description=Sets the 7th bit of the address to one, creating what is known as modified\nEUI-64, for inclusion in an IPv6 address. +[MAKEACLITEM] +declaration=grantee oid, grantor oid, privileges text, is_grantable boolean +category=Session Information Functions +description=Constructs an aclitem with the given properties. privileges is a\ncomma-separated list of privilege names such as SELECT, INSERT, etc, all of\nwhich are set in the result. (Case of the privilege string is not\nsignificant, and extra whitespace is allowed between but not within\nprivilege names.) +[MAKE_DATE] +declaration=year int, month int, day int +category=Date/Time Functions +description=Create date from year, month and day fields (negative years signify BC) +[MAKE_INTERVAL] +declaration=[ years int [, months int [, weeks int [, days int [, hours int [, mins int [, secs double precision ]]]]]]] +category=Date/Time Functions +description=Create interval from years, months, weeks, days, hours, minutes and seconds\nfields, each of which can default to zero +[MAKE_TIME] +declaration=hour int, min int, sec double precision +category=Date/Time Functions +description=Create time from hour, minute and seconds fields +[MAKE_TIMESTAMP] +declaration=year int, month int, day int, hour int, min int, sec double precision +category=Date/Time Functions +description=Create timestamp from year, month, day, hour, minute and seconds fields\n(negative years signify BC) +[MAKE_TIMESTAMPTZ] +declaration=year int, month int, day int, hour int, min int, sec double precision [, timezone text ] +category=Date/Time Functions +description=Create timestamp with time zone from year, month, day, hour, minute and\nseconds fields (negative years signify BC). If timezone is not specified,\nthe current time zone is used; the examples assume the session time zone is\nEurope/London +[MASKLEN] +declaration=inet +category=Network Address Functions +description=Returns the netmask length in bits. +[MAX] +declaration=see text +category=Aggregate Functions +description=Computes the maximum of the non-null input values. Available for any\nnumeric, string, date/time, or enum type, as well as inet, interval, money,\noid, pg_lsn, tid, xid8, and arrays of any of these types. +[MD51] +name=MD5 +declaration=text +category=String Functions +description=Computes the MD5 hash of the argument, with the result written in\nhexadecimal. +[MD52] +name=MD5 +declaration=bytea +category=Binary String Functions +description=Computes the MD5 hash of the binary string, with the result written in\nhexadecimal. +[MERGE_ACTION] +declaration= +category=Merge Support Functions +description=Returns the merge action command executed for the current row. This will be\n'INSERT', 'UPDATE', or 'DELETE'. +[MIN] +declaration=see text +category=Aggregate Functions +description=Computes the minimum of the non-null input values. Available for any\nnumeric, string, date/time, or enum type, as well as inet, interval, money,\noid, pg_lsn, tid, xid8, and arrays of any of these types. +[MIN_SCALE] +declaration=numeric +category=Numeric/Math Functions +description=Minimum scale (number of fractional decimal digits) needed to represent the\nsupplied value precisely +[MOD] +declaration=y numeric_type, x numeric_type +category=Numeric/Math Functions +description=Remainder of y/x; available for smallint, integer, bigint, and numeric +[MODE] +declaration= +category=Aggregate Functions +description=Computes the mode, the most frequent value of the aggregated argument\n(arbitrarily choosing the first one if there are multiple equally-frequent\nvalues). The aggregated argument must be of a sortable type. +[MULTIRANGE] +declaration=anyrange +category=Range Functions +description=Returns a multirange containing just the given range. +[MXID_AGE] +declaration=xid +category=Session Information Functions +description=Returns the number of multixacts IDs between the supplied multixact ID and\nthe current multixacts counter. +[NETMASK] +declaration=inet +category=Network Address Functions +description=Computes the network mask for the address's network. +[NETWORK] +declaration=inet +category=Network Address Functions +description=Returns the network part of the address, zeroing out whatever is to the\nright of the netmask. (This is equivalent to casting the value to cidr.) +[NEXTVAL] +declaration=regclass +category=Sequence Manipulation Functions +description=Advances the sequence object to its next value and returns that value. This\nis done atomically: even if multiple sessions execute nextval concurrently,\neach will safely receive a distinct sequence value. If the sequence object\nhas been created with default parameters, successive nextval calls will\nreturn successive values beginning with 1. Other behaviors can be obtained\nby using appropriate parameters in the CREATE SEQUENCE command. +[NOW] +declaration= +category=Date/Time Functions +description=Current date and time (start of current transaction); see Section 9.9.5 +[NPOINTS] +declaration=geometric_type +category=Geometric Functions +description=Returns the number of points. Available for path, polygon. +[NTH_VALUE] +declaration=value anyelement, n integer +category=Window Functions +description=Returns value evaluated at the row that is the n'th row of the window frame\n(counting from 1); returns NULL if there is no such row. +[NTILE] +declaration=num_buckets integer +category=Window Functions +description=Returns an integer ranging from 1 to the argument value, dividing the\npartition as equally as possible. +[NUMNODE] +declaration=tsquery +category=Text Search Functions +description=Returns the number of lexemes plus operators in the tsquery. +[OBJ_DESCRIPTION] +declaration=object oid, catalog name +category=Session Information Functions +description=Returns the comment for a database object specified by its OID and the name\nof the containing system catalog. For example, obj_description(123456,\n'pg_class') would retrieve the comment for the table with OID 123456. +[OCTET_LENGTH1] +name=OCTET_LENGTH +declaration=text +category=String Functions +description=Returns number of bytes in the string. +[OCTET_LENGTH2] +name=OCTET_LENGTH +declaration=character +category=String Functions +description=Returns number of bytes in the string. Since this version of the function\naccepts type character directly, it will not strip trailing spaces. +[OCTET_LENGTH3] +name=OCTET_LENGTH +declaration=bytea +category=Binary String Functions +description=Returns number of bytes in the binary string. +[OCTET_LENGTH4] +name=OCTET_LENGTH +declaration=bit +category=Bit String Functions +description=Returns number of bytes in the bit string. +[OVERLAY1] +name=OVERLAY +declaration=string text PLACING newsubstring text FROM start integer [ FOR count integer ] +category=String Functions +description=Replaces the substring of string that starts at the start'th character and\nextends for count characters with newsubstring. If count is omitted, it\ndefaults to the length of newsubstring. +[OVERLAY2] +name=OVERLAY +declaration=bytes bytea PLACING newsubstring bytea FROM start integer [ FOR count integer ] +category=Binary String Functions +description=Replaces the substring of bytes that starts at the start'th byte and\nextends for count bytes with newsubstring. If count is omitted, it defaults\nto the length of newsubstring. +[OVERLAY3] +name=OVERLAY +declaration=bits bit PLACING newsubstring bit FROM start integer [ FOR count integer ] +category=Bit String Functions +description=Replaces the substring of bits that starts at the start'th bit and extends\nfor count bits with newsubstring. If count is omitted, it defaults to the\nlength of newsubstring. +[PARSE_IDENT] +declaration=qualified_identifier text [, strict_mode boolean DEFAULT true ] +category=String Functions +description=Splits qualified_identifier into an array of identifiers, removing any\nquoting of individual identifiers. By default, extra characters after the\nlast identifier are considered an error; but if the second parameter is\nfalse, then such extra characters are ignored. (This behavior is useful for\nparsing names for objects like functions.) Note that this function does not\ntruncate over-length identifiers. If you want truncation you can cast the\nresult to name[]. +[PATH] +declaration=polygon +category=Geometric Functions +description=Converts polygon to a closed path with the same list of points. +[PCLOSE] +declaration=path +category=Geometric Functions +description=Converts path to closed form. +[PERCENTILE_DISC] +declaration=fraction double precision +category=Aggregate Functions +description=Computes the discrete percentile, the first value within the ordered set of\naggregated argument values whose position in the ordering equals or exceeds\nthe specified fraction. The aggregated argument must be of a sortable type. +[PERCENT_RANK1] +name=PERCENT_RANK +declaration=args +category=Aggregate Functions +description=Computes the relative rank of the hypothetical row, that is (rank - 1) /\n(total rows - 1). The value thus ranges from 0 to 1 inclusive. +[PERCENT_RANK2] +name=PERCENT_RANK +declaration= +category=Window Functions +description=Returns the relative rank of the current row, that is (rank - 1) / (total\npartition rows - 1). The value thus ranges from 0 to 1 inclusive. +[PG_ADVISORY_UNLOCK_ALL] +declaration= +category=System Administration Functions +description=Releases all session-level advisory locks held by the current session.\n(This function is implicitly invoked at session end, even if the client\ndisconnects ungracefully.) +[PG_AVAILABLE_WAL_SUMMARIES] +declaration= +category=Session Information Functions +description=Returns information about the WAL summary files present in the data\ndirectory, under pg_wal/summaries. One row will be returned per WAL summary\nfile. Each file summarizes WAL on the indicated TLI within the indicated\nLSN range. This function might be useful to determine whether enough WAL\nsummaries are present on the server to take an incremental backup based on\nsome prior backup whose start LSN is known. +[PG_BACKEND_PID] +declaration= +category=Session Information Functions +description=Returns the process ID of the server process attached to the current\nsession. +[PG_BACKUP_START] +declaration=label text [, fast boolean ] +category=System Administration Functions +description=Prepares the server to begin an on-line backup. The only required parameter\nis an arbitrary user-defined label for the backup. (Typically this would be\nthe name under which the backup dump file will be stored.) If the optional\nsecond parameter is given as true, it specifies executing pg_backup_start\nas quickly as possible. This forces an immediate checkpoint which will\ncause a spike in I/O operations, slowing any concurrently executing\nqueries. +[PG_BACKUP_STOP] +declaration=[wait_for_archive boolean ] +category=System Administration Functions +description=Finishes performing an on-line backup. The desired contents of the backup\nlabel file and the tablespace map file are returned as part of the result\nof the function and must be written to files in the backup area. These\nfiles must not be written to the live data directory (doing so will cause\nPostgreSQL to fail to restart in the event of a crash). +[PG_BASETYPE] +declaration=regtype +category=Session Information Functions +description=Returns the OID of the base type of a domain identified by its type OID. If\nthe argument is the OID of a non-domain type, returns the argument as-is.\nReturns NULL if the argument is not a valid type OID. If there's a chain of\ndomain dependencies, it will recurse until finding the base type. +[PG_BLOCKING_PIDS] +declaration=integer +category=Session Information Functions +description=Returns an array of the process ID(s) of the sessions that are blocking the\nserver process with the specified process ID from acquiring a lock, or an\nempty array if there is no such server process or it is not blocked. +[PG_CANCEL_BACKEND] +declaration=pid integer +category=System Administration Functions +description=Cancels the current query of the session whose backend process has the\nspecified process ID. This is also allowed if the calling role is a member\nof the role whose backend is being canceled or the calling role has\nprivileges of pg_signal_backend, however only superusers can cancel\nsuperuser backends. +[PG_CHAR_TO_ENCODING] +declaration=encoding name +category=Session Information Functions +description=Converts the supplied encoding name into an integer representing the\ninternal identifier used in some system catalog tables. Returns -1 if an\nunknown encoding name is provided. +[PG_CLIENT_ENCODING] +declaration= +category=String Functions +description=Returns current client encoding name. +[PG_COLLATION_ACTUAL_VERSION] +declaration=oid +category=System Administration Functions +description=Returns the actual version of the collation object as it is currently\ninstalled in the operating system. If this is different from the value in\npg_collation.collversion, then objects depending on the collation might\nneed to be rebuilt. See also ALTER COLLATION. +[PG_COLLATION_IS_VISIBLE] +declaration=collation oid +category=Session Information Functions +description=Is collation visible in search path? +[PG_COLUMN_COMPRESSION] +declaration="any" +category=System Administration Functions +description=Shows the compression algorithm that was used to compress an individual\nvariable-length value. Returns NULL if the value is not compressed. +[PG_COLUMN_SIZE] +declaration="any" +category=System Administration Functions +description=Shows the number of bytes used to store any individual data value. If\napplied directly to a table column value, this reflects any compression\nthat was done. +[PG_COLUMN_TOAST_CHUNK_ID] +declaration="any" +category=System Administration Functions +description=Shows the chunk_id of an on-disk TOASTed value. Returns NULL if the value\nis un-TOASTed or not on-disk. See Section 65.2 for more information about\nTOAST. +[PG_CONF_LOAD_TIME] +declaration= +category=Session Information Functions +description=Returns the time when the server configuration files were last loaded. If\nthe current session was alive at the time, this will be the time when the\nsession itself re-read the configuration files (so the reading will vary a\nlittle in different sessions). Otherwise it is the time when the postmaster\nprocess re-read the configuration files. +[PG_CONTROL_CHECKPOINT] +declaration= +category=Session Information Functions +description=Returns information about current checkpoint state, as shown in Table 9.87. +[PG_CONTROL_INIT] +declaration= +category=Session Information Functions +description=Returns information about cluster initialization state, as shown in Table\n9.89. +[PG_CONTROL_RECOVERY] +declaration= +category=Session Information Functions +description=Returns information about recovery state, as shown in Table 9.90. +[PG_CONTROL_SYSTEM] +declaration= +category=Session Information Functions +description=Returns information about current control file state, as shown in Table\n9.88. +[PG_CONVERSION_IS_VISIBLE] +declaration=conversion oid +category=Session Information Functions +description=Is conversion visible in search path? +[PG_COPY_LOGICAL_REPLICATION_SLOT] +declaration=src_slot_name name, dst_slot_name name [, temporary boolean [, plugin name ]] +category=System Administration Functions +description=Copies an existing logical replication slot named src_slot_name to a\nlogical replication slot named dst_slot_name, optionally changing the\noutput plugin and persistence. The copied logical slot starts from the same\nLSN as the source logical slot. Both temporary and plugin are optional; if\nthey are omitted, the values of the source slot are used. +[PG_COPY_PHYSICAL_REPLICATION_SLOT] +declaration=src_slot_name name, dst_slot_name name [, temporary boolean ] +category=System Administration Functions +description=Copies an existing physical replication slot named src_slot_name to a\nphysical replication slot named dst_slot_name. The copied physical slot\nstarts to reserve WAL from the same LSN as the source slot. temporary is\noptional. If temporary is omitted, the same value as the source slot is\nused. +[PG_CREATE_LOGICAL_REPLICATION_SLOT] +declaration=slot_name name, plugin name [, temporary boolean, twophase boolean, failover boolean ] +category=System Administration Functions +description=Creates a new logical (decoding) replication slot named slot_name using the\noutput plugin plugin. The optional third parameter, temporary, when set to\ntrue, specifies that the slot should not be permanently stored to disk and\nis only meant for use by the current session. Temporary slots are also\nreleased upon any error. The optional fourth parameter, twophase, when set\nto true, specifies that the decoding of prepared transactions is enabled\nfor this slot. The optional fifth parameter, failover, when set to true,\nspecifies that this slot is enabled to be synced to the standbys so that\nlogical replication can be resumed after failover. A call to this function\nhas the same effect as the replication protocol command\nCREATE_REPLICATION_SLOT ... LOGICAL. +[PG_CREATE_PHYSICAL_REPLICATION_SLOT] +declaration=slot_name name [, immediately_reserve boolean, temporary boolean ] +category=System Administration Functions +description=Creates a new physical replication slot named slot_name. The optional\nsecond parameter, when true, specifies that the LSN for this replication\nslot be reserved immediately; otherwise the LSN is reserved on first\nconnection from a streaming replication client. Streaming changes from a\nphysical slot is only possible with the streaming-replication protocol -\nsee Section 53.4. The optional third parameter, temporary, when set to\ntrue, specifies that the slot should not be permanently stored to disk and\nis only meant for use by the current session. Temporary slots are also\nreleased upon any error. This function corresponds to the replication\nprotocol command CREATE_REPLICATION_SLOT ... PHYSICAL. +[PG_CREATE_RESTORE_POINT] +declaration=name text +category=System Administration Functions +description=Creates a named marker record in the write-ahead log that can later be used\nas a recovery target, and returns the corresponding write-ahead log\nlocation. The given name can then be used with recovery_target_name to\nspecify the point up to which recovery will proceed. Avoid creating\nmultiple restore points with the same name, since recovery will stop at the\nfirst one whose name matches the recovery target. +[PG_CURRENT_SNAPSHOT] +declaration= +category=Session Information Functions +description=Returns a current snapshot, a data structure showing which transaction IDs\nare now in-progress. Only top-level transaction IDs are included in the\nsnapshot; subtransaction IDs are not shown; see Section 66.3 for details. +[PG_CURRENT_WAL_FLUSH_LSN] +declaration= +category=System Administration Functions +description=Returns the current write-ahead log flush location (see notes below). +[PG_CURRENT_WAL_INSERT_LSN] +declaration= +category=System Administration Functions +description=Returns the current write-ahead log insert location (see notes below). +[PG_CURRENT_WAL_LSN] +declaration= +category=System Administration Functions +description=Returns the current write-ahead log write location (see notes below). +[PG_CURRENT_XACT_ID] +declaration= +category=Session Information Functions +description=Returns the current transaction's ID. It will assign a new one if the\ncurrent transaction does not have one already (because it has not performed\nany database updates); see Section 66.1 for details. If executed in a\nsubtransaction, this will return the top-level transaction ID; see Section\n66.3 for details. +[PG_CURRENT_XACT_ID_IF_ASSIGNED] +declaration= +category=Session Information Functions +description=Returns the current transaction's ID, or NULL if no ID is assigned yet.\n(It's best to use this variant if the transaction might otherwise be\nread-only, to avoid unnecessary consumption of an XID.) If executed in a\nsubtransaction, this will return the top-level transaction ID. +[PG_DATABASE_COLLATION_ACTUAL_VERSION] +declaration=oid +category=System Administration Functions +description=Returns the actual version of the database's collation as it is currently\ninstalled in the operating system. If this is different from the value in\npg_database.datcollversion, then objects depending on the collation might\nneed to be rebuilt. See also ALTER DATABASE. +[PG_DESCRIBE_OBJECT] +declaration=classid oid, objid oid, objsubid integer +category=Session Information Functions +description=Returns a textual description of a database object identified by catalog\nOID, object OID, and sub-object ID (such as a column number within a table;\nthe sub-object ID is zero when referring to a whole object). This\ndescription is intended to be human-readable, and might be translated,\ndepending on server configuration. This is especially useful to determine\nthe identity of an object referenced in the pg_depend catalog. This\nfunction returns NULL values for undefined objects. +[PG_DROP_REPLICATION_SLOT] +declaration=slot_name name +category=System Administration Functions +description=Drops the physical or logical replication slot named slot_name. Same as\nreplication protocol command DROP_REPLICATION_SLOT. For logical slots, this\nmust be called while connected to the same database the slot was created\non. +[PG_ENCODING_TO_CHAR] +declaration=encoding integer +category=Session Information Functions +description=Converts the integer used as the internal identifier of an encoding in some\nsystem catalog tables into a human-readable string. Returns an empty string\nif an invalid encoding number is provided. +[PG_EXPORT_SNAPSHOT] +declaration= +category=System Administration Functions +description=Saves the transaction's current snapshot and returns a text string\nidentifying the snapshot. This string must be passed (outside the database)\nto clients that want to import the snapshot. The snapshot is available for\nimport only until the end of the transaction that exported it. +[PG_FILENODE_RELATION] +declaration=tablespace oid, filenode oid +category=System Administration Functions +description=Returns a relation's OID given the tablespace OID and filenode it is stored\nunder. This is essentially the inverse mapping of pg_relation_filepath. For\na relation in the database's default tablespace, the tablespace can be\nspecified as zero. Returns NULL if no relation in the current database is\nassociated with the given values. +[PG_FUNCTION_IS_VISIBLE] +declaration=function oid +category=Session Information Functions +description=Is function visible in search path? (This also works for procedures and\naggregates.) +[PG_GET_CATALOG_FOREIGN_KEYS] +declaration= +category=Session Information Functions +description=Returns a set of records describing the foreign key relationships that\nexist within the PostgreSQL system catalogs. The fktable column contains\nthe name of the referencing catalog, and the fkcols column contains the\nname(s) of the referencing column(s). Similarly, the pktable column\ncontains the name of the referenced catalog, and the pkcols column contains\nthe name(s) of the referenced column(s). If is_array is true, the last\nreferencing column is an array, each of whose elements should match some\nentry in the referenced catalog. If is_opt is true, the referencing\ncolumn(s) are allowed to contain zeroes instead of a valid reference. +[PG_GET_CONSTRAINTDEF] +declaration=constraint oid [, pretty boolean ] +category=Session Information Functions +description=Reconstructs the creating command for a constraint. (This is a decompiled\nreconstruction, not the original text of the command.) +[PG_GET_EXPR] +declaration=expr pg_node_tree, relation oid [, pretty boolean ] +category=Session Information Functions +description=Decompiles the internal form of an expression stored in the system\ncatalogs, such as the default value for a column. If the expression might\ncontain Vars, specify the OID of the relation they refer to as the second\nparameter; if no Vars are expected, passing zero is sufficient. +[PG_GET_FUNCTIONDEF] +declaration=func oid +category=Session Information Functions +description=Reconstructs the creating command for a function or procedure. (This is a\ndecompiled reconstruction, not the original text of the command.) The\nresult is a complete CREATE OR REPLACE FUNCTION or CREATE OR REPLACE\nPROCEDURE statement. +[PG_GET_FUNCTION_ARGUMENTS] +declaration=func oid +category=Session Information Functions +description=Reconstructs the argument list of a function or procedure, in the form it\nwould need to appear in within CREATE FUNCTION (including default values). +[PG_GET_FUNCTION_IDENTITY_ARGUMENTS] +declaration=func oid +category=Session Information Functions +description=Reconstructs the argument list necessary to identify a function or\nprocedure, in the form it would need to appear in within commands such as\nALTER FUNCTION. This form omits default values. +[PG_GET_FUNCTION_RESULT] +declaration=func oid +category=Session Information Functions +description=Reconstructs the RETURNS clause of a function, in the form it would need to\nappear in within CREATE FUNCTION. Returns NULL for a procedure. +[PG_GET_INDEXDEF] +declaration=index oid [, column integer, pretty boolean ] +category=Session Information Functions +description=Reconstructs the creating command for an index. (This is a decompiled\nreconstruction, not the original text of the command.) If column is\nsupplied and is not zero, only the definition of that column is\nreconstructed. +[PG_GET_KEYWORDS] +declaration= +category=Session Information Functions +description=Returns a set of records describing the SQL keywords recognized by the\nserver. The word column contains the keyword. The catcode column contains a\ncategory code: U for an unreserved keyword, C for a keyword that can be a\ncolumn name, T for a keyword that can be a type or function name, or R for\na fully reserved keyword. The barelabel column contains true if the keyword\ncan be used as a "bare" column label in SELECT lists, or false if it can\nonly be used after AS. The catdesc column contains a possibly-localized\nstring describing the keyword's category. The baredesc column contains a\npossibly-localized string describing the keyword's column label status. +[PG_GET_OBJECT_ADDRESS] +declaration=type text, object_names text[], object_args text[] +category=Session Information Functions +description=Returns a row containing enough information to uniquely identify the\ndatabase object specified by a type code and object name and argument\narrays. The returned values are the ones that would be used in system\ncatalogs such as pg_depend; they can be passed to other system functions\nsuch as pg_describe_object or pg_identify_object. classid is the OID of the\nsystem catalog containing the object; objid is the OID of the object\nitself, and objsubid is the sub-object ID, or zero if none. This function\nis the inverse of pg_identify_object_as_address. Undefined objects are\nidentified with NULL values. +[PG_GET_PARTKEYDEF] +declaration=table oid +category=Session Information Functions +description=Reconstructs the definition of a partitioned table's partition key, in the\nform it would have in the PARTITION BY clause of CREATE TABLE. (This is a\ndecompiled reconstruction, not the original text of the command.) +[PG_GET_RULEDEF] +declaration=rule oid [, pretty boolean ] +category=Session Information Functions +description=Reconstructs the creating command for a rule. (This is a decompiled\nreconstruction, not the original text of the command.) +[PG_GET_SERIAL_SEQUENCE] +declaration=table text, column text +category=Session Information Functions +description=Returns the name of the sequence associated with a column, or NULL if no\nsequence is associated with the column. If the column is an identity\ncolumn, the associated sequence is the sequence internally created for that\ncolumn. For columns created using one of the serial types (serial,\nsmallserial, bigserial), it is the sequence created for that serial column\ndefinition. In the latter case, the association can be modified or removed\nwith ALTER SEQUENCE OWNED BY. (This function probably should have been\ncalled pg_get_owned_sequence; its current name reflects the fact that it\nhas historically been used with serial-type columns.) The first parameter\nis a table name with optional schema, and the second parameter is a column\nname. Because the first parameter potentially contains both schema and\ntable names, it is parsed per usual SQL rules, meaning it is lower-cased by\ndefault. The second parameter, being just a column name, is treated\nliterally and so has its case preserved. The result is suitably formatted\nfor passing to the sequence functions (see Section 9.17). +[PG_GET_STATISTICSOBJDEF] +declaration=statobj oid +category=Session Information Functions +description=Reconstructs the creating command for an extended statistics object. (This\nis a decompiled reconstruction, not the original text of the command.) +[PG_GET_TRIGGERDEF] +declaration=trigger oid [, pretty boolean ] +category=Session Information Functions +description=Reconstructs the creating command for a trigger. (This is a decompiled\nreconstruction, not the original text of the command.) +[PG_GET_USERBYID] +declaration=role oid +category=Session Information Functions +description=Returns a role's name given its OID. +[PG_GET_VIEWDEF] +declaration=view oid [, pretty boolean ] +category=Session Information Functions +description=Reconstructs the underlying SELECT command for a view or materialized view.\n(This is a decompiled reconstruction, not the original text of the\ncommand.) +[PG_GET_WAL_REPLAY_PAUSE_STATE] +declaration= +category=System Administration Functions +description=Returns recovery pause state. The return values are not paused if pause is\nnot requested, pause requested if pause is requested but recovery is not\nyet paused, and paused if the recovery is actually paused. +[PG_GET_WAL_RESOURCE_MANAGERS] +declaration= +category=System Administration Functions +description=Returns the currently-loaded WAL resource managers in the system. The\ncolumn rm_builtin indicates whether it's a built-in resource manager, or a\ncustom resource manager loaded by an extension. +[PG_GET_WAL_SUMMARIZER_STATE] +declaration= +category=Session Information Functions +description=Returns information about the progress of the WAL summarizer. If the WAL\nsummarizer has never run since the instance was started, then\nsummarized_tli and summarized_lsn will be 0 and 0/0 respectively;\notherwise, they will be the TLI and ending LSN of the last WAL summary file\nwritten to disk. If the WAL summarizer is currently running, pending_lsn\nwill be the ending LSN of the last record that it has consumed, which must\nalways be greater than or equal to summarized_lsn; if the WAL summarizer is\nnot running, it will be equal to summarized_lsn. summarizer_pid is the PID\nof the WAL summarizer process, if it is running, and otherwise NULL. +[PG_HAS_ROLE] +declaration=[ user name or oid, ] role text or oid, privilege text +category=Session Information Functions +description=Does user have privilege for role? Allowable privilege types are MEMBER,\nUSAGE, and SET. MEMBER denotes direct or indirect membership in the role\nwithout regard to what specific privileges may be conferred. USAGE denotes\nwhether the privileges of the role are immediately available without doing\nSET ROLE, while SET denotes whether it is possible to change to the role\nusing the SET ROLE command. WITH ADMIN OPTION or WITH GRANT OPTION can be\nadded to any of these privilege types to test whether the ADMIN privilege\nis held (all six spellings test the same thing). This function does not\nallow the special case of setting user to public, because the PUBLIC\npseudo-role can never be a member of real roles. +[PG_IDENTIFY_OBJECT] +declaration=classid oid, objid oid, objsubid integer +category=Session Information Functions +description=Returns a row containing enough information to uniquely identify the\ndatabase object specified by catalog OID, object OID and sub-object ID.\nThis information is intended to be machine-readable, and is never\ntranslated. type identifies the type of database object; schema is the\nschema name that the object belongs in, or NULL for object types that do\nnot belong to schemas; name is the name of the object, quoted if necessary,\nif the name (along with schema name, if pertinent) is sufficient to\nuniquely identify the object, otherwise NULL; identity is the complete\nobject identity, with the precise format depending on object type, and each\nname within the format being schema-qualified and quoted as necessary.\nUndefined objects are identified with NULL values. +[PG_IDENTIFY_OBJECT_AS_ADDRESS] +declaration=classid oid, objid oid, objsubid integer +category=Session Information Functions +description=Returns a row containing enough information to uniquely identify the\ndatabase object specified by catalog OID, object OID and sub-object ID. The\nreturned information is independent of the current server, that is, it\ncould be used to identify an identically named object in another server.\ntype identifies the type of database object; object_names and object_args\nare text arrays that together form a reference to the object. These three\nvalues can be passed to pg_get_object_address to obtain the internal\naddress of the object. +[PG_IMPORT_SYSTEM_COLLATIONS] +declaration=schema regnamespace +category=System Administration Functions +description=Adds collations to the system catalog pg_collation based on all the locales\nit finds in the operating system. This is what initdb uses; see Section\n23.2.2 for more details. If additional locales are installed into the\noperating system later on, this function can be run again to add collations\nfor the new locales. Locales that match existing entries in pg_collation\nwill be skipped. (But collation objects based on locales that are no longer\npresent in the operating system are not removed by this function.) The\nschema parameter would typically be pg_catalog, but that is not a\nrequirement; the collations could be installed into some other schema as\nwell. The function returns the number of new collation objects it created.\nUse of this function is restricted to superusers. +[PG_INDEXAM_HAS_PROPERTY] +declaration=am oid, property text +category=Session Information Functions +description=Tests whether an index access method has the named property. Access method\nproperties are listed in Table 9.77. NULL is returned if the property name\nis not known or does not apply to the particular object, or if the OID does\nnot identify a valid object. +[PG_INDEXES_SIZE] +declaration=regclass +category=System Administration Functions +description=Computes the total disk space used by indexes attached to the specified\ntable. +[PG_INDEX_COLUMN_HAS_PROPERTY] +declaration=index regclass, column integer, property text +category=Session Information Functions +description=Tests whether an index column has the named property. Common index column\nproperties are listed in Table 9.75. (Note that extension access methods\ncan define additional property names for their indexes.) NULL is returned\nif the property name is not known or does not apply to the particular\nobject, or if the OID or column number does not identify a valid object. +[PG_INDEX_HAS_PROPERTY] +declaration=index regclass, property text +category=Session Information Functions +description=Tests whether an index has the named property. Common index properties are\nlisted in Table 9.76. (Note that extension access methods can define\nadditional property names for their indexes.) NULL is returned if the\nproperty name is not known or does not apply to the particular object, or\nif the OID does not identify a valid object. +[PG_INPUT_ERROR_INFO] +declaration=string text, type text +category=Session Information Functions +description=Tests whether the given string is valid input for the specified data type;\nif not, return the details of the error that would have been thrown. If the\ninput is valid, the results are NULL. The inputs are the same as for\npg_input_is_valid. +[PG_INPUT_IS_VALID] +declaration=string text, type text +category=Session Information Functions +description=Tests whether the given string is valid input for the specified data type,\nreturning true or false. +[PG_IS_IN_RECOVERY] +declaration= +category=System Administration Functions +description=Returns true if recovery is still in progress. +[PG_IS_OTHER_TEMP_SCHEMA] +declaration=oid +category=Session Information Functions +description=Returns true if the given OID is the OID of another session's temporary\nschema. (This can be useful, for example, to exclude other sessions'\ntemporary tables from a catalog display.) +[PG_IS_WAL_REPLAY_PAUSED] +declaration= +category=System Administration Functions +description=Returns true if recovery pause is requested. +[PG_JIT_AVAILABLE] +declaration= +category=Session Information Functions +description=Returns true if a JIT compiler extension is available (see Chapter 30) and\nthe jit configuration parameter is set to on. +[PG_LAST_COMMITTED_XACT] +declaration= +category=Session Information Functions +description=Returns the transaction ID, commit timestamp and replication origin of the\nlatest committed transaction. +[PG_LAST_WAL_RECEIVE_LSN] +declaration= +category=System Administration Functions +description=Returns the last write-ahead log location that has been received and synced\nto disk by streaming replication. While streaming replication is in\nprogress this will increase monotonically. If recovery has completed then\nthis will remain static at the location of the last WAL record received and\nsynced to disk during recovery. If streaming replication is disabled, or if\nit has not yet started, the function returns NULL. +[PG_LAST_WAL_REPLAY_LSN] +declaration= +category=System Administration Functions +description=Returns the last write-ahead log location that has been replayed during\nrecovery. If recovery is still in progress this will increase\nmonotonically. If recovery has completed then this will remain static at\nthe location of the last WAL record applied during recovery. When the\nserver has been started normally without recovery, the function returns\nNULL. +[PG_LAST_XACT_REPLAY_TIMESTAMP] +declaration= +category=System Administration Functions +description=Returns the time stamp of the last transaction replayed during recovery.\nThis is the time at which the commit or abort WAL record for that\ntransaction was generated on the primary. If no transactions have been\nreplayed during recovery, the function returns NULL. Otherwise, if recovery\nis still in progress this will increase monotonically. If recovery has\ncompleted then this will remain static at the time of the last transaction\napplied during recovery. When the server has been started normally without\nrecovery, the function returns NULL. +[PG_LISTENING_CHANNELS] +declaration= +category=Session Information Functions +description=Returns the set of names of asynchronous notification channels that the\ncurrent session is listening to. +[PG_LOGICAL_SLOT_GET_BINARY_CHANGES] +declaration=slot_name name, upto_lsn pg_lsn, upto_nchanges integer, VARIADIC options text[] +category=System Administration Functions +description=Behaves just like the pg_logical_slot_get_changes() function, except that\nchanges are returned as bytea. +[PG_LOGICAL_SLOT_GET_CHANGES] +declaration=slot_name name, upto_lsn pg_lsn, upto_nchanges integer, VARIADIC options text[] +category=System Administration Functions +description=Returns changes in the slot slot_name, starting from the point from which\nchanges have been consumed last. If upto_lsn and upto_nchanges are NULL,\nlogical decoding will continue until end of WAL. If upto_lsn is non-NULL,\ndecoding will include only those transactions which commit prior to the\nspecified LSN. If upto_nchanges is non-NULL, decoding will stop when the\nnumber of rows produced by decoding exceeds the specified value. Note,\nhowever, that the actual number of rows returned may be larger, since this\nlimit is only checked after adding the rows produced when decoding each new\ntransaction commit. If the specified slot is a logical failover slot then\nthe function will not return until all physical slots specified in\nsynchronized_standby_slots have confirmed WAL receipt. +[PG_LOGICAL_SLOT_PEEK_BINARY_CHANGES] +declaration=slot_name name, upto_lsn pg_lsn, upto_nchanges integer, VARIADIC options text[] +category=System Administration Functions +description=Behaves just like the pg_logical_slot_peek_changes() function, except that\nchanges are returned as bytea. +[PG_LOGICAL_SLOT_PEEK_CHANGES] +declaration=slot_name name, upto_lsn pg_lsn, upto_nchanges integer, VARIADIC options text[] +category=System Administration Functions +description=Behaves just like the pg_logical_slot_get_changes() function, except that\nchanges are not consumed; that is, they will be returned again on future\ncalls. +[PG_LOG_BACKEND_MEMORY_CONTEXTS] +declaration=pid integer +category=System Administration Functions +description=Requests to log the memory contexts of the backend with the specified\nprocess ID. This function can send the request to backends and auxiliary\nprocesses except logger. These memory contexts will be logged at LOG\nmessage level. They will appear in the server log based on the log\nconfiguration set (see Section 19.8 for more information), but will not be\nsent to the client regardless of client_min_messages. +[PG_LOG_STANDBY_SNAPSHOT] +declaration= +category=System Administration Functions +description=Take a snapshot of running transactions and write it to WAL, without having\nto wait for bgwriter or checkpointer to log one. This is useful for logical\ndecoding on standby, as logical slot creation has to wait until such a\nrecord is replayed on the standby. +[PG_LS_ARCHIVE_STATUSDIR] +declaration= +category=System Administration Functions +description=Returns the name, size, and last modification time (mtime) of each ordinary\nfile in the server's WAL archive status directory (pg_wal/archive_status).\nFilenames beginning with a dot, directories, and other special files are\nexcluded. +[PG_LS_DIR] +declaration=dirname text [, missing_ok boolean, include_dot_dirs boolean ] +category=System Administration Functions +description=Returns the names of all files (and directories and other special files) in\nthe specified directory. The include_dot_dirs parameter indicates whether\n"." and ".." are to be included in the result set; the default is to\nexclude them. Including them can be useful when missing_ok is true, to\ndistinguish an empty directory from a non-existent directory. +[PG_LS_LOGDIR] +declaration= +category=System Administration Functions +description=Returns the name, size, and last modification time (mtime) of each ordinary\nfile in the server's log directory. Filenames beginning with a dot,\ndirectories, and other special files are excluded. +[PG_LS_LOGICALMAPDIR] +declaration= +category=System Administration Functions +description=Returns the name, size, and last modification time (mtime) of each ordinary\nfile in the server's pg_logical/mappings directory. Filenames beginning\nwith a dot, directories, and other special files are excluded. +[PG_LS_LOGICALSNAPDIR] +declaration= +category=System Administration Functions +description=Returns the name, size, and last modification time (mtime) of each ordinary\nfile in the server's pg_logical/snapshots directory. Filenames beginning\nwith a dot, directories, and other special files are excluded. +[PG_LS_REPLSLOTDIR] +declaration=slot_name text +category=System Administration Functions +description=Returns the name, size, and last modification time (mtime) of each ordinary\nfile in the server's pg_replslot/slot_name directory, where slot_name is\nthe name of the replication slot provided as input of the function.\nFilenames beginning with a dot, directories, and other special files are\nexcluded. +[PG_LS_TMPDIR] +declaration=[ tablespace oid ] +category=System Administration Functions +description=Returns the name, size, and last modification time (mtime) of each ordinary\nfile in the temporary file directory for the specified tablespace. If\ntablespace is not provided, the pg_default tablespace is examined.\nFilenames beginning with a dot, directories, and other special files are\nexcluded. +[PG_LS_WALDIR] +declaration= +category=System Administration Functions +description=Returns the name, size, and last modification time (mtime) of each ordinary\nfile in the server's write-ahead log (WAL) directory. Filenames beginning\nwith a dot, directories, and other special files are excluded. +[PG_MY_TEMP_SCHEMA] +declaration= +category=Session Information Functions +description=Returns the OID of the current session's temporary schema, or zero if it\nhas none (because it has not created any temporary tables). +[PG_NOTIFICATION_QUEUE_USAGE] +declaration= +category=Session Information Functions +description=Returns the fraction (0–1) of the asynchronous notification queue's\nmaximum size that is currently occupied by notifications that are waiting\nto be processed. See LISTEN and NOTIFY for more information. +[PG_OPCLASS_IS_VISIBLE] +declaration=opclass oid +category=Session Information Functions +description=Is operator class visible in search path? +[PG_OPERATOR_IS_VISIBLE] +declaration=operator oid +category=Session Information Functions +description=Is operator visible in search path? +[PG_OPFAMILY_IS_VISIBLE] +declaration=opclass oid +category=Session Information Functions +description=Is operator family visible in search path? +[PG_OPTIONS_TO_TABLE] +declaration=options_array text[] +category=Session Information Functions +description=Returns the set of storage options represented by a value from\npg_class.reloptions or pg_attribute.attoptions. +[PG_PARTITION_ANCESTORS] +declaration=regclass +category=System Administration Functions +description=Lists the ancestor relations of the given partition, including the relation\nitself. Returns no rows if the relation does not exist or is not a\npartition or partitioned table. +[PG_PARTITION_ROOT] +declaration=regclass +category=System Administration Functions +description=Returns the top-most parent of the partition tree to which the given\nrelation belongs. Returns NULL if the relation does not exist or is not a\npartition or partitioned table. +[PG_PARTITION_TREE] +declaration=regclass +category=System Administration Functions +description=Lists the tables or indexes in the partition tree of the given partitioned\ntable or partitioned index, with one row for each partition. Information\nprovided includes the OID of the partition, the OID of its immediate\nparent, a boolean value telling if the partition is a leaf, and an integer\ntelling its level in the hierarchy. The level value is 0 for the input\ntable or index, 1 for its immediate child partitions, 2 for their\npartitions, and so on. Returns no rows if the relation does not exist or is\nnot a partition or partitioned table. +[PG_POSTMASTER_START_TIME] +declaration= +category=Session Information Functions +description=Returns the time when the server started. +[PG_PROMOTE] +declaration=wait boolean DEFAULT true, wait_seconds integer DEFAULT 60 +category=System Administration Functions +description=Promotes a standby server to primary status. With wait set to true (the\ndefault), the function waits until promotion is completed or wait_seconds\nseconds have passed, and returns true if promotion is successful and false\notherwise. If wait is set to false, the function returns true immediately\nafter sending a SIGUSR1 signal to the postmaster to trigger promotion. +[PG_READ_BINARY_FILE] +declaration=filename text [, offset bigint, length bigint ] [, missing_ok boolean ] +category=System Administration Functions +description=Returns all or part of a file. This function is identical to pg_read_file\nexcept that it can read arbitrary binary data, returning the result as\nbytea not text; accordingly, no encoding checks are performed. +[PG_READ_FILE] +declaration=filename text [, offset bigint, length bigint ] [, missing_ok boolean ] +category=System Administration Functions +description=Returns all or part of a text file, starting at the given byte offset,\nreturning at most length bytes (less if the end of file is reached first).\nIf offset is negative, it is relative to the end of the file. If offset and\nlength are omitted, the entire file is returned. The bytes read from the\nfile are interpreted as a string in the database's encoding; an error is\nthrown if they are not valid in that encoding. +[PG_RELATION_FILENODE] +declaration=relation regclass +category=System Administration Functions +description=Returns the "filenode" number currently assigned to the specified relation.\nThe filenode is the base component of the file name(s) used for the\nrelation (see Section 65.1 for more information). For most relations the\nresult is the same as pg_class.relfilenode, but for certain system catalogs\nrelfilenode is zero and this function must be used to get the correct\nvalue. The function returns NULL if passed a relation that does not have\nstorage, such as a view. +[PG_RELATION_FILEPATH] +declaration=relation regclass +category=System Administration Functions +description=Returns the entire file path name (relative to the database cluster's data\ndirectory, PGDATA) of the relation. +[PG_RELATION_SIZE] +declaration=relation regclass [, fork text ] +category=System Administration Functions +description=Computes the disk space used by one "fork" of the specified relation. (Note\nthat for most purposes it is more convenient to use the higher-level\nfunctions pg_total_relation_size or pg_table_size, which sum the sizes of\nall forks.) With one argument, this returns the size of the main data fork\nof the relation. The second argument can be provided to specify which fork\nto examine: +[PG_RELOAD_CONF] +declaration= +category=System Administration Functions +description=Causes all processes of the PostgreSQL server to reload their configuration\nfiles. (This is initiated by sending a SIGHUP signal to the postmaster\nprocess, which in turn sends SIGHUP to each of its children.) You can use\nthe pg_file_settings, pg_hba_file_rules and pg_ident_file_mappings views to\ncheck the configuration files for possible errors, before reloading. +[PG_REPLICATION_ORIGIN_ADVANCE] +declaration=node_name text, lsn pg_lsn +category=System Administration Functions +description=Sets replication progress for the given node to the given location. This is\nprimarily useful for setting up the initial location, or setting a new\nlocation after configuration changes and similar. Be aware that careless\nuse of this function can lead to inconsistently replicated data. +[PG_REPLICATION_ORIGIN_CREATE] +declaration=node_name text +category=System Administration Functions +description=Creates a replication origin with the given external name, and returns the\ninternal ID assigned to it. +[PG_REPLICATION_ORIGIN_DROP] +declaration=node_name text +category=System Administration Functions +description=Deletes a previously-created replication origin, including any associated\nreplay progress. +[PG_REPLICATION_ORIGIN_OID] +declaration=node_name text +category=System Administration Functions +description=Looks up a replication origin by name and returns the internal ID. If no\nsuch replication origin is found, NULL is returned. +[PG_REPLICATION_ORIGIN_PROGRESS] +declaration=node_name text, flush boolean +category=System Administration Functions +description=Returns the replay location for the given replication origin. The parameter\nflush determines whether the corresponding local transaction will be\nguaranteed to have been flushed to disk or not. +[PG_REPLICATION_ORIGIN_SESSION_IS_SETUP] +declaration= +category=System Administration Functions +description=Returns true if a replication origin has been selected in the current\nsession. +[PG_REPLICATION_ORIGIN_SESSION_PROGRESS] +declaration=flush boolean +category=System Administration Functions +description=Returns the replay location for the replication origin selected in the\ncurrent session. The parameter flush determines whether the corresponding\nlocal transaction will be guaranteed to have been flushed to disk or not. +[PG_REPLICATION_ORIGIN_SESSION_RESET] +declaration= +category=System Administration Functions +description=Cancels the effects of pg_replication_origin_session_setup(). +[PG_REPLICATION_ORIGIN_SESSION_SETUP] +declaration=node_name text +category=System Administration Functions +description=Marks the current session as replaying from the given origin, allowing\nreplay progress to be tracked. Can only be used if no origin is currently\nselected. Use pg_replication_origin_session_reset to undo. +[PG_REPLICATION_ORIGIN_XACT_RESET] +declaration= +category=System Administration Functions +description=Cancels the effects of pg_replication_origin_xact_setup(). +[PG_REPLICATION_ORIGIN_XACT_SETUP] +declaration=origin_lsn pg_lsn, origin_timestamp timestamp with time zone +category=System Administration Functions +description=Marks the current transaction as replaying a transaction that has committed\nat the given LSN and timestamp. Can only be called when a replication\norigin has been selected using pg_replication_origin_session_setup. +[PG_REPLICATION_SLOT_ADVANCE] +declaration=slot_name name, upto_lsn pg_lsn +category=System Administration Functions +description=Advances the current confirmed position of a replication slot named\nslot_name. The slot will not be moved backwards, and it will not be moved\nbeyond the current insert location. Returns the name of the slot and the\nactual position that it was advanced to. The updated slot position\ninformation is written out at the next checkpoint if any advancing is done.\nSo in the event of a crash, the slot may return to an earlier position. If\nthe specified slot is a logical failover slot then the function will not\nreturn until all physical slots specified in synchronized_standby_slots\nhave confirmed WAL receipt. +[PG_ROTATE_LOGFILE] +declaration= +category=System Administration Functions +description=Signals the log-file manager to switch to a new output file immediately.\nThis works only when the built-in log collector is running, since otherwise\nthere is no log-file manager subprocess. +[PG_SAFE_SNAPSHOT_BLOCKING_PIDS] +declaration=integer +category=Session Information Functions +description=Returns an array of the process ID(s) of the sessions that are blocking the\nserver process with the specified process ID from acquiring a safe\nsnapshot, or an empty array if there is no such server process or it is not\nblocked. +[PG_SETTINGS_GET_FLAGS] +declaration=guc text +category=Session Information Functions +description=Returns an array of the flags associated with the given GUC, or NULL if it\ndoes not exist. The result is an empty array if the GUC exists but there\nare no flags to show. Only the most useful flags listed in Table 9.78 are\nexposed. +[PG_SIZE_BYTES] +declaration=text +category=System Administration Functions +description=Converts a size in human-readable format (as returned by pg_size_pretty)\ninto bytes. Valid units are bytes, B, kB, MB, GB, TB, and PB. +[PG_SNAPSHOT_XIP] +declaration=pg_snapshot +category=Session Information Functions +description=Returns the set of in-progress transaction IDs contained in a snapshot. +[PG_SNAPSHOT_XMAX] +declaration=pg_snapshot +category=Session Information Functions +description=Returns the xmax of a snapshot. +[PG_SNAPSHOT_XMIN] +declaration=pg_snapshot +category=Session Information Functions +description=Returns the xmin of a snapshot. +[PG_SPLIT_WALFILE_NAME] +declaration=file_name text +category=System Administration Functions +description=Extracts the sequence number and timeline ID from a WAL file name. +[PG_STATISTICS_OBJ_IS_VISIBLE] +declaration=stat oid +category=Session Information Functions +description=Is statistics object visible in search path? +[PG_STAT_FILE] +declaration=filename text [, missing_ok boolean ] +category=System Administration Functions +description=Returns a record containing the file's size, last access time stamp, last\nmodification time stamp, last file status change time stamp (Unix platforms\nonly), file creation time stamp (Windows only), and a flag indicating if it\nis a directory. +[PG_SWITCH_WAL] +declaration= +category=System Administration Functions +description=Forces the server to switch to a new write-ahead log file, which allows the\ncurrent file to be archived (assuming you are using continuous archiving).\nThe result is the ending write-ahead log location plus 1 within the\njust-completed write-ahead log file. If there has been no write-ahead log\nactivity since the last write-ahead log switch, pg_switch_wal does nothing\nand returns the start location of the write-ahead log file currently in\nuse. +[PG_SYNC_REPLICATION_SLOTS] +declaration= +category=System Administration Functions +description=Synchronize the logical failover replication slots from the primary server\nto the standby server. This function can only be executed on the standby\nserver. Temporary synced slots, if any, cannot be used for logical decoding\nand must be dropped after promotion. See Section 47.2.3 for details. Note\nthat this function cannot be executed if sync_replication_slots is enabled\nand the slotsync worker is already running to perform the synchronization\nof slots. +[PG_TABLESPACE_DATABASES] +declaration=tablespace oid +category=Session Information Functions +description=Returns the set of OIDs of databases that have objects stored in the\nspecified tablespace. If this function returns any rows, the tablespace is\nnot empty and cannot be dropped. To identify the specific objects\npopulating the tablespace, you will need to connect to the database(s)\nidentified by pg_tablespace_databases and query their pg_class catalogs. +[PG_TABLESPACE_LOCATION] +declaration=tablespace oid +category=Session Information Functions +description=Returns the file system path that this tablespace is located in. +[PG_TABLE_IS_VISIBLE] +declaration=table oid +category=Session Information Functions +description=Is table visible in search path? (This works for all types of relations,\nincluding views, materialized views, indexes, sequences and foreign\ntables.) +[PG_TABLE_SIZE] +declaration=regclass +category=System Administration Functions +description=Computes the disk space used by the specified table, excluding indexes (but\nincluding its TOAST table if any, free space map, and visibility map). +[PG_TERMINATE_BACKEND] +declaration=pid integer, timeout bigint DEFAULT 0 +category=System Administration Functions +description=Terminates the session whose backend process has the specified process ID.\nThis is also allowed if the calling role is a member of the role whose\nbackend is being terminated or the calling role has privileges of\npg_signal_backend, however only superusers can terminate superuser\nbackends. +[PG_TOTAL_RELATION_SIZE] +declaration=regclass +category=System Administration Functions +description=Computes the total disk space used by the specified table, including all\nindexes and TOAST data. The result is equivalent to pg_table_size +\npg_indexes_size. +[PG_TRIGGER_DEPTH] +declaration= +category=Session Information Functions +description=Returns the current nesting level of PostgreSQL triggers (0 if not called,\ndirectly or indirectly, from inside a trigger). +[PG_TS_CONFIG_IS_VISIBLE] +declaration=config oid +category=Session Information Functions +description=Is text search configuration visible in search path? +[PG_TS_DICT_IS_VISIBLE] +declaration=dict oid +category=Session Information Functions +description=Is text search dictionary visible in search path? +[PG_TS_PARSER_IS_VISIBLE] +declaration=parser oid +category=Session Information Functions +description=Is text search parser visible in search path? +[PG_TS_TEMPLATE_IS_VISIBLE] +declaration=template oid +category=Session Information Functions +description=Is text search template visible in search path? +[PG_TYPEOF] +declaration="any" +category=Session Information Functions +description=Returns the OID of the data type of the value that is passed to it. This\ncan be helpful for troubleshooting or dynamically constructing SQL queries.\nThe function is declared as returning regtype, which is an OID alias type\n(see Section 8.19); this means that it is the same as an OID for comparison\npurposes but displays as a type name. +[PG_TYPE_IS_VISIBLE] +declaration=type oid +category=Session Information Functions +description=Is type (or domain) visible in search path? +[PG_VISIBLE_IN_SNAPSHOT] +declaration=xid8, pg_snapshot +category=Session Information Functions +description=Is the given transaction ID visible according to this snapshot (that is,\nwas it completed before the snapshot was taken)? Note that this function\nwill not give the correct answer for a subtransaction ID (subxid); see\nSection 66.3 for details. +[PG_WALFILE_NAME] +declaration=lsn pg_lsn +category=System Administration Functions +description=Converts a write-ahead log location to the name of the WAL file holding\nthat location. +[PG_WALFILE_NAME_OFFSET] +declaration=lsn pg_lsn +category=System Administration Functions +description=Converts a write-ahead log location to a WAL file name and byte offset\nwithin that file. +[PG_WAL_LSN_DIFF] +declaration=lsn1 pg_lsn, lsn2 pg_lsn +category=System Administration Functions +description=Calculates the difference in bytes (lsn1 - lsn2) between two write-ahead\nlog locations. This can be used with pg_stat_replication or some of the\nfunctions shown in Table 9.95 to get the replication lag. +[PG_WAL_REPLAY_PAUSE] +declaration= +category=System Administration Functions +description=Request to pause recovery. A request doesn't mean that recovery stops right\naway. If you want a guarantee that recovery is actually paused, you need to\ncheck for the recovery pause state returned by\npg_get_wal_replay_pause_state(). Note that pg_is_wal_replay_paused()\nreturns whether a request is made. While recovery is paused, no further\ndatabase changes are applied. If hot standby is active, all new queries\nwill see the same consistent snapshot of the database, and no further query\nconflicts will be generated until recovery is resumed. +[PG_WAL_REPLAY_RESUME] +declaration= +category=System Administration Functions +description=Restarts recovery if it was paused. +[PG_WAL_SUMMARY_CONTENTS] +declaration=tli bigint, start_lsn pg_lsn, end_lsn pg_lsn +category=Session Information Functions +description=Returns one information about the contents of a single WAL summary file\nidentified by TLI and starting and ending LSNs. Each row with\nis_limit_block false indicates that the block identified by the remaining\noutput columns was modified by at least one WAL record within the range of\nrecords summarized by this file. Each row with is_limit_block true\nindicates either that (a) the relation fork was truncated to the length\ngiven by relblocknumber within the relevant range of WAL records or (b)\nthat the relation fork was created or dropped within the relevant range of\nWAL records; in such cases, relblocknumber will be zero. +[PG_XACT_COMMIT_TIMESTAMP] +declaration=xid +category=Session Information Functions +description=Returns the commit timestamp of a transaction. +[PG_XACT_COMMIT_TIMESTAMP_ORIGIN] +declaration=xid +category=Session Information Functions +description=Returns the commit timestamp and replication origin of a transaction. +[PG_XACT_STATUS] +declaration=xid8 +category=Session Information Functions +description=Reports the commit status of a recent transaction. The result is one of in\nprogress, committed, or aborted, provided that the transaction is recent\nenough that the system retains the commit status of that transaction. If it\nis old enough that no references to the transaction survive in the system\nand the commit status information has been discarded, the result is NULL.\nApplications might use this function, for example, to determine whether\ntheir transaction committed or aborted after the application and database\nserver become disconnected while a COMMIT is in progress. Note that\nprepared transactions are reported as in progress; applications must check\npg_prepared_xacts if they need to determine whether a transaction ID\nbelongs to a prepared transaction. +[PHRASETO_TSQUERY] +declaration=[ config regconfig, ] query text +category=Text Search Functions +description=Converts text to a tsquery, normalizing words according to the specified or\ndefault configuration. Any punctuation in the string is ignored (it does\nnot determine query operators). The resulting query matches phrases\ncontaining all non-stopwords in the text. +[PI] +declaration= +category=Numeric/Math Functions +description=Approximate value of π +[PLAINTO_TSQUERY] +declaration=[ config regconfig, ] query text +category=Text Search Functions +description=Converts text to a tsquery, normalizing words according to the specified or\ndefault configuration. Any punctuation in the string is ignored (it does\nnot determine query operators). The resulting query matches documents\ncontaining all non-stopwords in the text. +[POINT] +declaration=double precision, double precision +category=Geometric Functions +description=Constructs point from its coordinates. +[POLYGON] +declaration=box +category=Geometric Functions +description=Converts box to a 4-point polygon. +[POPEN] +declaration=path +category=Geometric Functions +description=Converts path to open form. +[POSITION1] +name=POSITION +declaration=substring text IN string text +category=String Functions +description=Returns first starting index of the specified substring within string, or\nzero if it's not present. +[POSITION2] +name=POSITION +declaration=substring bytea IN bytes bytea +category=Binary String Functions +description=Returns first starting index of the specified substring within bytes, or\nzero if it's not present. +[POSITION3] +name=POSITION +declaration=substring bit IN bits bit +category=Bit String Functions +description=Returns first starting index of the specified substring within bits, or\nzero if it's not present. +[QUERYTREE] +declaration=tsquery +category=Text Search Functions +description=Produces a representation of the indexable portion of a tsquery. A result\nthat is empty or just T indicates a non-indexable query. +[QUOTE_IDENT] +declaration=text +category=String Functions +description=Returns the given string suitably quoted to be used as an identifier in an\nSQL statement string. Quotes are added only if necessary (i.e., if the\nstring contains non-identifier characters or would be case-folded).\nEmbedded quotes are properly doubled. See also Example 41.1. +[QUOTE_LITERAL] +declaration=text +category=String Functions +description=Returns the given string suitably quoted to be used as a string literal in\nan SQL statement string. Embedded single-quotes and backslashes are\nproperly doubled. Note that quote_literal returns null on null input; if\nthe argument might be null, quote_nullable is often more suitable. See also\nExample 41.1. +[QUOTE_NULLABLE] +declaration=text +category=String Functions +description=Returns the given string suitably quoted to be used as a string literal in\nan SQL statement string; or, if the argument is null, returns NULL.\nEmbedded single-quotes and backslashes are properly doubled. See also\nExample 41.1. +[RADIANS] +declaration=double precision +category=Numeric/Math Functions +description=Converts degrees to radians +[RADIUS] +declaration=circle +category=Geometric Functions +description=Computes radius of circle. +[RANDOM] +declaration= +category=Numeric/Math Functions +description=Returns a random value in the range 0.0 <= x < 1.0 +[RANDOM_NORMAL] +declaration=[ mean double precision [, stddev double precision ]] +category=Numeric/Math Functions +description=Returns a random value from the normal distribution with the given\nparameters; mean defaults to 0.0 and stddev defaults to 1.0 +[RANGE_MERGE1] +name=RANGE_MERGE +declaration=anyrange, anyrange +category=Range Functions +description=Computes the smallest range that includes both of the given ranges. +[RANGE_MERGE2] +name=RANGE_MERGE +declaration=anymultirange +category=Range Functions +description=Computes the smallest range that includes the entire multirange. +[RANK1] +name=RANK +declaration=args +category=Aggregate Functions +description=Computes the rank of the hypothetical row, with gaps; that is, the row\nnumber of the first row in its peer group. +[RANK2] +name=RANK +declaration= +category=Window Functions +description=Returns the rank of the current row, with gaps; that is, the row_number of\nthe first row in its peer group. +[REGEXP_COUNT] +declaration=string text, pattern text [, start integer [, flags text ] ] +category=String Functions +description=Returns the number of times the POSIX regular expression pattern matches in\nthe string; see Section 9.7.3. +[REGEXP_INSTR] +declaration=string text, pattern text [, start integer [, N integer [, endoption integer [, flags text [, subexpr integer ] ] ] ] ] +category=String Functions +description=Returns the position within string where the N'th match of the POSIX\nregular expression pattern occurs, or zero if there is no such match; see\nSection 9.7.3. +[REGEXP_LIKE] +declaration=string text, pattern text [, flags text ] +category=String Functions +description=Checks whether a match of the POSIX regular expression pattern occurs\nwithin string; see Section 9.7.3. +[REGEXP_MATCH] +declaration=string text, pattern text [, flags text ] +category=String Functions +description=Returns substrings within the first match of the POSIX regular expression\npattern to the string; see Section 9.7.3. +[REGEXP_MATCHES] +declaration=string text, pattern text [, flags text ] +category=String Functions +description=Returns substrings within the first match of the POSIX regular expression\npattern to the string, or substrings within all such matches if the g flag\nis used; see Section 9.7.3. +[REGEXP_REPLACE] +declaration=string text, pattern text, replacement text [, start integer ] [, flags text ] +category=String Functions +description=Replaces the substring that is the first match to the POSIX regular\nexpression pattern, or all such matches if the g flag is used; see Section\n9.7.3. +[REGEXP_SPLIT_TO_ARRAY] +declaration=string text, pattern text [, flags text ] +category=String Functions +description=Splits string using a POSIX regular expression as the delimiter, producing\nan array of results; see Section 9.7.3. +[REGEXP_SPLIT_TO_TABLE] +declaration=string text, pattern text [, flags text ] +category=String Functions +description=Splits string using a POSIX regular expression as the delimiter, producing\na set of results; see Section 9.7.3. +[REGEXP_SUBSTR] +declaration=string text, pattern text [, start integer [, N integer [, flags text [, subexpr integer ] ] ] ] +category=String Functions +description=Returns the substring within string that matches the N'th occurrence of the\nPOSIX regular expression pattern, or NULL if there is no such match; see\nSection 9.7.3. +[REGR_AVGX] +declaration=Y double precision, X double precision +category=Aggregate Functions +description=Computes the average of the independent variable, sum(X)/N. +[REGR_AVGY] +declaration=Y double precision, X double precision +category=Aggregate Functions +description=Computes the average of the dependent variable, sum(Y)/N. +[REGR_COUNT] +declaration=Y double precision, X double precision +category=Aggregate Functions +description=Computes the number of rows in which both inputs are non-null. +[REGR_R2] +declaration=Y double precision, X double precision +category=Aggregate Functions +description=Computes the square of the correlation coefficient. +[REGR_SXX] +declaration=Y double precision, X double precision +category=Aggregate Functions +description=Computes the "sum of squares" of the independent variable, sum(X^2) -\nsum(X)^2/N. +[REGR_SXY] +declaration=Y double precision, X double precision +category=Aggregate Functions +description=Computes the "sum of products" of independent times dependent variables,\nsum(X*Y) - sum(X) * sum(Y)/N. +[REGR_SYY] +declaration=Y double precision, X double precision +category=Aggregate Functions +description=Computes the "sum of squares" of the dependent variable, sum(Y^2) -\nsum(Y)^2/N. +[REPEAT] +declaration=string text, number integer +category=String Functions +description=Repeats string the specified number of times. +[REPLACE] +declaration=string text, from text, to text +category=String Functions +description=Replaces all occurrences in string of substring from with substring to. +[REVERSE] +declaration=text +category=String Functions +description=Reverses the order of the characters in the string. +[RIGHT] +declaration=string text, n integer +category=String Functions +description=Returns last n characters in the string, or when n is negative, returns all\nbut first |n| characters. +[ROW_NUMBER] +declaration= +category=Window Functions +description=Returns the number of the current row within its partition, counting from\n1. +[ROW_SECURITY_ACTIVE] +declaration=table text or oid +category=Session Information Functions +description=Is row-level security active for the specified table in the context of the\ncurrent user and current environment? +[ROW_TO_JSON] +declaration=record [, boolean ] +category=JSON Functions +description=Converts an SQL composite value to a JSON object. The behavior is the same\nas to_json except that line feeds will be added between top-level elements\nif the optional boolean parameter is true. +[RPAD] +declaration=string text, length integer [, fill text ] +category=String Functions +description=Extends the string to length length by appending the characters fill (a\nspace by default). If the string is already longer than length then it is\ntruncated. +[RTRIM1] +name=RTRIM +declaration=string text [, characters text ] +category=String Functions +description=Removes the longest string containing only characters in characters (a\nspace by default) from the end of string. +[RTRIM2] +name=RTRIM +declaration=bytes bytea, bytesremoved bytea +category=Binary String Functions +description=Removes the longest string containing only bytes appearing in bytesremoved\nfrom the end of bytes. +[SCALE] +declaration=numeric +category=Numeric/Math Functions +description=Scale of the argument (the number of decimal digits in the fractional part) +[SETSEED] +declaration=double precision +category=Numeric/Math Functions +description=Sets the seed for subsequent random() and random_normal() calls; argument\nmust be between -1.0 and 1.0, inclusive +[SETVAL] +declaration=regclass, bigint [, boolean ] +category=Sequence Manipulation Functions +description=Sets the sequence object's current value, and optionally its is_called\nflag. The two-parameter form sets the sequence's last_value field to the\nspecified value and sets its is_called field to true, meaning that the next\nnextval will advance the sequence before returning a value. The value that\nwill be reported by currval is also set to the specified value. In the\nthree-parameter form, is_called can be set to either true or false. true\nhas the same effect as the two-parameter form. If it is set to false, the\nnext nextval will return exactly the specified value, and sequence\nadvancement commences with the following nextval. Furthermore, the value\nreported by currval is not changed in this case. For example, +[SETWEIGHT1] +name=SETWEIGHT +declaration=vector tsvector, weight "char" +category=Text Search Functions +description=Assigns the specified weight to each element of the vector. +[SETWEIGHT2] +name=SETWEIGHT +declaration=vector tsvector, weight "char", lexemes text[] +category=Text Search Functions +description=Assigns the specified weight to elements of the vector that are listed in\nlexemes. The strings in lexemes are taken as lexemes as-is, without further\nprocessing. Strings that do not match any lexeme in vector are ignored. +[SET_BIT1] +name=SET_BIT +declaration=bytes bytea, n bigint, newvalue integer +category=Binary String Functions +description=Sets n'th bit in binary string to newvalue. +[SET_BIT2] +name=SET_BIT +declaration=bits bit, n integer, newvalue integer +category=Bit String Functions +description=Sets n'th bit in bit string to newvalue; the first (leftmost) bit is bit 0. +[SET_BYTE] +declaration=bytes bytea, n integer, newvalue integer +category=Binary String Functions +description=Sets n'th byte in binary string to newvalue. +[SET_CONFIG] +declaration=setting_name text, new_value text, is_local boolean +category=System Administration Functions +description=Sets the parameter setting_name to new_value, and returns that value. If\nis_local is true, the new value will only apply during the current\ntransaction. If you want the new value to apply for the rest of the current\nsession, use false instead. This function corresponds to the SQL command\nSET. +[SET_MASKLEN] +declaration=inet, integer +category=Network Address Functions +description=Sets the netmask length for an inet value. The address part does not\nchange. +[SHA224] +declaration=bytea +category=Binary String Functions +description=Computes the SHA-224 hash of the binary string. +[SHA256] +declaration=bytea +category=Binary String Functions +description=Computes the SHA-256 hash of the binary string. +[SHA384] +declaration=bytea +category=Binary String Functions +description=Computes the SHA-384 hash of the binary string. +[SHA512] +declaration=bytea +category=Binary String Functions +description=Computes the SHA-512 hash of the binary string. +[SHOBJ_DESCRIPTION] +declaration=object oid, catalog name +category=Session Information Functions +description=Returns the comment for a shared database object specified by its OID and\nthe name of the containing system catalog. This is just like\nobj_description except that it is used for retrieving comments on shared\nobjects (that is, databases, roles, and tablespaces). Some system catalogs\nare global to all databases within each cluster, and the descriptions for\nobjects in them are stored globally as well. +[SIN] +declaration=double precision +category=Numeric/Math Functions +description=Sine, argument in radians +[SIND] +declaration=double precision +category=Numeric/Math Functions +description=Sine, argument in degrees +[SINH] +declaration=double precision +category=Numeric/Math Functions +description=Hyperbolic sine +[SLOPE] +declaration=point, point +category=Geometric Functions +description=Computes slope of a line drawn through the two points. +[SPLIT_PART] +declaration=string text, delimiter text, n integer +category=String Functions +description=Splits string at occurrences of delimiter and returns the n'th field\n(counting from one), or when n is negative, returns the |n|'th-from-last\nfield. +[STARTS_WITH] +declaration=string text, prefix text +category=String Functions +description=Returns true if string starts with prefix. +[STATEMENT_TIMESTAMP] +declaration= +category=Date/Time Functions +description=Current date and time (start of current statement); see Section 9.9.5 +[STRING_TO_ARRAY] +declaration=string text, delimiter text [, null_string text ] +category=String Functions +description=Splits the string at occurrences of delimiter and forms the resulting\nfields into a text array. If delimiter is NULL, each character in the\nstring will become a separate element in the array. If delimiter is an\nempty string, then the string is treated as a single field. If null_string\nis supplied and is not NULL, fields matching that string are replaced by\nNULL. See also array_to_string. +[STRING_TO_TABLE] +declaration=string text, delimiter text [, null_string text ] +category=String Functions +description=Splits the string at occurrences of delimiter and returns the resulting\nfields as a set of text rows. If delimiter is NULL, each character in the\nstring will become a separate row of the result. If delimiter is an empty\nstring, then the string is treated as a single field. If null_string is\nsupplied and is not NULL, fields matching that string are replaced by NULL. +[STRIP] +declaration=tsvector +category=Text Search Functions +description=Removes positions and weights from the tsvector. +[STRPOS] +declaration=string text, substring text +category=String Functions +description=Returns first starting index of the specified substring within string, or\nzero if it's not present. (Same as position(substring in string), but note\nthe reversed argument order.) +[SUBSTR1] +name=SUBSTR +declaration=string text, start integer [, count integer ] +category=String Functions +description=Extracts the substring of string starting at the start'th character, and\nextending for count characters if that is specified. (Same as\nsubstring(string from start for count).) +[SUBSTR2] +name=SUBSTR +declaration=bytes bytea, start integer [, count integer ] +category=Binary String Functions +description=Extracts the substring of bytes starting at the start'th byte, and\nextending for count bytes if that is specified. (Same as substring(bytes\nfrom start for count).) +[SUBSTRING1] +name=SUBSTRING +declaration=string text [ FROM start integer ] [ FOR count integer ] +category=String Functions +description=Extracts the substring of string starting at the start'th character if that\nis specified, and stopping after count characters if that is specified.\nProvide at least one of start and count. +[SUBSTRING2] +name=SUBSTRING +declaration=bytes bytea [ FROM start integer ] [ FOR count integer ] +category=Binary String Functions +description=Extracts the substring of bytes starting at the start'th byte if that is\nspecified, and stopping after count bytes if that is specified. Provide at\nleast one of start and count. +[SUBSTRING3] +name=SUBSTRING +declaration=bits bit [ FROM start integer ] [ FOR count integer ] +category=Bit String Functions +description=Extracts the substring of bits starting at the start'th bit if that is\nspecified, and stopping after count bits if that is specified. Provide at\nleast one of start and count. +[SUPPRESS_REDUNDANT_UPDATES_TRIGGER] +declaration= +category=Trigger Functions +description=Suppresses do-nothing update operations. See below for details. +[TAN] +declaration=double precision +category=Numeric/Math Functions +description=Tangent, argument in radians +[TAND] +declaration=double precision +category=Numeric/Math Functions +description=Tangent, argument in degrees +[TANH] +declaration=double precision +category=Numeric/Math Functions +description=Hyperbolic tangent +[TEXT] +declaration=inet +category=Network Address Functions +description=Returns the unabbreviated IP address and netmask length as text. (This has\nthe same result as an explicit cast to text.) +[TIMEOFDAY] +declaration= +category=Date/Time Functions +description=Current date and time (like clock_timestamp, but as a text string); see\nSection 9.9.5 +[TO_JSONB] +declaration=anyelement +category=JSON Functions +description=Converts any SQL value to json or jsonb. Arrays and composites are\nconverted recursively to arrays and objects (multidimensional arrays become\narrays of arrays in JSON). Otherwise, if there is a cast from the SQL data\ntype to json, the cast function will be used to perform the conversion;[a]\notherwise, a scalar JSON value is produced. For any scalar other than a\nnumber, a Boolean, or a null value, the text representation will be used,\nwith escaping as necessary to make it a valid JSON string value. +[TO_REGCLASS] +declaration=text +category=Session Information Functions +description=Translates a textual relation name to its OID. A similar result is obtained\nby casting the string to type regclass (see Section 8.19); however, this\nfunction will return NULL rather than throwing an error if the name is not\nfound. +[TO_REGCOLLATION] +declaration=text +category=Session Information Functions +description=Translates a textual collation name to its OID. A similar result is\nobtained by casting the string to type regcollation (see Section 8.19);\nhowever, this function will return NULL rather than throwing an error if\nthe name is not found. +[TO_REGNAMESPACE] +declaration=text +category=Session Information Functions +description=Translates a textual schema name to its OID. A similar result is obtained\nby casting the string to type regnamespace (see Section 8.19); however,\nthis function will return NULL rather than throwing an error if the name is\nnot found. +[TO_REGOPER] +declaration=text +category=Session Information Functions +description=Translates a textual operator name to its OID. A similar result is obtained\nby casting the string to type regoper (see Section 8.19); however, this\nfunction will return NULL rather than throwing an error if the name is not\nfound or is ambiguous. +[TO_REGOPERATOR] +declaration=text +category=Session Information Functions +description=Translates a textual operator name (with parameter types) to its OID. A\nsimilar result is obtained by casting the string to type regoperator (see\nSection 8.19); however, this function will return NULL rather than throwing\nan error if the name is not found. +[TO_REGPROC] +declaration=text +category=Session Information Functions +description=Translates a textual function or procedure name to its OID. A similar\nresult is obtained by casting the string to type regproc (see Section\n8.19); however, this function will return NULL rather than throwing an\nerror if the name is not found or is ambiguous. +[TO_REGPROCEDURE] +declaration=text +category=Session Information Functions +description=Translates a textual function or procedure name (with argument types) to\nits OID. A similar result is obtained by casting the string to type\nregprocedure (see Section 8.19); however, this function will return NULL\nrather than throwing an error if the name is not found. +[TO_REGROLE] +declaration=text +category=Session Information Functions +description=Translates a textual role name to its OID. A similar result is obtained by\ncasting the string to type regrole (see Section 8.19); however, this\nfunction will return NULL rather than throwing an error if the name is not\nfound. +[TO_REGTYPE] +declaration=text +category=Session Information Functions +description=Parses a string of text, extracts a potential type name from it, and\ntranslates that name into a type OID. A syntax error in the string will\nresult in an error; but if the string is a syntactically valid type name\nthat happens not to be found in the catalogs, the result is NULL. A similar\nresult is obtained by casting the string to type regtype (see Section\n8.19), except that that will throw error for name not found. +[TO_REGTYPEMOD] +declaration=text +category=Session Information Functions +description=Parses a string of text, extracts a potential type name from it, and\ntranslates its type modifier, if any. A syntax error in the string will\nresult in an error; but if the string is a syntactically valid type name\nthat happens not to be found in the catalogs, the result is NULL. The\nresult is -1 if no type modifier is present. +[TO_TIMESTAMP] +declaration=double precision +category=Date/Time Functions +description=Convert Unix epoch (seconds since 1970-01-01 00:00:00+00) to timestamp with\ntime zone +[TO_TSQUERY] +declaration=[ config regconfig, ] query text +category=Text Search Functions +description=Converts text to a tsquery, normalizing words according to the specified or\ndefault configuration. The words must be combined by valid tsquery\noperators. +[TO_TSVECTOR] +declaration=[ config regconfig, ] document text +category=Text Search Functions +description=Converts text to a tsvector, normalizing words according to the specified\nor default configuration. Position information is included in the result. +[TRANSACTION_TIMESTAMP] +declaration= +category=Date/Time Functions +description=Current date and time (start of current transaction); see Section 9.9.5 +[TRANSLATE] +declaration=string text, from text, to text +category=String Functions +description=Replaces each character in string that matches a character in the from set\nwith the corresponding character in the to set. If from is longer than to,\noccurrences of the extra characters in from are deleted. +[TRIM1] +name=TRIM +declaration=[ LEADING | TRAILING | BOTH ] [ characters text ] FROM string text +category=String Functions +description=Removes the longest string containing only characters in characters (a\nspace by default) from the start, end, or both ends (BOTH is the default)\nof string. +[TRIM2] +name=TRIM +declaration=[ LEADING | TRAILING | BOTH ] bytesremoved bytea FROM bytes bytea +category=Binary String Functions +description=Removes the longest string containing only bytes appearing in bytesremoved\nfrom the start, end, or both ends (BOTH is the default) of bytes. +[TRIM_ARRAY] +declaration=array anyarray, n integer +category=Array Functions +description=Trims an array by removing the last n elements. If the array is\nmultidimensional, only the first dimension is trimmed. +[TRIM_SCALE] +declaration=numeric +category=Numeric/Math Functions +description=Reduces the value's scale (number of fractional decimal digits) by removing\ntrailing zeroes +[TRUNC] +declaration=macaddr +category=Network Address Functions +description=Sets the last 3 bytes of the address to zero. The remaining prefix can be\nassociated with a particular manufacturer (using data not included in\nPostgreSQL). +[TSQUERY_PHRASE] +declaration=query1 tsquery, query2 tsquery +category=Text Search Functions +description=Constructs a phrase query that searches for matches of query1 and query2 at\nsuccessive lexemes (same as <-> operator). +[TSVECTOR_TO_ARRAY] +declaration=tsvector +category=Text Search Functions +description=Converts a tsvector to an array of lexemes. +[TSVECTOR_UPDATE_TRIGGER] +declaration= +category=Trigger Functions +description=Automatically updates a tsvector column from associated plain-text document\ncolumn(s). The text search configuration to use is specified by name as a\ntrigger argument. See Section 12.4.3 for details. +[TSVECTOR_UPDATE_TRIGGER_COLUMN] +declaration= +category=Trigger Functions +description=Automatically updates a tsvector column from associated plain-text document\ncolumn(s). The text search configuration to use is taken from a regconfig\ncolumn of the table. See Section 12.4.3 for details. +[TS_DEBUG] +declaration=[ config regconfig, ] document text +category=Text Search Functions +description=Extracts and normalizes tokens from the document according to the specified\nor default text search configuration, and returns information about how\neach token was processed. See Section 12.8.1 for details. +[TS_DELETE] +declaration=vector tsvector, lexeme text +category=Text Search Functions +description=Removes any occurrence of the given lexeme from the vector. The lexeme\nstring is treated as a lexeme as-is, without further processing. +[TS_FILTER] +declaration=vector tsvector, weights "char"[] +category=Text Search Functions +description=Selects only elements with the given weights from the vector. +[TS_HEADLINE] +declaration=[ config regconfig, ] document text, query tsquery [, options text ] +category=Text Search Functions +description=Displays, in an abbreviated form, the match(es) for the query in the\ndocument, which must be raw text not a tsvector. Words in the document are\nnormalized according to the specified or default configuration before\nmatching to the query. Use of this function is discussed in Section 12.3.4,\nwhich also describes the available options. +[TS_LEXIZE] +declaration=dict regdictionary, token text +category=Text Search Functions +description=Returns an array of replacement lexemes if the input token is known to the\ndictionary, or an empty array if the token is known to the dictionary but\nit is a stop word, or NULL if it is not a known word. See Section 12.8.3\nfor details. +[TS_PARSE] +declaration=parser_name text, document text +category=Text Search Functions +description=Extracts tokens from the document using the named parser. See Section\n12.8.2 for details. +[TS_RANK] +declaration=[ weights real[], ] vector tsvector, query tsquery [, normalization integer ] +category=Text Search Functions +description=Computes a score showing how well the vector matches the query. See Section\n12.3.3 for details. +[TS_RANK_CD] +declaration=[ weights real[], ] vector tsvector, query tsquery [, normalization integer ] +category=Text Search Functions +description=Computes a score showing how well the vector matches the query, using a\ncover density algorithm. See Section 12.3.3 for details. +[TS_REWRITE] +declaration=query tsquery, target tsquery, substitute tsquery +category=Text Search Functions +description=Replaces occurrences of target with substitute within the query. See\nSection 12.4.2.1 for details. +[TS_STAT] +declaration=sqlquery text [, weights text ] +category=Text Search Functions +description=Executes the sqlquery, which must return a single tsvector column, and\nreturns statistics about each distinct lexeme contained in the data. See\nSection 12.4.4 for details. +[TS_TOKEN_TYPE] +declaration=parser_name text +category=Text Search Functions +description=Returns a table that describes each type of token the named parser can\nrecognize. See Section 12.8.2 for details. +[TXID_CURRENT] +declaration= +category=Session Information Functions +description=See pg_current_xact_id(). +[TXID_CURRENT_IF_ASSIGNED] +declaration= +category=Session Information Functions +description=See pg_current_xact_id_if_assigned(). +[TXID_CURRENT_SNAPSHOT] +declaration= +category=Session Information Functions +description=See pg_current_snapshot(). +[TXID_SNAPSHOT_XIP] +declaration=txid_snapshot +category=Session Information Functions +description=See pg_snapshot_xip(). +[TXID_SNAPSHOT_XMAX] +declaration=txid_snapshot +category=Session Information Functions +description=See pg_snapshot_xmax(). +[TXID_SNAPSHOT_XMIN] +declaration=txid_snapshot +category=Session Information Functions +description=See pg_snapshot_xmin(). +[TXID_STATUS] +declaration=bigint +category=Session Information Functions +description=See pg_xact_status(). +[TXID_VISIBLE_IN_SNAPSHOT] +declaration=bigint, txid_snapshot +category=Session Information Functions +description=See pg_visible_in_snapshot(). +[UNICODE_ASSIGNED] +declaration=text +category=String Functions +description=Returns true if all characters in the string are assigned Unicode\ncodepoints; false otherwise. This function can only be used when the server\nencoding is UTF8. +[UNICODE_VERSION] +declaration= +category=Session Information Functions +description=Returns a string representing the version of Unicode used by PostgreSQL. +[UNISTR] +declaration=text +category=String Functions +description=Evaluate escaped Unicode characters in the argument. Unicode characters can\nbe specified as \XXXX (4 hexadecimal digits), \+XXXXXX (6 hexadecimal\ndigits), \uXXXX (4 hexadecimal digits), or \UXXXXXXXX (8 hexadecimal\ndigits). To specify a backslash, write two backslashes. All other\ncharacters are taken literally. +[UNNEST1] +name=UNNEST +declaration=tsvector +category=Text Search Functions +description=Expands a tsvector into a set of rows, one per lexeme. +[UNNEST2] +name=UNNEST +declaration=anyarray +category=Array Functions +description=Expands an array into a set of rows. The array's elements are read out in\nstorage order. +[UNNEST3] +name=UNNEST +declaration=anymultirange +category=Range Functions +description=Expands a multirange into a set of ranges in ascending order. +[UPPER1] +name=UPPER +declaration=text +category=String Functions +description=Converts the string to all upper case, according to the rules of the\ndatabase's locale. +[UPPER2] +name=UPPER +declaration=anyrange +category=Range Functions +description=Extracts the upper bound of the range (NULL if the range is empty or has no\nupper bound). +[UPPER3] +name=UPPER +declaration=anymultirange +category=Range Functions +description=Extracts the upper bound of the multirange (NULL if the multirange is empty\nor has no upper bound). +[UPPER_INC1] +name=UPPER_INC +declaration=anyrange +category=Range Functions +description=Is the range's upper bound inclusive? +[UPPER_INC2] +name=UPPER_INC +declaration=anymultirange +category=Range Functions +description=Is the multirange's upper bound inclusive? +[UPPER_INF1] +name=UPPER_INF +declaration=anyrange +category=Range Functions +description=Does the range have no upper bound? (An upper bound of Infinity returns\nfalse.) +[UPPER_INF2] +name=UPPER_INF +declaration=anymultirange +category=Range Functions +description=Does the multirange have no upper bound? (An upper bound of Infinity\nreturns false.) +[VARIANCE] +declaration=numeric_type +category=Aggregate Functions +description=This is a historical alias for var_samp. +[VERSION] +declaration= +category=Session Information Functions +description=Returns a string describing the PostgreSQL server's version. You can also\nget this information from server_version, or for a machine-readable version\nuse server_version_num. Software developers should use server_version_num\n(available since 8.2) or PQserverVersion instead of parsing the text\nversion. +[WEBSEARCH_TO_TSQUERY] +declaration=[ config regconfig, ] query text +category=Text Search Functions +description=Converts text to a tsquery, normalizing words according to the specified or\ndefault configuration. Quoted word sequences are converted to phrase tests.\nThe word "or" is understood as producing an OR operator, and a dash\nproduces a NOT operator; other punctuation is ignored. This approximates\nthe behavior of some common web search tools. +[WIDTH] +declaration=box +category=Geometric Functions +description=Computes horizontal size of box. +[XMLAGG] +declaration=xml ORDER BY input_sort_columns +category=Aggregate Functions +description=Concatenates the non-null XML input values (see Section 9.15.1.8). \ No newline at end of file diff --git a/out/functions-redshift.ini b/out/functions-redshift.ini new file mode 100644 index 000000000..5e1c1443e --- /dev/null +++ b/out/functions-redshift.ini @@ -0,0 +1,684 @@ +[ABS] +declaration=number +category=Math Functions +description=ABS calculates the absolute value of a number, where that number can be a literal or an expression that evaluates to a number. +[ACOS] +declaration=number +category=Math Functions +description=ACOS is a trigonometric function that returns the arc cosine of a number. The return value is in radians and is between PI/2 and -PI/2. +[ADD_MONTHS] +declaration=date,timestamp,integer +category=Date and Time Functions +description=ADD_MONTHS adds the specified number of months to a date or time stamp value or expression. The DATEADD function provides similar functionality. +[APPROXIMATE] +declaration=percentile,expr +category=Aggregate Functions +description=APPROXIMATE PERCENTILE_DISC is an inverse distribution function that assumes a discrete distribution model. It takes a percentile value and a sort specification and returns an element from the given set. Approximation enables the function to execute much faster, with a low relative error of around 0.5 percent. +[ASIN] +declaration=number +category=Math Functions +description=ASIN is a trigonometric function that returns the arc sine of a number. The return value is in radians and is between PI/2 and -PI/2. +[ATAN2] +declaration=number1,number2 +category=Math Functions +description=ATAN2 is a trigonometric function that returns the arc tangent of a one number divided by another number. The return value is in radians and is between PI/2 and -PI/2. +[ATAN] +declaration=number +category=Math Functions +description=ATAN is a trigonometric function that returns the arc tangent of a number. The return value is in radians and is between PI/2 and -PI/2. +[AVG] +declaration=expression +category=Aggregate Functions +description=The AVG function returns the average (arithmetic mean) of the input expression values. The AVG function works with numeric values and ignores NULL values. +[BIT_AND] +declaration=expression +category=Bit-Wise Aggregate Functions +description= +[BIT_OR] +declaration=expression +category=Bit-Wise Aggregate Functions +description= +[BOOL_AND] +declaration=expression +category=Bit-Wise Aggregate Functions +description= +[BOOL_OR] +declaration=expression +category=Bit-Wise Aggregate Functions +description= +[BTRIM] +declaration=string,matching_string +category=String Functions +description=The BTRIM function trims a string by removing leading and trailing blanks or by removing characters that match an optional specified string. +[BTTEXT_PATTERN_CMP] +declaration= +category=String Functions +description=Synonym for the BPCHARCMP function. +[CASE] +declaration=expression,value,result,Boolean condition +category=Conditional Expressions +description=The CASE expression is a conditional expression, similar to if/then/else statements found in other languages. CASE is used to specify a result when there are multiple conditions. +[CAST] +declaration=expression,type +category=Data Type Formatting Functions +description=You can do run-time conversions between compatible data types by using the CAST and CONVERT functions. +[CBRT] +declaration= +category=Math Functions +description=The CBRT function is a mathematical function that calculates the cube root of a number. +[CEILING] +declaration=number +category=Math Functions +description=The CEILING or CEIL function is used to round a number up to the next whole number. (The FLOOR Function rounds a number down to the next whole number.) +[CEIL] +declaration=number +category=Math Functions +description=The CEILING or CEIL function is used to round a number up to the next whole number. (The FLOOR Function rounds a number down to the next whole number.) +[CHARACTER_LENGTH] +declaration= +category=String Functions +description=Synonym of the LEN function. +[CHARINDEX] +declaration=substring,string +category=String Functions +description=Returns the location of the specified substring within a string. Synonym of the STRPOS function. +[CHAR_LENGTH] +declaration= +category=String Functions +description=Synonym of the LEN function. +[CHECKSUM] +declaration=expression +category=Math Functions +description=Computes a checksum value for building a hash index. +[CHR] +declaration=number +category=String Functions +description=The CHR function returns the character that matches the ASCII code point value specified by of the input parameter. +[COALESCE] +declaration= +category=Conditional Expressions +description=Synonym of the NVL expression. +[CONCAT] +declaration=string1,string2 +category=String Functions +description=The CONCAT function concatenates two character strings and returns the resulting string. To concatenate more than two strings, use nested CONCAT functions. The concatenation operator (||) between two strings produces the same results as the CONCAT function. +[CONVERT] +declaration=expression,type +category=Data Type Formatting Functions +description=You can do run-time conversions between compatible data types by using the CAST and CONVERT functions. +[CONVERT_TIMEZONE] +declaration=source_timezone,target_timezone,timestamp +category=Date and Time Functions +description=CONVERT_TIMEZONE converts a time stamp from one time zone to another. +[COS] +declaration=number +category=Math Functions +description=COS is a trigonometric function that returns the cosine of a number. The return value is in radians and is between PI/2 and -PI/2. +[COT] +declaration=number +category=Math Functions +description=COT is a trigonometric function that returns the cotangent of a number. The input parameter must be nonzero. +[COUNT] +declaration=expression +category=Aggregate Functions +description=The COUNT function counts the rows defined by the expression. +[CRC32] +declaration=string +category=String Functions +description=CRC32 is an error-detecting function that uses a CRC32 algorithm to detect changes between source and target data. The CRC32 function converts a variable-length string into an 8-character string that is a text representation of the hexadecimal value of a 32 bit-binary sequence. +[CUME_DIST] +declaration=partition_expression,order_list +category=Window Functions +description=Calculates the cumulative distribution of a value within a window or partition. Assuming ascending ordering, the cumulative distribution is determined using this formula: +[CURRENT_DATABASE] +declaration= +category=System Information Functions +description=Returns the name of the database where you are currently connected. +[CURRENT_DATE] +declaration= +category=Date and Time Functions +description=CURRENT_DATE returns a date in the current session time zone (UTC by default) in the default format: YYYY-MM-DD. +[CURRENT_SCHEMAS] +declaration=include_implicit +category=System Information Functions +description=Returns an array of the names of any schemas in the current search path. The current search path is defined in the search_path parameter. +[CURRENT_SCHEMA] +declaration= +category=System Information Functions +description=Returns the name of the schema at the front of the search path. This schema will be used for any tables or other named objects that are created without specifying a target schema. +[CURRENT_SETTING] +declaration=parameter +category=System Administration Functions +description=CURRENT_SETTING returns the current value of the specified configuration parameter. +[CURRENT_USER] +declaration= +category=System Information Functions +description=Returns the user name of the current "effective" user of the database, as applicable to checking permissions. Usually, this user name will be the same as the session user; however, this can occasionally be changed by superusers. +[CURRENT_USER_ID] +declaration= +category=System Information Functions +description=Returns the unique identifier for the Amazon Redshift user logged in to the current session. +[DATEADD] +declaration=datepart,interval,date,timestamp +category=Date and Time Functions +description=Increments a date or time stamp value by a specified interval. +[DATEDIFF] +declaration=datepart,datepart boundaries,date,timestamp +category=Date and Time Functions +description=DATEDIFF returns the difference between the date parts of two date or time expressions. +[DATE_CMP] +declaration=date1,date2 +category=Date and Time Functions +description=DATE_CMP compares two dates. The function returns 0 if the dates are identical, 1 if date1 is greater, and -1 if date2 is greater. +[DATE_CMP_TIMESTAMPTZ] +declaration=date,timestamptz +category=Date and Time Functions +description=DATE_CMP_TIMESTAMPTZ compares a date to a time stamp with time zone. If the date and time stamp values are identical, the function returns 0. If the date is greater alphabetically, the function returns 1. If the time stamp is greater, the function returns –1. +[DATE_CMP_TIMESTAMP] +declaration=date,timestamp +category=Date and Time Functions +description=Compares a date to a time stamp and returns 0 if the values are identical, 1 if date is greater alphabetically and -1 if timestamp is greater. +[DATE_PART] +declaration=datepart,date,timestamp +category=Date and Time Functions +description=DATE_PART extracts datepart values from an expression. DATE_PART is a synonym of the PGDATE_PART function. +[DATE_PART_YEAR] +declaration=date +category=Date and Time Functions +description=The DATE_PART_YEAR function extracts the year from a date. +[DATE_TRUNC] +declaration=datepart,timestamp +category=Date and Time Functions +description=The DATE_TRUNC function truncates a time stamp expression or literal based on the date part that you specify, such as hour, week, or month. DATE_TRUNC returns the first day of the specified year, the first day of the specified month, or the Monday of the specified week. +[DECODE] +declaration=expression,search,result,default +category=Conditional Expressions +description=A DECODE expression replaces a specific value with either another specific value or a default value, depending on the result of an equality condition. This operation is equivalent to the operation of a simple CASE expression or an IF-THEN-ELSE statement. +[DEGREES] +declaration=number +category=Math Functions +description=Converts an angle in radians to its equivalent in degrees. +[DENSE_RANK] +declaration=expr_list,order_list +category=Window Functions +description=The DENSE_RANK window function determines the rank of a value in a group of values, based on the ORDER BY expression in the OVER clause. If the optional PARTITION BY clause is present, the rankings are reset for each group of rows. Rows with equal values for the ranking criteria receive the same rank. The DENSE_RANK function differs from RANK in one respect: If two or more rows tie, there is no gap in the sequence of ranked values. For example, if two rows are ranked 1, the next rank is 2. +[DEXP] +declaration=number +category=Math Functions +description=The DEXP function returns the exponential value in scientific notation for a double precision number. The only difference between the DEXP and EXP functions is that the parameter for DEXP must be a double precision. +[DLOG10] +declaration=number +category=Math Functions +description=The DLOG10 returns the base 10 logarithm of the input parameter. Synonym of the LOG function. +[DLOG1] +declaration= +category=Math Functions +description=The DLOG1 function returns the natural logarithm of the input parameter. Synonym for the LN function. +[EXP] +declaration=expression +category=Math Functions +description=The EXP function returns the exponential value in scientific notation for a numeric expression. +[EXTRACT] +declaration=datepart,literal,timestamp +category=Date and Time Functions +description=The EXTRACT function returns a date part, such as a day, month, or year, from a time stamp value or expression. +[FIRST_VALUE] +declaration=expression,expr_list,order_list,frame_clause +category=Window Functions +description=Given an ordered set of rows, FIRST_VALUE returns the value of the specified expression with respect to the first row in the window frame. The LAST_VALUE function returns the value of the expression with respect to the last row in the frame. +[FLOOR] +declaration=number +category=Math Functions +description=The FLOOR function rounds a number down to the next whole number. +[FUNC_SHA1] +declaration=string +category=String Functions +description=The FUNC_SHA1 function uses the SHA1 cryptographic hash function to convert a variable-length string into a 40-character string that is a text representation of the hexadecimal value of a 160-bit checksum. +[GETDATE] +declaration= +category=Date and Time Functions +description=GETDATE returns the current date and time in the current session time zone (UTC by default). +[GREATEST] +declaration=expression_list +category=Conditional Expressions +description=Returns the largest value from a list of any number of expressions. +[HAS_DATABASE_PRIVILEGE] +declaration=user,database,privilege +category=System Information Functions +description=Returns true if the user has the specified privilege for the specified database. For more information about privileges, see GRANT. +[HAS_SCHEMA_PRIVILEGE] +declaration=user,schema,privilege +category=System Information Functions +description=Returns true if the user has the specified privilege for the specified schema. For more information about privileges, see GRANT. +[HAS_TABLE_PRIVILEGE] +declaration=user,table,privilege +category=System Information Functions +description=Returns true if the user has the specified privilege for the specified table. +[INITCAP] +declaration=string +category=String Functions +description=Capitalizes the first letter of each word in a specified string. INITCAP supports UTF-8 multibyte characters, up to a maximum of four bytes per character. +[INTERVAL_CMP] +declaration=interval1,interval2 +category=Date and Time Functions +description=INTERVAL_CMP compares two intervals and returns 1 if the first interval is greater, -1 if the second interval is greater, and 0 if the intervals are equal. For more information, see Interval Literals. +[IS_VALID_JSON] +declaration=json_string +category=JSON Functions +description=IS_VALID_JSON validates a JSON string. The function returns Boolean true (t) if the string is properly formed JSON or false (f) if the string is malformed. To validate a JSON array, use IS_VALID_JSON_ARRAY Function +[IS_VALID_JSON_ARRAY] +declaration=json_array +category=JSON Functions +description=IS_VALID_JSON_ARRAY validates a JSON array. The function returns Boolean true (t) if the array is properly formed JSON or false (f) if the array is malformed. To validate a JSON string, use IS_VALID_JSON Function +[JSON_ARRAY_LENGTH] +declaration=json_array,null_if_invalid +category=JSON Functions +description=JSON_ARRAY_LENGTH returns the number of elements in the outer array of a JSON string. If the null_if_invalid argument is set to true and the JSON string is invalid, the function returns NULL instead of returning an error. +[JSON_EXTRACT_ARRAY_ELEMENT_TEXT] +declaration=json_string,pos,null_if_invalid +category=JSON Functions +description=JSON_EXTRACT_ARRAY_ELEMENT_TEXT returns a JSON array element in the outermost array of a JSON string, using a zero-based index. The first element in an array is at position 0. If the index is negative or out of bound, JSON_EXTRACT_ARRAY_ELEMENT_TEXT returns empty string. If the null_if_invalid argument is set to true and the JSON string is invalid, the function returns NULL instead of returning an error. +[JSON_EXTRACT_PATH_TEXT] +declaration=json_string,path_elem,null_if_invalid +category=JSON Functions +description=JSON_EXTRACT_PATH_TEXT returns the value for the key:value pair referenced by a series of path elements in a JSON string. The JSON path can be nested up to five levels deep. Path elements are case-sensitive. If a path element does not exist in the JSON string, JSON_EXTRACT_PATH_TEXT returns an empty string. If the null_if_invalid argument is set to true and the JSON string is invalid, the function returns NULL instead of returning an error. +[LAG] +declaration=value_expr,offset,window_partition,window_ordering +category=Window Functions +description=The LAG window function returns the values for a row at a given offset above (before) the current row in the partition. +[LAST_DAY] +declaration= +category=Date and Time Functions +description=LAST_DAY returns the date of the last day of the month that contains date. The return type is always DATE, regardless of the data type of the date argument. +[LAST_VALUE] +declaration=expression,expr_list,order_list,frame_clause +category=Window Functions +description=Given an ordered set of rows, FIRST_VALUE returns the value of the specified expression with respect to the first row in the window frame. The LAST_VALUE function returns the value of the expression with respect to the last row in the frame. +[LEAD] +declaration=value_expr,offset,window_partition,window_ordering +category=Window Functions +description=The LEAD window function returns the values for a row at a given offset below (after) the current row in the partition. +[LEAST] +declaration=expression_list +category=Conditional Expressions +description=Returns the smallest value from a list of any number of expressions. +[LEFT] +declaration=string,integer +category=String Functions +description=These functions return the specified number of leftmost or rightmost characters from a character string. +[LENGTH] +declaration= +category=String Functions +description=Synonym of the LEN function. +[LEN] +declaration=expression +category=String Functions +description=Returns the length of the specified string as the number of characters. +[LISTAGG] +declaration=aggregate_expression,delimiter,WITHIN GROUP (ORDER BY order_list) +category=Aggregate Functions +description=For each group in a query, the LISTAGG aggregate function orders the rows for that group according to the ORDER BY expression, then concatenates the values into a single string. +[LN] +declaration=expression +category=Math Functions +description=Returns the natural logarithm of the input parameter. Synonym of the DLOG1 function. +[LOG] +declaration=number +category=Math Functions +description=Returns the base 10 logarithm of a number. +[LOWER] +declaration=string +category=String Functions +description=Converts a string to lowercase. LOWER supports UTF-8 multibyte characters, up to a maximum of four bytes per character. +[LPAD] +declaration=string1,length,string2 +category=String Functions +description=These functions prepend or append characters to a string, based on a specified length. +[LTRIM] +declaration=string,trim_chars +category=String Functions +description=The LTRIM function trims a specified set of characters from the beginning of a string. +[MAX] +declaration=expression +category=Aggregate Functions +description=The MAX function returns the maximum value in a set of rows. DISTINCT or ALL may be used but do not affect the result. +[MD5] +declaration=string +category=String Functions +description=Uses the MD5 cryptographic hash function to convert a variable-length string into a 32-character string that is a text representation of the hexadecimal value of a 128-bit checksum. +[MEDIAN] +declaration=median_expression +category=Aggregate Functions +description=Calculates the median value for the range of values. NULL values in the range are ignored. +[MIN] +declaration=expression +category=Aggregate Functions +description=The MIN function returns the minimum value in a set of rows. DISTINCT or ALL may be used but do not affect the result. +[MOD] +declaration=number1,number2 +category=Math Functions +description=The MOD function returns a numeric result that is the remainder of two numeric parameters. The first parameter is divided by the second parameter. +[MONTHS_BETWEEN] +declaration=date1,date2 +category=Date and Time Functions +description=MONTHS_BETWEEN determines the number of months between two dates. +[NEXT_DAY] +declaration=date,timestamp,day +category=Date and Time Functions +description=NEXT_DAY returns the date of the first instance of the specified day that is later than the given date. +[NTH_VALUE] +declaration=expr,offset,window_partition,window_ordering,frame_clause +category=Window Functions +description=The NTH_VALUE window function returns the expression value of the specified row of the window frame relative to the first row of the window. +[NTILE] +declaration=expr,window_partition,window_ordering +category=Window Functions +description=The NTILE window function divides ordered rows in the partition into the specified number of ranked groups of as equal size as possible and returns the group that a given row falls into. +[NULLIF] +declaration=expression1, expression2 +category=Conditional Expressions +description=The NULLIF expression compares two arguments and returns null if the arguments are equal. +[NVL2] +declaration=expression,not_null_return_value,null_return_value +category=Conditional Expressions +description=Returns one of two values based on whether a specified expression evaluates to NULL or NOT NULL. +[NVL] +declaration= +category=Conditional Expressions +description=An NVL expression is identical to a COALESCE expression. NVL and COALESCE are synonyms. +[OCTET_LENGTH] +declaration=expression +category=String Functions +description=Returns the length of the specified string as the number of bytes. +[PERCENTILE_CONT] +declaration=percentile,expr +category=Aggregate Functions +description=PERCENTILE_CONT is an inverse distribution function that assumes a continuous distribution model. It takes a percentile value and a sort specification, and returns an interpolated value that would fall into the given percentile value with respect to the sort specification. +[PERCENTILE_DISC] +declaration=percentile,expr +category=Aggregate Functions +description=APPROXIMATE PERCENTILE_DISC is an inverse distribution function that assumes a discrete distribution model. It takes a percentile value and a sort specification and returns an element from the given set. Approximation enables the function to execute much faster, with a low relative error of around 0.5 percent. +[PERCENT_RANK] +declaration=partition_expression,order_list +category=Window Functions +description=Calculates the percent rank of a given row. The percent rank is determined using this formula: +[PG_BACKEND_PID] +declaration= +category=System Information Functions +description=Returns the process ID (PID) of the server process handling the current session. +[PG_CANCEL_BACKEND] +declaration=pid +category=System Administration Functions +description=Cancels a query. PG_CANCEL_BACKEND is functionally equivalent to the CANCEL command. You can cancel queries currently being run by your user. Superusers can cancel any query. +[PG_GET_COLS] +declaration=name +category=System Information Functions +description=Returns the column metadata for a table or view definition. +[PG_GET_LATE_BINDING_VIEW_COLS] +declaration= +category=System Information Functions +description=Returns the column metadata for all late-binding views in the database. For more information, see Late-Binding Views +[PG_LAST_COPY_COUNT] +declaration= +category=System Information Functions +description=Returns the number of rows that were loaded by the last COPY command executed in the current session. PG_LAST_COPY_COUNT is updated with the last COPY ID, which is the query ID of the last COPY that began the load process, even if the load failed. The query ID and COPY ID are updated when the COPY command begins the load process. +[PG_LAST_COPY_ID] +declaration= +category=System Information Functions +description=Returns the query ID of the most recently executed COPY command in the current session. If no COPY commands have been executed in the current session, PG_LAST_COPY_ID returns -1. +[PG_LAST_QUERY_ID] +declaration= +category=System Information Functions +description=Returns the query ID of the most recently executed query in the current session. If no queries have been executed in the current session, PG_LAST_QUERY_ID returns -1. PG_LAST_QUERY_ID does not return the query ID for queries that execute exclusively on the leader node. For more information, see Leader Node–Only Functions. +[PG_LAST_UNLOAD_COUNT] +declaration= +category=System Information Functions +description=Returns the number of rows that were unloaded by the last UNLOAD command executed in the current session. PG_LAST_UNLOAD_COUNT is updated with the query ID of the last UNLOAD, even if the operation failed. The query ID is updated when the UNLOAD is executed. If the UNLOAD fails because of a syntax error or because of insufficient privileges, PG_LAST_UNLOAD_COUNT returns the count for the previous UNLOAD. If no UNLOAD commands were executed in the current session, or if the last UNLOAD failed during the unload operation, PG_LAST_UNLOAD_COUNT returns 0. +[PG_LAST_UNLOAD_ID] +declaration= +category=System Information Functions +description=Returns the query ID of the most recently executed UNLOAD command in the current session. If no UNLOAD commands have been executed in the current session, PG_LAST_UNLOAD_ID returns -1. +[PG_TERMINATE_BACKEND] +declaration=pid +category=System Administration Functions +description=Terminates a session. You can terminate a session owned by your user. A superuser can terminate any session. +[PI] +declaration= +category=Math Functions +description=The PI function returns the value of PI to 14 decimal places. +[POSITION] +declaration=substring,string +category=String Functions +description=Returns the location of the specified substring within a string. +[POWER] +declaration=expression1,expression2 +category=Math Functions +description=The POWER function is an exponential function that raises a numeric expression to the power of a second numeric expression. +[QUOTE_IDENT] +declaration=string +category=String Functions +description=The QUOTE_IDENT function returns the specified string as a double quoted string so that it can be used as an identifier in a SQL statement. Appropriately doubles any embedded double quotes. +[QUOTE_LITERAL] +declaration=string +category=String Functions +description=The QUOTE_LITERAL function returns the specified string as a quoted string so that it can be used as a string literal in a SQL statement. If the input parameter is a number, QUOTE_LITERAL treats it as a string. Appropriately doubles any embedded single quotes and backslashes. +[RADIANS] +declaration=string +category=Math Functions +description=Converts an angle in degrees to its equivalent in radians. +[RANDOM] +declaration= +category=Math Functions +description=The RANDOM function generates a random value between 0.0 and 1.0. +[RANK] +declaration=expr_list,order_list +category=Window Functions +description=The RANK window function determines the rank of a value in a group of values, based on the ORDER BY expression in the OVER clause. If the optional PARTITION BY clause is present, the rankings are reset for each group of rows. Rows with equal values for the ranking criteria receive the same rank. Amazon Redshift adds the number of tied rows to the tied rank to calculate the next rank and thus the ranks might not be consecutive numbers. For example, if two rows are ranked 1, the next rank is 3. +[RATIO_TO_REPORT] +declaration=ratio_expression,partition_expression +category=Window Functions +description=Calculates the ratio of a value to the sum of the values in a window or partition. The ratio to report value is determined using the formula: +[REGEXP_COUNT] +declaration=source_string,pattern,position +category=String Functions +description=Searches a string for a regular expression pattern and returns an integer that indicates the number of times the pattern occurs in the string. If no match is found, then the function returns 0. For more information about regular expressions, see POSIX Operators. +[REGEXP_INSTR] +declaration=source_string,pattern,position,occurrence,option,parameters +category=String Functions +description=Searches a string for a regular expression pattern and returns an integer that indicates the beginning position or ending position of the matched substring. If no match is found, then the function returns 0. REGEXP_INSTR is similar to the POSITION function, but lets you search a string for a regular expression pattern. For more information about regular expressions, see POSIX Operators. +[REGEXP_REPLACE] +declaration=source_string,pattern,replace_string,position +category=String Functions +description=Searches a string for a regular expression pattern and replaces every occurrence of the pattern with the specified string. REGEXP_REPLACE is similar to the REPLACE Function, but lets you search a string for a regular expression pattern. For more information about regular expressions, see POSIX Operators. +[REGEXP_SUBSTR] +declaration=source_string,pattern,position,occurrence,parameters +category=String Functions +description=Returns the characters extracted from a string by searching for a regular expression pattern. REGEXP_SUBSTR is similar to the SUBSTRING Function function, but lets you search a string for a regular expression pattern. For more information about regular expressions, see POSIX Operators. +[REPEAT] +declaration=string,integer +category=String Functions +description=Repeats a string the specified number of times. If the input parameter is numeric, REPEAT treats it as a string. +[REPLACE] +declaration=string,old_chars,new_chars,old_string +category=String Functions +description=Replaces all occurrences of a set of characters within an existing string with other specified characters. +[REPLICATE] +declaration= +category=String Functions +description=Synonym for the REPEAT function. +[REVERSE] +declaration=expression +category=String Functions +description=The REVERSE function operates on a string and returns the characters in reverse order. For example, reverse('abcde') returns edcba. This function works on numeric and date data types as well as character data types; however, in most cases it has practical value for character strings. +[RIGHT] +declaration=string,integer +category=String Functions +description=These functions return the specified number of leftmost or rightmost characters from a character string. +[ROUND] +declaration=number +category=Math Functions +description=The ROUND function rounds numbers to the nearest integer or decimal. +[ROW_NUMBER] +declaration=expr_list,order_list +category=Window Functions +description=Determines the ordinal number of the current row within a group of rows, counting from 1, based on the ORDER BY expression in the OVER clause. If the optional PARTITION BY clause is present, the ordinal numbers are reset for each group of rows. Rows with equal values for the ORDER BY expressions receive the different row numbers nondeterministically. +[RPAD] +declaration=string1,length,string2 +category=String Functions +description=These functions prepend or append characters to a string, based on a specified length. +[RTRIM] +declaration=string,trim_chars +category=String Functions +description=The RTRIM function trims a specified set of characters from the end of a string. +[SESSION_USER] +declaration= +category=System Information Functions +description=Returns the name of the user associated with the current session. This is the user who initiated the current database connection. +[SET_CONFIG] +declaration=parameter,new_value,is_local +category=System Administration Functions +description=Sets a configuration parameter to a new setting. +[SIGN] +declaration=numeric +category=Math Functions +description=The SIGN function returns the sign (positive or negative) of a numeric value. The result of the SIGN function will be a 1, -1, or 0 indicating the sign of the argument. +[SIN] +declaration=number +category=Math Functions +description=SIN is a trigonometric function that returns the sine of a number. The return value is in radians and is between PI/2 and -PI/2. +[SLICE_NUM] +declaration= +category=System Information Functions +description=Returns an integer corresponding to the slice number in the cluster where the data for a row is located. SLICE_NUM takes no parameters. +[SPLIT_PART] +declaration=string,delimiter,part +category=String Functions +description=Splits a string on the specified delimiter and returns the part at the specified position. +[SQRT] +declaration=expression +category=Math Functions +description=The SQRT function returns the square root of a numeric value. +[STDDEV_POP] +declaration= +category=Aggregate Functions +description=The STDDEV_SAMP and STDDEV_POP functions return the sample and population standard deviation of a set of numeric values (integer, decimal, or floating-point). The result of the STDDEV_SAMP function is equivalent to the square root of the sample variance of the same set of values. +[STDDEV_SAMP] +declaration= +category=Aggregate Functions +description=The STDDEV_SAMP and STDDEV_POP functions return the sample and population standard deviation of a set of numeric values (integer, decimal, or floating-point). The result of the STDDEV_SAMP function is equivalent to the square root of the sample variance of the same set of values. +[STRPOS] +declaration=string,substring +category=String Functions +description=Returns the position of a substring within a specified string. +[STRTOL] +declaration=num_string,base +category=String Functions +description=Converts a string expression of a number of the specified base to the equivalent integer value. The converted value must be within the signed 64-bit range. +[SUBSTRING] +declaration=string,start_position,number_characters +category=String Functions +description=Returns the characters extracted from a string based on the specified character position for a specified number of characters. +[SUM] +declaration=expression +category=Aggregate Functions +description=The SUM function returns the sum of the input column or expression values. The SUM function works with numeric values and ignores NULL values. +[SYSDATE] +declaration= +category=Date and Time Functions +description=SYSDATE returns the current date and time in the current session time zone (UTC by default). +[TAN] +declaration=number +category=Math Functions +description=TAN is a trigonometric function that returns the tangent of a number. The input parameter must be a non-zero number (in radians). +[TEXTLEN] +declaration= +category=String Functions +description=Synonym of LEN function. +[TIMEOFDAY] +declaration= +category=Date and Time Functions +description=TIMEOFDAY is a special alias used to return the weekday, date, and time as a string value. +[TIMESTAMPTZ_CMP] +declaration=timestamptz1,timestamptz2 +category=Date and Time Functions +description=TIMESTAMPTZ_CMP compares the value of two time stamp with time zone values and returns an integer. If the time stamps are identical, the function returns 0. If the first time stamp is greater alphabetically, the function returns 1. If the second time stamp is greater, the function returns –1. +[TIMESTAMPTZ_CMP_DATE] +declaration=timestamptz,date +category=Date and Time Functions +description=TIMESTAMPTZ_CMP_DATE compares the value of a time stamp and a date. If the time stamp and date values are identical, the function returns 0. If the time stamp is greater alphabetically, the function returns 1. If the date is greater, the function returns –1. +[TIMESTAMPTZ_CMP_TIMESTAMP] +declaration=timestamptz,timestamp +category=Date and Time Functions +description=TIMESTAMPTZ_CMP_TIMESTAMP compares the value of a time stamp with time zone expression with a time stamp expression. If the time stamp with time zone and time stamp values are identical, the function returns 0. If the time stamp with time zone is greater alphabetically, the function returns 1. If the time stamp is greater, the function returns –1. +[TIMESTAMP_CMP] +declaration=timestamp1,timestamp2 +category=Date and Time Functions +description=Compares the value of two time stamps and returns an integer. If the time stamps are identical, the function returns 0. If the first time stamp is greater alphabetically, the function returns 1. If the second time stamp is greater, the function returns –1. +[TIMESTAMP_CMP_DATE] +declaration=timestamp,date +category=Date and Time Functions +description=TIMESTAMP_CMP_DATE compares the value of a time stamp and a date. If the time stamp and date values are identical, the function returns 0. If the time stamp is greater alphabetically, the function returns 1. If the date is greater, the function returns –1. +[TIMESTAMP_CMP_TIMESTAMPTZ] +declaration=timestamp,timestamptz +category=Date and Time Functions +description=TIMESTAMP_CMP_TIMESTAMPTZ compares the value of a time stamp expression with a time stamp with time zone expression. If the time stamp and time stamp with time zone values are identical, the function returns 0. If the time stamp is greater alphabetically, the function returns 1. If the time stamp with time zone is greater, the function returns –1. +[TIMEZONE] +declaration=timezone,timestamp,timestamptz +category=Date and Time Functions +description=TIMEZONE returns a time stamp for the specified time zone and time stamp value. +[TO_CHAR] +declaration=timestamp_expression,numeric_expression,format +category=Data Type Formatting Functions +description=TO_CHAR converts a time stamp or numeric expression to a character-string data format. +[TO_DATE] +declaration=string,format +category=Data Type Formatting Functions +description=TO_DATE converts a date represented in a character string to a DATE data type. +[TO_HEX] +declaration=number +category=Math Functions +description=The TO_HEX function converts a number to its equivalent hexadecimal value. +[TO_NUMBER] +declaration=string,format +category=Data Type Formatting Functions +description=TO_NUMBER converts a string to a numeric (decimal) value. +[TO_TIMESTAMP] +declaration=timestamp,format +category=Date and Time Functions +description=TO_TIMESTAMP converts a TIMESTAMP string to TIMESTAMPTZ. +[TRANSLATE] +declaration=expression,characters_to_replace,characters_to_substitute +category=String Functions +description=For a given expression, replaces all occurrences of specified characters with specified substitutes. Existing characters are mapped to replacement characters by their positions in the characters_to_replace and characters_to_substitute arguments. If more characters are specified in the characters_to_replace argument than in the characters_to_substitute argument, the extra characters from the characters_to_replace argument are omitted in the return value. +[TRIM] +declaration=characters,string +category=String Functions +description=The TRIM function trims a string by removing leading and trailing blanks or by removing characters that match an optional specified string. +[TRUNC] +declaration=number,integer,timestamp +category=Math Functions +description=The TRUNC function truncates a number and right-fills it with zeros from the position specified. This function also truncates a time stamp and returns a date. +[TRUNC] +declaration=timestamp +category=Date and Time Functions +description=Truncates a time stamp and returns a date. +[UPPER] +declaration=string +category=String Functions +description=Converts a string to uppercase. UPPER supports UTF-8 multibyte characters, up to a maximum of four bytes per character. +[USER] +declaration= +category=System Information Functions +description=Synonym for CURRENT_USER. See CURRENT_USER. +[VAR_POP] +declaration= +category=Aggregate Functions +description=The VAR_SAMP and VAR_POP functions return the sample and population variance of a set of numeric values (integer, decimal, or floating-point). The result of the VAR_SAMP function is equivalent to the squared sample standard deviation of the same set of values. +[VAR_SAMP] +declaration= +category=Aggregate Functions +description=The VAR_SAMP and VAR_POP functions return the sample and population variance of a set of numeric values (integer, decimal, or floating-point). The result of the VAR_SAMP function is equivalent to the squared sample standard deviation of the same set of values. +[VERSION] +declaration= +category=System Information Functions +description=The VERSION() function returns details about the currently installed release, with specific Amazon Redshift version information at the end. \ No newline at end of file diff --git a/out/functions-sqlite.ini b/out/functions-sqlite.ini new file mode 100644 index 000000000..d827e4536 Binary files /dev/null and b/out/functions-sqlite.ini differ diff --git a/out/heidisql.iss b/out/heidisql.iss index 37c95ef16..bf9fbe812 100644 --- a/out/heidisql.iss +++ b/out/heidisql.iss @@ -4,16 +4,22 @@ #define ProgName "HeidiSQL" #define ProgNameLower LowerCase(ProgName) #define ProgExeName ProgNameLower + ".exe" -#define ProgVersion GetFileVersion(AddBackslash(SourcePath) + ProgNameLower + "32.exe") -; Take care: this takes the first 4(!) chars of the exe's version string, eg "10.0" -#define ProgShortVersion Copy(ProgVersion, 1, 4) #define WebSite "https://www." + ProgNameLower + ".com/" #define OutDir "." #define ResourceDir OutDir + "\..\res\" +#define SnippetsDir "{autodocs}\" + ProgName + "\Snippets" +; Some effort to get the major.minor program version: "11.23" +#define ProgVerMajor +#define ProgVerMinor +#define ProgVerRevision +#define ProgVerBuild +#define ProgVersion GetVersionComponents(AddBackslash(SourcePath) + ProgNameLower + "64.exe", ProgVerMajor, ProgVerMinor, ProgVerRevision, ProgVerBuild) +#define ProgVersionStr Str(ProgVerMajor) + "." + Str(ProgVerMinor) + "." + Str(ProgVerRevision) + "." + Str(ProgVerBuild) [Languages] Name: "en"; MessagesFile: "compiler:Default.isl" Name: "hy"; MessagesFile: "compiler:Languages\Armenian.isl" +Name: "bg"; MessagesFile: "compiler:Languages\Bulgarian.isl" Name: "ca"; MessagesFile: "compiler:Languages\Catalan.isl" Name: "co"; MessagesFile: "compiler:Languages\Corsican.isl" Name: "cs"; MessagesFile: "compiler:Languages\Czech.isl" @@ -23,16 +29,21 @@ Name: "fi"; MessagesFile: "compiler:Languages\Finnish.isl" Name: "fr"; MessagesFile: "compiler:Languages\French.isl" Name: "de"; MessagesFile: "compiler:Languages\German.isl" Name: "he"; MessagesFile: "compiler:Languages\Hebrew.isl" +Name: "hu"; MessagesFile: "compiler:Languages\Hungarian.isl" Name: "is"; MessagesFile: "compiler:Languages\Icelandic.isl" Name: "it"; MessagesFile: "compiler:Languages\Italian.isl" Name: "ja"; MessagesFile: "compiler:Languages\Japanese.isl" +Name: "kr"; MessagesFile: "compiler:Languages\Korean.isl" Name: "no"; MessagesFile: "compiler:Languages\Norwegian.isl" Name: "pl"; MessagesFile: "compiler:Languages\Polish.isl" Name: "pt"; MessagesFile: "compiler:Languages\Portuguese.isl" Name: "pt_BR"; MessagesFile: "compiler:Languages\BrazilianPortuguese.isl" Name: "ru"; MessagesFile: "compiler:Languages\Russian.isl" +Name: "sk"; MessagesFile: "compiler:Languages\Slovak.isl" Name: "sl"; MessagesFile: "compiler:Languages\Slovenian.isl" Name: "es"; MessagesFile: "compiler:Languages\Spanish.isl" +Name: "se"; MessagesFile: "compiler:Languages\Swedish.isl" +Name: "ta"; MessagesFile: "compiler:Languages\Tamil.isl" Name: "tr"; MessagesFile: "compiler:Languages\Turkish.isl" Name: "uk"; MessagesFile: "compiler:Languages\Ukrainian.isl" @@ -41,86 +52,87 @@ AppId={#ProgName} AppName={#ProgName} AppVerName={#ProgName} {#ProgVersion} VersionInfoVersion={#ProgVersion} - ; Displayed on the "Support" dialog of the Add/Remove Programs Control Panel applet: -AppVersion={#ProgShortVersion} +AppVersion={#ProgVersionStr} AppPublisher=Ansgar Becker AppPublisherURL={#WebSite} AppSupportURL={#WebSite}forum.php AppUpdatesURL={#WebSite}download.php -AppContact={#ProgNameLower}@anse.de +AppContact=anse@heidisql.com AppReadmeFile={#WebSite}help.php?place=installer - +Compression=lzma2/ultra64 +SolidCompression=yes CloseApplications=yes ShowLanguageDialog=auto -DefaultDirName={commonpf}\{#ProgName} +DefaultDirName={autopf}\{#ProgName} DefaultGroupName={#ProgName} AllowNoIcons=yes LicenseFile=license.txt ChangesAssociations=yes +WizardStyle=modern WizardImageFile={#ResourceDir}installer-logo.bmp WizardSmallImageFile={#ResourceDir}installer-small-logo.bmp OutputDir={#OutDir} -OutputBaseFilename={#ProgName}_{#ProgShortVersion}_Setup +OutputBaseFilename={#ProgName}_{#ProgVersionStr}_Setup UninstallDisplayIcon={app}\{#ProgExeName} SetupIconFile={#ResourceDir}mainicon.ico -ArchitecturesInstallIn64BitMode=x64 +ArchitecturesAllowed=x64compatible +ArchitecturesInstallIn64BitMode=x64compatible UsePreviousAppDir=yes DirExistsWarning=auto -PrivilegesRequired=none +PrivilegesRequired=admin +PrivilegesRequiredOverridesAllowed=commandline dialog +;SignedUninstaller=yes +;SignTool=signtool $f [Tasks] -Name: "desktopicon"; Description: "Create a &desktop icon"; GroupDescription: "Options:"; MinVersion: 4,4 -Name: "associatesqlfiles"; Description: "Associate .&SQL files with {#ProgName}"; GroupDescription: "Options:"; -Name: "activate_updatechecks"; Description: "Automatically check {#WebSite} for updates"; GroupDescription: "Options:"; -Name: "activate_statistics"; Description: "Automatically report client and server versions on {#WebSite}"; GroupDescription: "Options:"; -Name: "theme_windows"; Description: "Use default Windows theme"; GroupDescription: "Select theme:"; Flags: exclusive -Name: "theme_material"; Description: "Use dark Material theme"; GroupDescription: "Select theme:"; Flags: exclusive unchecked - -[InstallDelete] -Type: files; Name: "{app}\heidisql32.exe" -Type: files; Name: "{app}\ssleay32.dll" -Type: files; Name: "{app}\libeay32.dll" -Type: files; Name: "{app}\libpq.dll" +Name: "desktopicon"; Description: "Create a &desktop icon"; GroupDescription: "Local options:"; MinVersion: 4,4 +Name: "install_snippets"; Description: "Create example SQL snippet files in {#SnippetsDir}"; GroupDescription: "Local options:"; Flags: unchecked +Name: "associatesqlfiles"; Description: "Associate .&SQL files with {#ProgName}"; GroupDescription: "Local options:"; +Name: "activate_updatechecks"; Description: "Automatically check {#WebSite} for updates"; GroupDescription: "Telemetry:"; +Name: "activate_statistics"; Description: "Automatically report client and server versions on {#WebSite}"; GroupDescription: "Telemetry:"; [Files] -Source: "{#ProgNameLower}64.exe"; DestDir: "{app}"; DestName: "{#ProgExeName}"; Check: Is64BitInstallMode; Flags: ignoreversion -Source: "{#ProgNameLower}32.exe"; DestDir: "{app}"; DestName: "{#ProgExeName}"; Check: not Is64BitInstallMode; Flags: ignoreversion +Source: "{#ProgNameLower}64.exe"; DestDir: "{app}"; DestName: "{#ProgExeName}"; Flags: ignoreversion Source: "license.txt"; DestDir: "{app}"; Flags: ignoreversion Source: "gpl.txt"; DestDir: "{app}"; Flags: ignoreversion -Source: "plugins64\*.dll"; DestDir: "{app}\plugins"; Check: Is64BitInstallMode; Flags: ignoreversion -Source: "plugins32\*.dll"; DestDir: "{app}\plugins"; Check: not Is64BitInstallMode; Flags: ignoreversion -Source: "Snippets\*.sql"; DestDir: "{userdocs}\{#ProgName}\Snippets"; -Source: "plink-64.exe"; DestDir: "{app}"; DestName: "plink.exe"; Check: Is64BitInstallMode; Flags: ignoreversion -Source: "plink-32.exe"; DestDir: "{app}"; DestName: "plink.exe"; Check: not Is64BitInstallMode; Flags: ignoreversion +Source: "plugins64\*.dll"; DestDir: "{app}\plugins"; Flags: ignoreversion +Source: "Snippets\*.sql"; DestDir: "{#SnippetsDir}"; Tasks: install_snippets +Source: "plink-64.exe"; DestDir: "{app}"; DestName: "plink.exe"; Flags: ignoreversion +Source: "plink-0.81-64.exe"; DestDir: "{app}"; DestName: "plink-0.81.exe"; Flags: ignoreversion +; OpenSSL libraries, used by Indy HTTP: +Source: "libeay32-64.dll"; DestDir: "{app}"; DestName: "libeay32.dll"; Flags: ignoreversion +Source: "ssleay32-64.dll"; DestDir: "{app}"; DestName: "ssleay32.dll"; Flags: ignoreversion ; MySQL + MariaDB: -Source: "libmariadb64.dll"; DestDir: "{app}"; DestName: "libmariadb.dll"; Check: Is64BitInstallMode; Flags: ignoreversion -Source: "libmariadb32.dll"; DestDir: "{app}"; DestName: "libmariadb.dll"; Check: not Is64BitInstallMode; Flags: ignoreversion -Source: "libmysql64.dll"; DestDir: "{app}"; DestName: "libmysql.dll"; Check: Is64BitInstallMode; Flags: ignoreversion -Source: "libmysql32.dll"; DestDir: "{app}"; DestName: "libmysql.dll"; Check: not Is64BitInstallMode; Flags: ignoreversion -Source: "libmysql-6.1-64.dll"; DestDir: "{app}"; DestName: "libmysql-6.1.dll"; Check: Is64BitInstallMode; Flags: ignoreversion -Source: "libmysql-6.1-32.dll"; DestDir: "{app}"; DestName: "libmysql-6.1.dll"; Check: not Is64BitInstallMode; Flags: ignoreversion +Source: "libmariadb-64.dll"; DestDir: "{app}"; DestName: "libmariadb.dll"; Flags: ignoreversion +Source: "libmysql-64.dll"; DestDir: "{app}"; DestName: "libmysql.dll"; Flags: ignoreversion +Source: "libmysql-6.1-64.dll"; DestDir: "{app}"; DestName: "libmysql-6.1.dll"; Flags: ignoreversion +Source: "libmysql-8.4.0-64.dll"; DestDir: "{app}"; DestName: "libmysql-8.4.0.dll"; Flags: ignoreversion +Source: "libmysql-9.4.0-64.dll"; DestDir: "{app}"; DestName: "libmysql-9.4.0.dll"; Flags: ignoreversion ; PostgreSQL: -Source: "libpq-10-64.dll"; DestDir: "{app}"; DestName: "libpq-10.dll"; Check: Is64BitInstallMode; Flags: ignoreversion -Source: "libpq-10-32.dll"; DestDir: "{app}"; DestName: "libpq-10.dll"; Check: not Is64BitInstallMode; Flags: ignoreversion -Source: "libpq-12-64.dll"; DestDir: "{app}"; DestName: "libpq-12.dll"; Check: Is64BitInstallMode; Flags: ignoreversion -Source: "libintl-8-64.dll"; DestDir: "{app}"; DestName: "libintl-8.dll"; Check: Is64BitInstallMode; Flags: ignoreversion -Source: "libintl-8-32.dll"; DestDir: "{app}"; DestName: "libintl-8.dll"; Check: not Is64BitInstallMode; Flags: ignoreversion -Source: "libssl-1_1-x64.dll"; DestDir: "{app}"; DestName: "libssl-1_1-x64.dll"; Check: Is64BitInstallMode; Flags: ignoreversion -Source: "libssl-1_1-32.dll"; DestDir: "{app}"; DestName: "libssl-1_1.dll"; Check: not Is64BitInstallMode; Flags: ignoreversion -Source: "libcrypto-1_1-x64.dll"; DestDir: "{app}"; DestName: "libcrypto-1_1-x64.dll"; Check: Is64BitInstallMode; Flags: ignoreversion -Source: "libcrypto-1_1-32.dll"; DestDir: "{app}"; DestName: "libcrypto-1_1.dll"; Check: not Is64BitInstallMode; Flags: ignoreversion -Source: "libiconv-2-64.dll"; DestDir: "{app}"; DestName: "libiconv-2.dll"; Check: Is64BitInstallMode; Flags: ignoreversion -Source: "libiconv-2-32.dll"; DestDir: "{app}"; DestName: "libiconv-2.dll"; Check: not Is64BitInstallMode; Flags: ignoreversion +Source: "libpq-15-64.dll"; DestDir: "{app}"; DestName: "libpq-15.dll"; Flags: ignoreversion +Source: "libpq-17-64.dll"; DestDir: "{app}"; DestName: "libpq-17.dll"; Flags: ignoreversion +Source: "libintl-9-64.dll"; DestDir: "{app}"; DestName: "libintl-9.dll"; Flags: ignoreversion +Source: "libssl-3-x64.dll"; DestDir: "{app}"; DestName: "libssl-3-x64.dll"; Flags: ignoreversion +Source: "libcrypto-3-x64.dll"; DestDir: "{app}"; DestName: "libcrypto-3-x64.dll"; Flags: ignoreversion +Source: "LICENSE-openssl"; DestDir: "{app}"; Flags: ignoreversion +Source: "libiconv-2-64.dll"; DestDir: "{app}"; DestName: "libiconv-2.dll"; Flags: ignoreversion +Source: "libwinpthread-1-64.dll"; DestDir: "{app}"; DestName: "libwinpthread-1.dll"; Flags: ignoreversion ; SQLite: -Source: "sqlite3-64.dll"; DestDir: "{app}"; DestName: "sqlite3.dll"; Check: Is64BitInstallMode; Flags: ignoreversion -Source: "sqlite3-32.dll"; DestDir: "{app}"; DestName: "sqlite3.dll"; Check: not Is64BitInstallMode; Flags: ignoreversion +Source: "sqlite3-64.dll"; DestDir: "{app}"; DestName: "sqlite3.dll"; Flags: ignoreversion +Source: "sqlite3mc-64.dll"; DestDir: "{app}"; DestName: "sqlite3mc.dll"; Flags: ignoreversion +; Interbase/Firebird: +Source: "ibclient64-14.1.dll"; DestDir: "{app}"; Flags: ignoreversion +Source: "fbclient-4.0-64.dll"; DestDir: "{app}"; DestName: "fbclient-4.0.dll"; Flags: ignoreversion +; SQL function definitions +Source: "functions-*.ini"; DestDir: "{app}"; Flags: ignoreversion [Icons] Name: "{group}\{#ProgName}"; Filename: "{app}\{#ProgExeName}" -Name: "{group}\General help"; Filename: "http://www.heidisql.com/help.php?place=startmenu" -Name: "{userdesktop}\{#ProgName}"; Filename: "{app}\{#ProgExeName}"; MinVersion: 4,4; Tasks: desktopicon +Name: "{group}\Website"; Filename: "{#Website}" +Name: "{group}\General help"; Filename: "{#Website}help.php?place=startmenu" +Name: "{autodesktop}\{#ProgName}"; Filename: "{app}\{#ProgExeName}"; MinVersion: 4,4; Tasks: desktopicon [Registry] Root: HKCR; Subkey: ".sql"; ValueType: string; ValueName: ""; ValueData: "SQLScriptFile"; Flags: noerror uninsdeletevalue; Tasks: associatesqlfiles @@ -131,54 +143,6 @@ Root: HKCR; Subkey: "SQLScriptFile\shell\open\command"; ValueType: string; Value Root: HKCU; Subkey: "Software\{#ProgName}"; ValueType: dword; ValueName: "Updatecheck"; ValueData: 1; Tasks: activate_updatechecks Root: HKCU; Subkey: "Software\{#ProgName}"; ValueType: dword; ValueName: "DoUsageStatistics"; ValueData: 1; Tasks: activate_statistics -; Store theme selection: "Windows" -Root: HKCU; Subkey: "Software\{#ProgName}"; ValueType: string; ValueName: "Theme"; ValueData: "Windows"; Tasks: theme_windows -; SQL colors from "Light" preset -Root: HKCU; Subkey: "Software\{#ProgName}"; ValueType: dword; ValueName: "SQL Attr Comment Foreground"; ValueData: "8421504"; Tasks: theme_windows -Root: HKCU; Subkey: "Software\{#ProgName}"; ValueType: dword; ValueName: "SQL Attr ConditionalComment Foreground"; ValueData: "8421504"; Tasks: theme_windows -Root: HKCU; Subkey: "Software\{#ProgName}"; ValueType: dword; ValueName: "SQL Attr DataType Foreground"; ValueData: "128"; Tasks: theme_windows -Root: HKCU; Subkey: "Software\{#ProgName}"; ValueType: dword; ValueName: "SQL Attr DelimitedIdentifier Foreground"; ValueData: "32896"; Tasks: theme_windows -Root: HKCU; Subkey: "Software\{#ProgName}"; ValueType: dword; ValueName: "SQL Attr Function Foreground"; ValueData: "8388608"; Tasks: theme_windows -Root: HKCU; Subkey: "Software\{#ProgName}"; ValueType: dword; ValueName: "SQL Attr Identifier Foreground"; ValueData: "32896"; Tasks: theme_windows -Root: HKCU; Subkey: "Software\{#ProgName}"; ValueType: dword; ValueName: "SQL Attr Key Foreground"; ValueData: "16711680"; Tasks: theme_windows -Root: HKCU; Subkey: "Software\{#ProgName}"; ValueType: dword; ValueName: "SQL Attr Number Foreground"; ValueData: "8388736"; Tasks: theme_windows -Root: HKCU; Subkey: "Software\{#ProgName}"; ValueType: dword; ValueName: "SQL Attr String Foreground"; ValueData: "32768"; Tasks: theme_windows -Root: HKCU; Subkey: "Software\{#ProgName}"; ValueType: dword; ValueName: "SQL Attr Symbol Foreground"; ValueData: "16711680"; Tasks: theme_windows -Root: HKCU; Subkey: "Software\{#ProgName}"; ValueType: dword; ValueName: "SQL Attr TableName Foreground"; ValueData: "16711935"; Tasks: theme_windows -Root: HKCU; Subkey: "Software\{#ProgName}"; ValueType: dword; ValueName: "SQL Attr Variable Foreground"; ValueData: "8388736"; Tasks: theme_windows -; Data type colors from "Light" preset -Root: HKCU; Subkey: "Software\{#ProgName}"; ValueType: dword; ValueName: "FieldColor_Binary"; ValueData: "8388736"; Tasks: theme_windows -Root: HKCU; Subkey: "Software\{#ProgName}"; ValueType: dword; ValueName: "FieldColor_Datetime"; ValueData: "128"; Tasks: theme_windows -Root: HKCU; Subkey: "Software\{#ProgName}"; ValueType: dword; ValueName: "FieldColor_Numeric"; ValueData: "16711680"; Tasks: theme_windows -Root: HKCU; Subkey: "Software\{#ProgName}"; ValueType: dword; ValueName: "FieldColor_Other"; ValueData: "32896"; Tasks: theme_windows -Root: HKCU; Subkey: "Software\{#ProgName}"; ValueType: dword; ValueName: "FieldColor_Real"; ValueData: "16711752"; Tasks: theme_windows -Root: HKCU; Subkey: "Software\{#ProgName}"; ValueType: dword; ValueName: "FieldColor_Spatial"; ValueData: "8421376"; Tasks: theme_windows -Root: HKCU; Subkey: "Software\{#ProgName}"; ValueType: dword; ValueName: "FieldColor_Text"; ValueData: "32768"; Tasks: theme_windows - -; Store theme selection: "Material" -Root: HKCU; Subkey: "Software\{#ProgName}"; ValueType: string; ValueName: "Theme"; ValueData: "Material"; Tasks: theme_material -; SQL colors from "Material" preset -Root: HKCU; Subkey: "Software\{#ProgName}"; ValueType: dword; ValueName: "SQL Attr Comment Foreground"; ValueData: "8023636"; Tasks: theme_material -Root: HKCU; Subkey: "Software\{#ProgName}"; ValueType: dword; ValueName: "SQL Attr ConditionalComment Foreground"; ValueData: "12108397"; Tasks: theme_material -Root: HKCU; Subkey: "Software\{#ProgName}"; ValueType: dword; ValueName: "SQL Attr DataType Foreground"; ValueData: "15372999"; Tasks: theme_material -Root: HKCU; Subkey: "Software\{#ProgName}"; ValueType: dword; ValueName: "SQL Attr DelimitedIdentifier Foreground"; ValueData: "16757122"; Tasks: theme_material -Root: HKCU; Subkey: "Software\{#ProgName}"; ValueType: dword; ValueName: "SQL Attr Function Foreground"; ValueData: "14929603"; Tasks: theme_material -Root: HKCU; Subkey: "Software\{#ProgName}"; ValueType: dword; ValueName: "SQL Attr Identifier Foreground"; ValueData: "16757122"; Tasks: theme_material -Root: HKCU; Subkey: "Software\{#ProgName}"; ValueType: dword; ValueName: "SQL Attr Key Foreground"; ValueData: "14929603"; Tasks: theme_material -Root: HKCU; Subkey: "Software\{#ProgName}"; ValueType: dword; ValueName: "SQL Attr Number Foreground"; ValueData: "7361535"; Tasks: theme_material -Root: HKCU; Subkey: "Software\{#ProgName}"; ValueType: dword; ValueName: "SQL Attr String Foreground"; ValueData: "8906947"; Tasks: theme_material -Root: HKCU; Subkey: "Software\{#ProgName}"; ValueType: dword; ValueName: "SQL Attr Symbol Foreground"; ValueData: "12897152"; Tasks: theme_material -Root: HKCU; Subkey: "Software\{#ProgName}"; ValueType: dword; ValueName: "SQL Attr TableName Foreground"; ValueData: "6911735"; Tasks: theme_material -Root: HKCU; Subkey: "Software\{#ProgName}"; ValueType: dword; ValueName: "SQL Attr Variable Foreground"; ValueData: "7064575"; Tasks: theme_material -; Data type colors from "Dark" preset -Root: HKCU; Subkey: "Software\{#ProgName}"; ValueType: dword; ValueName: "FieldColor_Binary"; ValueData: "13203071"; Tasks: theme_material -Root: HKCU; Subkey: "Software\{#ProgName}"; ValueType: dword; ValueName: "FieldColor_Datetime"; ValueData: "7566281"; Tasks: theme_material -Root: HKCU; Subkey: "Software\{#ProgName}"; ValueType: dword; ValueName: "FieldColor_Numeric"; ValueData: "16750469"; Tasks: theme_material -Root: HKCU; Subkey: "Software\{#ProgName}"; ValueType: dword; ValueName: "FieldColor_Other"; ValueData: "7586241"; Tasks: theme_material -Root: HKCU; Subkey: "Software\{#ProgName}"; ValueType: dword; ValueName: "FieldColor_Real"; ValueData: "13663613"; Tasks: theme_material -Root: HKCU; Subkey: "Software\{#ProgName}"; ValueType: dword; ValueName: "FieldColor_Spatial"; ValueData: "13553267"; Tasks: theme_material -Root: HKCU; Subkey: "Software\{#ProgName}"; ValueType: dword; ValueName: "FieldColor_Text"; ValueData: "7591283"; Tasks: theme_material - [Run] Filename: "{app}\{#ProgExeName}"; Description: "Launch {#ProgName}"; Flags: nowait postinstall skipifsilent diff --git a/out/ibclient64-14.1.dll b/out/ibclient64-14.1.dll new file mode 100644 index 000000000..b6397c013 Binary files /dev/null and b/out/ibclient64-14.1.dll differ diff --git a/out/libcrypto-1_1-32.dll b/out/libcrypto-1_1-32.dll deleted file mode 100644 index 05c35aed4..000000000 Binary files a/out/libcrypto-1_1-32.dll and /dev/null differ diff --git a/out/libcrypto-1_1-x64.dll b/out/libcrypto-1_1-x64.dll deleted file mode 100644 index b067a15dd..000000000 Binary files a/out/libcrypto-1_1-x64.dll and /dev/null differ diff --git a/out/libcrypto-3-x64.dll b/out/libcrypto-3-x64.dll new file mode 100644 index 000000000..bc5570fc6 Binary files /dev/null and b/out/libcrypto-3-x64.dll differ diff --git a/out/libeay32-64.dll b/out/libeay32-64.dll new file mode 100644 index 000000000..8d34547af Binary files /dev/null and b/out/libeay32-64.dll differ diff --git a/out/libiconv-2-32.dll b/out/libiconv-2-32.dll deleted file mode 100644 index 5a0f41c9e..000000000 Binary files a/out/libiconv-2-32.dll and /dev/null differ diff --git a/out/libiconv-2-64.dll b/out/libiconv-2-64.dll index aa33b6421..1e990c66f 100644 Binary files a/out/libiconv-2-64.dll and b/out/libiconv-2-64.dll differ diff --git a/out/libintl-8-32.dll b/out/libintl-8-32.dll deleted file mode 100644 index baf011b2a..000000000 Binary files a/out/libintl-8-32.dll and /dev/null differ diff --git a/out/libintl-8-64.dll b/out/libintl-8-64.dll deleted file mode 100644 index f27a4344b..000000000 Binary files a/out/libintl-8-64.dll and /dev/null differ diff --git a/out/libintl-9-64.dll b/out/libintl-9-64.dll new file mode 100644 index 000000000..5582953e0 Binary files /dev/null and b/out/libintl-9-64.dll differ diff --git a/out/libmariadb-64.dll b/out/libmariadb-64.dll new file mode 100644 index 000000000..2f686799c Binary files /dev/null and b/out/libmariadb-64.dll differ diff --git a/out/libmariadb32.dll b/out/libmariadb32.dll deleted file mode 100644 index e077fab51..000000000 Binary files a/out/libmariadb32.dll and /dev/null differ diff --git a/out/libmariadb64.dll b/out/libmariadb64.dll deleted file mode 100644 index 3261751f0..000000000 Binary files a/out/libmariadb64.dll and /dev/null differ diff --git a/out/libmysql-6.1-64.dll b/out/libmysql-6.1-64.dll index 9adf4c5cc..1f9c9dabd 100644 Binary files a/out/libmysql-6.1-64.dll and b/out/libmysql-6.1-64.dll differ diff --git a/out/libmysql64.dll b/out/libmysql-64.dll similarity index 99% rename from out/libmysql64.dll rename to out/libmysql-64.dll index 9031b9468..f22dd273c 100644 Binary files a/out/libmysql64.dll and b/out/libmysql-64.dll differ diff --git a/out/libmysql-6.1-32.dll b/out/libmysql-8.4.0-64.dll similarity index 54% rename from out/libmysql-6.1-32.dll rename to out/libmysql-8.4.0-64.dll index eea53cb92..d9a2c2971 100644 Binary files a/out/libmysql-6.1-32.dll and b/out/libmysql-8.4.0-64.dll differ diff --git a/out/libmysql-9.4.0-64.dll b/out/libmysql-9.4.0-64.dll new file mode 100644 index 000000000..e65f866be Binary files /dev/null and b/out/libmysql-9.4.0-64.dll differ diff --git a/out/libmysql32.dll b/out/libmysql32.dll deleted file mode 100644 index 60e2a8bab..000000000 Binary files a/out/libmysql32.dll and /dev/null differ diff --git a/out/libpq-10-32.dll b/out/libpq-10-32.dll deleted file mode 100644 index 63b1d6153..000000000 Binary files a/out/libpq-10-32.dll and /dev/null differ diff --git a/out/libpq-10-64.dll b/out/libpq-10-64.dll deleted file mode 100644 index 094b19cf9..000000000 Binary files a/out/libpq-10-64.dll and /dev/null differ diff --git a/out/libpq-12-64.dll b/out/libpq-12-64.dll deleted file mode 100644 index ba98387e2..000000000 Binary files a/out/libpq-12-64.dll and /dev/null differ diff --git a/out/libpq-15-64.dll b/out/libpq-15-64.dll new file mode 100644 index 000000000..416d68e78 Binary files /dev/null and b/out/libpq-15-64.dll differ diff --git a/out/libpq-17-64.dll b/out/libpq-17-64.dll new file mode 100644 index 000000000..c7e450172 Binary files /dev/null and b/out/libpq-17-64.dll differ diff --git a/out/libssl-1_1-32.dll b/out/libssl-1_1-32.dll deleted file mode 100644 index 29b20da2d..000000000 Binary files a/out/libssl-1_1-32.dll and /dev/null differ diff --git a/out/libssl-1_1-x64.dll b/out/libssl-1_1-x64.dll deleted file mode 100644 index 2426ffecd..000000000 Binary files a/out/libssl-1_1-x64.dll and /dev/null differ diff --git a/out/libssl-3-x64.dll b/out/libssl-3-x64.dll new file mode 100644 index 000000000..eabd8d649 Binary files /dev/null and b/out/libssl-3-x64.dll differ diff --git a/out/libwinpthread-1-64.dll b/out/libwinpthread-1-64.dll new file mode 100644 index 000000000..2d5ecc2eb Binary files /dev/null and b/out/libwinpthread-1-64.dll differ diff --git a/out/license.txt b/out/license.txt index f85b1cc25..dd76f4598 100644 --- a/out/license.txt +++ b/out/license.txt @@ -1,4 +1,4 @@ -Copyright (C)2000 - 2020 - Ansgar Becker +Copyright (C)2000 - 2026 - Ansgar Becker HeidiSQL is free. You don't have to pay for it, and you can use it any way you want. It is developed as an Open Source project under the GNU @@ -31,3 +31,6 @@ or data being rendered inaccurate or losses sustained by you or third parties or a failure of the program to operate with any other programs), even if such holder or other party has been advised of the possibility of such damages. + +This product includes software developed by the OpenSSL Project +for use in the OpenSSL Toolkit. (http://www.openssl.org/) \ No newline at end of file diff --git a/out/locale/en/LC_MESSAGES/default.po b/out/locale/en/LC_MESSAGES/default.po index ae9b6c456..4d11cf009 100644 --- a/out/locale/en/LC_MESSAGES/default.po +++ b/out/locale/en/LC_MESSAGES/default.po @@ -7,15 +7,15 @@ msgid "" msgstr "" "Project-Id-Version: HeidiSQL\n" "POT-Creation-Date: 2012-11-05 21:40\n" -"PO-Revision-Date: 2020-08-28 07:56+0200\n" +"PO-Revision-Date: 2025-11-06 19:16+0100\n" "Last-Translator: Ansgar Becker \n" "Language-Team: English (http://www.transifex.com/projects/p/heidisql/language/en/)\n" +"Language: en\n" "MIME-Version: 1.0\n" "Content-Type: text/plain; charset=UTF-8\n" "Content-Transfer-Encoding: 8bit\n" -"Language: en\n" "Plural-Forms: nplurals=2; plural=(n != 1);\n" -"X-Generator: Poedit 2.4.1\n" +"X-Generator: Poedit 3.8\n" #. AboutBox..Caption #: about.dfm:5 @@ -153,21 +153,6 @@ msgstr "OK" msgid "String:" msgstr "String:" -#. frmClickFilter..groupValue..radioExpression..Caption -#: clickfilter.dfm:81 -msgid "Expression:" -msgstr "Expression:" - -#. frmClickFilter..groupConcatType..Caption -#: clickfilter.dfm:91 -msgid "Append to current filter" -msgstr "Append to current filter" - -#. frmClickFilter..groupConcatType....Items.Strings -#: clickfilter.dfm:96 -msgid "Reset" -msgstr "Reset" - #. ColumnSelectionForm..pnlBevel..chkSelectAll..Caption #: column_selection.dfm:55 msgid "Select / Deselect all" @@ -330,22 +315,14 @@ msgstr "Flush tables" msgid "Databases:" msgstr "Databases:" +msgid "Encryption parameters:" +msgstr "Encryption parameters:" + #. connform..PageControlDetails..tabSettings..chkCompressed..Caption #: connections.dfm:298 msgid "Compressed client/server protocol" msgstr "Compressed client/server protocol" -#. connform..PageControlDetails..tabSettings..comboNetType..Text -#. connform..PageControlDetails..tabSettings..comboNetType....Items.Strings -#: connections.dfm:359 connections.dfm:362 -msgid "TCP/IP" -msgstr "TCP/IP" - -#. connform..PageControlDetails..tabSettings..comboNetType....Items.Strings -#: connections.dfm:363 -msgid "Named pipe" -msgstr "Named pipe" - #. connform..PageControlDetails..tabSettings..comboNetType....Items.Strings #. connform..PageControlDetails..tabSSHtunnel..Caption #: connections.dfm:364 connections.dfm:414 @@ -357,6 +334,9 @@ msgstr "SSH tunnel" msgid "Separated by semicolon" msgstr "Separated by semicolon" +msgid "Single database name" +msgstr "Single database name" + #. connform..PageControlDetails..tabSettings..chkLoginPrompt..Caption #: connections.dfm:384 msgid "Prompt for credentials" @@ -382,11 +362,11 @@ msgstr "Use your client time zone in date/time SQL functions, e.g. NOW(), for My msgid "Use own client time zone" msgstr "Use own client time zone" -# Session > Advanced +#. Session > Advanced msgid "Get full table status" msgstr "Get full table status" -# Session > Advanced +#. Session > Advanced msgid "Disable to speed up internal queries on databases with many tables" msgstr "Disable to speed up internal queries on databases with many tables" @@ -402,8 +382,8 @@ msgstr "Username:" #. connform..PageControlDetails..tabSSHtunnel..lblSSHPlinkExe..Caption #: connections.dfm:448 -msgid "plink.exe location:" -msgstr "plink.exe location:" +msgid "SSH executable:" +msgstr "SSH executable:" #. connform..PageControlDetails..tabSSHtunnel..lblSSHhost..Caption #: connections.dfm:455 @@ -415,15 +395,10 @@ msgstr "SSH host + port:" msgid "Private key file:" msgstr "Private key file:" -#. connform..PageControlDetails..tabSSHtunnel..lblDownloadPlink..Caption -#: connections.dfm:473 -msgid "Download plink.exe" -msgstr "Download plink.exe" - #. connform..PageControlDetails..tabSSHtunnel..lblPlinkTimeout..Caption #: connections.dfm:487 -msgid "plink.exe timeout:" -msgstr "plink.exe timeout:" +msgid "SSH timeout:" +msgstr "SSH timeout:" #. connform..PageControlDetails..tabSSHtunnel..editSSHUser..TextHint #: connections.dfm:508 @@ -435,15 +410,10 @@ msgstr "Your secure shell username" msgid "Your secure shell password" msgstr "Your secure shell password" -#. connform..PageControlDetails..tabSSHtunnel..editSSHPlinkExe..TextHint -#: connections.dfm:534 -msgid "Doubleclick to select plink.exe ..." -msgstr "Doubleclick to select plink.exe ..." - #. connform..PageControlDetails..tabSSHtunnel..editSSHPrivateKey..TextHint #: connections.dfm:571 -msgid "PuTTY private key (*.ppk)" -msgstr "PuTTY private key (*.ppk)" +msgid "Private key / identify file" +msgstr "Private key / identify file" #. UserManagerForm..pnlRight..PageControlSettings..tabSSL..Caption #: usermanager.dfm:468 @@ -469,6 +439,21 @@ msgstr "SSL certificate:" msgid "SSL cipher:" msgstr "SSL cipher:" +msgid "Certificate verification" +msgstr "Certificate verification" + +msgid "No verification (insecure)" +msgstr "No verification (insecure)" + +msgid "Verify CA (insecure)" +msgstr "Verify CA (insecure)" + +msgid "Verify CA and host name identity (may fail with self-signed certs and wildcard cn)" +msgstr "Verify CA and host name identity (may fail with self-signed certs and wildcard cn)" + +msgid "You might need to lower the certificate verification in the SSL settings." +msgstr "You might need to lower the certificate verification in the SSL settings." + msgid "Path to key file" msgstr "Path to key file" @@ -496,11 +481,6 @@ msgstr "Statistics" msgid "Last connect:" msgstr "Last connect:" -#. connform..PageControlDetails..tabStatistics..lblCounterLeft..Caption -#: connections.dfm:696 -msgid "Counter:" -msgstr "Counter:" - #. connform..PageControlDetails..tabStatistics..lblCreatedLeft..Caption #: connections.dfm:703 msgid "Created:" @@ -751,7 +731,7 @@ msgstr "CREATE code" msgid "ALTER code" msgstr "ALTER code" -# Table editor +#. Table editor msgid "Partitions" msgstr "Partitions" @@ -760,6 +740,10 @@ msgstr "Partitions" msgid "Export grid rows" msgstr "Export grid rows" +#. Grid context menu +msgid "Copy as" +msgstr "Copy as" + #. frmExportGrid..grpFormat..Caption #: exportgrid.dfm:54 msgid "Output format" @@ -1115,6 +1099,9 @@ msgstr "Input file contains local formatted numbers, e.g. 1.234,56 in Germany" msgid "Truncate destination table before import" msgstr "Truncate destination table before import" +msgid "Keep dialog open after import" +msgstr "Keep dialog open after import" + #. loaddataform..grpDuplicates..Caption #: loaddata.dfm:272 msgid "Handling of duplicate rows" @@ -1174,7 +1161,7 @@ msgstr "Table:" msgid "Columns:" msgstr "Columns:" -# CSV import +#. CSV import msgid "Cannot truncate table" msgstr "Cannot truncate table" @@ -1234,7 +1221,7 @@ msgstr "Default" msgid "Data" msgstr "Data" -#. MainForm..panelTop..pnlLeft..comboDBFilter....Hint +#. Short and longer hint, separated by pipe #: main.dfm:384 msgid "Database filter|A list of databases, separated by semicolon. Can contain regular expressions, e.g. \"mydb;test.*;project\\d+\"." msgstr "Database filter|A list of databases, separated by semicolon. Can contain regular expressions, e.g. \"mydb;test.*;project\\d+\"." @@ -1248,7 +1235,7 @@ msgstr "Database filter" msgid "Table filter" msgstr "Table filter" -#. Table filter box hint +#. Table filter box hint, short and longer hint, separated by pipe msgid "Table filter|Can contain regular expressions, e.g. \"phpbb_\\d\"" msgstr "Table filter|Can contain regular expressions, e.g. \"phpbb_\\d\"" @@ -1567,11 +1554,6 @@ msgstr "Query" msgid "Attributes" msgstr "Attributes" -#. MainForm..MainMenu1..File1..Caption -#: main.dfm:1679 -msgid "&File" -msgstr "&File" - #. MainForm..MainMenu1..File1..Hint #: main.dfm:1680 msgid "File related commands" @@ -1582,11 +1564,6 @@ msgstr "File related commands" msgid "Connect to" msgstr "Connect to" -#. MainForm..MainMenu1..Edit1..Caption -#: main.dfm:1718 -msgid "&Edit" -msgstr "&Edit" - #. MainForm..MainMenu1..Edit1..Hint #: main.dfm:1719 msgid "Edit commands" @@ -1598,16 +1575,6 @@ msgstr "Edit commands" msgid "Search" msgstr "Search" -#. MainForm..MainMenu1..Extra1..Caption -#: main.dfm:1762 -msgid "&Tools" -msgstr "&Tools" - -#. MainForm..MainMenu1..Help1..Caption -#: main.dfm:1837 -msgid "&Help" -msgstr "&Help" - #. MainForm..MainMenu1..Help1..Hint #: main.dfm:1838 msgid "Help topics" @@ -1633,8 +1600,7 @@ msgstr "New window..." msgid "E&xit" msgstr "E&xit" -#. MainForm..ActionList1..actExitApplication..Hint -#: main.dfm:1887 +#. Short and longer hint, separated by pipe msgid "Exit|Exit application" msgstr "Exit|Exit application" @@ -1667,8 +1633,7 @@ msgstr "Various" msgid "&Copy" msgstr "&Copy" -#. MainForm..ActionList1..actCopy..Hint -#: main.dfm:1894 +#. Short and longer hint, separated by pipe msgid "Copy|Copy to Clipboard" msgstr "Copy|Copy to Clipboard" @@ -1677,8 +1642,7 @@ msgstr "Copy|Copy to Clipboard" msgid "&Paste" msgstr "&Paste" -#. MainForm..ActionList1..actPaste..Hint -#: main.dfm:1902 +#. Short and longer hint, separated by pipe msgid "Paste|Paste from Clipboard" msgstr "Paste|Paste from Clipboard" @@ -1720,8 +1684,7 @@ msgstr "Manage user authentication and privileges" msgid "Cu&t" msgstr "Cu&t" -#. MainForm..ActionList1..actCut..Hint -#: main.dfm:1917 +#. Short and longer hint, separated by pipe msgid "Cut|Cuts the selection and puts it on the Clipboard" msgstr "Cut|Cuts the selection and puts it on the Clipboard" @@ -1730,6 +1693,10 @@ msgstr "Cut|Cuts the selection and puts it on the Clipboard" msgid "&Undo" msgstr "&Undo" +#. Short and longer hint, separated by pipe +msgid "Undo|Revert last modification" +msgstr "Undo|Revert last modification" + #. MainForm..ActionList1..actAboutBox..Caption #: main.dfm:1931 msgid "About..." @@ -1854,8 +1821,7 @@ msgstr "Execute selected SQL...|Execute selected SQL-query/queries..." msgid "Run current query" msgstr "Run current query" -#. MainForm..ActionList1..actExecuteCurrentQuery..Hint -#: main.dfm:1997 +#. Short and longer hint, separated by pipe msgid "Run current query|Run currently focused SQL query" msgstr "Run current query|Run currently focused SQL query" @@ -2031,7 +1997,7 @@ msgstr "SQL help browser" msgid "Refresh" msgstr "Refresh" -# Full table status refresh +#. Full table status refresh msgid "Full status refresh" msgstr "Full status refresh" @@ -2080,16 +2046,6 @@ msgstr "Support forum" msgid "Changelog" msgstr "Changelog" -#. MainForm..ActionList1..actReadme..Caption -#: main.dfm:2249 -msgid "Readme" -msgstr "Readme" - -#. MainForm..ActionList1..actReadme..Hint -#: main.dfm:2250 -msgid "Open readme file" -msgstr "Open readme file" - #. MainForm..ActionList1..actSaveSQLAs..Hint #: main.dfm:2258 msgid "Save SQL to a textfile" @@ -2165,6 +2121,12 @@ msgstr "Set delimiter used in SQL execution" msgid "Apply filter" msgstr "Apply filter" +msgid "Always generate filter" +msgstr "Always generate filter" + +msgid "Generate filter based on this text, even if the current filter is not empty" +msgstr "Generate filter based on this text, even if the current filter is not empty" + #. MainForm..ActionList1..actRemoveFilter..Caption #: main.dfm:2362 msgid "Remove filter" @@ -2175,8 +2137,7 @@ msgstr "Remove filter" msgid "&Previous tab" msgstr "&Previous tab" -#. MainForm..ActionList1..actPreviousTab..Hint -#: main.dfm:2377 +#. Short and longer hint, separated by pipe msgid "Previous tab|Go back to the previous tab" msgstr "Previous tab|Go back to the previous tab" @@ -2185,8 +2146,7 @@ msgstr "Previous tab|Go back to the previous tab" msgid "&Next tab" msgstr "&Next tab" -#. MainForm..ActionList1..actNextTab..Hint -#: main.dfm:2386 +#. Short and longer hint, separated by pipe msgid "Next tab|Go to the next tab" msgstr "Next tab|Go to the next tab" @@ -2203,20 +2163,21 @@ msgstr "Next result tab" msgid "Select all" msgstr "Select all" -#. MainForm..ActionList1..actSelectAll..Hint -#: main.dfm:2394 +#. Short and longer hint, separated by pipe msgid "Select all|Select all items or text" msgstr "Select all|Select all items or text" -#. MainForm..ActionList1..actCreateRoutine..Caption -#: main.dfm:2401 -msgid "Stored routine" -msgstr "Stored routine" +msgid "Stored procedure" +msgstr "Stored procedure" + +msgid "Create stored procedure" +msgstr "Create stored procedure" + +msgid "Stored function" +msgstr "Stored function" -#. MainForm..ActionList1..actCreateRoutine..Hint -#: main.dfm:2402 -msgid "Create stored routine|Create stored procedure or function" -msgstr "Create stored routine|Create stored procedure or function" +msgid "Create stored function" +msgstr "Create stored function" #. MainForm..ActionList1..actNewQueryTab..Caption #: main.dfm:2408 @@ -2460,11 +2421,6 @@ msgstr "Analyze selected process SQL" msgid "EXPLAIN analyzer on MariaDB.org" msgstr "EXPLAIN analyzer on MariaDB.org" -#. MainForm..popupHost..menuExplainAnalyzer..Hint -#: main.dfm:8701 -msgid "Pass EXPLAIN output to MariaDB's analyzer webpage" -msgstr "Pass EXPLAIN output to MariaDB's analyzer webpage" - #: tabletools.pas:1061 main.pas:2855 connections.pas:1047 msgid "SQL files" msgstr "SQL files" @@ -2487,7 +2443,7 @@ msgstr "Compressing" msgid "Insert value" msgstr "Insert value" -# Data grid context menu +#. Data grid context menu msgid "This is a UNIX timestamp column" msgstr "This is a UNIX timestamp column" @@ -2798,6 +2754,9 @@ msgstr "Enable query history" msgid "days to keep queries before removing them" msgstr "days to keep queries before removing them" +msgid "Add timestamp to all log messages" +msgstr "Add timestamp to all log messages" + #. optionsform..pagecontrolMain..tabSQL..lblFont..Caption #: options.dfm:357 msgid "Editor font:" @@ -2813,10 +2772,11 @@ msgstr "Tab width:" msgid "Maximum result sets:" msgstr "Maximum result sets:" -#. optionsform..pagecontrolMain..tabSQL..chkCompletionProposal..Caption -#: options.dfm:418 -msgid "Enable autocompletion" -msgstr "Enable autocompletion" +msgid "Auto completion proposal:" +msgstr "Auto completion proposal:" + +msgid "Enable" +msgstr "Enable" msgid "Auto uppercase reserved words and functions" msgstr "Auto uppercase reserved words and functions" @@ -2831,14 +2791,30 @@ msgstr "Tabs to spaces" msgid "Prompt to save modified files on tab close" msgstr "Prompt to save modified files on tab close" +msgid "Close tab on doubleclick" +msgstr "Close tab on doubleclick" + +msgid "Close tab on middleclick" +msgstr "Close tab on middleclick" + +msgid "Grayscale inactive tab icons" +msgstr "Grayscale inactive tab icons" + +msgid "Color icons on all tabs" +msgstr "Color icons on all tabs" + +msgid "Grayscale icons on inactive query tabs only" +msgstr "Grayscale icons on inactive query tabs only" + +msgid "Grayscale icons on every inactive tab" +msgstr "Grayscale icons on every inactive tab" + +msgid "Tabs in multiple lines" +msgstr "Tabs in multiple lines" + msgid "Show query warnings dialog" msgstr "Show query warnings dialog" -#. optionsform..pagecontrolMain..tabHighlighter..Caption -#: options.dfm:483 -msgid "Highlighter" -msgstr "Highlighter" - #. optionsform..pagecontrolMain..tabHighlighter..lblSQLColElement..Caption #: options.dfm:497 msgid "Element:" @@ -2864,9 +2840,6 @@ msgstr "Bold" msgid "Italic" msgstr "Italic" -msgid "Size:" -msgstr "Size:" - msgid "Colors preset:" msgstr "Colors preset:" @@ -2915,6 +2888,12 @@ msgstr "Data editors" msgid "Alternating row background:" msgstr "Alternating row background:" +msgid "Max decimal zeros for floats:" +msgstr "Max decimal zeros for floats:" + +msgid "Set to -1 to keep all zeros" +msgstr "Set to -1 to keep all zeros" + #. Preferences > Grid formatting msgid "Local number format" msgstr "Local number format" @@ -2944,6 +2923,9 @@ msgstr "Enable SET checkbox editor" msgid "Prefill empty date/time fields with current date/time" msgstr "Prefill empty date/time fields with current date/time" +msgid "Click on column headers toggles sorting" +msgstr "Click on column headers toggles sorting" + #. optionsform..pagecontrolMain..tabData..chkRememberFilters..Caption #: options.dfm:838 msgid "Remember filters, sorting and column selection across sessions" @@ -2953,6 +2935,10 @@ msgstr "Remember filters, sorting and column selection across sessions" msgid "Show values in foreign key columns" msgstr "Show values in foreign key columns" +#. Preferences checkbox +msgid "Incremental search through typing" +msgstr "Incremental search through typing" + msgid "Connected table has too many rows. Foreign key drop-down is limited to %d items." msgstr "Connected table has too many rows. Foreign key drop-down is limited to %d items." @@ -3306,6 +3292,15 @@ msgstr "Expression" msgid "Virtuality" msgstr "Virtuality" +msgid "Spatial reference system" +msgstr "Spatial reference system" + +msgid "Invisible" +msgstr "Invisible" + +msgid "Hide in certain contexts" +msgstr "Hide in certain contexts" + #. frmTableEditor..PageControlMain..tabBasic..Caption #: table_editor.dfm:183 msgid "Basic" @@ -3450,14 +3445,6 @@ msgstr "Remove column" msgid "Copy selected columns" msgstr "Copy selected columns" -#. grid export -msgid "Copy selected rows" -msgstr "Copy selected rows" - -#. grid export -msgid "Copy selected rows in custom format" -msgstr "Copy selected rows in custom format" - #. frmTableEditor..popupColumns..menuPasteColumns..Caption #: table_editor.dfm:803 msgid "Paste columns" @@ -3682,6 +3669,9 @@ msgstr "Nightly build" msgid "Download nightly build" msgstr "Download nightly build" +msgid "No build updates for 32 bit version" +msgstr "No build updates for 32 bit version" + #. frmUpdateCheck..groupRelease..Caption #: updatecheck.dfm:90 msgid "Official release" @@ -3961,14 +3951,6 @@ msgstr "Settings for \"%s\" were changed." msgid "Socket name:" msgstr "Socket name:" -#: connections.pas:1049 -msgid "Executables" -msgstr "Executables" - -#: connections.pas:1051 -msgid "PuTTY private key" -msgstr "PuTTY private key" - #: connections.pas:1053 msgid "Privacy Enhanced Mail certificates" msgstr "Privacy Enhanced Mail certificates" @@ -4034,17 +4016,12 @@ msgid "Error: Session \"%s\" not found in registry." msgstr "Error: Session \"%s\" not found in registry." #: dbconnection.pas:680 -msgid "Broken \"NetType\" value (%d) found in settings for session \"%s\"." -msgstr "Broken \"NetType\" value (%d) found in settings for session \"%s\"." +msgid "Unsupported \"NetType\" value (%d) found in settings for session \"%s\"." +msgstr "Unsupported \"NetType\" value (%d) found in settings for session \"%s\"." #: dbconnection.pas:681 -msgid "Please report that on %s" -msgstr "Please report that on %s" - -#. Comes into SQL log when assigning dll procedures from libmysql.dll -#: dbconnection.pas:1038 -msgid "Assign procedure \"%s\"" -msgstr "Assign procedure \"%s\"" +msgid "Loaded as MySQL/MariaDB session." +msgstr "Loaded as MySQL/MariaDB session." #: dbconnection.pas:1047 msgid "Your %s is incompatible to %s, or your system is missing a dependent library." @@ -4054,9 +4031,12 @@ msgstr "Your %s is incompatible to %s, or your system is missing a dependent lib msgid "SSL parameters successfully set." msgstr "SSL parameters successfully set." +msgid "SSL parameters not fully set. Result: %d" +msgstr "SSL parameters not fully set. Result: %d" + #: dbconnection.pas:1151 -msgid "Attempt to create plink.exe process, waiting %ds for response ..." -msgstr "Attempt to create plink.exe process, waiting %ds for response ..." +msgid "Attempt to create SSH process, waiting %ds for response ..." +msgstr "Attempt to create SSH process, waiting %ds for response ..." #. Plink connection msgid "Error creating I/O pipes" @@ -4067,20 +4047,20 @@ msgid "Error reading I/O pipes" msgstr "Error reading I/O pipes" #. Plink connection -msgid "PLink cancelled" -msgstr "PLink cancelled" +msgid "SSH command cancelled" +msgstr "SSH command cancelled" #: dbconnection.pas:1162 -msgid "PLink exited unexpected. Command line was: %s" -msgstr "PLink exited unexpected. Command line was: %s" +msgid "SSH exited unexpected. Command line was: %s" +msgstr "SSH exited unexpected. Command line was: %s" #: dbconnection.pas:1165 -msgid "Could not execute PLink: %s" -msgstr "Could not execute PLink: %s" +msgid "Could not execute SSH command: %s" +msgstr "Could not execute SSH command: %s" #. Plink connection -msgid "Could not execute PLink: Port %d already in use." -msgstr "Could not execute PLink: Port %d already in use." +msgid "Could not execute SSH command: Port %d already in use." +msgstr "Could not execute SSH command: Port %d already in use." #. Plink connection msgid "Port #%d in use. Checking if #%d is available..." @@ -4115,9 +4095,6 @@ msgstr "OLE DB property \"%s\": %s" msgid "Loading library file %s ..." msgstr "Loading library file %s ..." -msgid "Trying to load library with full path: %s" -msgstr "Trying to load library with full path: %s" - #. DLL loading fails on one procedure msgid "Library error in %s: Could not find procedure address for \"%s\"" msgstr "Library error in %s: Could not find procedure address for \"%s\"" @@ -4125,10 +4102,6 @@ msgstr "Library error in %s: Could not find procedure address for \"%s\"" msgid "Library %s could not be loaded. Please select a different one." msgstr "Library %s could not be loaded. Please select a different one." -#. DLL loading failed entirely -msgid "Library %s seems unusable. Please select a different one." -msgstr "Library %s seems unusable. Please select a different one." - #: dbconnection.pas:1392 msgid "Please launch %s from the directory where you have installed it. Or just reinstall %s." msgstr "Please launch %s from the directory where you have installed it. Or just reinstall %s." @@ -4144,9 +4117,12 @@ msgstr "Login to %s:" msgid "Connecting to %s via %s, username %s, using password: %s ..." msgstr "Connecting to %s via %s, username %s, using password: %s ..." +msgid "Connecting to %s via %s, cipher %s, using encryption key: %s ..." +msgstr "Connecting to %s via %s, cipher %s, using encryption key: %s ..." + #: dbconnection.pas:1582 -msgid "Closing plink.exe process #%d ..." -msgstr "Closing plink.exe process #%d ..." +msgid "Closing SSH process #%d ..." +msgstr "Closing SSH process #%d ..." #: dbconnection.pas:1600 dbconnection.pas:1706 msgid "Waiting for running query to finish ..." @@ -4352,12 +4328,8 @@ msgid "Save new %s?" msgstr "Save new %s?" #: helpers.pas:2821 -msgid "Could not open URL: %s" -msgstr "Could not open URL: %s" - -#: helpers.pas:2829 -msgid "Server did not send required \"Content-Length\" header: %s" -msgstr "Server did not send required \"Content-Length\" header: %s" +msgid "Could not open %s (%s)" +msgstr "Could not open %s (%s)" #: helpers.pas:2837 msgid "Got HTTP status %d from %s" @@ -4383,10 +4355,6 @@ msgstr "Attempt to write session setting without session path" msgid "%u files, %s, %u files selected." msgstr "%u files, %s, %u files selected." -#: loaddata.pas:176 -msgid "Let server/database decide" -msgstr "Let server/database decide" - #: loaddata.pas:315 msgid "Your file was imported but the server returned %s warnings and/or notes. See the log panel for details." msgstr "Your file was imported but the server returned %s warnings and/or notes. See the log panel for details." @@ -4483,8 +4451,8 @@ msgid "Checking queries for unsafe UPDATEs/DELETEs ..." msgstr "Checking queries for unsafe UPDATEs/DELETEs ..." #. Query execution -msgid "Your query contains UPDATEs and/or DELETEs without a WHERE clause. Please confirm that you know what you''re doing." -msgstr "Your query contains UPDATEs and/or DELETEs without a WHERE clause. Please confirm that you know what you''re doing." +msgid "Your query contains UPDATEs and/or DELETEs without a WHERE clause. Please confirm that you know what you're doing." +msgstr "Your query contains UPDATEs and/or DELETEs without a WHERE clause. Please confirm that you know what you're doing." #: main.pas:2166 msgid "Query profiling requires %s or later, and the server must not be configured with %s." @@ -4556,10 +4524,6 @@ msgstr "First %s warnings:" msgid "Show all warnings in a new query tab?" msgstr "Show all warnings in a new query tab?" -#: main.pas:2364 -msgid "The server variable %s is currently set to %d, so you won't see all warnings." -msgstr "The server variable %s is currently set to %d, so you won't see all warnings." - #: main.pas:2379 msgid "Updating query history ..." msgstr "Updating query history ..." @@ -4724,10 +4688,16 @@ msgstr "Empty %d table(s) and/or view(s)?" msgid "No stored procedure selected." msgstr "No stored procedure selected." +msgid "No table selected." +msgstr "No table selected." + #: main.pas:3285 msgid "Please select one or more stored function(s) or routine(s)." msgstr "Please select one or more stored function(s) or routine(s)." +msgid "Please select one or more table(s) or view(s)." +msgstr "Please select one or more table(s) or view(s)." + #: main.pas:3304 msgid "Parameter" msgstr "Parameter" @@ -4836,6 +4806,10 @@ msgstr "rows total" msgid "approximately" msgstr "approximately" +#. Row count statistics in data tab header +msgid "exact" +msgstr "exact" + #: main.pas:4439 msgid "limited to" msgstr "limited to" @@ -4865,8 +4839,11 @@ msgid "unknown" msgstr "unknown" #. Give the user some hint what he can do with his SSL related connection error -msgid "Please select a different library in your session settings. (Current: \"%s\")" -msgstr "Please select a different library in your session settings. (Current: \"%s\")" +msgid "You could try the default library %s in your session settings. (Current: %s)" +msgstr "You could try the default library %s in your session settings. (Current: %s)" + +msgid "This is a known issue with older libraries. Try a newer %s in the session settings." +msgstr "This is a known issue with older libraries. Try a newer %s in the session settings." #: main.pas:5261 msgid "Specify filter-value..." @@ -4982,6 +4959,15 @@ msgstr "Please select a non-readonly SQL editor first." msgid "No SQL editor focused. ActiveControl is %s" msgstr "No SQL editor focused. ActiveControl is %s" +msgid "No listing or tree focused. ActiveControl is %s" +msgstr "No listing or tree focused. ActiveControl is %s" + +msgid "Copy all lines from listing or tree in CSV format" +msgstr "Copy all lines from listing or tree in CSV format" + +msgid "%s: %s lines copied to clipboard" +msgstr "%s: %s lines copied to clipboard" + #: main.pas:9768 msgid "The current editor is empty." msgstr "The current editor is empty." @@ -5204,16 +5190,6 @@ msgstr "Same as source" msgid "Create missing %s" msgstr "Create missing %s" -#. TODO -#: tabletools.pas:155 -msgid "Skipped" -msgstr "Skipped" - -#. TODO -#: tabletools.pas:156 -msgid "One big file" -msgstr "One big file" - #. TODO #: tabletools.pas:158 msgid "Directory - one file per object in database subdirectories" @@ -5224,26 +5200,11 @@ msgstr "Directory - one file per object in database subdirectories" msgid "No data" msgstr "No data" -#. TODO -#: tabletools.pas:162 -msgid "truncate existing data" -msgstr "truncate existing data" - -#. TODO -#: tabletools.pas:164 -msgid "do not update existing" -msgstr "do not update existing" - -#. TODO -#: tabletools.pas:165 -msgid "existing data" -msgstr "existing data" - -# Export SQL data +#. Export SQL data msgid "Max INSERT size:" msgstr "Max INSERT size:" -# Export SQL data +#. Export SQL data msgid "KB (0 = Single INSERTs)" msgstr "KB (0 = Single INSERTs)" @@ -5319,9 +5280,12 @@ msgstr "Selected operations cannot be applied to a %s" msgid "Unhandled tree level" msgstr "Unhandled tree level" +msgid "%s finished" +msgstr "%s finished" + #: table_editor.pas:380 -msgid "%s Index \"%s\" does not contain any column. You can add columns using drag''n drop from the columns list." -msgstr "%s Index \"%s\" does not contain any column. You can add columns using drag''n drop from the columns list." +msgid "%s Index \"%s\" does not contain any column. You can add columns using drag'n drop from the columns list." +msgstr "%s Index \"%s\" does not contain any column. You can add columns using drag'n drop from the columns list." #: table_editor.pas:476 msgid "Composing ALTER statement ..." @@ -5343,10 +5307,6 @@ msgstr "Add duplicated column to index?" msgid "Index \"%s\" already contains the column \"%s\". It is possible to add a column twice into a index, but total nonsense in practice." msgstr "Index \"%s\" already contains the column \"%s\". It is possible to add a column twice into a index, but total nonsense in practice." -#: table_editor.pas:1815 -msgid "The selected table engine (%s) does not support foreign keys." -msgstr "The selected table engine (%s) does not support foreign keys." - #: table_editor.pas:1946 msgid "Key already exists. Really create another identical one?" msgstr "Key already exists. Really create another identical one?" @@ -5367,10 +5327,6 @@ msgstr "Reference table \"%s\" seems to be missing, broken or non-accessible." msgid "Trigger definition not found!" msgstr "Trigger definition not found!" -#: updatecheck.pas:76 -msgid "Initializing" -msgstr "Initializing" - #: updatecheck.pas:77 msgid "Check for %s updates" msgstr "Check for %s updates" @@ -5379,10 +5335,6 @@ msgstr "Check for %s updates" msgid "Downloading check file" msgstr "Downloading check file" -#: updatecheck.pas:95 -msgid "Reading check file" -msgstr "Reading check file" - #: updatecheck.pas:100 msgid "Error: Cannot determine current revision. Using a developer version?" msgstr "Error: Cannot determine current revision. Using a developer version?" @@ -5395,10 +5347,6 @@ msgstr "Your %s is up-to-date (no update available)." msgid "Updates available." msgstr "Updates available." -#. Update button on top right of main window -msgid "Update available" -msgstr "Update available" - #: updatecheck.pas:147 msgid "Version %s (yours: %s)" msgstr "Version %s (yours: %s)" @@ -5408,8 +5356,8 @@ msgid "Released: %s" msgstr "Released: %s" #: updatecheck.pas:152 -msgid "Download version %s" -msgstr "Download version %s" +msgid "Download version %s (%s)" +msgstr "Download version %s (%s)" #: updatecheck.pas:168 msgid "Revision %d (yours: %d)" @@ -5436,8 +5384,8 @@ msgid "Update in progress" msgstr "Update in progress" #: updatecheck.pas:264 -msgid "Downloading: %s / %s" -msgstr "Downloading: %s / %s" +msgid "Downloading: %s" +msgstr "Downloading: %s" #: usermanager.pas:435 msgid "Save modified user?" @@ -5491,10 +5439,6 @@ msgstr "Unhandled privilege object: %s" msgid "Delete user %s@%s?" msgstr "Delete user %s@%s?" -#. dbconnection.pas -msgid "experimental" -msgstr "experimental" - #. dbconnection.pas msgid "Yes" msgstr "Yes" @@ -5507,7 +5451,7 @@ msgstr "No" msgid "Connected" msgstr "Connected" -# Main form status bar +#. Main form status bar msgid "Disconnected" msgstr "Disconnected" @@ -5684,8 +5628,8 @@ msgid "Unhandled tree node index" msgstr "Unhandled tree node index" #. const.inc -msgid "Selected columns don''t contain a sufficient set of key columns to allow editing. Please select primary or unique key columns, or just all columns." -msgstr "Selected columns don''t contain a sufficient set of key columns to allow editing. Please select primary or unique key columns, or just all columns." +msgid "Selected columns don't contain a sufficient set of key columns to allow editing. Please select primary or unique key columns, or just all columns." +msgstr "Selected columns don't contain a sufficient set of key columns to allow editing. Please select primary or unique key columns, or just all columns." #. const.inc msgid "Idle." @@ -5867,13 +5811,17 @@ msgstr "The selected foreign column do not match the source columns data type an msgid "Foreign key mismatch" msgstr "Foreign key mismatch" -#. Clear data tab filter +#. Clear data tab filter and sort order msgid "Data filter for %s deleted" msgstr "Data filter for %s deleted" -#. Clear data tab filter -msgid "Clear data tab filter" -msgstr "Clear data tab filter" +#. Clear data tab filter and sort order +msgid "Sort order for %s deleted" +msgstr "Sort order for %s deleted" + +#. Clear data tab filter and sort order +msgid "Clear data tab filter and sort order" +msgstr "Clear data tab filter and sort order" msgid "Error when updating query history: %s" msgstr "Error when updating query history: %s" @@ -5913,19 +5861,15 @@ msgstr "%s%% of your file has been processed, but there were %s errors when exec msgid "Notice: You can disable the \"%s\" option to ignore such errors" msgstr "Notice: You can disable the \"%s\" option to ignore such errors" -#. ReadTextFileChunk -msgid "End of file block was cut within some multibyte character, at position %s. Increasing chunk size and retry reading..." -msgstr "End of file block was cut within some multibyte character, at position %s. Increasing chunk size and retry reading..." - #. InitConnection, JumpList msgid "Recent sessions" msgstr "Recent sessions" -# GetParentFormOrFrame +#. GetParentFormOrFrame msgid "Could not determine parent form of this %s" msgstr "Could not determine parent form of this %s" -# Button on update check dialog, appearing right after application start +#. Button on update check dialog, appearing right after application start msgid "Skip" msgstr "Skip" @@ -5955,15 +5899,18 @@ msgstr "GUID" msgid "GUID without braces" msgstr "GUID without braces" +msgid "GUID lowercase" +msgstr "GUID lowercase" + +msgid "GUID lowercase without braces" +msgstr "GUID lowercase without braces" + msgid "Query timeout:" msgstr "Query timeout:" msgid "Ping every X seconds:" msgstr "Ping every X seconds:" -msgid "Connection attempts:" -msgstr "Connection attempts:" - msgid "Pop up SQL text over result tabs" msgstr "Pop up SQL text over result tabs" @@ -6318,8 +6265,8 @@ msgstr "Add comments" msgid "Remove AUTO_INCREMENT clauses" msgstr "Remove AUTO_INCREMENT clauses" -msgid "%s%s missing." -msgstr "%s%s missing." +msgid "Remove DEFINER clauses" +msgstr "Remove DEFINER clauses" msgid "Filename or path contains illegal characters: \"%s\"" msgstr "Filename or path contains illegal characters: \"%s\"" @@ -6411,34 +6358,16 @@ msgstr "Go to tab 5" msgid "Reached maximum number of result tabs (%d). To display more results, increase setting in Preferences > SQL" msgstr "Reached maximum number of result tabs (%d). To display more results, increase setting in Preferences > SQL" -msgid "Does not work on Windows 10 S" -msgstr "Does not work on Windows 10 S" - -msgid "The network type defined for this session is not compatible to your Windows 10 S" -msgstr "The network type defined for this session is not compatible to your Windows 10 S" - msgid "Error when checking for updates: %s" msgstr "Error when checking for updates: %s" msgid "Please update %s through the Microsoft Store." msgstr "Please update %s through the Microsoft Store." -# Text in parentheses for detected linebreak style in popup text editor +#. Text in parentheses for detected linebreak style in popup text editor msgid "detected" msgstr "detected" -msgid "Migrating snippet files to new folder: %s" -msgstr "Migrating snippet files to new folder: %s" - -msgid "Successfully moved \"%s\" to \"%s\"" -msgstr "Successfully moved \"%s\" to \"%s\"" - -msgid "Error: Could not move \"%s\" to \"%s\" (Error: %s)" -msgstr "Error: Could not move \"%s\" to \"%s\" (Error: %s)" - -msgid "Scaling font size from %d to %d." -msgstr "Scaling font size from %d to %d." - msgid "Current custom settings" msgstr "Current custom settings" @@ -6512,8 +6441,8 @@ msgid "Your code is saved anyway, as auto-restoring is activated." msgstr "Your code is saved anyway, as auto-restoring is activated." #. Tab caption in preferences -msgid "Files" -msgstr "Files" +msgid "Files and tabs" +msgstr "Files and tabs" msgid "Reopen previously used SQL files and unsaved content in tabs *" msgstr "Reopen previously used SQL files and unsaved content in tabs *" @@ -6569,8 +6498,8 @@ msgstr "Note: The database file will not get deleted." msgid "Show SQL completion proposal" msgstr "Show SQL completion proposal" -msgid "Find matches in middle of entered text" -msgstr "Find matches in middle of entered text" +msgid "Find matches in the middle" +msgstr "Find matches in the middle" msgid "Wait longer for sorting?" msgstr "Wait longer for sorting?" @@ -6589,3 +6518,252 @@ msgstr "Size &All Columns to Fit" msgid "This view probably contains an error in its code." msgstr "This view probably contains an error in its code." + +msgid "Rename query tab" +msgstr "Rename query tab" + +msgid "Enter new name" +msgstr "Enter new name" + +msgid "Analyzing %s rows..." +msgstr "Analyzing %s rows..." + +msgid "New table" +msgstr "New table" + +msgid "Detect CSV layout" +msgstr "Detect CSV layout" + +msgid "Scan file..." +msgstr "Scan file..." + +msgid "Ok, create table" +msgstr "Ok, create table" + +msgid "Current query is empty" +msgstr "Current query is empty" + +msgid "Please move the cursor inside the query you want to use." +msgstr "Please move the cursor inside the query you want to use." + +#. Keyboard shortcut settings +msgid "Keyboard shortcut [%s] is already assigned to \"%s\"." +msgstr "Keyboard shortcut [%s] is already assigned to \"%s\"." + +#. Keyboard shortcut settings +msgid "Remove it there and assign to \"%s\" instead?" +msgstr "Remove it there and assign to \"%s\" instead?" + +#. Keyboard shortcut settings +msgid "Press ignore to keep both and ignore all conflicts." +msgstr "Press ignore to keep both and ignore all conflicts." + +msgid "Really auto-detect file encoding?" +msgstr "Really auto-detect file encoding?" + +msgid "Auto detecting the encoding of a file is highly discouraged. You may experience data loss if the detection fails." +msgstr "Auto detecting the encoding of a file is highly discouraged. You may experience data loss if the detection fails." + +msgid "To avoid this message select the correct encoding before pressing Open." +msgstr "To avoid this message select the correct encoding before pressing Open." + +msgid "keyword" +msgstr "keyword" + +msgid "Check constraints" +msgstr "Check constraints" + +msgid "Check clause" +msgstr "Check clause" + +msgid "Log queries to file:" +msgstr "Log queries to file:" + +msgid "Logging disabled" +msgstr "Logging disabled" + +msgid "Editor commands" +msgstr "Editor commands" + +msgid "Lowercase hexadecimal" +msgstr "Lowercase hexadecimal" + +msgid "Update instructions" +msgstr "Update instructions" + +msgid "Download the portable package and extract it in %s" +msgstr "Download the portable package and extract it in %s" + +msgid "No area selected" +msgstr "No area selected" + +msgid "Close all query tabs" +msgstr "Close all query tabs" + +msgid "Close query tabs to the right" +msgstr "Close query tabs to the right" + +msgid "Copy mysqldump command" +msgstr "Copy mysqldump command" + +msgid "Scaling controls to screen DPI: %d%%" +msgstr "Scaling controls to screen DPI: %d%%" + +msgid "Caution: Style \"%s\" selected and non-default DPI factor - be aware that some styles appear broken with high DPI settings!" +msgstr "Caution: Style \"%s\" selected and non-default DPI factor - be aware that some styles appear broken with high DPI settings!" + +msgid "Toggle visibility of all columns" +msgstr "Toggle visibility of all columns" + +msgid "Connection failed" +msgstr "Connection failed" + +msgid "Disable foreign key checks" +msgstr "Disable foreign key checks" + +msgid "Altering tables restricted. For details see %s" +msgstr "Altering tables restricted. For details see %s" + +msgid "Foreign key not found for column \"%s\"" +msgstr "Foreign key not found for column \"%s\"" + +msgid "Empty recent filters" +msgstr "Empty recent filters" + +msgid "Customize highlighter" +msgstr "Customize highlighter" + +msgid "Color picker" +msgstr "Color picker" + +msgid "Style:" +msgstr "Style:" + +msgid "Error in code formatting: %s" +msgstr "Error in code formatting: %s" + +msgid "Auto-disabling wordwrap for large text" +msgstr "Auto-disabling wordwrap for large text" + +msgid "%d tab(s) took longer than expected to restore. Closing and reopening these should fix that: %s" +msgstr "%d tab(s) took longer than expected to restore. Closing and reopening these should fix that: %s" + +msgid "Library:" +msgstr "Library:" + +msgid "Move line up" +msgstr "Move line up" + +msgid "Move line down" +msgstr "Move line down" + +msgid "New query tab in background" +msgstr "New query tab in background" + +msgid "Follow foreign key" +msgstr "Follow foreign key" + +msgid "Follow foreign key to the linked table" +msgstr "Follow foreign key to the linked table" + +msgid "Copy with tabs to spaces" +msgstr "Copy with tabs to spaces" + +msgid "Connection properties" +msgstr "Connection properties" + +msgid "Recent prompts:" +msgstr "Recent prompts:" + +msgid "Generate SQL" +msgstr "Generate SQL" + +msgid "Execute in new tab" +msgstr "Execute in new tab" + +msgid "Select reformatter" +msgstr "Select reformatter" + +msgid "Internal" +msgstr "Internal" + +msgid "Online on %s" +msgstr "Online on %s" + +msgid "Empty result from online reformatter" +msgstr "Empty result from online reformatter" + +msgid "Query exact row count" +msgstr "Query exact row count" + +msgid "Code reformatted in %s, using formatter %s" +msgstr "Code reformatted in %s, using formatter %s" + +msgid "Show static row id column" +msgstr "Show static row id column" + +msgid "Reset panel dimensions" +msgstr "Reset panel dimensions" + +msgid "Reset and fix overlapping panels in main window" +msgstr "Reset and fix overlapping panels in main window" + +msgid "Warning: Given cipher scheme name \"%s\" could not be found" +msgstr "Warning: Given cipher scheme name \"%s\" could not be found" + +msgid "Warning: Configuring with cipher index %d failed" +msgstr "Warning: Configuring with cipher index %d failed" + +msgid "Warning: Failed to set cipher encryption parameter \"%s\"" +msgstr "Warning: Failed to set cipher encryption parameter \"%s\"" + +msgid "Info: Cipher encryption parameter \"%s\" set" +msgstr "Info: Cipher encryption parameter \"%s\" set" + +msgid "You have activated encryption on a probably non-encrypted database." +msgstr "You have activated encryption on a probably non-encrypted database." + +msgid "Number of rows:" +msgstr "Number of rows:" + +msgid "Amount of NULLs [percent]:" +msgstr "Amount of NULLs [percent]:" + +msgid "Generate" +msgstr "Generate" + +msgid "Generate data" +msgstr "Generate data" + +msgid "Reformatter:" +msgstr "Reformatter:" + +msgid "Always ask" +msgstr "Always ask" + +msgid "" +"File already exists: %s\n" +"\n" +"Overwrite it?" +msgstr "" +"File already exists: %s\n" +"\n" +"Overwrite it?" + +msgid "Export cancelled, file not overwritten: %s" +msgstr "Export cancelled, file not overwritten: %s" + +msgid "Discard changes?" +msgstr "Discard changes?" + +msgid "Select top %s rows" +msgstr "Select top %s rows" + +msgid "Selects the first %s rows in a new query tab" +msgstr "Selects the first %s rows in a new query tab" + +msgid "Open file after creation" +msgstr "Open file after creation" + +msgid "Source table" +msgstr "Source table" diff --git a/out/plink-0.81-64.exe b/out/plink-0.81-64.exe new file mode 100644 index 000000000..c1dbbd092 Binary files /dev/null and b/out/plink-0.81-64.exe differ diff --git a/out/plink-32.exe b/out/plink-32.exe deleted file mode 100644 index 6c31f53a1..000000000 Binary files a/out/plink-32.exe and /dev/null differ diff --git a/out/plink-64.exe b/out/plink-64.exe index 414078de4..11aa60d03 100644 Binary files a/out/plink-64.exe and b/out/plink-64.exe differ diff --git a/out/plugins32/auth_gssapi_client.dll b/out/plugins32/auth_gssapi_client.dll deleted file mode 100644 index 1214bd31c..000000000 Binary files a/out/plugins32/auth_gssapi_client.dll and /dev/null differ diff --git a/out/plugins32/auth_named_pipe.dll b/out/plugins32/auth_named_pipe.dll deleted file mode 100644 index 91d079d3d..000000000 Binary files a/out/plugins32/auth_named_pipe.dll and /dev/null differ diff --git a/out/plugins32/caching_sha2_password.dll b/out/plugins32/caching_sha2_password.dll deleted file mode 100644 index 5bbc9593c..000000000 Binary files a/out/plugins32/caching_sha2_password.dll and /dev/null differ diff --git a/out/plugins32/client_ed25519.dll b/out/plugins32/client_ed25519.dll deleted file mode 100644 index 657cd0c24..000000000 Binary files a/out/plugins32/client_ed25519.dll and /dev/null differ diff --git a/out/plugins32/dialog.dll b/out/plugins32/dialog.dll deleted file mode 100644 index 209c12097..000000000 Binary files a/out/plugins32/dialog.dll and /dev/null differ diff --git a/out/plugins32/mysql_clear_password.dll b/out/plugins32/mysql_clear_password.dll deleted file mode 100644 index 72af6f645..000000000 Binary files a/out/plugins32/mysql_clear_password.dll and /dev/null differ diff --git a/out/plugins32/pvio_npipe.dll b/out/plugins32/pvio_npipe.dll deleted file mode 100644 index 649d25b9e..000000000 Binary files a/out/plugins32/pvio_npipe.dll and /dev/null differ diff --git a/out/plugins32/pvio_shmem.dll b/out/plugins32/pvio_shmem.dll deleted file mode 100644 index 933b604e4..000000000 Binary files a/out/plugins32/pvio_shmem.dll and /dev/null differ diff --git a/out/plugins32/sha256_password.dll b/out/plugins32/sha256_password.dll deleted file mode 100644 index 3b232dfef..000000000 Binary files a/out/plugins32/sha256_password.dll and /dev/null differ diff --git a/out/plugins64/auth_ed25519.dll b/out/plugins64/auth_ed25519.dll new file mode 100644 index 000000000..e0e977a91 Binary files /dev/null and b/out/plugins64/auth_ed25519.dll differ diff --git a/out/plugins64/auth_gssapi.dll b/out/plugins64/auth_gssapi.dll new file mode 100644 index 000000000..f10859afb Binary files /dev/null and b/out/plugins64/auth_gssapi.dll differ diff --git a/out/plugins64/auth_gssapi_client.dll b/out/plugins64/auth_gssapi_client.dll index ec3ae1c82..e88d25738 100644 Binary files a/out/plugins64/auth_gssapi_client.dll and b/out/plugins64/auth_gssapi_client.dll differ diff --git a/out/plugins64/auth_named_pipe.dll b/out/plugins64/auth_named_pipe.dll index d4f61c4ff..0318dc07f 100644 Binary files a/out/plugins64/auth_named_pipe.dll and b/out/plugins64/auth_named_pipe.dll differ diff --git a/out/plugins64/authentication_windows_client.dll b/out/plugins64/authentication_windows_client.dll new file mode 100644 index 000000000..ea6f5abc1 Binary files /dev/null and b/out/plugins64/authentication_windows_client.dll differ diff --git a/out/plugins64/caching_sha2_password.dll b/out/plugins64/caching_sha2_password.dll index 1e2ab3a66..6c03b4008 100644 Binary files a/out/plugins64/caching_sha2_password.dll and b/out/plugins64/caching_sha2_password.dll differ diff --git a/out/plugins64/client_ed25519.dll b/out/plugins64/client_ed25519.dll index 41a34d010..a8980b868 100644 Binary files a/out/plugins64/client_ed25519.dll and b/out/plugins64/client_ed25519.dll differ diff --git a/out/plugins64/dialog.dll b/out/plugins64/dialog.dll index 320f8835d..c214e2fdb 100644 Binary files a/out/plugins64/dialog.dll and b/out/plugins64/dialog.dll differ diff --git a/out/plugins64/mysql_clear_password.dll b/out/plugins64/mysql_clear_password.dll index 6e1abecb7..4eac16d3c 100644 Binary files a/out/plugins64/mysql_clear_password.dll and b/out/plugins64/mysql_clear_password.dll differ diff --git a/out/plugins64/parsec.dll b/out/plugins64/parsec.dll new file mode 100644 index 000000000..b8e25c946 Binary files /dev/null and b/out/plugins64/parsec.dll differ diff --git a/out/plugins64/pvio_npipe.dll b/out/plugins64/pvio_npipe.dll index 5ecb6578b..2d5934145 100644 Binary files a/out/plugins64/pvio_npipe.dll and b/out/plugins64/pvio_npipe.dll differ diff --git a/out/plugins64/pvio_shmem.dll b/out/plugins64/pvio_shmem.dll index e09ef9099..c07c10127 100644 Binary files a/out/plugins64/pvio_shmem.dll and b/out/plugins64/pvio_shmem.dll differ diff --git a/out/plugins64/sha256_password.dll b/out/plugins64/sha256_password.dll index f1bab4352..0e5c85f25 100644 Binary files a/out/plugins64/sha256_password.dll and b/out/plugins64/sha256_password.dll differ diff --git a/out/sqlite3-32.dll b/out/sqlite3-32.dll deleted file mode 100644 index 233d3c221..000000000 Binary files a/out/sqlite3-32.dll and /dev/null differ diff --git a/out/sqlite3-64.dll b/out/sqlite3-64.dll index 6fda3259c..cb279efd6 100644 Binary files a/out/sqlite3-64.dll and b/out/sqlite3-64.dll differ diff --git a/out/sqlite3mc-64.dll b/out/sqlite3mc-64.dll new file mode 100644 index 000000000..d21fd0bdc Binary files /dev/null and b/out/sqlite3mc-64.dll differ diff --git a/out/ssleay32-64.dll b/out/ssleay32-64.dll new file mode 100644 index 000000000..44f79428e Binary files /dev/null and b/out/ssleay32-64.dll differ diff --git a/packages/Delphi10.4/heidisql.dproj b/packages/Delphi10.4/heidisql.dproj deleted file mode 100644 index 47d63b5fe..000000000 --- a/packages/Delphi10.4/heidisql.dproj +++ /dev/null @@ -1,322 +0,0 @@ - - - {32493ED6-4F48-45D7-9D50-E4FA13F59063} - heidisql.dpr - True - Debug - 3 - Application - VCL - 19.0 - Win64 - - - true - - - true - Base - true - - - true - Base - true - - - true - Base - true - - - true - Cfg_1 - true - true - - - true - Cfg_1 - true - true - - - true - Base - true - - - true - Cfg_2 - true - true - - - true - Cfg_2 - true - true - - - false - false - ..\..\out\ - ..\..\build\$(Platform) - ..\..\components\synedit\build\$(Platform);..\..\components\virtualtreeview\build\$(Platform);..\..\components\synedit\source;..\..\components\virtualtreeview\source;..\..\source\detours\Source;..\..\source\vcl-styles-utils;..\..\source\sizegrip;$(DCC_UnitSearchPath) - $(BDS)\bin\default_app.manifest - false - false - Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;Winapi;FMX.Canvas.GPU;System.Win;Data.Win;$(DCC_Namespace) - false - 00400000 - CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName=;CFBundleDisplayName=;UIDeviceFamily=;CFBundleIdentifier=;CFBundleVersion=;CFBundlePackageType=;CFBundleSignature=;CFBundleAllowMixedLocalizations=;UISupportedInterfaceOrientations=;CFBundleExecutable=;CFBundleResourceSpecification=;LSRequiresIPhoneOS=;CFBundleInfoDictionaryVersion=;CFBundleDevelopmentRegion=;package=;label=;versionCode=;versionName=;persistent=;restoreAnyVersion=;installLocation=;largeHeap=;theme= - false - true - false - 1033 - heidisql - - - Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) - true - CompanyName=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName);FileDescription=$(MSBuildProjectName);ProductName=$(MSBuildProjectName) - $(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_44.png - $(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_150.png - - - Datasnap.Win;Web.Win;Soap.Win;Xml.Win;$(DCC_Namespace) - CompanyName=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName);FileDescription=$(MSBuildProjectName);ProductName=$(MSBuildProjectName) - true - $(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_44.png - $(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_150.png - - - RELEASE;$(DCC_Define) - false - 0 - 0 - - - true - CompanyName=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName);FileDescription=$(MSBuildProjectName);ProductName=$(MSBuildProjectName) - false - - - true - CompanyName=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName);FileDescription=$(MSBuildProjectName);ProductName=$(MSBuildProjectName) - - - true - DEBUG;$(DCC_Define) - false - - - None - 2 - 3 - madExcept;$(DCC_Define) - true - CompanyName=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName);FileDescription=$(MSBuildProjectName);ProductName=$(MSBuildProjectName) - Debug - - - 2 - madExcept;$(DCC_Define) - true - CompanyName=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName);FileDescription=$(MSBuildProjectName);ProductName=$(MSBuildProjectName) - 3 - true - Debug - (Ohne) - PerMonitor - - - - MainSource - - -

MainForm -
- -
AboutBox
- - -
connform
- - -
loaddataform
- - -
UserManagerForm
- - -
optionsform
- - -
frmTableTools
- - -
printlistForm
- - -
CopyTableForm
- - -
frmInsertFiles
- - - -
frmSQLhelp
- - - -
ColumnSelectionForm
- - -
DataSortingForm
- - -
CreateDatabaseForm
- - -
frmUpdateCheck
- - -
frmEditVariable
- - -
frmView
- - -
frmSelectDBObject
- - -
frmTextEditor
- - -
frmBinEditor
- - - -
frmRoutineEditor
- - -
frmTableEditor
- - - -
frmTriggerEditor
- TFrame - - -
frmSearchReplace
- - -
frmEventEditor
- TFrame - - -
frmLogin
- - - -
frmExportGrid
- - -
frmSyncDB
- - - - - -
frmPasswordChange
- - -
frmThemePreview
- - - Cfg_2 - Base - - - Base - - - Cfg_1 - Base - - - - Delphi.Personality.12 - - - - - heidisql.dpr - - - False - False - 1 - 0 - 0 - 0 - False - False - False - False - False - 1033 - 1252 - - - - - 1.0.0.0 - - - - - - 1.0.0.0 - - - - - - - - - - - - - - - - - - - - - - - - - - - Microsoft Office 2000 Beispiele für gekapselte Komponenten für Automatisierungsserver - Microsoft Office XP Beispiele für gekapselte Komponenten für Automation Server - - - - True - True - - False - - 12 - - - - diff --git a/packages/Delphi10.4/heidisql.dpr b/packages/Delphi12.1/heidisql.dpr similarity index 76% rename from packages/Delphi10.4/heidisql.dpr rename to packages/Delphi12.1/heidisql.dpr index f139c12ec..b9d721e61 100644 --- a/packages/Delphi10.4/heidisql.dpr +++ b/packages/Delphi12.1/heidisql.dpr @@ -2,16 +2,17 @@ program heidisql; uses madExcept, - Forms, - SysUtils, - Dialogs, - Windows, + Vcl.Forms, + System.SysUtils, + Vcl.Dialogs, + Vcl.Controls, + Winapi.Windows, main in '..\..\source\main.pas' {MainForm}, about in '..\..\source\about.pas' {AboutBox}, connections in '..\..\source\connections.pas' {connform}, loaddata in '..\..\source\loaddata.pas' {loaddataform}, usermanager in '..\..\source\usermanager.pas' {UserManagerForm}, - options in '..\..\source\options.pas' {optionsform}, + preferences in '..\..\source\preferences.pas' {frmPreferences}, tabletools in '..\..\source\tabletools.pas' {frmTableTools}, printlist in '..\..\source\printlist.pas' {printlistForm}, copytable in '..\..\source\copytable.pas' {CopyTableForm}, @@ -19,8 +20,13 @@ uses apphelpers in '..\..\source\apphelpers.pas', sqlhelp in '..\..\source\sqlhelp.pas' {frmSQLhelp}, dbstructures in '..\..\source\dbstructures.pas', - column_selection in '..\..\source\column_selection.pas' {ColumnSelectionForm}, - data_sorting in '..\..\source\data_sorting.pas' {DataSortingForm}, + dbstructures.mysql in '..\..\source\dbstructures.mysql.pas', + dbstructures.mssql in '..\..\source\dbstructures.mssql.pas', + dbstructures.postgresql in '..\..\source\dbstructures.postgresql.pas', + dbstructures.sqlite in '..\..\source\dbstructures.sqlite.pas', + dbstructures.interbase in '..\..\source\dbstructures.interbase.pas', + column_selection in '..\..\source\column_selection.pas' {frmColumnSelection}, + data_sorting in '..\..\source\data_sorting.pas' {frmDataSorting}, createdatabase in '..\..\source\createdatabase.pas' {CreateDatabaseForm}, updatecheck in '..\..\source\updatecheck.pas' {frmUpdateCheck}, editvar in '..\..\source\editvar.pas' {frmEditVariable}, @@ -46,14 +52,20 @@ uses Vcl.Themes, Vcl.Styles, Vcl.Graphics, - theme_preview in '..\..\source\theme_preview.pas' {frmThemePreview}; + theme_preview in '..\..\source\theme_preview.pas' {frmThemePreview}, + csv_detector in '..\..\source\csv_detector.pas' {frmCsvDetector}, + generic_types in '..\..\source\generic_types.pas', + customize_highlighter in '..\..\source\customize_highlighter.pas' {frmCustomizeHighlighter}, + Xml.VerySimple in '..\..\source\Xml.VerySimple.pas', + Sequal.Suggest in '..\..\source\Sequal.Suggest.pas' {SequalSuggestForm}, + reformatter in '..\..\source\reformatter.pas' {frmReformatter}; {.$R *.RES} {$R ..\..\res\icon.RES} {$R ..\..\res\icon-question.RES} {$R ..\..\res\version.RES} {$R ..\..\res\manifest.RES} -{$R ..\..\res\updater.RES} +{$IFDEF CPUX64}{$R ..\..\res\updater.RES}{$ENDIF} {$R ..\..\res\styles.RES} var @@ -61,6 +73,7 @@ var WantedStyle: String; begin PostponedLogItems := TDBLogItems.Create(True); + //Application.MainFormOnTaskBar := True; // Use MySQL standard format for date/time variables: YYYY-MM-DD HH:MM:SS // Be aware that Delphi internally converts the slashes in ShortDateFormat to the DateSeparator @@ -84,6 +97,9 @@ begin // Issue #3064: Ignore TFont, so "Default" on mainform for WinXP users does not get broken. gnugettext.TP_GlobalIgnoreClass(TFont); + // Enable padding in customized tooltips + HintWindowClass := TExtHintWindow; + Application.Initialize; Application.Title := APPNAME; Application.UpdateFormatSettings := False; @@ -94,7 +110,6 @@ begin if TStyleManager.ActiveStyle.Name <> WantedStyle then begin AppSettings.WriteString(asTheme, TStyleManager.ActiveStyle.Name); end; - Application.CreateForm(TMainForm, MainForm); MainForm.AfterFormCreate; Application.OnDeactivate := MainForm.ApplicationDeActivate; diff --git a/packages/Delphi12.1/heidisql.dproj b/packages/Delphi12.1/heidisql.dproj new file mode 100644 index 000000000..49289f45c --- /dev/null +++ b/packages/Delphi12.1/heidisql.dproj @@ -0,0 +1,1319 @@ + + + {32493ED6-4F48-45D7-9D50-E4FA13F59063} + heidisql.dpr + True + Debug + 3 + Application + VCL + 20.1 + Win64 + heidisql + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_1 + true + true + + + true + Cfg_1 + true + true + + + true + Base + true + + + true + Cfg_2 + true + true + + + true + Cfg_2 + true + true + + + false + false + ..\..\out\ + ..\..\build\$(Platform) + ..\..\components\synedit\build\$(Platform);..\..\components\virtualtreeview\build\$(Platform);..\..\components\synedit\source;..\..\components\virtualtreeview\source;..\..\source\detours\Source;..\..\source\vcl-styles-utils;..\..\source\sizegrip;$(DCC_UnitSearchPath) + $(BDS)\bin\default_app.manifest + false + false + false + 00400000 + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName=;CFBundleDisplayName=;UIDeviceFamily=;CFBundleIdentifier=;CFBundleVersion=;CFBundlePackageType=;CFBundleSignature=;CFBundleAllowMixedLocalizations=;UISupportedInterfaceOrientations=;CFBundleExecutable=;CFBundleResourceSpecification=;LSRequiresIPhoneOS=;CFBundleInfoDictionaryVersion=;CFBundleDevelopmentRegion=;package=;label=;versionCode=;versionName=;persistent=;restoreAnyVersion=;installLocation=;largeHeap=;theme= + false + true + false + 1033 + heidisql + Vcl;System;Winapi;System.Win;Data;$(DCC_Namespace) + false + false + false + + + true + CompanyName=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName);FileDescription=$(MSBuildProjectName);ProductName=$(MSBuildProjectName) + $(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_44.png + $(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_150.png + + + CompanyName=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName);FileDescription=$(MSBuildProjectName);ProductName=$(MSBuildProjectName) + true + $(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_44.png + $(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_150.png + + + RELEASE;$(DCC_Define) + false + 0 + 0 + + + true + CompanyName=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName);FileDescription=$(MSBuildProjectName);ProductName=$(MSBuildProjectName) + false + Debug + madExcept;$(DCC_Define) + 3 + 2 + true + + + true + CompanyName=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName);FileDescription=$(MSBuildProjectName);ProductName=$(MSBuildProjectName) + Debug + 2 + true + madExcept;$(DCC_Define) + 3 + + + true + DEBUG;$(DCC_Define) + false + + + None + 2 + 3 + madExcept;$(DCC_Define) + true + CompanyName=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName);FileDescription=$(MSBuildProjectName);ProductName=$(MSBuildProjectName) + Debug + + + 2 + true + CompanyName=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName);FileDescription=$(MSBuildProjectName);ProductName=$(MSBuildProjectName) + 3 + Debug + PerMonitorV2 + madExcept;$(DCC_Define) + + + + MainSource + + +
MainForm
+ + +
AboutBox
+ + +
connform
+ + +
loaddataform
+ + +
UserManagerForm
+ + +
frmPreferences
+ + +
frmTableTools
+ + +
printlistForm
+ + +
CopyTableForm
+ + +
frmInsertFiles
+ + + +
frmSQLhelp
+ + + + + + + + +
frmColumnSelection
+ + +
frmDataSorting
+ + +
CreateDatabaseForm
+ + +
frmUpdateCheck
+ + +
frmEditVariable
+ + +
frmView
+ + +
frmSelectDBObject
+ + +
frmTextEditor
+ + +
frmBinEditor
+ + + +
frmRoutineEditor
+ + +
frmTableEditor
+ + + +
frmTriggerEditor
+ TFrame + + +
frmSearchReplace
+ + +
frmEventEditor
+ TFrame + + +
frmLogin
+ + + +
frmExportGrid
+ + +
frmSyncDB
+ + + + + +
frmPasswordChange
+ + +
frmThemePreview
+ + +
frmCsvDetector
+ + + +
frmCustomizeHighlighter
+ + + +
SequalSuggestForm
+ dfm + + +
frmReformatter
+ dfm + + + + Base + + + Cfg_1 + Base + + + Cfg_2 + Base + + + + Delphi.Personality.12 + + + + + heidisql.dpr + + + False + False + 1 + 0 + 0 + 0 + False + False + False + False + False + 1033 + 1252 + + + + + 1.0.0.0 + + + + + + 1.0.0.0 + + + + + + + + + + + + + + + + + + + + + + + + + + + Microsoft Office 2000 Sample Automation Server Wrapper Components + Microsoft Office XP Sample Automation Server Wrapper Components + + + + True + True + + False + + + + + + + + + 1 + + + Contents\MacOS + 1 + + + 0 + + + + + classes + 64 + + + classes + 64 + + + + + res\xml + 1 + + + res\xml + 1 + + + + + library\lib\armeabi-v7a + 1 + + + + + library\lib\armeabi + 1 + + + library\lib\armeabi + 1 + + + + + library\lib\armeabi-v7a + 1 + + + + + library\lib\mips + 1 + + + library\lib\mips + 1 + + + + + library\lib\armeabi-v7a + 1 + + + library\lib\arm64-v8a + 1 + + + + + library\lib\armeabi-v7a + 1 + + + + + res\drawable + 1 + + + res\drawable + 1 + + + + + res\drawable-anydpi-v21 + 1 + + + res\drawable-anydpi-v21 + 1 + + + + + res\values + 1 + + + res\values + 1 + + + + + res\values-v21 + 1 + + + res\values-v21 + 1 + + + + + res\values-v31 + 1 + + + res\values-v31 + 1 + + + + + res\drawable-anydpi-v26 + 1 + + + res\drawable-anydpi-v26 + 1 + + + + + res\drawable + 1 + + + res\drawable + 1 + + + + + res\drawable + 1 + + + res\drawable + 1 + + + + + res\drawable + 1 + + + res\drawable + 1 + + + + + res\drawable-anydpi-v33 + 1 + + + res\drawable-anydpi-v33 + 1 + + + + + res\values + 1 + + + res\values + 1 + + + + + res\values-night-v21 + 1 + + + res\values-night-v21 + 1 + + + + + res\drawable + 1 + + + res\drawable + 1 + + + + + res\drawable-xxhdpi + 1 + + + res\drawable-xxhdpi + 1 + + + + + res\drawable-xxxhdpi + 1 + + + res\drawable-xxxhdpi + 1 + + + + + res\drawable-ldpi + 1 + + + res\drawable-ldpi + 1 + + + + + res\drawable-mdpi + 1 + + + res\drawable-mdpi + 1 + + + + + res\drawable-hdpi + 1 + + + res\drawable-hdpi + 1 + + + + + res\drawable-xhdpi + 1 + + + res\drawable-xhdpi + 1 + + + + + res\drawable-mdpi + 1 + + + res\drawable-mdpi + 1 + + + + + res\drawable-hdpi + 1 + + + res\drawable-hdpi + 1 + + + + + res\drawable-xhdpi + 1 + + + res\drawable-xhdpi + 1 + + + + + res\drawable-xxhdpi + 1 + + + res\drawable-xxhdpi + 1 + + + + + res\drawable-xxxhdpi + 1 + + + res\drawable-xxxhdpi + 1 + + + + + res\drawable-small + 1 + + + res\drawable-small + 1 + + + + + res\drawable-normal + 1 + + + res\drawable-normal + 1 + + + + + res\drawable-large + 1 + + + res\drawable-large + 1 + + + + + res\drawable-xlarge + 1 + + + res\drawable-xlarge + 1 + + + + + res\values + 1 + + + res\values + 1 + + + + + res\drawable-anydpi-v24 + 1 + + + res\drawable-anydpi-v24 + 1 + + + + + res\drawable + 1 + + + res\drawable + 1 + + + + + res\drawable-night-anydpi-v21 + 1 + + + res\drawable-night-anydpi-v21 + 1 + + + + + res\drawable-anydpi-v31 + 1 + + + res\drawable-anydpi-v31 + 1 + + + + + res\drawable-night-anydpi-v31 + 1 + + + res\drawable-night-anydpi-v31 + 1 + + + + + 1 + + + Contents\MacOS + 1 + + + 0 + + + + + Contents\MacOS + 1 + .framework + + + Contents\MacOS + 1 + .framework + + + Contents\MacOS + 1 + .framework + + + 0 + + + + + 1 + .dylib + + + 1 + .dylib + + + 1 + .dylib + + + Contents\MacOS + 1 + .dylib + + + Contents\MacOS + 1 + .dylib + + + Contents\MacOS + 1 + .dylib + + + 0 + .dll;.bpl + + + + + 1 + .dylib + + + 1 + .dylib + + + 1 + .dylib + + + Contents\MacOS + 1 + .dylib + + + Contents\MacOS + 1 + .dylib + + + Contents\MacOS + 1 + .dylib + + + 0 + .bpl + + + + + 0 + + + 0 + + + 0 + + + 0 + + + 0 + + + Contents\Resources\StartUp\ + 0 + + + Contents\Resources\StartUp\ + 0 + + + Contents\Resources\StartUp\ + 0 + + + 0 + + + + + 1 + + + 1 + + + + + ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF + 1 + + + ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF + 1 + + + + + ..\ + 1 + + + ..\ + 1 + + + ..\ + 1 + + + + + Contents + 1 + + + Contents + 1 + + + Contents + 1 + + + + + Contents\Resources + 1 + + + Contents\Resources + 1 + + + Contents\Resources + 1 + + + + + library\lib\armeabi-v7a + 1 + + + library\lib\arm64-v8a + 1 + + + 1 + + + 1 + + + 1 + + + 1 + + + Contents\MacOS + 1 + + + Contents\MacOS + 1 + + + Contents\MacOS + 1 + + + 0 + + + + + library\lib\armeabi-v7a + 1 + + + + + 1 + + + 1 + + + 1 + + + + + ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF + 1 + + + ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF + 1 + + + ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF + 1 + + + + + ..\ + 1 + + + ..\ + 1 + + + ..\ + 1 + + + + + 1 + + + 1 + + + 1 + + + + + ..\$(PROJECTNAME).launchscreen + 64 + + + ..\$(PROJECTNAME).launchscreen + 64 + + + + + 1 + + + 1 + + + 1 + + + + + Assets + 1 + + + Assets + 1 + + + + + Assets + 1 + + + Assets + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + + + + + + + + + + + + + + 12 + + + + + diff --git a/packages/Delphi10.4/heidisql.groupproj b/packages/Delphi12.1/heidisql.groupproj similarity index 68% rename from packages/Delphi10.4/heidisql.groupproj rename to packages/Delphi12.1/heidisql.groupproj index a8d8bf3c6..c86a77c88 100644 --- a/packages/Delphi10.4/heidisql.groupproj +++ b/packages/Delphi12.1/heidisql.groupproj @@ -1,84 +1,96 @@ - - - {C4296A31-CCFB-4D2F-8BEC-26CD630E9987} - - - - - - - - - - - - - - - - - - - - Default.Personality.12 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + {C4296A31-CCFB-4D2F-8BEC-26CD630E9987} + + + + + + + + + + + + + + + + + + + + + + + Default.Personality.12 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/packages/Delphi10.4/heidisql.mes b/packages/Delphi12.1/heidisql.mes similarity index 96% rename from packages/Delphi10.4/heidisql.mes rename to packages/Delphi12.1/heidisql.mes index 943bb4737..cf4d3b4fd 100644 --- a/packages/Delphi10.4/heidisql.mes +++ b/packages/Delphi12.1/heidisql.mes @@ -13,7 +13,7 @@ CopyBugReportToClipboard=0 SuspendAllRunningThreads=0 ShowPleaseWaitBox=1 PleaseWaitIcon=plwait1 -AutomaticallyContinueApplication=0 +AutomaticallyContinueApplication=1 AutomaticallyRestartApplication=0 AutomaticallyCloseApplication=0 MailAddress= @@ -29,7 +29,7 @@ SmtpPort=0 SmtpAccount= SmtpPassword= HttpServer=www.heidisql.com/bugreport.php -HttpPort=443 +HttpPort=0 HttpAccount= HttpPassword= BugReportFile=bugreport.txt @@ -38,7 +38,7 @@ AttachBugReportFile=1 DeleteBugReportFile=1 BugReportSendAs=bugreport.txt BugReportZip= -ScreenShotDepth=8 +ScreenShotDepth=0 ScreenShotAppOnly=1 ScreenShotSendAs=screenshot.png ScreenShotZip= @@ -107,7 +107,7 @@ FocusedButton=0 SendAssistant=SendAssistant SaveAssistant= PrintAssistant=PrintAssistant -AutomaticallyShowBugReport=1 +AutomaticallyShowBugReport=0 NoOwnerDrawButtons=0 BigExceptionIcon=big1 TitleBar=%25appname%25 diff --git a/packages/Delphi12.3/heidisql.dpr b/packages/Delphi12.3/heidisql.dpr new file mode 100644 index 000000000..f25ac703e --- /dev/null +++ b/packages/Delphi12.3/heidisql.dpr @@ -0,0 +1,122 @@ +program heidisql; + +uses + madExcept, + Vcl.Forms, + System.SysUtils, + Vcl.Dialogs, + Vcl.Controls, + Vcl.ComCtrls, + Winapi.Windows, + main in '..\..\source\main.pas' {MainForm}, + about in '..\..\source\about.pas' {AboutBox}, + connections in '..\..\source\connections.pas' {connform}, + loaddata in '..\..\source\loaddata.pas' {loaddataform}, + usermanager in '..\..\source\usermanager.pas' {UserManagerForm}, + preferences in '..\..\source\preferences.pas' {frmPreferences}, + tabletools in '..\..\source\tabletools.pas' {frmTableTools}, + printlist in '..\..\source\printlist.pas' {printlistForm}, + copytable in '..\..\source\copytable.pas' {CopyTableForm}, + insertfiles in '..\..\source\insertfiles.pas' {frmInsertFiles}, + apphelpers in '..\..\source\apphelpers.pas', + sqlhelp in '..\..\source\sqlhelp.pas' {frmSQLhelp}, + dbstructures in '..\..\source\dbstructures.pas', + dbstructures.mysql in '..\..\source\dbstructures.mysql.pas', + dbstructures.mssql in '..\..\source\dbstructures.mssql.pas', + dbstructures.postgresql in '..\..\source\dbstructures.postgresql.pas', + dbstructures.sqlite in '..\..\source\dbstructures.sqlite.pas', + dbstructures.interbase in '..\..\source\dbstructures.interbase.pas', + column_selection in '..\..\source\column_selection.pas' {frmColumnSelection}, + data_sorting in '..\..\source\data_sorting.pas' {frmDataSorting}, + createdatabase in '..\..\source\createdatabase.pas' {CreateDatabaseForm}, + updatecheck in '..\..\source\updatecheck.pas' {frmUpdateCheck}, + editvar in '..\..\source\editvar.pas' {frmEditVariable}, + view in '..\..\source\view.pas' {frmView}, + selectdbobject in '..\..\source\selectdbobject.pas' {frmSelectDBObject}, + texteditor in '..\..\source\texteditor.pas' {frmTextEditor}, + bineditor in '..\..\source\bineditor.pas' {frmBinEditor}, + grideditlinks in '..\..\source\grideditlinks.pas', + routine_editor in '..\..\source\routine_editor.pas' {frmRoutineEditor}, + table_editor in '..\..\source\table_editor.pas' {frmTableEditor}, + dbconnection in '..\..\source\dbconnection.pas', + trigger_editor in '..\..\source\trigger_editor.pas' {frmTriggerEditor: TFrame}, + searchreplace in '..\..\source\searchreplace.pas' {frmSearchReplace}, + event_editor in '..\..\source\event_editor.pas' {frmEventEditor: TFrame}, + loginform in '..\..\source\loginform.pas' {frmLogin}, + Cromis.DirectoryWatch in '..\..\source\Cromis.DirectoryWatch.pas', + exportgrid in '..\..\source\exportgrid.pas' {frmExportGrid}, + syncdb in '..\..\source\syncdb.pas' {frmSyncDB}, + gnugettext in '..\..\source\gnugettext.pas', + JumpList in '..\..\source\JumpList.pas', + extra_controls in '..\..\source\extra_controls.pas', + change_password in '..\..\source\change_password.pas' {frmPasswordChange}, + Vcl.Themes, + Vcl.Styles, + Vcl.Graphics, + theme_preview in '..\..\source\theme_preview.pas' {frmThemePreview}, + csv_detector in '..\..\source\csv_detector.pas' {frmCsvDetector}, + generic_types in '..\..\source\generic_types.pas', + customize_highlighter in '..\..\source\customize_highlighter.pas' {frmCustomizeHighlighter}, + Xml.VerySimple in '..\..\source\Xml.VerySimple.pas', + Sequal.Suggest in '..\..\source\Sequal.Suggest.pas' {SequalSuggestForm}, + reformatter in '..\..\source\reformatter.pas' {frmReformatter}; + +{.$R *.RES} +{$R ..\..\res\icon.RES} +{$R ..\..\res\icon-question.RES} +{$R ..\..\res\version.RES} +{$R ..\..\res\manifest.RES} +{$IFDEF CPUX64}{$R ..\..\res\updater.RES}{$ENDIF} +{$R ..\..\res\styles.RES} + +var + AppLanguage: String; + WantedStyle: String; +begin + PostponedLogItems := TDBLogItems.Create(True); + //Application.MainFormOnTaskBar := True; + + // Use MySQL standard format for date/time variables: YYYY-MM-DD HH:MM:SS + // Be aware that Delphi internally converts the slashes in ShortDateFormat to the DateSeparator + FormatSettings.DateSeparator := '-'; + FormatSettings.TimeSeparator := ':'; + FormatSettings.ShortDateFormat := 'yyyy/mm/dd'; + FormatSettings.LongTimeFormat := 'hh:nn:ss'; + + AppSettings := TAppSettings.Create; + SecondInstMsgId := RegisterWindowMessage(APPNAME); + if (not AppSettings.ReadBool(asAllowMultipleInstances)) and CheckForSecondInstance then begin + AppSettings.Free; + Application.Terminate; + end else begin + + AppLanguage := AppSettings.ReadString(asAppLanguage); + // SysLanguage may be zh_CN, while we don't offer such a language, but anyway, this is just the current system language: + SysLanguage := gnugettext.DefaultInstance.GetCurrentLocaleName; + gnugettext.UseLanguage(AppLanguage); + // First time translation via dxgettext. + // Issue #3064: Ignore TFont, so "Default" on mainform for WinXP users does not get broken. + gnugettext.TP_GlobalIgnoreClass(TFont); + gnugettext.TP_GlobalIgnoreClass(TComboBoxEx); + + // Enable padding in customized tooltips + HintWindowClass := TExtHintWindow; + + Application.Initialize; + Application.Title := APPNAME; + Application.UpdateFormatSettings := False; + + // Try to set style name. If that fails, the user gets an error message box - reset it to default when that happened + WantedStyle := AppSettings.ReadString(asTheme); + TStyleManager.TrySetStyle(WantedStyle); + if TStyleManager.ActiveStyle.Name <> WantedStyle then begin + AppSettings.WriteString(asTheme, TStyleManager.ActiveStyle.Name); + end; + Application.CreateForm(TMainForm, MainForm); + MainForm.AfterFormCreate; + Application.OnDeactivate := MainForm.ApplicationDeActivate; + Application.OnShowHint := MainForm.ApplicationShowHint; + Application.MainFormOnTaskBar := True; + Application.Run; + end; + end. diff --git a/packages/Delphi12.3/heidisql.dproj b/packages/Delphi12.3/heidisql.dproj new file mode 100644 index 000000000..a725978f6 --- /dev/null +++ b/packages/Delphi12.3/heidisql.dproj @@ -0,0 +1,1315 @@ + + + {32493ED6-4F48-45D7-9D50-E4FA13F59063} + heidisql.dpr + True + Debug + 3 + Application + VCL + 20.3 + Win64 + heidisql + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_1 + true + true + + + true + Cfg_1 + true + true + + + true + Base + true + + + true + Cfg_2 + true + true + + + true + Cfg_2 + true + true + + + false + false + ..\..\out\ + ..\..\build\$(Platform) + ..\..\components\synedit\build\$(Platform);..\..\components\virtualtreeview\build\$(Platform);..\..\components\synedit\source;..\..\components\virtualtreeview\source;..\..\source\detours\Source;..\..\source\vcl-styles-utils;..\..\source\sizegrip;$(DCC_UnitSearchPath) + $(BDS)\bin\default_app.manifest + false + false + false + 00400000 + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName=;CFBundleDisplayName=;UIDeviceFamily=;CFBundleIdentifier=;CFBundleVersion=;CFBundlePackageType=;CFBundleSignature=;CFBundleAllowMixedLocalizations=;UISupportedInterfaceOrientations=;CFBundleExecutable=;CFBundleResourceSpecification=;LSRequiresIPhoneOS=;CFBundleInfoDictionaryVersion=;CFBundleDevelopmentRegion=;package=;label=;versionCode=;versionName=;persistent=;restoreAnyVersion=;installLocation=;largeHeap=;theme= + false + true + false + 1033 + heidisql + Vcl;System;Winapi;System.Win;Data;$(DCC_Namespace) + false + false + false + + + true + CompanyName=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName);FileDescription=$(MSBuildProjectName);ProductName=$(MSBuildProjectName) + $(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_44.png + $(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_150.png + + + CompanyName=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName);FileDescription=$(MSBuildProjectName);ProductName=$(MSBuildProjectName) + true + $(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_44.png + $(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_150.png + + + RELEASE;$(DCC_Define) + false + 0 + 0 + + + true + CompanyName=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName);FileDescription=$(MSBuildProjectName);ProductName=$(MSBuildProjectName) + false + Debug + madExcept;$(DCC_Define) + 3 + 2 + true + + + true + CompanyName=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName);FileDescription=$(MSBuildProjectName);ProductName=$(MSBuildProjectName) + Debug + madExcept;$(DCC_Define) + 2 + 3 + none + true + + + true + DEBUG;$(DCC_Define) + false + true + + + None + 2 + 3 + madExcept;$(DCC_Define) + true + CompanyName=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName);FileDescription=$(MSBuildProjectName);ProductName=$(MSBuildProjectName) + Debug + + + 2 + true + CompanyName=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName);FileDescription=$(MSBuildProjectName);ProductName=$(MSBuildProjectName) + 3 + Debug + PerMonitorV2 + madExcept;$(DCC_Define) + + + + MainSource + + +
MainForm
+ + +
AboutBox
+ + +
connform
+ + +
loaddataform
+ + +
UserManagerForm
+ + +
frmPreferences
+ + +
frmTableTools
+ + +
printlistForm
+ + +
CopyTableForm
+ + +
frmInsertFiles
+ + + +
frmSQLhelp
+ + + + + + + + +
frmColumnSelection
+ + +
frmDataSorting
+ + +
CreateDatabaseForm
+ + +
frmUpdateCheck
+ + +
frmEditVariable
+ + +
frmView
+ + +
frmSelectDBObject
+ + +
frmTextEditor
+ + +
frmBinEditor
+ + + +
frmRoutineEditor
+ + +
frmTableEditor
+ + + +
frmTriggerEditor
+ TFrame + + +
frmSearchReplace
+ + +
frmEventEditor
+ TFrame + + +
frmLogin
+ + + +
frmExportGrid
+ + +
frmSyncDB
+ + + + + +
frmPasswordChange
+ + +
frmThemePreview
+ + +
frmCsvDetector
+ + + +
frmCustomizeHighlighter
+ + + +
SequalSuggestForm
+ dfm + + +
frmReformatter
+ dfm + + + + Base + + + Cfg_1 + Base + + + Cfg_2 + Base + + + + Delphi.Personality.12 + + + + + heidisql.dpr + + + False + False + 1 + 0 + 0 + 0 + False + False + False + False + False + 1033 + 1252 + + + + + 1.0.0.0 + + + + + + 1.0.0.0 + + + + + + + + + + + + + + + + + + + + + + + + + + + Microsoft Office 2000 Beispiele für gekapselte Komponenten für Automatisierungsserver + Microsoft Office XP Beispiele für gekapselte Komponenten für Automation Server + + + + True + True + + False + + + + + + + + + 1 + + + Contents\MacOS + 1 + + + 0 + + + + + res\xml + 1 + + + res\xml + 1 + + + + + library\lib\armeabi + 1 + + + library\lib\armeabi + 1 + + + + + library\lib\armeabi-v7a + 1 + + + + + library\lib\mips + 1 + + + library\lib\mips + 1 + + + + + library\lib\armeabi-v7a + 1 + + + library\lib\arm64-v8a + 1 + + + + + library\lib\armeabi-v7a + 1 + + + + + res\drawable + 1 + + + res\drawable + 1 + + + + + res\drawable-anydpi-v21 + 1 + + + res\drawable-anydpi-v21 + 1 + + + + + res\values + 1 + + + res\values + 1 + + + + + res\values-v21 + 1 + + + res\values-v21 + 1 + + + + + res\values-v31 + 1 + + + res\values-v31 + 1 + + + + + res\values-v35 + 1 + + + res\values-v35 + 1 + + + + + res\drawable-anydpi-v26 + 1 + + + res\drawable-anydpi-v26 + 1 + + + + + res\drawable + 1 + + + res\drawable + 1 + + + + + res\drawable + 1 + + + res\drawable + 1 + + + + + res\drawable + 1 + + + res\drawable + 1 + + + + + res\drawable-anydpi-v33 + 1 + + + res\drawable-anydpi-v33 + 1 + + + + + res\values + 1 + + + res\values + 1 + + + + + res\values-night-v21 + 1 + + + res\values-night-v21 + 1 + + + + + res\drawable + 1 + + + res\drawable + 1 + + + + + res\drawable-xxhdpi + 1 + + + res\drawable-xxhdpi + 1 + + + + + res\drawable-xxxhdpi + 1 + + + res\drawable-xxxhdpi + 1 + + + + + res\drawable-ldpi + 1 + + + res\drawable-ldpi + 1 + + + + + res\drawable-mdpi + 1 + + + res\drawable-mdpi + 1 + + + + + res\drawable-hdpi + 1 + + + res\drawable-hdpi + 1 + + + + + res\drawable-xhdpi + 1 + + + res\drawable-xhdpi + 1 + + + + + res\drawable-mdpi + 1 + + + res\drawable-mdpi + 1 + + + + + res\drawable-hdpi + 1 + + + res\drawable-hdpi + 1 + + + + + res\drawable-xhdpi + 1 + + + res\drawable-xhdpi + 1 + + + + + res\drawable-xxhdpi + 1 + + + res\drawable-xxhdpi + 1 + + + + + res\drawable-xxxhdpi + 1 + + + res\drawable-xxxhdpi + 1 + + + + + res\drawable-small + 1 + + + res\drawable-small + 1 + + + + + res\drawable-normal + 1 + + + res\drawable-normal + 1 + + + + + res\drawable-large + 1 + + + res\drawable-large + 1 + + + + + res\drawable-xlarge + 1 + + + res\drawable-xlarge + 1 + + + + + res\values + 1 + + + res\values + 1 + + + + + res\drawable-anydpi-v24 + 1 + + + res\drawable-anydpi-v24 + 1 + + + + + res\drawable + 1 + + + res\drawable + 1 + + + + + res\drawable-night-anydpi-v21 + 1 + + + res\drawable-night-anydpi-v21 + 1 + + + + + res\drawable-anydpi-v31 + 1 + + + res\drawable-anydpi-v31 + 1 + + + + + res\drawable-night-anydpi-v31 + 1 + + + res\drawable-night-anydpi-v31 + 1 + + + + + 1 + + + Contents\MacOS + 1 + + + 0 + + + + + Contents\MacOS + 1 + .framework + + + Contents\MacOS + 1 + .framework + + + Contents\MacOS + 1 + .framework + + + 0 + + + + + 1 + .dylib + + + 1 + .dylib + + + 1 + .dylib + + + Contents\MacOS + 1 + .dylib + + + Contents\MacOS + 1 + .dylib + + + Contents\MacOS + 1 + .dylib + + + 0 + .dll;.bpl + + + + + 1 + .dylib + + + 1 + .dylib + + + 1 + .dylib + + + Contents\MacOS + 1 + .dylib + + + Contents\MacOS + 1 + .dylib + + + Contents\MacOS + 1 + .dylib + + + 0 + .bpl + + + + + 0 + + + 0 + + + 0 + + + 0 + + + 0 + + + Contents\Resources\StartUp\ + 0 + + + Contents\Resources\StartUp\ + 0 + + + Contents\Resources\StartUp\ + 0 + + + 0 + + + + + 1 + + + 1 + + + + + ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF + 1 + + + ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF + 1 + + + + + ..\ + 1 + + + ..\ + 1 + + + ..\ + 1 + + + + + Contents + 1 + + + Contents + 1 + + + Contents + 1 + + + + + Contents\Resources + 1 + + + Contents\Resources + 1 + + + Contents\Resources + 1 + + + + + library\lib\armeabi-v7a + 1 + + + library\lib\arm64-v8a + 1 + + + 1 + + + 1 + + + 1 + + + 1 + + + Contents\MacOS + 1 + + + Contents\MacOS + 1 + + + Contents\MacOS + 1 + + + 0 + + + + + library\lib\armeabi-v7a + 1 + + + + + 1 + + + 1 + + + 1 + + + + + ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF + 1 + + + ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF + 1 + + + ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF + 1 + + + + + ..\ + 1 + + + ..\ + 1 + + + ..\ + 1 + + + + + 1 + + + 1 + + + 1 + + + + + ..\$(PROJECTNAME).launchscreen + 64 + + + ..\$(PROJECTNAME).launchscreen + 64 + + + + + 1 + + + 1 + + + 1 + + + + + Assets + 1 + + + Assets + 1 + + + + + Assets + 1 + + + Assets + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + + + + + + + + + + + + + + 12 + + + + + diff --git a/packages/Delphi12.3/heidisql.groupproj b/packages/Delphi12.3/heidisql.groupproj new file mode 100644 index 000000000..ef3f2fbb5 --- /dev/null +++ b/packages/Delphi12.3/heidisql.groupproj @@ -0,0 +1,96 @@ + + + {C4296A31-CCFB-4D2F-8BEC-26CD630E9987} + + + + + + + + + + + + + + + + + + + + + + + Default.Personality.12 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/packages/Delphi12.3/heidisql.mes b/packages/Delphi12.3/heidisql.mes new file mode 100644 index 000000000..cf4d3b4fd --- /dev/null +++ b/packages/Delphi12.3/heidisql.mes @@ -0,0 +1,164 @@ +[GeneralSettings] +HandleExceptions=1 +AppendMapFileToBinary=1 +NoOwnMadExceptSettings=0 +CheckFileCrc=1 +CheckForFrozenMainThread=0 +FreezeTimeout=60000 +AutomaticallySaveBugReport=0 +AutoSaveBugReportIfNotSent=0 +AutomaticallyMailBugReport=0 +AutoMailProgressBox=0 +CopyBugReportToClipboard=0 +SuspendAllRunningThreads=0 +ShowPleaseWaitBox=1 +PleaseWaitIcon=plwait1 +AutomaticallyContinueApplication=1 +AutomaticallyRestartApplication=0 +AutomaticallyCloseApplication=0 +MailAddress= +SendInBackground=0 +Send32Icon=send321 +MailAsSmtpServer=0 +MailAsSmtpClient=0 +UploadViaHttp=1 +MailViaMapi=0 +MailViaMailto=0 +SmtpServer= +SmtpPort=0 +SmtpAccount= +SmtpPassword= +HttpServer=www.heidisql.com/bugreport.php +HttpPort=0 +HttpAccount= +HttpPassword= +BugReportFile=bugreport.txt +AttachBugReport=1 +AttachBugReportFile=1 +DeleteBugReportFile=1 +BugReportSendAs=bugreport.txt +BugReportZip= +ScreenShotDepth=0 +ScreenShotAppOnly=1 +ScreenShotSendAs=screenshot.png +ScreenShotZip= +AdditionalAttachments= +AppendBugReports=0 +BugReportFileSize=100000 +DontSaveDuplicateExceptions=1 +DontSaveDuplicateFreezings=1 +DuplicateExceptionDefinition=1 +DuplicateFreezeDefinition=2 +ShowExceptionBox=1 +OkBtnText=&OK +DetailsBtnText=&Details +PleaseWaitTitle=Information +PleaseWaitText=Please wait a moment... +MailSubject=bug report +MailBody=please find the bug report attached +SendBoxTitle=Sending bug report... +PrepareAttachMsg=Preparing attachments... +MxLookupMsg=Searching for mail server... +ConnectMsg=Connecting to server... +AuthMsg=Authentication... +SendMailMsg=Sending mail... +FieldsMsg=Setting fields... +SendAttachMsg=Sending attachments... +SendFinalizeMsg=Finalizing... +MailFailureMsg=Sorry, sending the bug report didn't work. +VersionVariable= +MesVersion=4 +LinkInCode=1 +ReportLeaks=0 +WindowsLogo=0 +CrashOnBuffer=0 +CrashOnUnderrun=0 +SendHelper=196608 +HttpSsl=1 +UploadToFogBugz=0 +UploadToBugZilla=0 +UploadToMantis=0 +BugTrackerAccount= +BugTrackerPassword= +BugTrackerProject= +BugTrackerArea= +BugTrackerAssignTo= +SmtpSsl=0 +SmtpTls=0 +BugTrackerTitle=%25appname%25, %25exceptMsg%25 +BugTrackerDescr=error details: %0d%0a%25errorDetails%25 +[ExceptionBox] +ShowButtonMailBugReport=1 +ShowButtonSaveBugReport=1 +ShowButtonPrintBugReport=0 +ShowButtonShowBugReport=1 +ShowButtonContinueApplication=1 +ShowButtonRestartApplication=1 +ShowButtonCloseApplication=1 +IconButtonSendBugReport=send1 +IconButtonSaveBugReport=save1 +IconButtonPrintBugReport=print1 +IconButtonShowBugReport=show1 +IconButtonContinueApplication=continue1 +IconButtonCantContinueApplication=cantContinue1 +IconButtonRestartApplication=restart1 +IconButtonCloseApplication=close1 +FocusedButton=0 +SendAssistant=SendAssistant +SaveAssistant= +PrintAssistant=PrintAssistant +AutomaticallyShowBugReport=0 +NoOwnerDrawButtons=0 +BigExceptionIcon=big1 +TitleBar=%25appname%25 +ExceptionMessage=An error occurred in the application. +FrozenMessage=The application seems to be frozen. +BitFaultMsg=The file "%25modname%25" seems to be corrupt! +MailBugReportText=send bug report +SaveBugReportText=save bug report +PrintBugReportText=print bug report +ShowBugReportText=show bug report +ContinueApplicationText=continue application +RestartApplicationText=restart application +CloseApplicationText=close application +[BugReport] +ListThreads=0 +ListModules=0 +ListHardware=0 +ShowCpuRegisters=0 +ShowStackDump=0 +Disassembly=0 +HideUglyItems=0 +ShowRelativeAddrs=0 +ShowRelativeLines=1 +FormatDisassembly=0 +LimitDisassembly=5 +EnabledPlugins= +[Filters] +Filter1ExceptionClasses=EDBEditError +Filter1DontCreateBugReport=1 +Filter1DontCreateScreenshot=1 +Filter1DontSuspendThreads=1 +Filter1DontCallHandlers=1 +Filter1ShowBox=3 +Filter1Assis= +Filter2ExceptionClasses= +Filter2DontCreateBugReport=0 +Filter2DontCreateScreenshot=0 +Filter2DontSuspendThreads=0 +Filter2DontCallHandlers=0 +Filter2ShowBox=0 +Filter2Assis= +GeneralDontCreateBugReport=0 +GeneralDontCreateScreenshot=0 +GeneralDontSuspendThreads=0 +GeneralDontCallHandlers=0 +GeneralShowBox=0 +GeneralAssis= +[Assistants] +Assistant1=SendAssistant|Send Assistant|ContactForm|DetailsForm|ScrShotForm +Assistant2=SaveAssistant|Save Assistant|ContactForm|DetailsForm +Assistant3=PrintAssistant|Print Assistant|ContactForm|DetailsForm +Forms1=TPF0%0eTMEContactForm%0bContactForm%07Message%0c%13%00%00%00Contact Information%08MinWidth%04%00%00%00%00%08OnAction%0c%1b%00%00%00madExcept.HandleContactForm%05Timer%04%00%00%00%00%00%09INVButton%0bContinueBtn%07Caption%0c%08%00%00%00Continue%07Enabled%09%0bNoOwnerDraw%08%07Visible%09%00%00%09INVButton%07SkipBtn%07Caption%0c%04%00%00%00Skip%07Enabled%08%0bNoOwnerDraw%08%07Visible%09%00%00%09INVButton%09CancelBtn%07Caption%0c%06%00%00%00Cancel%07Enabled%09%0bNoOwnerDraw%08%07Visible%09%00%00%08INVLabel%06Label1%07Caption%0c%0a%00%00%00your name:%07Enabled%09%07Spacing%04%00%00%00%00%00%00%07INVEdit%08NameEdit%07Colored%09%07Enabled%09%05Lines%04%01%00%00%00%08Optional%09%0aOutputName%0c%0c%00%00%00contact name%0aOutputType%07%09nvoHeader%07Spacing%04%00%00%00%00%04Text%0c%00%00%00%00%05Valid%09%00%00%08INVLabel%06Label2%07Caption%0c%0b%00%00%00your email:%07Enabled%09%07Spacing%04%00%00%00%00%00%00%07INVEdit%09EmailEdit%07Colored%09%07Enabled%09%05Lines%04%01%00%00%00%08Optional%08%0aOutputName%0c%0d%00%00%00contact email%0aOutputType%07%09nvoHeader%07Spacing%04%00%00%00%00%04Text%0c%00%00%00%00%05Valid%09%00%00%0bINVCheckBox%08MemCheck%07Caption%0c%0b%00%00%00remember me%07Checked%08%07Enabled%09%0aOutputName%0c%00%00%00%00%07Spacing%04%00%00%00%00%00%00%00 +Forms2=TPF0%0eTMEDetailsForm%0bDetailsForm%07Message%0c%0d%00%00%00Error Details%08MinWidth%04%00%00%00%00%08OnAction%0c%00%00%00%00%05Timer%04%00%00%00%00%00%09INVButton%0bContinueBtn%07Caption%0c%08%00%00%00Continue%07Enabled%09%0bNoOwnerDraw%08%07Visible%09%00%00%09INVButton%07SkipBtn%07Caption%0c%04%00%00%00Skip%07Enabled%09%0bNoOwnerDraw%08%07Visible%09%00%00%09INVButton%09CancelBtn%07Caption%0c%06%00%00%00Cancel%07Enabled%09%0bNoOwnerDraw%08%07Visible%09%00%00%08INVLabel%06Label1%07Caption%0c'%00%00%00in which situation did the error occur?%07Enabled%09%07Spacing%04%00%00%00%00%00%00%07INVEdit%0bDetailsMemo%07Colored%09%07Enabled%09%05Lines%04%09%00%00%00%08Optional%08%0aOutputName%0c%0d%00%00%00error details%0aOutputType%07%0dnvoOwnSection%07Spacing%04%00%00%00%00%04Text%0c%00%00%00%00%05Valid%09%00%00%00 +Forms3=TPF0%0eTMEScrShotForm%0bScrShotForm%0dActiveControl%07%0bContinueBtn%07Message%0c%18%00%00%00Screenshot Configuration%08MinWidth%04%00%00%00%00%08OnAction%0c%1e%00%00%00madExcept.HandleScreenshotForm%05Timer%04%fa%00%00%00%00%09INVButton%0bContinueBtn%07Caption%0c%08%00%00%00Continue%07Enabled%09%0bNoOwnerDraw%08%07Visible%09%00%00%09INVButton%07SkipBtn%07Caption%0c%04%00%00%00Skip%07Enabled%08%0bNoOwnerDraw%08%07Visible%09%00%00%09INVButton%09CancelBtn%07Caption%0c%06%00%00%00Cancel%07Enabled%09%0bNoOwnerDraw%08%07Visible%09%00%00%0bINVCheckBox%0bAttachCheck%07Caption%0c%25%00%00%00attach a screenshot to the bug report%07Checked%09%07Enabled%09%0aOutputName%0c%00%00%00%00%07Spacing%04%00%00%00%00%00%00%08INVImage%0aScrShotImg%06Border%09%09Clickable%09%07Enabled%09%04File%0c%00%00%00%00%06Height%04%00%00%00%00%07Spacing%04%00%00%00%00%05Width%04%00%00%00%00%00%00%08INVLabel%06Label1%07Caption%0c%15%00%00%00(click to edit image)%07Enabled%09%07Spacing%04%00%00%00%00%00%00%00 diff --git a/readme.md b/readme.md index de6e34067..e996fd965 100644 --- a/readme.md +++ b/readme.md @@ -4,29 +4,49 @@ ![](https://img.shields.io/github/languages/code-size/HeidiSQL/HeidiSQL.svg?style=flat) # HeidiSQL -HeidiSQL is a graphical interface for managing [MariaDB](http://www.mariadb.org/) or [MySQL](http://www.mysql.com/) servers, [Microsoft SQL databases](http://www.microsoft.com/sql/), [PostgreSQL](http://www.postgresql.org/) or [SQLite](https://www.sqlite.org/). "Heidi" lets you browse and edit data, create and edit tables, views, procedures, triggers and scheduled events. Also, you can export structure and data, either to SQL file, clipboard or to other servers. Read about [features](https://www.heidisql.com/#featurelist) or see some [screenshots](https://www.heidisql.com/screenshots.php). +HeidiSQL is a graphical interface for managing [MariaDB](http://www.mariadb.org/) or [MySQL](http://www.mysql.com/) servers, [Microsoft SQL databases](http://www.microsoft.com/sql/), [PostgreSQL](http://www.postgresql.org/), [SQLite](https://www.sqlite.org/), [Interbase](https://www.embarcadero.com/de/products/interbase) or [Firebird](https://firebirdsql.org/). "Heidi" lets you browse and edit data, create and edit tables, views, procedures, triggers and scheduled events. Also, you can export structure and data, either to SQL file, clipboard or to other servers. Read about [features](https://www.heidisql.com/#featurelist) or see some [screenshots](https://www.heidisql.com/screenshots.php). -# Need help? +### Need help? Look at [the online help page](https://www.heidisql.com/help.php) to learn how to use HeidiSQL. The [forum](https://www.heidisql.com/forum.php) is meant to ask questions. The [issue tracker](https://github.com/HeidiSQL/HeidiSQL/issues) is the place to report bugs or request new features. -# Building -Delphi 10.4 is required for building HeidiSQL. Older Delphi versions will most likely fail; newer Delphi versions may work or fail. Unfortunately, Lazarus or one +### Building +For compiling on platforms other than Windows, look at the [`lazarus`](https://github.com/HeidiSQL/HeidiSQL/tree/lazarus) branch. + +Delphi 12.1 is required for building HeidiSQL for Windows. Older Delphi versions will most likely fail; newer Delphi versions may work or fail. Unfortunately, Lazarus or one of the other free compilers cannot currently compile HeidiSQL. Once Delphi is installed, you need to load the SynEdit project from the components folder. Build both run-time and design-time packages. Install the -design-time package. Do the same for the VirtualTree component project, and install madExcept. +design-time package. Do the same for the VirtualTree component project. + +Second you need install [madExcept](http://madshi.net/madCollection.exe). + +Third compile *.rc files: + +| folder | file | command | +| ------ | ------ | ------ | +|HeidiSQL/source/vcl-styles-utils |AwesomeFont.RC| brcc32 AwesomeFont.RC| +|HeidiSQL/res| icon.rc | cgrc icon.rc | +|HeidiSQL/res| icon-question.rc | brcc32 icon-question.rc | +|HeidiSQL/res| version.rc | brcc32 version.rc | +|HeidiSQL/res| manifest.rc | manifest.rc | +|HeidiSQL/res| styles.rc | brcc32 styles.rc | +|HeidiSQL/res| updater.rc | brcc32 updater.rc | +> if updater.rc and updater.exe are not exists. you can copy them from updater64.rc and updater64.exe. Afterwards, load the HeidiSQL project from the packages folder. -# Translation +### Translation If you'd like to contribute by translating HeidiSQL into your mother tongue, you need to register at -[Transifex](https://www.transifex.com/heidisql/heidisql/), and join an existing language or request a +[Transifex](https://explore.transifex.com/heidisql/heidisql/), and join an existing language or request a new one. -# Contributing to HeidiSQL +### Contributing to HeidiSQL * Pull requests will only be accepted for bugfixes. No new features please. * Please mention a ticket id in your pull request. If there is no ticket for that particular bug yet, go and create an issue request first, and fill out all fields of the issue template. * To become a developer member, ask Ansgar via email (see https://www.heidisql.com/imprint.php for email address) -# Icons8 copyright -Icons added in January 2019 into a TImageCollection component are copyright by [Icons8](https://icons8.com). Used with a special permission from Icons8 given to Ansgar for this project only. Do not copy them for anything else other than building HeidiSQL. +### Icons8 copyright +Icons added in January 2019 into a `TImageCollection` component are copyright by [Icons8](https://icons8.com). Used with a special permission from Icons8 given to Ansgar for this project only. Do not copy them for anything else other than building HeidiSQL. + +[![Embarcadero logo.](https://www.heidisql.com/images/made-with-delphi.png)](https://www.embarcadero.com/de/case-study/heidisql-case-study) + diff --git a/res/icons/js-96.png b/res/icons/js-96.png new file mode 100644 index 000000000..ac67e6e35 Binary files /dev/null and b/res/icons/js-96.png differ diff --git a/res/icons/key_vector.png b/res/icons/key_vector.png new file mode 100644 index 000000000..83ae5ab03 Binary files /dev/null and b/res/icons/key_vector.png differ diff --git a/res/icons/markdown-96.png b/res/icons/markdown-96.png new file mode 100644 index 000000000..4de669708 Binary files /dev/null and b/res/icons/markdown-96.png differ diff --git a/res/icons/php-100.png b/res/icons/php-100.png new file mode 100644 index 000000000..63d7783b0 Binary files /dev/null and b/res/icons/php-100.png differ diff --git a/res/icons/server-firebird.png b/res/icons/server-firebird.png new file mode 100644 index 000000000..ef6fb715f Binary files /dev/null and b/res/icons/server-firebird.png differ diff --git a/res/icons/server-interbase.png b/res/icons/server-interbase.png new file mode 100644 index 000000000..1f4ce62b8 Binary files /dev/null and b/res/icons/server-interbase.png differ diff --git a/res/icons/server-rds-mysql.png b/res/icons/server-rds-mysql.png new file mode 100644 index 000000000..6040183c1 Binary files /dev/null and b/res/icons/server-rds-mysql.png differ diff --git a/res/icons/sql-96.png b/res/icons/sql-96.png new file mode 100644 index 000000000..6acb7a69b Binary files /dev/null and b/res/icons/sql-96.png differ diff --git a/res/icons/table_column.png b/res/icons/table_column.png new file mode 100644 index 000000000..b2d11546a Binary files /dev/null and b/res/icons/table_column.png differ diff --git a/res/icons/table_column_add.png b/res/icons/table_column_add.png new file mode 100644 index 000000000..480ecd13c Binary files /dev/null and b/res/icons/table_column_add.png differ diff --git a/res/icons/table_column_delete.png b/res/icons/table_column_delete.png new file mode 100644 index 000000000..730ef89ee Binary files /dev/null and b/res/icons/table_column_delete.png differ diff --git a/res/icons/textile-lang.png b/res/icons/textile-lang.png new file mode 100644 index 000000000..17cd4583f Binary files /dev/null and b/res/icons/textile-lang.png differ diff --git a/res/installer-logo.bmp b/res/installer-logo.bmp index 515395020..eefb3b2cf 100644 Binary files a/res/installer-logo.bmp and b/res/installer-logo.bmp differ diff --git a/res/installer-small-logo.bmp b/res/installer-small-logo.bmp index dee6a3d5e..c5fc0705e 100644 Binary files a/res/installer-small-logo.bmp and b/res/installer-small-logo.bmp differ diff --git a/res/manifest.xml b/res/manifest.xml index 812631280..b315924c5 100644 --- a/res/manifest.xml +++ b/res/manifest.xml @@ -2,6 +2,13 @@ + + + true/pm + PerMonitorV2 + + + A lightweight, fast and flexible interface to MySQL @@ -42,4 +49,7 @@ + + + \ No newline at end of file diff --git a/res/styles.rc b/res/styles.rc index 287df5cae..907cfdf80 100644 --- a/res/styles.rc +++ b/res/styles.rc @@ -1,6 +1,7 @@ Amakrits VCLSTYLE "styles/Amakrits.vsf" Carbon VCLSTYLE "styles/Carbon.vsf" CharcoalDarkSlate VCLSTYLE "styles/CharcoalDarkSlate.vsf" +Glow VCLSTYLE "styles/Glow.vsf" Light VCLSTYLE "styles/Light.vsf" Material VCLSTYLE "styles/material.vsf" TurquoiseGray VCLSTYLE "styles/TurquoiseGray.vsf" diff --git a/res/styles/Amakrits.vsf b/res/styles/Amakrits.vsf index 59d0e3850..19f8c19b7 100644 Binary files a/res/styles/Amakrits.vsf and b/res/styles/Amakrits.vsf differ diff --git a/res/styles/Carbon.vsf b/res/styles/Carbon.vsf index f782c446c..c14dd4293 100644 Binary files a/res/styles/Carbon.vsf and b/res/styles/Carbon.vsf differ diff --git a/res/styles/CharcoalDarkSlate.vsf b/res/styles/CharcoalDarkSlate.vsf index 75a44b86d..91b6f301a 100644 Binary files a/res/styles/CharcoalDarkSlate.vsf and b/res/styles/CharcoalDarkSlate.vsf differ diff --git a/res/styles/Glow.vsf b/res/styles/Glow.vsf new file mode 100644 index 000000000..6acafc775 Binary files /dev/null and b/res/styles/Glow.vsf differ diff --git a/res/styles/Light.vsf b/res/styles/Light.vsf index 571864738..a29bbe070 100644 Binary files a/res/styles/Light.vsf and b/res/styles/Light.vsf differ diff --git a/res/styles/TurquoiseGray.vsf b/res/styles/TurquoiseGray.vsf index 0f76fe607..b4543d3a1 100644 Binary files a/res/styles/TurquoiseGray.vsf and b/res/styles/TurquoiseGray.vsf differ diff --git a/res/styles/Windows10.vsf b/res/styles/Windows10.vsf index fed4a4684..fb439e224 100644 Binary files a/res/styles/Windows10.vsf and b/res/styles/Windows10.vsf differ diff --git a/res/styles/Windows10Dark.vsf b/res/styles/Windows10Dark.vsf index ec2aee2d5..5bdc77a2c 100644 Binary files a/res/styles/Windows10Dark.vsf and b/res/styles/Windows10Dark.vsf differ diff --git a/res/styles/Windows10SlateGray.vsf b/res/styles/Windows10SlateGray.vsf index 5e0dbf248..e2599baf0 100644 Binary files a/res/styles/Windows10SlateGray.vsf and b/res/styles/Windows10SlateGray.vsf differ diff --git a/res/updater.rc b/res/updater.rc new file mode 100644 index 000000000..2d8509ce8 --- /dev/null +++ b/res/updater.rc @@ -0,0 +1 @@ +updater exe "updater\updater.exe" \ No newline at end of file diff --git a/res/updater/manifest.xml b/res/updater/manifest.xml index c60513894..450de06ec 100644 --- a/res/updater/manifest.xml +++ b/res/updater/manifest.xml @@ -6,7 +6,7 @@ processorArchitecture="*" name="HeidiSQL" type="win32" /> - A lightweight, fast and flexible interface to MySQL + HeidiSQL build updater diff --git a/res/updater/updater.dpr b/res/updater/updater.dpr index 4ed1165f3..9869cc2eb 100644 --- a/res/updater/updater.dpr +++ b/res/updater/updater.dpr @@ -1,93 +1,25 @@ program updater; -{ A window which terminates running HeidiSQL instances and moves the downloaded update file to - its desired directory. Avoids to use any VCL unit, to keep the executable small. } +{ A console window which terminates running HeidiSQL instances and moves the downloaded update file to + its desired directory. } + +{$APPTYPE CONSOLE} {$R manifest.RES} +// (un)comment the following resource inclusion to vary the binary size. Update checker trusts the same file size before overwriting the old one. +{$R ..\icon.RES} uses - Windows, Messages, Tlhelp32, psapi; + Winapi.Windows, Winapi.Messages, Winapi.TlHelp32, Winapi.PsAPI, Winapi.ShellAPI, System.SysUtils; var - WClass: TWndClass; BackupPath, AppPath, DownloadPath: String; - hAppHandle, HLabel: HWND; - AppMsg: TMsg; + RestartTaskName, RestartCmd, RestartParams: String; const AppName = 'HeidiSQL'; - WindowPadding = 10; - WindowWidth = 600; - WindowHeight = 80; QuitTimeout = 20000; // We long we're gracefully waiting for a window to be gone, in milliseconds - TerminatedCheck = 200; // Interval between checks if host application is gone - PathDelim = '\'; - - - -{ We don't include SysUtils unit, so we need to implement our own versions of some basic functions here } - -function FileExists(Filename: String): Boolean; -var - Find: THandle; - Data: TWin32FindData; -begin - Find := FindFirstFile(PChar(Filename), Data); - Result := Find <> INVALID_HANDLE_VALUE; -end; - -function IntToStr(Value: Int64): String; -var - Minus : Boolean; -begin - Result := ''; - if Value = 0 then - Result := '0'; - Minus := Value < 0; - if Minus then - Value := -Value; - while Value > 0 do begin - Result := Char((Value mod 10) + Integer('0')) + Result; - Value := Value div 10; - end; - if Minus then - Result := '-' + Result; -end; - -function ExtractFileName(const FileName: string): string; -var - i: Integer; -begin - for i:=Length(Filename) downto 0 do - if Filename[i] = PathDelim then - break; - Result := Copy(FileName, i+1, MaxInt); -end; - -function ExtractFilePath(const FileName: string): string; -var - i: Integer; -begin - for i:=Length(Filename) downto 0 do - if Filename[i] = PathDelim then - break; - Result := Copy(FileName, 1, i); -end; - - -function Trim(const S: string): string; -var - I, L: Integer; -begin - L := Length(S); - I := 1; - if (L > 0) and (S[I] > ' ') and (S[L] > ' ') then Exit(S); - while (I <= L) and (S[I] <= ' ') do Inc(I); - if I > L then Exit(''); - while S[L] <= ' ' do Dec(L); - Result := Copy(S, I, L - I + 1); -end; - + TerminatedCheck = 500; // Interval between checks if host application is gone function GetEXEFromHandle(const wnd: HWND) : string; var @@ -143,12 +75,14 @@ end; procedure Status(Text: String; IsError: Boolean=False); +const + SleepSecondsOnError: Integer=10; begin - // Display status message on label - SendMessage(HLabel, WM_SETTEXT, 1, Integer(PChar(Text)) ); - UpdateWindow(hLabel); + // Display status message + WriteLn(Text); if IsError then begin - Sleep(4000); + Writeln('Exiting in '+SleepSecondsOnError.ToString+' seconds...'); + Sleep(SleepSecondsOnError * 1000); Halt(1); end; end; @@ -163,7 +97,7 @@ begin // EnumWindows will stop processing if we return false Result := True; WndPath := GetEXEFromHandle(Wnd); - if (WndPath <> AppPath) and (WndPath <> ExtractFilename(AppPath)) then + if LowerCase(ExtractFilename(WndPath)) <> LowerCase(ExtractFilename(AppPath)) then Exit; SetLength(WndTitle, 256); @@ -172,7 +106,7 @@ begin GetWindowText(Wnd, PChar(WndTitle), 256); WndTitle := Trim(WndTitle); - Hint := 'Closing "'+WndTitle+'"'; + Hint := 'Closing "'+WndTitle+'", path: "' + WndPath + '"'; Status(Hint); WaitTime := 0; PostMessage(Wnd, WM_CLOSE, 0, 0); @@ -190,149 +124,59 @@ begin end; end; - -// Callback function for Timer -procedure FormShow(wnd: HWND; uMsg: UINT; idEvent: UINT; dwTime: DWORD); stdcall; -var - SUInfo: TStartupInfo; - ProcInfo: TProcessInformation; -begin - KillTimer(hAppHandle, 0); - AppPath := Paramstr(1); - DownloadPath := ParamStr(2); - - // Paremeter syntax check - if (AppPath = '') or (DownloadPath = '') then begin - Status('Syntax: '+ExtractFilename(Paramstr(0))+' OldFile.exe NewFile.exe'+#13#10+ - 'Please don''t execute this file directly.', True); - end; - if (not FileExists(AppPath)) or (not FileExists(DownloadPath)) then - Status('Error: Either target file "'+AppPath+'" or download file "'+DownloadPath+'" does not exist.', True); - - // Terminate running instances - Status('Close running '+AppName+' instances ...'); - EnumWindows(@EnumAllInstances, 0); - - // Backup old .exe to working directory - Status('Creating backup of old file ...'); - BackupPath := ExtractFilepath(Paramstr(0))+ExtractFilename(AppPath)+'.backup.exe'; - if FileExists(BackupPath) then - DeleteFile(PChar(BackupPath)); - if not MoveFile(PChar(AppPath), PChar(BackupPath)) then - Status('Failed to create backup file "'+BackupPath+'" from "'+AppPath+'"', True) - else - Status('Success.'); - - // Move update file to final path - Status('Moving downloaded file to desired directory ...'); - if not MoveFile(PChar(DownloadPath), PChar(AppPath)) then - Status('Failed to move file "'+DownloadPath+'" to "'+AppPath+'"', True) - else begin - Status('Success. Restarting '+AppName+' now ...'); - FillChar(SUInfo, SizeOf(SUInfo), #0); - SUInfo.cb := SizeOf(SUInfo); - SUInfo.dwFlags := STARTF_USESHOWWINDOW; - SUInfo.wShowWindow := SW_SHOWNORMAL; - CreateProcess( - nil, - PChar(AppPath), - nil, - nil, - False, - CREATE_NEW_CONSOLE or NORMAL_PRIORITY_CLASS, - nil, - PChar(ExtractFilePath(AppPath)), - SUInfo, - ProcInfo - ); - end; - PostQuitMessage(0); -end; - - -function WindowProc(hWnd, msg, wpr, lpr: Longint): Longint; stdcall; -var - x, y: integer; - Font: HFont; +// Main program code begin - // Custom window procedure - case msg of - - WM_CREATE: begin - // Center window - x := GetSystemMetrics(SM_CXSCREEN); - y := GetSystemMetrics(SM_CYSCREEN); - MoveWindow(hWnd, - (x div 2) - (WindowWidth div 2), - (y div 2) - (WindowHeight div 2), - WindowWidth, - WindowHeight, - true); - // Create status label - HLabel := CreateWindow( - 'STATIC', // Class name - 'Status:', // Label's text - WS_VISIBLE or WS_CHILD or SS_LEFT, // Styles - WindowPadding, // X pos - WindowPadding, // Y pos - WindowWidth - 2*WindowPadding, // Width - WindowHeight - 2*WindowPadding, // Height - hWnd, // Parent hwnd - 0, // ID - hAppHandle, // HInstance of program - nil // Params for main window - ); - // Cosmetics - Font := Createfont(-11, 0, 0, 0, 0, 0, 0, 0, ANSI_CHARSET, OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY, DEFAULT_PITCH, 'Tahoma'); - SendMessage(HLabel, WM_SETFONT, Font, 1); - SetBkColor(hwnd, COLOR_BTNFACE+1); + try + AppPath := Paramstr(1); + DownloadPath := ParamStr(2); + RestartTaskName := ParamStr(3); + + // Parameter syntax check + if (AppPath = '') or (DownloadPath = '') or (RestartTaskName = '') then begin + Status('Syntax: '+ExtractFilename(Paramstr(0))+' OldFile.exe NewFile.exe RestartTaskName'); + Status('Please don''t execute this file directly.', True); end; - WM_SHOWWINDOW: SetTimer(hAppHandle, 0, 200, @FormShow); - - WM_DESTROY: PostQuitMessage(0); - - end; - - Result := DefWindowProc(hWnd, msg, wpr, lpr); -end; - - - -// Main program goes here -begin - // Define window class - WClass.hInstance := hInstance; - WClass.style := CS_HREDRAW or CS_VREDRAW; - WClass.hIcon := LoadIcon(hInstance, IDI_WINLOGO); - WClass.lpfnWndProc := @WindowProc; - WClass.hbrBackground := COLOR_BTNFACE+1; - WClass.lpszClassName := 'WndClass'; - WClass.hCursor := LoadCursor(0, IDC_ARROW); - WClass.cbClsExtra := 0; - WClass.cbWndExtra := 0; - WClass.lpszMenuName := ''; - RegisterClass(WClass); + Status('AppPath: "'+AppPath+'"'); + Status('DownloadPath: "'+DownloadPath+'"'); + if not FileExists(AppPath) then + Status('Error: target file "'+AppPath+'" does not exist.', True); + if not FileExists(DownloadPath) then + Status('Error: downloaded file "'+DownloadPath+'" does not exist.', True); + + // Terminate running instances + Status('Close running '+AppName+' instances ...'); + EnumWindows(@EnumAllInstances, 0); + + // Backup old .exe to working directory + Status('Creating backup of old file ...'); + BackupPath := ExtractFilepath(Paramstr(0))+ExtractFilename(AppPath)+'.backup.exe'; + if FileExists(BackupPath) then + DeleteFile(PChar(BackupPath)); + if not CopyFile(PChar(AppPath), PChar(BackupPath), False) then + Status('Failed to create backup file "'+BackupPath+'" from "'+AppPath+'"', True) + else begin + DeleteFile(PChar(AppPath)); + Status('Success.'); + end; - // Create form - hAppHandle := CreateWindow( - WClass.lpszClassName, - AppName+' Updater', - WS_POPUPWINDOW or WS_CAPTION or WS_VISIBLE, - 100, // Default x + y coordinates, will be centered in WM_CREATE - 100, - WindowWidth, - WindowHeight, - 0, - 0, - hInstance, - nil - ); + // Move update file to final path + Status('Moving downloaded file to desired directory ...'); + // Issue #1616: MoveFile() does not work when target directory is a symlink, so we prefer CopyFile + DeleteFile + if not CopyFile(PChar(DownloadPath), PChar(AppPath), False) then + Status('Failed to copy file "'+DownloadPath+'" to "'+AppPath+'"', True) + else begin + DeleteFile(PChar(DownloadPath)); + Status('Success. Restarting '+AppName+' through task "'+RestartTaskName+'" now ...'); + RestartCmd := 'schtasks'; + RestartParams := '/Run /TN "' + RestartTaskName + '"'; + ShellExecute(0, 'open', PChar(RestartCmd), PChar(RestartParams), '', SW_HIDE); + end; - // Message loop - while GetMessage(AppMsg, 0, 0, 0) do begin - TranslateMessage(AppMsg); - DispatchMessage(AppMsg); + Status('Exiting in 10 seconds...'); + Sleep(10000); + except + on E: Exception do + Status(E.ClassName + ': ' + E.Message, True); end; - ExitCode := AppMsg.wParam; end. diff --git a/res/updater/updater.dproj b/res/updater/updater.dproj index 3e68e59fc..12a659e02 100644 --- a/res/updater/updater.dproj +++ b/res/updater/updater.dproj @@ -1,15 +1,14 @@  - {24E2AAD6-CDE7-46EC-95BD-79028373B17A} - 15.2 - updater.dpr - Debug - DCC32 - True - Console + {C28BA881-C743-44B2-B6E9-C2E111A6A9A4} + 19.5 None + True + Release Win64 - 3 + 2 + Console + updater.dpr true @@ -24,114 +23,981 @@ Base true - + true Base true - + + true + Cfg_1 + true + true + + + true + Cfg_1 + true + true + + true Base true + + true + Cfg_2 + true + true + - 1031 - CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= - System;Xml;Data;Datasnap;Web;Soap;Winapi;$(DCC_Namespace) - ..\ - vcl;rtl;vclx;vclimg;vclactnband;dbrtl;vcldb;vcldbx;bdertl;vcltouch;xmlrtl;dsnap;dsnapcon;TeeUI;TeeDB;Tee;vclib;ibxpress;adortl;IndyCore;IndySystem;IndyProtocols;inet;intrawebdb_100_140;Intraweb_100_140;VclSmp;vclie;websnap;webdsnap;inetdb;inetdbbde;inetdbxpress;soaprtl;vclribbon;dbexpress;DbxCommonDriver;DataSnapIndy10ServerTransport;DataSnapProviderClient;DbxClientDriver;DataSnapServer;DBXInterBaseDriver;DBXMySQLDriver;dbxcds;DBXFirebirdDriver;DBXSybaseASEDriver;DBXSybaseASADriver;DBXOracleDriver;DBXMSSQLDriver;DBXInformixDriver;DBXDb2Driver;madBasic_;madDisAsm_;madExcept_;SynEditR;VirtualTreesR;$(DCC_UsePackage) - ..\updater.exe - 00400000 - x86 + .\$(Platform)\$(Config) + false false false - false - false false + false + System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace) + updater + 1031 + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProgramID=com.embarcadero.$(MSBuildProjectName);ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments= + .\ - System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + vclwinx;DataSnapServer;fmx;emshosting;vclie;DbxCommonDriver;bindengine;IndyIPCommon;VCLRESTComponents;DBXMSSQLDriver;FireDACCommonODBC;emsclient;FireDACCommonDriver;appanalytics;IndyProtocols;vclx;IndyIPClient;dbxcds;vcledge;bindcompvclwinx;emsedge;bindcompfmx;DBXFirebirdDriver;SynEdit_R;madBasic_;inetdb;ibmonitor;FireDACSqliteDriver;DbxClientDriver;FireDACASADriver;soapmidas;vclactnband;fmxFireDAC;dbexpress;FireDACInfxDriver;DBXMySQLDriver;VclSmp;inet;DataSnapCommon;vcltouch;fmxase;DBXOdbcDriver;dbrtl;FireDACDBXDriver;FireDACOracleDriver;fmxdae;FireDACMSAccDriver;CustomIPTransport;FireDACMSSQLDriver;DataSnapIndy10ServerTransport;DataSnapConnectors;vcldsnap;DBXInterBaseDriver;madExcept_;FireDACMongoDBDriver;IndySystem;FireDACTDataDriver;vcldb;ibxbindings;VirtualTreesR;vclFireDAC;madDisAsm_;bindcomp;FireDACCommon;DataSnapServerMidas;FireDACODBCDriver;emsserverresource;IndyCore;RESTBackendComponents;bindcompdbx;rtl;FireDACMySQLDriver;FireDACADSDriver;RESTComponents;DBXSqliteDriver;vcl;IndyIPServer;dsnapxml;dsnapcon;DataSnapClient;DataSnapProviderClient;adortl;DBXSybaseASEDriver;DBXDb2Driver;vclimg;DataSnapFireDAC;emsclientfiredac;FireDACPgDriver;FireDAC;FireDACDSDriver;inetdbxpress;xmlrtl;tethering;ibxpress;bindcompvcl;dsnap;CloudService;DBXSybaseASADriver;DBXOracleDriver;FireDACDb2Driver;DBXInformixDriver;vclib;fmxobj;bindcompvclsmp;DataSnapNativeClient;DatasnapConnectorsFreePascal;soaprtl;soapserver;FireDACIBDriver;$(DCC_UsePackage) + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + Debug + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProgramID=com.embarcadero.$(MSBuildProjectName);ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments= 1033 + true + $(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_44.png + $(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_150.png - System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;$(DCC_Namespace) + vclwinx;DataSnapServer;fmx;emshosting;vclie;DbxCommonDriver;bindengine;IndyIPCommon;VCLRESTComponents;DBXMSSQLDriver;FireDACCommonODBC;emsclient;FireDACCommonDriver;appanalytics;IndyProtocols;vclx;IndyIPClient;dbxcds;vcledge;bindcompvclwinx;emsedge;bindcompfmx;DBXFirebirdDriver;SynEdit_R;inetdb;ibmonitor;FireDACSqliteDriver;DbxClientDriver;FireDACASADriver;soapmidas;vclactnband;fmxFireDAC;dbexpress;FireDACInfxDriver;DBXMySQLDriver;VclSmp;inet;DataSnapCommon;vcltouch;fmxase;DBXOdbcDriver;dbrtl;FireDACDBXDriver;FireDACOracleDriver;fmxdae;FireDACMSAccDriver;CustomIPTransport;FireDACMSSQLDriver;DataSnapIndy10ServerTransport;DataSnapConnectors;vcldsnap;DBXInterBaseDriver;FireDACMongoDBDriver;IndySystem;FireDACTDataDriver;vcldb;ibxbindings;VirtualTreesR;vclFireDAC;bindcomp;FireDACCommon;DataSnapServerMidas;FireDACODBCDriver;emsserverresource;IndyCore;RESTBackendComponents;bindcompdbx;rtl;FireDACMySQLDriver;FireDACADSDriver;RESTComponents;DBXSqliteDriver;vcl;IndyIPServer;dsnapxml;dsnapcon;DataSnapClient;DataSnapProviderClient;adortl;DBXSybaseASEDriver;DBXDb2Driver;vclimg;DataSnapFireDAC;emsclientfiredac;FireDACPgDriver;FireDAC;FireDACDSDriver;inetdbxpress;xmlrtl;tethering;ibxpress;bindcompvcl;dsnap;CloudService;DBXSybaseASADriver;DBXOracleDriver;FireDACDb2Driver;DBXInformixDriver;vclib;fmxobj;bindcompvclsmp;DataSnapNativeClient;DatasnapConnectorsFreePascal;soaprtl;soapserver;FireDACIBDriver;$(DCC_UsePackage) + true + $(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_44.png + $(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_150.png + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;$(DCC_Namespace) + Debug 1033 + (None) + none + DEBUG;$(DCC_Define) + true + false + true + true + true + true + true + + + false + + + 1033 + + false RELEASE;$(DCC_Define) 0 0 - - DEBUG;$(DCC_Define) + + 1033 MainSource - - Cfg_2 - Base - Base - + Cfg_1 Base + + Cfg_2 + Base + - Delphi.Personality.12 - + Application updater.dpr - - - False - False - 1 - 0 - 0 - 0 - False - False - False - False - False - 1031 - 1252 - - - - - 1.0.0.0 - - - - - - 1.0.0.0 - - - File D:\heidisql\trunk\components\pngcomponents\build\PngComponentsD.bpl not found - Microsoft Office 2000 Sample Automation Server Wrapper Components - Microsoft Office XP Sample Automation Server Wrapper Components + Microsoft Office 2000 Sample Automation Server Wrapper Components + Microsoft Office XP Sample Automation Server Wrapper Components + + + + true + + + + + true + + + + + true + + + + + updater.exe + true + + + + + updater.rsm + true + + + + + 1 + + + Contents\MacOS + 1 + + + 0 + + + + + classes + 64 + + + classes + 64 + + + + + res\xml + 1 + + + res\xml + 1 + + + + + library\lib\armeabi-v7a + 1 + + + + + library\lib\armeabi + 1 + + + library\lib\armeabi + 1 + + + + + library\lib\armeabi-v7a + 1 + + + + + library\lib\mips + 1 + + + library\lib\mips + 1 + + + + + library\lib\armeabi-v7a + 1 + + + library\lib\arm64-v8a + 1 + + + + + library\lib\armeabi-v7a + 1 + + + + + res\drawable + 1 + + + res\drawable + 1 + + + + + res\values + 1 + + + res\values + 1 + + + + + res\values-v21 + 1 + + + res\values-v21 + 1 + + + + + res\values + 1 + + + res\values + 1 + + + + + res\drawable + 1 + + + res\drawable + 1 + + + + + res\drawable-xxhdpi + 1 + + + res\drawable-xxhdpi + 1 + + + + + res\drawable-xxxhdpi + 1 + + + res\drawable-xxxhdpi + 1 + + + + + res\drawable-ldpi + 1 + + + res\drawable-ldpi + 1 + + + + + res\drawable-mdpi + 1 + + + res\drawable-mdpi + 1 + + + + + res\drawable-hdpi + 1 + + + res\drawable-hdpi + 1 + + + + + res\drawable-xhdpi + 1 + + + res\drawable-xhdpi + 1 + + + + + res\drawable-mdpi + 1 + + + res\drawable-mdpi + 1 + + + + + res\drawable-hdpi + 1 + + + res\drawable-hdpi + 1 + + + + + res\drawable-xhdpi + 1 + + + res\drawable-xhdpi + 1 + + + + + res\drawable-xxhdpi + 1 + + + res\drawable-xxhdpi + 1 + + + + + res\drawable-xxxhdpi + 1 + + + res\drawable-xxxhdpi + 1 + + + + + res\drawable-small + 1 + + + res\drawable-small + 1 + + + + + res\drawable-normal + 1 + + + res\drawable-normal + 1 + + + + + res\drawable-large + 1 + + + res\drawable-large + 1 + + + + + res\drawable-xlarge + 1 + + + res\drawable-xlarge + 1 + + + + + res\values + 1 + + + res\values + 1 + + + + + 1 + + + Contents\MacOS + 1 + + + 0 + + + + + Contents\MacOS + 1 + .framework + + + Contents\MacOS + 1 + .framework + + + Contents\MacOS + 1 + .framework + + + 0 + + + + + 1 + .dylib + + + 1 + .dylib + + + 1 + .dylib + + + Contents\MacOS + 1 + .dylib + + + Contents\MacOS + 1 + .dylib + + + Contents\MacOS + 1 + .dylib + + + 0 + .dll;.bpl + + + + + 1 + .dylib + + + 1 + .dylib + + + 1 + .dylib + + + Contents\MacOS + 1 + .dylib + + + Contents\MacOS + 1 + .dylib + + + Contents\MacOS + 1 + .dylib + + + 0 + .bpl + + + + + 0 + + + 0 + + + 0 + + + 0 + + + 0 + + + Contents\Resources\StartUp\ + 0 + + + Contents\Resources\StartUp\ + 0 + + + Contents\Resources\StartUp\ + 0 + + + 0 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + 1 + + + 1 + + + + + ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF + 1 + + + ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF + 1 + + + ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF + 1 + + + + + ..\ + 1 + + + ..\ + 1 + + + ..\ + 1 + + + + + 1 + + + 1 + + + 1 + + + + + ..\$(PROJECTNAME).launchscreen + 64 + + + ..\$(PROJECTNAME).launchscreen + 64 + + + + + 1 + + + 1 + + + 1 + + + + + ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF + 1 + + + ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF + 1 + + + + + ..\ + 1 + + + ..\ + 1 + + + ..\ + 1 + + + + + Contents + 1 + + + Contents + 1 + + + Contents + 1 + + + + + Contents\Resources + 1 + + + Contents\Resources + 1 + + + Contents\Resources + 1 + + + + + library\lib\armeabi-v7a + 1 + + + library\lib\arm64-v8a + 1 + + + 1 + + + 1 + + + 1 + + + 1 + + + Contents\MacOS + 1 + + + Contents\MacOS + 1 + + + Contents\MacOS + 1 + + + 0 + + + + + library\lib\armeabi-v7a + 1 + + + + + 1 + + + 1 + + + + + Assets + 1 + + + Assets + 1 + + + + + Assets + 1 + + + Assets + 1 + + + + + + + + + + + + + + - False - True + False True 12 + + diff --git a/res/updater/updater.exe b/res/updater/updater.exe new file mode 100644 index 000000000..276dd3999 Binary files /dev/null and b/res/updater/updater.exe differ diff --git a/res/updater32.exe b/res/updater32.exe deleted file mode 100644 index 6a1b31b2d..000000000 Binary files a/res/updater32.exe and /dev/null differ diff --git a/res/updater32.rc b/res/updater32.rc deleted file mode 100644 index 44bc75941..000000000 --- a/res/updater32.rc +++ /dev/null @@ -1 +0,0 @@ -updater exe "updater32.exe" \ No newline at end of file diff --git a/res/updater64.exe b/res/updater64.exe deleted file mode 100644 index 0a4d41309..000000000 Binary files a/res/updater64.exe and /dev/null differ diff --git a/res/updater64.rc b/res/updater64.rc deleted file mode 100644 index bbe3b01ec..000000000 --- a/res/updater64.rc +++ /dev/null @@ -1 +0,0 @@ -updater exe "updater64.exe" \ No newline at end of file diff --git a/res/version.rc b/res/version.rc index 0226842b5..5a537ff9f 100644 --- a/res/version.rc +++ b/res/version.rc @@ -1,5 +1,5 @@ 1 VERSIONINFO - FILEVERSION 11,0,0,0 + FILEVERSION 12,21,0,0 FILEOS VOS__WINDOWS32 FILETYPE VFT_APP BEGIN @@ -9,7 +9,7 @@ BEGIN VALUE "FileDescription", "%APPNAME% %APPVER%\000" VALUE "ProductName", "%APPNAME%\000" - VALUE "LegalCopyright", "See GPL license\000" + VALUE "LegalCopyright", "Ansgar Becker, see gpl.txt\000" END END BLOCK "VarFileInfo" diff --git a/source/Cromis.DirectoryWatch.pas b/source/Cromis.DirectoryWatch.pas index 516a08f12..5e82ae393 100644 --- a/source/Cromis.DirectoryWatch.pas +++ b/source/Cromis.DirectoryWatch.pas @@ -257,6 +257,7 @@ procedure TDirWatchThread.Execute; begin ErrorMessage := SysErrorMessage(ERROR_NOTIFY_ENUM_DIR); SignalError(ErrorMessage, ERROR_NOTIFY_ENUM_DIR); + Terminate; end; repeat @@ -276,6 +277,7 @@ procedure TDirWatchThread.Execute; begin ErrorMessage := SysErrorMessage(GetLastError); SignalError(ErrorMessage); + Terminate; end; end; end @@ -283,12 +285,14 @@ procedure TDirWatchThread.Execute; begin ErrorMessage := SysErrorMessage(GetLastError); SignalError(ErrorMessage); + Terminate; end; except on E :Exception do begin ErrorMessage := E.Message; SignalError(ErrorMessage); + Terminate; end; end; end; diff --git a/source/Sequal.Suggest.dfm b/source/Sequal.Suggest.dfm new file mode 100644 index 000000000..9db28cdca --- /dev/null +++ b/source/Sequal.Suggest.dfm @@ -0,0 +1,224 @@ +object SequalSuggestForm: TSequalSuggestForm + Left = 0 + Top = 0 + Caption = 'SequalSuggestForm' + ClientHeight = 361 + ClientWidth = 484 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -12 + Font.Name = 'Segoe UI' + Font.Style = [] + Position = poOwnerFormCenter + OnClose = FormClose + OnCreate = FormCreate + OnShow = FormShow + DesignSize = ( + 484 + 361) + TextHeight = 15 + object imgSequalLogo: TImage + Left = 8 + Top = 328 + Width = 90 + Height = 25 + Cursor = crHandPoint + Hint = 'https://sequal.dev/' + Anchors = [akLeft, akBottom] + Picture.Data = { + 0954506E67496D61676589504E470D0A1A0A0000000D494844520000005A0000 + 00190806000000B16439C0000000017352474200AECE1CE90000000467414D41 + 0000B18F0BFC6105000000097048597300000EC300000EC301C76FA864000009 + B24944415478DAED980B5094D71580775960792D8BB0A202BEAA5551A4152546 + 69699D248A48126C498C89557CA68D54273144D2888DC4884D529BD64E9292D2 + 181363EA23A6254A2198061A47298528A22286C1CAF09087BC9F02DBEFC2FD37 + BF2B558648653ADC993BFBEFDD7BCE3DE73BE79E7BFFD56A86DAFFA469EFB601 + 83BD8D1B372EB2BABAFA41F16C6B6B7BA4A6A6E6FDFEE819027D9B3672E4C8B7 + CBCBCBD788673B3BBBDDD7AF5FDFD01F3D43A06FD300FD06A07F269E01BD0BD0 + 9BFAA36708F46DDA80811E3B76ECB8FAFAFAD9CDCDCDDE3A9D4EE3E0E050EAEC + EC7CAAB8B8F8F2AD148D183162727B7BFB9C969616935EAF6F4236372222222B + 2121A1FD56721E1E1E414D4D4D336C6C6CEC0D06C3B9AB57AFA6C4C5C5D9C6C7 + C707A3CB9E296DF413F4F63367CE6867CF9E3DA7B5B5D595F962CDECB2B2B24A + 2B9513E9DF96CF85F402EB35BDBCBC46E1DF9CB6B6B6B15A1A3E96D8DBDB6702 + F4261FFB0BBA3A628FB7C646DBE0716045FD0DA0E7CF9FEF989E9EFE724747C7 + DAAEAE2E17B3D9DC1309AD5683534D8E8E8E6F6ED9B2E5F99898980EB5C2F1E3 + C7BB959494FC1AB965C8D92BE3020486E512A40DD7AE5D4BB736047D3E9D9D9D + 7F42EE01E42C3204E8A3A0A0A05F6466666601DAC0701D7D12BD02D03A409F05 + B4AF04FD10A093AC546FA7BF209F77D12D6056AF5E6DBB6FDFBE5F022B8A35DD + AC7D04F85E4F4FCF4D4545452DDF0474D5C284683EB6D14B21FCA8E9D8BA1C0B + 6816791707962B0BE370218B77A178220689C00B38BBC804CB42A3478F369496 + 96FE0D60731550F472E63B33669063AD6E6E6E0B81FDB92AFB8D9595951938EB + AF8CA1BF8D6ECB988EF929D812487717C9419FAA02FD25E3D325E830401FB5F2 + 338E1E2B9F5FA347AB7C4C447695CAC7521E31B573B4029D39EF33E727FD055D + FD50A287B9BD43EC24A374EC0353F2BA27B4D2F1E9387E0627B522B26CE127C2 + C2C292030303BB76EEDC195255557590CC73C0B076223E05E78A6456BE4ED66D + 94469C462ECAC7C7278F60182835EBD99A31E237B6E5B979F3E6CD4A49496915 + DF9D9C9C763267B374B893EF2FA27B3FFAF4757575AB917B46715C82F6A557F6 + 11B4C8A4ADD6A0B1EB7EE67E0A5411FC06D65C191010904A503BD8C93F6A6868 + 7807FFED845E7777F719F87CBA3FA06B567FE8D059569FA9E932F724918DF605 + 327A87562A5B545151F189D8C240C9A7D6FAAA85870F1F1E06504FEE91C53897 + 79F1E2C57A5F5F5F9F4B972EE511002390AAA87B01C02D56CB51AB0F022D4264 + 0F8E2DA2161F0394212727270F83C748E82F017DAB5A0EE07B586FC59D043D71 + E2442F7C9C85BD93B0F73C608F59D99A8EADC172FDC7597F7F7F40CBAC9E6CBE + DEB15EA3B329B6313AFECE7DDFB2B69B325A96883D2E2E2E8946A3311F9855BD + 29E3108BA01C1C14994770FE02B0C76A6B6B1DE5CF426F33C6AFC0F8B724D05F + 0134861D1140B6FC4BAC85C3CDDEDEDE7E57AE5C2952EB36994C41E8FE42D6EE + 3B02BAB7E6EFEF6F601D23764DE102904810C6C89F44097DAFBFA07B6B961A0D + DC778862A4F25DD6DB4A7A010B9C00D4018291ADFC4E2D7B16875F955F9BE90D + 428C6E56E9D76B64AD62FE7EE63F4EF04271EAA808107A0B2951D38F1C39D2A2 + 368AECF3B97CF9F2791C37DC49D0AB56ADB23B7CF8F0C3C82F62FD69047214DD + 9D672759AACC92C9C0810E0909B1CFC8C8D88CA235D4B131CA4D4005DE4C0DDE + 410DDD228744FD8DEF56429DE5F70ECDCDD7456178A78823FD5DF4AE04781859 + 9E241C43EEECA4499366508A3AD5429C0D5E403D4F0933DE0A3410C2388CFB04 + 9AF2E7CE8E3B44F0E659DD361AE9F98C7B323EF019ADB4B973E73A512EFC8131 + 13A5B3E8F761C468095BE3EAEA1A82C1295CDBA2A8B9BBC53825E200D7BC8DD4 + 3D27CDD719AD9590B1DFACE3B31128951C34C1353535E9C2594A47D9840913A6 + 161414D4AA6D107772764FAEBC2E5A409F3A754AC7A1FA253B6FBA8084AED0EA + EAEA64B52C656C07017ADE1A34A5F08DC6C6C66E609C359709F8ABE2EE3C6CD8 + B0B2C2C24271FB38407F6440412F58B0C0961705478C36723A5F3B79F264B332 + 813AE6969F9F9F86F133C57740BFC2D6DFCCE7F7019B214B401606DC63AD7CF1 + E2C576172E5C30646767D71298EE2D326AD4A831AC950744838085A321D4C914 + B51C63510473B7CC3C0B6871CDA4C46591D1DDB650CE9EA2BEBEA99605E0DFF9 + FD876AD0B1B1B13A5E804E93307E624D6E1ADF23D827D472EAC370C040032D1A + 839FC3111716FC33CF9156C6A761FC7D72EE5640BFC416D6033007E3A7CA03F4 + E7C8FD5E9191500E60D80232B71628CF88AD2BB3EE530277BF74F0B49F9FDF42 + 74952BD94CC03F43AF975465012DE777DF6494CCA49C3D08B43C6ABDE3F1E3C7 + A3C9F66D2AD3BB41878787DB262525E552BA7CB1D5CC417E8F389095492269C8 + F634D50BD78081160B891788EEBA05D8839489249E75287E18C7C2C53CC6DA31 + 7216DBFAACF84E663C06F4FD8A1C003F66F873F1568B53E1C8DE2BE601BA869B + C477C9E42BE23B5BFE01A0A72AE700C0AE88608A7B2C010D63C8D9DCD3F4D6A0 + 29014B28591F2A7556D458D6CBA38F64CD71AC75892029AFE096D241A045023D + 2A81E5A1E737C85E253001ACB9097D46D5DDFD1B81AE0AF943281F62AD76AE78 + F1A6A36B8B2C359ACC88C68157AC0F41A509C818FB2401D9A31EE716B199B178 + 9CECF50F2A71C746F752C0A6A9C709522C418AEBE5D015017B0AE75FE4ABA735 + 6865A7F07B442F6B1DE2F753E87C4D0EBD4E7F5A3C708DFC0E81163BC5DD9265 + 24873C2B7208761909B548FEB492BE47824E00F45A09BA4F7F93568526ECE285 + E56991C65A3BDD648FBFAE29B8010E77DC1F00FBA7280BC000770CEEC2F12AFA + 3FC47F1DC03AD39B624EF4D9C05E0FEC7B11198603E2067215C33E2310BFE50A + F6EFDEE4D81D61ACB70199690220EB7C452DDF26D661EC2B4DCFD5F006D0A205 + 0505D97103D9889D4B58D3035075ACF53137A2389E4398F29C9CBA8FFE47458E + 5D358DF562919B837E67E636B0661A7EC760E323046189A6E7307F997E5C828E + 02F48F25E80F907DBB0FA0DF03F4324017699DF57E1E87229B7BCDC2E5CB97EB + 7373730D386C0E0E0EAEDBBB776FC7ED948BB674E9523D6F7D0660756EDFBEBD + 2E3434B4AB2F72DC248C044A9B9595A5DC3EBCE9E7E9AEBD8156375EA39DA8EF + AD04B74F6B893673E64C97929212470EFAE6D4D4D4A6BECAF5B5552D4CF882AD + 12C496F9C894BCAE3B4883F5FF6801FA9CE6BF64F4606ED5E18946735BC779F6 + 8597C646BBC6746C5DA2181F027D871B652390B2F14F8D785BB6B59962FA646D + F7FF3F8315B48FA6E74F7B71DD125BFB5BF48ABB6D545F1AA09702FA2DC81E31 + 253F19A98C0F4AD0DC52C4CD40FC8F22FEEB1075FB595E8EEAEFB65D7D695CED + 1C3422416C6D5AC8E6EBCAF8A004FDFFD8FE03833BE76573FF7FB80000000049 + 454E44AE426082} + OnClick = imgSequalLogoClick + end + object lblRecentPrompts: TLabel + Left = 8 + Top = 11 + Width = 87 + Height = 15 + Caption = 'Recent prompts:' + end + object memoPrompt: TMemo + Left = 8 + Top = 37 + Width = 468 + Height = 84 + Anchors = [akLeft, akTop, akRight] + EditMargins.Auto = True + Lines.Strings = ( + 'Give me column a, b and c from table foobar') + ScrollBars = ssBoth + TabOrder = 0 + WantTabs = True + WordWrap = False + end + object btnGenerateSQL: TButton + Left = 354 + Top = 127 + Width = 122 + Height = 25 + Anchors = [akTop, akRight] + Caption = 'Generate SQL' + TabOrder = 1 + OnClick = btnGenerateSQLClick + end + object memoGeneratedSQL: TSynMemo + Left = 8 + Top = 158 + Width = 468 + Height = 164 + SingleLineMode = False + Anchors = [akLeft, akTop, akRight, akBottom] + Font.Charset = DEFAULT_CHARSET + Font.Color = clGrayText + Font.Height = -13 + Font.Name = 'Courier New' + Font.Style = [] + TabOrder = 2 + CodeFolding.GutterShapeSize = 11 + CodeFolding.CollapsedLineColor = clGrayText + CodeFolding.FolderBarLinesColor = clGrayText + CodeFolding.IndentGuidesColor = clGray + CodeFolding.IndentGuides = True + CodeFolding.ShowCollapsedLine = False + CodeFolding.ShowHintMark = True + UseCodeFolding = False + Gutter.AutoSize = True + Gutter.DigitCount = 2 + Gutter.Font.Charset = DEFAULT_CHARSET + Gutter.Font.Color = clWindowText + Gutter.Font.Height = -11 + Gutter.Font.Name = 'Courier New' + Gutter.Font.Style = [] + Gutter.LeftOffset = 0 + Gutter.ShowLineNumbers = True + Highlighter = MainForm.SynSQLSynUsed + Options = [eoAutoIndent, eoDragDropEditing, eoEnhanceEndKey, eoGroupUndo, eoShowScrollHint, eoSmartTabDelete, eoSmartTabs, eoTabsToSpaces] + ReadOnly = True + FontSmoothing = fsmNone + end + object btnExecute: TButton + Left = 354 + Top = 328 + Width = 122 + Height = 25 + Anchors = [akRight, akBottom] + Caption = 'Execute in new tab' + Enabled = False + ModalResult = 1 + TabOrder = 3 + OnClick = btnExecuteClick + end + object btnClose: TButton + Left = 273 + Top = 328 + Width = 75 + Height = 25 + Anchors = [akRight, akBottom] + Cancel = True + Caption = 'Close' + ModalResult = 2 + TabOrder = 4 + end + object btnHelp: TButton + Left = 192 + Top = 328 + Width = 75 + Height = 25 + Anchors = [akRight, akBottom] + Caption = 'Help' + TabOrder = 5 + OnClick = btnHelpClick + end + object comboRecentPrompts: TComboBox + Left = 136 + Top = 8 + Width = 340 + Height = 23 + AutoDropDownWidth = True + Style = csDropDownList + Anchors = [akLeft, akTop, akRight] + TabOrder = 6 + OnSelect = comboRecentPromptsSelect + end +end diff --git a/source/Sequal.Suggest.pas b/source/Sequal.Suggest.pas new file mode 100644 index 000000000..182e71c3e --- /dev/null +++ b/source/Sequal.Suggest.pas @@ -0,0 +1,184 @@ +unit Sequal.Suggest; + +interface + +uses + Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics, + Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, SynEdit, SynMemo, extra_controls, apphelpers, + IdHTTP, IdSSLOpenSSL, System.JSON, dbconnection, Vcl.Imaging.pngimage, + Vcl.ExtCtrls; + +type + TSequalSuggestForm = class(TExtForm) + memoPrompt: TMemo; + btnGenerateSQL: TButton; + memoGeneratedSQL: TSynMemo; + btnExecute: TButton; + btnClose: TButton; + btnHelp: TButton; + imgSequalLogo: TImage; + comboRecentPrompts: TComboBox; + lblRecentPrompts: TLabel; + procedure btnHelpClick(Sender: TObject); + procedure btnGenerateSQLClick(Sender: TObject); + procedure btnExecuteClick(Sender: TObject); + procedure FormShow(Sender: TObject); + procedure FormClose(Sender: TObject; var Action: TCloseAction); + procedure FormCreate(Sender: TObject); + procedure imgSequalLogoClick(Sender: TObject); + procedure comboRecentPromptsSelect(Sender: TObject); + private + { Private declarations } + FConnection: TDBConnection; + function EngineType: String; + function JsonEncode(aValue: String): String; + public + { Public declarations } + end; + +var + SequalSuggestForm: TSequalSuggestForm; + +implementation + +uses main; + +{$R *.dfm} + + +function TSequalSuggestForm.EngineType: String; +begin + // Supported engine types, see https://sequal.dev/docs#suggest + if FConnection.Parameters.IsMariaDB then + Result := 'mariadb' + else if FConnection.Parameters.IsAnyPostgreSQL then + Result := 'postgres' + else + Result := 'mysql'; +end; + +function TSequalSuggestForm.JsonEncode(aValue: String): String; +var + JsonText: TJSONString; +begin + JsonText := TJSONString.Create(aValue); + Result := JsonText.ToJSON; + JsonText.Free; +end; + +procedure TSequalSuggestForm.btnGenerateSQLClick(Sender: TObject); +var + HttpReq: TIdHTTP; + SSLio: TIdSSLIOHandlerSocketOpenSSL; + JsonBodyStr, JsonResponseStr: String; + JsonBodyStream: TStringStream; + JsonTmp: TJSONValue; + ComboIdx: Integer; +begin + // Call suggest API + HttpReq := TIdHTTP.Create; + SSLio := TIdSSLIOHandlerSocketOpenSSL.Create; + HttpReq.IOHandler := SSLio; + SSLio.SSLOptions.SSLVersions := [sslvTLSv1_1, sslvTLSv1_2]; + HttpReq.Request.ContentType := 'application/json'; + HttpReq.Request.CharSet := 'utf-8'; + HttpReq.Request.UserAgent := apphelpers.UserAgent(Self); + + JsonBodyStr := '{"prompt": '+JsonEncode(memoPrompt.Text)+', "type":'+JsonEncode(EngineType)+'}'; + //showmessage(jsonbodystr); + JsonBodyStream := TStringStream.Create(JsonBodyStr, TEncoding.UTF8); + + try + Screen.Cursor := crHourGlass; + JsonResponseStr := HttpReq.Post('https://api.sequal.dev/simple-suggest', JsonBodyStream); + JsonTmp := TJSONObject.ParseJSONValue(JsonResponseStr); + memoGeneratedSQL.Text := JsonTmp.FindValue('data').Value; + btnExecute.Enabled := Length(Trim(memoGeneratedSQL.Text)) > 0; + except + on E:Exception do begin + Screen.Cursor := crDefault; + ErrorDialog(E.ClassName + ': ' + E.Message); + end; + end; + HttpReq.Free; + JsonBodyStream.Free; + + // Add to recent prompts if not already done + ComboIdx := comboRecentPrompts.Items.IndexOf(memoPrompt.Text); + if ComboIdx = -1 then + comboRecentPrompts.Items.Insert(0, memoPrompt.Text) + else if ComboIdx > 0 then + comboRecentPrompts.Items.Move(ComboIdx, 0); + comboRecentPrompts.ItemIndex := 0; + + Screen.Cursor := crDefault; +end; + +procedure TSequalSuggestForm.btnHelpClick(Sender: TObject); +begin + // Help button + ShellExec('https://sequal.dev/our-plans'); +end; + +procedure TSequalSuggestForm.comboRecentPromptsSelect(Sender: TObject); +begin + memoPrompt.Text := comboRecentPrompts.Text; +end; + +procedure TSequalSuggestForm.FormClose(Sender: TObject; + var Action: TCloseAction); +begin + // Store GUI setup + AppSettings.WriteIntDpiAware(asSequalSuggestWindowWidth, Self, Width); + AppSettings.WriteIntDpiAware(asSequalSuggestWindowHeight, Self, Height); + AppSettings.WriteString(asSequalSuggestPrompt, memoPrompt.Text); + AppSettings.WriteString(asSequalSuggestRecentPrompts, Implode(DELIM, comboRecentPrompts.Items)); +end; + +procedure TSequalSuggestForm.FormCreate(Sender: TObject); +begin + HasSizeGrip := True; + Caption := MainForm.actSequalSuggest.Caption; +end; + +procedure TSequalSuggestForm.FormShow(Sender: TObject); +var + RecentPromptsText: String; + RecentPromptsList: TStringList; +begin + // Restore GUI setup + Width := AppSettings.ReadIntDpiAware(asSequalSuggestWindowWidth, Self); + Height := AppSettings.ReadIntDpiAware(asSequalSuggestWindowHeight, Self); + RecentPromptsText := AppSettings.ReadString(asSequalSuggestRecentPrompts); + RecentPromptsList := Explode(DELIM, RecentPromptsText); + comboRecentPrompts.Items.AddStrings(RecentPromptsList); + + FConnection := MainForm.ActiveConnection; + memoPrompt.TextHint := 'Write me a '+EngineType+' query to select column a, b and c from table foobar'; + memoPrompt.Text := AppSettings.ReadString(asSequalSuggestPrompt); + if Length(Trim(memoPrompt.Text)) = 0 then + memoPrompt.Text := memoPrompt.TextHint; + comboRecentPrompts.ItemIndex := comboRecentPrompts.Items.IndexOf(memoPrompt.Text); +end; + +procedure TSequalSuggestForm.imgSequalLogoClick(Sender: TObject); +begin + // Logo clicked + ShellExec(TControl(Sender).Hint); +end; + +procedure TSequalSuggestForm.btnExecuteClick(Sender: TObject); +var + Tab: TQueryTab; +begin + // Pass to query tab and run (!) + if MainForm.actNewQueryTab.Execute then begin + Tab := MainForm.QueryTabs[MainForm.QueryTabs.Count-1]; + Tab.Memo.Text := memoGeneratedSQL.Text; + Tab.TabSheet.Show; + MainForm.actExecuteQueryExecute(Sender); + end; +end; + + +end. diff --git a/source/Xml.VerySimple.pas b/source/Xml.VerySimple.pas new file mode 100644 index 000000000..865424bd2 --- /dev/null +++ b/source/Xml.VerySimple.pas @@ -0,0 +1,1506 @@ +{ VerySimpleXML v3.0.0 - a lightweight, one-unit, cross-platform XML reader/writer + for Delphi 10.4+ by Dennis Spreen + http://blog.spreendigital.de/2014/09/13/verysimplexml-3-0/ + + (c) Copyrights 2011-2020 Dennis D. Spreen + This unit is free and can be used for any needs. The introduction of + any changes and the use of those changed library is permitted without + limitations. Only requirement: + This text must be present without changes in all modifications of library. + + * The contents of this file are used with permission, 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/MPL-1.1.html * + * * + * 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 Xml.VerySimple; + +interface + +uses + System.Classes, System.SysUtils, Generics.Defaults, Generics.Collections, System.Rtti; + +const + TXmlSpaces = #$20 + #$0A + #$0D + #9; + +type + TXmlVerySimple = class; + TXmlNode = class; + TXmlNodeType = (ntElement, ntText, ntCData, ntProcessingInstr, ntComment, ntDocument, ntDocType, ntXmlDecl); + TXmlNodeTypes = set of TXmlNodeType; + TXmlNodeList = class; + TXmlAttributeType = (atValue, atSingle); + TXmlOptions = set of (doNodeAutoIndent, doCompact, doParseProcessingInstr, doPreserveWhiteSpace, doCaseInsensitive, + doWriteBOM, doSimplifyTextNodes); + TExtractTextOptions = set of (etoDeleteStopChar, etoStopString); + + {$IFNDEF AUTOREFCOUNT} + WeakAttribute = class(TCustomAttribute); + {$ENDIF} + + TStreamReaderFillBuffer = procedure(var Encoding: TEncoding) of object; + + TXmlStreamReader = class(TStreamReader) + protected + /// Call to FillBuffer method of TStreamreader + procedure FillBuffer; overload; + public + /// Assures the read buffer holds at least Value characters + function PrepareBuffer(Value: Integer): Boolean; + /// Extract text until chars found in StopChars + function ReadText(const StopChars: String; Options: TExtractTextOptions): String; virtual; + /// Returns fist char but does not removes it from the buffer + function FirstChar: String; + /// Proceed with the next character(s) (value optional, default 1) + procedure IncCharPos(Value: Integer = 1); virtual; + /// Returns True if the first uppercased characters at the current position match Value + function IsUppercaseText(const Value: String): Boolean; virtual; + end; + + + TXmlAttribute = class(TObject) + private + FValue: String; + protected + procedure SetValue(const Value: String); virtual; + public + /// Attribute name + Name: String; + /// Attributes without values are set to atSingle, else to atValue + AttributeType: TXmlAttributeType; + /// Create a new attribute + constructor Create; virtual; + /// Return the attribute as a String + function AsString: String; + /// Escapes XML control characters + class function Escape(const Value: String): String; virtual; + /// Assign attribute values from source attribute + procedure Assign(Source: TXmlAttribute); virtual; + /// Attribute value (always a String) + property Value: String read FValue write SetValue; + end; + + TXmlAttributeList = class(TObjectList) + public + /// The xml document of the attribute list of the node + [Weak] Document: TXmlVerySimple; + /// Add a name only attribute + function Add(const Name: String): TXmlAttribute; overload; virtual; + /// Returns the attribute given by name (case insensitive), NIL if no attribute found + function Find(const Name: String): TXmlAttribute; virtual; + /// Deletes an attribute given by name (case insensitive) + procedure Delete(const Name: String); overload; virtual; + /// Returns True if an attribute with the given name is found (case insensitive) + function HasAttribute(const AttrName: String): Boolean; virtual; + /// Returns the attributes in string representation + function AsString: String; virtual; + /// Clears current attributes and assigns all attributes from source attributes + procedure Assign(Source: TXmlAttributeList); virtual; + end; + + TXmlNode = class(TObject) + protected + [Weak] FDocument: TXmlVerySimple; + procedure SetDocument(Value: TXmlVerySimple); + function GetAttr(const AttrName: String): String; virtual; + procedure SetAttr(const AttrName: String; const AttrValue: String); virtual; + public + /// All attributes of the node + AttributeList: TXmlAttributeList; + /// List of child nodes, never NIL + ChildNodes: TXmlNodeList; + /// Name of the node + Name: String; // Node name + /// The node type, see TXmlNodeType + NodeType: TXmlNodeType; + /// Parent node, may be NIL + [Weak] Parent: TXmlNode; + /// Text value of the node + Text: String; + /// Creates a new XML node + constructor Create(ANodeType: TXmlNodeType = ntElement); virtual; + /// Removes the node from its parent and frees all of its childs + destructor Destroy; override; + /// Clears the attributes, the text and all of its child nodes (but not the name) + procedure Clear; + /// Find a child node by its name + function Find(const Name: String; NodeTypes: TXmlNodeTypes = [ntElement]): TXmlNode; overload; virtual; + /// Find a child node by name and attribute name + function Find(const Name, AttrName: String; NodeTypes: TXmlNodeTypes = [ntElement]): TXmlNode; overload; virtual; + /// Find a child node by name, attribute name and attribute value + function Find(const Name, AttrName, AttrValue: String; NodeTypes: TXmlNodeTypes = [ntElement]): TXmlNode; overload; virtual; + /// Return a list of child nodes with the given name and (optional) node types + function FindNodes(const Name: String; NodeTypes: TXmlNodeTypes = [ntElement]): TXmlNodeList; virtual; + /// Return a child node by NodePath + function SelectNode(const NodePath: String): TXmlNode; overload; virtual; + /// Returns True if the attribute exists + function HasAttribute(const AttrName: String): Boolean; virtual; + /// Returns True if a child node with that name exits + function HasChild(const Name: String; NodeTypes: TXmlNodeTypes = [ntElement]): Boolean; virtual; + /// Add a child node with an optional NodeType (default: ntElement) + function AddChild(const AName: String; ANodeType: TXmlNodeType = ntElement): TXmlNode; virtual; + /// Insert a child node at a specific position with a (optional) NodeType (default: ntElement) + function InsertChild(const Name: String; Position: Integer; NodeType: TXmlNodeType = ntElement): TXmlNode; virtual; + /// Fluent interface for setting the text of the node + function SetText(const Value: String): TXmlNode; virtual; + /// Fluent interface for setting the node attribute given by attribute name and attribute value + function SetAttribute(const AttrName, AttrValue: String): TXmlNode; virtual; + /// Returns first child or NIL if there aren't any child nodes + function FirstChild: TXmlNode; virtual; + /// Returns last child node or NIL if there aren't any child nodes + function LastChild: TXmlNode; virtual; + /// Returns next sibling + function NextSibling: TXmlNode; overload; virtual; + /// Returns previous sibling + function PreviousSibling: TXmlNode; overload; virtual; + /// Returns True if the node has at least one child node + function HasChildNodes: Boolean; virtual; + /// Returns True if the node has a text content and no child nodes + function IsTextElement: Boolean; virtual; + /// Fluent interface for setting the node type + function SetNodeType(Value: TXmlNodeType): TXmlNode; virtual; + /// Attributes of a node, accessible by attribute name (case insensitive) + property Attributes[const AttrName: String]: String read GetAttr write SetAttr; + /// The xml document of the node + property Document: TXmlVerySimple read FDocument write SetDocument; + /// The node name, same as property Name + property NodeName: String read Name write Name; + /// The node text, same as property Text + property NodeValue: String read Text write Text; + end; + + TXmlNodeList = class(TObjectList) + protected + function IsSame(const Value1, Value2: String): Boolean; virtual; + public + /// The xml document of the node list + [Weak] Document: TXmlVerySimple; + /// The parent node of the node list + [Weak] Parent: TXmlNode; + /// Adds a node and sets the parent of the node to the parent of the list + function Add(Value: TXmlNode): Integer; overload; virtual; + /// Creates a new node of type NodeType (default ntElement) and adds it to the list + function Add(NodeType: TXmlNodeType = ntElement): TXmlNode; overload; virtual; + /// Add a child node with an optional NodeType (default: ntElement) + function Add(const Name: String; NodeType: TXmlNodeType = ntElement): TXmlNode; overload; virtual; + /// Find a node by its name (case sensitive), returns NIL if no node is found + function Find(const Name: String; NodeTypes: TXmlNodeTypes = [ntElement]): TXmlNode; overload; virtual; + /// Same as Find(), returnsa a node by its name (case sensitive) + function FindNode(const Name: String; NodeTypes: TXmlNodeTypes = [ntElement]): TXmlNode; virtual; + /// Find a node that has the the given attribute, returns NIL if no node is found + function Find(const Name, AttrName: String; NodeTypes: TXmlNodeTypes = [ntElement]): TXmlNode; overload; virtual; + /// Find a node that as the given attribute name and value, returns NIL otherwise + function Find(const Name, AttrName, AttrValue: String; NodeTypes: TXmlNodeTypes = [ntElement]): TXmlNode; overload; virtual; + /// Return a list of child nodes with the given name and (optional) node types + function FindNodes(const Name: String; NodeTypes: TXmlNodeTypes = [ntElement]): TXmlNodeList; virtual; + /// Returns True if the list contains a node with the given name + function HasNode(const Name: String; NodeTypes: TXmlNodeTypes = [ntElement]): Boolean; virtual; + /// Inserts a node at the given position + function Insert(const Name: String; Position: Integer; NodeType: TXmlNodeType = ntElement): TXmlNode; overload; virtual; + /// Returns the first child node, same as .First + function FirstChild: TXmlNode; virtual; + /// Returns next sibling node + function NextSibling(Node: TXmlNode): TXmlNode; virtual; + /// Returns previous sibling node + function PreviousSibling(Node: TXmlNode): TXmlNode; virtual; + /// Returns the node at the given position + function Get(Index: Integer): TXmlNode; virtual; + end; + + TXmlVerySimple = class(TObject) + protected + FRoot: TXmlNode; + [Weak] FHeader: TXmlNode; + [Weak] FDocumentElement: TXmlNode; + SkipIndent: Boolean; + procedure Parse(Reader: TXmlStreamReader); virtual; + procedure ParseComment(Reader: TXmlStreamReader; var Parent: TXmlNode); virtual; + procedure ParseDocType(Reader: TXmlStreamReader; var Parent: TXmlNode); virtual; + procedure ParseProcessingInstr(Reader: TXmlStreamReader; var Parent: TXmlNode); virtual; + procedure ParseCData(Reader: TXmlStreamReader; var Parent: TXmlNode); virtual; + procedure ParseText(const Line: String; Parent: TXmlNode; ReplaceText: Boolean = False); virtual; + function ParseTag(Reader: TXmlStreamReader; FindText: Boolean; var Parent: TXmlNode): TXmlNode; overload; virtual; + function ParseTag(const TagStr: String; var Parent: TXmlNode): TXmlNode; overload; virtual; + procedure Walk(Writer: TStreamWriter; const PrefixNode: String; Node: TXmlNode); virtual; + procedure SetText(const Value: String); virtual; + function GetText: String; virtual; + procedure SetEncoding(const Value: String); virtual; + function GetEncoding: String; virtual; + procedure SetVersion(const Value: String); virtual; + function GetVersion: String; virtual; + procedure Compose(Writer: TStreamWriter); virtual; + procedure SetStandAlone(const Value: String); virtual; + function GetStandAlone: String; virtual; + function GetChildNodes: TXmlNodeList; virtual; + procedure CreateHeaderNode; virtual; + function ExtractText(var Line: String; const StopChars: String; Options: TExtractTextOptions): String; virtual; + procedure SetDocumentElement(Value: TXMlNode); virtual; + procedure SetPreserveWhitespace(Value: Boolean); + function GetPreserveWhitespace: Boolean; + function IsSame(const Value1, Value2: String): Boolean; + public + /// Indent used for the xml output + NodeIndentStr: String; + /// LineBreak used for the xml output, default set to sLineBreak which is OS dependent + LineBreak: String; + /// Options for xml output like indentation type + Options: TXmlOptions; + /// Creates a new XML document parser + constructor Create; virtual; + /// Destroys the XML document parser + destructor Destroy; override; + /// Deletes all nodes + procedure Clear; virtual; + /// Adds a new node to the document, if it's the first ntElement then sets it as .DocumentElement + function AddChild(const Name: String; NodeType: TXmlNodeType = ntElement): TXmlNode; virtual; + /// Creates a new node but doesn't adds it to the document nodes + function CreateNode(const Name: String; NodeType: TXmlNodeType = ntElement): TXmlNode; virtual; + /// Escapes XML control characters + class function Escape(const Value: String): String; virtual; + /// Translates escaped characters back into XML control characters + class function Unescape(const Value: String): String; virtual; + /// Loads the XML from a file + function LoadFromFile(const FileName: String; BufferSize: Integer = 4096): TXmlVerySimple; virtual; + /// Loads the XML from a stream + function LoadFromStream(const Stream: TStream; BufferSize: Integer = 4096): TXmlVerySimple; virtual; + /// Parse attributes into the attribute list for a given string + procedure ParseAttributes(const AttribStr: String; AttributeList: TXmlAttributeList); virtual; + /// Saves the XML to a file + function SaveToFile(const FileName: String): TXmlVerySimple; virtual; + /// Saves the XML to a stream, the encoding is specified in the .Encoding property + function SaveToStream(const Stream: TStream): TXmlVerySimple; virtual; + /// A list of all root nodes of the document + property ChildNodes: TXmlNodeList read GetChildNodes; + /// Returns the first element node + property DocumentElement: TXmlNode read FDocumentElement write SetDocumentElement; + /// Specifies the encoding of the XML file, anything else then 'utf-8' is considered as ANSI + property Encoding: String read GetEncoding write SetEncoding; + /// XML declarations are stored in here as Attributes + property Header: TXmlNode read FHeader; + /// Set to True if all spaces and linebreaks should be included as a text node, same as doPreserve option + property PreserveWhitespace: Boolean read GetPreserveWhitespace write SetPreserveWhitespace; + /// The root node of the document + property Root: TXmlNode read FRoot; + /// Defines the xml declaration property "StandAlone", set it to "yes" or "no" + property StandAlone: String read GetStandAlone write SetStandAlone; + /// The XML as a string representation + property Text: String read GetText write SetText; + /// Defines the xml declaration property "Version", default set to "1.0" + property Version: String read GetVersion write SetVersion; + /// The XML as a string representation, same as .Text + property Xml: String read GetText write SetText; + end; + +implementation + +uses + System.StrUtils; + +{ TVerySimpleXml } + +function TXmlVerySimple.AddChild(const Name: String; NodeType: TXmlNodeType = ntElement): TXmlNode; +begin + Result := CreateNode(Name, NodeType); + if (NodeType = ntElement) and (not Assigned(FDocumentElement)) then + FDocumentElement := Result; + try + FRoot.ChildNodes.Add(Result); + except + Result.Free; + raise; + end; + Result.Document := Self; +end; + +procedure TXmlVerySimple.Clear; +begin + FDocumentElement := NIL; + FHeader := NIL; + FRoot.Clear; +end; + +constructor TXmlVerySimple.Create; +begin + inherited; + FRoot := TXmlNode.Create; + FRoot.NodeType := ntDocument; + FRoot.Parent := FRoot; + FRoot.Document := Self; + NodeIndentStr := ' '; + Options := [doNodeAutoIndent, doWriteBOM, doSimplifyTextNodes]; + LineBreak := sLineBreak; + CreateHeaderNode; +end; + +procedure TXmlVerySimple.CreateHeaderNode; +begin + if Assigned(FHeader) then + Exit; + FHeader := FRoot.ChildNodes.Insert('xml', 0, ntXmlDecl); + FHeader.Attributes['version'] := '1.0'; // Default XML version + FHeader.Attributes['encoding'] := 'utf-8'; +end; + +function TXmlVerySimple.CreateNode(const Name: String; NodeType: TXmlNodeType): TXmlNode; +begin + Result := TXmlNode.Create(NodeType); + Result.Name := Name; + Result.Document := Self; +end; + +destructor TXmlVerySimple.Destroy; +begin + FRoot.Parent := NIL; + FRoot.Clear; + FRoot.Free; + inherited; +end; + +function TXmlVerySimple.GetChildNodes: TXmlNodeList; +begin + Result := FRoot.ChildNodes; +end; + +function TXmlVerySimple.GetEncoding: String; +begin + if Assigned(FHeader) then + Result := FHeader.Attributes['encoding'] + else + Result := ''; +end; + +function TXmlVerySimple.GetPreserveWhitespace: Boolean; +begin + Result := doPreserveWhitespace in Options; +end; + +function TXmlVerySimple.GetStandAlone: String; +begin + if Assigned(FHeader) then + Result := FHeader.Attributes['standalone'] + else + Result := ''; +end; + +function TXmlVerySimple.GetVersion: String; +begin + if Assigned(FHeader) then + Result := FHeader.Attributes['version'] + else + Result := ''; +end; + +function TXmlVerySimple.IsSame(const Value1, Value2: String): Boolean; +begin + if doCaseInsensitive in Options then + Result := AnsiSameText(Value1, Value2) + else + Result := (Value1 = Value2); +end; + +function TXmlVerySimple.GetText: String; +var + Stream: TStringStream; +begin + if AnsiSameText(Encoding, 'utf-8') then + Stream := TStringStream.Create('', TEncoding.UTF8) + else + Stream := TStringStream.Create('', TEncoding.ANSI); + try + SaveToStream(Stream); + Result := Stream.DataString; + finally + Stream.Free; + end; +end; + +procedure TXmlVerySimple.Compose(Writer: TStreamWriter); +var + Child: TXmlNode; +begin + if doCompact in Options then + begin + Writer.NewLine := ''; + LineBreak := ''; + end + else + Writer.NewLine := LineBreak; + + SkipIndent := False; + for Child in FRoot.ChildNodes do + Walk(Writer, '', Child); +end; + +function TXmlVerySimple.LoadFromFile(const FileName: String; BufferSize: Integer = 4096): TXmlVerySimple; +var + Stream: TFileStream; +begin + Stream := TFileStream.Create(FileName, fmOpenRead + fmShareDenyWrite); + try + LoadFromStream(Stream, BufferSize); + finally + Stream.Free; + end; + Result := Self; +end; + +function TXmlVerySimple.LoadFromStream(const Stream: TStream; BufferSize: Integer = 4096): TXmlVerySimple; +var + Reader: TXmlStreamReader; +begin + if Encoding.IsEmpty then // none specified then use UTF8 with DetectBom + Reader := TXmlStreamReader.Create(Stream, TEncoding.UTF8, True, BufferSize) + else + if AnsiSameText(Encoding, 'utf-8') then + Reader := TXmlStreamReader.Create(Stream, TEncoding.UTF8, False, BufferSize) + else + Reader := TXmlStreamReader.Create(Stream, TEncoding.ANSI, False, BufferSize); + try + Parse(Reader); + finally + Reader.Free; + end; + Result := Self; +end; + +procedure TXmlVerySimple.Parse(Reader: TXmlStreamReader); +var + Parent, Node: TXmlNode; + FirstChar: String; + ALine: String; +begin + Clear; + Parent := FRoot; + + while not Reader.EndOfStream do + begin + ALine := Reader.ReadText('<', [etoDeleteStopChar]); + if not ALine.IsEmpty then // Check for text nodes + begin + ParseText(Aline, Parent); + if Reader.EndOfStream then // if no chars available then exit + Break; + end; + FirstChar := Reader.FirstChar; + if FirstChar = '!' then + if Reader.IsUppercaseText('!--') then // check for a comment node + ParseComment(Reader, Parent) + else + if Reader.IsUppercaseText('!DOCTYPE') then // check for a doctype node + ParseDocType(Reader, Parent) + else + if Reader.IsUppercaseText('![CDATA[') then // check for a cdata node + ParseCData(Reader, Parent) + else + ParseTag(Reader, False, Parent) // try to parse as tag + else // Check for XML header / processing instructions + if FirstChar = '?' then // could be header or processing instruction + ParseProcessingInstr(Reader, Parent) + else + if not FirstChar.IsEmpty then + begin // Parse a tag, the first tag in a document is the DocumentElement + Node := ParseTag(Reader, True, Parent); + if (not Assigned(FDocumentElement)) and (Parent = FRoot) then + FDocumentElement := Node; + end; + end; +end; + +procedure TXmlVerySimple.ParseAttributes(const AttribStr: String; AttributeList: TXmlAttributeList); +var + Attribute: TXmlAttribute; + AttrName, AttrText: String; + Quote: String; + Value: String; +begin + Value := TrimLeft(AttribStr); + while not Value.IsEmpty do + begin + AttrName := ExtractText(Value, ' =', []); + Value := TrimLeft(Value); + + Attribute := AttributeList.Add(AttrName); + if (Value.IsEmpty) or (Value[1] <> '=') then + Continue; + + Delete(Value, 1, 1); + Attribute.AttributeType := atValue; + ExtractText(Value, '''' + '"', []); + Value := TrimLeft(Value); + if not Value.IsEmpty then + begin + Quote := Value[1]; + Delete(Value, 1, 1); + AttrText := ExtractText(Value, Quote, [etoDeleteStopChar]); // Get Attribute Value + Attribute.Value := Unescape(AttrText); + Value := TrimLeft(Value); + end; + end; +end; + + +procedure TXmlVerySimple.ParseText(const Line: String; Parent: TXmlNode; ReplaceText: Boolean = False); +var + SingleChar: Char; + Node: TXmlNode; + TextNode: Boolean; +begin + if PreserveWhiteSpace then + TextNode := True + else + begin + TextNode := False; + for SingleChar in Line do + if not Assigned(AnsiStrScan(TXmlSpaces, SingleChar)) then + begin + TextNode := True; + Break; + end; + end; + + if TextNode then + if ReplaceText then + Parent.Text := Line + else + begin + Node := Parent.ChildNodes.Add(ntText); + Node.Text := Line; + end; +end; + +procedure TXmlVerySimple.ParseCData(Reader: TXmlStreamReader; var Parent: TXmlNode); +var + Node: TXmlNode; +begin + Node := Parent.ChildNodes.Add(ntCData); + Node.Text := Reader.ReadText(']]>', [etoDeleteStopChar, etoStopString]); +end; + +procedure TXmlVerySimple.ParseComment(Reader: TXmlStreamReader; var Parent: TXmlNode); +var + Node: TXmlNode; +begin + Node := Parent.ChildNodes.Add(ntComment); + Node.Text := Reader.ReadText('-->', [etoDeleteStopChar, etoStopString]); +end; + +procedure TXmlVerySimple.ParseDocType(Reader: TXmlStreamReader; var Parent: TXmlNode); +var + Node: TXmlNode; + Quote: String; +begin + Node := Parent.ChildNodes.Add(ntDocType); + Node.Text := Reader.ReadText('>[', []); + if not Reader.EndOfStream then + begin + Quote := Reader.FirstChar; + Reader.IncCharPos; + if Quote = '[' then + Node.Text := Node.Text + Quote + Reader.ReadText(']',[etoDeleteStopChar]) + ']' + + Reader.ReadText('>', [etoDeleteStopChar]); + end; +end; + +procedure TXmlVerySimple.ParseProcessingInstr(Reader: TXmlStreamReader; var Parent: TXmlNode); +var + Node: TXmlNode; + Tag: String; +begin + Reader.IncCharPos; // omit the '?' + Tag := Reader.ReadText('?>', [etoDeleteStopChar, etoStopString]); + Node := ParseTag(Tag, Parent); + if lowercase(Node.Name) = 'xml' then + begin + FHeader := Node; + FHeader.NodeType := ntXmlDecl; + end + else + begin + Node.NodeType := ntProcessingInstr; + if not (doParseProcessingInstr in Options) then + begin + Node.Text := Tag; + Node.AttributeList.Clear; + end; + end; + Parent := Node.Parent; +end; + +function TXmlVerySimple.ParseTag(Reader: TXmlStreamReader; FindText: Boolean; var Parent: TXmlNode): TXmlNode; +var + Tag: String; + ALine: String; +begin + Tag := Reader.ReadText('>', [etoDeleteStopChar]); + Result := ParseTag(Tag, Parent); + if (Result = Parent) and (FindText) then // only non-self closing nodes may have a text + begin + ALine := Reader.ReadText('<', []); + ALine := Unescape(ALine); + + // if a node consists of text only then replace text, else parse as separate text node + if not Aline.IsEmpty then + ParseText(ALine, Result, doSimplifyTextNodes in Options); + end; +end; + +function TXmlVerySimple.ParseTag(const TagStr: String; var Parent: TXmlNode): TXmlNode; +var + Node: TXmlNode; + ALine: String; + CharPos: Integer; + Tag: String; +begin + // A closing tag does not have any attributes nor text + if (not TagStr.IsEmpty) and (TagStr[1] = '/') then + begin + Result := Parent; + Parent := Parent.Parent; + Exit; + end; + + // Creat a new new ntElement node + Node := Parent.ChildNodes.Add; + Result := Node; + Tag := TagStr; + + // Check for a self-closing Tag (does not have any text) + if (not Tag.IsEmpty) and (Tag[High(Tag)] = '/') then + Delete(Tag, Length(Tag), 1) + else + Parent := Node; + + CharPos := Pos(' ', Tag); + if CharPos <> 0 then // Tag may have attributes + begin + ALine := Tag; + Delete(Tag, CharPos, Length(Tag)); + Delete(ALine, 1, CharPos); + if not ALine.IsEmpty then + ParseAttributes(ALine, Node.AttributeList); + end; + + Node.Name := Tag; +end; + + +function TXmlVerySimple.SaveToFile(const FileName: String): TXmlVerySimple; +var + Stream: TFileStream; +begin + Stream := TFileStream.Create(FileName, fmCreate); + try + SaveToStream(Stream); + finally + Stream.Free; + end; + Result := Self; +end; + +function TXmlVerySimple.SaveToStream(const Stream: TStream): TXmlVerySimple; +var + Writer: TStreamWriter; +begin + if AnsiSameText(Encoding, 'utf-8') then + if doWriteBOM in Options then + Writer := TStreamWriter.Create(Stream, TEncoding.UTF8) + else + Writer := TStreamWriter.Create(Stream) + else + Writer := TStreamWriter.Create(Stream, TEncoding.ANSI); + try + Compose(Writer); + finally + Writer.Free; + end; + Result := Self; +end; + +procedure TXmlVerySimple.SetDocumentElement(Value: TXMlNode); +begin + FDocumentElement := Value; + if not Assigned(Value.Parent) then + FRoot.ChildNodes.Add(Value); +end; + +procedure TXmlVerySimple.SetEncoding(const Value: String); +begin + CreateHeaderNode; + FHeader.Attributes['encoding'] := Value; +end; + +procedure TXmlVerySimple.SetPreserveWhitespace(Value: Boolean); +begin + if Value then + Options := Options + [doPreserveWhitespace] + else + Options := Options - [doPreserveWhitespace] +end; + +procedure TXmlVerySimple.SetStandAlone(const Value: String); +begin + CreateHeaderNode; + FHeader.Attributes['standalone'] := Value; +end; + +procedure TXmlVerySimple.SetVersion(const Value: String); +begin + CreateHeaderNode; + FHeader.Attributes['version'] := Value; +end; + + +class function TXmlVerySimple.Unescape(const Value: String): String; +begin + Result := ReplaceStr(Value, '<', '<'); + Result := ReplaceStr(Result, '>', '>'); + Result := ReplaceStr(Result, '"', '"'); + Result := ReplaceStr(Result, ''', ''''); + Result := ReplaceStr(Result, '&', '&'); +end; + +procedure TXmlVerySimple.SetText(const Value: String); +var + Stream: TStringStream; +begin + Stream := TStringStream.Create('', TEncoding.UTF8); + try + Stream.WriteString(Value); + Stream.Position := 0; + LoadFromStream(Stream); + finally + Stream.Free; + end; +end; + +procedure TXmlVerySimple.Walk(Writer: TStreamWriter; const PrefixNode: String; Node: TXmlNode); +var + Child: TXmlNode; + Line: String; + Indent: String; +begin + if (Node = FRoot.ChildNodes.First) or (SkipIndent) then + begin + Line := '<'; + SkipIndent := False; + end + else + Line := LineBreak + PrefixNode + '<'; + + case Node.NodeType of + ntComment: + begin + Writer.Write(Line + '!--' + Node.Text + '-->'); + Exit; + end; + ntDocType: + begin + Writer.Write(Line + '!DOCTYPE ' + Node.Text + '>'); + Exit; + end; + ntCData: + begin + Writer.Write(''); + Exit; + end; + ntText: + begin + Writer.Write(Node.Text); + SkipIndent := True; + Exit; + end; + ntProcessingInstr: + begin + if Node.AttributeList.Count > 0 then + Writer.Write(Line + '?' + Node.Name + Node.AttributeList.AsString + '?>') + else + Writer.Write(Line + '?' + Node.Text + '?>'); + Exit; + end; + ntXmlDecl: + begin + Writer.Write(Line + '?' + Node.Name + Node.AttributeList.AsString + '?>'); + Exit; + end; + end; + + Line := Line + Node.Name + Node.AttributeList.AsString; + + // Self closing tags + if (Node.Text.IsEmpty) and (not Node.HasChildNodes) then + begin + Writer.Write(Line + '/>'); + Exit; + end; + + Line := Line + '>'; + if not Node.Text.IsEmpty then + begin + Line := Line + Escape(Node.Text); + if Node.HasChildNodes then + SkipIndent := True; + end; + + Writer.Write(Line); + + // Set indent for child nodes + if doCompact in Options then + Indent := '' + else + Indent := PrefixNode + NodeIndentStr; + + // Process child nodes + for Child in Node.ChildNodes do + Walk(Writer, Indent, Child); + + // If node has child nodes and last child node is not a text node then set indent for closing tag + if (Node.HasChildNodes) and (not SkipIndent) then + Indent := LineBreak + PrefixNode + else + Indent := ''; + + Writer.Write(Indent + ''); +end; + + +class function TXmlVerySimple.Escape(const Value: String): String; +begin + Result := TXmlAttribute.Escape(Value); + Result := ReplaceStr(Result, '''', '''); +end; + +function TXmlVerySimple.ExtractText(var Line: String; const StopChars: String; + Options: TExtractTextOptions): String; +var + CharPos, FoundPos: Integer; + TestChar: Char; +begin + FoundPos := 0; + for TestChar in StopChars do + begin + CharPos := Pos(TestChar, Line); + if (CharPos <> 0) and ((FoundPos = 0) or (CharPos < FoundPos)) then + FoundPos := CharPos; + end; + + if FoundPos <> 0 then + begin + Dec(FoundPos); + Result := Copy(Line, 1, FoundPos); + if etoDeleteStopChar in Options then + Inc(FoundPos); + Delete(Line, 1, FoundPos); + end + else + begin + Result := Line; + Line := ''; + end; +end; + +{ TXmlNode } + +function TXmlNode.AddChild(const AName: String; ANodeType: TXmlNodeType = ntElement): TXmlNode; +begin + Result := ChildNodes.Add(AName, ANodeType); +end; + +procedure TXmlNode.Clear; +begin + Text := ''; + AttributeList.Clear; + ChildNodes.Clear; +end; + +constructor TXmlNode.Create(ANodeType: TXmlNodeType = ntElement); +begin + ChildNodes := TXmlNodeList.Create; + ChildNodes.Parent := Self; + AttributeList := TXmlAttributeList.Create; + NodeType := ANodeType; +end; + +destructor TXmlNode.Destroy; +begin + Clear; + ChildNodes.Free; + AttributeList.Free; + inherited; +end; + +function TXmlNode.Find(const Name: String; NodeTypes: TXmlNodeTypes = [ntElement]): TXmlNode; +begin + Result := ChildNodes.Find(Name, NodeTypes); +end; + +function TXmlNode.Find(const Name, AttrName, AttrValue: String; NodeTypes: TXmlNodeTypes = [ntElement]): TXmlNode; +begin + Result := ChildNodes.Find(Name, AttrName, AttrValue, NodeTypes); +end; + +function TXmlNode.Find(const Name, AttrName: String; NodeTypes: TXmlNodeTypes = [ntElement]): TXmlNode; +begin + Result := ChildNodes.Find(Name, AttrName, NodeTypes); +end; + +function TXmlNode.FindNodes(const Name: String; NodeTypes: TXmlNodeTypes = [ntElement]): TXmlNodeList; +begin + Result := ChildNodes.FindNodes(Name, NodeTypes); +end; + +function TXmlNode.FirstChild: TXmlNode; +begin + Result := ChildNodes.First; +end; + +function TXmlNode.GetAttr(const AttrName: String): String; +var + Attribute: TXmlAttribute; +begin + Attribute := AttributeList.Find(AttrName); + if Assigned(Attribute) then + Result := Attribute.Value + else + Result := ''; +end; + +function TXmlNode.HasAttribute(const AttrName: String): Boolean; +begin + Result := AttributeList.HasAttribute(AttrName); +end; + +function TXmlNode.HasChild(const Name: String; NodeTypes: TXmlNodeTypes = [ntElement]): Boolean; +begin + Result := ChildNodes.HasNode(Name, NodeTypes); +end; + +function TXmlNode.HasChildNodes: Boolean; +begin + Result := (ChildNodes.Count > 0); +end; + +function TXmlNode.InsertChild(const Name: String; Position: Integer; NodeType: TXmlNodeType = ntElement): TXmlNode; +begin + Result := ChildNodes.Insert(Name, Position, NodeType); + if Assigned(Result) then + Result.Parent := Self; +end; + +function TXmlNode.IsTextElement: Boolean; +begin + Result := (not Text.IsEmpty) and (not HasChildNodes); +end; + +function TXmlNode.LastChild: TXmlNode; +begin + if ChildNodes.Count > 0 then + Result := ChildNodes.Last + else + Result := NIL; +end; + +function TXmlNode.NextSibling: TXmlNode; +begin + if not Assigned(Parent) then + Result := NIL + else + Result := Parent.ChildNodes.NextSibling(Self); +end; + +function TXmlNode.PreviousSibling: TXmlNode; +begin + if not Assigned(Parent) then + Result := NIL + else + Result := Parent.ChildNodes.PreviousSibling(Self); +end; + +function TXmlNode.SelectNode(const NodePath: String): TXmlNode; +var + Elements: TArray; + Element: String; + SubNode, Node: TXmlNode; +begin + Result := NIL; + + // SplitElements by '/' delimiter + Elements := NodePath.Split(['/']); + if not Assigned(Elements) then + Exit; + + // Start from the root if the path is prefixed with '/' + if Elements[0].IsEmpty then + begin + Node := FDocument.Root; + Delete(Elements, 0, 1); + end + else + Node := Self; + + // Traverse all elements + SubNode := NIL; + for Element in Elements do + begin + if Element.IsEmpty then + Continue; + + SubNode := Node.Find(Element, []); + if not Assigned(SubNode) then + Break; + + Node := SubNode; + end; + + Result := SubNode; +end; + +procedure TXmlNode.SetAttr(const AttrName, AttrValue: String); +begin + SetAttribute(AttrName, AttrValue); +end; + +function TXmlNode.SetAttribute(const AttrName, AttrValue: String): TXmlNode; +var + Attribute: TXmlAttribute; +begin + Attribute := AttributeList.Find(AttrName); // Search for given name + if not Assigned(Attribute) then // If attribute is not found, create one + Attribute := AttributeList.Add(AttrName); + Attribute.AttributeType := atValue; + Attribute.Name := AttrName; // this allows rewriting of the attribute name (lower/upper case) + Attribute.Value := AttrValue; + Result := Self; +end; + +procedure TXmlNode.SetDocument(Value: TXmlVerySimple); +begin + FDocument := Value; + AttributeList.Document := Value; + ChildNodes.Document := Value; +end; + +function TXmlNode.SetNodeType(Value: TXmlNodeType): TXmlNode; +begin + NodeType := Value; + Result := Self; +end; + +function TXmlNode.SetText(const Value: String): TXmlNode; +begin + Text := Value; + Result := Self; +end; + +{ TXmlAttributeList } + +function TXmlAttributeList.Add(const Name: String): TXmlAttribute; +begin + Result := TXmlAttribute.Create; + Result.Name := Name; + try + Add(Result); + except + Result.Free; + raise; + end; +end; + +procedure TXmlAttributeList.Assign(Source: TXmlAttributeList); +var + Attribute: TXmlAttribute; + SourceAttribute: TXmlAttribute; +begin + Clear; + for SourceAttribute in Source do + begin + Attribute := Add(''); + Attribute.Assign(SourceAttribute); + end; +end; + +function TXmlAttributeList.AsString: String; +var + Attribute: TXmlAttribute; +begin + Result := ''; + for Attribute in Self do + Result := Result + ' ' + Attribute.AsString; +end; + +procedure TXmlAttributeList.Delete(const Name: String); +var + Attribute: TXmlAttribute; +begin + Attribute := Find(Name); + if Assigned(Attribute) then + Remove(Attribute); +end; + +function TXmlAttributeList.Find(const Name: String): TXmlAttribute; +var + Attribute: TXmlAttribute; +begin + Result := NIL; + for Attribute in Self do + if ((Assigned(Document) and Document.IsSame(Attribute.Name, Name)) or // use the documents text comparison + ((not Assigned(Document)) and (Attribute.Name = Name))) then // or if not assigned then compare names case sensitive + begin + Result := Attribute; + Break; + end; +end; + +function TXmlAttributeList.HasAttribute(const AttrName: String): Boolean; +begin + Result := Assigned(Find(AttrName)); +end; + +{ TXmlNodeList } + +function TXmlNodeList.Find(const Name: String; NodeTypes: TXmlNodeTypes = [ntElement]): TXmlNode; +var + Node: TXmlNode; +begin + Result := NIL; + for Node in Self do + if ((NodeTypes = []) or (Node.NodeType in NodeTypes)) and (IsSame(Node.Name, Name)) then + begin + Result := Node; + Break; + end; + +end; + +function TXmlNodeList.Add(Value: TXmlNode): Integer; +begin + Result := inherited Add(Value); + Value.Parent := Parent; +end; + +function TXmlNodeList.Add(NodeType: TXmlNodeType = ntElement): TXmlNode; +begin + Result := TXmlNode.Create(NodeType); + try + Add(Result); + except + Result.Free; + raise; + end; + Result.Document := Document; +end; + +function TXmlNodeList.Add(const Name: String; NodeType: TXmlNodeType): TXmlNode; +begin + Result := Add(NodeType); + Result.Name := Name; +end; + +function TXmlNodeList.Find(const Name, AttrName, AttrValue: String; NodeTypes: TXmlNodeTypes = [ntElement]): TXmlNode; +var + Node: TXmlNode; +begin + Result := NIL; + for Node in Self do + if ((NodeTypes = []) or (Node.NodeType in NodeTypes)) and // if no type specified or node type in types + IsSame(Node.Name, Name) and Node.HasAttribute(AttrName) and IsSame(Node.Attributes[AttrName], AttrValue) then + begin + Result := Node; + Break; + end; +end; + +function TXmlNodeList.Find(const Name, AttrName: String; NodeTypes: TXmlNodeTypes = [ntElement]): TXmlNode; +var + Node: TXmlNode; +begin + Result := NIL; + for Node in Self do + if ((NodeTypes = []) or (Node.NodeType in NodeTypes)) and IsSame(Node.Name, Name) and + Node.HasAttribute(AttrName) then + begin + Result := Node; + Break; + end; +end; + + +function TXmlNodeList.FindNode(const Name: String; NodeTypes: TXmlNodeTypes = [ntElement]): TXmlNode; +begin + Result := Find(Name, NodeTypes); +end; + +function TXmlNodeList.FindNodes(const Name: String; NodeTypes: TXmlNodeTypes = [ntElement]): TXmlNodeList; +var + Node: TXmlNode; +begin + Result := TXmlNodeList.Create(False); + Result.Document := Document; + try + for Node in Self do + if ((NodeTypes = []) or (Node.NodeType in NodeTypes)) and IsSame(Node.Name, Name) then + begin + Result.Parent := Node.Parent; + Result.Add(Node); + end; + Result.Parent := NIL; + except + Result.Free; + raise; + end; +end; + +function TXmlNodeList.FirstChild: TXmlNode; +begin + Result := First; +end; + + +function TXmlNodeList.Get(Index: Integer): TXmlNode; +begin + Result := Items[Index]; +end; + +function TXmlNodeList.HasNode(const Name: String; NodeTypes: TXmlNodeTypes = [ntElement]): Boolean; +begin + Result := Assigned(Find(Name, NodeTypes)); +end; + +function TXmlNodeList.Insert(const Name: String; Position: Integer; NodeType: TXmlNodeType = ntElement): TXmlNode; +begin + Result := TXmlNode.Create; + Result.Document := Document; + try + Result.Name := Name; + Result.NodeType := NodeType; + Insert(Position, Result); + except + Result.Free; + raise; + end; +end; + +function TXmlNodeList.IsSame(const Value1, Value2: String): Boolean; +begin + Result := ((Assigned(Document) and Document.IsSame(Value1, Value2)) or // use the documents text comparison + ((not Assigned(Document)) and (Value1 = Value2))); // or if not assigned then compare names case sensitive +end; + +function TXmlNodeList.NextSibling(Node: TXmlNode): TXmlNode; +var + Index: Integer; +begin + if (not Assigned(Node)) and (Count > 0) then + Result := First + else + begin + Index := IndexOf(Node); + if (Index >= 0) and (Index + 1 < Count) then + Result := Self[Index + 1] + else + Result := NIL; + end; +end; + +function TXmlNodeList.PreviousSibling(Node: TXmlNode): TXmlNode; +var + Index: Integer; +begin + Index := IndexOf(Node); + if Index - 1 >= 0 then + Result := Self[Index - 1] + else + Result := NIL; +end; + +{ TXmlAttribute } + +procedure TXmlAttribute.Assign(Source: TXmlAttribute); +begin + FValue := Source.Value; + Name := Source.Name; + AttributeType := Source.AttributeType; +end; + +function TXmlAttribute.AsString: String; +begin + Result := Name; + if AttributeType = atSingle then + Exit; + Result := Result + '="' + Escape(Value) + '"'; +end; + +constructor TXmlAttribute.Create; +begin + AttributeType := atSingle; +end; + +class function TXmlAttribute.Escape(const Value: String): String; +begin + Result := ReplaceStr(Value, '&', '&'); + Result := ReplaceStr(Result, '<', '<'); + Result := ReplaceStr(Result, '>', '>'); + Result := ReplaceStr(Result, '"', '"'); +end; + +procedure TXmlAttribute.SetValue(const Value: String); +begin + FValue := Value; + AttributeType := atValue; +end; + +{ TXmlStreamReader } + +procedure TXmlStreamReader.FillBuffer; +var + TempEncoding: TEncoding; +begin + TempEncoding := CurrentEncoding; + FillBuffer(TempEncoding); + if TempEncoding <> CurrentEncoding then + TRttiContext.Create.GetType(TStreamReader).GetField('FEncoding').SetValue(Self, TempEncoding) +end; + +function TXmlStreamReader.FirstChar: String; +begin + if PrepareBuffer(1) then + Result := FBufferedData.Chars[0] + else + Result := ''; +end; + +procedure TXmlStreamReader.IncCharPos(Value: Integer); +begin + if PrepareBuffer(Value) then + FBufferedData.Remove(0, Value); +end; + +function TXmlStreamReader.IsUppercaseText(const Value: String): Boolean; +var + ValueLength: Integer; + Text: String; +begin + Result := False; + ValueLength := Length(Value); + + if PrepareBuffer(ValueLength) then + begin + Text := FBufferedData.ToString(0, ValueLength); + if Text = Value then + begin + FBufferedData.Remove(0, ValueLength); + Result := True; + end; + end; +end; + +function TXmlStreamReader.PrepareBuffer(Value: Integer): Boolean; +begin + Result := False; + + if not Assigned(FBufferedData) then + Exit; + + if (FBufferedData.Length < Value) and (not FNoDataInStream) then + FillBuffer; + + Result := (FBufferedData.Length >= Value); +end; + +function TXmlStreamReader.ReadText(const StopChars: String; Options: TExtractTextOptions): String; +var + NewLineIndex: Integer; + PostNewLineIndex: Integer; + StopChar: Char; + Found: Boolean; + TempIndex: Integer; + StopCharLength: Integer; + PrevLength: Integer; +begin + Result := ''; + if not Assigned(FBufferedData) then + Exit; + NewLineIndex := 0; + PostNewLineIndex := 0; + StopCharLength := Length(StopChars); + + while True do + begin + // if we're searching for a string then assure the buffer is wide enough + if (etoStopString in Options) and (NewLineIndex + StopCharLength > FBufferedData.Length) and + (not FNoDataInStream) then + FillBuffer; + + if NewLineIndex >= FBufferedData.Length then + begin + if FNoDataInStream then + begin + PostNewLineIndex := NewLineIndex; + Break; + end + else + begin + PrevLength := FBufferedData.Length; + FillBuffer; + // Break if no more data + if (FBufferedData.Length = 0) or (FBufferedData.Length = PrevLength) then + Break; + end; + end; + + if etoStopString in Options then + begin + if NewLineIndex + StopCharLength - 1 < FBufferedData.Length then + begin + Found := True; + TempIndex := NewLineIndex; + for StopChar in StopChars do + if FBufferedData[TempIndex] <> StopChar then + begin + Found := False; + Break; + end + else + Inc(TempIndex); + + if Found then + begin + if etoDeleteStopChar in Options then + PostNewLineIndex := NewLineIndex + StopCharLength + else + PostNewLineIndex := NewLineIndex; + Break; + end; + end; + end + else + begin + Found := False; + for StopChar in StopChars do + if FBufferedData[NewLineIndex] = StopChar then + begin + if etoDeleteStopChar in Options then + PostNewLineIndex := NewLineIndex + 1 + else + PostNewLineIndex := NewLineIndex; + Found := True; + Break; + end; + if Found then + Break; + end; + + Inc(NewLineIndex); + end; + + if NewLineIndex > 0 then + Result := FBufferedData.ToString(0, NewLineIndex); + FBufferedData.Remove(0, PostNewLineIndex); +end; + +end. diff --git a/source/about.dfm b/source/about.dfm index 9f115e3e8..79659877c 100644 --- a/source/about.dfm +++ b/source/about.dfm @@ -3,28 +3,26 @@ object AboutBox: TAboutBox Top = 105 BorderStyle = bsDialog Caption = 'About' - ClientHeight = 315 - ClientWidth = 481 + ClientHeight = 371 + ClientWidth = 471 Color = clBtnFace Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText - Font.Height = -11 + Font.Height = -12 Font.Name = 'Tahoma' Font.Style = [] FormStyle = fsStayOnTop - OldCreateOrder = True Position = poOwnerFormCenter OnShow = FormShow DesignSize = ( - 481 - 315) - PixelsPerInch = 96 - TextHeight = 13 + 471 + 371) + TextHeight = 14 object lblAppName: TLabel Left = 117 Top = 8 - Width = 56 - Height = 13 + Width = 64 + Height = 14 Caption = 'lblAppName' PopupMenu = popupLabels Transparent = True @@ -33,8 +31,8 @@ object AboutBox: TAboutBox object lblAppVersion: TLabel Left = 117 Top = 43 - Width = 64 - Height = 13 + Width = 73 + Height = 14 Caption = 'lblAppVersion' PopupMenu = popupLabels Transparent = True @@ -42,9 +40,9 @@ object AboutBox: TAboutBox end object lblAppCompiled: TLabel Left = 117 - Top = 62 - Width = 72 - Height = 13 + Top = 63 + Width = 82 + Height = 14 Caption = 'lblAppCompiled' PopupMenu = popupLabels Transparent = True @@ -264,1098 +262,26 @@ object AboutBox: TAboutBox Transparent = True OnClick = OpenURL end - object imgDonate: TImage - Left = 117 - Top = 152 - Width = 250 - Height = 45 - Cursor = crHandPoint - Hint = - 'Send an arbitrary amount as donation to the author - per PayPal ' + - '(also supports credit cards)' - AutoSize = True - Picture.Data = { - 07544269746D617066840000424D66840000000000003600000028000000FA00 - 00002D000000010018000000000030840000C40E0000C40E0000000000000000 - 0000FFFFFFD2E4D92B583D082111071C0E071C0E071C0E071C0E071C0E071C0E - 071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C - 0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E07 - 1C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E - 071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C - 0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E07 - 1C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E - 071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C - 0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E07 - 1C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E - 071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C - 0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E07 - 1C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E - 071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C - 0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E07 - 1C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E - 071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C - 0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E07 - 1C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E - 071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C - 0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E07 - 1C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E - 071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C - 0E071C0E092413376649E8F1EBFFFFFF70FFC6DDCF0216090000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000072612E8F1EB - 43FF1E4B2F000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000003666484EFF000D050000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000092614 - B4FF000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000000000071C0EB5FF0000000000000000000000000017 - 0900A44100A44100A44100A44100A44100A44100A44100A44100A44100A44100 - A44100A44100A44100A44100A44100A44100A44100A44100A44100A44100A441 - 00A44100A44100A44100A44100A44100A44100A44100A44100A44100A44100A4 - 4100A44100A44100A44100A44100A44100A44100A44100A44100A44100A44100 - A44100A44100A44100A44100A44100A44100A44100A44100A44100A44100A441 - 00A44100A44100A44100A44100A44100A44100A44100A44100A44100A44100A4 - 4100A44100A44100A44100A44100A44100A44100A44100A44100A44100A44100 - A44100A44100A44100A44100A44100A44100A44100A44100A44100A44100A441 - 00A44100A44100A44100A44100A44100A44100A44100A44100A44100A44100A4 - 4100A44100A44100A44100A44100A44100A44100A44100A44100A44100A44100 - A44100A44100A44100A44100A44100A44100A44100A44100A44100A44100A441 - 00A44100A44100A44100A44100A44100A44100A44100A44100A44100A44100A4 - 4100A44100A44100A44100A44100A44100A44100A44100A44100A44100A44100 - A44100A44100A44100A44100A44100A44100A44100A44100A44100A44100A441 - 00A44100A44100A44100A44100A44100A44100A44100A44100A44100A44100A4 - 4100A44100A44100A44100A44100A44100A44100A44100A44100A44100A44100 - A44100A44100A44100A44100A44100A44100A44100A44100A44100A44100A441 - 00A44100A44100A44100A44100A44100A44100A44100A44100A44100A44100A4 - 4100A44100A44100A44100A44100A44100A44100A44100A44100A44100A44100 - A44100A44100A44100A44100A44100A44100A44100A44100A44100A44100A441 - 00A44100A44100A44100A44100A44100A44100A44100A44100A44100A44100A4 - 4100A44100A44100A44100A44100A44100A44100A44100A44100A44100A44100 - A44100A44100A44100A44100A44100A13F000000000000000000000000071C0E - 43FF00000000000000000000000000170900A44200A44200A44200A44200A442 - 00A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200A4 - 4200A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200 - A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200A442 - 00A44200A4429EDCB73AB86C00A44200A44200A44236B76AA3DEBA00A44200A4 - 4200A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200 - A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200A442 - 00A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200A4 - 4200A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200 - A44214AB508CD5A9B3E3C69BDBB42EB46400A44200A44200A44200A44200A442 - 00A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200A4 - 4200A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200 - A44200A44200A44200A44200A44200A44200A44200A44200A44200A44207A647 - 01A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200A4 - 4200A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200 - A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200A442 - 00A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200A4 - 4200A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200 - A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200A442 - 00A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200A4 - 4200A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200 - A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200A442 - 00A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200A1 - 40000000000000000000000000071C0F44FF0000000000000000000000000017 - 0900A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200 - A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200A442 - 00A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200A4 - 4200A44200A44200A44200A44200A44200A44200A442E6F6EC58C38300A44200 - A44200A44253C17FECF8F000A44200A44200A44200A44200A44200A44200A442 - 00A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200A4 - 4200A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200 - A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200A442 - 00A44200A44200A44200A44200A44200A44276CE99D3EFDE20AF5979CF9BE2F4 - E902A44300A44200A44200A44200A44200A44200A44200A44200A44200A44200 - A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200A442 - 00A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200A4 - 4200A44200A44201A4426DCA92EBF7F017AC5300A44200A44200A44200A44200 - A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200A442 - 00A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200A4 - 4200A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200 - A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200A442 - 00A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200A4 - 4200A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200 - A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200A442 - 00A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200A4 - 4200A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200 - A44200A44200A44200A44200A44200A140000000000000000000000000071C0F - 44FF00000000000000000000000000170900A54200A54200A54200A54200A542 - 00A54200A54200A54200A54200A54200A54200A54200A54200A54200A54200A5 - 4200A54200A54200A54200A54200A54200A54200A54200A54200A54200A54200 - A54200A54255C381D7F0E1E7F6EDA2DEBA0DA94B18AD53CAECD7DEF3E67ED19F - A1DDB900A542E6F6ECB7E5C9E6F6ECB5E4C80EA94C53C27FF3FAF6B5E4C8E5F5 - EB69CA8F00A54245BD75D2EFDDEAF7EFA9E0BF11AB4E24B15CC0E8D00BA84A00 - A54211AB4EC9EBD6E3F5EA19AD5400A54200A54275CE987AD09C00A5427DD19E - 71CC9500A54286D4A568C98F1DAF57CAECD7E0F4E897DAB184D3A30AA849C2E9 - D122B15B4DC07BBDE7CE17AD53C3E9D21EAF5865C88C8AD5A800A5425FC68890 - D7AC2AB361F1FAF4A1DDB9CCEDD9D6F0E001A54200A54200A5427FD1A07DD19E - 00A54200A542AFE2C34EC07B02A54391D8ADE5F5EBE3F5EA80D2A000A542BDE7 - CE31B6661CAE56C7EBD5E2F4E988D5A6A5DFBC00A542ACE1C143BC7354C280D7 - F0E1E8F6EDA2DEBA0EA94C01A54275CE98D9F1E2EBF7F0CEEDDAE7F6ED49BE78 - 2AB361C5EAD4C5EAD4C5EAD440BB7100A54200A54275CE9893D8AED7F0E1D5F0 - DF33B76700A54279CF9BE0F4E8E7F6ED9BDBB400A54257C382E6F6EC98DAB22F - B564DCF2E5C7EBD506A7469ADBB4E7F6EDE1F4E874CD9707A747C2E9D126B25E - 00A54200A54200A5420CA94AB9E6CBE6F6EC97DAB1A0DDB801A542AFE2C33EBA - 6F00A542A9E0BF46BD7510AA4DBBE7CCE6F6EC89D5A7B8E5CA00A54200A54200 - A54254C2809BDBB4C8EBD6E0F4E851C17E00A5425AC484D8F1E2EBF7F0B9E6CB - 06A74636B86ADEF3E6C0E8D016AC52CDEDD9DFF3E710AA4D7DD19EE1F4E8E6F6 - EC97DAB100A542A7DFBD47BE7600A54200A54200A54200A54200A54200A54200 - A54200A54200A54200A54200A54200A54200A54200A54200A54200A54200A542 - 00A54200A54200A54200A54200A54200A54200A54200A54200A54200A54200A2 - 40000000000000000000000000071C0F44FF0000000000000000000000000018 - 0900A64200A64200A64200A64200A64200A64200A64200A64200A64200A64200 - A64200A64200A64200A64200A64200A64200A64200A64200A64200A64200A642 - 00A64200A64200A64200A64200A64200A64200A64264C88C4BC07940BC71E8F6 - ED7ED19F6DCC92ECF8F043BD73C6EBD4D5F0DF00A642E6F6ECB4E4C744BD74EE - F9F272CD9653C27FFCFDFC64C88C86D4A5F6FBF811AB4EE3F5EA8BD6A915AD51 - CDEDD98DD7AA32B767FBFDFC10AB4D00A6424ABF78FBFDFC42BD720AA94900A6 - 4200A6429CDCB5A3DEBA00A642A7E0BD98DBB200A642B2E4C58BD6A96ACA90DE - F3E614AC50B6E5C8AFE3C30FAB4DFFFFFF42BD72E5F5EB7FD2A014AC50FFFFFF - 2BB56187D5A6B7E5C900A64280D2A0BFE8CF43BD73E9F7EE7BD09D56C48110AB - 4D00A64200A64200A642ABE1C0A9E0BF00A64200A642E8F6ED6CCB924FC17CF2 - FAF52AB46113AC5033B76700A642FAFDFB45BE758BD6A9DDF3E53EBB6FC2E9D1 - DAF2E300A642E3F5EA5CC68663C88B4BC07940BC71E8F6ED7ED19F54C380FEFE - FE70CD9536B86A9EDDB7F1FAF419AE543DBB6FFEFEFE6ACA905AC5841BAF5600 - A64200A6429ADBB4E1F4E845BE75BEE8CEBDE7CE2EB664FBFDFC41BC720FAB4D - 38B96B00A642B3E4C6B2E4C52AB4617ED19FDBF2E436B86A5EC687EAF7EF24B2 - 5C15AD5130B6650AA949FFFFFF36B86A00A64200A64200A64245BE75F5FBF71D - B05797DAB1D4EFDF02A643E6F6EC55C38100A642DFF3E75FC78872CD96ECF8F0 - 42BD72B1E3C5F3FAF600A64200A64200A64271CD95F4FBF653C27F9DDCB6E3F5 - EA13AC50F4FBF667C98E0CAA4A39B96C04A74488D5A6D3EFDE34B86853C27FF5 - FBF741BC723ABA6CFCFDFC3BBA6D0FAB4D37B96A00A642DCF2E561C78900A642 - 00A64200A64200A64200A64200A64200A64200A64200A64200A64200A64200A6 - 4200A64200A64200A64200A64200A64200A64200A64200A64200A64200A64200 - A64200A64200A64200A64200A64200A340000000000000000000000000071C0F - 44FF00000000000000000000000000180900A64200A64200A64200A64200A642 - 00A64200A64200A64200A64200A64200A64200A64200A64200A64200A64200A6 - 4200A64200A64200A64200A64200A64200A64200A64200A64200A64200A64200 - A64200A64200A64201A64239B96CECF8F08ED7AB7DD19ECDEDD900A64273CE97 - D5F0DF00A642E6F6EC58C48300A642B7E5C99BDCB453C27FECF8F000A64223B2 - 5BFFFFFF42BD72FDFEFD45BE7500A6428DD7AABDE7CE32B767FBFDFC10AB4D00 - A64250C17DF5FBF704A74400A64200A64200A6429CDCB5A3DEBA00A642A7E0BD - 98DBB200A642B2E4C58BD6A926B35EDCF2E5B9E6CBDBF2E4AFE3C30FAB4DFFFF - FFCAECD7CFEEDB07A84714AC50FFFFFF2BB56187D5A6B7E5C900A64280D2A0BF - E8CF0EAA4CF3FAF6B7E5C9E5F5EB39B96C00A64200A64200A642ABE1C0ACE2C1 - 08A84708A847E9F7EE6CCB9276CF99F1FAF4ADE2C2ADE2C29CDCB502A643FAFD - FB45BE75ABE1C09FDDB700A6426FCC94DAF2E300A642E3F5EA5CC68600A64201 - A64238B96BECF8F08FD7AB9DDCB6CDEDD900A64200A6420CAA4AF4FBF666C98D - 3DBB6FFDFEFD18AE5300A64200A64200A64200A6429ADBB4A3DEBA00A6426BCB - 91E7F6ED55C381FBFDFCAEE2C2ADE2C2AAE1C00AA949B9E6CB8FD7AB00A64287 - D5A6C0E9D000A64285D4A4ECF8F0ADE2C2ADE2C294D9AF0AA949FFFFFF36B86A - 00A64200A64200A64212AC4FCDEDD9C3EAD2CFEEDBD4EFDF02A643E6F6EC55C3 - 8100A642DFF3E75FC78892D8AEB8E6CA00A64256C481F3FAF600A64200A64200 - A64271CD95CEEDDA00A64240BC71FEFEFE3FBB70FFFFFFB7E5C9ADE2C2ACE2C1 - 26B35E8ED7ABBAE6CB00A6425DC686EDF8F100A6425AC584F9FCFAADE2C2ADE2 - C2A8E0BE0AA949DCF2E561C78900A64200A64200A64200A64200A64200A64200 - A64200A64200A64200A64200A64200A64200A64200A64200A64200A64200A642 - 00A64200A64200A64200A64200A64200A64200A64200A64200A64200A64200A3 - 40000000000000000000000000071C0F5CFF0000000000000000000000000018 - 0900A64300A64300A64300A64300A64300A64300A64300A64300A64300A64300 - A64300A64300A64300A64300A64300A64300A64300A64300A64300A64300A643 - 00A64300A64300A64300A64300A64300A64300A64311AB4FB5E5C8FEFEFECCED - D91DB0587DD19FCDEDDA00A64373CE97D5F0E000A643E6F6EC86D4A508A848D7 - F1E18CD6AA53C280F6FBF824B25D49BF78FFFFFF24B25DEDF8F166C98E00A643 - ADE2C2ADE2C232B767FEFEFE49BF7804A74550C17DF5FBF704A74500A64300A6 - 4300A6439CDCB6C7EBD509A949BFE8CFBDE7CE09A949CAECD789D5A806A84716 - AD531CAF57A4DFBBADE2C20FAB4EFFFFFFA8E0BED1EEDD11AB4F14AC51FFFFFF - 2BB56287D5A6D6F0E00EAA4D9ADBB4BBE7CC2EB664EBF8F004A74599DBB382D3 - A200A64300A64300A643ABE1C1FFFFFFFFFFFFFFFFFFFFFFFF6CCB9259C584E9 - F7EE25B25E6DCC93E4F5EB02A644FAFDFB45BE7597DAB2C5EAD406A84796DAB1 - DAF2E300A643E3F5EA5CC68611AB4FB4E4C7FEFEFECCEDD91DB058ADE2C2B9E6 - CB00A64300A64300A643E2F4E97ED19F3DBB6FFDFEFD18AE5400A64300A64300 - A64300A6439ADBB4C7EBD50AA94A93D9AFD6F0E038B96CF9FCFA32B76751C27E - FBFDFC0CAA4BB9E6CB8FD7AC00A64387D5A6C0E9D000A64368CA8FDEF3E624B2 - 5D7AD09CD7F1E10AA94AFFFFFF71CD9604A74500A64300A64301A64319AE5518 - AE5484D4A4D2EFDD02A644E6F6EC82D3A20CAA4BEFF9F35CC6867ED19FDAF2E3 - 0AA94A7DD19FF3FAF600A64300A64300A64371CD96E6F6EC16AD5368CA8FF5FB - F71FB059F9FCFA51C27E2FB665FBFDFC33B7688ED7ABBAE6CC00A6435DC687ED - F8F100A6433EBB70F9FCFA2DB56455C381F6FBF80CAA4BDCF2E59BDCB505A746 - 00A64300A64300A64300A64300A64300A64300A64300A64300A64300A64300A6 - 4300A64300A64300A64300A64300A64300A64300A64300A64300A64300A64300 - A64300A64300A64300A64300A64300A341000000000000000000000000071C0F - A5FF00000000000000000000000000180900A74300A74300A74300A74300A743 - 00A74300A74300A74300A74300A74300A74300A74300A74300A74300A74300A7 - 4300A74300A74300A74300A74300A74300A74300A74300A74300A74300A74300 - A74300A7437AD19CF2FAF550C27D03A84500A74379D09CCAECD700A74370CD95 - D2EFDD00A743E3F5EAC5EAD4EEF9F2F3FAF630B76650C27DDBF2E4DFF3E7F7FC - F9B7E6C902A74467CA8EEEF9F2C8ECD6EFF9F33FBC7130B766ECF8F0DCF2E5AA - E1C0E6F6ECFEFEFEE6F6EC1DB15800A74300A7439ADCB4CCEDD9EBF8F0FBFDFC - A8E0BEECF8F0FBFDFC46BF761DB158DFF3E7C2E9D2F3FAF668CA8F0FAC4EFFFF - FF33B868B1E4C5B6E5C914AD51FDFEFD29B56185D4A5D0EEDCE8F7EEFCFDFC73 - CE9709AA49D1EFDDA8E0BEEBF8F0EBF8F00BAA4B00A74300A743ABE2C1B1E4C5 - 19AF5519AF55EAF7EF6CCC920AAA4AC9ECD7D2EFDDE9F7EE7AD19C00A743F7FC - F942BD7333B868F2FAF5EEF9F2E9F7EEDAF2E300A743E0F4E859C5847AD19CF3 - FAF64FC27D03A84500A74390D8ADD7F1E101A74300A7430DAB4CF5FBF76BCB91 - 3DBC6FFDFEFD18AF5400A74300A74300A74300A7439ADCB4E6F6ECEAF7EFFCFD - FC70CD9502A744AFE3C4DAF2E3E2F4E999DBB363C98BF8FCF9F4FBF6E6F6ECF3 - FAF6F9FCFAD1EFDD10AC4ED1EFDDCFEEDBEBF8F06CCC9209AA49F8FCF9D1EFDD - C5EAD400A74300A74307A948D5F0E0C4EAD3ECF8F08CD7AA02A744E4F5EBC6EB - D4EFF9F3F1FAF421B25B21B25BEAF7EFEFF9F3E8F7EEF3FAF600A74300A74300 - A74371CD96EEF9F2E6F6ECFAFDFB9ADCB400A74388D5A7E4F5EBD7F1E1BFE8CF - 41BD72F4FBF6F8FCF9E6F6ECEFF9F3FDFEFDE5F6EB16AE53B3E4C6D9F1E2E3F5 - EA94DAB000A743DAF2E3CFEEDBE7F6ED07A94800A74300A74300A74300A74300 - A74300A74300A74300A74300A74300A74300A74300A74300A74300A74300A743 - 00A74300A74300A74300A74300A74300A74300A74300A74300A74300A74300A4 - 41000000000000000000000000071C0F74FF0000000000000000000000000018 - 0900A74300A74300A74300A74300A74300A74300A74300A74300A74300A74300 - A74300A74300A74300A74300A74300A74300A74300A74300A74300A74300A743 - 00A74300A74300A74300A74300A74300A74300A74374CF98E6F6EC2DB66458C5 - 8320B25A06A9470BAA4B00A74305A8460CAB4B00A7430DAB4C03A8452DB66419 - AF5500A74304A8450BAA4B0FAC4E33B86806A94700A74300A74319AF5537B96B - 11AC4F00A74302A7440DAB4C15AE5220B25A5AC685F6FBF814AD5101A74300A7 - 4300A74308A94806A94720B25A24B35D00A74323B35C22B25C00A74300A7430C - AB4B35B96A22B25C00A7430FAC4EFFFFFF30B76604A8450EAB4D05A84653C380 - 09AA4907A94807A9481BB0562BB56201A74300A74308A94834B86919AF5510AC - 4E00A74300A74300A743ABE2C1A9E1BF00A74300A743E8F7EE6CCC9200A74305 - A84630B76622B25C00A74301A7434FC27D11AC4F00A74316AE532FB76571CD96 - DAF2E300A74348BF7818AF5473CE97E6F6EC2CB66357C58320B25A31B767F9FC - FA95DAB04EC17CA9E1BFF4FBF61FB1593DBC6FFDFEFD18AF5400A74300A74300 - A74300A7439ADCB4A3DFBB20B25A29B56101A74300A74302A7442BB56229B561 - 02A74406A947BEE8CF96DAB110AC4E8ED8ABC4EAD30EAB4D00A74306A94732B8 - 671FB15900A74300A7430EAB4D0CAB4B28B46000A74300A74300A74307A94831 - B76729B56102A74400A7430DAB4C03A8452EB66416AE5300A74300A74311AC4F - 32B8675AC685F3FAF600A74300A74300A74371CD96CEEEDA16AE5330B76603A8 - 4500A74301A74323B35C30B76605A84604A84595DAB0BFE8CF10AC4E68CA8FEE - F9F210AC4E01A74303A8452CB66328B46001A74300A7430DAB4C07A9482FB765 - 00A74300A74300A74300A74300A74300A74300A74300A74300A74300A74300A7 - 4300A74300A74300A74300A74300A74300A74300A74300A74300A74300A74300 - A74300A74300A74300A74300A74300A441000000000000000000000000071C0F - 44FF00000000000000000000000000180900A84300A84300A84300A84300A843 - 00A84300A84300A84300A84300A84300A84300A84300A84300A84300A84300A8 - 4300A84300A84300A84300A84300A84300A84300A84300A84300A84300A84300 - A84300A8430BAB4B96DBB1D1EFDDB0E4C416AF5300A84300A84300A84300A843 - 00A84300A84300A84300A84300A84300A84300A84300A84300A84300A84300A8 - 4300A84300A84300A84300A84300A84300A84300A84300A84300A84300A84300 - A84317AF5352C37F01A84300A84300A84300A84300A84300A84300A84300A843 - 00A84300A84300A84300A84300A84300A84300A84300A84300A8430FAD4EFFFF - FF30B86600A84300A84324B45DF8FCF933B96800A84300A84300A84300A84300 - A84300A84300A84300A84300A84300A84300A84300A84300A8436FCD946DCD93 - 00A84300A84398DBB344BF7500A84300A84300A84300A84300A8430FAD4EF4FB - F64DC27B00A84300A84300A8436ECD94DAF2E306AA47E7F6ED63C98B0BAB4B95 - DAB0D2EFDDB0E4C416AF5300A84341BE72B5E5C8D4F0DFB3E5C63DBC6F00A843 - 25B45EA8E1BE0EAC4D00A84300A84300A84300A8439ADCB4A3DFBB00A84300A8 - 4300A84300A84300A84300A84300A84300A84300A8433CBC6F2DB76400A84354 - C4807DD29F00A84300A84300A84300A84300A84300A84300A84300A84300A843 - 00A84300A84300A84300A84300A84300A84300A84300A84300A84300A84300A8 - 4300A84300A84300A84300A84300A84300A84355C581F3FAF600A84300A84300 - A84371CE96CEEEDA00A84300A84300A84300A84300A84300A84300A84300A843 - 00A8432DB7643CBC6F00A84338BB6C9BDCB500A84300A84300A84300A84300A8 - 4300A84300A84300A84300A84300A84300A84300A84300A84300A84300A84300 - A84300A84300A84300A84300A84300A84300A84300A84300A84300A84300A843 - 00A84300A84300A84300A84300A84300A84300A84300A84300A84300A84300A5 - 41000000000000000000000000071D0FD3FF0000000000000000000000000018 - 0900A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400 - A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A944 - 00A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A9 - 4400A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400 - A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A944 - 00A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A9 - 4400A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400 - A94400A94400A94400A94401A94425B55F04AA4600A94400A94400A94400A944 - 00A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A9 - 4400A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400 - A94400A94400A94400A94400A94400A94400A94400A94400A94400A9440CAD4C - 1DB25900A94400A94400A94400A94400A94400A94400A94400A94400A94400A9 - 4400A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400 - A94400A94414AF5216B05400A94400A94400A94400A94400A94400A94400A944 - 00A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A9 - 4400A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400 - A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A944 - 00A94408AB4921B45C00A94400A94400A9440DAD4D1CB25800A94400A94400A9 - 4400A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400 - A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A944 - 00A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A9 - 4400A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400 - A94400A94400A94400A94400A94400A642000000000000000000000000071D0F - FFFF00000000000000000000000000180900A94400A94400A94400A94400A944 - 00A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A9 - 4400A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400 - A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A944 - 00A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A9 - 4400A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400 - A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A944 - 00A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A9 - 4400A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400 - A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A944 - 00A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A9 - 4400A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400 - A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A944 - 00A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A9 - 4400A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400 - A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A944 - 00A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A9 - 4400A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400 - A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A944 - 00A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A9 - 4400A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400 - A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A944 - 00A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A6 - 42000000000000000000000000071D0F75FF0000000000000000000000000018 - 0900A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400 - A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A944 - 00A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A9 - 4400A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400 - A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A944 - 00A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A9 - 4400A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400 - A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A944 - 00A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A9 - 4400A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400 - A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A944 - 00A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A9 - 4400A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400 - A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A944 - 00A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A9 - 4400A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400 - A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A944 - 00A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A9 - 4400A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400 - A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A944 - 00A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A9 - 4400A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400 - A94400A94400A94400A94400A94400A642000000000000000000000000071D0F - 45FF00000000000000000000000000180900AA4400AA4400AA4400AA4400AA44 - 00AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA - 4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400 - AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA44 - 00AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA - 4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400 - AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA44 - 00AA4400AA4400AA4403AB461FB45A21B55C21B55C21B55C21B55C21B55C16B1 - 5406AC4800AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400 - AA4400AA4400AA4400AA4402AA4531BA675EC98872D0976DCE9351C57F1BB357 - 00AA4400AA4400AA4400AA4400AA4400AA4400AA4415B15344C07549C2792CB8 - 6400AA4400AA4400AA4400AA4400AA440FAF4F41BF734AC27A32BA6801AA4400 - AA4400AA4400AA4400AA4409AD4A46C1776DCE936ECE9448C2780AAD4B00AA44 - 1BB35748C27844C0750EAE4E00AA4400AA4400AA4400AA4400AA4406AC4844C0 - 756DCE936FCF954EC47D10AF5004AB4708AC490CAE4C0EAE4E10AF4F16B15447 - C1776DCE937FD4A17ED4A06ACD9248C27925B55E20B45B20B45B21B55C23B55D - 23B55D23B55D23B55D23B55D23B55D23B55D22B55C20B45B20B45B20B45B1FB4 - 5A1EB45A1CB3581AB25718B25516B15414B05212B05110AF4F0EAE4E0AAD4B06 - AC4905AB4702AA4500AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA44 - 00AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA - 4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400 - AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA44 - 00AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400A7 - 42000000000000000000000000071D0F45FF0000000000000000000000000018 - 0900AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400 - AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA44 - 00AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA - 4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400 - AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA44 - 00AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA - 4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA449ADDB4FFFFFFFF - FFFFFFFFFFFFFFFFFFFFFFFFFFFFFCFEFCF6FCF8D3F0DE95DBB13CBE7000AA44 - 00AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4458C784DAF2E3FFFF - FFFFFFFFFFFFFFFFFFFFFFFFFFFCFEFCB3E5C729B76200AA4400AA4400AA4400 - AA4400AA44B5E6C8FFFFFFFFFFFFFDFEFD18B25500AA4400AA4400AA4400AA44 - 99DDB4FFFFFFFFFFFFFFFFFF32BA6800AA4400AA4400AA4452C580E7F7EDFFFF - FFFFFFFFFFFFFFFFFFFFE9F7EE5FC989AEE3C3FFFFFFFFFFFF85D6A519B2561E - B45A23B55D28B7614DC37CE0F4E8FFFFFFFFFFFFFFFFFFFFFFFFDDF3E642BF74 - 42C07442C07444C07698DCB3EDF9F1FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF - FFF2FAF5B4E6C847C17742C07442C07442C07442C07442C07442C07442C07442 - C07442C07442C07442C07442C07442C07442C07442C07442C07442C07442C074 - 42C07442C07442C07442C07442C07442C07441BF7340BF723EBE713BBD6F37BC - 6C34BB6A30BA672BB86326B65F21B55C1CB35817B15412B0510DAE4D07AC4902 - AA4500AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA44 - 00AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA - 4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400 - AA4400AA4400AA4400AA4400AA4400A742000000000000000000000000071D0F - EEFF00000000000000000000000000180900AB4400AB4400AB4400AB4400AB44 - 00AB4400AB4400AB4400AB4400AB4400AB4400AB4400AB4400AB4400AB4400AB - 4400AB4400AB4400AB4400AB4400AB4400AB4400AB4400AB4400AB4400AB4400 - AB4400AB4400AB4400AB4400AB4400AB4400AB4400AB4400AB4400AB4400AB44 - 00AB4400AB4400AB4400AB4400AB4400AB4400AB4400AB4400AB4400AB4400AB - 4400AB4400AB4400AB4400AB4400AB4400AB4400AB4400AB4400AB4400AB4400 - AB4400AB4400AB4400AB4400AB4400AB4400AB4400AB4400AB4400AB4400AB44 - 00AB4400AB4400AB44C4EBD3FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF - FFFFFFFFFFFFFFFFFFFFFFFFFFBCE8CD21B55C00AB4400AB4400AB4400AB4400 - AB4400AB4481D5A2FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF - FFFFFFF3FBF644C17500AB4400AB4400AB4400AB44BBE8CDFFFFFFFFFFFFFEFE - FE1CB45800AB4400AB4400AB4400AB449FDFB8FFFFFFFFFFFFFFFFFF36BC6B01 - AB4403AB4641C073FAFDFBFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF - F4FBF7FFFFFFFFFFFFA0DFB942C07442C07442C07443C075D6F1E1FFFFFFFFFF - FFFFFFFFFFFFFFFFFFFFF6FCF848C27842C07444C075C2EAD2FFFFFFFFFFFFFF - FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF6ACD9142C07442C074 - 42C07442C07442C07442C07442C07442C07442C07442C07442C07442C07442C0 - 7442C07442C07442C07442C07442C07442C07442C07442C07442C07442C07442 - C07442C07442C07442C07442C07442C07442C07442C07442C07442C07442C074 - 42C07442C07442C07442C07442C07442C0743DBF7037BD6C30BA672AB86223B6 - 5D1DB45917B2540FAF4F07AD4901AB4500AB4400AB4400AB4400AB4400AB4400 - AB4400AB4400AB4400AB4400AB4400AB4400AB4400AB4400AB4400AB4400AB44 - 00AB4400AB4400AB4400AB4400AB4400AB4400AB4400AB4400AB4400AB4400A8 - 42000000000000000000000000071D0F75FF0000000000000000000000000018 - 0A00AB4500AB4500AB4500AB4500AB4500AB4500AB4500AB4500AB4500AB4500 - AB4500AB4500AB4500AB4500AB4500AB4500AB4500AB4500AB4500AB4500AB45 - 00AB4500AB4500AB4500AB4500AB4500AB4500AB4500AB4500AB4500AB4500AB - 4500AB4500AB4500AB4500AB4500AB4500AB4500AB4500AB4500AB4500AB4500 - AB4500AB4500AB4500AB4500AB4500AB4500AB4500AB4500AB4500AB4500AB45 - 00AB4500AB4500AB4500AB4500AB4500AB4500AB4500AB4500AB4500AB4500AB - 4500AB4500AB4500AB4500AB4500AB4500AB4500AB4500AB45C4EBD3FFFFFFFF - FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF - E8F7EE2DB96500AB4500AB4500AB4500AB453FBF72FDFEFDFFFFFFFFFFFFFFFF - FFE1F5E9A4E1BCA6E1BEE6F6ECFFFFFFFFFFFFFFFFFFECF8F11AB35700AB4500 - AB4500AB45BBE8CDFFFFFFFFFFFFFEFEFE1CB45900AB4500AB4502AB4709AD4B - A6E1BDFFFFFFFFFFFFFFFFFF5ECA893BBE7041C074C2EAD2FFFFFFFFFFFFFFFF - FFC7ECD67FD4A187D7A7D4F0E0FFFFFFFFFFFFFFFFFFFFFFFFA0DFB942C07542 - C07542C0755EC989FFFFFFFFFFFFFFFFFFFFFFFFE4F6EBDCF3E6EDF9F245C177 - 42C07592DAAFFFFFFFFFFFFFFFFFFFFCFEFDC9EDD89EDEB897DCB3A6E1BECBED - D9F6FCF9FFFFFF6CCE9342C07542C07542C07542C07542C07542C07542C07542 - C07542C07542C07542C07542C07542C07542C07542C07542C07542C07542C075 - 42C07542C07542C07542C07542C07542C07542C07542C07542C07542C07542C0 - 7542C07542C07542C07542C07542C07542C07542C07542C07542C07542C07542 - C07542C07542C07542C07542C07542C07542C07542C07542C07542C0753FBF72 - 39BD6E31BB6829B86221B55D19B35710B05006AC4901AB4500AB4500AB4500AB - 4500AB4500AB4500AB4500AB4500AB4500AB4500AB4500AB4500AB4500AB4500 - AB4500AB4500AB4500AB4500AB4500A843000000000000000000000000071D0F - 46FF00000000000000000000000000180A00AC4500AC4500AC4500AC4500AC45 - 00AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC - 4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500 - AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC45 - 00AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC - 4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500 - AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC45 - 00AC4500AC4500AC45C4EBD3FFFFFFFFFFFFFFFFFF43C17519B45719B4572BB9 - 645AC986B8E7CBFEFEFEFFFFFFFFFFFFFFFFFFDAF2E40CAF4D00AC4500AC4500 - AC45B3E6C7FFFFFFFFFFFFFFFFFFAFE4C409AE4B00AC4500AC450CAF4DB8E7CB - FFFFFFFFFFFFFFFFFF8EDAAC00AC4500AC4500AC45BBE8CDFFFFFFFFFFFFFEFE - FE3DBF712FBB6738BE6D3FC07242C175B7E7CBFFFFFFFFFFFFFFFFFF6ACE9242 - C17542C175E3F6EAFFFFFFFFFFFFF0FAF447C27842C17542C17545C277BAE8CC - FFFFFFFFFFFFFFFFFFA0DFB942C17542C17542C1757BD39EFFFFFFFFFFFFFFFF - FFCEEFDB44C17642C1754DC47D42C17542C175E6F6EDFFFFFFFFFFFFFDFEFD81 - D5A342C17542C17542C17542C17542C1754DC47D83D6A44AC37B42C17542C175 - 42C17542C17542C17542C17542C17542C17542C17542C17542C17542C17542C1 - 7542C17542C17542C17542C17542C17542C17542C17542C17542C17542C17542 - C17542C17542C17542C17542C17542C17542C17542C17542C17542C17542C175 - 42C17542C17542C17542C17542C17542C17542C17542C17542C17542C17542C1 - 7542C17542C17542C17542C17542C17542C17542C17542C17542C17542C17542 - C17542C1753DBF7135BD6B2CBA6522B75D19B4570FB04F05AD4800AC4500AC45 - 00AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500A9 - 43000000000000000000000000071D0F46FF0000000000000000000000000018 - 0A00AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500 - AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC45 - 00AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC - 4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500 - AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC45 - 00AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC - 4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC45C4EBD3FFFFFFFF - FFFFFFFFFF2FBB6700AC4500AC4500AC4500AC4501AC4565CC8EFDFEFDFFFFFF - FFFFFFFFFFFF79D39D00AC4500AC4509AE4BF4FBF6FFFFFFFFFFFFFCFEFC1DB5 - 5A00AC4500AC4500AC4500AC4520B65CFCFEFCFFFFFFFFFFFFE5F6EC20B55B29 - B96234BC6ACBEED9FFFFFFFFFFFFFEFEFE56C78442C17542C17542C17542C175 - B7E7CBFFFFFFFFFFFFFFFFFF6ACE9242C17542C175E2F5E9FFFFFFFFFFFFEBF8 - F043C17642C17542C17542C17571D097FFFFFFFFFFFFFFFFFFA0DFB942C17542 - C17542C17584D6A5FFFFFFFFFFFFFFFFFF9EDFB842C17542C17542C17542C175 - 5FCA8AFEFEFEFFFFFFFFFFFFCEEEDB42C17542C17542C17542C17542C17542C1 - 7542C17542C17542C17542C17542C17542C17542C17542C17542C17542C17542 - C17542C17542C17542C17542C17542C17542C17542C17542C17542C17542C175 - 42C17542C17542C17542C17542C17542C17542C17542C17542C17542C17542C1 - 7542C17542C17542C17542C17542C17542C17542C17542C17542C17542C17542 - C17542C17542C17542C17542C17542C17542C17542C17542C17542C17542C175 - 42C17542C17542C17542C17542C17542C17542C17542C17542C17542C17542C1 - 7542C17542C17541C1743BBF7030BB6825B85F1AB4570FB04F04AD4800AC4500 - AC4500AC4500AC4500AC4500AC4500A943000000000000000000000000071D0F - 75FF00000000000000000000000000190A00AD4500AD4500AD4500AD4500AD45 - 00AD4500AD4500AD4500AD4500AD4500AD4500AD4500AD4500AD4500AD4500AD - 4500AD4500AD4500AD4500AD4500AD4500AD4500AD4500AD4500AD4500AD4500 - AD4500AD4500AD4500AD4500AD4500AD4500AD4500AD4500AD4500AD4500AD45 - 00AD4500AD4500AD4500AD4500AD4500AD4500AD4500AD4500AD4500AD4500AD - 4500AD4500AD4500AD4500AD4500AD4500AD4500AD4500AD4500AD4500AD4500 - AD4500AD4500AD4500AD4500AD4500AD4500AD4500AD4500AD4500AD4500AD45 - 00AD4500AD4500AD45C4ECD3FFFFFFFFFFFFFFFFFF2FBC6700AD4500AD4500AD - 4500AD4500AD4500AD4593DCB0FFFFFFFFFFFFFFFFFFDFF4E703AD4700AD4528 - B962FFFFFFFFFFFFFFFFFFD2F0DE00AD4500AD4501AD450CB04D18B45625B85F - D9F2E3FFFFFFFFFFFFFFFFFF58C98542C27542C275CCEEDAFFFFFFFFFFFFFEFE - FE56C88442C27542C27542C27542C275B7E8CBFFFFFFFFFFFFFFFFFF6ACE9242 - C27542C275B9E8CCFFFFFFFFFFFFFFFFFFA3E1BC4AC47B42C27542C27571D197 - FFFFFFFFFFFFFFFFFFA0E0B942C27542C27542C27587D8A7FFFFFFFFFFFFFFFF - FF9ADEB542C27542C27542C27542C2757DD5A0FFFFFFFFFFFFFFFFFFA4E1BC42 - C27542C27542C27542C27542C27542C27542C27542C27542C27542C27542C275 - 42C27542C27542C27542C27542C27542C27542C27542C27542C27542C27542C2 - 7542C27542C27542C27542C27542C27542C27542C27542C27542C27542C27542 - C27542C27542C27542C27542C27542C27542C27542C27542C27542C27542C275 - 42C27542C27542C27542C27542C27542C27542C27542C27542C27542C27542C2 - 7542C27542C27542C27542C27542C27542C27542C27542C27542C27542C27542 - C27542C27542C27542C27542C27542C27542C27542C27542C27542C27542C275 - 42C27542C27542C27541C1743ABF6F2DBB6521B75D14B35307AF4A00AD4500AA - 43000000000000000000000000071D0F75FF0000000000000000000000000019 - 0A00AD4600AD4600AD4600AD4600AD4600AD4600AD4600AD4600AD4600AD4600 - AD4600AD4600AD4600AD4600AD4600AD4600AD4600AD4600AD4600AD4600AD46 - 00AD4600AD4600AD4600AD4600AD4600AD4600AD4600AD4600AD4600AD4600AD - 4600AD4600AD4600AD4600AD4600AD4600AD4600AD4600AD4600AD4600AD4600 - AD4600AD4600AD4600AD4600AD4600AD4600AD4600AD4600AD4600AD4600AD46 - 00AD4600AD4600AD4600AD4600AD4600AD4600AD4600AD4600AD4600AD4600AD - 4600AD4600AD4600AD4600AD4600AD4600AD4600AD4600AD46C4ECD4FFFFFFFF - FFFFFFFFFF2FBC6800AD4600AD4600AD4600AD4600AD4600AD461BB559FCFEFC - FFFFFFFFFFFFFFFFFF2DBB6600AD463CC071FFFFFFFFFFFFFFFFFFBBE9CD28B9 - 6335BE6C40C17442C27542C27542C275C6ECD5FFFFFFFFFFFFFFFFFF6CCF9342 - C27542C275CCEEDAFFFFFFFFFFFFFEFEFE56C88442C27542C27542C27542C275 - B7E8CBFFFFFFFFFFFFFFFFFF6ACE9242C27542C2755ECB8AF2FAF5FFFFFFFFFF - FFFFFFFFFBFDFCE5F6ECE0F5E8E8F7EEFFFFFFFFFFFFFFFFFFA0E0B942C27542 - C27542C27587D8A7FFFFFFFFFFFFFFFFFF9ADEB542C27542C27542C27542C275 - 89D9A9FFFFFFFFFFFFFFFFFFEFF9F3E0F5E8E0F5E8E0F5E8E0F5E8E0F5E8E0F5 - E8E0F5E8E0F5E89DDFB842C27542C27542C27542C27542C27542C27542C27542 - C27542C27542C27542C27542C27542C27542C27542C27542C27542C27542C275 - 42C27542C27542C27542C27542C27542C27542C27542C27542C27542C27542C2 - 7542C27542C27542C27542C27542C27542C27542C27542C27542C27542C27542 - C27542C27542C27542C27542C27542C27542C27542C27542C27542C27542C275 - 42C27542C27542C27542C27542C27542C27542C27542C27542C27542C27542C2 - 7542C27542C27542C27542C27542C27542C27542C27542C27542C27542C27542 - C27542C27542C27542C2753DC0722FB966000000000000000000000000071D0F - 46FF00000000000000000000000000190A00AE4600AE4600AE4600AE4600AE46 - 00AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE - 4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600 - AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE46 - 00AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE - 4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600 - AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE46 - 00AE4600AE4600AE46C4ECD4FFFFFFFFFFFFFFFFFF2FBC6800AE4600AE4600AE - 4600AE4600AE4600AE4600AE46CEEFDBFFFFFFFFFFFFFFFFFF61CC8C14B45456 - C984FFFFFFFFFFFFFFFFFFC4ECD442C27542C27542C27542C27542C27542C275 - C4ECD4FFFFFFFFFFFFFFFFFF6DD09442C27542C275CCEEDAFFFFFFFFFFFFFEFE - FE56C88442C27542C27542C27542C275B7E8CBFFFFFFFFFFFFFFFFFF6ACE9242 - C27542C27542C27562CC8CCDEEDAFCFEFDFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF - FFFFFFFFFFFFFFFFFFA0E0B942C27542C27542C27587D8A7FFFFFFFFFFFFFFFF - FF9ADEB542C27542C27542C27542C27589D8A8FFFFFFFFFFFFFFFFFFFFFFFFFF - FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFE6F7ED42C27542C275 - 42C27542C27542C27542C27542C27542C27542C27542C27542C27542C27542C2 - 7542C27542C27542C27542C27542C27542C27542C27542C27542C27542C27542 - C27542C27542C27542C27542C27542C27542C27542C27542C27542C27542C275 - 42C27542C27542C27542C27542C27542C27542C27542C27542C27542C27542C2 - 7542C27542C27542C27542C27542C27542C27542C27542C27542C27542C27542 - C27542C27542C27542C27542C27542C27542C27542C27542C27542C27542C275 - 42C27542C27542C27542C27542C27542C27542C27542C27542C27542C27540BE - 730000000000000000000000000B1F1346FF0000000000000000000000000019 - 0A00AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600 - AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE46 - 00AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE - 4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600 - AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE46 - 00AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE - 4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE46C4ECD4FFFFFFFF - FFFFFFFFFF2FBC6800AE4600AE4600AE4600AE4600AE4600AE4600AE46ABE4C1 - FFFFFFFFFFFFFFFFFF9BDFB742C2755DCA89FFFFFFFFFFFFFFFFFFD6F1E142C2 - 7542C27542C27542C27542C27542C275D4F1DFFFFFFFFFFFFFFFFFFF67CD9042 - C27542C275CCEEDAFFFFFFFFFFFFFEFEFE56C88442C27542C27542C27542C275 - B8E8CBFFFFFFFFFFFFFFFFFF6ACE9242C27542C27542C27542C27542C2755AC9 - 8683D7A59DDFB8ABE4C2AFE5C5C3EBD3FFFFFFFFFFFFFFFFFFA0E0B942C27542 - C27542C27587D8A7FFFFFFFFFFFFFFFFFF9ADEB542C27542C27542C27542C275 - 7AD49EFFFFFFFFFFFFFFFFFFD6F2E1AFE5C5AFE5C5AFE5C5AFE5C5AFE5C5EEF9 - F3FFFFFFFFFFFFE6F7ED42C27542C27542C27542C27542C27542C27542C27542 - C27542C27542C27542C27542C27542C27542C27542C27542C27542C27542C275 - 42C27542C27542C27542C27542C27542C27542C27542C27542C27542C27542C2 - 7542C27542C27542C27542C27542C27542C27542C27542C27542C27542C27542 - C27542C27542C27542C27542C27542C27542C27542C27542C27542C27542C275 - 42C27542C27542C27542C27542C27542C27542C27542C27542C27542C27542C2 - 7542C27542C27542C27542C27542C27542C27542C27542C27542C27542C27542 - C27542C27542C27542C27542C27540BE730000000000000000000000000E2015 - FFFF00000000000000000000000000190A00AE4600AE4600AE4600AE4600AE46 - 00AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE - 4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600 - AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE46 - 00AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE - 4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600 - AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE46 - 00AE4600AE4600AE46C4ECD4FFFFFFFFFFFFFFFFFF2FBC6800AE4600AE4600AE - 4609B04C1AB6582ABB643AC070B1E6C6FFFFFFFFFFFFFFFFFFA6E2BE42C27546 - C378F2FAF5FFFFFFFFFFFFF9FDFB4EC67E42C27542C27542C27542C2754AC47A - F6FCF8FFFFFFFFFFFFFCFEFD4DC57D42C27542C275CCEEDAFFFFFFFFFFFFFFFF - FF81D6A342C27542C27542C27542C275D1F0DDFFFFFFFFFFFFFFFFFF63CC8D42 - C27542C27542C27542C27542C27542C27542C27542C27542C27542C27574D299 - FFFFFFFFFFFFFFFFFF9BDEB642C27542C27542C27587D8A7FFFFFFFFFFFFFFFF - FF9ADEB542C27542C27542C27542C27558C985FEFEFEFFFFFFFFFFFFB4E7C842 - C27542C27542C27542C27542C275E4F6EBFFFFFFFFFFFFD7F2E242C27542C275 - 42C27542C27542C27542C27542C27542C27542C27542C27542C27542C27542C2 - 7542C27542C27542C27542C27542C27542C27542C27542C27542C27542C27542 - C27542C27542C27542C27542C27542C27542C27542C27542C27542C27542C275 - 42C27542C27542C27542C27542C27542C27542C27542C27542C27542C27542C2 - 7542C27542C27542C27542C27542C27542C27542C27542C27542C27542C27542 - C27542C27542C27542C27542C27542C27542C27542C27542C27542C27542C275 - 42C27542C27542C27542C27542C27542C27542C27542C27542C27542C27540BE - 730000000000000000000000000E201576FF0000000000000000000000000019 - 0A00AF4600AF4600AF4600AF4600AF4600AF4600AF4600AF4600AF4600AF4600 - AF4600AF4600AF4600AF4600AF4600AF4600AF4600AF4600AF4600AF4600AF46 - 00AF4600AF4600AF4600AF4600AF4600AF4600AF4600AF4600AF4600AF4600AF - 4600AF4600AF4600AF4600AF4600AF4600AF4600AF4600AF4600AF4600AF4600 - AF4600AF4600AF4600AF4600AF4600AF4600AF4600AF4600AF4600AF4600AF46 - 00AF4600AF4600AF4600AF4600AF4600AF4600AF4600AF4600AF4600AF4600AF - 4600AF4600AF4600AF4600AF4600AF4600AF4600AF4600AF46C4ECD4FFFFFFFF - FFFFFFFFFF32BE6915B55527BB6239C06F41C37542C37542C37542C375B4E7C8 - FFFFFFFFFFFFFFFFFFA4E2BC42C37542C375BCE9CEFFFFFFFFFFFFFFFFFFACE4 - C242C37542C37542C37542C375A0E0B9FFFFFFFFFFFFFFFFFFD9F3E342C37542 - C37542C375CCEFDAFFFFFFFFFFFFFFFFFFF7FCF980D6A242C37542C3756CD094 - FCFEFDFFFFFFFFFFFFFDFEFD51C78042C37542C37542C3758ADAAA5CCB8842C3 - 7542C37542C37542C37542C37593DCB0FFFFFFFFFFFFFFFFFF90DBAE42C37542 - C37542C37587D9A7FFFFFFFFFFFFFFFFFF9ADFB542C37542C37542C37542C375 - 42C375DCF4E6FFFFFFFFFFFFEDF9F24DC67D42C37542C37542C3755ECC8AFCFE - FCFFFFFFFFFFFFB1E6C642C37542C37542C37542C37542C37542C37542C37542 - C37542C37542C37542C37542C37542C37542C37542C37542C37542C37542C375 - 42C37542C37542C37542C37542C37542C37542C37542C37542C37542C37542C3 - 7542C37542C37542C37542C37542C37542C37542C37542C37542C37542C37542 - C37542C37542C37542C37542C37542C37542C37542C37542C37542C37542C375 - 42C37542C37542C37542C37542C37542C37542C37542C37542C37542C37542C3 - 7542C37542C37542C37542C37542C37542C37542C37542C37542C37542C37542 - C37542C37542C37542C37542C37540BF730000000000000000000000000E2015 - 47FF00000000000000000000000000190A00B04600B04600B04600B04600B046 - 00B04600B04600B04600B04600B04600B04600B04600B04600B04600B04600B0 - 4600B04600B04600B04600B04600B04600B04600B04600B04600B04600B04600 - B04600B04600B04600B04600B04600B04600B04600B04600B04600B04600B046 - 00B04600B04600B04600B04600B04600B04600B04600B04600B04600B04600B0 - 4600B04600B04600B04600B04600B04600B04600B04600B04600B04600B04600 - B04600B04600B04600B04600B04600B04600B04600B04600B04600B04600B046 - 00B04600B04600B046C4ECD4FFFFFFFFFFFFFFFFFF64CE8E42C47542C47542C4 - 7542C47542C47542C47542C475C9EED8FFFFFFFFFFFFFFFFFF96DEB242C47542 - C47565CF8EFBFDFCFFFFFFFFFFFFFFFFFFC7EDD68CDBAB8ADAAABEEACFFEFEFE - FFFFFFFFFFFFFFFFFF8CDBAB42C47542C47542C475CCEFDAFFFFFFFFFFFFFFFF - FFFFFFFFFFFFFFD7F2E2CAEED8F9FDFBFFFFFFFFFFFFFFFFFFE1F5E942C47542 - C47542C47554C982FEFEFEFCFEFCC6EDD58BDAAA6CD19369D0918CDBABF0FAF4 - FFFFFFFFFFFFFFFFFF6CD19342C47571D297C2ECD2D8F2E2FFFFFFFFFFFFFFFF - FFDEF4E7C2ECD2C2ECD2ABE4C142C47542C47586D9A6FFFFFFFFFFFFFFFFFFCE - EFDB63CE8D4AC67A6AD092D9F3E3FFFFFFFFFFFFFEFEFE6DD19442C47542C475 - 42C47542C47542C47542C47542C47542C47542C47542C47542C47542C47542C4 - 7542C47542C47542C47542C47542C47542C47542C47542C47542C47542C47542 - C47542C47542C47542C47542C47542C47542C47542C47542C47542C47542C475 - 42C47542C47542C47542C47542C47542C47542C47542C47542C47542C47542C4 - 7542C47542C47542C47542C47542C47542C47542C47542C47542C47542C47542 - C47542C47542C47542C47542C47542C47542C47542C47542C47542C47542C475 - 42C47542C47542C47542C47542C47542C47542C47542C47542C47542C47540C0 - 730000000000000000000000000E201559FF0000000000000000000000000019 - 0A00B04700B04700B04700B04700B04700B04700B04700B04700B04700B04700 - B04700B04700B04700B04700B04700B04700B04700B04700B04700B04700B047 - 00B04700B04700B04700B04700B04700B04700B04700B04700B04700B04700B0 - 4700B04700B04700B04700B04700B04700B04700B04700B04700B04700B04700 - B04700B04700B04700B04700B04700B04700B04700B04700B04700B04700B047 - 00B04700B04700B04700B04700B04700B04700B04700B04700B04700B04700B0 - 4700B04700B04700B04700B04700B04702B04914B65528BC63D1F0DEFFFFFFFF - FFFFFFFFFF64CE8F42C47642C47642C47642C47642C47642C47644C478F0FAF4 - FFFFFFFFFFFFFFFFFF79D59E42C47642C47642C47697DEB3FEFEFEFFFFFFFFFF - FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFCDEFDB45C57842C47642 - C47642C476CCEFDAFFFFFFFFFFFFDCF4E6FAFDFBFFFFFFFFFFFFFFFFFFFFFFFF - FFFFFFFFFFFFFFFFFF91DCAF42C47642C47642C47653C982FCFEFDFFFFFFFFFF - FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFDAF3E444C47742C476A8 - E3C0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF5FBF847C57A - 42C47643C477C0EBD1FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF - FFFFFFFFBAE9CD42C47642C47642C47642C47642C47642C47642C47642C47642 - C47642C47642C47642C47642C47642C47642C47642C47642C47642C47642C476 - 42C47642C47642C47642C47642C47642C47642C47642C47642C47642C47642C4 - 7642C47642C47642C47642C47642C47642C47642C47642C47642C47642C47642 - C47642C47642C47642C47642C47642C47642C47642C47642C47642C47642C476 - 42C47642C47642C47642C47642C47642C47642C47642C47642C47642C47642C4 - 7642C47642C47642C47642C47642C47642C47642C47642C47642C47642C47642 - C47642C47642C47642C47642C47640C0740000000000000000000000000E2015 - 76FF00000000000000000000000000190A00B14700B14700B14700B14700B147 - 00B14700B14700B14700B14700B14700B14700B14700B14700B14700B14700B1 - 4700B14700B14700B14700B14700B14700B14700B14700B14700B14700B14700 - B14700B14700B14700B14700B14700B14700B14700B14700B14700B14700B147 - 00B14700B14700B14700B14700B14700B14700B14700B14700B14700B14700B1 - 4700B14700B14700B14700B14700B14700B14700B14700B14700B14700B14700 - B14700B14700B14700B14700B14700B14700B14700B14705B24A1AB8592EBF68 - 3FC47442C57642C576D3F1DFFFFFFFFFFFFFFFFFFF64CF8F42C57642C57642C5 - 7642C57642C57642C57681D8A4FFFFFFFFFFFFFFFFFFF9FDFB50C98042C57642 - C57642C57642C57686DAA7EDF9F2FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF - FCFEFDB8E9CB4BC77C42C57642C57642C57642C576CBEFD9FFFFFFFFFFFFA8E4 - C074D49AE9F8EFFFFFFFFFFFFFFFFFFFFFFFFFFEFEFEB7E9CB44C57842C57642 - C57642C57642C5768CDBABEAF8EFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF - FFFFFFDFF5E75CCD8942C57642C576A3E3BCFFFFFFFFFFFFFFFFFFFFFFFFFFFF - FFFFFFFFFFFFFFFFFFFFF3FBF646C67942C57642C57647C679ADE5C3FBFDFCFF - FFFFFFFFFFFFFFFFFFFFFFFFFFFFFCFEFDB4E8C947C67942C57642C57642C576 - 42C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642C5 - 7642C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642 - C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642C576 - 42C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642C5 - 7642C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642 - C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642C576 - 42C57642C57642C57642C57642C57642C57642C57642C57642C57642C57640C1 - 740000000000000000000000000E201576FF0000000000000000000000000019 - 0A00B14700B14700B14700B14700B14700B14700B14700B14700B14700B14700 - B14700B14700B14700B14700B14700B14700B14700B14700B14700B14700B147 - 00B14700B14700B14700B14700B14700B14700B14700B14700B14700B14700B1 - 4700B14700B14700B14700B14700B14700B14700B14700B14700B14700B14700 - B14700B14700B14700B14700B14700B14700B14700B14700B14700B14700B147 - 00B14700B14700B14700B14700B14700B14700B14700B14700B14700B14705B2 - 4A19B8592FBF6840C47542C57642C57642C57642C57642C576D3F1DFFFFFFFFF - FFFFFFFFFF64CF8F42C57642C57642C57642C57642C57656CB85EAF8EFFFFFFF - FFFFFFFFFFFFC2ECD242C57642C57642C57642C57642C57642C5764AC77C83D9 - A5AEE6C4C3ECD4C7EDD6B8E9CB98DFB45ECD8A42C57642C57642C57642C57642 - C57642C57673D499A6E3BFA4E3BD64CF8E42C5764BC77C8DDCACBCEACEC6EDD6 - B1E7C675D49B42C57642C57642C57642C57642C57642C57642C57647C67974D4 - 9AA1E2BBBDEACFC8EED7C0EBD1AAE5C17BD69F46C67942C57642C57642C57658 - CC868BDBABB5E8C9FFFFFFFFFFFFFFFFFFC1ECD28BDBAB8BDBAB79D69E42C576 - 42C57642C57642C57642C5765CCD8999DFB5BCEACEC8EED7BDEACF9EE1B962CF - 8D42C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642 - C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642C576 - 42C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642C5 - 7642C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642 - C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642C576 - 42C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642C5 - 7642C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642 - C57642C57642C57642C57642C57640C1740000000000000000000000000E2015 - 47FF00000000000000000000000000190A00B14700B14700B14700B14700B147 - 00B14700B14700B14700B14700B14700B14700B14700B14700B14700B14700B1 - 4700B14700B14700B14700B14700B14700B14700B14700B14700B14700B14700 - B14700B14700B14700B14700B14700B14700B14700B14700B14700B14700B147 - 00B14700B14700B14700B14700B14700B14700B14700B14700B14700B14700B1 - 4700B14700B14700B14700B14700B14700B14700B14700B14700B14700B14700 - B14700B14703B24919B85930BF6940C47542C57642C57642C57642C57642C576 - 42C57642C57642C576D3F1DFFFFFFFFFFFFFFFFFFF64CF8F42C57642C57642C5 - 7644C5777ED7A2E9F8EFFFFFFFFFFFFFFFFFFFF9FDFB64CF8E42C57642C57642 - C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642C576 - 42C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642C5 - 7642C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642 - C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642C576 - 42C57642C57642C57642C57642C57642C57642C57687DAA8FFFFFFFFFFFFFFFF - FF9AE0B642C57642C57642C57642C57642C57642C57642C57642C57642C57642 - C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642C576 - 42C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642C5 - 7642C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642 - C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642C576 - 42C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642C5 - 7642C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642 - C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642C576 - 42C57642C57642C57642C57642C57642C57642C57642C57642C57642C57640C1 - 740000000000000000000000000E201577FF0000000000000000000000000019 - 0A00B24700B24700B24700B24700B24700B24700B24700B24700B24700B24700 - B24700B24700B24700B24700B24700B24700B24700B24700B24700B24700B247 - 00B24700B24700B24700B24700B24700B24700B24700B24700B24700B24700B2 - 4700B24700B24700B24700B24700B24700B24700B24700B24700B24700B24700 - B24700B24700B24700B24700B24700B24700B24700B24700B24700B24700B247 - 00B24700B24700B24700B24701B24815B8562DBF6740C57542C57642C57642C5 - 7642C57642C57642C57642C57642C57642C57642C57642C576D3F1DFFFFFFFFF - FFFFFFFFFFCDEFDBC2ECD2C2ECD2CFF0DCF0FAF4FFFFFFFFFFFFFFFFFFFFFFFF - FDFEFD90DDAE42C57642C57642C57642C57642C57642C57642C57642C57642C5 - 7642C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642 - C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642C576 - 42C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642C5 - 7642C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642 - C57642C57687DAA8FFFFFFFFFFFFFFFFFF9AE0B642C57642C57642C57642C576 - 42C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642C5 - 7642C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642 - C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642C576 - 42C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642C5 - 7642C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642 - C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642C576 - 42C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642C5 - 7642C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642 - C57642C57642C57642C57642C57640C1740000000000000000000000000E2015 - 77FF00000000000000000000000000190A00B34800B34800B34800B34800B348 - 00B34800B34800B34800B34800B34800B34800B34800B34800B34800B34800B3 - 4800B34800B34800B34800B34800B34800B34800B34800B34800B34800B34800 - B34800B34800B34800B34800B34800B34800B34800B34800B34800B34800B348 - 00B34800B34800B34800B34800B34800B34800B34800B34800B34800B34800B3 - 4800B34800B34800B34800B34800B34800B34800B3480CB65025BE623CC47342 - C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742C677 - 42C67742C67742C677D3F1DFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF - FFFFFFFFFFFFFFFFFFFFFFFFFFF4FBF789DBAA42C67742C67742C67742C67742 - C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742C677 - 42C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742C6 - 7742C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742 - C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742C677 - 42C67742C67742C67742C67742C67742C67742C67777D69DF9FDFAFFFFFFFBFD - FC8ADBAB42C67742C67742C67742C67742C67742C67742C67742C67742C67742 - C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742C677 - 42C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742C6 - 7742C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742 - C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742C677 - 42C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742C6 - 7742C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742 - C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742C677 - 42C67742C67742C67742C67742C67742C67742C67742C67742C67742C67740C2 - 750000000000000000000000000E201677FF0000000000000000000000000019 - 0A00B34800B34800B34800B34800B34800B34800B34800B34800B34800B34800 - B34800B34800B34800B34800B34800B34800B34800B34800B34800B34800B348 - 00B34800B34800B34800B34800B34800B34800B34800B34800B34800B34800B3 - 4800B34800B34800B34800B34800B34800B34800B34800B34800B34800B34800 - B34800B34800B34800B34800B34800B34800B34800B34800B34800B34804B44A - 1ABA5A34C26D42C67742C67742C67742C67742C67742C67742C67742C67742C6 - 7742C67742C67742C67742C67742C67742C67742C67742C677C7EED7FFFFFFFF - FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEFEFEE8F8EEA9E5C156CC85 - 42C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742C6 - 7742C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742 - C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742C677 - 42C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742C6 - 7742C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742 - C67742C67742C6774CC97E54CB844EC98042C67742C67742C67742C67742C677 - 42C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742C6 - 7742C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742 - C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742C677 - 42C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742C6 - 7742C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742 - C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742C677 - 42C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742C6 - 7742C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742 - C67742C67742C67742C67742C67740C2750000000000000000000000000E2016 - 00FF00000000000000000000000000190A00B34800B34800B34800B34800B348 - 00B34800B34800B34800B34800B34800B34800B34800B34800B34800B34800B3 - 4800B34800B34800B34800B34800B34800B34800B34800B34800B34800B34800 - B34800B34800B34800B34800B34800B34800B34800B34800B34800B34800B348 - 00B34800B34800B34800B34800B34800B34800B34800B34800B34800B34800B3 - 4800B34800B3480CB65027BE633EC57442C67742C67742C67742C67742C67742 - C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742C677 - 42C67742C67742C67756CC8589DBAA8BDCAB8BDCAB8BDCAB8BDCAB8BDCAB85DA - A775D59C5ACD8844C67842C67742C67742C67742C67742C67742C67742C67742 - C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742C677 - 42C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742C6 - 7742C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742 - C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742C677 - 42C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742C6 - 7742C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742 - C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742C677 - 42C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742C6 - 7742C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742 - C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742C677 - 42C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742C6 - 7742C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742 - C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742C677 - 42C67742C67742C67742C67742C67742C67742C67742C67742C67742C67740C2 - 750000000000000000000000000E201677FF000000000000000000000000001A - 0A00B44800B44800B44800B44800B44800B44800B44800B44800B44800B44800 - B44800B44800B44800B44800B44800B44800B44800B44800B44800B44800B448 - 00B44800B44800B44800B44800B44800B44800B44800B44800B44800B44800B4 - 4800B44800B44800B44800B44800B44800B44800B44800B44800B44800B44800 - B44800B44800B44800B44800B44800B44815BA5732C26B41C77642C77742C777 - 42C77742C77742C77742C77742C77742C77742C77742C77742C77742C77742C7 - 7742C77742C77742C77742C77742C77742C77742C77742C77742C77742C77742 - C77742C77742C77742C77742C77742C77742C77742C77742C77742C77742C777 - 42C77742C77742C77742C77742C77742C77742C77742C77742C77742C77742C7 - 7742C77742C77742C77742C77742C77742C77742C77742C77742C77742C77742 - C77742C77742C77742C77742C77742C77742C77742C77742C77742C77742C777 - 42C77742C77742C77742C77742C77742C77742C77742C77742C77742C77742C7 - 7742C77742C77742C77742C77742C77742C77742C77742C77742C77742C77742 - C77742C77742C77742C77742C77742C77742C77742C77742C77742C77742C777 - 42C77742C77742C77742C77742C77742C77742C77742C77742C77742C77742C7 - 7742C77742C77742C77742C77742C77742C77742C77742C77742C77742C77742 - C77742C77742C77742C77742C77742C77742C77742C77742C77742C77742C777 - 42C77742C77742C77742C77742C77742C77742C77742C77742C77742C77742C7 - 7742C77742C77742C77742C77742C77742C77742C77742C77742C77742C77742 - C77742C77742C77742C77742C77742C77742C77742C77742C77742C77742C777 - 42C77742C77742C77742C77742C77742C77742C77742C77742C77742C77742C7 - 7742C77742C77742C77742C77742C77742C77742C77742C77742C77742C77742 - C77742C77742C77742C77742C77740C3750000000000000000000000000E2116 - 13FF000000000000000000000000000401001C0B001C0B001C0B001C0B001C0B - 001C0B001C0B001C0B001C0B001C0B001C0B001C0B001C0B001C0B001C0B001C - 0B001C0B001C0B001C0B001C0B001C0B001C0B001C0B001C0B001C0B001C0B00 - 1C0B001C0B001C0B001C0B001C0B001C0B001C0B001C0B001C0B001C0B001C0B - 001C0B001C0B001C0B001C0B001C0B001C0B001C0B001C0B001D0C041E0F091F - 120A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A - 1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F13 - 0A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F - 130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A - 1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F13 - 0A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F - 130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A - 1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F13 - 0A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F - 130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A - 1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F13 - 0A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F - 130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A - 1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F13 - 0A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F - 130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A - 1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F13 - 0A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F - 120000000000000000000000000E211600FF000B040000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000000000000000000000000012291B - 00FF144327000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000003E654E00FFB7D4C2000D050000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000000000000000000000000000000000000A1C12DCEBE2 - 00FFFFFFFFB7D4C219472B000C05000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000006120B345A43D7E6DDFFFFFF00FF} - end object lblDonated: TLabel Left = 117 - Top = 203 - Width = 210 - Height = 13 + Top = 171 + Width = 238 + Height = 14 Caption = 'I have donated per following email address:' end object lblEnvironment: TLabel Left = 117 - Top = 81 - Width = 70 - Height = 13 + Top = 83 + Width = 80 + Height = 14 Caption = 'lblEnvironment' PopupMenu = popupLabels end object lnklblWebpage: TLinkLabel Left = 117 - Top = 100 - Width = 83 - Height = 19 + Top = 103 + Width = 104 + Height = 24 Caption = 'lnklblWebpage' TabOrder = 0 UseVisualStyle = True @@ -1363,17 +289,17 @@ object AboutBox: TAboutBox end object lnklblCredits: TLinkLabel Left = 117 - Top = 119 - Width = 41 - Height = 19 + Top = 123 + Width = 50 + Height = 24 Caption = 'Credits' TabOrder = 1 UseVisualStyle = True OnLinkClick = lnklblCreditsLinkClick end object btnClose: TButton - Left = 373 - Top = 282 + Left = 353 + Top = 338 Width = 100 Height = 25 Anchors = [akRight, akBottom] @@ -1381,23 +307,23 @@ object AboutBox: TAboutBox Caption = 'Close' Default = True ModalResult = 1 - TabOrder = 5 + TabOrder = 6 end object btnUpdateCheck: TButton Left = 117 - Top = 282 - Width = 250 + Top = 338 + Width = 230 Height = 25 Action = MainForm.actUpdateCheck Anchors = [akLeft, akRight, akBottom] Images = MainForm.VirtualImageListMain - TabOrder = 4 + TabOrder = 5 end object editDonated: TEdit Left = 117 - Top = 222 + Top = 190 Width = 180 - Height = 21 + Height = 22 TabOrder = 2 TextHint = 'Email address' OnEnter = editDonatedEnter @@ -1405,13 +331,39 @@ object AboutBox: TAboutBox end object btnDonatedOK: TButton Left = 303 - Top = 220 + Top = 189 Width = 64 Height = 25 Caption = 'OK' TabOrder = 3 OnClick = btnDonatedOKClick end + object btnDonate: TButton + Left = 117 + Top = 218 + Width = 336 + Height = 74 + Hint = + 'Send an arbitrary amount as donation to the author - per PayPal ' + + '(also supports credit cards)' + Anchors = [akLeft, akTop, akRight] + Caption = 'Donate' + CommandLinkHint = + 'Send an arbitrary amount as donation to the author - per PayPal ' + + '(also supports credit cards)' + Style = bsCommandLink + TabOrder = 4 + end + object lnklblCompiler: TLinkLabel + Left = 246 + Top = 63 + Width = 101 + Height = 24 + Caption = 'lnklblCompiler' + TabOrder = 7 + UseVisualStyle = True + OnLinkClick = lnklblWebpageLinkClick + end object popupLabels: TPopupMenu Images = MainForm.VirtualImageListMain Left = 32 diff --git a/source/about.pas b/source/about.pas index d78110b0f..f72b4bc0c 100644 --- a/source/about.pas +++ b/source/about.pas @@ -7,8 +7,8 @@ interface uses - Windows, Classes, Graphics, Forms, Controls, StdCtrls, ExtCtrls, SysUtils, ComCtrls, pngimage, gnugettext, - Dialogs, SynRegExpr, Vcl.Menus, ClipBrd, extra_controls; + Winapi.Windows, System.Classes, Vcl.Graphics, Vcl.Forms, Vcl.Controls, Vcl.StdCtrls, Vcl.ExtCtrls, System.SysUtils, Vcl.ComCtrls, Vcl.Imaging.pngimage, gnugettext, + Vcl.Dialogs, SynRegExpr, Vcl.Menus, Vcl.ClipBrd, extra_controls, generic_types, System.StrUtils; type TAboutBox = class(TExtForm) @@ -19,7 +19,6 @@ TAboutBox = class(TExtForm) lnklblWebpage: TLinkLabel; btnUpdateCheck: TButton; ImageHeidisql: TImage; - imgDonate: TImage; lblDonated: TLabel; editDonated: TEdit; btnDonatedOK: TButton; @@ -27,6 +26,8 @@ TAboutBox = class(TExtForm) popupLabels: TPopupMenu; menuCopyLabel: TMenuItem; lblEnvironment: TLabel; + btnDonate: TButton; + lnklblCompiler: TLinkLabel; procedure OpenURL(Sender: TObject); procedure FormShow(Sender: TObject); procedure editDonatedEnter(Sender: TObject); @@ -39,6 +40,7 @@ TAboutBox = class(TExtForm) procedure menuCopyLabelClick(Sender: TObject); private { Private declarations } + function GetDelphiVersion: String; public { Public declarations } end; @@ -71,8 +73,8 @@ procedure TAboutBox.btnDonatedOKClick(Sender: TObject); nbTrue: MessageDialog(_('Thanks for donating!'), mtInformation, [mbOK]); end; - imgDonate.Visible := Check <> nbTrue; - MainForm.imgDonate.Visible := imgDonate.Visible; + btnDonate.Visible := Check <> nbTrue; + MainForm.ToolBarDonate.Visible := btnDonate.Visible; MainForm.FormResize(Self); end; @@ -82,11 +84,9 @@ procedure TAboutBox.menuCopyLabelClick(Sender: TObject); LabelComp: TComponent; begin // Copy label caption - if Sender is TMenuItem then begin - LabelComp := TPopupMenu(TMenuItem(Sender).GetParentMenu).PopupComponent; - if LabelComp is TLabel then begin - Clipboard.AsText := TLabel(LabelComp).Caption; - end; + LabelComp := PopupComponent(Sender); + if LabelComp is TLabel then begin + Clipboard.TryAsText := TLabel(LabelComp).Caption; end; end; @@ -104,6 +104,8 @@ procedure TAboutBox.editDonatedExit(Sender: TObject); end; procedure TAboutBox.FormShow(Sender: TObject); +var + OsMajor, OsMinor, OsBuild: Integer; begin Screen.Cursor := crHourGlass; @@ -111,32 +113,41 @@ procedure TAboutBox.FormShow(Sender: TObject); lblAppName.Font.Size := Round(lblAppName.Font.Size * 1.5); lblAppName.Font.Style := [fsBold]; - imgDonate.Visible := MainForm.HasDonated(False) <> nbTrue; - imgDonate.OnClick := MainForm.DonateClick; + btnDonate.Caption := f_('Donate to the %s project', [APPNAME]); + btnDonate.Visible := MainForm.HasDonated(False) <> nbTrue; + btnDonate.OnClick := MainForm.DonateClick; editDonated.Text := AppSettings.ReadString(asDonatedEmail); // Assign text Caption := f_('About %s', [APPNAME]); lblAppName.Caption := APPNAME; lblAppVersion.Caption := _('Version') + ' ' + Mainform.AppVersion + ' (' + IntToStr(GetExecutableBits) + ' Bit)'; - lblAppCompiled.Caption := _('Compiled on:') + ' ' + DateTimeToStr(GetImageLinkTimeStamp(Application.ExeName)); + lblAppCompiled.Caption := _('Compiled on:') + ' ' + DateTimeToStr(GetImageLinkTimeStamp(Application.ExeName)) + ' with'; + lnklblCompiler.Top := lblAppCompiled.Top; + lnklblCompiler.Left := lblAppCompiled.Left + lblAppCompiled.Width + Canvas.TextWidth(' '); + lnklblCompiler.Caption := ''+GetDelphiVersion+''; lnklblWebpage.Caption := ''+APPDOMAIN+''; lnklblCredits.Caption := ''+lnklblCredits.Caption+''; ImageHeidisql.Hint := APPDOMAIN+'?place='+EncodeURLParam(ImageHeidisql.Name); lblEnvironment.Caption := _('Environment:'); - if RunningAsUwp then begin - lblEnvironment.Caption := lblEnvironment.Caption + - ' Windows v'+IntToStr(Win32MajorVersion)+'.'+IntToStr(Win32MinorVersion) + - ', Store Package ' + GetUwpFullName; - end else if MainForm.IsWine then begin + if IsWine then begin lblEnvironment.Caption := lblEnvironment.Caption + ' Linux/Wine'; end else begin + OsMajor := Win32MajorVersion; + OsMinor := Win32MinorVersion; + OsBuild := Win32BuildNumber; + if (OsMajor = 10) and (OsBuild >= 22000) then + OsMajor := 11; lblEnvironment.Caption := lblEnvironment.Caption + - ' Windows v'+IntToStr(Win32MajorVersion)+'.'+IntToStr(Win32MinorVersion); + ' Windows ' + + IntToStr(OsMajor) + + IfThen(OsMinor > 0, '.'+IntToStr(OsMinor), '') + + ' Build '+IntToStr(OsBuild); end; Screen.Cursor := crDefault; + btnClose.TrySetFocus; end; @@ -152,5 +163,21 @@ procedure TAboutBox.lnklblWebpageLinkClick(Sender: TObject; const Link: string; ShellExec(Link); end; +function TAboutBox.GetDelphiVersion: string; +begin + {$IF Defined(VER360)} + // Oldest/first official version where this gets used + Result := '12'; + {$ELSEIF Defined(VER350)} + Result := '11'; + {$ELSEIF Defined(VER340)} + Result := '10.4'; + {$ELSE} + Result := '10.3 or older'; + {$ENDIF} + + Result := 'Delphi ' + Result; +end; + end. diff --git a/source/apphelpers.pas b/source/apphelpers.pas index 4054adc47..02fb5e160 100644 --- a/source/apphelpers.pas +++ b/source/apphelpers.pas @@ -9,20 +9,29 @@ interface uses - Classes, SysUtils, Graphics, GraphUtil, ClipBrd, Dialogs, Forms, Controls, ShellApi, - Windows, ShlObj, ActiveX, VirtualTrees, SynRegExpr, Messages, Math, - Registry, DateUtils, Generics.Collections, StrUtils, AnsiStrings, TlHelp32, Types, - dbconnection, dbstructures, SynMemo, Menus, WinInet, gnugettext, Themes, - Character, ImgList, System.UITypes, ActnList, WinSock, IOUtils, StdCtrls, ComCtrls, - CommCtrl, Winapi.KnownFolders; + System.Classes, System.SysUtils, Vcl.Graphics, Vcl.GraphUtil, Vcl.ClipBrd, Vcl.Dialogs, Vcl.Forms, Vcl.Controls, Winapi.ShellApi, + Winapi.Windows, Winapi.ShlObj, Winapi.ActiveX, VirtualTrees, VirtualTrees.BaseTree, VirtualTrees.Types, SynRegExpr, Winapi.Messages, System.Math, + System.Win.Registry, System.DateUtils, System.Generics.Collections, System.Contnrs, System.StrUtils, System.AnsiStrings, Winapi.TlHelp32, System.Types, + dbconnection, dbstructures, dbstructures.mysql, SynMemo, Vcl.Menus, Winapi.WinInet, gnugettext, Vcl.Themes, + System.Character, Vcl.ImgList, System.UITypes, Vcl.ActnList, Winapi.WinSock, System.IOUtils, Vcl.StdCtrls, Vcl.ComCtrls, + Winapi.CommCtrl, Winapi.KnownFolders, SynUnicode, SynEdit, System.IniFiles; type - TOrderCol = class(TObject) - ColumnName: String; - SortDirection: Byte; + TSortItemOrder = (sioAscending, sioDescending); + TSortItem = class(TPersistent) + public + Column: String; + Order: TSortItemOrder; + procedure Assign(Source: TPersistent); override; + end; + TSortItems = class(TObjectList) + public + function AddNew(Column: String=''; Order: TSortItemOrder=sioAscending): TSortItem; + function ComposeOrderClause(Connection: TDBConnection): String; + function FindByColumn(Column: String): TSortItem; + procedure Assign(Source: TSortItems); end; - TOrderColArray = Array of TOrderCol; TLineBreaks = (lbsNone, lbsWindows, lbsUnix, lbsMac, lbsWide, lbsMixed); @@ -36,12 +45,15 @@ TDBObjectEditor = class(TFrame) FModified: Boolean; procedure SetModified(Value: Boolean); protected + FMainSynMemo: TSynMemo; // Main editor in case of routine, view, trigger or event + FMainSynMemoPreviousTopLine: Integer; + function ObjectExists: Boolean; public DBObject: TDBObject; constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure Init(Obj: TDBObject); virtual; - function DeInit: TModalResult; + function DeInit: TModalResult; virtual; property Modified: Boolean read FModified write SetModified; function ApplyModifications: TModalResult; virtual; abstract; end; @@ -64,11 +76,18 @@ TSQLSentence = class(TObject) TSQLBatch = class(TObjectList) private FSQL: String; + FQuotes: THashedStringList; + FEscape: Char; procedure SetSQL(Value: String); function GetSize: Integer; + function GetSQLWithoutComments: String; overload; public + constructor Create(NetTypeGroup: TNetTypeGroup); + destructor Destroy; override; + class function GetSQLWithoutComments(FullSQL: String): String; overload; property Size: Integer read GetSize; property SQL: String read FSQL write SetSQL; + property SQLWithoutComments: String read GetSQLWithoutComments; end; // Download @@ -78,7 +97,6 @@ THttpDownload = class(TObject) FURL: String; FLastContent: String; FBytesRead: Integer; - FContentLength: Integer; FTimeOut: Cardinal; FOnProgress: TNotifyEvent; public @@ -88,10 +106,18 @@ THttpDownload = class(TObject) property URL: String read FURL write FURL; property TimeOut: Cardinal read FTimeOut write FTimeOut; property BytesRead: Integer read FBytesRead; - property ContentLength: Integer read FContentLength; property LastContent: String read FLastContent; end; + // Extended string list with support for empty values + TExtStringList = class(TStringList) + private + function GetValue(const Name: string): string; + procedure SetValue(const Name, Value: string); reintroduce; + public + property Values[const Name: string]: string read GetValue write SetValue; + end; + // Threading stuff TQueryThread = class(TThread) private @@ -110,12 +136,6 @@ TQueryThread = class(TThread) FRowsAffected: Int64; FRowsFound: Int64; FWarningCount: Int64; - FLogMsg: String; - FLogCategory: TDBLogCategory; - procedure BeforeQuery; - procedure AfterQuery; - procedure BatchFinished; - procedure Log; public property Connection: TDBConnection read FConnection; property Batch: TSQLBatch read FBatch; @@ -132,68 +152,92 @@ TQueryThread = class(TThread) property ErrorMessage: String read FErrorMessage; constructor Create(Connection: TDBConnection; Batch: TSQLBatch; TabNumber: Integer); procedure Execute; override; - procedure LogFromOutside(Msg: String; Category: TDBLogCategory); + procedure LogFromThread(Msg: String; Category: TDBLogCategory); + end; + + TSqlTranspiler = class(TObject) + class function CreateTable(SQL: String; SourceDb, TargetDb: TDBConnection): String; + end; + + TClipboardHelper = class helper for TClipboard + private + function GetTryAsText: String; + procedure SetTryAsText(AValue: String); + public + property TryAsText: String read GetTryAsText write SetTryAsText; + end; + + TWinControlHelper = class helper for TWinControl + public + procedure TrySetFocus; end; + //TSimpleKeyValuePairs = TDictionary; + TAppSettingDataType = (adInt, adBool, adString); TAppSettingIndex = (asHiddenColumns, asFilter, asSort, asDisplayedColumnsSorted, asLastSessions, - asLastActiveSession, asAutoReconnect, asRestoreLastUsedDB, asLastUsedDB, asTreeBackground, asIgnoreDatabasePattern, - asFontName, asFontSize, asTabWidth, asDataFontName, asDataFontSize, asDataLocalNumberFormat, asHintsOnResultTabs, asHightlightSameTextBackground, + asLastActiveSession, asAutoReconnect, asRestoreLastUsedDB, asLastUsedDB, asTreeBackground, asIgnoreDatabasePattern, asLogFileDdl, asLogFileDml, asLogFilePath, + asFontName, asFontSize, asTabWidth, asDataFontName, asDataFontSize, asDataLocalNumberFormat, asLowercaseHex, asHintsOnResultTabs, asHightlightSameTextBackground, + asShowRowId, asLogsqlnum, asLogsqlwidth, asSessionLogsDirectory, asLogHorizontalScrollbar, asSQLColActiveLine, asSQLColMatchingBraceForeground, asSQLColMatchingBraceBackground, - asMaxColWidth, asDatagridMaximumRows, asDatagridRowsPerStep, asGridRowLineCount, asReuseEditorConfiguration, + asMaxColWidth, asDatagridMaximumRows, asDatagridRowsPerStep, asGridRowLineCount, asColumnHeaderClick, asReuseEditorConfiguration, asLogToFile, asMainWinMaximized, asMainWinLeft, asMainWinTop, asMainWinWidth, asMainWinHeight, asMainWinOnMonitor, asCoolBandIndex, asCoolBandBreak, asCoolBandWidth, asToolbarShowCaptions, asQuerymemoheight, asDbtreewidth, asDataPreviewHeight, asDataPreviewEnabled, asLogHeight, asQueryhelperswidth, asStopOnErrorsInBatchMode, asWrapLongLines, asCodeFolding, asDisplayBLOBsAsText, asSingleQueries, asMemoEditorWidth, asMemoEditorHeight, asMemoEditorMaximized, - asMemoEditorWrap, asDelimiter, asSQLHelpWindowLeft, asSQLHelpWindowTop, asSQLHelpWindowWidth, + asMemoEditorWrap, asMemoEditorHighlighter, asMemoEditorAlwaysFormatCode, asDelimiter, asSQLHelpWindowLeft, asSQLHelpWindowTop, asSQLHelpWindowWidth, asSQLHelpWindowHeight, asSQLHelpPnlLeftWidth, asSQLHelpPnlRightTopHeight, asHost, - asUser, asPassword, asCleartextPluginEnabled, asWindowsAuth, asLoginPrompt, asPort, asLibrary, asAllProviders, - asPlinkExecutable, asSSHtunnelHost, asSSHtunnelHostPort, asSSHtunnelPort, asSSHtunnelUser, + asUser, asPassword, asCleartextPluginEnabled, asForceUnicode, asWindowsAuth, asLoginPrompt, asPort, asLibrary, asAllProviders, + asSSHtunnelActive, asPlinkExecutable, asSshExecutable, asSSHtunnelHost, asSSHtunnelHostPort, asSSHtunnelPort, asSSHtunnelUser, asSSHtunnelPassword, asSSHtunnelTimeout, asSSHtunnelPrivateKey, asSSLActive, asSSLKey, - asSSLCert, asSSLCA, asSSLCipher, asNetType, asCompressed, asLocalTimeZone, asQueryTimeout, asKeepAlive, - asStartupScriptFilename, asDatabases, asComment, asDatabaseFilter, asTableFilter, asExportSQLCreateDatabases, + asSSLCert, asSSLCA, asSSLCipher, asSSLVerification, asSSLWarnUnused, asNetType, asCompressed, asLocalTimeZone, asQueryTimeout, asKeepAlive, + asStartupScriptFilename, asDatabases, asComment, asDatabaseFilter, asTableFilter, asFilterVT, asExportSQLCreateDatabases, asExportSQLCreateTables, asExportSQLDataHow, asExportSQLDataInsertSize, asExportSQLFilenames, asExportZIPFilenames, asExportSQLDirectories, - asExportSQLDatabase, asExportSQLServerDatabase, asExportSQLOutput, asExportSQLAddComments, asExportSQLRemoveAutoIncrement, asExportSQLRemoveDefiner, + asExportSQLDatabase, asExportSQLServerDatabase, asExportSQLOutput, asExportSQLAddComments, asExportSQLTransactions, asExportSQLRemoveAutoIncrement, asExportSQLRemoveDefiner, asGridExportWindowWidth, asGridExportWindowHeight, asGridExportOutputCopy, asGridExportOutputFile, asGridExportFilename, asGridExportRecentFiles, asGridExportEncoding, asGridExportFormat, asGridExportSelection, - asGridExportColumnNames, asGridExportIncludeAutoInc, asGridExportIncludeQuery, asGridExportRemoveLinebreaks, + asGridExportColumnNames, asGridExportIncludeAutoInc, asGridExportFocusedColumnOnly, asGridExportIncludeQuery, asGridExportRemoveLinebreaks, asGridExportOpenFile, asGridExportSeparator, asGridExportEncloser, asGridExportTerminator, asGridExportNull, - asGridExportClpFormat, asGridExportClpColumnNames, asGridExportClpIncludeAutoInc, asGridExportClpRemoveLinebreaks, + asGridExportClpColumnNames, asGridExportClpIncludeAutoInc, asGridExportClpRemoveLinebreaks, asGridExportClpSeparator, asGridExportClpEncloser, asGridExportClpTerminator, asGridExportClpNull, asCSVImportSeparator, asCSVImportEncloser, asCSVImportTerminator, asCSVImportFieldEscaper, asCSVImportWindowWidth, asCSVImportWindowHeight, asCSVImportFilename, asCSVImportFieldsEnclosedOptionally, asCSVImportIgnoreLines, asCSVImportLowPriority, asCSVImportLocalNumbers, - asCSVImportDuplicateHandling, asCSVImportParseMethod, + asCSVImportDuplicateHandling, asCSVImportParseMethod, asCSVKeepDialogOpen, asUpdatecheck, asUpdatecheckBuilds, asUpdatecheckInterval, asUpdatecheckLastrun, asUpdateCheckWindowWidth, asUpdateCheckWindowHeight, asTableToolsWindowWidth, asTableToolsWindowHeight, asTableToolsTreeWidth, - asTableToolsFindText, asTableToolsDatatype, asTableToolsFindCaseSensitive, asTableToolsFindMatchType, asFileImportWindowWidth, asFileImportWindowHeight, + asTableToolsFindTextTab, asTableToolsFindText, asTableToolsFindSQL, asTableToolsDatatype, asTableToolsFindCaseSensitive, asTableToolsFindMatchType, asFileImportWindowWidth, asFileImportWindowHeight, asEditVarWindowWidth, asEditVarWindowHeight, asUsermanagerWindowWidth, asUsermanagerWindowHeight, asUsermanagerListWidth, asSelectDBOWindowWidth, asSelectDBOWindowHeight, - asSessionManagerListWidth, asSessionManagerWindowWidth, asSessionManagerWindowHeight, asSessionManagerWindowLeft, asSessionManagerWindowTop, + asSessionManagerListWidth, asSessionManagerListFoldersAtTop, asSessionManagerWindowWidth, asSessionManagerWindowHeight, asSessionManagerWindowLeft, asSessionManagerWindowTop, asCopyTableWindowHeight, asCopyTableWindowWidth, asCopyTableColumns, asCopyTableKeys, asCopyTableForeignKeys, asCopyTableData, asCopyTableRecentFilter, asServerVersion, asServerVersionFull, asLastConnect, asConnectCount, asRefusedCount, asSessionCreated, asDoUsageStatistics, asLastUsageStatisticCall, asWheelZoom, asDisplayBars, asMySQLBinaries, asCustomSnippetsDirectory, - asPromptSaveFileOnTabClose, asRestoreTabs, asWarnUnsafeUpdates, asQueryWarningsMessage, asQueryGridLongSortRowNum, - asCompletionProposal, asCompletionProposalSearchOnMid, asCompletionProposalWidth, asCompletionProposalNbLinesInWindow, asAutoUppercase, + asPromptSaveFileOnTabClose, asRestoreTabs, asTabCloseOnDoubleClick, asTabCloseOnMiddleClick, asTabsInMultipleLines, asTabIconsGrayscaleMode, + asWarnUnsafeUpdates, asQueryGridLongSortRowNum, + asCompletionProposal, asCompletionProposalInterval, asCompletionProposalSearchOnMid, asCompletionProposalWidth, asCompletionProposalNbLinesInWindow, asAutoUppercase, asTabsToSpaces, asFilterPanel, asAllowMultipleInstances, asFindDialogSearchHistory, asGUIFontName, asGUIFontSize, asTheme, asIconPack, asWebSearchBaseUrl, asFindDialogReplaceHistory, asMaxQueryResults, asLogErrors, - asLogUserSQL, asLogSQL, asLogInfos, asLogDebug, asLogScript, asFieldColorNumeric, + asLogUserSQL, asLogSQL, asLogInfos, asLogDebug, asLogScript, asLogTimestamp, asFieldColorNumeric, asFieldColorReal, asFieldColorText, asFieldColorBinary, asFieldColorDatetime, asFieldColorSpatial, asFieldColorOther, asFieldEditorBinary, asFieldEditorDatetime, asFieldEditorDatetimePrefill, asFieldEditorEnum, - asFieldEditorSet, asFieldNullBackground, asRowBackgroundEven, asRowBackgroundOdd, asGroupTreeObjects, asDisplayObjectSizeColumn, asSQLfile, + asFieldEditorSet, asFieldNullBackground, asRowBackgroundEven, asRowBackgroundOdd, asGroupTreeObjects, asTreeShowColumns, asDisplayObjectSizeColumn, asSQLfile, asActionShortcut1, asActionShortcut2, asHighlighterForeground, asHighlighterBackground, asHighlighterStyle, asListColWidths, asListColsVisible, asListColPositions, asListColSort, asSessionFolder, asRecentFilter, asTimestampColumns, asDateTimeEditorCursorPos, asAppLanguage, asAutoExpand, asDoubleClickInsertsNodeText, asForeignDropDown, - asQueryHistoryEnabled, asQueryHistoryKeepDays, + asIncrementalSearch, asQueryHistoryEnabled, asQueryHistoryKeepDays, asColumnSelectorWidth, asColumnSelectorHeight, asDonatedEmail, asFavoriteObjects, asFavoriteObjectsOnly, asFullTableStatus, asLineBreakStyle, asPreferencesWindowWidth, asPreferencesWindowHeight, asFileDialogEncoding, asThemePreviewWidth, asThemePreviewHeight, asThemePreviewTop, asThemePreviewLeft, - asCreateDbCollation, + asCreateDbCollation, asRealTrailingZeros, + asSequalSuggestWindowWidth, asSequalSuggestWindowHeight, asSequalSuggestPrompt, asSequalSuggestRecentPrompts, + asReformatter, asReformatterNoDialog, asAlwaysGenerateFilter, asDisplayReverseForeignKeys, + asGenerateDataNumRows, asGenerateDataNullAmount, asWebOnceAction, asDisplayLogPanel, asDisplayTreeFilters, asUnused); TAppSetting = record Name: String; @@ -208,6 +252,7 @@ TAppSettings = class(TObject) FReads, FWrites: Integer; FBasePath: String; FSessionPath: String; + FStoredPath: String; FRegistry: TRegistry; FPortableMode: Boolean; FPortableModeReadOnly: Boolean; @@ -229,10 +274,12 @@ TAppSettings = class(TObject) constructor Create; destructor Destroy; override; function ReadInt(Index: TAppSettingIndex; FormatName: String=''; Default: Integer=0): Integer; + function ReadIntDpiAware(Index: TAppSettingIndex; AControl: TControl; FormatName: String=''; Default: Integer=0): Integer; function ReadBool(Index: TAppSettingIndex; FormatName: String=''; Default: Boolean=False): Boolean; function ReadString(Index: TAppSettingIndex; FormatName: String=''; Default: String=''): String; overload; function ReadString(ValueName: String): String; overload; procedure WriteInt(Index: TAppSettingIndex; Value: Integer; FormatName: String=''); + procedure WriteIntDpiAware(Index: TAppSettingIndex; AControl: TControl; Value: Integer; FormatName: String=''); procedure WriteBool(Index: TAppSettingIndex; Value: Boolean; FormatName: String=''); procedure WriteString(Index: TAppSettingIndex; Value: String; FormatName: String=''); overload; procedure WriteString(ValueName, Value: String); overload; @@ -252,6 +299,8 @@ TAppSettings = class(TObject) function SessionPathExists(SessionPath: String): Boolean; function IsEmptyKey: Boolean; procedure ResetPath; + procedure StorePath; + procedure RestorePath; property SessionPath: String read FSessionPath write SetSessionPath; property PortableMode: Boolean read FPortableMode; property PortableModeReadOnly: Boolean read FPortableModeReadOnly write FPortableModeReadOnly; @@ -264,69 +313,83 @@ TAppSettings = class(TObject) function DirnameUserDocuments: String; function DirnameSnippets: String; function DirnameBackups: String; + function DirnameHighlighters: String; // "Static" options, initialized in OnCreate only. For settings which need a restart to take effect. property RestoreTabsInitValue: Boolean read FRestoreTabsInitValue; end; {$I const.inc} - function implodestr(seperator: String; a: TStrings) :String; + function Implode(Separator: String; a: TStrings): String; function Explode(Separator, Text: String) :TStringList; procedure ExplodeQuotedList(Text: String; var List: TStringList); function StrEllipsis(const S: String; MaxLen: Integer; FromLeft: Boolean=True): String; + function isUnicode(str: String): Boolean; + function encryptUnicode(str: String): String; + function decryptUnicode(str: String): String; function encrypt(str: String): String; function decrypt(str: String): String; function HTMLSpecialChars(str: String): String; function EncodeURLParam(const Value: String): String; procedure StreamWrite(S: TStream; Text: String = ''); function _GetFileSize(Filename: String): Int64; + function DeleteFileWithUndo(sFileName: String): Boolean; function MakeInt(Str: String) : Int64; function MakeFloat(Str: String): Extended; + function RoundCommercial(e: Extended): Int64; function CleanupNumber(Str: String): String; function IsInt(Str: String): Boolean; function IsFloat(Str: String): Boolean; function ScanLineBreaks(Text: String): TLineBreaks; - function CountLineBreaks(Text: String; LineBreak: TLineBreaks=lbsWindows): Cardinal; function fixNewlines(txt: String): String; + procedure StripNewLines(var txt: String; Replacement: String=' '); + function GetLineBreak(LineBreakIndex: TLineBreaks): String; + procedure RemoveNullChars(var Text: String; var HasNulls: Boolean); function GetShellFolder(FolderId: TGUID): String; - function goodfilename( str: String ): String; - function ExtractBaseFileName(FileName: String): String; + function ValidFilename(Str: String): String; function FormatNumber( str: String; Thousands: Boolean=True): String; Overload; function UnformatNumber(Val: String): String; function FormatNumber( int: Int64; Thousands: Boolean=True): String; Overload; function FormatNumber( flt: Double; decimals: Integer = 0; Thousands: Boolean=True): String; Overload; - procedure ShellExec(cmd: String; path: String=''; params: String=''); + procedure ShellExec(cmd: String; path: String=''; params: String=''; RunHidden: Boolean=False); function getFirstWord(text: String; MustStartWithWordChar: Boolean=True): String; function RegExprGetMatch(Expression: String; var Input: String; ReturnMatchNum: Integer; DeleteFromSource, CaseInsensitive: Boolean): String; Overload; function RegExprGetMatch(Expression: String; Input: String; ReturnMatchNum: Integer): String; Overload; + function ExecRegExprI(const ARegExpr, AInputStr: RegExprString): Boolean; function FormatByteNumber( Bytes: Int64; Decimals: Byte = 1 ): String; Overload; function FormatByteNumber( Bytes: String; Decimals: Byte = 1 ): String; Overload; - function FormatTimeNumber(Seconds: Double; DisplaySeconds: Boolean): String; + function FormatTimeNumber(Seconds: Double; DisplaySeconds: Boolean; MilliSecondsPrecision: Integer=1): String; function GetTempDir: String; - procedure SaveUnicodeFile(Filename: String; Text: String); + // Return directory of running executable, including a trailing path delimiter + function GetAppDir: String; + // Return directory with dlls or dylibs, or empty string for auto-detection + function GetLibDir: String; + // Return directory with MySQL plugin files. Empty on Linux inidicating auto-detection. + function GetPluginDir: String; + procedure SaveUnicodeFile(Filename: String; Text: String; Encoding: TEncoding); procedure OpenTextFile(const Filename: String; out Stream: TFileStream; var Encoding: TEncoding); function DetectEncoding(Stream: TStream): TEncoding; function ReadTextfileChunk(Stream: TFileStream; Encoding: TEncoding; ChunkSize: Int64 = 0): String; function ReadTextfile(Filename: String; Encoding: TEncoding): String; function ReadBinaryFile(Filename: String; MaxBytes: Int64): AnsiString; - procedure StreamToClipboard(Text, HTML: TStream; CreateHTMLHeader: Boolean); + procedure StreamToClipboard(Text, HTML: TStream); function WideHexToBin(text: String): AnsiString; function BinToWideHex(bin: AnsiString): String; procedure FixVT(VT: TVirtualStringTree; MultiLineCount: Word=1); function GetTextHeight(Font: TFont): Integer; function ColorAdjustBrightness(Col: TColor; Shift: SmallInt): TColor; - function ComposeOrderClause(Cols: TOrderColArray): String; procedure DeInitializeVTNodes(Sender: TBaseVirtualTree); function FindNode(VT: TVirtualStringTree; idx: Int64; ParentNode: PVirtualNode): PVirtualNode; - procedure SelectNode(VT: TVirtualStringTree; idx: Int64; ParentNode: PVirtualNode=nil); overload; - procedure SelectNode(VT: TVirtualStringTree; Node: PVirtualNode); overload; + function SelectNode(VT: TVirtualStringTree; idx: Int64; ParentNode: PVirtualNode=nil): Boolean; overload; + function SelectNode(VT: TVirtualStringTree; Node: PVirtualNode; ClearSelection: Boolean=True): Boolean; overload; procedure GetVTSelection(VT: TVirtualStringTree; var SelectedCaptions: TStringList; var FocusedCaption: String); procedure SetVTSelection(VT: TVirtualStringTree; SelectedCaptions: TStringList; FocusedCaption: String); function GetNextNode(Tree: TVirtualStringTree; CurrentNode: PVirtualNode; Selected: Boolean=False): PVirtualNode; function GetPreviousNode(Tree: TVirtualStringTree; CurrentNode: PVirtualNode; Selected: Boolean=False): PVirtualNode; function DateBackFriendlyCaption(d: TDateTime): String; + function DateTimeToStrDef(DateTime: TDateTime; Default: String): String; + function TruncDef(X: Real; Default: Int64): Int64; function GetLightness(AColor: TColor): Byte; - function ReformatSQL(SQL: String): String; function ParamBlobToStr(lpData: Pointer): String; function ParamStrToBlob(out cbData: DWORD): Pointer; function CheckForSecondInstance: Boolean; @@ -343,42 +406,52 @@ TAppSettings = class(TObject) function GetImageLinkTimeStamp(const FileName: string): TDateTime; function IsEmpty(Str: String): Boolean; function IsNotEmpty(Str: String): Boolean; + function IfEmpty(Str: String; WhenEmpty: String): String; function MessageDialog(const Msg: string; DlgType: TMsgDlgType; Buttons: TMsgDlgButtons): Integer; overload; - function MessageDialog(const Title, Msg: string; DlgType: TMsgDlgType; Buttons: TMsgDlgButtons; KeepAskingSetting: TAppSettingIndex=asUnused): Integer; overload; + function MessageDialog(const Title, Msg: string; DlgType: TMsgDlgType; Buttons: TMsgDlgButtons; KeepAskingSetting: TAppSettingIndex=asUnused; FooterText: String=''): Integer; overload; function ErrorDialog(Msg: string): Integer; overload; function ErrorDialog(const Title, Msg: string): Integer; overload; function GetLocaleString(const ResourceId: Integer): WideString; function GetHTMLCharsetByEncoding(Encoding: TEncoding): String; - procedure ParseCommandLine(CommandLine: String; var ConnectionParams: TConnectionParameters; var FileNames: TStringList); + procedure ParseCommandLine(CommandLine: String; var ConnectionParams: TConnectionParameters; var FileNames: TStringList; var RunFrom: String); function f_(const Pattern: string; const Args: array of const): string; function GetOutputFilename(FilenameWithPlaceholders: String; DBObj: TDBObject): String; function GetOutputFilenamePlaceholders: TStringList; function GetSystemImageList: TImageList; function GetSystemImageIndex(Filename: String): Integer; function GetExecutableBits: Byte; + procedure GetExecutableVersion(FileName: String; var MajorVer, MinorVer, ReleaseVer, RevisionVer: Word); procedure Help(Sender: TObject; Anchor: String); function PortOpen(Port: Word): Boolean; function IsValidFilePath(FilePath: String): Boolean; function FileIsWritable(FilePath: String): Boolean; function GetProductInfo(dwOSMajorVersion, dwOSMinorVersion, dwSpMajorVersion, dwSpMinorVersion: DWORD; out pdwReturnedProductType: DWORD): BOOL stdcall; external kernel32 delayed; - function RunningOnWindows10S: Boolean; function GetCurrentPackageFullName(out Len: Cardinal; Name: PWideChar): Integer; stdcall; external kernel32 delayed; - function GetUwpFullName: String; - function RunningAsUwp: Boolean; function GetThemeColor(Color: TColor): TColor; - function ThemeIsDark(ThemeName: String): Boolean; - function ProcessExists(pid: Cardinal): Boolean; + function ThemeIsDark(ThemeName: String=''): Boolean; + function ProcessExists(pid: Cardinal; ExeNamePattern: String): Boolean; procedure ToggleCheckBoxWithoutClick(chk: TCheckBox; State: Boolean); + function SynCompletionProposalPrettyText(ImageIndex: Integer; LeftText, CenterText, RightText: String; LeftColor: TColor=-1; CenterColor: TColor=-1; RightColor: TColor=-1): String; + function PopupComponent(Sender: TObject): TComponent; + function IsWine: Boolean; + function DirSep: Char; + procedure FindComponentInstances(BaseForm: TComponent; ClassType: TClass; var List: TObjectList); + function WebColorStrToColorDef(WebColor: string; Default: TColor): TColor; + function UserAgent(OwnerComponent: TComponent): String; + function CodeIndent(Steps: Integer=1): String; + function EscapeHotkeyPrefix(Text: String): String; var AppSettings: TAppSettings; MutexHandle: THandle = 0; - SystemImageList: TImageList; + SystemImageList: TImageList = nil; mtCriticalConfirmation: TMsgDlgType = mtCustom; ConfirmIcon: TIcon; NumberChars: TSysCharSet; LibHandleUser32: THandle; UTF8NoBOMEncoding: TUTF8NoBOMEncoding; + DateTimeNever: TDateTime; + IsWineStored: Integer = -1; implementation @@ -413,7 +486,7 @@ function BinToWideHex(bin: AnsiString): String; @param a TStringList Containing strings @return string } -function implodestr(seperator: String; a: TStrings) :String; +function Implode(Separator: String; a: TStrings): String; var i : Integer; begin @@ -422,12 +495,11 @@ function implodestr(seperator: String; a: TStrings) :String; begin Result := Result + a[i]; if i < a.Count-1 then - Result := Result + seperator; + Result := Result + Separator; end; end; - function Explode(Separator, Text: String): TStringList; var i: Integer; @@ -474,6 +546,77 @@ function StrEllipsis(const S: String; MaxLen: Integer; FromLeft: Boolean=True): +{*** + Check if string is Unicode + + @param string String to check + @return boolean +} +function isUnicode(str: String): Boolean; +var i: integer; +begin + result := false; + for i := 1 to length(str) do begin + result := ord(str[i]) > 255; + if result then exit; + end; +end; + + +{*** + Password-encryption, used to store session-passwords in registry + Unicode (UTF-16) version, support up to 0xFFFF + + @param string Text to encrypt + @return string Encrypted Text +} +function encryptUnicode(str: String): String; +var + i, salt, nr: integer; + h: String; +begin + randomize(); + result := ''; + salt := random(9) + 1; + for i := 1 to length(str) do begin + nr := (ord(str[i]) + salt) mod 65536; + h := IntToHex(nr, 4); // 4 hex-symbols + result := result + h; + end; + // Adding Unicode flag + result := result + IntToStr(salt) + '0'; +end; + + +{*** + Password-decryption, used to restore session-passwords from registry + Unicode (UTF-16) version, support up to 0xFFFF + + @param string Text to decrypt + @return string Decrypted Text +} +function decryptUnicode(str: String): String; +var + j, salt, nr: integer; +begin + result := ''; + if str = '' then exit; + salt := StrToIntDef(str[length(str)], -1); + + // Salt is NAN + if salt < 0 then exit; + + j := 1; + while j < length(str) do begin + nr := StrToInt('$' + copy(str, j, 4)) - salt; + if nr < 0 then + nr := nr + 65536; + result := result + chr(nr); + inc(j, 4); + end; +end; + + {*** Password-encryption, used to store session-passwords in registry @@ -485,6 +628,11 @@ function encrypt(str: String) : String; i, salt, nr : integer; h : String; begin + if isUnicode(str) then begin + result := encryptUnicode(str); + exit; + end; + randomize(); result := ''; salt := random(9) + 1; @@ -501,7 +649,6 @@ function encrypt(str: String) : String; end; - {*** Password-decryption, used to restore session-passwords from registry @@ -514,9 +661,20 @@ function decrypt(str: String) : String; begin result := ''; if str = '' then exit; + salt := StrToIntDef(str[length(str)], -1); + + // Salt is NAN - error + if salt < 0 then exit; + + // Salt is Unicode flag - Unicode logic + if salt = 0 then begin + // Removing Unicode flag + result := decryptUnicode(copy(str, 1, length(str) - 1)); + exit; + end; + + // Salt is... salt - ANSI logic j := 1; - salt := StrToIntDef(str[length(str)],0); - result := ''; while j < length(str)-1 do begin nr := StrToInt('$' + str[j] + str[j+1]) - salt; if nr < 0 then @@ -558,30 +716,48 @@ function EncodeURLParam(const Value: String): String; } procedure StreamWrite(S: TStream; Text: String = ''); var - utf8: AnsiString; + utf8: UTF8String; + L: Integer; begin utf8 := Utf8Encode(Text); - S.Write(utf8[1], Length(utf8)); + L := Length(utf8); + if L > 0 then + S.WriteBuffer(utf8[1], L); end; {*** Return filesize of a given file + Partly taken from https://www.delphipraxis.net/194137-getfilesize-welches-ist-die-bessere-funktion-2.html @param string Filename @return int64 Size in bytes } function _GetFileSize(Filename: String): Int64; var - Attr: _WIN32_FILE_ATTRIBUTE_DATA; + Attr: TWin32FileAttributeData; begin - if FileExists(Filename) then begin - GetFileAttributesEx(PChar(Filename), GetFileExInfoStandard, @Attr); + FillChar(Attr, SizeOf(Attr), 0); + if GetFileAttributesEx(PChar(Filename), GetFileExInfoStandard, @Attr) then + begin Result := Int64(Attr.nFileSizeHigh) shl 32 + Int64(Attr.nFileSizeLow); - end else + end + else Result := -1; end; +function DeleteFileWithUndo(sFileName: string): Boolean; +var + fos: TSHFileOpStruct; +begin + FillChar(fos, SizeOf(fos), 0); + fos.wFunc := FO_DELETE; + fos.pFrom := PChar(sFileName + #0); + fos.fFlags := FOF_ALLOWUNDO or FOF_NOCONFIRMATION or FOF_SILENT; + Result := (0 = ShFileOperation(fos)); +end; + + {*** Convert a string-number to an integer-number @@ -688,6 +864,16 @@ function MakeFloat(Str: String): Extended; end; +function RoundCommercial(e: Extended): Int64; +begin + // "Kaufmnnisch runden" + // In contrast to Delphi's Round() which rounds *.5 to the next even number + Result := Trunc(e); + if Frac(e) >= 0.5 then + Result := Result + 1; +end; + + {*** SynEdit removes all newlines and semi-randomly decides a new newline format to use for any text edited. @@ -736,28 +922,6 @@ function ScanLineBreaks(Text: String): TLineBreaks; end; -function CountLineBreaks(Text: String; LineBreak: TLineBreaks=lbsWindows): Cardinal; -var - Offset: Integer; - BreakStr: String; -begin - // Count number of given line breaks in text - Result := 0; - case LineBreak of - lbsWindows: BreakStr := CRLF; - lbsUnix: BreakStr := LB_UNIX; - lbsMac: BreakStr := LB_MAC; - lbsWide: BreakStr := LB_WIDE; - else Exit; - end; - Offset := PosEx(BreakStr, Text, 1); - while Offset <> 0 do begin - Inc(Result); - Offset := PosEx(BreakStr, Text, Offset + Length(BreakStr)); - end; -end; - - {*** Unify CR's and LF's to CRLF @@ -772,6 +936,40 @@ function fixNewlines(txt: String): String; result := txt; end; +procedure StripNewLines(var txt: String; Replacement: String=' '); +begin + txt := StringReplace(txt, #13#10, Replacement, [rfReplaceAll]); + txt := StringReplace(txt, #13, Replacement, [rfReplaceAll]); + txt := StringReplace(txt, #10, Replacement, [rfReplaceAll]); +end; + +function GetLineBreak(LineBreakIndex: TLineBreaks): String; +begin + case LineBreakIndex of + lbsUnix: Result := LB_UNIX; + lbsMac: Result := LB_MAC; + else Result := CRLF; + end; +end; + + +{*** + Mangle input text so that SynEdit can load it. +} +procedure RemoveNullChars(var Text: String; var HasNulls: Boolean); +var + i, Len: Integer; +begin + HasNulls := False; + Len := Length(Text); + for i:=1 to Len do begin + if Text[i] = #0 then begin + Text[i] := #32; // space + HasNulls := True; + end; + end; +end; + {*** Get the path of a Windows(r)-shellfolder, specified by a KNOWNFOLDERID constant @@ -798,24 +996,14 @@ function GetShellFolder(FolderId: TGUID): String; @param string Filename @return string } -function goodfilename( str: String ): String; -var - c : Char; -begin - result := str; - for c in ['\', '/', ':', '*', '?', '"', '<', '>', '|'] do - result := StringReplace( result, c, '_', [rfReplaceAll] ); -end; - - -function ExtractBaseFileName(FileName: String): String; +function ValidFilename(Str: String): String; var - Ext: String; + c: Char; begin - // Extract file name without path and file extension - FileName := ExtractFileName(FileName); - Ext := ExtractFileExt(FileName); - Result := Copy(FileName, 1, Length(FileName)-Length(Ext)); + Result := Str; + for c in TPath.GetInvalidFileNameChars do begin + Result := StringReplace(Result, c, '_', [rfReplaceAll]); + end; end; @@ -919,17 +1107,19 @@ function FormatNumber(flt: Double; decimals: Integer = 0; Thousands: Boolean=Tru @param string Command or URL to execute @param string Working directory, only usefull is first param is a system command } -procedure ShellExec(cmd: String; path: String=''; params: String=''); +procedure ShellExec(cmd: String; path: String=''; params: String=''; RunHidden: Boolean=False); var Msg: String; + ShowCmd: Integer; begin + ShowCmd := IfThen(RunHidden, SW_HIDE, SW_SHOWNORMAL); Msg := 'Executing shell command: "'+cmd+'"'; if not path.IsEmpty then Msg := Msg + ' path: "'+path+'"'; if not params.IsEmpty then Msg := Msg + ' params: "'+params+'"'; MainForm.LogSQL(Msg, lcDebug); - ShellExecute(0, 'open', PChar(cmd), PChar(params), PChar(path), SW_SHOWNORMAL); + ShellExecute(0, 'open', PChar(cmd), PChar(params), PChar(path), ShowCmd); end; @@ -1022,6 +1212,22 @@ function RegExprGetMatch(Expression: String; Input: String; ReturnMatchNum: Inte end; +function ExecRegExprI(const ARegExpr, AInputStr: RegExprString): Boolean; +var + r: TRegExpr; +begin + Result := False; + r := TRegExpr.Create; + r.ModifierI := True; + try + r.Expression := ARegExpr; + Result := r.Exec(AInputStr); + finally + r.Free; + end; +end; + + {** Format a filesize to automatically use the best fitting expression 16 100 000 Bytes -> 16,1 MB @@ -1059,14 +1265,16 @@ function FormatByteNumber( Bytes: String; Decimals: Byte = 1 ): String; Overload {** Format a number of seconds to a human readable time format @param Cardinal Number of seconds - @result String 12:34:56 + @result String 12:34:56.7 } -function FormatTimeNumber(Seconds: Double; DisplaySeconds: Boolean): String; +function FormatTimeNumber(Seconds: Double; DisplaySeconds: Boolean; MilliSecondsPrecision: Integer=1): String; var - d, h, m, s, ts: Integer; + d, h, m, s, ms: Integer; + msStr: String; begin - s := Trunc(Seconds); - ts := Trunc((Seconds - s) * 10); // ts = tenth of a second + s := TruncDef(Seconds, 0); + ms := TruncDef((Seconds - s) * Power(10, MilliSecondsPrecision), 0); // Milliseconds, with variable precision/digits + msStr := IntToStr(ms).PadLeft(MilliSecondsPrecision, '0'); d := s div (60*60*24); s := s mod (60*60*24); h := s div (60*60); @@ -1076,7 +1284,7 @@ function FormatTimeNumber(Seconds: Double; DisplaySeconds: Boolean): String; if d > 0 then begin if DisplaySeconds then begin Result := Format('%d '+_('days')+', %.2d:%.2d:%.2d', [d, h, m, s]); - Result := Result + '.' + IntToStr(ts); + Result := Result + '.' + msStr; // Append milliseconds end else begin Result := Format('%d '+_('days')+', %.2d:%.2d h', [d, h, m]); @@ -1084,7 +1292,7 @@ function FormatTimeNumber(Seconds: Double; DisplaySeconds: Boolean): String; end else begin if DisplaySeconds then begin Result := Format('%.2d:%.2d:%.2d', [h, m, s]); - Result := Result + '.' + IntToStr(ts); + Result := Result + '.' + msStr; // Append milliseconds end else begin Result := Format('%.2d:%.2d h', [h, m]); @@ -1102,14 +1310,33 @@ function GetTempDir: String; end; +function GetAppDir: String; +begin + Result := ExtractFilePath(Application.ExeName); +end; + +function GetLibDir: String; +begin + Result := GetAppDir; +end; + +function GetPluginDir: String; +begin + Result := GetLibDir; + Result := Result + 'plugins' + PathDelim; +end; + {** Save a textfile with unicode } -procedure SaveUnicodeFile(Filename: String; Text: String); +procedure SaveUnicodeFile(Filename: String; Text: String; Encoding: TEncoding); var Writer: TStreamWriter; begin - Writer := TStreamWriter.Create(Filename, False, UTF8NoBOMEncoding); + // Encoding may be nil when previously loaded via auto-detection + if not Assigned(Encoding) then + Encoding := UTF8NoBOMEncoding; + Writer := TStreamWriter.Create(Filename, False, Encoding); Writer.Write(Text); Writer.Free; end; @@ -1124,6 +1351,9 @@ procedure OpenTextFile(const Filename: String; out Stream: TFileStream; var Enco Stream := TFileStream.Create(Filename, fmOpenRead or fmShareDenyNone); if Encoding = nil then Encoding := DetectEncoding(Stream); + // For a 0-bytes file, override the encoding to one without BOM + if _GetFileSize(Filename) < Length(Encoding.GetPreamble) then + Encoding := UTF8NoBOMEncoding; // If the file contains a BOM, advance the stream's position BomLen := 0; if Length(Encoding.GetPreamble) > 0 then begin @@ -1137,7 +1367,7 @@ procedure OpenTextFile(const Filename: String; out Stream: TFileStream; var Enco {** - Detect stream's content encoding by examing first 100k bytes (MaxBufferSize). Result can be: + Detect stream's content encoding through SynEdit's GetEncoding. Result can be: UTF-16 BE with BOM UTF-16 LE with BOM UTF-8 with or without BOM @@ -1148,143 +1378,21 @@ procedure OpenTextFile(const Filename: String; out Stream: TFileStream; var Enco } function DetectEncoding(Stream: TStream): TEncoding; var - ByteOrderMark: Char; - BytesRead: Integer; - Utf8Test: array[0..2] of AnsiChar; - Buffer: array of Byte; - BufferSize, i, FoundUTF8Strings: Integer; -const - UNICODE_BOM = Char($FEFF); - UNICODE_BOM_SWAPPED = Char($FFFE); - UTF8_BOM = AnsiString(#$EF#$BB#$BF); - MinimumCountOfUTF8Strings = 1; - MaxBufferSize = 1000000; - - // 3 trailing bytes are the maximum in valid UTF-8 streams, - // so a count of 4 trailing bytes is enough to detect invalid UTF-8 streams - function CountOfTrailingBytes: Integer; - begin - Result := 0; - inc(i); - while (i < BufferSize) and (Result < 4) do begin - if Buffer[i] in [$80..$BF] then - inc(Result) + SynEnc: TSynEncoding; + WithBOM: Boolean; +begin + SynEnc := SynUnicode.GetEncoding(Stream, WithBOM); + case SynEnc of + seUTF8: begin + if WithBOM then + Result := TEncoding.UTF8 else - Break; - inc(i); - end; - end; - -begin - // Byte Order Mark - ByteOrderMark := #0; - if (Stream.Size - Stream.Position) >= SizeOf(ByteOrderMark) then begin - BytesRead := Stream.Read(ByteOrderMark, SizeOf(ByteOrderMark)); - if (ByteOrderMark <> UNICODE_BOM) and (ByteOrderMark <> UNICODE_BOM_SWAPPED) then begin - ByteOrderMark := #0; - Stream.Seek(-BytesRead, soFromCurrent); - if (Stream.Size - Stream.Position) >= Length(Utf8Test) * SizeOf(AnsiChar) then begin - BytesRead := Stream.Read(Utf8Test[0], Length(Utf8Test) * SizeOf(AnsiChar)); - if Utf8Test <> UTF8_BOM then - Stream.Seek(-BytesRead, soFromCurrent); - end; - end; - end; - // Test Byte Order Mark - if ByteOrderMark = UNICODE_BOM then - Result := TEncoding.Unicode - else if ByteOrderMark = UNICODE_BOM_SWAPPED then - Result := TEncoding.BigEndianUnicode - else if Utf8Test = UTF8_BOM then - Result := TEncoding.UTF8 - else begin - { @note Taken from SynUnicode.pas } - { If no BOM was found, check for leading/trailing byte sequences, - which are uncommon in usual non UTF-8 encoded text. - - NOTE: There is no 100% save way to detect UTF-8 streams. The bigger - MinimumCountOfUTF8Strings, the lower is the probability of - a false positive. On the other hand, a big MinimumCountOfUTF8Strings - makes it unlikely to detect files with only little usage of non - US-ASCII chars, like usual in European languages. } - - // if no special characteristics are found it is not UTF-8 - Result := TEncoding.Default; - - // start analysis at actual Stream.Position - BufferSize := Min(MaxBufferSize, Stream.Size - Stream.Position); - - if BufferSize > 0 then begin - SetLength(Buffer, BufferSize); - Stream.ReadBuffer(Buffer[0], BufferSize); - Stream.Seek(-BufferSize, soFromCurrent); - - FoundUTF8Strings := 0; - i := 0; - while i < BufferSize do begin - if FoundUTF8Strings = MinimumCountOfUTF8Strings then begin - Result := TEncoding.UTF8; - Break; - end; - case Buffer[i] of - $00..$7F: // skip US-ASCII characters as they could belong to various charsets - ; - $C2..$DF: - if CountOfTrailingBytes = 1 then - inc(FoundUTF8Strings) - else - Break; - $E0: - begin - inc(i); - if (i < BufferSize) and (Buffer[i] in [$A0..$BF]) and (CountOfTrailingBytes = 1) then - inc(FoundUTF8Strings) - else - Break; - end; - $E1..$EC, $EE..$EF: - if CountOfTrailingBytes = 2 then - inc(FoundUTF8Strings) - else - Break; - $ED: - begin - inc(i); - if (i < BufferSize) and (Buffer[i] in [$80..$9F]) and (CountOfTrailingBytes = 1) then - inc(FoundUTF8Strings) - else - Break; - end; - $F0: - begin - inc(i); - if (i < BufferSize) and (Buffer[i] in [$90..$BF]) and (CountOfTrailingBytes = 2) then - inc(FoundUTF8Strings) - else - Break; - end; - $F1..$F3: - if CountOfTrailingBytes = 3 then - inc(FoundUTF8Strings) - else - Break; - $F4: - begin - inc(i); - if (i < BufferSize) and (Buffer[i] in [$80..$8F]) and (CountOfTrailingBytes = 2) then - inc(FoundUTF8Strings) - else - Break; - end; - $C0, $C1, $F5..$FF: // invalid UTF-8 bytes - Break; - $80..$BF: // trailing bytes are consumed when handling leading bytes, - // any occurence of "orphaned" trailing bytes is invalid UTF-8 - Break; - end; - inc(i); - end; + Result := UTF8NoBOMEncoding; end; + seUTF16LE: Result := TEncoding.Unicode; + seUTF16BE: Result := TEncoding.BigEndianUnicode; + seAnsi: Result := TEncoding.ANSI; + else Result := UTF8NoBOMEncoding; end; end; @@ -1355,20 +1463,30 @@ function ReadBinaryFile(Filename: String; MaxBytes: Int64): AnsiString; end; -procedure StreamToClipboard(Text, HTML: TStream; CreateHTMLHeader: Boolean); +procedure StreamToClipboard(Text, HTML: TStream); var - TextContent, HTMLContent: AnsiString; + TextContent, HTMLContent, HTMLHeader, NullPos: AnsiString; GlobalMem: HGLOBAL; lp: PChar; ClpLen: Integer; CF_HTML: Word; + StartHTML, EndHTML, StartFragment, EndFragment: Integer; +const + PosFormat: AnsiString = '%.10d'; + + procedure ReplacePos(Name: AnsiString; Value: Integer); + var NewPos: AnsiString; + begin + NewPos := Format(PosFormat, [Value]); + HTMLContent := StringReplace(HTMLContent, Name+':'+NullPos, Name+':'+NewPos, []); + end; begin // Copy unicode text to clipboard if Assigned(Text) then begin SetLength(TextContent, Text.Size); Text.Position := 0; Text.Read(PAnsiChar(TextContent)^, Text.Size); - Clipboard.AsText := Utf8ToString(TextContent); + Clipboard.TryAsText := Utf8ToString(TextContent); SetString(TextContent, nil, 0); end; @@ -1382,17 +1500,23 @@ procedure StreamToClipboard(Text, HTML: TStream; CreateHTMLHeader: Boolean); SetLength(HTMLContent, HTML.Size); HTML.Position := 0; HTML.Read(PAnsiChar(HTMLContent)^, HTML.Size); - if CreateHTMLHeader then begin - HTMLContent := 'Version:0.9' + CRLF + - 'StartHTML:000089' + CRLF + - 'EndHTML:' + CRLF + - 'StartFragment:000089' + CRLF + - 'EndFragment:' + CRLF + - HTMLContent + CRLF; - HTMLContent := AnsiStrings.StringReplace( - HTMLContent, '', - AnsiStrings.Format('%.6d', [Length(HTMLContent)]), - [rfReplaceAll]); + if Pos(AnsiString('Version:'), HTMLContent) = 0 then begin + // Only required if header was not already prepended by SynEdit, e.g. in grid export of SQL Inserts + NullPos := Format(PosFormat, [0]); + HTMLHeader := 'Version:0.9' + sLineBreak + + 'StartHTML:' + NullPos + sLineBreak + + 'EndHTML:' + NullPos + sLineBreak + + 'StartFragment:' + NullPos + sLineBreak + + 'EndFragment:' + NullPos + sLineBreak; + StartHTML := Length(HTMLHeader); + HTMLContent := HTMLHeader + HTMLContent; + EndHTML := Length(HTMLContent); + StartFragment := Pos(AnsiString(''), HTMLContent) + 6; + EndFragment := Pos(AnsiString(' 1; Node := VT.GetNextInitialized(Node); end; VT.EndUpdate; + VT.TextMargin := 6; + VT.Margin := 2; + VT.DefaultText := '-'; // "Node" by default // Disable hottracking in non-Vista mode, looks ugly in XP, but nice in Vista if (toUseExplorerTheme in VT.TreeOptions.PaintOptions) and (Win32MajorVersion >= 6) then VT.TreeOptions.PaintOptions := VT.TreeOptions.PaintOptions + [toHotTrack] @@ -1435,12 +1563,12 @@ procedure FixVT(VT: TVirtualStringTree; MultiLineCount: Word=1); VT.OnMouseWheel := MainForm.AnyGridMouseWheel; VT.ShowHint := True; - if toVariableNodeHeight in VT.TreeOptions.MiscOptions then + if toGridExtensions in VT.TreeOptions.MiscOptions then VT.HintMode := hmHint // Show cell contents with linebreakds in datagrid and querygrid's else VT.HintMode := hmTooltip; // Just a quick tooltip for clipped nodes // Apply case insensitive incremental search event - if VT.IncrementalSearch <> VirtualTrees.isNone then + if VT.IncrementalSearch <> VirtualTrees.Types.isNone then VT.OnIncrementalSearch := Mainform.AnyGridIncrementalSearch; VT.OnStartOperation := Mainform.AnyGridStartOperation; VT.OnEndOperation := Mainform.AnyGridEndOperation; @@ -1479,28 +1607,6 @@ function ColorAdjustBrightness(Col: TColor; Shift: SmallInt): TColor; end; -{** - Concat all sort options to a ORDER clause -} -function ComposeOrderClause(Cols: TOrderColArray): String; -var - i : Integer; - sort : String; -begin - result := ''; - for i := 0 to Length(Cols) - 1 do - begin - if result <> '' then - result := result + ', '; - if Cols[i].SortDirection = ORDER_ASC then - sort := TXT_ASC - else - sort := TXT_DESC; - result := result + MainForm.ActiveConnection.QuoteIdent( Cols[i].ColumnName ) + ' ' + sort; - end; -end; - - procedure DeInitializeVTNodes(Sender: TBaseVirtualTree); var Node: PVirtualNode; @@ -1542,30 +1648,43 @@ function FindNode(VT: TVirtualStringTree; idx: Int64; ParentNode: PVirtualNode): end; -procedure SelectNode(VT: TVirtualStringTree; idx: Int64; ParentNode: PVirtualNode=nil); overload; +function SelectNode(VT: TVirtualStringTree; idx: Int64; ParentNode: PVirtualNode=nil): Boolean; overload; var Node: PVirtualNode; begin // Helper to focus and highlight a node by its index Node := FindNode(VT, idx, ParentNode); if Assigned(Node) then - SelectNode(VT, Node); + Result := SelectNode(VT, Node) + else + Result := False; end; -procedure SelectNode(VT: TVirtualStringTree; Node: PVirtualNode); overload; +function SelectNode(VT: TVirtualStringTree; Node: PVirtualNode; ClearSelection: Boolean=True): Boolean; overload; var OldFocus: PVirtualNode; + MinimumColumnIndex: TColumnIndex; begin if Node = VT.RootNode then Node := nil; OldFocus := VT.FocusedNode; - VT.ClearSelection; - VT.FocusedNode := Node; - VT.Selected[Node] := True; - VT.ScrollIntoView(Node, False); - if (OldFocus = Node) and Assigned(VT.OnFocusChanged) then - VT.OnFocusChanged(VT, Node, VT.Header.MainColumn); + Result := True; + if (Node <> OldFocus) and Assigned(VT.OnFocusChanging) then begin + VT.OnFocusChanging(VT, OldFocus, Node, VT.FocusedColumn, VT.FocusedColumn, Result); + end; + if Result then begin + if ClearSelection then + VT.ClearSelection; + VT.FocusedNode := Node; + MinimumColumnIndex := VT.Header.Columns.GetFirstVisibleColumn(True); + if VT.FocusedColumn < MinimumColumnIndex then + VT.FocusedColumn := MinimumColumnIndex; + VT.Selected[Node] := True; + VT.ScrollIntoView(Node, False); + if (OldFocus = Node) and Assigned(VT.OnFocusChanged) then + VT.OnFocusChanged(VT, Node, VT.FocusedColumn); + end; end; @@ -1682,6 +1801,29 @@ function DateBackFriendlyCaption(d: TDateTime): String; end; +function DateTimeToStrDef(DateTime: TDateTime; Default: String) : String; +begin + try + if DateTime = 0 then + Result := Default + else + Result := DateTimeToStr(DateTime); + except + on EInvalidOp do Result := Default; + end; +end; + + +function TruncDef(X: Real; Default: Int64): Int64; +begin + try + Result := Trunc(X); + except + on EInvalidOp do Result := Default; + end; +end; + + procedure ExplodeQuotedList(Text: String; var List: TStringList); var i: Integer; @@ -1729,112 +1871,78 @@ function GetLightness(AColor: TColor): Byte; end; -function ReformatSQL(SQL: String): String; + +{ *** TSortItem } + +procedure TSortItem.Assign(Source: TPersistent); var - AllKeywords, ImportantKeywords, PairKeywords: TStringList; - i, Run, KeywordMaxLen: Integer; - IsEsc, IsQuote, InComment, InBigComment, InString, InKeyword, InIdent, LastWasComment: Boolean; - c, p: Char; - Keyword, PreviousKeyword, TestPair: String; - Datatypes: TDBDataTypeArray; -const - WordChars = ['a'..'z', 'A'..'Z', '0'..'9', '_', '.']; - WhiteSpaces = [#9, #10, #13, #32]; -begin - // Known SQL keywords, get converted to UPPERCASE - AllKeywords := TStringList.Create; - AllKeywords.Text := MySQLKeywords.Text; - for i:=Low(MySQLFunctions) to High(MySQLFunctions) do begin - // Leave out operator functions like ">>", and the "X()" function so hex values don't get touched - if (MySQLFunctions[i].Declaration <> '') and (MySQLFunctions[i].Name <> 'X') then - AllKeywords.Add(MySQLFunctions[i].Name); - end; - Datatypes := Mainform.ActiveConnection.Datatypes; - for i:=Low(Datatypes) to High(Datatypes) do - AllKeywords.Add(Datatypes[i].Name); - KeywordMaxLen := 0; - for i:=0 to AllKeywords.Count-1 do - KeywordMaxLen := Max(KeywordMaxLen, Length(AllKeywords[i])); - - // A subset of the above list, each of them will get a linebreak left to it - ImportantKeywords := Explode(',', 'SELECT,FROM,LEFT,RIGHT,STRAIGHT,NATURAL,INNER,JOIN,WHERE,GROUP,ORDER,HAVING,LIMIT,CREATE,DROP,UPDATE,INSERT,REPLACE,TRUNCATE,DELETE'); - // Keywords which followers should not get separated into a new line - PairKeywords := Explode(',', 'LEFT,RIGHT,STRAIGHT,NATURAL,INNER,ORDER,GROUP'); - - IsEsc := False; - InComment := False; - InBigComment := False; - LastWasComment := False; - InString := False; - InIdent := False; - Run := 1; - Result := ''; - SQL := SQL + ' '; - SetLength(Result, Length(SQL)*2); - Keyword := ''; - PreviousKeyword := ''; - for i:=1 to Length(SQL) do begin - c := SQL[i]; // Current char - if i > 1 then p := SQL[i-1] else p := #0; // Previous char - - // Detection logic - where are we? - if c = '\' then IsEsc := not IsEsc - else IsEsc := False; - IsQuote := (c = '''') or (c = '"'); - if c = '`' then InIdent := not InIdent; - if (not IsEsc) and IsQuote then InString := not InString; - if (c = '#') or ((c = '-') and (p = '-')) then InComment := True; - if ((c = #10) or (c = #13)) and InComment then begin - LastWasComment := True; - InComment := False; - end; - if (c = '*') and (p = '/') and (not InComment) and (not InString) then InBigComment := True; - if (c = '/') and (p = '*') and (not InComment) and (not InString) then InBigComment := False; - InKeyword := (not InComment) and (not InBigComment) and (not InString) and (not InIdent) and CharInSet(c, WordChars); + SourceItem: TSortItem; +begin + if Source is TSortItem then begin + SourceItem := Source as TSortItem; + Column := SourceItem.Column; + Order := SourceItem.Order; + end + else + Inherited; +end; - // Creation of returning text - if InKeyword then begin - Keyword := Keyword + c; - end else begin - if Keyword <> '' then begin - if AllKeywords.IndexOf(KeyWord) > -1 then begin - while (Run > 1) and CharInSet(Result[Run-1], WhiteSpaces) do - Dec(Run); - Keyword := UpperCase(Keyword); - if Run > 1 then begin - // SELECT, WHERE, JOIN etc. get a new line, but don't separate LEFT JOIN with linebreaks - if LastWasComment or ((ImportantKeywords.IndexOf(Keyword) > -1) and (PairKeywords.IndexOf(PreviousKeyword) = -1)) then - Keyword := CRLF + Keyword - else if (Result[Run-1] <> '(') then - Keyword := ' ' + Keyword; - end; - LastWasComment := False; - end; - PreviousKeyword := Trim(Keyword); - Insert(Keyword, Result, Run); - Inc(Run, Length(Keyword)); - Keyword := ''; - end; - if (not InComment) and (not InBigComment) and (not InString) and (not InIdent) then begin - TestPair := Result[Run-1] + c; - if (TestPair = ' ') or (TestPair = '( ') then begin - c := Result[Run-1]; - Dec(Run); - end; - if (TestPair = ' )') or (TestPair = ' ,') then - Dec(Run); - end; - Result[Run] := c; - Inc(Run); - end; +{ *** TSortItems } + +function TSortItems.AddNew(Column: String=''; Order: TSortItemOrder=sioAscending): TSortItem; +begin + Result := TSortItem.Create; + Result.Column := Column; + Result.Order := Order; + Add(Result); +end; + + +function TSortItems.ComposeOrderClause(Connection: TDBConnection): String; +var + SortItem: TSortItem; + SortOrder: String; +begin + // Concat all sort options to an ORDER BY clause + Result := ''; + for SortItem in Self do begin + if Result <> '' then + Result := Result + ', '; + if SortItem.Order = sioAscending then + SortOrder := Connection.SqlProvider.GetSql(qOrderAsc) + else + SortOrder := Connection.SqlProvider.GetSql(qOrderDesc); + Result := Result + Connection.QuoteIdent(SortItem.Column) + ' ' + SortOrder; end; +end; - // Cut overlength - SetLength(Result, Run-2); + +function TSortItems.FindByColumn(Column: String): TSortItem; +var + SortItem: TSortItem; +begin + Result := nil; + for SortItem in Self do begin + if SortItem.Column = Column then begin + Result := SortItem; + Break; + end; + end; end; +procedure TSortItems.Assign(Source: TSortItems); +var + Item, ItemCopy: TSortItem; +begin + Clear; + for Item in Source do begin + ItemCopy := AddNew; + ItemCopy.Assign(Item); + end; +end; + { *** TDBObjectEditor } @@ -1844,6 +1952,8 @@ constructor TDBObjectEditor.Create(AOwner: TComponent); // Do not set alClient via DFM! In conjunction with ExplicitXXX properties that // repeatedly breaks the GUI layout when you reload the project Align := alClient; + FMainSynMemo := nil; + DBObject := nil; TranslateComponent(Self); end; @@ -1857,6 +1967,11 @@ procedure TDBObjectEditor.SetModified(Value: Boolean); FModified := Value; end; +function TDBObjectEditor.ObjectExists: Boolean; +begin + Result := not DBObject.Name.IsEmpty; +end; + procedure TDBObjectEditor.Init(Obj: TDBObject); var editName: TWinControl; @@ -1864,10 +1979,16 @@ procedure TDBObjectEditor.Init(Obj: TDBObject); popup: TPopupMenu; Item: TMenuItem; i: Integer; + IsRefresh: Boolean; begin Mainform.ShowStatusMsg(_('Initializing editor ...')); Mainform.LogSQL(Self.ClassName+'.Init, using object "'+Obj.Name+'"', lcDebug); TExtForm.FixControls(Self); + IsRefresh := Assigned(DBObject) and DBObject.IsSameAs(Obj); + if IsRefresh and Assigned(FMainSynMemo) then + FMainSynMemoPreviousTopLine := FMainSynMemo.TopLine + else + FMainSynMemoPreviousTopLine := 0; DBObject := TDBObject.Create(Obj.Connection); DBObject.Assign(Obj); Mainform.UpdateEditorTab; @@ -1932,6 +2053,7 @@ function TDBObjectEditor.DeInit: TModalResult; Result := mrOk; if Modified then begin ObjType := _(LowerCase(DBObject.ObjType)); + // Todo: no save button for objects without minimum requirements, such as name. See #1134 if DBObject.Name <> '' then Msg := f_('Save modified %s "%s"?', [ObjType, DBObject.Name]) else @@ -1964,7 +2086,7 @@ function ParamStrToBlob(out cbData: DWORD): Pointer; var cmd: String; begin - cmd := Windows.GetCommandLine; + cmd := GetCommandLine; cbData := Length(cmd)*2 + 3; Result := PChar(cmd); end; @@ -2017,7 +2139,7 @@ procedure HandleSecondInstance; // FreeMemory(Dat.lpData); // Bring first instance to front - if not IsWindowVisible(Wnd) then + if IsIconic(Wnd) then ShowWindow(Wnd, SW_RESTORE); BringWindowToTop(Wnd); SetForegroundWindow(Wnd); @@ -2173,7 +2295,7 @@ function CompareAnyNode(Text1, Text2: String): Integer; end; if (not NumberMode) or (Result=0) then begin // Compare Strings - Result := CompareText(Text1, Text2); + Result := CompareText(Text1, Text2, loUserLocale); end; end; @@ -2332,6 +2454,13 @@ function IsNotEmpty(Str: String): Boolean; Result := Str <> ''; end; +function IfEmpty(Str: String; WhenEmpty: String): String; +begin + if Str.IsEmpty then + Result := WhenEmpty + else + Result := Str; +end; function MessageDialog(const Msg: string; DlgType: TMsgDlgType; Buttons: TMsgDlgButtons): Integer; begin @@ -2339,7 +2468,7 @@ function MessageDialog(const Msg: string; DlgType: TMsgDlgType; Buttons: TMsgDlg end; -function MessageDialog(const Title, Msg: string; DlgType: TMsgDlgType; Buttons: TMsgDlgButtons; KeepAskingSetting: TAppSettingIndex=asUnused): Integer; +function MessageDialog(const Title, Msg: string; DlgType: TMsgDlgType; Buttons: TMsgDlgButtons; KeepAskingSetting: TAppSettingIndex=asUnused; FooterText: String=''): Integer; var m: String; Dialog: TTaskDialog; @@ -2366,7 +2495,7 @@ function MessageDialog(const Title, Msg: string; DlgType: TMsgDlgType; Buttons: cap := _(BtnCaption); for i:=1 to Length(cap) do begin // Auto apply hotkey - if (Pos(LowerCase(cap[i]), Hotkeys) = 0) and Character.TCharacter.IsLetter(cap[i]) then begin + if (Pos(LowerCase(cap[i]), Hotkeys) = 0) and cap[i].IsLetter then begin Hotkeys := Hotkeys + LowerCase(cap[i]); Insert('&', cap, i); break; @@ -2379,6 +2508,9 @@ function MessageDialog(const Title, Msg: string; DlgType: TMsgDlgType; Buttons: Btn.Default := True; end; begin + // Remember current path and restore it later, so the caller does not try to read from the wrong path after this dialog + AppSettings.StorePath; + if (Win32MajorVersion >= 6) and StyleServices.Enabled then begin // Use modern task dialog on Vista and above Dialog := TTaskDialog.Create(nil); @@ -2396,11 +2528,14 @@ function MessageDialog(const Title, Msg: string; DlgType: TMsgDlgType; Buttons: end; if Title <> Dialog.Caption then Dialog.Title := Title; - if Assigned(MainForm) and (MainForm.ActiveConnection <> nil) then + if Assigned(MainForm) and (MainForm.ActiveConnection <> nil) and (MainForm.ActiveConnection.Parameters <> nil) then Dialog.Caption := MainForm.ActiveConnection.Parameters.SessionName + ': ' + Dialog.Caption; rx := TRegExpr.Create; - rx.Expression := 'https?://\S+'; - Dialog.Text := rx.Replace(Msg, '$0', True); + rx.Expression := 'https?://[^\s"]+'; + if ThemeIsDark then + Dialog.Text := Msg + else // See issue #2036 + Dialog.Text := rx.Replace(Msg, '$0', True); rx.Free; // Main icon, and footer link @@ -2418,16 +2553,13 @@ function MessageDialog(const Title, Msg: string; DlgType: TMsgDlgType; Buttons: else WebSearchHost := '[unknown host]'; rx.Free; - Dialog.FooterText := ''+_('Find some help on this error')+' (=> '+WebSearchHost+')'; + Dialog.FooterText := IfThen(FooterText.IsEmpty, '', FooterText + sLineBreak + sLineBreak) + + ''+_('Find some help on this error')+' (=> '+WebSearchHost+')'; Dialog.FooterIcon := tdiInformation; end; mtInformation: Dialog.MainIcon := tdiInformation; mtConfirmation, mtCustom: begin - if not Assigned(ConfirmIcon) then begin - ConfirmIcon := TIcon.Create; - ConfirmIcon.LoadFromResourceName(hInstance, 'Z_ICONQUESTION'); - end; Dialog.Flags := Dialog.Flags + [tfUseHiconMain]; Dialog.CustomMainIcon := ConfirmIcon; end; @@ -2478,8 +2610,10 @@ function MessageDialog(const Title, Msg: string; DlgType: TMsgDlgType; Buttons: end else begin // Backwards compatible dialog on Windows XP m := Msg; - if Title <> '' then - m := Title + CRLF + CRLF + m; + if not Title.IsEmpty then + m := Title + SLineBreak + SLineBreak + m; + if not FooterText.IsEmpty then + m := m + SLineBreak + SLineBreak + FooterText; if KeepAskingSetting <> asUnused then KeepAskingValue := AppSettings.ReadBool(KeepAskingSetting) @@ -2491,12 +2625,14 @@ function MessageDialog(const Title, Msg: string; DlgType: TMsgDlgType; Buttons: else Result := mrNo; end; + + AppSettings.RestorePath; end; function ErrorDialog(Msg: string): Integer; begin - Result := MessageDialog(Msg, mtError, [mbOK]); + Result := MessageDialog('', Msg, mtError, [mbOK]); end; @@ -2539,12 +2675,13 @@ function GetHTMLCharsetByEncoding(Encoding: TEncoding): String; end; -procedure ParseCommandLine(CommandLine: String; var ConnectionParams: TConnectionParameters; var FileNames: TStringList); +procedure ParseCommandLine(CommandLine: String; var ConnectionParams: TConnectionParameters; var FileNames: TStringList; var RunFrom: String); var rx: TRegExpr; ExeName, SessName, Host, Lib, Port, User, Pass, Socket, AllDatabases, - SSLPrivateKey, SSLCACertificate, SSLCertificate, SSLCipher: String; - NetType, WindowsAuth, WantSSL, CleartextPluginEnabled: Integer; + SSLPrivateKey, SSLCACertificate, SSLCertificate, SSLCipher, + SshExe, SshHost, SshPort, SshLocalPort, SshUser, SshPassword, SshKey, SshTimeout: String; + NetType, WindowsAuth, WantSSL, CleartextPluginEnabled, SSLVerification: Integer; AbsentFiles: TStringList; function GetParamValue(ShortName, LongName: String): String; @@ -2590,6 +2727,10 @@ procedure ParseCommandLine(CommandLine: String; var ConnectionParams: TConnectio CommandLine := Copy(CommandLine, Pos(ExeName, CommandLine)+Length(ExeName), Length(CommandLine)); CommandLine := CommandLine + ' '; rx := TRegExpr.Create; + + // --runfrom=scheduler after build update + RunFrom := GetParamValue('rf', 'runfrom'); + SessName := GetParamValue('d', 'description'); if SessName <> '' then begin try @@ -2598,7 +2739,6 @@ procedure ParseCommandLine(CommandLine: String; var ConnectionParams: TConnectio on E:Exception do begin // Session params not found in registry MainForm.LogSQL(E.Message); - SessName := ''; end; end; end; @@ -2620,7 +2760,16 @@ procedure ParseCommandLine(CommandLine: String; var ConnectionParams: TConnectio SSLCACertificate := GetParamValue('sslca', 'sslcacertificate'); SSLCertificate := GetParamValue('sslcert', 'sslcertificate'); SSLCipher := GetParamValue('sslcip', 'sslcipher'); + SSLVerification := StrToIntDef(GetParamValue('sslvrf', 'sslverification'), -1); // Leave out support for startup script, seems reasonable for command line connecting + SshExe := GetParamValue('se', 'ssh-executable'); + SshHost := GetParamValue('sh', 'ssh-host'); + SshPort := GetParamValue('sP', 'ssh-port'); + SshLocalPort := GetParamValue('sLP', 'ssh-local-port'); + SshUser := GetParamValue('su', 'ssh-user'); + SshPassword := GetParamValue('sp', 'ssh-password'); + SshKey := GetParamValue('sk', 'ssh-key'); + SshTimeout := GetParamValue('st', 'ssh-timeout'); if (Host <> '') or (User <> '') or (Pass <> '') or (Port <> '') or (Socket <> '') or (AllDatabases <> '') then begin if not Assigned(ConnectionParams) then begin @@ -2656,13 +2805,39 @@ procedure ParseCommandLine(CommandLine: String; var ConnectionParams: TConnectio ConnectionParams.SSLCertificate := SSLCertificate; if SSLCipher <> '' then ConnectionParams.SSLCipher := SSLCipher; + if SSLVerification >= 0 then + ConnectionParams.SSLVerification := SSLVerification; if WindowsAuth in [0,1] then ConnectionParams.WindowsAuth := Boolean(WindowsAuth); - // Ensure we have a session name to pass to InitConnection - if (ConnectionParams.SessionPath = '') and (ConnectionParams.Hostname <> '') then - ConnectionParams.SessionPath := ConnectionParams.Hostname; + if not SshHost.IsEmpty then begin + ConnectionParams.SSHActive := True; + if not SshExe.IsEmpty then + ConnectionParams.SSHExe := SshExe; + if not SshHost.IsEmpty then + ConnectionParams.SSHHost := SshHost; + if not SshPort.IsEmpty then + ConnectionParams.SSHPort := StrToIntDef(SshPort, ConnectionParams.SSHPort); + if not SshLocalPort.IsEmpty then + ConnectionParams.SSHLocalPort := StrToIntDef(SshLocalPort, ConnectionParams.SSHLocalPort); + if not SshUser.IsEmpty then + ConnectionParams.SSHUser := SshUser; + if not SshPassword.IsEmpty then + ConnectionParams.SSHPassword := SshPassword; + if not SshKey.IsEmpty then + ConnectionParams.SSHPrivateKey := SshKey; + if not SshTimeout.IsEmpty then + ConnectionParams.SSHTimeout := StrToIntDef(SshTimeout, ConnectionParams.SSHTimeout); + end; + + if ConnectionParams.SessionPath.IsEmpty then begin + // Ensure we have a (random) session name to pass to InitConnection + ConnectionParams.SessionPath := IfEmpty(ConnectionParams.Hostname, 'temp')+'-'+GeneratePassword(4); + end; + + // Delete stored session in Destroy: + ConnectionParams.DeleteAfterUse := True; end; // Check for valid filename(s) in parameters. @@ -2678,28 +2853,38 @@ procedure ParseCommandLine(CommandLine: String; var ConnectionParams: TConnectio function f_(const Pattern: string; const Args: array of const): string; +var + TranslatedPattern: String; begin // Helper for translation, replacement for Format(_()) - Result := Format(_(Pattern), Args); + try + TranslatedPattern := _(Pattern); + Result := Format(TranslatedPattern, Args); + except + on E:Exception do begin + MainForm.LogSQL(E.ClassName+' in translation string with invalid format arguments: "'+TranslatedPattern+'"', lcError); + Result := Format(Pattern, Args); + end; + end; end; function GetOutputFilename(FilenameWithPlaceholders: String; DBObj: TDBObject): String; var - Arguments: TStringList; + Arguments: TExtStringList; Year, Month, Day, Hour, Min, Sec, MSec: Word; i: Integer; begin // Rich format output filename, replace certain markers. See issue #2622 - Arguments := TStringList.Create; + Arguments := TExtStringList.Create; if Assigned(DBObj) then begin - Arguments.Values['session'] := goodfilename(DBObj.Connection.Parameters.SessionName); - Arguments.Values['host'] := goodfilename(DBObj.Connection.Parameters.Hostname); - Arguments.Values['u'] := goodfilename(DBObj.Connection.Parameters.Username); - Arguments.Values['db'] := goodfilename(DBObj.Database); + Arguments.Values['session'] := ValidFilename(DBObj.Connection.Parameters.SessionName); + Arguments.Values['host'] := ValidFilename(DBObj.Connection.Parameters.Hostname); + Arguments.Values['u'] := ValidFilename(DBObj.Connection.Parameters.Username); + Arguments.Values['db'] := ValidFilename(DBObj.Database); end; - Arguments.Values['date'] := goodfilename(DateTimeToStr(Now)); + Arguments.Values['date'] := ValidFilename(DateTimeToStr(Now)); DecodeDateTime(Now, Year, Month, Day, Hour, Min, Sec, MSec); Arguments.Values['d'] := Format('%.2d', [Day]); Arguments.Values['m'] := Format('%.2d', [Month]); @@ -2764,45 +2949,44 @@ function GetSystemImageIndex(Filename: String): Integer; function GetExecutableBits: Byte; -const - kb32 = 1024 * 32; -var - ExeFilename: String; - Buffer: Array[0..kb32-1] of Byte; // warning: assuming both headers are in there! - hFile: DWord; - bRead: DWord; - bToRead: DWord; - pDos: PImageDosHeader; - pNt: PImageNtHeaders; begin + {$IFDEF WIN64} + Result := 64; + {$ELSE} Result := 32; - ExeFilename := ParamStr(0); - hFile := CreateFile(pChar(ExeFilename), GENERIC_READ, FILE_SHARE_READ, NIL, OPEN_EXISTING, 0, 0); - if hFile <> INVALID_HANDLE_VALUE then try - bToRead := GetFileSize(hFile, NIL); - if bToRead > kb32 then - bToRead := kb32; - if not ReadFile(hFile, Buffer, bToRead, bRead, NIL) then - Exit; - if bRead = bToRead then begin - pDos := @Buffer[0]; - if pDos.e_magic = IMAGE_DOS_SIGNATURE then begin - pNt := PImageNtHeaders(LongInt(pDos) + pDos._lfanew); - if pNt.Signature = IMAGE_NT_SIGNATURE then begin - if pNt.FileHeader.Machine and IMAGE_FILE_32BIT_MACHINE > 0 then - Result := 32 - else - Result := 64 - end; - end; - end; - finally - CloseHandle(hFile); - end; + {$ENDIF} end; - -procedure Help(Sender: TObject; Anchor: String); +procedure GetExecutableVersion(FileName: String; var MajorVer, MinorVer, ReleaseVer, RevisionVer: Word); +var + dwInfoSize, // Size of VERSIONINFO structure + dwVerSize, // Size of Version Info Data + dwWnd: DWORD; // Handle for the size call. + FI: PVSFixedFileInfo; // Delphi structure; see WINDOWS.PAS + ptrVerBuf: Pointer; +begin + // Detect version of given executable or library + MajorVer := 0; + MinorVer := 0; + ReleaseVer := 0; + RevisionVer := 0; + try + dwInfoSize := GetFileVersionInfoSize(PChar(FileName), dwWnd); + GetMem(ptrVerBuf, dwInfoSize); + GetFileVersionInfo(PChar(FileName), dwWnd, dwInfoSize, ptrVerBuf); + VerQueryValue(ptrVerBuf, '\', Pointer(FI), dwVerSize ); + MajorVer := HiWord(FI.dwFileVersionMS); + MinorVer := LoWord(FI.dwFileVersionMS); + ReleaseVer := HiWord(FI.dwFileVersionLS); + RevisionVer := LoWord(FI.dwFileVersionLS); + FreeMem(ptrVerBuf); + except + // Silence any error + end; +end; + + +procedure Help(Sender: TObject; Anchor: String); var Place: String; begin @@ -2874,52 +3058,6 @@ function FileIsWritable(FilePath: String): Boolean; end; -function RunningOnWindows10S: Boolean; -const - PRODUCT_CLOUD = $000000B2; //* Windows 10 S - PRODUCT_CLOUDN = $000000B3; //* Windows 10 S N - PRODUCT_CORE = $00000065; //* Windows 10 Home -var - pdwReturnedProductType: DWORD; -begin - // Detect if we're running on Windows 10 S - // Taken from https://forums.embarcadero.com/message.jspa?messageID=900804 - Result := False; - // Avoid crash on WinXP - if Win32MajorVersion >= 6 then begin - if GetProductInfo(Win32MajorVersion, Win32MinorVersion, TOSVersion.ServicePackMajor, TOSVersion.ServicePackMinor, pdwReturnedProductType) then begin - Result := (pdwReturnedProductType = PRODUCT_CLOUD) OR (pdwReturnedProductType = PRODUCT_CLOUDN); - end; - end; -end; - - -function GetUwpFullName: String; -var - Len: Cardinal; - Name: String; -begin - // Detect current Microsoft Store package name - // See https://stackoverflow.com/questions/48549899/how-to-detect-universal-windows-platform-uwp-in-delphi - Result := ''; - if (Win32MajorVersion > 6) or ((Win32MajorVersion = 6) and (Win32MinorVersion > 1)) then begin - // Windows 10, but not necessarily a Store App - Len := 0; - GetCurrentPackageFullName(Len, nil); - SetLength(Name, Len-1); - GetCurrentPackageFullName(Len, PWideChar(Name)); - if not Name.IsEmpty then - Result := Trim(Name); - end; -end; - - -function RunningAsUwp: Boolean; -begin - Result := GetUwpFullName <> ''; -end; - - function GetThemeColor(Color: TColor): TColor; begin // Not required with vcl-style-utils: @@ -2928,19 +3066,21 @@ function GetThemeColor(Color: TColor): TColor; end; -function ThemeIsDark(ThemeName: String): Boolean; +function ThemeIsDark(ThemeName: String=''): Boolean; const DarkThemes: String = 'Amakrits,Aqua Graphite,Auric,Carbon,Charcoal Dark Slate,Cobalt XEMedia,Glossy,Glow,Golden Graphite,Material,Onyx Blue,Ruby Graphite,TabletDark,Windows10 Dark,Windows10 SlateGray'; var DarkThemesList: TStringList; begin DarkThemesList := Explode(',', DarkThemes); + if ThemeName.IsEmpty then + ThemeName := TStyleManager.ActiveStyle.Name; Result := DarkThemesList.IndexOf(ThemeName) > -1; DarkThemesList.Free; end; -function ProcessExists(pid: Cardinal): Boolean; +function ProcessExists(pid: Cardinal; ExeNamePattern: String): Boolean; var Proc: TProcessEntry32; SnapShot: THandle; @@ -2952,7 +3092,7 @@ function ProcessExists(pid: Cardinal): Boolean; Result := False; ContinueLoop := Process32First(SnapShot, Proc); while ContinueLoop do begin - Result := Proc.th32ProcessID = pid; + Result := (Proc.th32ProcessID = pid) and ContainsText(Proc.szExeFile, ExeNamePattern); if Result then Break; ContinueLoop := Process32Next(SnapShot, Proc); @@ -2972,6 +3112,166 @@ procedure ToggleCheckBoxWithoutClick(chk: TCheckBox; State: Boolean); end; +function SynCompletionProposalPrettyText(ImageIndex: Integer; LeftText, CenterText, RightText: String; + LeftColor: TColor=-1; CenterColor: TColor=-1; RightColor: TColor=-1): String; +const + LineFormat = '\image{%d}\hspace{5}\color{%s}%s\column{}\color{%s}%s\hspace{10}\color{%s}\style{+i}%s'; +begin + // Return formatted item string for a TSynCompletionProposal + if LeftColor = -1 then LeftColor := clGrayText; + if CenterColor = -1 then CenterColor := clWindowText; + if RightColor = -1 then RightColor := clGrayText; + Result := Format(LineFormat, [ImageIndex, ColorToString(LeftColor), LeftText, ColorToString(CenterColor), CenterText, ColorToString(RightColor), RightText]); +end; + + +function PopupComponent(Sender: TObject): TComponent; +var + Menu: TObject; +begin + // Return owner component of clicked menu item, probably combined with a TAction + Result := nil; + Menu := nil; + if Sender is TAction then + Sender := (Sender as TAction).ActionComponent; + + if Sender is TMenuItem then + Menu := (Sender as TMenuItem).GetParentMenu + else if Sender is TPopupMenu then + Menu := Sender; + + if Menu is TPopupMenu then + Result := (Menu as TPopupMenu).PopupComponent; +end; + + +function IsWine: Boolean; +var + NTHandle: THandle; + wine_nt_to_unix_file_name: procedure(p1:pointer; p2:pointer); stdcall; +begin + // Detect if we're running on Wine, not on native Windows + // Idea taken from http://ruminatedrumblings.blogspot.com/2008/04/detecting-virtualized-environment.html + if IsWineStored = -1 then begin + NTHandle := LoadLibrary('NTDLL.DLL'); + if NTHandle>32 then + wine_nt_to_unix_file_name := GetProcAddress(NTHandle, 'wine_nt_to_unix_file_name') + else + wine_nt_to_unix_file_name := nil; + IsWineStored := IfThen(Assigned(wine_nt_to_unix_file_name), 1, 0); + FreeLibrary(NTHandle); + end; + Result := IsWineStored = 1; +end; + + +function DirSep: Char; +begin + if IsWine then + Result := '/' + else + Result := '\'; +end; + +procedure FindComponentInstances(BaseForm: TComponent; ClassType: TClass; var List: TObjectList); +var + i: Integer; +begin + for i:=0 to BaseForm.ComponentCount-1 do begin + if BaseForm.Components[i] is ClassType then + List.Add(BaseForm.Components[i] as ClassType) + else + FindComponentInstances(BaseForm.Components[i], ClassType, List); + end; +end; + +function WebColorStrToColorDef(WebColor: string; Default: TColor): TColor; +begin + try + Result := WebColorStrToColor(WebColor); + except + Result := Default; + end; +end; + + +function UserAgent(OwnerComponent: TComponent): String; +var + OS: String; +begin + if IsWine then + OS := 'Linux/Wine' + else + OS := 'Windows NT '+IntToStr(Win32MajorVersion)+'.'+IntToStr(Win32MinorVersion); + Result := APPNAME+'/'+MainForm.AppVersion+' ('+OS+'; '+ExtractFilename(Application.ExeName)+'; '+OwnerComponent.Name+')'; +end; + + +function CodeIndent(Steps: Integer=1): String; +begin + // Provide tab or spaces for indentation, uniquely used for all SQL statements + if AppSettings.ReadBool(asTabsToSpaces) then + Result := StringOfChar(' ', AppSettings.ReadInt(asTabWidth) * Steps) + else + Result := StringOfChar(#9, Steps); +end; + + +function EscapeHotkeyPrefix(Text: String): String; +begin + // Issue #1992: Escape ampersand in caption of menus and tabs, preventing underlined hotkey generation + Result := StringReplace(Text, Vcl.Menus.cHotkeyPrefix, Vcl.Menus.cHotkeyPrefix + Vcl.Menus.cHotkeyPrefix, [rfReplaceAll]); +end; + + +{ Get SID of current Windows user, probably useful in the future +function GetCurrentUserSID: string; +type + PTOKEN_USER = ^TOKEN_USER; + _TOKEN_USER = record + User: TSidAndAttributes; + end; + TOKEN_USER = _TOKEN_USER; +var + hToken: THandle; + cbBuf: Cardinal; + ptiUser: PTOKEN_USER; + bSuccess: Boolean; + StrSid: PWideChar; +begin + // Taken from https://stackoverflow.com/a/71730865/4110077 + // SidToString does not exist, prefer WinApi.Windows.ConvertSidToStringSid() + Result := ''; + + // Get the calling thread's access token. + if not OpenThreadToken(GetCurrentThread(), TOKEN_QUERY, True, hToken) then + begin + if (GetLastError <> ERROR_NO_TOKEN) then + Exit; + + // Retry against process token if no thread token exists. + if not OpenProcessToken(GetCurrentProcess, TOKEN_QUERY, hToken) then + Exit; + end; + try + // Obtain the size of the user information in the token. + bSuccess := GetTokenInformation(hToken, TokenUser, nil, 0, cbBuf); + ptiUser := nil; + try + while (not bSuccess) and (GetLastError = ERROR_INSUFFICIENT_BUFFER) do + begin + ReallocMem(ptiUser, cbBuf); + bSuccess := GetTokenInformation(hToken, TokenUser, ptiUser, cbBuf, cbBuf); + end; + ConvertSidToStringSid(ptiUser.User.Sid, StrSid); + Result := StrSid; + finally + FreeMem(ptiUser); + end; + finally + CloseHandle(hToken); + end; +end; } { Threading stuff } @@ -3021,32 +3321,38 @@ procedure TQueryThread.Execute; end else begin // Concat queries up to a size of max_allowed_packet if MaxAllowedPacket = 0 then begin - FConnection.LockedByThread := Self; + FConnection.SetLockedByThread(Self); MaxAllowedPacket := FConnection.MaxAllowedPacket; - FConnection.LockedByThread := nil; + FConnection.SetLockedByThread(nil); // TODO: Log('Detected maximum allowed packet size: '+FormatByteNumber(MaxAllowedPacket), lcDebug); end; BatchStartOffset := FBatch[i].LeftOffset; while i < FBatch.Count do begin PacketSize := FBatch[i].RightOffset - BatchStartOffset + ((i-FBatchPosition) * 20); - if (PacketSize >= MaxAllowedPacket) and (SQL <> '') then begin - // TODO: Log('Limiting batch packet size to '+FormatByteNumber(Length(SQL))+' with '+FormatNumber(i-FUserQueryOffset)+' queries.', lcDebug); - break; + if not SQL.IsEmpty then begin + if PacketSize >= MaxAllowedPacket then begin + // TODO: Log('Limiting batch packet size to '+FormatByteNumber(Length(SQL))+' with '+FormatNumber(i-FUserQueryOffset)+' queries.', lcDebug); + Break; + end + else begin + // Don't append to the very last query. See issue #1583 + SQL := SQL + '; '; + end; end; - SQL := SQL + FBatch[i].SQL + ';'; + SQL := SQL + FBatch[i].SQL; Inc(i); end; FQueriesInPacket := i - FBatchPosition; end; - Synchronize(BeforeQuery); + Synchronize(procedure begin MainForm.BeforeQueryExecution(Self); end); try - FConnection.LockedByThread := Self; + FConnection.SetLockedByThread(Self); DoStoreResult := ResultCount < AppSettings.ReadInt(asMaxQueryResults); if (not DoStoreResult) and (not LogMaxResultsDone) then begin // Inform user about preference setting for limiting result tabs - LogFromOutside( - f_('Reached maximum number of result tabs (%d). To display more results, increase setting in Preferences > SQL', [AppSettings.ReadInt(asMaxQueryResults)]), - lcInfo); + FConnection.Log(lcInfo, + f_('Reached maximum number of result tabs (%d). To display more results, increase setting in Preferences > SQL', [AppSettings.ReadInt(asMaxQueryResults)]) + ); LogMaxResultsDone := True; end; FConnection.Query(SQL, DoStoreResult, lcUserFiredSQL); @@ -3059,53 +3365,27 @@ procedure TQueryThread.Execute; Inc(FWarningCount, FConnection.WarningCount); except on E:EDbError do begin - if FStopOnErrors or (i = FBatch.Count - 1) then begin + if FStopOnErrors or (i = FBatch.Count) then begin FErrorMessage := E.Message; ErrorAborted := True; end; end; end; - FConnection.LockedByThread := nil; - Synchronize(AfterQuery); + FConnection.SetLockedByThread(nil); + Synchronize(procedure begin MainForm.AfterQueryExecution(Self); end); // Check if FAborted is set by the main thread, to avoid proceeding the loop in case // FStopOnErrors is set to false if FAborted or ErrorAborted then break; end; - Synchronize(BatchFinished); + Synchronize(procedure begin MainForm.FinishedQueryExecution(Self); end); end; -procedure TQueryThread.BeforeQuery; +procedure TQueryThread.LogFromThread(Msg: String; Category: TDBLogCategory); begin - MainForm.BeforeQueryExecution(Self); -end; - - -procedure TQueryThread.LogFromOutside(Msg: String; Category: TDBLogCategory); -begin - FLogMsg := Msg; - FLogCategory := Category; - Synchronize(Log); -end; - - -procedure TQueryThread.Log; -begin - FConnection.OnLog(FLogMsg, FLogCategory, FConnection); -end; - - -procedure TQueryThread.AfterQuery; -begin - MainForm.AfterQueryExecution(Self); -end; - - -procedure TQueryThread.BatchFinished; -begin - MainForm.FinishedQueryExecution(Self); + Queue(procedure begin FConnection.Log(Category, Msg); end); end; @@ -3126,63 +3406,41 @@ function TSQLSentence.GetSize: Integer; function TSQLSentence.GetSQL: String; begin - Result := Copy(FOwner.SQL, LeftOffset, RightOffset-LeftOffset); + // Result := Copy(FOwner.SQL, LeftOffset, RightOffset-LeftOffset); + // Probably faster than Copy(): + SetString(Result, PChar(FOwner.SQL) +LeftOffset -1, RightOffset-LeftOffset); end; function TSQLSentence.GetSQLWithoutComments: String; -var - InLineComment, InMultiLineComment: Boolean; - AddCur: Boolean; - i: Integer; - FullSQL: String; - Cur, Prev1, Prev2: Char; begin - // Strip comments out of SQL sentence - // TODO: leave quoted string literals and identifiers untouched - FullSQL := GetSQL; - Result := ''; - InLineComment := False; - InMultiLineComment := False; - Prev1 := #0; - Prev2 := #0; - for i:=1 to Length(FullSQL) do begin - Cur := FullSQL[i]; - AddCur := True; - if i > 1 then Prev1 := FullSQL[i-1]; - if i > 2 then Prev2 := FullSQL[i-2]; + Result := FOwner.GetSQLWithoutComments(GetSQL); +end; - if (Cur = '*') and (Prev1 = '/') then begin - InMultiLineComment := True; - Delete(Result, Length(Result), 1); // Delete comment chars - end - else if InMultiLineComment and (Cur = '/') and (Prev1 = '*') then begin - InMultiLineComment := False; - Delete(Result, Length(Result), 1); - AddCur := False; - end; - if not InMultiLineComment then begin - if InLineComment and ((Cur = #13) or (Cur = #10)) then begin - InLineComment := False; // Reset - end - else if Cur = '#' then begin - InLineComment := True; - end - else if (Cur = ' ') and (Prev1 = '-') and (Prev2 = '-') then begin - InLineComment := True; - Delete(Result, Length(Result)-1, 2); // Delete comment chars - end; - end; +{ TSQLBatch } - if AddCur and (not InLineComment) and (not InMultiLineComment) then begin - Result := Result + Cur; - end; +constructor TSQLBatch.Create(NetTypeGroup: TNetTypeGroup); +begin + inherited Create; + FQuotes := THashedStringList.Create; + FQuotes.CaseSensitive := True; + FQuotes.Sorted := True; + FQuotes.Add('"'); + FQuotes.Add(''''); + FEscape := '\'; + case NetTypeGroup of + ngMySQL: FQuotes.Add('`'); // MySQL/MariaDB only + ngPgSQL: FQuotes.Add('$$'); // PostgreSQL only ($abc$ unsupported) + ngSQLite: FEscape := ''''; end; end; - -{ TSQLBatch } +destructor TSQLBatch.Destroy; +begin + FQuotes.Free; + inherited; +end; function TSQLBatch.GetSize: Integer; var @@ -3198,13 +3456,12 @@ function TSQLBatch.GetSize: Integer; procedure TSQLBatch.SetSQL(Value: String); var i, AllLen, DelimLen, DelimStart, LastLeftOffset, RightOffset: Integer; - c, n, LastStringEncloser: Char; - Delim, DelimTest, QueryTest: String; + c, n: Char; + Delim, DelimTest, QueryTest, LastQuote, cn: String; InString, InComment, InBigComment, InEscape: Boolean; Marker: TSQLSentence; rx: TRegExpr; const - StringEnclosers = ['"', '''', '`']; NewLines = [#13, #10]; WhiteSpaces = NewLines + [#9, ' ']; begin @@ -3215,11 +3472,12 @@ procedure TSQLBatch.SetSQL(Value: String); i := 0; LastLeftOffset := 1; Delim := Mainform.Delimiter; - InString := False; // Loop in "enclosed string" or `identifier` - InComment := False; // Loop in one-line comment (# or --) - InBigComment := False; // Loop in /* multi-line */ or /*! condictional comment */ - InEscape := False; // Previous char was backslash - LastStringEncloser := #0; + + InString := False; // c is in "enclosed string" or `identifier` + InComment := False; // c is in one-line comment (# or --) + InBigComment := False; // c is in /* multi-line */ or /*! condictional comment */ + InEscape := False; // Previous char was backslash + LastQuote := #0; DelimLen := Length(Delim); rx := TRegExpr.Create; rx.Expression := '^\s*DELIMITER\s+(\S+)'; @@ -3230,20 +3488,27 @@ procedure TSQLBatch.SetSQL(Value: String); Inc(i); // Current and next char c := FSQL[i]; - if i < AllLen then n := FSQL[i+1] - else n := #0; + if i < AllLen then + n := FSQL[i+1] + else + n := #0; + cn := c + n; - // Check for comment syntax and for enclosed literals, so a query delimiter can be ignored + // Check for comment syntax, so a query delimiter can be ignored if (not InComment) and (not InBigComment) and (not InString) and ((c + n = '--') or (c = '#')) then InComment := True; if (not InComment) and (not InBigComment) and (not InString) and (c + n = '/*') then InBigComment := True; if InBigComment and (not InComment) and (not InString) and (c + n = '*/') then InBigComment := False; - if (not InEscape) and (not InComment) and (not InBigComment) and CharInSet(c, StringEnclosers) then begin - if (not InString) or (InString and (c = LastStringEncloser)) then begin - InString := not InString; - LastStringEncloser := c; + // Check for enclosed literals, so a query delimiter can be ignored + if (not InEscape) and (not InComment) and (not InBigComment) and (FQuotes.Contains(c) or FQuotes.Contains(cn)) then begin + if not InString then begin + InString := True; + LastQuote := IfThen(FQuotes.Contains(c), c, cn); + end + else if (c = LastQuote) or (cn = LastQuote) then begin + InString := False; end; end; if (CharInSet(c, NewLines) and (not CharInSet(n, NewLines))) or (i = 1) then begin @@ -3258,7 +3523,7 @@ procedure TSQLBatch.SetSQL(Value: String); end; end; if not InEscape then - InEscape := c = '\' + InEscape := c = FEscape else InEscape := False; @@ -3286,15 +3551,66 @@ procedure TSQLBatch.SetSQL(Value: String); end; end; end; + end; +function TSQLBatch.GetSQLWithoutComments: String; +begin + Result := GetSQLWithoutComments(SQL); +end; + +class function TSQLBatch.GetSQLWithoutComments(FullSQL: String): String; +var + InLineComment, InMultiLineComment: Boolean; + AddCur: Boolean; + i: Integer; + Cur, Prev1, Prev2: Char; +begin + // Strip comments out of SQL sentence + // TODO: leave quoted string literals and identifiers untouched + Result := ''; + InLineComment := False; + InMultiLineComment := False; + for i:=1 to Length(FullSQL) do begin + Cur := FullSQL[i]; + AddCur := True; + if i > 1 then Prev1 := FullSQL[i-1] else Prev1 := #0; + if i > 2 then Prev2 := FullSQL[i-2] else Prev2 := #0; + + if (Cur = '*') and (Prev1 = '/') then begin + InMultiLineComment := True; + System.Delete(Result, Length(Result), 1); // Delete comment chars + end + else if InMultiLineComment and (Cur = '/') and (Prev1 = '*') then begin + InMultiLineComment := False; + System.Delete(Result, Length(Result), 1); + AddCur := False; + end; + + if not InMultiLineComment then begin + if InLineComment and ((Cur = #13) or (Cur = #10)) then begin + InLineComment := False; // Reset + end + else if Cur = '#' then begin + InLineComment := True; + end + else if (not InLineComment) and (Cur = ' ') and (Prev1 = '-') and (Prev2 = '-') then begin + InLineComment := True; + System.Delete(Result, Length(Result)-1, 2); // Delete comment chars + end; + end; + + if AddCur and (not InLineComment) and (not InMultiLineComment) then begin + Result := Result + Cur; + end; + end; +end; { THttpDownload } constructor THttpDownload.Create(Owner: TComponent); begin FBytesRead := -1; - FContentLength := -1; FOwner := Owner; FTimeOut := 10; end; @@ -3309,17 +3625,11 @@ procedure THttpDownload.SendRequest(Filename: String); BytesInChunk, HeadSize, Reserved, TimeOutSeconds: Cardinal; LocalFile: File; DoStore: Boolean; - UserAgent, OS: String; HttpStatus: Integer; ContentChunk: UTF8String; begin DoStore := False; - if MainForm.IsWine then - OS := 'Linux/Wine' - else - OS := 'Windows NT '+IntToStr(Win32MajorVersion)+'.'+IntToStr(Win32MinorVersion); - UserAgent := APPNAME+'/'+MainForm.AppVersion+' ('+OS+'; '+ExtractFilename(Application.ExeName)+'; '+FOwner.Name+')'; - NetHandle := InternetOpen(PChar(UserAgent), INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0); + NetHandle := InternetOpen(PChar(UserAgent(FOwner)), INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0); // Do not let the user wait 30s TimeOutSeconds := FTimeOut * 1000; @@ -3329,16 +3639,9 @@ procedure THttpDownload.SendRequest(Filename: String); FLastContent := ''; try UrlHandle := InternetOpenURL(NetHandle, PChar(FURL), nil, 0, INTERNET_FLAG_RELOAD, 0); - if not Assigned(UrlHandle) then - raise Exception.CreateFmt(_('Could not open URL: %s'), [FURL]); - - // Detect content length - HeadSize := SizeOf(Head); - Reserved := 0; - if HttpQueryInfo(UrlHandle, HTTP_QUERY_CONTENT_LENGTH, @Head, HeadSize, Reserved) then - FContentLength := StrToIntDef(Head, -1) - else - raise Exception.CreateFmt(_('Server did not send required "Content-Length" header: %s'), [FURL]); + if not Assigned(UrlHandle) then begin + raise Exception.CreateFmt(_('Could not open %s (%s)'), [FURL, SysErrorMessage(GetLastError)]); + end; // Check if we got HTTP status 200 HeadSize := SizeOf(Head); @@ -3385,13 +3688,114 @@ procedure THttpDownload.SendRequest(Filename: String); +{ TExtStringList } +// taken from https://stackoverflow.com/questions/33893377/can-i-prevent-tstringlist-removing-key-value-pair-when-value-set-to-empty + +function TExtStringList.GetValue(const Name: string): string; +begin + Result := Self.GetValue(Name); +end; + + +procedure TExtStringList.SetValue(const Name, Value: string); +var + I: Integer; +begin + I := IndexOfName(Name); + if I < 0 then I := Add(''); + Put(I, Name + NameValueSeparator + Value); +end; + + +{ TSqlTranspiler } + +class function TSqlTranspiler.CreateTable(SQL: String; SourceDb, TargetDb: TDBConnection): String; +begin + Result := SQL; + + if SourceDb.Parameters.IsMySQL(False) and TargetDb.Parameters.IsMariaDB then begin + // Remove COLLATE clause from virtual column definition: + // `tax_status` varchar(255) COLLATE utf8mb4_unicode_ci GENERATED ALWAYS AS (json_unquote(json_extract(`price`,'$.taxStatus'))) VIRTUAL + Result := ReplaceRegExpr('\sCOLLATE\s\w+(\s+GENERATED\s)', Result, '$1', [rroModifierI, rroUseSubstitution]); + end; + +end; + + +{ TClipboardHelper } + +function TClipboardHelper.GetTryAsText: String; +var + AttemptsLeft: Integer; + Success: Boolean; + LastError: String; +begin + AttemptsLeft := 5; + Result := ''; + Success := False; + while AttemptsLeft > 0 do begin + Dec(AttemptsLeft); + try + Result := AsText; + Success := True; + Break; + except + // We could also just catch EClipboardException + on E:Exception do begin + LastError := E.Message; + Sleep(100); + end; + end; + end; + if not Success then + MainForm.LogSQL(LastError, lcError); +end; + +procedure TClipboardHelper.SetTryAsText(AValue: String); +var + AttemptsLeft: Integer; + Success: Boolean; + LastError: String; +begin + AttemptsLeft := 5; + Success := False; + while AttemptsLeft > 0 do begin + Dec(AttemptsLeft); + try + AsText := AValue; + Success := True; + Break; + except + // We could also just catch EClipboardException + on E:Exception do begin + LastError := E.Message; + Sleep(100); + end; + end; + end; + if not Success then + MainForm.LogSQL(LastError, lcError); +end; + + +procedure TWinControlHelper.TrySetFocus; +begin + try + if Enabled + and CanFocus then + SetFocus; + except + MessageBeep(MB_ICONWARNING); + end; +end; + + { TAppSettings } constructor TAppSettings.Create; var rx: TRegExpr; i: Integer; - DefaultSnippetsDirectory: String; PortableLockFile: String; NewFileHandle: THandle; begin @@ -3400,7 +3804,7 @@ constructor TAppSettings.Create; FReads := 0; FWrites := 0; - PortableLockFile := ExtractFilePath(ParamStr(0)) + FPortableLockFileBase; + PortableLockFile := GetAppDir + FPortableLockFileBase; // Use filename from command line. If not given, use file in directory of executable. rx := TRegExpr.Create; @@ -3413,7 +3817,7 @@ constructor TAppSettings.Create; end; // Default settings file, if not given per command line if FSettingsFile = '' then - FSettingsFile := ExtractFilePath(ParamStr(0)) + 'portable_settings.txt'; + FSettingsFile := GetAppDir + 'portable_settings.txt'; // Backwards compatibility: only settings file exists, create lock file in that case if FileExists(FSettingsFile) and (not FileExists(PortableLockFile)) then begin NewFileHandle := FileCreate(PortableLockFile); @@ -3455,6 +3859,9 @@ constructor TAppSettings.Create; InitSetting(asLastUsedDB, 'lastUsedDB', 0, False, '', True); InitSetting(asTreeBackground, 'TreeBackground', clNone, False, '', True); InitSetting(asIgnoreDatabasePattern, 'IgnoreDatabasePattern', 0, False, '', True); + InitSetting(asLogFileDdl, 'LogFileDdl', 0, False, '', True); + InitSetting(asLogFileDml, 'LogFileDml', 0, False, '', True); + InitSetting(asLogFilePath, 'LogFilePath', 0, False, DirnameUserAppData + 'Logs'+PathDelim+'%session'+PathDelim+'%db'+PathDelim+'%y%m%d.sql', True); if Screen.Fonts.IndexOf('Consolas') > -1 then InitSetting(asFontName, 'FontName', 0, False, 'Consolas') else @@ -3464,11 +3871,13 @@ constructor TAppSettings.Create; InitSetting(asDataFontName, 'DataFontName', 0, False, 'Tahoma'); InitSetting(asDataFontSize, 'DataFontSize', 8); InitSetting(asDataLocalNumberFormat, 'DataLocalNumberFormat', 0, True); + InitSetting(asLowercaseHex, 'LowercaseHex', 0, True); InitSetting(asHintsOnResultTabs, 'HintsOnResultTabs', 0, True); + InitSetting(asShowRowId, 'ShowRowId', 0, True); InitSetting(asHightlightSameTextBackground, 'HightlightSameTextBackground', GetThemeColor(clInfoBk)); InitSetting(asLogsqlnum, 'logsqlnum', 300); InitSetting(asLogsqlwidth, 'logsqlwidth', 2000); - InitSetting(asSessionLogsDirectory, 'SessionLogsDirectory', 0, False, DirnameUserAppData + 'Sessionlogs\'); + InitSetting(asSessionLogsDirectory, 'SessionLogsDirectory', 0, False, DirnameUserAppData + 'Sessionlogs' + PathDelim); InitSetting(asLogHorizontalScrollbar, 'LogHorizontalScrollbar', 0, False); InitSetting(asSQLColActiveLine, 'SQLColActiveLine', 0, False, 'clNone'); InitSetting(asSQLColMatchingBraceForeground, 'SQLColMatchingBraceForeground', 0, False, 'clBlack'); @@ -3477,6 +3886,7 @@ constructor TAppSettings.Create; InitSetting(asDatagridMaximumRows, 'DatagridMaximumRows', 100000); InitSetting(asDatagridRowsPerStep, 'DatagridRowsPerStep', 1000); InitSetting(asGridRowLineCount, 'GridRowLineCount', 1); + InitSetting(asColumnHeaderClick, 'ColumnHeaderClick', 0, True); InitSetting(asReuseEditorConfiguration, 'ReuseEditorConfiguration', 0, True); InitSetting(asLogToFile, 'LogToFile', 0, False); InitSetting(asMainWinMaximized, 'MainWinMaximized', 0, False); @@ -3500,10 +3910,12 @@ constructor TAppSettings.Create; InitSetting(asCodeFolding, 'CodeFolding', 0, True); InitSetting(asDisplayBLOBsAsText, 'DisplayBLOBsAsText', 0, True); InitSetting(asSingleQueries, 'SingleQueries', 0, True); - InitSetting(asMemoEditorWidth, 'MemoEditorWidth', 100); - InitSetting(asMemoEditorHeight, 'MemoEditorHeight', 100); + InitSetting(asMemoEditorWidth, 'MemoEditorWidth', 500); + InitSetting(asMemoEditorHeight, 'MemoEditorHeight', 200); InitSetting(asMemoEditorMaximized, 'MemoEditorMaximized', 0, False); InitSetting(asMemoEditorWrap, 'MemoEditorWrap', 0, False); + InitSetting(asMemoEditorHighlighter, 'MemoEditorHighlighter_%s', 0, False, 'General', True); + InitSetting(asMemoEditorAlwaysFormatCode, 'MemoEditorAlwaysFormatCode', 0, False); InitSetting(asDelimiter, 'Delimiter', 0, False, ';'); InitSetting(asSQLHelpWindowLeft, 'SQLHelp_WindowLeft', 0); InitSetting(asSQLHelpWindowTop, 'SQLHelp_WindowTop', 0); @@ -3511,16 +3923,19 @@ constructor TAppSettings.Create; InitSetting(asSQLHelpWindowHeight, 'SQLHelp_WindowHeight', 400); InitSetting(asSQLHelpPnlLeftWidth, 'SQLHelp_PnlLeftWidth', 150); InitSetting(asSQLHelpPnlRightTopHeight, 'SQLHelp_PnlRightTopHeight', 150); - InitSetting(asHost, 'Host', 0, False, '127.0.0.1', True); + InitSetting(asHost, 'Host', 0, False, '', True); InitSetting(asUser, 'User', 0, False, '', True); InitSetting(asPassword, 'Password', 0, False, '', True); InitSetting(asCleartextPluginEnabled, 'CleartextPluginEnabled', 0, False, '', True); + InitSetting(asForceUnicode, 'ForceUnicode', 0, True, '', True); InitSetting(asWindowsAuth, 'WindowsAuth', 0, False, '', True); InitSetting(asLoginPrompt, 'LoginPrompt', 0, False, '', True); InitSetting(asPort, 'Port', 0, False, '', True); - InitSetting(asLibrary, 'Library', 0, False, 'libmariadb.dll', True); + InitSetting(asLibrary, 'Library', 0, False, '', True); // Gets its default in TConnectionParameters.Create InitSetting(asAllProviders, 'AllProviders', 0, False); - InitSetting(asPlinkExecutable, 'PlinkExecutable', 0, False, 'plink.exe'); + InitSetting(asSSHtunnelActive, 'SSHtunnelActive', -1, False, '', True); + InitSetting(asPlinkExecutable, 'PlinkExecutable', 0, False, 'plink.exe'); // Legacy support with global setting + InitSetting(asSshExecutable, 'SshExecutable', 0, False, '', True); InitSetting(asSSHtunnelHost, 'SSHtunnelHost', 0, False, '', True); InitSetting(asSSHtunnelHostPort, 'SSHtunnelHostPort', 22, False, '', True); InitSetting(asSSHtunnelPort, 'SSHtunnelPort', 0, False, '', True); @@ -3533,6 +3948,8 @@ constructor TAppSettings.Create; InitSetting(asSSLCert, 'SSL_Cert', 0, False, '', True); InitSetting(asSSLCA, 'SSL_CA', 0, False, '', True); InitSetting(asSSLCipher, 'SSL_Cipher', 0, False, '', True); + InitSetting(asSSLVerification, 'SSL_Verification', 2, False, '', True); + InitSetting(asSSLWarnUnused, 'SSL_WarnUnused', 0, True); InitSetting(asNetType, 'NetType', Integer(ntMySQL_TCPIP), False, '', True); InitSetting(asCompressed, 'Compressed', 0, False, '', True); InitSetting(asLocalTimeZone, 'LocalTimeZone', 0, False, '', True); @@ -3543,6 +3960,7 @@ constructor TAppSettings.Create; InitSetting(asComment, 'Comment', 0, False, '', True); InitSetting(asDatabaseFilter, 'DatabaseFilter', 0, False, ''); InitSetting(asTableFilter, 'TableFilter', 0, False, ''); + InitSetting(asFilterVT, 'FilterVTHistory', 0, False, ''); InitSetting(asExportSQLCreateDatabases, 'ExportSQL_CreateDatabases', 0, False); InitSetting(asExportSQLCreateTables, 'ExportSQL_CreateTables', 0, False); InitSetting(asExportSQLDataHow, 'ExportSQL_DataHow', 0); @@ -3554,6 +3972,7 @@ constructor TAppSettings.Create; InitSetting(asExportSQLServerDatabase, 'ExportSQL_ServerDatabase', 0, False, ''); InitSetting(asExportSQLOutput, 'ExportSQL_Output', 0); InitSetting(asExportSQLAddComments, 'ExportSQLAddComments', 0, True); + InitSetting(asExportSQLTransactions, 'ExportSQLTransactions', 0, False); InitSetting(asExportSQLRemoveAutoIncrement, 'ExportSQLRemoveAutoIncrement', 0, False); InitSetting(asExportSQLRemoveDefiner, 'ExportSQLRemoveDefiner', 0, True); InitSetting(asGridExportWindowWidth, 'GridExportWindowWidth', 400); @@ -3567,15 +3986,16 @@ constructor TAppSettings.Create; InitSetting(asGridExportSelection, 'GridExportSelection', 1); InitSetting(asGridExportColumnNames, 'GridExportColumnNames', 0, True); InitSetting(asGridExportIncludeAutoInc, 'GridExportAutoInc', 0, True); + InitSetting(asGridExportFocusedColumnOnly, 'GridExportFocusedColumnOnly', 0, False); InitSetting(asGridExportIncludeQuery, 'GridExportIncludeQuery', 0, False); InitSetting(asGridExportRemoveLinebreaks, 'GridExportRemoveLinebreaks', 0, False); + InitSetting(asGridExportOpenFile, 'GridExportOpenFile', 0, False); InitSetting(asGridExportSeparator, 'GridExportSeparator', 0, False, ';'); InitSetting(asGridExportEncloser, 'GridExportEncloser', 0, False, ''); InitSetting(asGridExportTerminator, 'GridExportTerminator', 0, False, '\r\n'); InitSetting(asGridExportNull, 'GridExportNull', 0, False, '\N'); // Copy to clipboard defaults: - InitSetting(asGridExportClpFormat, 'GridExportClpFormat', 0); - InitSetting(asGridExportClpColumnNames, 'GridExportClpColumnNames', 0, False); + InitSetting(asGridExportClpColumnNames, 'GridExportClpColumnNames', 0, True); InitSetting(asGridExportClpIncludeAutoInc, 'GridExportClpAutoInc', 0, True); InitSetting(asGridExportClpRemoveLinebreaks, 'GridExportClpRemoveLinebreaks', 0, False); InitSetting(asGridExportClpSeparator, 'GridExportClpSeparator', 0, False, ';'); @@ -3588,7 +4008,7 @@ constructor TAppSettings.Create; InitSetting(asCSVImportTerminator, 'CSVTerminator', 0, False, '\r\n'); InitSetting(asCSVImportFieldEscaper, 'CSVImportFieldEscaperV2', 0, False, '"'); InitSetting(asCSVImportWindowWidth, 'CSVImportWindowWidth', 530); - InitSetting(asCSVImportWindowHeight, 'CSVImportWindowHeight', 530); + InitSetting(asCSVImportWindowHeight, 'CSVImportWindowHeight', 550); InitSetting(asCSVImportFilename, 'loadfilename', 0, False, ''); InitSetting(asCSVImportFieldsEnclosedOptionally, 'CSVImportFieldsEnclosedOptionallyV2', 0, True); InitSetting(asCSVImportIgnoreLines, 'CSVImportIgnoreLines', 1); @@ -3596,16 +4016,19 @@ constructor TAppSettings.Create; InitSetting(asCSVImportLocalNumbers, 'CSVImportLocalNumbers', 0, False); InitSetting(asCSVImportDuplicateHandling, 'CSVImportDuplicateHandling', 2); InitSetting(asCSVImportParseMethod, 'CSVImportParseMethod', 0); + InitSetting(asCSVKeepDialogOpen, 'CSVKeepDialogOpen', 0, False); InitSetting(asUpdatecheck, 'Updatecheck', 0, False); InitSetting(asUpdatecheckBuilds, 'UpdatecheckBuilds', 0, False); InitSetting(asUpdatecheckInterval, 'UpdatecheckInterval', 3); - InitSetting(asUpdatecheckLastrun, 'UpdatecheckLastrun', 0, False, '2000-01-01'); + InitSetting(asUpdatecheckLastrun, 'UpdatecheckLastrun', 0, False, DateToStr(DateTimeNever)); InitSetting(asUpdateCheckWindowWidth, 'UpdateCheckWindowWidth', 400); InitSetting(asUpdateCheckWindowHeight, 'UpdateCheckWindowHeight', 460); InitSetting(asTableToolsWindowWidth, 'TableTools_WindowWidth', 800); InitSetting(asTableToolsWindowHeight, 'TableTools_WindowHeight', 420); InitSetting(asTableToolsTreeWidth, 'TableTools_TreeWidth', 300); + InitSetting(asTableToolsFindTextTab, 'TableToolsFindTextTab', 0); InitSetting(asTableToolsFindText, 'TableTools_FindText', 0, False, ''); + InitSetting(asTableToolsFindSQL, 'TableToolsFindSQL', 0, False, ''); InitSetting(asTableToolsDatatype, 'TableTools_Datatype', 0); InitSetting(asTableToolsFindCaseSensitive, 'TableTools_FindCaseSensitive', 0, False); InitSetting(asTableToolsFindMatchType, 'TableToolsFindMatchType', 0); @@ -3619,6 +4042,7 @@ constructor TAppSettings.Create; InitSetting(asSelectDBOWindowWidth, 'SelectDBO_WindowWidth', 250); InitSetting(asSelectDBOWindowHeight, 'SelectDBO_WindowHeight', 350); InitSetting(asSessionManagerListWidth, 'SessionManager_ListWidth', 220); + InitSetting(asSessionManagerListFoldersAtTop, 'SessionManager_ListFoldersAtTop', 0, True); InitSetting(asSessionManagerWindowWidth, 'SessionManager_WindowWidth', 700); InitSetting(asSessionManagerWindowHeight, 'SessionManager_WindowHeight', 490); InitSetting(asSessionManagerWindowLeft, 'SessionManager_WindowLeft', 50); @@ -3632,30 +4056,38 @@ constructor TAppSettings.Create; InitSetting(asCopyTableRecentFilter, 'CopyTable_RecentFilter_%s', 0, False, ''); InitSetting(asServerVersion, 'ServerVersion', 0, False, '', True); InitSetting(asServerVersionFull, 'ServerVersionFull', 0, False, '', True); - InitSetting(asLastConnect, 'LastConnect', 0, False, '2000-01-01', True); + InitSetting(asLastConnect, 'LastConnect', 0, False, DateToStr(DateTimeNever), True); InitSetting(asConnectCount, 'ConnectCount', 0, False, '', True); InitSetting(asRefusedCount, 'RefusedCount', 0, False, '', True); InitSetting(asSessionCreated, 'SessionCreated', 0, False, '', True); InitSetting(asDoUsageStatistics, 'DoUsageStatistics', 0, False); - InitSetting(asLastUsageStatisticCall, 'LastUsageStatisticCall', 0, False, '2000-01-01'); + InitSetting(asLastUsageStatisticCall, 'LastUsageStatisticCall', 0, False, DateToStr(DateTimeNever)); InitSetting(asWheelZoom, 'WheelZoom', 0, True); InitSetting(asDisplayBars, 'DisplayBars', 0, true); InitSetting(asMySQLBinaries, 'MySQL_Binaries', 0, False, ''); - // Default folder for snippets - if FPortableMode then - DefaultSnippetsDirectory := ExtractFilePath(ParamStr(0)) - else - DefaultSnippetsDirectory := DirnameUserDocuments; - DefaultSnippetsDirectory := DefaultSnippetsDirectory + 'Snippets\'; - InitSetting(asCustomSnippetsDirectory, 'CustomSnippetsDirectory', 0, False, DefaultSnippetsDirectory); + InitSetting(asSequalSuggestWindowWidth, 'SequalSuggestWindowWidth', 500); + InitSetting(asSequalSuggestWindowHeight, 'SequalSuggestWindowHeight', 400); + InitSetting(asSequalSuggestPrompt, 'SequalSuggestPrompt', 0, False, ''); + InitSetting(asSequalSuggestRecentPrompts, 'SequalSuggestRecentPrompts', 0, False, ''); + InitSetting(asReformatter, 'Reformatter', 0); + InitSetting(asReformatterNoDialog, 'ReformatterNoDialog', 0); + InitSetting(asAlwaysGenerateFilter, 'AlwaysGenerateFilter', 0, False); + InitSetting(asDisplayReverseForeignKeys, 'DisplayReverseForeignKeys', 0, False); + InitSetting(asGenerateDataNumRows, 'GenerateDataNumRows', 1000); + InitSetting(asGenerateDataNullAmount, 'GenerateDataNullAmount', 10); + InitSetting(asCustomSnippetsDirectory, 'CustomSnippetsDirectory', 0, False, DirnameUserDocuments + 'Snippets' + PathDelim); InitSetting(asPromptSaveFileOnTabClose, 'PromptSaveFileOnTabClose', 0, True); // Restore tabs feature crashes often on old XP systems, see https://www.heidisql.com/forum.php?t=34044 InitSetting(asRestoreTabs, 'RestoreTabs', 0, Win32MajorVersion >= 6); + InitSetting(asTabCloseOnDoubleClick, 'TabCloseOnDoubleClick', 0, True); + InitSetting(asTabCloseOnMiddleClick, 'TabCloseOnMiddleClick', 0, True); + InitSetting(asTabsInMultipleLines, 'TabsInMultipleLines', 0, True); + InitSetting(asTabIconsGrayscaleMode, 'TabIconsGrayscaleMode', 1); InitSetting(asWarnUnsafeUpdates, 'WarnUnsafeUpdates', 0, True); - InitSetting(asQueryWarningsMessage, 'QueryWarningsMessage', 0, True); InitSetting(asQueryGridLongSortRowNum, 'QueryGridLongSortRowNum', 10000); InitSetting(asCompletionProposal, 'CompletionProposal', 0, True); - InitSetting(asCompletionProposalSearchOnMid, 'CompletionProposalSearchOnMid', 0, False); + InitSetting(asCompletionProposalInterval, 'CompletionProposalInterval', 500); + InitSetting(asCompletionProposalSearchOnMid, 'CompletionProposalSearchOnMid', 0, True); InitSetting(asCompletionProposalWidth, 'CompletionProposalWidth', 350); InitSetting(asCompletionProposalNbLinesInWindow,'CompletionProposalNbLinesInWindow', 12); InitSetting(asAutoUppercase, 'AutoUppercase', 0, True); @@ -3676,6 +4108,7 @@ constructor TAppSettings.Create; InitSetting(asLogScript, 'LogScript', 0, False); InitSetting(asLogInfos, 'LogInfos', 0, True); InitSetting(asLogDebug, 'LogDebug', 0, False); + InitSetting(asLogTimestamp, 'LogTimestamp', 0, False); InitSetting(asFieldColorNumeric, 'FieldColor_Numeric', $00FF0000); InitSetting(asFieldColorReal, 'FieldColor_Real', $00FF0048); InitSetting(asFieldColorText, 'FieldColor_Text', $00008000); @@ -3692,7 +4125,10 @@ constructor TAppSettings.Create; InitSetting(asRowBackgroundEven, 'RowBackgroundEven', clNone); InitSetting(asRowBackgroundOdd, 'RowBackgroundOdd', clNone); InitSetting(asGroupTreeObjects, 'GroupTreeObjects', 0, False); + InitSetting(asTreeShowColumns, 'TreeShowColumns', 0, False); InitSetting(asDisplayObjectSizeColumn, 'DisplayObjectSizeColumn', 0, True); + InitSetting(asDisplayLogPanel, 'DisplayLogPanel', 0, True); + InitSetting(asDisplayTreeFilters, 'DisplayTreeFilters', 0, True); InitSetting(asActionShortcut1, 'Shortcut1_%s', 0); InitSetting(asActionShortcut2, 'Shortcut2_%s', 0); InitSetting(asHighlighterForeground, 'SQL Attr %s Foreground', 0); @@ -3711,13 +4147,14 @@ constructor TAppSettings.Create; InitSetting(asAutoExpand, 'AutoExpand', 0, False); InitSetting(asDoubleClickInsertsNodeText, 'DoubleClickInsertsNodeText', 0, True); InitSetting(asForeignDropDown, 'ForeignDropDown', 0, True); + InitSetting(asIncrementalSearch, 'IncrementalSearch', 0, True); InitSetting(asQueryHistoryEnabled, 'QueryHistory', 0, True); InitSetting(asQueryHistoryKeepDays, 'QueryHistoryKeeypDays', 30); InitSetting(asColumnSelectorWidth, 'ColumnSelectorWidth', 200, False, ''); InitSetting(asColumnSelectorHeight, 'ColumnSelectorHeight', 270, False, ''); InitSetting(asDonatedEmail, 'DonatedEmail', 0, False, ''); InitSetting(asFavoriteObjects, 'FavoriteObjects', 0, False, '', True); - InitSetting(asFavoriteObjectsOnly, 'FavoriteObjectsOnly', 0, False); + InitSetting(asFavoriteObjectsOnly, 'FavoriteObjectsOnly', 0, False); // No longer used InitSetting(asFullTableStatus, 'FullTableStatus', 0, True, '', True); InitSetting(asLineBreakStyle, 'LineBreakStyle', Integer(lbsWindows)); InitSetting(asPreferencesWindowWidth, 'PreferencesWindowWidth', 740); @@ -3728,6 +4165,8 @@ constructor TAppSettings.Create; InitSetting(asThemePreviewTop, 'ThemePreviewTop', 300); InitSetting(asThemePreviewLeft, 'ThemePreviewLeft', 300); InitSetting(asCreateDbCollation, 'CreateDbCollation', 0, False, ''); + InitSetting(asRealTrailingZeros, 'RealTrailingZeros', 1); + InitSetting(asWebOnceAction, 'WebOnceAction', 0, False, DateToStr(DateTimeNever)); // Initialization values FRestoreTabsInitValue := ReadBool(asRestoreTabs); @@ -3816,6 +4255,17 @@ procedure TAppSettings.ResetPath; end; +procedure TAppSettings.StorePath; +begin + FStoredPath := SessionPath; +end; + +procedure TAppSettings.RestorePath; +begin + SessionPath := FStoredPath; +end; + + procedure TAppSettings.PrepareRegistry; var Folder: String; @@ -3867,6 +4317,7 @@ function TAppSettings.DeleteValue(Index: TAppSettingIndex; FormatName: String='' if FormatName <> '' then ValueName := Format(ValueName, [FormatName]); Result := FRegistry.DeleteValue(ValueName); + FSettings[Index].Synced := False; end; @@ -3880,6 +4331,8 @@ procedure TAppSettings.DeleteCurrentKey; var KeyPath: String; begin + // Delete the current registry key + // Note that, contrary to the documentation, .DeleteKey is done even when this key has subkeys PrepareRegistry; if FSessionPath.IsEmpty then raise Exception.CreateFmt(_('No path set, won''t delete root key %s'), [FRegistry.CurrentPath]) @@ -4009,6 +4462,13 @@ function TAppSettings.ReadInt(Index: TAppSettingIndex; FormatName: String=''; De end; +function TAppSettings.ReadIntDpiAware(Index: TAppSettingIndex; AControl: TControl; FormatName: String=''; Default: Integer=0): Integer; +begin + Result := ReadInt(Index, FormatName, Default); + Result := Round(Result * AControl.ScaleFactor); +end; + + function TAppSettings.ReadBool(Index: TAppSettingIndex; FormatName: String=''; Default: Boolean=False): Boolean; var I: Integer; @@ -4089,6 +4549,13 @@ procedure TAppSettings.WriteInt(Index: TAppSettingIndex; Value: Integer; FormatN end; +procedure TAppSettings.WriteIntDpiAware(Index: TAppSettingIndex; AControl: TControl; Value: Integer; FormatName: String=''); +begin + Value := Round(Value / AControl.ScaleFactor); + WriteInt(Index, Value, FormatName); +end; + + procedure TAppSettings.WriteBool(Index: TAppSettingIndex; Value: Boolean; FormatName: String=''); begin Write(Index, FormatName, adBool, 0, Value, ''); @@ -4163,7 +4630,7 @@ procedure TAppSettings.ImportSettings(Filename: String); raise Exception.CreateFmt('File does not exist: %s', [Filename]); end; - Content := ReadTextfile(FileName, nil); + Content := ReadTextfile(FileName, UTF8NoBOMEncoding); Lines := Explode(CRLF, Content); for i:=0 to Lines.Count-1 do begin // Each line has 3 segments: reg path | data type | value. Continue if explode finds less or more than 3. @@ -4241,7 +4708,7 @@ function TAppSettings.ExportSettings(Filename: String): Boolean; // Save registry settings to file Content := ''; ReadKeyToContent(FBasePath); - SaveUnicodeFile(FileName, Content); + SaveUnicodeFile(FileName, Content, UTF8NoBOMEncoding); Result := True; end; @@ -4256,7 +4723,7 @@ function TAppSettings.ExportSettings: Boolean; except on E:Exception do begin FPortableModeReadOnly := True; - Raise Exception.Create(E.Message + CRLF + CRLF + Raise Exception.Create(E.ClassName + ': ' + E.Message + CRLF + CRLF + f_('Switching to read-only mode. Settings won''t be saved. Use the command line parameter %s to use a custom file path.', ['--psettings']) ); end; @@ -4267,20 +4734,28 @@ function TAppSettings.ExportSettings: Boolean; function TAppSettings.DirnameUserAppData: String; begin - // User folder for HeidiSQL's data (\Application Data) - Result := GetShellFolder(FOLDERID_RoamingAppData) + '\' + APPNAME + '\'; - if not DirectoryExists(Result) then begin - ForceDirectories(Result); + // C:\Users\mike\AppData\Roaming\HeidiSQL\ + if PortableMode then begin + Result := GetAppDir; + end + else begin + Result := GetShellFolder(FOLDERID_RoamingAppData) + '\' + APPNAME + '\'; + if not DirectoryExists(Result) then begin + ForceDirectories(Result); + end; end; end; function TAppSettings.DirnameUserDocuments: String; begin - // "HeidiSQL" folder under user's documents folder, e.g. c:\Users\Mike\Documents\HeidiSQL\ - Result := GetShellFolder(FOLDERID_Documents) + '\' + APPNAME + '\'; - if not DirectoryExists(Result) then begin - ForceDirectories(Result); + // C:\Users\mike\Documents\HeidiSQL\ + if PortableMode then begin + Result := GetAppDir; + end + else begin + Result := GetShellFolder(FOLDERID_Documents) + '\' + APPNAME + '\'; + // Do not auto-create it, as we only use it for snippets which can also have a custom path. end; end; @@ -4288,7 +4763,10 @@ function TAppSettings.DirnameUserDocuments: String; function TAppSettings.DirnameSnippets: String; begin // Folder for snippets - Result := IncludeTrailingBackslash(ReadString(asCustomSnippetsDirectory)); + Result := ReadString(asCustomSnippetsDirectory); + if Result.IsEmpty then + Result := GetDefaultString(asCustomSnippetsDirectory); + Result := IncludeTrailingBackslash(Result); if not DirectoryExists(Result) then begin ForceDirectories(Result); end; @@ -4298,11 +4776,16 @@ function TAppSettings.DirnameSnippets: String; function TAppSettings.DirnameBackups: String; begin // Create backup folder if it does not exist and return it - if PortableMode then begin - Result := ExtractFilePath(Application.ExeName) + 'Backups\' - end else begin - Result := DirnameUserAppData + 'Backups\'; + Result := DirnameUserAppData + 'Backups' + PathDelim; + if not DirectoryExists(Result) then begin + ForceDirectories(Result); end; +end; + + +function TAppSettings.DirnameHighlighters: string; +begin + Result := DirnameUserAppData + 'Highlighters' + PathDelim; if not DirectoryExists(Result) then begin ForceDirectories(Result); end; @@ -4326,6 +4809,11 @@ initialization UTF8NoBOMEncoding := TUTF8NoBOMEncoding.Create; +DateTimeNever := MinDateTime; + +ConfirmIcon := TIcon.Create; +ConfirmIcon.LoadFromResourceName(hInstance, 'Z_ICONQUESTION'); + end. diff --git a/source/bineditor.dfm b/source/bineditor.dfm index 5b9a60e73..b1bd1fe35 100644 --- a/source/bineditor.dfm +++ b/source/bineditor.dfm @@ -7,8 +7,11 @@ object frmBinEditor: TfrmBinEditor Color = clBtnFace Constraints.MinHeight = 100 Constraints.MinWidth = 130 - ParentFont = True - OldCreateOrder = False + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -12 + Font.Name = 'Tahoma' + Font.Style = [] Position = poMainFormCenter OnClose = FormClose OnCreate = FormCreate @@ -17,8 +20,7 @@ object frmBinEditor: TfrmBinEditor DesignSize = ( 215 95) - PixelsPerInch = 96 - TextHeight = 13 + TextHeight = 14 object lblTextLength: TLabel Left = 103 Top = 77 diff --git a/source/bineditor.pas b/source/bineditor.pas index ae0ff46e3..74872ff09 100644 --- a/source/bineditor.pas +++ b/source/bineditor.pas @@ -3,8 +3,8 @@ interface uses - Windows, Classes, Graphics, Forms, Controls, StdCtrls, VirtualTrees, - ComCtrls, ToolWin, Dialogs, SysUtils, gnugettext, extra_controls; + Winapi.Windows, System.Classes, Vcl.Graphics, Vcl.Forms, Vcl.Controls, Vcl.StdCtrls, VirtualTrees, + Vcl.ComCtrls, Vcl.ToolWin, Vcl.Dialogs, System.SysUtils, gnugettext, extra_controls; {$I const.inc} @@ -95,8 +95,8 @@ procedure TfrmBinEditor.FormCreate(Sender: TObject); procedure TfrmBinEditor.FormDestroy(Sender: TObject); begin - AppSettings.WriteInt(asMemoEditorWidth, Width); - AppSettings.WriteInt(asMemoEditorHeight, Height); + AppSettings.WriteIntDpiAware(asMemoEditorWidth, Self, Width); + AppSettings.WriteIntDpiAware(asMemoEditorHeight, Self, Height); AppSettings.WriteBool(asMemoEditorWrap, btnWrap.Down); end; @@ -104,8 +104,8 @@ procedure TfrmBinEditor.FormDestroy(Sender: TObject); procedure TfrmBinEditor.FormShow(Sender: TObject); begin // Restore form dimensions - Width := AppSettings.ReadInt(asMemoEditorWidth); - Height := AppSettings.ReadInt(asMemoEditorHeight); + Width := AppSettings.ReadIntDpiAware(asMemoEditorWidth, Self); + Height := AppSettings.ReadIntDpiAware(asMemoEditorHeight, Self); if AppSettings.ReadBool(asMemoEditorWrap) then btnWrap.Click; // Fix label position: diff --git a/source/change_password.dfm b/source/change_password.dfm index 222ca8ab5..cb358394f 100644 --- a/source/change_password.dfm +++ b/source/change_password.dfm @@ -12,18 +12,16 @@ object frmPasswordChange: TfrmPasswordChange Constraints.MinWidth = 400 Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText - Font.Height = -11 + Font.Height = -12 Font.Name = 'Tahoma' Font.Style = [] - OldCreateOrder = False Position = poMainFormCenter OnCreate = FormCreate OnShow = FormShow DesignSize = ( 456 187) - PixelsPerInch = 96 - TextHeight = 13 + TextHeight = 14 object lblHeading: TLabel Left = 8 Top = 16 diff --git a/source/change_password.pas b/source/change_password.pas index 49b797509..9e437636a 100644 --- a/source/change_password.pas +++ b/source/change_password.pas @@ -5,7 +5,7 @@ interface uses Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ExtCtrls, extra_controls, gnugettext, - Vcl.Menus, Clipbrd, Vcl.ComCtrls, System.Math; + Vcl.Menus, Vcl.Clipbrd, Vcl.ComCtrls, System.Math; type TfrmPasswordChange = class(TExtForm) @@ -105,7 +105,7 @@ procedure TfrmPasswordChange.btnCopyToClipboardClick(Sender: TObject); OldImageIndex: Integer; begin // Copy new password to clipboard - Clipboard.AsText := editPassword.Text; + Clipboard.TryAsText := editPassword.Text; OldImageIndex := btnCopyToClipboard.ImageIndex; btnCopyToClipboard.ImageIndex := 55; btnCopyToClipboard.Repaint; diff --git a/source/column_selection.dfm b/source/column_selection.dfm index d1a25a18a..732c16e03 100644 --- a/source/column_selection.dfm +++ b/source/column_selection.dfm @@ -1,4 +1,4 @@ -object ColumnSelectionForm: TColumnSelectionForm +object frmColumnSelection: TfrmColumnSelection Left = 0 Top = 0 BorderStyle = bsSizeToolWin @@ -10,20 +10,17 @@ object ColumnSelectionForm: TColumnSelectionForm Constraints.MinWidth = 200 Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText - Font.Height = -11 + Font.Height = -12 Font.Name = 'Tahoma' Font.Style = [] - OldCreateOrder = False OnClose = FormClose OnCreate = FormCreate - OnDestroy = FormDestroy OnDeactivate = FormDeactivate OnShow = FormShow DesignSize = ( 184 243) - PixelsPerInch = 96 - TextHeight = 13 + TextHeight = 14 object btnCancel: TButton Left = 101 Top = 210 @@ -49,7 +46,7 @@ object ColumnSelectionForm: TColumnSelectionForm end object chkSort: TCheckBox Left = 8 - Top = 187 + Top = 167 Width = 168 Height = 17 Anchors = [akLeft, akRight, akBottom] @@ -71,11 +68,11 @@ object ColumnSelectionForm: TColumnSelectionForm Left = 8 Top = 31 Width = 168 - Height = 150 - OnClickCheck = chklistColumnsClickCheck + Height = 130 Anchors = [akLeft, akTop, akRight, akBottom] ItemHeight = 13 TabOrder = 4 + OnClickCheck = chklistColumnsClickCheck end object editFilter: TButtonedEdit Left = 63 @@ -92,4 +89,13 @@ object ColumnSelectionForm: TColumnSelectionForm OnChange = PopulateList OnLeftButtonClick = editFilterLeftButtonClick end + object chkShowRowId: TCheckBox + Left = 8 + Top = 190 + Width = 168 + Height = 17 + Anchors = [akLeft, akRight, akBottom] + Caption = 'Show static row id column' + TabOrder = 6 + end end diff --git a/source/column_selection.pas b/source/column_selection.pas index faecf21ee..2c5994ad8 100644 --- a/source/column_selection.pas +++ b/source/column_selection.pas @@ -3,17 +3,18 @@ interface uses - Windows, Classes, Controls, Forms, StdCtrls, CheckLst, ExtCtrls, SysUtils, + Winapi.Windows, System.Classes, Vcl.Controls, Vcl.Forms, Vcl.StdCtrls, Vcl.CheckLst, Vcl.ExtCtrls, System.SysUtils, apphelpers, gnugettext, extra_controls; type - TColumnSelectionForm = class(TExtForm) + TfrmColumnSelection = class(TExtForm) btnCancel: TButton; btnOK: TButton; chkSelectAll: TCheckBox; chklistColumns: TCheckListBox; chkSort: TCheckBox; editFilter: TButtonedEdit; + chkShowRowId: TCheckBox; procedure btnCancelClick(Sender: TObject); procedure FormShow(Sender: TObject); procedure chklistColumnsClickCheck(Sender: TObject); @@ -23,7 +24,6 @@ TColumnSelectionForm = class(TExtForm) procedure FormClose(Sender: TObject; var Action: TCloseAction); procedure FormDeactivate(Sender: TObject); procedure FormCreate(Sender: TObject); - procedure FormDestroy(Sender: TObject); procedure editFilterLeftButtonClick(Sender: TObject); private { Private declarations } @@ -43,31 +43,23 @@ implementation -procedure TColumnSelectionForm.FormCreate(Sender: TObject); +procedure TfrmColumnSelection.FormCreate(Sender: TObject); begin HasSizeGrip := True; - Width := AppSettings.ReadInt(asColumnSelectorWidth); - Height := AppSettings.ReadInt(asColumnSelectorHeight); FCheckedColumns := TStringList.Create; end; -procedure TColumnSelectionForm.FormDestroy(Sender: TObject); -begin - AppSettings.WriteInt(asColumnSelectorWidth, Width); - AppSettings.WriteInt(asColumnSelectorHeight, Height); - FCheckedColumns.Free; -end; - - {** FormShow } -procedure TColumnSelectionForm.FormShow(Sender: TObject); +procedure TfrmColumnSelection.FormShow(Sender: TObject); var i: Integer; Col: String; begin + Width := AppSettings.ReadIntDpiAware(asColumnSelectorWidth, Self); + Height := AppSettings.ReadIntDpiAware(asColumnSelectorHeight, Self); FCheckedColumns.Clear; for i:=0 to Mainform.SelectedTableColumns.Count-1 do begin Col := Mainform.SelectedTableColumns[i].Name; @@ -85,17 +77,20 @@ procedure TColumnSelectionForm.FormShow(Sender: TObject); // Restore last used sorting state from registry chkSort.Checked := AppSettings.ReadBool(asDisplayedColumnsSorted); + chkShowRowId.Checked := AppSettings.ReadBool(asShowRowId); end; {** OK clicked } -procedure TColumnSelectionForm.btnOKClick(Sender: TObject); +procedure TfrmColumnSelection.btnOKClick(Sender: TObject); var i: Integer; Col: String; begin + AppSettings.WriteBool(asDisplayedColumnsSorted, chkSort.Checked); + AppSettings.WriteBool(asShowRowId, chkShowRowId.Checked); // Prepare string for storing in registry. // Use quote-character as separator to ensure columnnames can // be extracted safely later @@ -113,26 +108,26 @@ procedure TColumnSelectionForm.btnOKClick(Sender: TObject); {** Select / Deselect all } -procedure TColumnSelectionForm.chkSelectAllClick(Sender: TObject); +procedure TfrmColumnSelection.chkSelectAllClick(Sender: TObject); var cb: TCheckBox; i: Integer; begin - // Avoid executing when checkbox was toggled by code (see proc below) + // Avoid executing when Checked or State property was modified by code. Happens in OnClickCheck handler of TCheckListBox. cb := Sender as TCheckBox; - if cb.Focused then begin - chklistColumns.CheckAll(cb.State); - for i:=0 to chklistColumns.Items.Count-1 do begin - if (FCheckedColumns.IndexOf(chklistColumns.Items[i]) = -1) and (cb.State = cbChecked) then - FCheckedColumns.Add(chklistColumns.Items[i]); - if (FCheckedColumns.IndexOf(chklistColumns.Items[i]) > -1) and (cb.State = cbUnchecked) then - FCheckedColumns.Delete(FCheckedColumns.IndexOf(chklistColumns.Items[i])); - end; + if cb.Tag = SUSPEND_ONCLICK then + Exit; + chklistColumns.CheckAll(cb.State); + for i:=0 to chklistColumns.Items.Count-1 do begin + if (FCheckedColumns.IndexOf(chklistColumns.Items[i]) = -1) and (cb.State = cbChecked) then + FCheckedColumns.Add(chklistColumns.Items[i]); + if (FCheckedColumns.IndexOf(chklistColumns.Items[i]) > -1) and (cb.State = cbUnchecked) then + FCheckedColumns.Delete(FCheckedColumns.IndexOf(chklistColumns.Items[i])); end; end; -procedure TColumnSelectionForm.editFilterLeftButtonClick(Sender: TObject); +procedure TfrmColumnSelection.editFilterLeftButtonClick(Sender: TObject); begin if IsNotEmpty(editFilter.Text) then begin FLastFilter := editFilter.Text; @@ -148,7 +143,7 @@ procedure TColumnSelectionForm.editFilterLeftButtonClick(Sender: TObject); Click within column list Updates state of "Select / deselect all" checkbox } -procedure TColumnSelectionForm.chklistColumnsClickCheck(Sender: TObject); +procedure TfrmColumnSelection.chklistColumnsClickCheck(Sender: TObject); var i : Integer; AllSelected, NoneSelected : Boolean; @@ -175,19 +170,21 @@ procedure TColumnSelectionForm.chklistColumnsClickCheck(Sender: TObject); else AllSelected := False; end; + chkSelectAll.Tag := SUSPEND_ONCLICK; if NoneSelected then chkSelectAll.State := cbUnchecked else if AllSelected then chkSelectAll.State := cbChecked else chkSelectAll.State := cbGrayed; + chkSelectAll.Tag := 0; end; {** Sort / Unsort the list with fields } -procedure TColumnSelectionForm.PopulateList(Sender: TObject); +procedure TfrmColumnSelection.PopulateList(Sender: TObject); var i: Integer; Col: String; @@ -212,7 +209,7 @@ procedure TColumnSelectionForm.PopulateList(Sender: TObject); end; -procedure TColumnSelectionForm.btnCancelClick(Sender: TObject); +procedure TfrmColumnSelection.btnCancelClick(Sender: TObject); begin Mainform.tbtnDataColumns.Down := False; Close; @@ -222,7 +219,7 @@ procedure TColumnSelectionForm.btnCancelClick(Sender: TObject); {** Cancel this dialog if the user clicks elsewhere on mainform } -procedure TColumnSelectionForm.FormDeactivate(Sender: TObject); +procedure TfrmColumnSelection.FormDeactivate(Sender: TObject); begin btnCancel.OnClick(Sender); end; @@ -231,10 +228,13 @@ procedure TColumnSelectionForm.FormDeactivate(Sender: TObject); {** Be sure the form is destroyed after closing. } -procedure TColumnSelectionForm.FormClose(Sender: TObject; var Action: +procedure TfrmColumnSelection.FormClose(Sender: TObject; var Action: TCloseAction); begin + AppSettings.WriteIntDpiAware(asColumnSelectorWidth, Self, Width); + AppSettings.WriteIntDpiAware(asColumnSelectorHeight, Self, Height); Action := caFree; + FCheckedColumns.Free; end; diff --git a/source/connections.dfm b/source/connections.dfm index 3a0c92d09..c458dd6b1 100644 --- a/source/connections.dfm +++ b/source/connections.dfm @@ -3,35 +3,32 @@ object connform: Tconnform Top = 129 BorderIcons = [biSystemMenu, biHelp] Caption = 'Session manager' - ClientHeight = 451 - ClientWidth = 649 + ClientHeight = 506 + ClientWidth = 749 Color = clBtnFace Constraints.MinHeight = 470 Constraints.MinWidth = 640 Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText - Font.Height = -11 + Font.Height = -12 Font.Name = 'Tahoma' Font.Style = [] - OldCreateOrder = False ShowHint = True OnClose = FormClose OnCloseQuery = FormCloseQuery OnCreate = FormCreate - OnDestroy = FormDestroy OnResize = FormResize OnShow = FormShow DesignSize = ( - 649 - 451) - PixelsPerInch = 96 - TextHeight = 13 + 749 + 506) + TextHeight = 14 object splitterMain: TSplitter AlignWithMargins = True Left = 208 Top = 8 Width = 8 - Height = 403 + Height = 458 Cursor = crSizeWE Margins.Left = 0 Margins.Top = 8 @@ -42,7 +39,7 @@ object connform: Tconnform end object btnSave: TButton Left = 64 - Top = 418 + Top = 473 Width = 50 Height = 25 Anchors = [akLeft, akBottom] @@ -54,8 +51,8 @@ object connform: Tconnform OnClick = btnSaveClick end object btnOpen: TButton - Left = 389 - Top = 418 + Left = 485 + Top = 473 Width = 80 Height = 25 Anchors = [akRight, akBottom] @@ -66,8 +63,8 @@ object connform: Tconnform OnClick = btnOpenClick end object btnCancel: TButton - Left = 475 - Top = 418 + Left = 571 + Top = 473 Width = 80 Height = 25 Anchors = [akRight, akBottom] @@ -78,7 +75,7 @@ object connform: Tconnform end object btnNew: TButton Left = 8 - Top = 418 + Top = 473 Width = 50 Height = 25 Anchors = [akLeft, akBottom] @@ -93,7 +90,7 @@ object connform: Tconnform end object btnDelete: TButton Left = 120 - Top = 418 + Top = 473 Width = 50 Height = 25 Anchors = [akLeft, akBottom] @@ -108,8 +105,8 @@ object connform: Tconnform AlignWithMargins = True Left = 216 Top = 8 - Width = 425 - Height = 403 + Width = 525 + Height = 458 Margins.Left = 0 Margins.Top = 8 Margins.Right = 8 @@ -118,6 +115,7 @@ object connform: Tconnform Align = alClient Images = MainForm.VirtualImageListMain TabOrder = 6 + OnChange = PageControlDetailsChange object tabStart: TTabSheet Caption = 'Start' ImageIndex = 112 @@ -126,7 +124,7 @@ object connform: Tconnform AlignWithMargins = True Left = 10 Top = 10 - Width = 397 + Width = 497 Height = 161 Margins.Left = 10 Margins.Top = 10 @@ -140,12 +138,11 @@ object connform: Tconnform object btnImportSettings: TButton Left = 10 Top = 184 - Width = 159 + Width = 493 Height = 25 - Caption = 'Import settings ...' - ImageIndex = 101 + Action = MainForm.actImportSettings + Anchors = [akLeft, akTop, akRight] TabOrder = 0 - OnClick = btnImportSettingsClick end end object tabSettings: TTabSheet @@ -153,72 +150,72 @@ object connform: Tconnform ImageIndex = 39 ImageName = 'icons8-support' DesignSize = ( - 417 - 374) + 517 + 429) object lblPort: TLabel Left = 3 Top = 199 - Width = 24 - Height = 13 + Width = 27 + Height = 14 Caption = 'Port:' FocusControl = editPort end object lblPassword: TLabel Left = 3 Top = 174 - Width = 50 - Height = 13 + Width = 55 + Height = 14 Caption = 'Password:' FocusControl = editPassword end object lblHost: TLabel Left = 3 Top = 76 - Width = 72 - Height = 13 + Width = 83 + Height = 14 Caption = 'Hostname / IP:' FocusControl = editHost end object lblUsername: TLabel Left = 3 Top = 149 - Width = 26 - Height = 13 + Width = 28 + Height = 14 Caption = 'User:' FocusControl = editUsername end object lblNetworkType: TLabel Left = 3 Top = 12 - Width = 69 - Height = 13 + Width = 80 + Height = 14 Caption = 'Network type:' end object lblDatabase: TLabel Left = 3 Top = 247 - Width = 55 - Height = 13 + Width = 59 + Height = 14 Caption = 'Databases:' end object lblComment: TLabel Left = 3 Top = 274 - Width = 49 - Height = 13 + Width = 57 + Height = 14 Caption = 'Comment:' end object lblLibrary: TLabel Left = 3 Top = 39 - Width = 37 - Height = 13 + Width = 39 + Height = 14 Caption = 'Library:' end object chkCompressed: TCheckBox Left = 190 Top = 221 - Width = 220 + Width = 316 Height = 17 Anchors = [akLeft, akTop, akRight] Caption = 'Compressed client/server protocol' @@ -229,7 +226,7 @@ object connform: Tconnform Left = 190 Top = 196 Width = 57 - Height = 21 + Height = 22 TabOrder = 7 Text = '0' OnChange = Modification @@ -238,7 +235,7 @@ object connform: Tconnform Left = 247 Top = 196 Width = 16 - Height = 21 + Height = 22 Associate = editPort Max = 2147483647 TabOrder = 8 @@ -248,28 +245,31 @@ object connform: Tconnform object editPassword: TEdit Left = 190 Top = 171 - Width = 220 - Height = 21 + Width = 316 + Height = 22 Anchors = [akLeft, akTop, akRight] PasswordChar = '*' TabOrder = 6 OnChange = Modification end - object editUsername: TEdit + object editUsername: TButtonedEdit Left = 190 Top = 146 - Width = 220 - Height = 21 + Width = 316 + Height = 22 Anchors = [akLeft, akTop, akRight] + Images = MainForm.VirtualImageListMain + RightButton.ImageIndex = 75 TabOrder = 5 OnChange = Modification OnExit = editTrim + OnRightButtonClick = editUsernameRightButtonClick end object editHost: TButtonedEdit Left = 190 Top = 73 - Width = 220 - Height = 21 + Width = 316 + Height = 22 Anchors = [akLeft, akTop, akRight] Images = MainForm.VirtualImageListMain RightButton.DropDownMenu = popupHost @@ -283,8 +283,8 @@ object connform: Tconnform object comboNetType: TComboBoxEx Left = 190 Top = 8 - Width = 220 - Height = 22 + Width = 316 + Height = 23 ItemsEx = <> Style = csExDropDownList Anchors = [akLeft, akTop, akRight] @@ -296,7 +296,7 @@ object connform: Tconnform object chkLoginPrompt: TCheckBox Left = 190 Top = 100 - Width = 220 + Width = 316 Height = 17 Anchors = [akLeft, akTop, akRight] Caption = 'Prompt for credentials' @@ -306,7 +306,7 @@ object connform: Tconnform object chkWindowsAuth: TCheckBox Left = 190 Top = 123 - Width = 220 + Width = 316 Height = 17 Anchors = [akLeft, akTop, akRight] Caption = 'Use Windows authentication' @@ -317,8 +317,8 @@ object connform: Tconnform object memoComment: TMemo Left = 190 Top = 271 - Width = 220 - Height = 98 + Width = 316 + Height = 153 Anchors = [akLeft, akTop, akRight, akBottom] ScrollBars = ssVertical TabOrder = 11 @@ -327,8 +327,8 @@ object connform: Tconnform object editDatabases: TButtonedEdit Left = 190 Top = 244 - Width = 220 - Height = 21 + Width = 316 + Height = 22 Anchors = [akLeft, akTop, akRight] Images = MainForm.VirtualImageListMain RightButton.ImageIndex = 75 @@ -341,8 +341,9 @@ object connform: Tconnform object comboLibrary: TComboBox Left = 190 Top = 36 - Width = 220 - Height = 21 + Width = 316 + Height = 22 + AutoDropDownWidth = True Style = csDropDownList Anchors = [akLeft, akTop, akRight] TabOrder = 1 @@ -354,80 +355,80 @@ object connform: Tconnform ImageIndex = 147 ImageName = 'icons8-lock' DesignSize = ( - 417 - 374) + 517 + 429) object lblSSHLocalPort: TLabel Left = 3 - Top = 174 - Width = 51 - Height = 13 + Top = 202 + Width = 58 + Height = 14 Caption = 'Local port:' FocusControl = editSSHlocalport end object lblSSHUser: TLabel Left = 3 - Top = 66 - Width = 52 - Height = 13 + Top = 94 + Width = 58 + Height = 14 Caption = 'Username:' FocusControl = editSSHUser end object lblSSHPassword: TLabel Left = 3 - Top = 93 - Width = 50 - Height = 13 + Top = 121 + Width = 55 + Height = 14 Caption = 'Password:' FocusControl = editSSHPassword end - object lblSSHPlinkExe: TLabel + object lblSSHExe: TLabel Left = 3 - Top = 12 - Width = 87 - Height = 13 - Caption = 'plink.exe location:' + Top = 40 + Width = 90 + Height = 14 + Caption = 'SSH executable:' end object lblSSHhost: TLabel Left = 3 - Top = 39 - Width = 81 - Height = 13 + Top = 67 + Width = 93 + Height = 14 Caption = 'SSH host + port:' FocusControl = editSSHhost end object lblSSHkeyfile: TLabel Left = 3 - Top = 147 - Width = 75 - Height = 13 + Top = 175 + Width = 83 + Height = 14 Caption = 'Private key file:' FocusControl = editSSHPrivateKey end - object lblPlinkTimeout: TLabel + object lblSSHTimeout: TLabel Left = 3 - Top = 120 - Width = 86 - Height = 13 - Caption = 'plink.exe timeout:' + Top = 148 + Width = 73 + Height = 14 + Caption = 'SSH timeout:' end object editSSHlocalport: TEdit Left = 190 - Top = 171 - Width = 220 - Height = 21 + Top = 199 + Width = 316 + Height = 22 Anchors = [akLeft, akTop, akRight] NumbersOnly = True - TabOrder = 8 + TabOrder = 9 Text = 'editSSHlocalport' OnChange = Modification end object editSSHUser: TEdit Left = 190 - Top = 63 - Width = 220 - Height = 21 + Top = 91 + Width = 316 + Height = 22 Anchors = [akLeft, akTop, akRight] - TabOrder = 3 + TabOrder = 4 Text = 'editSSHUser' TextHint = 'Your secure shell username' OnChange = Modification @@ -435,67 +436,50 @@ object connform: Tconnform end object editSSHPassword: TEdit Left = 190 - Top = 90 - Width = 220 - Height = 21 + Top = 118 + Width = 316 + Height = 22 Anchors = [akLeft, akTop, akRight] PasswordChar = '*' - TabOrder = 4 + TabOrder = 5 Text = 'editSSHPassword' TextHint = 'Your secure shell password' OnChange = Modification end - object editSSHPlinkExe: TButtonedEdit - Left = 190 - Top = 9 - Width = 220 - Height = 21 - Anchors = [akLeft, akTop, akRight] - Images = MainForm.VirtualImageListMain - RightButton.ImageIndex = 51 - RightButton.Visible = True - TabOrder = 0 - Text = 'editSSHPlinkExe' - TextHint = 'Doubleclick to select plink.exe ...' - OnChange = editSSHPlinkExeChange - OnDblClick = PickFile - OnExit = editTrim - OnRightButtonClick = PickFile - end object editSSHhost: TEdit Left = 190 - Top = 36 - Width = 160 - Height = 21 + Top = 64 + Width = 256 + Height = 22 Anchors = [akLeft, akTop, akRight] - TabOrder = 1 + TabOrder = 2 Text = 'editSSHhost' OnChange = Modification OnExit = editTrim end object editSSHport: TEdit - Left = 356 - Top = 36 + Left = 452 + Top = 64 Width = 54 - Height = 21 + Height = 22 Anchors = [akTop, akRight] NumbersOnly = True - TabOrder = 2 + TabOrder = 3 Text = 'editSSHport' OnChange = Modification end object editSSHPrivateKey: TButtonedEdit Left = 190 - Top = 144 - Width = 220 - Height = 21 + Top = 172 + Width = 316 + Height = 22 Anchors = [akLeft, akTop, akRight] Images = MainForm.VirtualImageListMain RightButton.ImageIndex = 51 RightButton.Visible = True - TabOrder = 7 + TabOrder = 8 Text = 'editSSHPrivateKey' - TextHint = 'PuTTY private key (*.ppk)' + TextHint = 'Private key / identify file' OnChange = Modification OnDblClick = PickFile OnExit = editTrim @@ -503,191 +487,129 @@ object connform: Tconnform end object editSSHTimeout: TEdit Left = 190 - Top = 117 + Top = 145 Width = 60 - Height = 21 - TabOrder = 5 + Height = 22 + TabOrder = 6 Text = '1' OnChange = Modification end object updownSSHTimeout: TUpDown Left = 250 - Top = 117 + Top = 145 Width = 17 - Height = 21 + Height = 22 Associate = editSSHTimeout Min = 1 Position = 1 - TabOrder = 6 + TabOrder = 7 Wrap = True end + object comboSSHExe: TComboBox + Left = 190 + Top = 36 + Width = 316 + Height = 22 + Anchors = [akLeft, akTop, akRight] + TabOrder = 1 + Text = 'comboSSHExe' + OnChange = Modification + end + object chkSSHActive: TCheckBox + Left = 190 + Top = 13 + Width = 320 + Height = 17 + Anchors = [akLeft, akTop, akRight] + Caption = 'Use SSH tunnel' + TabOrder = 0 + OnClick = Modification + end end object tabAdvanced: TTabSheet Caption = 'Advanced' ImageIndex = 98 ImageName = 'icons8-support-orange' DesignSize = ( - 417 - 374) - object lblSSLPrivateKey: TLabel - Left = 3 - Top = 39 - Width = 78 - Height = 13 - Caption = 'SSL private key:' - FocusControl = editSSLPrivateKey - end - object lblSSLCACertificate: TLabel - Left = 3 - Top = 68 - Width = 89 - Height = 13 - Caption = 'SSL CA certificate:' - FocusControl = editSSLCACertificate - end - object lblSSLCertificate: TLabel - Left = 3 - Top = 95 - Width = 72 - Height = 13 - Caption = 'SSL certificate:' - FocusControl = editSSLCertificate - end + 517 + 429) object lblStartupScript: TLabel Left = 3 - Top = 168 - Width = 69 - Height = 13 + Top = 12 + Width = 78 + Height = 14 Caption = 'Startup script:' FocusControl = editStartupScript end object lblQueryTimeout: TLabel Left = 3 - Top = 195 - Width = 73 - Height = 13 + Top = 39 + Width = 84 + Height = 14 Caption = 'Query timeout:' end - object lblSSLcipher: TLabel - Left = 3 - Top = 120 - Width = 53 - Height = 13 - Caption = 'SSL cipher:' - end object lblKeepAlive: TLabel Left = 3 - Top = 224 - Width = 106 - Height = 13 + Top = 66 + Width = 120 + Height = 14 Caption = 'Ping every X seconds:' end object lblBackgroundColor: TLabel Left = 3 - Top = 318 - Width = 86 - Height = 13 + Top = 185 + Width = 98 + Height = 14 Caption = 'Background color:' end object lblIgnoreDatabasePattern: TLabel Left = 3 - Top = 346 - Width = 112 - Height = 13 + Top = 213 + Width = 126 + Height = 14 Caption = 'Hide database pattern:' end - object editSSLPrivateKey: TButtonedEdit - Left = 190 - Top = 36 - Width = 220 - Height = 21 - Anchors = [akLeft, akTop, akRight] - Images = MainForm.VirtualImageListMain - RightButton.ImageIndex = 51 - RightButton.Visible = True - TabOrder = 1 - TextHint = 'Path to key file' - OnChange = Modification - OnDblClick = PickFile - OnExit = editTrim - OnRightButtonClick = PickFile - end - object editSSLCACertificate: TButtonedEdit - Left = 190 - Top = 65 - Width = 220 - Height = 21 - Anchors = [akLeft, akTop, akRight] - Images = MainForm.VirtualImageListMain - RightButton.ImageIndex = 51 - RightButton.Visible = True - TabOrder = 2 - TextHint = 'Path to certificate authority file' - OnChange = Modification - OnDblClick = PickFile - OnExit = editTrim - OnRightButtonClick = PickFile - end - object editSSLCertificate: TButtonedEdit - Left = 190 - Top = 92 - Width = 220 - Height = 21 - Anchors = [akLeft, akTop, akRight] - Images = MainForm.VirtualImageListMain - RightButton.ImageIndex = 51 - RightButton.Visible = True - TabOrder = 3 - TextHint = 'Path to certificate file' - OnChange = Modification - OnDblClick = PickFile - OnExit = editTrim - OnRightButtonClick = PickFile - end - object chkWantSSL: TCheckBox - Left = 190 - Top = 13 - Width = 220 - Height = 17 - Anchors = [akLeft, akTop, akRight] - Caption = 'Use SSL' - TabOrder = 0 - OnClick = Modification + object lblLogFile: TLabel + Left = 3 + Top = 252 + Width = 102 + Height = 14 + Caption = 'Log queries to file:' end object chkLocalTimeZone: TCheckBox Left = 190 - Top = 246 - Width = 220 + Top = 90 + Width = 320 Height = 17 Hint = 'Use your client time zone in date/time SQL functions, e.g. NOW()' + ', for MySQL 4.1.3+' Anchors = [akLeft, akTop, akRight] Caption = 'Use own client time zone' - TabOrder = 10 + TabOrder = 5 OnClick = Modification end object chkCleartextPluginEnabled: TCheckBox Left = 190 - Top = 292 - Width = 220 + Top = 136 + Width = 320 Height = 17 Hint = 'Send your password to the server in cleartext, for MySQL 5.5.47+' Anchors = [akLeft, akTop, akRight] Caption = 'Enable cleartext authentication' - TabOrder = 12 + TabOrder = 7 OnClick = Modification end object editStartupScript: TButtonedEdit Left = 190 - Top = 165 - Width = 220 - Height = 21 + Top = 9 + Width = 320 + Height = 22 Anchors = [akLeft, akTop, akRight] Images = MainForm.VirtualImageListMain RightButton.ImageIndex = 51 RightButton.Visible = True - TabOrder = 5 + TabOrder = 0 OnChange = Modification OnDblClick = PickFile OnExit = editTrim @@ -695,90 +617,253 @@ object connform: Tconnform end object chkFullTableStatus: TCheckBox Left = 190 - Top = 269 - Width = 220 + Top = 113 + Width = 320 Height = 17 Hint = 'Disable to speed up internal queries on databases with many tabl' + 'es' Anchors = [akLeft, akTop, akRight] Caption = 'Get full table status' - TabOrder = 11 + TabOrder = 6 OnClick = Modification end object editQueryTimeout: TEdit Left = 190 - Top = 192 + Top = 36 Width = 90 - Height = 21 + Height = 22 NumbersOnly = True - TabOrder = 6 + TabOrder = 1 Text = '0' OnChange = Modification end object updownQueryTimeout: TUpDown Left = 280 - Top = 192 + Top = 36 Width = 16 - Height = 21 + Height = 22 Associate = editQueryTimeout Max = 2147483646 - TabOrder = 7 + TabOrder = 2 Wrap = True end - object editSSLcipher: TEdit - Left = 190 - Top = 119 - Width = 220 - Height = 21 - Anchors = [akLeft, akTop, akRight] - TabOrder = 4 - TextHint = 'List of permissible ciphers to use for SSL encryption' - OnChange = Modification - OnExit = editTrim - end object editKeepAlive: TEdit Left = 190 - Top = 219 + Top = 63 Width = 90 - Height = 21 - TabOrder = 8 + Height = 22 + TabOrder = 3 Text = '0' OnChange = Modification end object updownKeepAlive: TUpDown Left = 280 - Top = 219 + Top = 63 Width = 16 - Height = 21 + Height = 22 Associate = editKeepAlive Max = 86400 - TabOrder = 9 + TabOrder = 4 end object ColorBoxBackgroundColor: TColorBox Left = 190 - Top = 315 - Width = 220 + Top = 182 + Width = 320 Height = 22 NoneColorColor = clNone Selected = clNone Style = [cbStandardColors, cbExtendedColors, cbSystemColors, cbIncludeNone, cbIncludeDefault, cbCustomColor, cbPrettyNames, cbCustomColors] Anchors = [akLeft, akTop, akRight] DropDownCount = 16 - TabOrder = 13 + TabOrder = 8 OnChange = Modification OnGetColors = ColorBoxBackgroundColorGetColors end object editIgnoreDatabasePattern: TEdit Left = 190 - Top = 343 - Width = 220 - Height = 21 + Top = 210 + Width = 320 + Height = 22 Anchors = [akLeft, akTop, akRight] - TabOrder = 14 + TabOrder = 9 TextHint = 'Regular expression' OnChange = Modification end + object chkLogFileDdl: TCheckBox + Left = 190 + Top = 276 + Width = 320 + Height = 17 + Anchors = [akLeft, akTop, akRight] + Caption = 'DDL queries (CREATE, ALTER, ...)' + TabOrder = 11 + OnClick = Modification + end + object editLogFilePath: TButtonedEdit + Left = 190 + Top = 249 + Width = 320 + Height = 22 + Anchors = [akLeft, akTop, akRight] + Enabled = False + Images = MainForm.VirtualImageListMain + RightButton.ImageIndex = 51 + RightButton.Visible = True + TabOrder = 10 + OnChange = Modification + OnRightButtonClick = PickFile + end + object chkLogFileDml: TCheckBox + Left = 190 + Top = 299 + Width = 320 + Height = 17 + Anchors = [akLeft, akTop, akRight] + Caption = 'DML queries (INSERT, UPDATE, ...)' + TabOrder = 12 + OnClick = Modification + end + object chkForceUnicode: TCheckBox + Left = 190 + Top = 159 + Width = 320 + Height = 17 + Anchors = [akLeft, akTop, akRight] + Caption = 'Force Unicode (disable on old servers only)' + TabOrder = 13 + OnClick = Modification + end + end + object tabSSL: TTabSheet + Caption = 'SSL' + ImageIndex = 25 + DesignSize = ( + 517 + 429) + object lblSSLPrivateKey: TLabel + Left = 3 + Top = 39 + Width = 88 + Height = 14 + Caption = 'SSL private key:' + FocusControl = editSSLPrivateKey + end + object lblSSLCACertificate: TLabel + Left = 3 + Top = 66 + Width = 101 + Height = 14 + Caption = 'SSL CA certificate:' + FocusControl = editSSLCACertificate + end + object lblSSLCertificate: TLabel + Left = 3 + Top = 93 + Width = 82 + Height = 14 + Caption = 'SSL certificate:' + FocusControl = editSSLCertificate + end + object lblSSLcipher: TLabel + Left = 3 + Top = 120 + Width = 61 + Height = 14 + Caption = 'SSL cipher:' + end + object lblSSLVerification: TLabel + Left = 3 + Top = 148 + Width = 121 + Height = 14 + Caption = 'Certificate verification:' + end + object chkWantSSL: TCheckBox + Left = 190 + Top = 13 + Width = 320 + Height = 17 + Anchors = [akLeft, akTop, akRight] + Caption = 'Use SSL' + TabOrder = 0 + OnClick = Modification + end + object editSSLcipher: TEdit + Left = 190 + Top = 117 + Width = 324 + Height = 22 + Anchors = [akLeft, akTop, akRight] + TabOrder = 4 + TextHint = 'List of permissible ciphers to use for SSL encryption' + OnChange = Modification + OnExit = editTrim + end + object editSSLCertificate: TButtonedEdit + Left = 190 + Top = 90 + Width = 324 + Height = 22 + Anchors = [akLeft, akTop, akRight] + Images = MainForm.VirtualImageListMain + RightButton.ImageIndex = 51 + RightButton.Visible = True + TabOrder = 3 + TextHint = 'Path to certificate file' + OnChange = Modification + OnDblClick = PickFile + OnExit = editTrim + OnRightButtonClick = PickFile + end + object editSSLCACertificate: TButtonedEdit + Left = 190 + Top = 63 + Width = 324 + Height = 22 + Anchors = [akLeft, akTop, akRight] + Images = MainForm.VirtualImageListMain + RightButton.ImageIndex = 51 + RightButton.Visible = True + TabOrder = 2 + TextHint = 'Path to certificate authority file' + OnChange = Modification + OnDblClick = PickFile + OnExit = editTrim + OnRightButtonClick = PickFile + end + object editSSLPrivateKey: TButtonedEdit + Left = 190 + Top = 36 + Width = 324 + Height = 22 + Anchors = [akLeft, akTop, akRight] + Images = MainForm.VirtualImageListMain + RightButton.ImageIndex = 51 + RightButton.Visible = True + TabOrder = 1 + TextHint = 'Path to key file' + OnChange = Modification + OnDblClick = PickFile + OnExit = editTrim + OnRightButtonClick = PickFile + end + object comboSSLVerification: TComboBox + Left = 190 + Top = 145 + Width = 324 + Height = 22 + Style = csDropDownList + Anchors = [akLeft, akTop, akRight] + TabOrder = 5 + OnChange = Modification + Items.Strings = ( + 'No verification (insecure)' + 'Verify CA (insecure)' + + 'Verify CA and host name identity (may fail with self-signed cert' + + 's and wildcard cn)') + end end object tabStatistics: TTabSheet Caption = 'Statistics' @@ -787,64 +872,64 @@ object connform: Tconnform object lblLastConnectLeft: TLabel Left = 3 Top = 31 - Width = 65 - Height = 13 + Width = 75 + Height = 14 Caption = 'Last connect:' end object lblCounterLeft: TLabel Left = 3 Top = 50 - Width = 100 - Height = 13 + Width = 114 + Height = 14 Caption = 'Successful connects:' end object lblCreatedLeft: TLabel Left = 3 Top = 12 - Width = 43 - Height = 13 + Width = 47 + Height = 14 Caption = 'Created:' end object lblCreatedRight: TLabel Left = 190 Top = 12 - Width = 5 - Height = 13 + Width = 6 + Height = 14 Caption = '?' end object lblCounterRight1: TLabel Left = 190 Top = 50 - Width = 5 - Height = 13 + Width = 6 + Height = 14 Caption = '?' end object lblLastConnectRight: TLabel Left = 190 Top = 31 - Width = 5 - Height = 13 + Width = 6 + Height = 14 Caption = '?' end object lblCounterRight2: TLabel Left = 190 Top = 69 - Width = 5 - Height = 13 + Width = 6 + Height = 14 Caption = '?' end object lblCounterLeft2: TLabel Left = 3 Top = 69 - Width = 112 - Height = 13 + Width = 127 + Height = 14 Caption = 'Unsuccessful connects:' end end end object btnMore: TButton - Left = 561 - Top = 418 + Left = 657 + Top = 473 Width = 80 Height = 25 Anchors = [akRight, akBottom] @@ -859,7 +944,7 @@ object connform: Tconnform Left = 8 Top = 8 Width = 200 - Height = 403 + Height = 458 Margins.Left = 8 Margins.Top = 8 Margins.Right = 0 @@ -870,12 +955,13 @@ object connform: Tconnform TabOrder = 7 object ListSessions: TVirtualStringTree Left = 0 - Top = 26 + Top = 27 Width = 200 - Height = 377 + Height = 431 Align = alClient DragMode = dmAutomatic Header.AutoSizeIndex = -1 + Header.Height = 18 Header.Options = [hoAutoResize, hoColumnResize, hoDblClickResize, hoDrag, hoHotTrack, hoShowSortGlyphs, hoVisible, hoDisableAnimatedResize, hoAutoResizeInclCaption] Header.PopupMenu = MainForm.popupListHeader Header.SortColumn = 0 @@ -889,6 +975,7 @@ object connform: Tconnform TreeOptions.PaintOptions = [toHotTrack, toShowButtons, toShowDropmark, toShowRoot, toShowTreeLines, toThemeAware, toUseBlendedImages, toUseExplorerTheme, toHideTreeLinesIfThemed] TreeOptions.SelectionOptions = [toFullRowSelect, toRightClickSelect] OnBeforeCellPaint = ListSessionsBeforeCellPaint + OnCompareNodes = ListSessionsCompareNodes OnCreateEditor = ListSessionsCreateEditor OnDragOver = ListSessionsDragOver OnDragDrop = ListSessionsDragDrop @@ -900,6 +987,8 @@ object connform: Tconnform OnNewText = ListSessionsNewText OnNodeDblClick = ListSessionsNodeDblClick OnStructureChange = ListSessionsStructureChange + Touch.InteractiveGestures = [igPan, igPressAndTap] + Touch.InteractiveGestureOptions = [igoPanSingleFingerHorizontal, igoPanSingleFingerVertical, igoPanInertia, igoPanGutter, igoParentPassthrough] Columns = < item Position = 0 @@ -912,29 +1001,35 @@ object connform: Tconnform Text = 'Host' end item - Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coAllowFocus] + Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus] Position = 2 - Text = 'User' + Text = 'Port' + Width = 10 end item Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coAllowFocus] Position = 3 + Text = 'User' + end + item + Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coAllowFocus] + Position = 4 Text = 'Version' end item Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus] - Position = 4 + Position = 5 Text = 'Last connect' end item Alignment = taRightJustify Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coAllowFocus] - Position = 5 + Position = 6 Text = 'Counter' end item Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus] - Position = 6 + Position = 7 Text = 'Comment' Width = 10 end> @@ -944,7 +1039,7 @@ object connform: Tconnform Left = 0 Top = 0 Width = 200 - Height = 21 + Height = 22 Margins.Left = 0 Margins.Top = 0 Margins.Right = 0 @@ -955,7 +1050,7 @@ object connform: Tconnform LeftButton.Visible = True RightButton.ImageIndex = 193 TabOrder = 1 - TextHint = 'Filter ...' + TextHint = 'Filter' OnChange = editSearchChange OnRightButtonClick = editSearchRightButtonClick end @@ -1005,6 +1100,14 @@ object connform: Tconnform ImageName = 'icons8-folder-other' OnClick = btnNewClick end + object Filter1: TMenuItem + Action = actFilter + end + object menuFoldersAtTop: TMenuItem + AutoCheck = True + Caption = 'Folders at top' + OnClick = menuFoldersAtTopClick + end end object TimerStatistics: TTimer Interval = 60000 @@ -1094,4 +1197,22 @@ object connform: Tconnform OnClick = FindAddDatabaseFilesClick end end + object ActionListConnections: TActionList + Images = MainForm.VirtualImageListMain + Left = 112 + Top = 208 + object actFilter: TAction + Caption = 'Filter ...' + ImageIndex = 30 + ShortCut = 16454 + OnExecute = actFilterExecute + end + end + object timerEditFilterDelay: TTimer + Enabled = False + Interval = 500 + OnTimer = timerEditFilterDelayTimer + Left = 24 + Top = 272 + end end diff --git a/source/connections.pas b/source/connections.pas index 4540a5b79..8914ff9c7 100644 --- a/source/connections.pas +++ b/source/connections.pas @@ -9,10 +9,11 @@ interface uses - Windows, SysUtils, Classes, Controls, Forms, Dialogs, StdCtrls, ExtCtrls, ComCtrls, - VirtualTrees, Menus, Graphics, Generics.Collections, ActiveX, extra_controls, Messages, - dbconnection, gnugettext, SynRegExpr, System.Types, Vcl.GraphUtil, ADODB, StrUtils, - System.Math; + Winapi.Windows, System.SysUtils, System.Classes, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ExtCtrls, Vcl.ComCtrls, + VirtualTrees, Vcl.Menus, Vcl.Graphics, System.Generics.Collections, Winapi.ActiveX, extra_controls, Winapi.Messages, + dbconnection, gnugettext, SynRegExpr, System.Types, Vcl.GraphUtil, Data.Win.ADODB, System.StrUtils, + System.Math, System.Actions, System.IOUtils, Vcl.ActnList, Vcl.StdActns, VirtualTrees.BaseTree, VirtualTrees.Types, VirtualTrees.EditLink, + VirtualTrees.BaseAncestorVCL, VirtualTrees.AncestorVCL, dbstructures; type Tconnform = class(TExtForm) @@ -21,6 +22,7 @@ Tconnform = class(TExtForm) btnSave: TButton; btnNew: TButton; btnDelete: TButton; + chkForceUnicode: TCheckBox; popupSessions: TPopupMenu; menuSave: TMenuItem; menuDelete: TMenuItem; @@ -37,15 +39,9 @@ Tconnform = class(TExtForm) editPort: TEdit; updownPort: TUpDown; editPassword: TEdit; - editUsername: TEdit; + editUsername: TButtonedEdit; editHost: TButtonedEdit; tabAdvanced: TTabSheet; - lblSSLPrivateKey: TLabel; - lblSSLCACertificate: TLabel; - lblSSLCertificate: TLabel; - editSSLPrivateKey: TButtonedEdit; - editSSLCACertificate: TButtonedEdit; - editSSLCertificate: TButtonedEdit; tabStatistics: TTabSheet; lblLastConnectLeft: TLabel; lblCounterLeft: TLabel; @@ -60,8 +56,7 @@ Tconnform = class(TExtForm) lblSSHLocalPort: TLabel; lblSSHUser: TLabel; lblSSHPassword: TLabel; - editSSHPlinkExe: TButtonedEdit; - lblSSHPlinkExe: TLabel; + lblSSHExe: TLabel; comboNetType: TComboBoxEx; lblSSHhost: TLabel; editSSHhost: TEdit; @@ -71,7 +66,7 @@ Tconnform = class(TExtForm) editDatabases: TButtonedEdit; lblDatabase: TLabel; chkLoginPrompt: TCheckBox; - lblPlinkTimeout: TLabel; + lblSSHTimeout: TLabel; editSSHTimeout: TEdit; updownSSHTimeout: TUpDown; chkWindowsAuth: TCheckBox; @@ -79,7 +74,6 @@ Tconnform = class(TExtForm) splitterMain: TSplitter; tabStart: TTabSheet; lblHelp: TLabel; - chkWantSSL: TCheckBox; btnImportSettings: TButton; timerSettingsImport: TTimer; popupNew: TPopupMenu; @@ -107,8 +101,6 @@ Tconnform = class(TExtForm) updownQueryTimeout: TUpDown; menuMoreGeneralHelp: TMenuItem; menuRename: TMenuItem; - lblSSLcipher: TLabel; - editSSLcipher: TEdit; lblKeepAlive: TLabel; editKeepAlive: TEdit; updownKeepAlive: TUpDown; @@ -127,6 +119,29 @@ Tconnform = class(TExtForm) menuAddDatabaseFiles: TMenuItem; lblIgnoreDatabasePattern: TLabel; editIgnoreDatabasePattern: TEdit; + ActionListConnections: TActionList; + actFilter: TAction; + Filter1: TMenuItem; + chkLogFileDdl: TCheckBox; + editLogFilePath: TButtonedEdit; + tabSSL: TTabSheet; + chkWantSSL: TCheckBox; + lblSSLPrivateKey: TLabel; + lblSSLCACertificate: TLabel; + lblSSLCertificate: TLabel; + lblSSLcipher: TLabel; + editSSLcipher: TEdit; + editSSLCertificate: TButtonedEdit; + editSSLCACertificate: TButtonedEdit; + editSSLPrivateKey: TButtonedEdit; + lblLogFile: TLabel; + chkLogFileDml: TCheckBox; + timerEditFilterDelay: TTimer; + comboSSHExe: TComboBox; + chkSSHActive: TCheckBox; + comboSSLVerification: TComboBox; + lblSSLVerification: TLabel; + menuFoldersAtTop: TMenuItem; procedure FormCreate(Sender: TObject); procedure btnOpenClick(Sender: TObject); procedure FormShow(Sender: TObject); @@ -148,13 +163,11 @@ Tconnform = class(TExtForm) NewNode: PVirtualNode; OldColumn, NewColumn: TColumnIndex; var Allowed: Boolean); procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean); - procedure FormDestroy(Sender: TObject); procedure TimerStatisticsTimer(Sender: TObject); procedure FormClose(Sender: TObject; var Action: TCloseAction); procedure ListSessionsCreateEditor(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; out EditLink: IVTEditLink); procedure PickFile(Sender: TObject); - procedure editSSHPlinkExeChange(Sender: TObject); procedure editHostChange(Sender: TObject); procedure editDatabasesRightButtonClick(Sender: TObject); procedure chkLoginPromptClick(Sender: TObject); @@ -162,7 +175,6 @@ Tconnform = class(TExtForm) var NodeDataSize: Integer); procedure comboNetTypeChange(Sender: TObject); procedure splitterMainMoved(Sender: TObject); - procedure btnImportSettingsClick(Sender: TObject); procedure timerSettingsImportTimer(Sender: TObject); procedure ListSessionsStructureChange(Sender: TBaseVirtualTree; Node: PVirtualNode; Reason: TChangeReason); @@ -170,7 +182,7 @@ Tconnform = class(TExtForm) Shift: TShiftState; State: TDragState; Pt: TPoint; Mode: TDropMode; var Effect: Integer; var Accept: Boolean); procedure ListSessionsDragDrop(Sender: TBaseVirtualTree; Source: TObject; - DataObject: IDataObject; Formats: TFormatArray; Shift: TShiftState; + DataObject: TVTDragDataObject; Formats: TFormatArray; Shift: TShiftState; Pt: TPoint; var Effect: Integer; Mode: TDropMode); procedure btnMoreClick(Sender: TObject); procedure menuRenameClick(Sender: TObject); @@ -188,6 +200,14 @@ Tconnform = class(TExtForm) procedure ListSessionsBeforeCellPaint(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; CellPaintMode: TVTCellPaintMode; CellRect: TRect; var ContentRect: TRect); + procedure actFilterExecute(Sender: TObject); + procedure timerEditFilterDelayTimer(Sender: TObject); + procedure chkSSHActiveClick(Sender: TObject); + procedure PageControlDetailsChange(Sender: TObject); + procedure editUsernameRightButtonClick(Sender: TObject); + procedure ListSessionsCompareNodes(Sender: TBaseVirtualTree; Node1, + Node2: PVirtualNode; Column: TColumnIndex; var Result: Integer); + procedure menuFoldersAtTopClick(Sender: TObject); private { Private declarations } FLoaded: Boolean; @@ -195,6 +215,7 @@ Tconnform = class(TExtForm) FServerVersion: String; FSettingsImportWaitTime: Cardinal; FPopupDatabases: TPopupMenu; + FPopupCiphers: TPopupMenu; FButtonAnimationStep: Integer; FLastSelectedNetTypeGroup: TNetTypeGroup; function GetSelectedNetType: TNetType; @@ -205,7 +226,9 @@ Tconnform = class(TExtForm) procedure FinalizeModifications(var CanProceed: Boolean); procedure ValidateControls; function NodeSessionNames(Node: PVirtualNode; var RegKey: String): TStringList; + function GetWindowCaption: String; procedure MenuDatabasesClick(Sender: TObject); + procedure MenuCiphersClick(Sender: TObject); procedure WMNCLBUTTONDOWN(var Msg: TWMNCLButtonDown) ; message WM_NCLBUTTONDOWN; procedure WMNCLBUTTONUP(var Msg: TWMNCLButtonUp) ; message WM_NCLBUTTONUP; procedure RefreshBackgroundColors; @@ -214,10 +237,12 @@ Tconnform = class(TExtForm) { Public declarations } end; +var + connform: Tconnform; implementation -uses Main, apphelpers, grideditlinks; +uses Main, apphelpers, grideditlinks, dbstructures.sqlite; {$I const.inc} @@ -243,33 +268,36 @@ procedure Tconnform.WMNCLBUTTONUP(var Msg: TWMNCLButtonUp) ; end; +function Tconnform.GetWindowCaption: String; +begin + Result := APPNAME + ' ' + MainForm.AppVersion + ' - ' + _('Session manager'); + if not SelectedSessionPath.IsEmpty then + Result := Result + ': ' + SelectedSessionPath; +end; + + procedure Tconnform.FormCreate(Sender: TObject); var - NetTypeStr: String; + NetTypeStr, FilenameHint, ExePath, ExeFile: String; nt: TNetType; ntg: TNetTypeGroup; Params: TConnectionParameters; ComboItem: TComboExItem; + Placeholders: TStringList; + i: Integer; + ExeFiles: TStringDynArray; begin // Fix GUI stuff HasSizeGrip := True; + Caption := GetWindowCaption; - Width := AppSettings.ReadInt(asSessionManagerWindowWidth); - Height := AppSettings.ReadInt(asSessionManagerWindowHeight); - Left := AppSettings.ReadInt(asSessionManagerWindowLeft, '', Left); - Top := AppSettings.ReadInt(asSessionManagerWindowTop, '', Top); - // Move to visible area if window was on a now plugged off monitor previously - MakeFullyVisible; - - pnlLeft.Width := AppSettings.ReadInt(asSessionManagerListWidth); - splitterMain.OnMoved(Sender); FixVT(ListSessions); - MainForm.RestoreListSetup(ListSessions); - ListSessions.OnCompareNodes := MainForm.AnyGridCompareNodes; ListSessions.OnHeaderClick := MainForm.AnyGridHeaderClick; ListSessions.OnHeaderDraggedOut := MainForm.AnyGridHeaderDraggedOut; btnImportSettings.Caption := MainForm.actImportSettings.Caption; FLoaded := False; + menuFoldersAtTop.Checked := AppSettings.ReadBool(asSessionManagerListFoldersAtTop); + FSettingsImportWaitTime := 0; comboNetType.Clear; Params := TConnectionParameters.Create; @@ -279,9 +307,6 @@ procedure Tconnform.FormCreate(Sender: TObject); if Params.GetNetTypeGroup <> ntg then Continue; NetTypeStr := Params.NetTypeName(True); - if RunningOnWindows10S and (not Params.IsCompatibleToWin10S) then begin - NetTypeStr := NetTypeStr + ' ['+_('Does not work on Windows 10 S')+']'; - end; ComboItem := TComboExItem.Create(comboNetType.ItemsEx); ComboItem.Caption := NetTypeStr; ComboItem.ImageIndex := Params.ImageIndex; @@ -290,6 +315,25 @@ procedure Tconnform.FormCreate(Sender: TObject); end; Params.Free; + // Create filename placeholders hint + Placeholders := GetOutputFilenamePlaceholders; + FilenameHint := _('Allows the following replacement patterns:'); + for i:=0 to Placeholders.Count-1 do begin + FilenameHint := FilenameHint + CRLF + '%' + Placeholders.Names[i] + ': ' + Placeholders.ValueFromIndex[i]; + end; + Placeholders.Free; + editLogFilePath.Hint := FilenameHint; + + // Populate dropdown with supported SSH executables + ExeFiles := TDirectory.GetFiles(GetAppDir, '*.exe'); + for ExePath in ExeFiles do begin + ExeFile := ExtractFileName(ExePath); + if ExecRegExprI('([pk]link|putty)', ExeFile) then begin + comboSSHExe.Items.Add(ExeFile); + end; + end; + SetLength(ExeFiles, 0); + comboSSHExe.Items.Add('ssh.exe'); end; @@ -313,21 +357,17 @@ procedure Tconnform.RefreshSessions(ParentNode: PVirtualNode); Params := TConnectionParameters.Create(RegKey+SessionNames[i]); SessNode := ListSessions.AddChild(ParentNode, PConnectionParameters(Params)); if Params.IsFolder then begin + SessNode.Dummy := 1; // We use this Byte value later in CompareNodes RefreshSessions(SessNode); + end + else begin + SessNode.Dummy := 0; end; end; -end; - - -procedure Tconnform.FormDestroy(Sender: TObject); -begin - // Save GUI stuff - AppSettings.WriteInt(asSessionManagerListWidth, pnlLeft.Width); - AppSettings.WriteInt(asSessionManagerWindowWidth, Width); - AppSettings.WriteInt(asSessionManagerWindowHeight, Height); - AppSettings.WriteInt(asSessionManagerWindowLeft, Left); - AppSettings.WriteInt(asSessionManagerWindowTop, Top); - MainForm.SaveListSetup(ListSessions); + if not Assigned(ParentNode) then begin + RefreshBackgroundColors; + ListSessions.SortTree(ListSessions.Header.SortColumn, ListSessions.Header.SortDirection); + end; end; @@ -347,7 +387,13 @@ procedure Tconnform.FormClose(Sender: TObject; var Action: TCloseAction); begin // Suspend calculating statistics as long as they're not visible TimerStatistics.Enabled := False; - Action := caFree; + // Save GUI stuff + AppSettings.WriteIntDpiAware(asSessionManagerListWidth, Self, pnlLeft.Width); + AppSettings.WriteIntDpiAware(asSessionManagerWindowWidth, Self, Width); + AppSettings.WriteIntDpiAware(asSessionManagerWindowHeight, Self, Height); + AppSettings.WriteInt(asSessionManagerWindowLeft, Left); + AppSettings.WriteInt(asSessionManagerWindowTop, Top); + SaveListSetup(ListSessions); end; @@ -358,6 +404,16 @@ procedure Tconnform.FormShow(Sender: TObject); PSess: PConnectionParameters; Node: PVirtualNode; begin + Width := AppSettings.ReadIntDpiAware(asSessionManagerWindowWidth, Self); + Height := AppSettings.ReadIntDpiAware(asSessionManagerWindowHeight, Self); + Left := AppSettings.ReadInt(asSessionManagerWindowLeft, '', Left); + Top := AppSettings.ReadInt(asSessionManagerWindowTop, '', Top); + // Move to visible area if window was on a now plugged off monitor previously + MakeFullyVisible; + pnlLeft.Width := AppSettings.ReadIntDpiAware(asSessionManagerListWidth, Self); + splitterMain.OnMoved(Sender); + RestoreListSetup(ListSessions); + // Init sessions tree RefreshSessions(nil); @@ -435,52 +491,61 @@ procedure Tconnform.btnSaveClick(Sender: TObject); Conn: TDBConnection; begin // Overtake edited values for current parameter object and save to registry - Sess := ListSessions.GetNodeData(ListSessions.FocusedNode); - Sess.Hostname := editHost.Text; - Sess.Username := editUsername.Text; - Sess.Password := editPassword.Text; - Sess.LoginPrompt := chkLoginPrompt.Checked; - Sess.WindowsAuth := chkWindowsAuth.Checked; - Sess.CleartextPluginEnabled := chkCleartextPluginEnabled.Checked; - Sess.Port := updownPort.Position; - Sess.NetType := SelectedNetType; - Sess.Compressed := chkCompressed.Checked; - Sess.QueryTimeout := updownQueryTimeout.Position; - Sess.KeepAlive := updownKeepAlive.Position; - Sess.LocalTimeZone := chkLocalTimeZone.Checked; - Sess.FullTableStatus := chkFullTableStatus.Checked; - Sess.SessionColor := ColorBoxBackgroundColor.Selected; - Sess.LibraryOrProvider := comboLibrary.Text; - Sess.AllDatabasesStr := editDatabases.Text; - Sess.Comment := memoComment.Text; - Sess.StartupScriptFilename := editStartupScript.Text; - Sess.SSHPlinkExe := editSSHPlinkExe.Text; - Sess.SSHHost := editSSHhost.Text; - Sess.SSHPort := MakeInt(editSSHport.Text); - Sess.SSHUser := editSSHUser.Text; - Sess.SSHPassword := editSSHPassword.Text; - Sess.SSHTimeout := updownSSHTimeout.Position; - Sess.SSHPrivateKey := editSSHPrivateKey.Text; - Sess.SSHLocalPort := MakeInt(editSSHlocalport.Text); - Sess.WantSSL := chkWantSSL.Checked; - Sess.SSLPrivateKey := editSSLPrivateKey.Text; - Sess.SSLCertificate := editSSLCertificate.Text; - Sess.SSLCACertificate := editSSLCACertificate.Text; - Sess.SSLCipher := editSSLCipher.Text; - Sess.IgnoreDatabasePattern := editIgnoreDatabasePattern.Text; - Sess.SaveToRegistry; + if Assigned(ListSessions.FocusedNode) then begin + Sess := ListSessions.GetNodeData(ListSessions.FocusedNode); + Sess.Hostname := editHost.Text; + Sess.Username := editUsername.Text; + Sess.Password := editPassword.Text; + Sess.LoginPrompt := chkLoginPrompt.Checked; + Sess.WindowsAuth := chkWindowsAuth.Checked; + Sess.CleartextPluginEnabled := chkCleartextPluginEnabled.Checked; + Sess.ForceUnicode := chkForceUnicode.Checked; + Sess.Port := updownPort.Position; + Sess.NetType := SelectedNetType; + Sess.Compressed := chkCompressed.Checked; + Sess.QueryTimeout := updownQueryTimeout.Position; + Sess.KeepAlive := updownKeepAlive.Position; + Sess.LocalTimeZone := chkLocalTimeZone.Checked; + Sess.FullTableStatus := chkFullTableStatus.Checked; + Sess.SessionColor := ColorBoxBackgroundColor.Selected; + Sess.LibraryOrProvider := comboLibrary.Text; + Sess.AllDatabasesStr := editDatabases.Text; + Sess.Comment := memoComment.Text; + Sess.StartupScriptFilename := editStartupScript.Text; + Sess.SSHActive := chkSSHActive.Enabled and chkSSHActive.Checked; + Sess.SSHExe := comboSSHExe.Text; + Sess.SSHHost := editSSHhost.Text; + Sess.SSHPort := MakeInt(editSSHport.Text); + Sess.SSHUser := editSSHUser.Text; + Sess.SSHPassword := editSSHPassword.Text; + Sess.SSHTimeout := updownSSHTimeout.Position; + Sess.SSHPrivateKey := editSSHPrivateKey.Text; + Sess.SSHLocalPort := MakeInt(editSSHlocalport.Text); + Sess.WantSSL := chkWantSSL.Checked; + Sess.SSLPrivateKey := editSSLPrivateKey.Text; + Sess.SSLCertificate := editSSLCertificate.Text; + Sess.SSLCACertificate := editSSLCACertificate.Text; + Sess.SSLCipher := editSSLCipher.Text; + Sess.SSLVerification := comboSSLVerification.ItemIndex; + Sess.IgnoreDatabasePattern := editIgnoreDatabasePattern.Text; + Sess.LogFileDdl := chkLogFileDdl.Checked; + Sess.LogFileDml := chkLogFileDml.Checked; + Sess.LogFilePath := editLogFilePath.Text; + Sess.SaveToRegistry; + + // Apply session color (and othher settings) to opened connection(s) + for Conn in MainForm.Connections do begin + if Conn.Parameters.SessionPath = Sess.SessionPath then begin + Conn.Parameters.SessionColor := Sess.SessionColor; + MainForm.DBtree.Invalidate; + end; + end; + end; FSessionModified := False; ListSessions.Invalidate; + RefreshBackgroundColors; ValidateControls; - - // Apply session color (and othher settings) to opened connection(s) - for Conn in MainForm.Connections do begin - if Conn.Parameters.SessionPath = Sess.SessionPath then begin - Conn.Parameters.SessionColor := Sess.SessionColor; - MainForm.DBtree.Repaint; - end; - end; end; @@ -525,22 +590,17 @@ procedure Tconnform.btnSaveAsClick(Sender: TObject); end; -procedure Tconnform.btnImportSettingsClick(Sender: TObject); -begin - MainForm.actImportSettings.Execute; - FSettingsImportWaitTime := 0; - timerSettingsImport.Enabled := MainForm.ImportSettingsDone; -end; - - procedure Tconnform.timerSettingsImportTimer(Sender: TObject); begin Inc(FSettingsImportWaitTime, timerSettingsImport.Interval); RefreshSessions(nil); - if ListSessions.RootNodeCount > 0 then + if ListSessions.RootNodeCount > 0 then begin timerSettingsImport.Enabled := False; + FSettingsImportWaitTime := 0; + end; if FSettingsImportWaitTime >= 10000 then begin timerSettingsImport.Enabled := False; + FSettingsImportWaitTime := 0; MessageDialog(f_('Imported sessions could not be detected. Restarting %s may solve that.', [APPNAME]), mtWarning, [mbOK]); end; end; @@ -596,6 +656,11 @@ procedure Tconnform.btnNewClick(Sender: TObject); end; +procedure Tconnform.actFilterExecute(Sender: TObject); +begin + editSearch.SetFocus; +end; + procedure Tconnform.btnDeleteClick(Sender: TObject); var Sess: PConnectionParameters; @@ -624,8 +689,12 @@ function Tconnform.SelectedSessionPath: String; var Sess: PConnectionParameters; begin - Sess := ListSessions.GetNodeData(ListSessions.FocusedNode); - Result := Sess.SessionPath; + if not Assigned(ListSessions.FocusedNode) then + Result := '' + else begin + Sess := ListSessions.GetNodeData(ListSessions.FocusedNode); + Result := Sess.SessionPath; + end; end; @@ -634,12 +703,18 @@ function Tconnform.CurrentParams: TConnectionParameters; FromReg: PConnectionParameters; begin // Return non-stored parameters + if not Assigned(ListSessions.FocusedNode) then begin + Result := nil; + Exit; + end; + FromReg := ListSessions.GetNodeData(ListSessions.FocusedNode); if FromReg.IsFolder then begin Result := FromReg^; end else begin Result := TConnectionParameters.Create; Result.SessionPath := SelectedSessionPath; + Result.Counter := FromReg.Counter; Result.SessionColor := ColorBoxBackgroundColor.Selected; Result.NetType := SelectedNetType; Result.ServerVersion := FServerVersion; @@ -649,6 +724,7 @@ function Tconnform.CurrentParams: TConnectionParameters; Result.LoginPrompt := chkLoginPrompt.Checked; Result.WindowsAuth := chkWindowsAuth.Checked; Result.CleartextPluginEnabled := chkCleartextPluginEnabled.Checked; + Result.ForceUnicode := chkForceUnicode.Checked; if updownPort.Enabled then Result.Port := updownPort.Position else @@ -656,6 +732,7 @@ function Tconnform.CurrentParams: TConnectionParameters; Result.AllDatabasesStr := editDatabases.Text; Result.LibraryOrProvider := comboLibrary.Text; Result.Comment := memoComment.Text; + Result.SSHActive := chkSSHActive.Enabled and chkSSHActive.Checked; Result.SSHHost := editSSHHost.Text; Result.SSHPort := MakeInt(editSSHPort.Text); Result.SSHUser := editSSHuser.Text; @@ -663,12 +740,13 @@ function Tconnform.CurrentParams: TConnectionParameters; Result.SSHTimeout := updownSSHTimeout.Position; Result.SSHPrivateKey := editSSHPrivateKey.Text; Result.SSHLocalPort := MakeInt(editSSHlocalport.Text); - Result.SSHPlinkExe := editSSHplinkexe.Text; + Result.SSHExe := comboSSHExe.Text; Result.WantSSL := chkWantSSL.Checked; Result.SSLPrivateKey := editSSLPrivateKey.Text; Result.SSLCertificate := editSSLCertificate.Text; Result.SSLCACertificate := editSSLCACertificate.Text; Result.SSLCipher := editSSLCipher.Text; + Result.SSLVerification := comboSSLVerification.ItemIndex; Result.StartupScriptFilename := editStartupScript.Text; Result.Compressed := chkCompressed.Checked; Result.QueryTimeout := updownQueryTimeout.Position; @@ -677,6 +755,9 @@ function Tconnform.CurrentParams: TConnectionParameters; Result.FullTableStatus := chkFullTableStatus.Checked; Result.SessionColor := ColorBoxBackgroundColor.Selected; Result.IgnoreDatabasePattern := editIgnoreDatabasePattern.Text; + Result.LogFileDdl := chkLogFileDdl.Checked; + Result.LogFileDml := chkLogFileDml.Checked; + Result.LogFilePath := editLogFilePath.Text; end; end; @@ -732,14 +813,15 @@ procedure Tconnform.ListSessionsGetText(Sender: TBaseVirtualTree; CellText := CellText + ' *'; end; 1: CellText := Sess.Hostname; - 2: CellText := Sess.Username; - 3: CellText := Sess.ServerVersion; - 4: if Sess.LastConnect>0 then + 2: CellText := Sess.Port.ToString; + 3: CellText := Sess.Username; + 4: CellText := Sess.ServerVersion; + 5: if Sess.LastConnect>0 then CellText := DateTimeToStr(Sess.LastConnect) else CellText := ''; - 5: CellText := FormatNumber(Sess.Counter); - 6: CellText := Sess.Comment; + 6: CellText := FormatNumber(Sess.Counter); + 7: CellText := Sess.Comment; end; end; end; @@ -786,16 +868,35 @@ procedure Tconnform.ListSessionsBeforeCellPaint(Sender: TBaseVirtualTree; end; end; +procedure Tconnform.ListSessionsCompareNodes(Sender: TBaseVirtualTree; Node1, + Node2: PVirtualNode; Column: TColumnIndex; var Result: Integer); +var + VT: TVirtualStringTree; + DirectionMarker: Integer; +begin + VT := Sender as TVirtualStringTree; + if Assigned(Node1) and Assigned(Node2) then begin + // This marker when set to -1 ensures folders are at the top + DirectionMarker := IfThen(VT.Header.SortDirection = sdAscending, 1, -1); + if menuFoldersAtTop.Checked and (Node1.Dummy=1) and (Node2.Dummy<>1) then + Result := -1 * DirectionMarker + else if menuFoldersAtTop.Checked and (Node1.Dummy<>1) and (Node2.Dummy=1) then + Result := 1 * DirectionMarker + else + Result := CompareAnyNode(VT.Text[Node1, Column], VT.Text[Node2, Column]); + end; +end; + procedure Tconnform.ListSessionsCreateEditor(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; out EditLink: IVTEditLink); begin // Use our own text editor to rename a session - EditLink := TInplaceEditorLink.Create(Sender as TVirtualStringTree, True); + EditLink := TInplaceEditorLink.Create(Sender as TVirtualStringTree, True, nil); end; procedure Tconnform.ListSessionsDragDrop(Sender: TBaseVirtualTree; - Source: TObject; DataObject: IDataObject; Formats: TFormatArray; + Source: TObject; DataObject: TVTDragDataObject; Formats: TFormatArray; Shift: TShiftState; Pt: TPoint; var Effect: Integer; Mode: TDropMode); var TargetNode, ParentNode: PVirtualNode; @@ -860,9 +961,11 @@ procedure Tconnform.ListSessionsDragOver(Sender: TBaseVirtualTree; TargetSess := Sender.GetNodeData(TargetNode); Accept := (Source = Sender) and Assigned(TargetSess) - and (Mode <> dmNowhere) - and (TargetNode <> ListSessions.FocusedNode.Parent); - + and (Mode <> dmNowhere); + if Accept and (Mode = dmOnNode) and (TargetNode = ListSessions.FocusedNode.Parent) then + Accept := False; + if Accept and (Mode in [dmAbove, dmBelow]) and (TargetNode.Parent = ListSessions.FocusedNode.Parent) then + Accept := False; // Moving a folder into itself would create an infinite folder structure if Accept and TargetSess.IsFolder then Accept := Accept and (TargetNode <> ListSessions.FocusedNode); @@ -906,17 +1009,19 @@ procedure Tconnform.ListSessionsFocusChanged(Sender: TBaseVirtualTree; tabSettings.TabVisible := SessionFocused; tabSSHtunnel.TabVisible := SessionFocused; tabAdvanced.TabVisible := SessionFocused; + tabSSL.TabVisible := SessionFocused; tabStatistics.TabVisible := SessionFocused; menuRename.Enabled := Assigned(Node); menuNewSessionInFolder.Enabled := InFolder; menuNewFolderInFolder.Enabled := InFolder; FreeAndNil(FPopupDatabases); + FreeAndNil(FPopupCiphers); if not SessionFocused then begin PageControlDetails.ActivePage := tabStart; if ListSessions.RootNodeCount = 0 then lblHelp.Caption := f_('New here? In order to connect to a server, you have to create a so called '+ - '"session" at first. Just click the "New" button on the bottom left to create your first session.'+ + '"session" at first. Just click the "New" button on the bottom left to create your first session. '+ 'Give it a friendly name (e.g. "Local DB server") so you''ll recall it the next time you start %s.', [APPNAME]) else lblHelp.Caption := _('Please click a session on the left list to edit parameters, doubleclick to open it.'); @@ -924,20 +1029,25 @@ procedure Tconnform.ListSessionsFocusChanged(Sender: TBaseVirtualTree; PageControlDetails.ActivePage := tabSettings; SelectedNetType := Sess.NetType; + FLastSelectedNetTypeGroup := Sess.NetTypeGroup; editHost.Text := Sess.Hostname; editUsername.Text := Sess.Username; editPassword.Text := Sess.Password; chkLoginPrompt.Checked := Sess.LoginPrompt; chkWindowsAuth.Checked := Sess.WindowsAuth; chkCleartextPluginEnabled.Checked := Sess.CleartextPluginEnabled; + chkForceUnicode.Checked := Sess.ForceUnicode; updownPort.Position := Sess.Port; chkCompressed.Checked := Sess.Compressed; updownQueryTimeout.Position := Sess.QueryTimeout; updownKeepAlive.Position := Sess.KeepAlive; chkLocalTimeZone.Checked := Sess.LocalTimeZone; chkFullTableStatus.Checked := Sess.FullTableStatus; - RefreshBackgroundColors; - ColorBoxBackgroundColor.Selected := Sess.SessionColor; + ColorBoxBackgroundColor.Items.Objects[0] := TObject(Sess.SessionColor); + if Sess.SessionColor = clNone then + ColorBoxBackgroundColor.Selected := Sess.SessionColor + else + ColorBoxBackgroundColor.ItemIndex := 0; editDatabases.Text := Sess.AllDatabasesStr; comboLibrary.Items := Sess.GetLibraries; comboLibrary.ItemIndex := comboLibrary.Items.IndexOf(Sess.LibraryOrProvider); @@ -946,7 +1056,8 @@ procedure Tconnform.ListSessionsFocusChanged(Sender: TBaseVirtualTree; end; memoComment.Text := Sess.Comment; editStartupScript.Text := Sess.StartupScriptFilename; - editSSHPlinkExe.Text := Sess.SSHPlinkExe; + chkSSHActive.Checked := Sess.SSHActive; + comboSSHExe.Text := Sess.SSHExe; editSSHHost.Text := Sess.SSHHost; editSSHport.Text := IntToStr(Sess.SSHPort); editSSHUser.Text := Sess.SSHUser; @@ -959,7 +1070,11 @@ procedure Tconnform.ListSessionsFocusChanged(Sender: TBaseVirtualTree; editSSLCertificate.Text := Sess.SSLCertificate; editSSLCACertificate.Text := Sess.SSLCACertificate; editSSLCipher.Text := Sess.SSLCipher; + comboSSLVerification.ItemIndex := Sess.SSLVerification; editIgnoreDatabasePattern.Text := Sess.IgnoreDatabasePattern; + chkLogFileDdl.Checked := Sess.LogFileDdl; + chkLogFileDml.Checked := Sess.LogFileDml; + editLogFilePath.Text := Sess.LogFilePath; FServerVersion := Sess.ServerVersion; end; @@ -984,7 +1099,7 @@ procedure Tconnform.RefreshBackgroundColors; procedure Tconnform.TimerStatisticsTimer(Sender: TObject); var - LastConnect, Created, DummyDate: TDateTime; + LastConnect, Created: TDateTime; begin // Continuously update statistics labels lblLastConnectRight.Caption := _('unknown or never'); @@ -1000,15 +1115,17 @@ procedure Tconnform.TimerStatisticsTimer(Sender: TObject); Exit; AppSettings.SessionPath := SelectedSessionPath; - DummyDate := StrToDateTime('2000-01-01'); - LastConnect := StrToDateTimeDef(AppSettings.ReadString(asLastConnect), DummyDate); - if LastConnect <> DummyDate then begin + if AppSettings.SessionPath.IsEmpty then + Exit; + + LastConnect := StrToDateTimeDef(AppSettings.ReadString(asLastConnect), DateTimeNever); + if LastConnect <> DateTimeNever then begin lblLastConnectRight.Hint := DateTimeToStr(LastConnect); lblLastConnectRight.Caption := DateBackFriendlyCaption(LastConnect); lblLastConnectRight.Enabled := True; end; - Created := StrToDateTimeDef(AppSettings.ReadString(asSessionCreated), DummyDate); - if Created <> DummyDate then begin + Created := StrToDateTimeDef(AppSettings.ReadString(asSessionCreated), DateTimeNever); + if Created <> DateTimeNever then begin lblCreatedRight.Hint := DateTimeToStr(Created); lblCreatedRight.Caption := DateBackFriendlyCaption(Created); lblCreatedRight.Enabled := True; @@ -1044,6 +1161,9 @@ procedure Tconnform.ListSessionsNewText(Sender: TBaseVirtualTree; SiblingSessions := NodeSessionNames(Node.Parent, ParentKey); + // Safety replacement for folder separator, see issue #682 + NewText := StringReplace(NewText, '\', '-', [rfReplaceAll]); + if SiblingSessions.IndexOf(NewText) > -1 then begin ErrorDialog( f_('Session "%s" already exists!', [ParentKey+NewText]) @@ -1106,6 +1226,7 @@ procedure Tconnform.editHostDblClick(Sender: TObject); PickFile(Sender); end; + procedure Tconnform.editTrim(Sender: TObject); var Edit: TCustomEdit; @@ -1135,6 +1256,13 @@ procedure Tconnform.chkLoginPromptClick(Sender: TObject); end; +procedure Tconnform.chkSSHActiveClick(Sender: TObject); +begin + if (comboSSHExe.Text = '') and (comboSSHExe.Items.Count > 0) then + comboSSHExe.ItemIndex := 0; + Modification(Sender); +end; + procedure Tconnform.ColorBoxBackgroundColorGetColors(Sender: TCustomColorBox; Items: TStrings); var @@ -1187,7 +1315,7 @@ procedure Tconnform.editDatabasesRightButtonClick(Sender: TObject); Item.Caption := DB; Item.OnClick := MenuDatabasesClick; Item.AutoCheck := True; - Item.RadioItem := Params.NetTypeGroup = ngPgSQL; + Item.RadioItem := Params.IsAnyPostgreSQL; FPopupDatabases.Items.Add(Item); end; Databases.Free; @@ -1222,11 +1350,57 @@ procedure Tconnform.MenuDatabasesClick(Sender: TObject); Databases.Add(Item.Caption); end; SelStart := editDatabases.SelStart; - editDatabases.Text := implodestr(';', Databases); + editDatabases.Text := Implode(';', Databases); editDatabases.SelStart := SelStart; end; +procedure Tconnform.MenuCiphersClick(Sender: TObject); +begin + editUsername.Text := TMenuItem(Sender).Caption; +end; + + +procedure Tconnform.editUsernameRightButtonClick(Sender: TObject); +var + Params: TConnectionParameters; + Item: TMenuItem; + LibraryPath: String; + Lib: TSQLiteLib; + p: TPoint; + i: Integer; +begin + // Provide supported cipher names + if FPopupCiphers = nil then begin + FPopupCiphers := TPopupMenu.Create(Self); + FPopupCiphers.AutoHotkeys := maManual; + Params := CurrentParams; + LibraryPath := GetAppDir + Params.LibraryOrProvider; + // Throws EDbError on any failure: + Lib := TSQLiteLib.CreateWithMultipleCipherFunctions(LibraryPath, Params.DefaultLibrary); + for i:=1 to Lib.sqlite3mc_cipher_count() do begin + Item := TMenuItem.Create(FPopupCiphers); + Item.Caption := Utf8ToString(Lib.sqlite3mc_cipher_name(i)); + Item.OnClick := MenuCiphersClick; + FPopupCiphers.Items.Add(Item); + end; + Lib.Free; + + end; + + p := editUsername.ClientToScreen(editUsername.ClientRect.BottomRight); + FPopupCiphers.Popup(p.X-editUsername.Images.Width, p.Y); +end; + + +procedure Tconnform.menuFoldersAtTopClick(Sender: TObject); +begin + AppSettings.WriteBool(asSessionManagerListFoldersAtTop, menuFoldersAtTop.Checked); + ListSessions.SortTree(ListSessions.Header.SortColumn, ListSessions.Header.SortDirection); + if ListSessions.SelectedCount > 0 then + ListSessions.ScrollIntoView(ListSessions.GetFirstSelected, False); +end; + procedure Tconnform.menuRenameClick(Sender: TObject); begin // Start node editor to rename a session @@ -1237,6 +1411,7 @@ procedure Tconnform.menuRenameClick(Sender: TObject); procedure Tconnform.comboNetTypeChange(Sender: TObject); var Params: TConnectionParameters; + Libs: TStringList; begin // Autoset default connection data as long as that was not modified by user // and only if net type group has now changed @@ -1252,7 +1427,17 @@ procedure Tconnform.comboNetTypeChange(Sender: TObject); editUsername.Text := Params.DefaultUsername; if not editIgnoreDatabasePattern.Modified then editIgnoreDatabasePattern.Text := Params.DefaultIgnoreDatabasePattern; - comboLibrary.Items := Params.GetLibraries; + if not editHost.Modified then + editHost.Text := Params.DefaultHost; + chkSSHActive.Checked := Params.DefaultSshActive; + end; + + // Populate libraries combobox. Required on each net group change, and also between + // SQLite and SQLite-encrypted. + Libs := Params.GetLibraries; + mainform.LogSQL(Libs.CommaText); + if Libs.Text <> comboLibrary.Items.Text then begin + comboLibrary.Items := Libs; comboLibrary.ItemIndex := comboLibrary.Items.IndexOf(Params.DefaultLibrary); end; @@ -1270,11 +1455,15 @@ procedure Tconnform.Modification(Sender: TObject); // Some modification - if FLoaded then begin Sess := ListSessions.GetNodeData(ListSessions.FocusedNode); + if Sess = nil then + Exit; + FSessionModified := (Sess.Hostname <> editHost.Text) or (Sess.Username <> editUsername.Text) or (Sess.LoginPrompt <> chkLoginPrompt.Checked) or (Sess.WindowsAuth <> chkWindowsAuth.Checked) or (Sess.CleartextPluginEnabled <> chkCleartextPluginEnabled.Checked) + or (Sess.ForceUnicode <> chkForceUnicode.Checked) or (Sess.Port <> updownPort.Position) or (Sess.Compressed <> chkCompressed.Checked) or (Sess.QueryTimeout <> updownQueryTimeout.Position) @@ -1287,9 +1476,10 @@ procedure Tconnform.Modification(Sender: TObject); or (Sess.LibraryOrProvider <> comboLibrary.Text) or (Sess.AllDatabasesStr <> editDatabases.Text) or (Sess.Comment <> memoComment.Text) + or (Sess.SSHActive <> chkSSHActive.Checked) or (Sess.SSHHost <> editSSHHost.Text) or (IntToStr(Sess.SSHPort) <> editSSHPort.Text) - or (Sess.SSHPlinkExe <> editSSHPlinkExe.Text) + or (Sess.SSHExe <> comboSSHExe.Text) or (IntToStr(Sess.SSHLocalPort) <> editSSHlocalport.Text) or (Sess.SSHUser <> editSSHUser.Text) or (Sess.SSHPassword <> editSSHPassword.Text) @@ -1300,13 +1490,19 @@ procedure Tconnform.Modification(Sender: TObject); or (Sess.SSLCertificate <> editSSLCertificate.Text) or (Sess.SSLCACertificate <> editSSLCACertificate.Text) or (Sess.SSLCipher <> editSSLCipher.Text) - or (Sess.IgnoreDatabasePattern <> editIgnoreDatabasePattern.Text); + or (Sess.SSLVerification <> comboSSLVerification.ItemIndex) + or (Sess.IgnoreDatabasePattern <> editIgnoreDatabasePattern.Text) + or (Sess.LogFileDdl <> chkLogFileDdl.Checked) + or (Sess.LogFileDml <> chkLogFileDml.Checked) + or (Sess.LogFilePath <> editLogFilePath.Text) + ; PasswordModified := Sess.Password <> editPassword.Text; FOnlyPasswordModified := PasswordModified and (not FSessionModified); FSessionModified := FSessionModified or PasswordModified; if (Sender=editHost) or (Sender=editUsername) or (Sender=editPassword) or (Sender=comboNetType) or (Sender=chkWindowsAuth) or (Sender=editPort) or - (Sender=chkCleartextPluginEnabled) then begin + (Sender=chkCleartextPluginEnabled) or (Sender=chkForceUnicode) + then begin // Be sure to use the modified connection params next time the user clicks the "Databases" pulldown FreeAndNil(FPopupDatabases); end; @@ -1364,37 +1560,75 @@ procedure Tconnform.ValidateControls; if SessionFocused then begin // Validate session GUI stuff on "Settings" tab: + lblHost.Caption := _('Hostname / IP:'); + lblUsername.Caption := _('User')+':'; + lblPassword.Caption := _('Password:'); + lblDatabase.Caption := _('Databases')+':'; + editDatabases.TextHint := _('Separated by semicolon'); case Params.NetType of ntMySQL_NamedPipe: begin lblHost.Caption := _('Socket name:'); end; - ntSQLite: begin + ntPgSQL_TCPIP, ntPgSQL_SSHtunnel: begin + lblDatabase.Caption := _('Database')+':'; + editDatabases.TextHint := _('Single database name'); + end; + ntSQLite, ntSQLiteEncrypted: begin lblHost.Caption := _('Database filename(s)')+':'; + lblUsername.Caption := _('Cipher')+':'; + lblPassword.Caption := _('Key:'); + lblDatabase.Caption := _('Encryption parameters')+':'; + editDatabases.TextHint := _('Example:') + ' kdf_iter=4000;legacy=1;...'; end - else begin - lblHost.Caption := _('Hostname / IP:'); - end; end; editHost.RightButton.Visible := Params.IsAnySQLite; chkLoginPrompt.Enabled := Params.NetTypeGroup in [ngMySQL, ngMSSQL, ngPgSQL]; chkWindowsAuth.Enabled := Params.IsAnyMSSQL or Params.IsAnyMySQL; - lblUsername.Enabled := (Params.NetTypeGroup in [ngMySQL, ngMSSQL, ngPgSQL]) + lblUsername.Enabled := (Params.NetTypeGroup in [ngMySQL, ngMSSQL, ngPgSQL, ngInterbase]) and ((not chkLoginPrompt.Checked) or (not chkLoginPrompt.Enabled)) and ((not chkWindowsAuth.Checked) or (not chkWindowsAuth.Enabled)); + lblUsername.Enabled := lblUsername.Enabled or (Params.NetType = ntSQLiteEncrypted); editUsername.Enabled := lblUsername.Enabled; + editUsername.RightButton.Visible := Params.NetType = ntSQLiteEncrypted; lblPassword.Enabled := lblUsername.Enabled; editPassword.Enabled := lblUsername.Enabled; - lblPort.Enabled := Params.NetType in [ntMySQL_TCPIP, ntMySQL_SSHtunnel, ntMySQL_ProxySQLAdmin, ntMSSQL_TCPIP, ntPgSQL_TCPIP, ntPgSQL_SSHtunnel]; + lblPort.Enabled := Params.NetType in [ntMySQL_TCPIP, ntMySQL_SSHtunnel, ntMySQL_ProxySQLAdmin, ntMySQL_RDS, ntMSSQL_TCPIP, ntPgSQL_TCPIP, ntPgSQL_SSHtunnel, ntInterbase_TCPIP, ntFirebird_TCPIP]; editPort.Enabled := lblPort.Enabled; updownPort.Enabled := lblPort.Enabled; chkCompressed.Enabled := Params.IsAnyMySQL; - lblDatabase.Caption := IfThen(Params.IsAnyPostgreSQL, _('Database')+':', _('Databases')+':'); - lblDatabase.Enabled := Params.NetTypeGroup in [ngMySQL, ngMSSQL, ngPgSQL]; + lblDatabase.Enabled := Params.NetTypeGroup in [ngMySQL, ngMSSQL, ngPgSQL, ngInterbase]; + lblDatabase.Enabled := lblDatabase.Enabled or (Params.NetType = ntSQLiteEncrypted); editDatabases.Enabled := lblDatabase.Enabled; + editDatabases.RightButton.Visible := Params.NetTypeGroup in [ngMySQL, ngMSSQL, ngPgSQL, ngInterbase]; // SSH tunnel tab: - tabSSHtunnel.TabVisible := Params.NetType in [ntMySQL_SSHtunnel, ntPgSQL_SSHtunnel]; + chkSSHActive.Enabled := Params.SshSupport; + lblSSHExe.Enabled := Params.SSHActive; + comboSSHExe.Enabled := Params.SSHActive; + lblSSHhost.Enabled := Params.SSHActive; + editSSHhost.Enabled := Params.SSHActive; + editSSHport.Enabled := Params.SSHActive; + lblSSHUser.Enabled := Params.SSHActive; + editSSHUser.Enabled := Params.SSHActive; + lblSSHPassword.Enabled := Params.SSHActive; + editSSHPassword.Enabled := Params.SSHActive; + lblSSHTimeout.Enabled := Params.SSHActive; + editSSHTimeout.Enabled := Params.SSHActive; + updownSSHTimeout.Enabled := Params.SSHActive; + lblSSHkeyfile.Enabled := Params.SSHActive; + editSSHPrivateKey.Enabled := Params.SSHActive; + lblSSHLocalPort.Enabled := Params.SSHActive; + editSSHlocalport.Enabled := Params.SSHActive; // Advanced tab: - chkWantSSL.Enabled := Params.NetType in [ntMySQL_TCPIP, ntMySQL_SSHtunnel, ntMySQL_ProxySQLAdmin, ntPgSQL_TCPIP, ntPgSQL_SSHtunnel]; + lblQueryTimeout.Enabled := True; + editQueryTimeout.Enabled := lblQueryTimeout.Enabled; + updownQueryTimeout.Enabled := lblQueryTimeout.Enabled; + chkLocalTimeZone.Enabled := Params.NetTypeGroup = ngMySQL; + chkFullTableStatus.Enabled := (Params.NetTypeGroup in [ngMySQL, ngPgSQL, ngSQLite]) and (Params.NetType <> ntMySQL_ProxySQLAdmin); + chkCleartextPluginEnabled.Enabled := Params.NetTypeGroup = ngMySQL; + chkForceUnicode.Enabled := Params.NetTypeGroup = ngMySQL; + editLogFilePath.Enabled := Params.LogFileDdl or Params.LogFileDml; + // SSL tab: + chkWantSSL.Enabled := Params.NetType in [ntMySQL_TCPIP, ntMySQL_SSHtunnel, ntMySQL_ProxySQLAdmin, ntMySQL_RDS, ntPgSQL_TCPIP, ntPgSQL_SSHtunnel]; lblSSLPrivateKey.Enabled := Params.WantSSL; editSSLPrivateKey.Enabled := Params.WantSSL; lblSSLCACertificate.Enabled := Params.WantSSL; @@ -1403,12 +1637,8 @@ procedure Tconnform.ValidateControls; editSSLCertificate.Enabled := Params.WantSSL; lblSSLcipher.Enabled := Params.WantSSL; editSSLcipher.Enabled := Params.WantSSL; - lblQueryTimeout.Enabled := Params.NetTypeGroup in [ngMSSQL, ngPgSQL, ngSQLite]; - editQueryTimeout.Enabled := lblQueryTimeout.Enabled; - updownQueryTimeout.Enabled := lblQueryTimeout.Enabled; - chkLocalTimeZone.Enabled := Params.NetTypeGroup = ngMySQL; - chkFullTableStatus.Enabled := (Params.NetTypeGroup in [ngMySQL, ngPgSQL]) and (Params.NetType <> ntMySQL_ProxySQLAdmin); - chkCleartextPluginEnabled.Enabled := Params.NetTypeGroup = ngMySQL; + lblSSLVerification.Enabled := Params.WantSSL; + comboSSLVerification.Enabled := Params.WantSSL; Params.Free; end; @@ -1421,12 +1651,15 @@ procedure Tconnform.ValidateControls; menuSave.Enabled := btnSave.Enabled; menuSaveAs.Enabled := SessionFocused; menuDelete.Enabled := btnDelete.Enabled; + TExtForm.PageControlTabHighlight(PageControlDetails); + + Caption := GetWindowCaption; end; procedure Tconnform.splitterMainMoved(Sender: TObject); var - ButtonWidth: Integer; + HorizSpace, ButtonWidth: Integer; begin // Splitter resized - adjust width of bottom left buttons ButtonWidth := Round((pnlLeft.Width - 2 * pnlLeft.Margins.Left) / 3); @@ -1438,9 +1671,10 @@ procedure Tconnform.splitterMainMoved(Sender: TObject); btnDelete.Left := btnSave.Left + btnSave.Width + pnlLeft.Margins.Left; // Resize bottom right buttons - ButtonWidth := Round((PageControlDetails.Width - 2 * PageControlDetails.Margins.Right) / 3); - ButtonWidth := Max(ButtonWidth, 50); - ButtonWidth := Min(ButtonWidth, 100); + HorizSpace := PageControlDetails.Width - 2 * PageControlDetails.Margins.Right; + ButtonWidth := Round(HorizSpace / 3); + ButtonWidth := Max(ButtonWidth, ScaleSize(50)); + ButtonWidth := Min(ButtonWidth, ScaleSize(100)); btnMore.Width := ButtonWidth; btnCancel.Width := ButtonWidth; btnOpen.Width := ButtonWidth; @@ -1464,6 +1698,11 @@ procedure Tconnform.TimerButtonAnimationTimer(Sender: TObject); FButtonAnimationStep := 0; end; +procedure Tconnform.PageControlDetailsChange(Sender: TObject); +begin + ValidateControls; +end; + procedure Tconnform.PickFile(Sender: TObject); var Selector: TOpenDialog; @@ -1475,18 +1714,15 @@ procedure Tconnform.PickFile(Sender: TObject); // Select startup SQL file, SSL file or whatever button clicked Edit := Sender as TButtonedEdit; Selector := TOpenDialog.Create(Self); - //Selector.InitialDir := ?; if Edit = editHost then begin Selector.Filter := 'SQLite databases ('+FILEFILTER_SQLITEDB+')|'+FILEFILTER_SQLITEDB+'|'+_('All files')+' (*.*)|*.*'; Selector.Options := Selector.Options - [ofFileMustExist]; Selector.Options := Selector.Options + [ofAllowMultiSelect]; Selector.DefaultExt := FILEEXT_SQLITEDB; - end else if Edit = editStartupScript then + end else if (Edit = editStartupScript) or (Edit = editLogFilePath) then Selector.Filter := _('SQL files')+' (*.sql)|*.sql|'+_('All files')+' (*.*)|*.*' - else if Edit = editSSHPlinkExe then - Selector.Filter := _('Executables')+' (*.exe)|*.exe|'+_('All files')+' (*.*)|*.*' else if Edit = editSSHPrivateKey then - Selector.Filter := _('PuTTY private key')+' (*.ppk)|*.ppk|'+_('All files')+' (*.*)|*.*' + Selector.Filter := _('All files')+' (*.*)|*.*' else Selector.Filter := _('Privacy Enhanced Mail certificates')+' (*.pem)|*.pem|'+_('Certificates')+' (*.crt)|*.crt|'+_('All files')+' (*.*)|*.*'; // Find relevant label and set open dialog's title @@ -1497,16 +1733,19 @@ procedure Tconnform.PickFile(Sender: TObject); break; end; end; - + // Set initial directory to the one from the edit's file + Selector.InitialDir := ExtractFilePath(Edit.Text); + if Selector.InitialDir.IsEmpty then + Selector.InitialDir := TPath.GetPathRoot(Application.ExeName); if Selector.Execute then begin FileNames := TStringList.Create; FileNames.Assign(Selector.Files); for i:=0 to FileNames.Count-1 do begin // Remove path if it's the application directory - if ExtractFilePath(FileNames[i]) = ExtractFilePath(Application.ExeName) then + if ExtractFilePath(FileNames[i]) = GetAppDir then FileNames[i] := ExtractFileName(FileNames[i]); end; - Edit.Text := implodestr(DELIM, FileNames); + Edit.Text := Implode(DELIM, FileNames); Modification(Selector); end; Selector.Free; @@ -1515,23 +1754,21 @@ procedure Tconnform.PickFile(Sender: TObject); procedure Tconnform.editSearchChange(Sender: TObject); begin - // Filter session nodes - FilterNodesByEdit(Sender as TButtonedEdit, ListSessions); + // Filter session nodes - start delay + timerEditFilterDelay.Enabled := False; + timerEditFilterDelay.Enabled := True; end; -procedure Tconnform.editSearchRightButtonClick(Sender: TObject); +procedure Tconnform.timerEditFilterDelayTimer(Sender: TObject); begin - editSearch.Clear; + // Filter session nodes + FilterNodesByEdit(editSearch, ListSessions); + timerEditFilterDelay.Enabled := False; end; -procedure Tconnform.editSSHPlinkExeChange(Sender: TObject); +procedure Tconnform.editSearchRightButtonClick(Sender: TObject); begin - if not FileExists(editSSHPlinkExe.Text) then - editSSHPlinkExe.Font.Color := clRed - else - editSSHPlinkExe.Font.Color := GetThemeColor(clWindowText); - Modification(Sender); + editSearch.Clear; end; - end. diff --git a/source/const.inc b/source/const.inc index 53272c3f5..9cf9371d0 100644 --- a/source/const.inc +++ b/source/const.inc @@ -33,6 +33,7 @@ const ICONINDEX_UNIQUEKEY = 24; ICONINDEX_FULLTEXTKEY = 22; ICONINDEX_SPATIALKEY = 126; + ICONINDEX_VECTORKEY = 207; ICONINDEX_FOREIGNKEY = 136; ICONINDEX_SERVER = 36; ICONINDEX_DB = 5; @@ -45,22 +46,24 @@ const ICONINDEX_FUNCTION = 13; ICONINDEX_EVENT = 80; ICONINDEX_KEYWORD = 25; + ICONINDEX_USER = 43; + ICONINDEX_ROLE = 95; // Size of byte units - {Kibibyte} SIZE_KB = 1024; - {Mebibyte} SIZE_MB = 1048576; - {Gibibyte} SIZE_GB = 1073741824; - {Tebibyte} SIZE_TB = 1099511627776; - {Pebibyte} SIZE_PB = 1125899906842624; - {Exbibyte} SIZE_EB = 1152921504606846976; + {Kibibyte} SIZE_KB = Int64(1024); + {Mebibyte} SIZE_MB = Int64(1048576); + {Gibibyte} SIZE_GB = Int64(1073741824); + {Tebibyte} SIZE_TB = Int64(1099511627776); + {Pebibyte} SIZE_PB = Int64(1125899906842624); + {Exbibyte} SIZE_EB = Int64(1152921504606846976); // Size of byte units for formatting purposes - {Kibibyte} FSIZE_KB = 1000; - {Mebibyte} FSIZE_MB = 1024000; - {Gibibyte} FSIZE_GB = 1048576000; - {Tebibyte} FSIZE_TB = 1073741824000; - {Pebibyte} FSIZE_PB = 1099511627776000; - {Exbibyte} FSIZE_EB = 1125899906842624000; + {Kibibyte} FSIZE_KB = Int64(1000); + {Mebibyte} FSIZE_MB = Int64(1024000); + {Gibibyte} FSIZE_GB = Int64(1048576000); + {Tebibyte} FSIZE_TB = Int64(1073741824000); + {Pebibyte} FSIZE_PB = Int64(1099511627776000); + {Exbibyte} FSIZE_EB = Int64(1125899906842624000); // Abbreviations of byte unit names {Bytes} NAME_BYTES = ' B'; @@ -71,16 +74,10 @@ const {Pebibyte} NAME_PB = ' PiB'; {Exbibyte} NAME_EB = ' EiB'; - // Used by ListViews and Grids - ORDER_ASC = 0; // Used for tag-value of "Direction"-button - ORDER_DESC = 1; // dito - TXT_ASC = 'ASC'; // Used for caption of "Direction"-button - TXT_DESC = 'DESC'; // dito - // Data grid: How many bytes to fetch from data fields that are potentially large. - GRIDMAXDATA: Integer = 256; + GRIDMAXDATA: Int64 = 256; - BACKUP_MAXFILESIZE: Integer = 10 * SIZE_MB; + BACKUP_MAXFILESIZE = 10 * SIZE_MB; BACKUP_FILEPATTERN: String = 'query-tab-%s.sql'; VTREE_NOTLOADED = 0; @@ -89,6 +86,8 @@ const // Modification indicator for TControl.Tag MODIFIEDFLAG = 10; + // Suspend click event handling tag for checkboxes + SUSPEND_ONCLICK = 20; SUnhandledNodeIndex = 'Unhandled tree node index'; MSG_NOGRIDEDITING = 'Selected columns don''t contain a sufficient set of key columns to allow editing. Please select primary or unique key columns, or just all columns.'; @@ -99,19 +98,16 @@ const MsgSQLError: String = 'SQL Error (%d): %s'; MsgSQLErrorMultiStatements: String = 'SQL Error (%d) in statement #%d: %s'; MsgUnhandledNetType: String = 'Unhandled connection type (%d)'; + MsgUnhandledControl: String = 'Unhandled control in %s'; MsgDisconnect: String = 'Connection to %s closed at %s'; - MsgInvalidColumn: String = 'Column #%d not available. Query returned %d columns and %d rows.'; + // This must be an empty string, otherwise TTableColumn's get GenerationExpression=XYZ on old servers + TextInvalidColumn: String = ''; FILEFILTER_SQLITEDB = '*.sqlite3;*.sqlite;*.db;*.s3db'; FILEEXT_SQLITEDB = 'sqlite3'; - - SYNCOMPLETION_PATTERN = '\image{%d}\hspace{5}\color{clGrayText}%s\column{}\color{clWindowText}%s\color{clGrayText}%s'; - - HELPERNODE_COLUMNS = 0; - HELPERNODE_FUNCTIONS = 1; - HELPERNODE_KEYWORDS = 2; - HELPERNODE_SNIPPETS = 3; - HELPERNODE_HISTORY = 4; - HELPERNODE_PROFILE = 5; - HELPERNODE_BINDING = 6; - + FILEEXT_SNIPPET = '.sql'; + PROPOSAL_ITEM_HEIGHT = 18; + // Note the following should be in sync to what MySQL returns from SHOW WARNINGS + SLogPrefixWarning = 'Warning'; + SLogPrefixNote = 'Note'; + SLogPrefixInfo = 'Info'; diff --git a/source/copytable.dfm b/source/copytable.dfm index 35df58a02..b0486b352 100644 --- a/source/copytable.dfm +++ b/source/copytable.dfm @@ -9,21 +9,18 @@ object CopyTableForm: TCopyTableForm Constraints.MinWidth = 380 Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText - Font.Height = -11 + Font.Height = -12 Font.Name = 'Tahoma' Font.Style = [] - OldCreateOrder = False Position = poMainFormCenter OnClose = FormClose OnCreate = FormCreate - OnDestroy = FormDestroy OnResize = FormResize OnShow = FormShow DesignSize = ( 364 304) - PixelsPerInch = 96 - TextHeight = 13 + TextHeight = 14 object lblNewTablename: TLabel Left = 8 Top = 8 @@ -103,6 +100,8 @@ object CopyTableForm: TCopyTableForm OnGetImageIndex = TreeElementsGetImageIndex OnInitChildren = TreeElementsInitChildren OnInitNode = TreeElementsInitNode + Touch.InteractiveGestures = [igPan, igPressAndTap] + Touch.InteractiveGestureOptions = [igoPanSingleFingerHorizontal, igoPanSingleFingerVertical, igoPanInertia, igoPanGutter, igoParentPassthrough] Columns = <> end object MemoFilter: TSynMemo @@ -118,6 +117,14 @@ object CopyTableForm: TCopyTableForm Font.Name = 'Courier New' Font.Style = [] TabOrder = 4 + CodeFolding.GutterShapeSize = 11 + CodeFolding.CollapsedLineColor = clGrayText + CodeFolding.FolderBarLinesColor = clGrayText + CodeFolding.IndentGuidesColor = clGray + CodeFolding.IndentGuides = True + CodeFolding.ShowCollapsedLine = False + CodeFolding.ShowHintMark = True + UseCodeFolding = False Gutter.AutoSize = True Gutter.DigitCount = 2 Gutter.Font.Charset = DEFAULT_CHARSET diff --git a/source/copytable.pas b/source/copytable.pas index aec2e1d89..af3e8aee8 100644 --- a/source/copytable.pas +++ b/source/copytable.pas @@ -4,8 +4,9 @@ interface uses - Windows, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, extra_controls, - dbconnection, dbstructures, VirtualTrees, SynEdit, SynMemo, Menus, gnugettext; + Winapi.Windows, System.SysUtils, System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, extra_controls, + dbconnection, dbstructures, dbstructures.mysql, VirtualTrees, SynEdit, SynMemo, Vcl.Menus, gnugettext, VirtualTrees.BaseTree, VirtualTrees.Types, + VirtualTrees.BaseAncestorVCL, VirtualTrees.AncestorVCL; type TCopyTableForm = class(TExtForm) @@ -32,7 +33,6 @@ TCopyTableForm = class(TExtForm) Kind: TVTImageKind; Column: TColumnIndex; var Ghosted: Boolean; var ImageIndex: TImageIndex); procedure TreeElementsInitChildren(Sender: TBaseVirtualTree; Node: PVirtualNode; var ChildCount: Cardinal); - procedure FormDestroy(Sender: TObject); procedure TreeElementsChecked(Sender: TBaseVirtualTree; Node: PVirtualNode); procedure FormClose(Sender: TObject; var Action: TCloseAction); procedure btnRecentFiltersClick(Sender: TObject); @@ -68,21 +68,11 @@ implementation procedure TCopyTableForm.FormCreate(Sender: TObject); begin HasSizeGrip := True; - Width := AppSettings.ReadInt(asCopyTableWindowWidth); - Height := AppSettings.ReadInt(asCopyTableWindowHeight); - MainForm.SetupSynEditors; + MainForm.SetupSynEditors(Self); FixVT(TreeElements); end; -procedure TCopyTableForm.FormDestroy(Sender: TObject); -begin - // Save GUI stuff - AppSettings.WriteInt(asCopyTableWindowWidth, Width); - AppSettings.WriteInt(asCopyTableWindowHeight, Height); -end; - - procedure TCopyTableForm.FormResize(Sender: TObject); var HalfWidth: Integer; @@ -105,6 +95,8 @@ procedure TCopyTableForm.FormShow(Sender: TObject); Item: TMenuItem; Tree: TVirtualStringTree; begin + Width := AppSettings.ReadIntDpiAware(asCopyTableWindowWidth, Self); + Height := AppSettings.ReadIntDpiAware(asCopyTableWindowHeight, Self); if Mainform.DBtree.Focused then Tree := Mainform.DBtree else @@ -193,7 +185,9 @@ procedure TCopyTableForm.FormClose(Sender: TObject; var Action: TCloseAction); AppSettings.WriteString(asCopyTableRecentFilter, NewValues[i], IntToStr(i)); end; end; - Action := caFree; + // Store GUI setup + AppSettings.WriteIntDpiAware(asCopyTableWindowWidth, Self, Width); + AppSettings.WriteIntDpiAware(asCopyTableWindowHeight, Self, Height); end; @@ -354,7 +348,7 @@ procedure TCopyTableForm.editNewTablenameChange(Sender: TObject); procedure TCopyTableForm.btnOKClick(Sender: TObject); var CreateCode, InsertCode, TargetTable, DataCols, Msg: String; - TableExistence: String; + TableExistence, AutoIncName: String; ParentNode, Node: PVirtualNode; DoData, AutoIncGetsKey, AutoIncRemoved, TableHasAutoInc: Boolean; SelectedColumns: TTableColumnList; @@ -363,12 +357,13 @@ procedure TCopyTableForm.btnOKClick(Sender: TObject); Column: TTableColumn; Key: TTableKey; ForeignKey: TForeignKey; -const - ClausePattern: String = #9 + '%s,' + CRLF; + ClausePattern: String; + NewObj: TDBObject; begin // Compose and run CREATE query TargetTable := FConnection.QuotedDbAndTableName(comboDatabase.Text, editNewTablename.Text); + ClausePattern := CodeIndent + '%s,' + sLineBreak; // Watch out if target table exists try @@ -383,6 +378,7 @@ procedure TCopyTableForm.btnOKClick(Sender: TObject); Exit; end; FConnection.Query('DROP TABLE '+TargetTable); + FConnection.ShowWarnings; end; Screen.Cursor := crHourglass; @@ -416,9 +412,11 @@ procedure TCopyTableForm.btnOKClick(Sender: TObject); // Columns code. Remove auto_increment attribute if pkey was unchecked, to overcome // "there can be only one auto column and it must be defined as a key" + AutoIncName := 'unknown'; for Column in SelectedColumns do begin AutoIncGetsKey := False; AutoIncRemoved := False; + AutoIncName := FConnection.SqlProvider.GetSql(qAutoInc); if Column.DefaultType = cdtAutoInc then begin for Key in SelectedKeys do begin // Don't check index type, MySQL allows auto-increment columns on nearly all indexes @@ -483,19 +481,26 @@ procedure TCopyTableForm.btnOKClick(Sender: TObject); try MainForm.ShowStatusMsg(_('Creating table ...')); FConnection.Query(CreateCode); - if InsertCode <> '' then + FConnection.ShowWarnings; + if InsertCode <> '' then begin FConnection.Query(InsertCode); + FConnection.ShowWarnings; + end; // actRefresh takes care of whether the table editor is open - if FConnection.Database = comboDatabase.Text then - MainForm.actRefresh.Execute - else - FConnection.ClearDbObjects(comboDatabase.Text); + // See also issue #1597 + MainForm.actRefresh.Execute; + // Select it in tree + NewObj := TDBObject.Create(FDBObj.Connection); + NewObj.NodeType := lntTable; + NewObj.Database := comboDatabase.Text; + NewObj.Name := editNewTablename.Text; + MainForm.ActiveDbObj := NewObj; except on E:EDbError do begin Screen.Cursor := crDefault; Msg := E.Message; - if FConnection.LastErrorCode = 1075 then - Msg := Msg + CRLF + CRLF + f_('Please select the required index for the %s flag.', ['auto_increment']); + if FConnection.LastErrorCode = ER_WRONG_AUTO_KEY then + Msg := Msg + CRLF + CRLF + f_('Please select the required index for the %s flag.', [AutoIncName]); ErrorDialog(Msg); ModalResult := mrNone; end; diff --git a/source/createdatabase.dfm b/source/createdatabase.dfm index f67f5cf2a..aac4de882 100644 --- a/source/createdatabase.dfm +++ b/source/createdatabase.dfm @@ -8,10 +8,9 @@ object CreateDatabaseForm: TCreateDatabaseForm Color = clBtnFace Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText - Font.Height = -11 + Font.Height = -12 Font.Name = 'Tahoma' Font.Style = [] - OldCreateOrder = False Position = poOwnerFormCenter OnClose = FormClose OnCreate = FormCreate @@ -19,8 +18,7 @@ object CreateDatabaseForm: TCreateDatabaseForm DesignSize = ( 317 227) - PixelsPerInch = 96 - TextHeight = 13 + TextHeight = 14 object lblDBName: TLabel Left = 8 Top = 19 @@ -89,6 +87,7 @@ object CreateDatabaseForm: TCreateDatabaseForm Top = 42 Width = 213 Height = 21 + AutoDropDownWidth = True Style = csDropDownList DropDownCount = 16 Sorted = True @@ -108,6 +107,14 @@ object CreateDatabaseForm: TCreateDatabaseForm Font.Name = 'Courier New' Font.Style = [] TabOrder = 4 + CodeFolding.GutterShapeSize = 11 + CodeFolding.CollapsedLineColor = clGrayText + CodeFolding.FolderBarLinesColor = clGrayText + CodeFolding.IndentGuidesColor = clGray + CodeFolding.IndentGuides = True + CodeFolding.ShowCollapsedLine = False + CodeFolding.ShowHintMark = True + UseCodeFolding = False Gutter.Font.Charset = DEFAULT_CHARSET Gutter.Font.Color = clWindowText Gutter.Font.Height = -11 diff --git a/source/createdatabase.pas b/source/createdatabase.pas index 8f581fd15..2f71279b1 100644 --- a/source/createdatabase.pas +++ b/source/createdatabase.pas @@ -3,7 +3,7 @@ interface uses - Windows, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, SynEdit, SynMemo, + Winapi.Windows, System.SysUtils, System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, SynEdit, SynMemo, dbconnection, dbstructures, gnugettext, SynRegExpr, extra_controls; type @@ -52,12 +52,15 @@ procedure TCreateDatabaseForm.FormCreate(Sender: TObject); } procedure TCreateDatabaseForm.FormShow(Sender: TObject); var - ServerCollation, Collation, Charset, CreateCode: String; + ServerCollation, PreviousCollation, CurrentCollation: String; + Charset, CreateCode: String; CollationTable: TDBQuery; rx: TRegExpr; begin FConnection := MainForm.ActiveConnection; CollationTable := FConnection.CollationTable; + CurrentCollation := ''; + PreviousCollation := AppSettings.ReadString(asCreateDbCollation); // Detect servers default collation case FConnection.Parameters.NetTypeGroup of @@ -68,13 +71,9 @@ procedure TCreateDatabaseForm.FormShow(Sender: TObject); end; lblServerDefaultCollation.Caption := f_('Servers default: %s', [ServerCollation]); - if modifyDB = '' then begin + if modifyDB.IsEmpty then begin Caption := _('Create database ...'); editDBName.Text := ''; - Charset := ''; - Collation := AppSettings.ReadString(asCreateDbCollation); - if Collation.IsEmpty then - Collation := ServerCollation; end else begin Caption := _('Alter database ...'); @@ -88,19 +87,19 @@ procedure TCreateDatabaseForm.FormShow(Sender: TObject); Charset := rx.Match[1]; rx.Expression := '\sCOLLATE\s+(\w+)\b'; if rx.Exec(CreateCode) then - Collation := rx.Match[1]; + CurrentCollation := rx.Match[1]; rx.Free; // Find default collation of given charset - if (Collation = '') and (Charset <> '') and Assigned(CollationTable) then begin + if (CurrentCollation = '') and (Charset <> '') and Assigned(CollationTable) then begin while not CollationTable.Eof do begin if (CollationTable.Col('Charset') = Charset) and (LowerCase(CollationTable.Col('Default')) = 'yes') then - Collation := CollationTable.Col('Collation'); + CurrentCollation := CollationTable.Col('Collation'); CollationTable.Next; end; end; end; - // Select collation in pulldown + // Populate collation combo box comboCollation.Enabled := Assigned(CollationTable); lblCollation.Enabled := comboCollation.Enabled; comboCollation.Clear; @@ -110,9 +109,16 @@ procedure TCreateDatabaseForm.FormShow(Sender: TObject); comboCollation.Items.Add(CollationTable.Col('Collation')); CollationTable.Next; end; - comboCollation.ItemIndex := comboCollation.Items.IndexOf(Collation); + // Pre-select best fitting collation + comboCollation.ItemIndex := comboCollation.Items.IndexOf(CurrentCollation); if comboCollation.ItemIndex = -1 then - comboCollation.ItemIndex := 0; + comboCollation.ItemIndex := comboCollation.Items.IndexOf(PreviousCollation); + if comboCollation.ItemIndex = -1 then + comboCollation.ItemIndex := comboCollation.Items.IndexOf(ServerCollation); + if comboCollation.ItemIndex = -1 then + comboCollation.ItemIndex := comboCollation.Items.IndexOf('utf8mb4_unicode_ci'); + if comboCollation.ItemIndex = -1 then + comboCollation.ItemIndex := 0; // give up, use the first one end; editDBName.SetFocus; @@ -120,7 +126,7 @@ procedure TCreateDatabaseForm.FormShow(Sender: TObject); // Invoke SQL preview Modified(Sender); - MainForm.SetupSynEditors; + MainForm.SetupSynEditors(Self); end; @@ -135,9 +141,10 @@ procedure TCreateDatabaseForm.btnOKClick(Sender: TObject); ObjectsInNewDb, ObjectsInOldDb: TDBObjectList; i, j: Integer; begin - if modifyDB = '' then try + if modifyDB.IsEmpty then try sql := GetCreateStatement; FConnection.Query(sql); + FConnection.ShowWarnings; AppSettings.WriteString(asCreateDbCollation, comboCollation.Text); MainForm.RefreshTree; // Close form @@ -154,6 +161,7 @@ procedure TCreateDatabaseForm.btnOKClick(Sender: TObject); if modifyDB = editDBName.Text then begin // Alter database FConnection.Query(sql); + FConnection.ShowWarnings; end else begin // Rename database ObjectsInOldDb := FConnection.GetDBObjects(modifyDB, True); @@ -180,6 +188,7 @@ procedure TCreateDatabaseForm.btnOKClick(Sender: TObject); if AllDatabases.IndexOf(editDBName.Text) = -1 then begin // Target db does not exist - create it FConnection.Query(GetCreateStatement); + FConnection.ShowWarnings; end else begin if MessageDialog(f_('Database "%s" exists. But it does not contain objects with same names as in "%s", so it''s uncritical to move everything. Move all objects to "%s"?', [editDBName.Text, modifyDB, editDBName.Text]), mtConfirmation, [mbYes, mbCancel]) <> mrYes then @@ -195,6 +204,7 @@ procedure TCreateDatabaseForm.btnOKClick(Sender: TObject); Delete(sql, Length(sql)-1, 2); sql := 'RENAME TABLE '+sql; FConnection.Query(sql); + FConnection.ShowWarnings; FConnection.ClearDbObjects(modifyDB); FConnection.ClearDbObjects(editDBName.Text); end; @@ -202,6 +212,7 @@ procedure TCreateDatabaseForm.btnOKClick(Sender: TObject); ObjectsLeft := FConnection.GetDBObjects(modifyDB); if ObjectsLeft.Count = 0 then begin FConnection.Query('DROP DATABASE '+FConnection.QuoteIdent(modifyDB)); + FConnection.ShowWarnings; MainForm.RefreshTree; end; end; @@ -222,7 +233,7 @@ procedure TCreateDatabaseForm.btnOKClick(Sender: TObject); else AllDatabases.Add(editDBname.Text); AppSettings.SessionPath := FConnection.Parameters.SessionPath; - FConnection.Parameters.AllDatabasesStr := ImplodeStr(';', AllDatabases); + FConnection.Parameters.AllDatabasesStr := Implode(';', AllDatabases); AppSettings.WriteString(asDatabases, FConnection.Parameters.AllDatabasesStr); end; end; diff --git a/source/csv_detector.dfm b/source/csv_detector.dfm new file mode 100644 index 000000000..4888c7178 --- /dev/null +++ b/source/csv_detector.dfm @@ -0,0 +1,88 @@ +object frmCsvDetector: TfrmCsvDetector + Left = 0 + Top = 0 + Caption = 'Detect CSV layout' + ClientHeight = 299 + ClientWidth = 635 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -12 + Font.Name = 'Tahoma' + Font.Style = [] + Position = poOwnerFormCenter + OnCreate = FormCreate + OnShow = FormShow + DesignSize = ( + 635 + 299) + TextHeight = 14 + object btnScan: TButton + Left = 8 + Top = 8 + Width = 113 + Height = 25 + Caption = 'Scan file...' + Images = MainForm.VirtualImageListMain + TabOrder = 0 + OnClick = btnScanClick + end + object SynMemoCreateTable: TSynMemo + Left = 8 + Top = 39 + Width = 619 + Height = 221 + SingleLineMode = False + Anchors = [akLeft, akTop, akRight, akBottom] + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -13 + Font.Name = 'Courier New' + Font.Style = [] + TabOrder = 1 + CodeFolding.GutterShapeSize = 11 + CodeFolding.CollapsedLineColor = clGrayText + CodeFolding.FolderBarLinesColor = clGrayText + CodeFolding.IndentGuidesColor = clGray + CodeFolding.IndentGuides = True + CodeFolding.ShowCollapsedLine = False + CodeFolding.ShowHintMark = True + UseCodeFolding = False + Gutter.Font.Charset = DEFAULT_CHARSET + Gutter.Font.Color = clWindowText + Gutter.Font.Height = -11 + Gutter.Font.Name = 'Courier New' + Gutter.Font.Style = [] + FontSmoothing = fsmNone + end + object btnCancel: TButton + Left = 505 + Top = 266 + Width = 122 + Height = 25 + Anchors = [akRight, akBottom] + Cancel = True + Caption = 'Cancel' + ModalResult = 2 + TabOrder = 2 + end + object btnSave: TButton + Left = 377 + Top = 266 + Width = 122 + Height = 25 + Anchors = [akRight, akBottom] + Caption = 'Ok, create table' + Default = True + ModalResult = 1 + TabOrder = 3 + OnClick = btnSaveClick + end + object TimerStartScan: TTimer + Enabled = False + Interval = 100 + OnTimer = btnScanClick + Left = 56 + Top = 64 + end +end diff --git a/source/csv_detector.pas b/source/csv_detector.pas new file mode 100644 index 000000000..ade43965d --- /dev/null +++ b/source/csv_detector.pas @@ -0,0 +1,404 @@ +unit csv_detector; + +interface + +uses + Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics, + Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, SynEdit, SynMemo, extra_controls, apphelpers, + loaddata, dbconnection, Vcl.ExtCtrls, gnugettext, dbstructures, System.Math, SynRegExpr, System.IOUtils, + System.StrUtils; + +type + TfrmCsvDetector = class(TExtForm) + btnScan: TButton; + SynMemoCreateTable: TSynMemo; + btnCancel: TButton; + btnSave: TButton; + TimerStartScan: TTimer; + procedure FormShow(Sender: TObject); + procedure btnScanClick(Sender: TObject); + procedure FormCreate(Sender: TObject); + procedure btnSaveClick(Sender: TObject); + private + FLoadDataFrm: Tloaddataform; + FConnection: TDBConnection; + function DetectColumnAttributes(Rows: TGridRows; IgnoreLines: Integer): TTableColumnList; + function ComposeCreateStatement(Columns: TTableColumnList): String; + public + end; + + +var + frmCsvDetector: TfrmCsvDetector; + +implementation + +{$R *.dfm} + +uses main; + + + +procedure TfrmCsvDetector.FormCreate(Sender: TObject); +begin + HasSizeGrip := True; + FLoadDataFrm := Tloaddataform(Owner); + FConnection := MainForm.ActiveConnection; +end; + +procedure TfrmCsvDetector.FormShow(Sender: TObject); +begin + SynMemoCreateTable.Highlighter := MainForm.SynSQLSynUsed; + MainForm.SetupSynEditors(Self); + TimerStartScan.Enabled := True; +end; + +procedure TfrmCsvDetector.btnScanClick(Sender: TObject); +var + Stream: TFileStream; + Encoding: TEncoding; + GridRows: TGridRows; + GridRow: TGridRow; + GridValue: TGridValue; + Term, Encl, Escp, LineTerm: String; + RowNum, IgnoreLines: Integer; + P, ContentLen, ProgressCharsPerStep, ProgressChars: Integer; + EnclLen, TermLen, LineTermLen: Integer; + Contents: String; + EnclTest, TermTest, LineTermTest: String; + Value: String; + IsEncl, IsTerm, IsLineTerm, IsEof: Boolean; + InEncl: Boolean; + Columns: TTableColumnList; +const + TestChunkSize = 20*SIZE_MB; + + procedure NextChar; + begin + Inc(P); + Inc(ProgressChars); + if ProgressChars >= ProgressCharsPerStep then begin + Mainform.ProgressStep; + Mainform.ShowStatusMsg(f_('Parsing textfile, row %s, %d%%', [FormatNumber(GridRows.Count-IgnoreLines), Mainform.ProgressBarStatus.Position])); + //Mainform.LogSQL(f_('Analyzing textfile, row %s, %d%%', [FormatNumber(Rows.Count-IgnoreLines), Mainform.ProgressBarStatus.Position])); + ProgressChars := 0; + end; + end; + + function TestLeftChars(var Portion: String; CompareTo: String; Len: Integer): Boolean; + var i: Integer; + begin + if Len > 0 then begin + for i:=1 to Len-1 do + Portion[i] := Portion[i+1]; + Portion[Len] := Contents[P]; + Result := Portion = CompareTo; + end else + Result := False; + end; + + procedure AddValue; + begin + if Copy(Value, 1, EnclLen) = Encl then begin + Delete(Value, 1, EnclLen); + Delete(Value, Length(Value)-EnclLen+1, EnclLen); + end; + GridValue := TGridValue.Create; + GridValue.OldText := Value; + GridValue.OldIsNull := Value = 'NULL'; + if GridRow = nil then + GridRow := TGridRow.Create(True); + GridRow.Add(GridValue); + Value := ''; + end; + + procedure AddRow; + begin + Inc(RowNum); + GridRows.Add(GridRow); + GridRow := TGridRow.Create(True); + end; + +begin + // Scan user selected file for column types + TimerStartScan.Enabled := False; + Screen.Cursor := crHourGlass; + btnScan.ImageIndex := 150; + btnScan.Enabled := False; + btnSave.Enabled := False; + // Parse contents to a TGridRows instance + GridRows := TGridRows.Create(True); + GridRow := nil; + Term := FConnection.UnescapeString(FLoadDataFrm.editFieldTerminator.Text); + Encl := FConnection.UnescapeString(FLoadDataFrm.editFieldEncloser.Text); + LineTerm := FConnection.UnescapeString(FLoadDataFrm.editLineTerminator.Text); + Escp := FConnection.UnescapeString(FLoadDataFrm.editFieldEscaper.Text); + RowNum := 0; + + TermLen := Length(Term); + EnclLen := Length(Encl); + LineTermLen := Length(LineTerm); + + SetLength(TermTest, TermLen); + SetLength(EnclTest, EnclLen); + SetLength(LineTermTest, LineTermLen); + + InEncl := False; + + try + MainForm.ShowStatusMsg(f_('Reading textfile (%s) ...', [FormatByteNumber(TestChunkSize)])); + Encoding := FLoadDataFrm.FileEncoding; + OpenTextfile(FLoadDataFrm.editFilename.Text, Stream, Encoding); + Contents := ReadTextfileChunk(Stream, Encoding, TestChunkSize); + Stream.Free; + ContentLen := Length(Contents); + MainForm.ShowStatusMsg; + + P := 0; + ProgressCharsPerStep := ContentLen div FLoadDataFrm.ProgressBarSteps; + ProgressChars := 0; + MainForm.EnableProgress(FLoadDataFrm.ProgressBarSteps); + IgnoreLines := FLoadDataFrm.updownIgnoreLines.Position; + NextChar; + + while P <= ContentLen do begin + // Check characters left-side from current position + IsEncl := TestLeftChars(EnclTest, Encl, EnclLen); + IsTerm := TestLeftChars(TermTest, Term, TermLen); + IsLineTerm := TestLeftChars(LineTermTest, LineTerm, LineTermLen); + IsEof := P = ContentLen; + + Value := Value + Contents[P]; + + if IsEncl then + InEncl := not InEncl; + + if IsEof or (not InEncl) then begin + if IsLineTerm then begin + SetLength(Value, Length(Value)-LineTermLen); + AddValue; + end else if IsEof then begin + AddValue; + end else if IsTerm then begin + SetLength(Value, Length(Value)-TermLen); + AddValue; + end; + end; + + if IsLineTerm and (not InEncl) then + AddRow; + + NextChar; + end; + + Contents := ''; + + // Find matching column types for values + Columns := DetectColumnAttributes(GridRows, IgnoreLines); + SynMemoCreateTable.Text := ComposeCreateStatement(Columns); + btnSave.Enabled := True; + except + on E:EFOpenError do + ErrorDialog(E.Message); + end; + GridRows.Free; + + MainForm.ShowStatusMsg; + MainForm.DisableProgress; + btnScan.ImageIndex := -1; + btnScan.Enabled := True; + Screen.Cursor := crDefault; +end; + + +function TfrmCsvDetector.DetectColumnAttributes(Rows: TGridRows; IgnoreLines: Integer): TTableColumnList; +var + Row: TGridRow; + Value: TGridValue; + Col, UnknownColumn: TTableColumn; + i, j, k: Integer; + UnknownTypeYet, IsInteger, IsFloat, IsDate, IsDatetime, IsText: Boolean; + ValueSize, TypeSize: Int64; + FloatValue: Extended; + LoopType: TDBDatatype; +const + FloatChars = ['0'..'9', '.']; +begin + MainForm.ShowStatusMsg(f_('Analyzing %s rows...', [FormatNumber(Rows.Count)])); + MainForm.EnableProgress(Rows.Count); + Result := TTableColumnList.Create; + + for Row in Rows do begin + for Value in Row do begin + Col := TTableColumn.Create(FConnection); + if IgnoreLines > 0 then + Col.Name := FConnection.CleanIdent(Value.OldText) + else + Col.Name := 'col_'+Row.IndexOf(Value).ToString; + Col.DataType := FConnection.Datatypes[0]; // UNKNOWN by default + Col.AllowNull := False; // Make True as soon as we encounter NULL or empty strings in the values + Col.Unsigned := False; // No detection for unsigned types + Col.LengthSet := ''; + Result.Add(Col); + end; + Break; + end; + + UnknownColumn := TTableColumn.Create(FConnection); + for i:=IgnoreLines to Rows.Count-1 do begin + MainForm.ProgressStep; + for j:=0 to Rows[i].Count-1 do begin + Value := Rows[i][j]; + if j >= Result.Count then + Col := UnknownColumn + else + Col := Result[j]; + + // Detect data type of current value + + IsInteger := IntToStr(StrToInt64Def(Value.OldText, -1)) = Value.OldText; + + FloatValue := StrToFloatDef(Value.OldText, -1, MainForm.FormatSettings); + IsFloat := Value.OldText.Contains('.'); + if IsFloat then begin + for k:=1 to Length(Value.OldText) do begin + IsFloat := IsFloat and CharInSet(Value.OldText[k], FloatChars); + if not IsFloat then + Break; + end; + end; + + { Using StrToDateTimeDef allows values like '2020-12-08 foo' + IsDate := (not IsInteger) and (not IsFloat) + and (StrToDateDef(Value.OldText, MaxDateTime) <> MaxDateTime); + IsDatetime := (not IsInteger) and (not IsFloat) + and (StrToDateTimeDef(Value.OldText, MaxDateTime) <> MaxDateTime);} + IsDate := (not IsInteger) and (not IsFloat) + and ExecRegExpr('^\d{4}-\d{2}-\d{2}$', Value.OldText); + IsDatetime := (not IsInteger) and (not IsFloat) + and ExecRegExpr('^\d{4}-\d{2}-\d{2}\s\d{2}:\d{2}:\d{2}$', Value.OldText); + + IsText := (not IsInteger) and (not IsFloat) and (not IsDate) and (not IsDatetime); + + ValueSize := IfThen(IsInteger, StrToInt64Def(Value.OldText, -1), Length(Value.OldText)); + + //MainForm.LogSQL(Format('Value:"%s" IsInteger:%d IsFloat:%d IsDate:%d IsDateTime:%d IsText:%d', + // [Value.OldText, IsInteger.ToInteger, IsFloat.ToInteger, IsDate.ToInteger, IsDatetime.ToInteger, IsText.ToInteger]), lcDebug); + + // Now, find a fitting data type for this column + + for k:=Low(FConnection.Datatypes) to High(FConnection.Datatypes) do begin + + LoopType := FConnection.Datatypes[k]; + UnknownTypeYet := Col.DataType.Index = dbdtUnknown; + if (ValueSize = 0) or (CompareText(Value.OldText, 'null')=0) or (CompareText(Value.OldText, '\N')=0) then + Col.AllowNull := True; + + // Integer types + if (LoopType.Category = dtcInteger) and IsInteger and (UnknownTypeYet or (Col.DataType.Category = dtcInteger)) then begin + if (ValueSize > Col.DataType.MaxSize) and (ValueSize <= LoopType.MaxSize) + then begin + Col.DataType := LoopType; + end; + end; + + // Float types + if (LoopType.Category = dtcReal) and IsFloat and (UnknownTypeYet or (Col.DataType.Category = dtcReal)) then begin + if (ValueSize > Col.DataType.MaxSize) and (ValueSize <= LoopType.MaxSize) + then begin + Col.DataType := LoopType; + if LoopType.RequiresLength then + Col.LengthSet := LoopType.DefLengthSet; + end; + end; + + // Datetime type + if IsDatetime and (UnknownTypeYet or (Col.DataType.Index in [dbdtDate, dbdtDatetime])) and (LoopType.Index = dbdtDatetime) then begin + Col.DataType := LoopType; + end; + // Date type + if IsDate and (UnknownTypeYet or (Col.DataType.Index = dbdtDate)) and (LoopType.Index = dbdtDate) then begin + Col.DataType := LoopType; + end; + + // Text types - fall back here if nothing else matches + if (LoopType.Category = dtcText) and IsText then begin + if ((not Col.LengthSet.IsEmpty) and (ValueSize > StrToInt64Def(Col.LengthSet, 0))) + or ((ValueSize > Col.DataType.MaxSize) and (ValueSize <= LoopType.MaxSize)) + or (Col.DataType.Category <> LoopType.Category) + then begin + if Col.DataType.Index <> LoopType.Index then begin + MainForm.LogSQL('Preferring '+LoopType.Name+' type over '+Col.DataType.Name+' for '+col.Name+' due to value "'+Value.OldText+'"', lcDebug); + end; + + Col.DataType := LoopType; + if Col.DataType.RequiresLength then begin + TypeSize := Max(ValueSize, 1); + TypeSize := System.Math.Ceil(TypeSize / 10) * 10; + Col.LengthSet := Min(TypeSize, LoopType.MaxSize).ToString; + end else + Col.LengthSet := ''; + end; + end; + + end; + end; + //break; + end; + +end; + + +function TfrmCsvDetector.ComposeCreateStatement(Columns: TTableColumnList): String; +var + Col: TTableColumn; + TableName: String; +begin + // Compose CREATE TABLE + TableName := TPath.GetFileNameWithoutExtension(FLoadDataFrm.editFilename.Text); + TableName := FConnection.CleanIdent(TableName); + Result := 'CREATE TABLE '+FConnection.QuoteIdent(FLoadDataFrm.comboDatabase.Text)+'.'+FConnection.QuoteIdent(TableName)+' (' + sLineBreak; + for Col in Columns do begin + Result := Result + CodeIndent + Col.SQLCode; + if Col <> Columns.Last then + Result := Result + ','; + Result := Result + sLineBreak; + end; + Result := Result + ')' + sLineBreak; +end; + + +procedure TfrmCsvDetector.btnSaveClick(Sender: TObject); +var + rx: TRegExpr; + TableName, Quote: String; +begin + // Run code + try + Screen.Cursor := crHourGlass; + FConnection.Query(SynMemoCreateTable.Text); + FConnection.ShowWarnings; + ModalResult := mrOk; + rx := TRegExpr.Create; + rx.ModifierI := True; + Quote := QuoteRegExprMetaChars(FConnection.QuoteChar); + rx.Expression := '^\s*CREATE\s+TABLE\s+' + Quote + '[^'+Quote+']+' + Quote + '.' + Quote + '([^'+Quote+']+)' + Quote; + Mainform.LogSQL(rx.Expression, lcDebug); + if rx.Exec(SynMemoCreateTable.Text) then + TableName := rx.Match[1] + else + TableName := ''; + Mainform.LogSQL(TableName, lcDebug); + FLoadDataFrm.comboTablePopulate(TableName, True); + Screen.Cursor := crDefault; + except + on E:EDbError do begin + Screen.Cursor := crDefault; + ErrorDialog(E.Message); + ModalResult := mrNone; + end; + end; +end; + + +end. diff --git a/source/customize_highlighter.dfm b/source/customize_highlighter.dfm new file mode 100644 index 000000000..7eb0af56a --- /dev/null +++ b/source/customize_highlighter.dfm @@ -0,0 +1,144 @@ +object frmCustomizeHighlighter: TfrmCustomizeHighlighter + Left = 0 + Top = 0 + BorderStyle = bsDialog + Caption = 'Customize highlighter' + ClientHeight = 249 + ClientWidth = 441 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -12 + Font.Name = 'Segoe UI' + Font.Style = [] + Position = poOwnerFormCenter + OnCreate = FormCreate + OnDestroy = FormDestroy + OnShow = FormShow + DesignSize = ( + 441 + 249) + TextHeight = 15 + object lblBackground: TLabel + Left = 159 + Top = 37 + Width = 67 + Height = 15 + Caption = 'Background:' + end + object lblForeground: TLabel + Left = 159 + Top = 65 + Width = 65 + Height = 15 + Caption = 'Foreground:' + end + object lblStyle: TLabel + Left = 159 + Top = 90 + Width = 28 + Height = 15 + Caption = 'Style:' + end + object comboHighlighter: TComboBox + Left = 8 + Top = 8 + Width = 145 + Height = 23 + AutoDropDownWidth = True + Style = csDropDownList + Sorted = True + TabOrder = 0 + OnSelect = comboHighlighterSelect + end + object listboxAttributes: TListBox + Left = 8 + Top = 37 + Width = 145 + Height = 173 + ItemHeight = 15 + TabOrder = 1 + OnClick = listboxAttributesClick + end + object chkBold: TCheckBox + Left = 277 + Top = 90 + Width = 156 + Height = 17 + Anchors = [akLeft, akTop, akRight] + Caption = 'Bold' + TabOrder = 4 + OnClick = Modified + end + object chkItalic: TCheckBox + Left = 277 + Top = 113 + Width = 156 + Height = 17 + Anchors = [akLeft, akTop, akRight] + Caption = 'Italic' + TabOrder = 5 + OnClick = Modified + end + object btnCancel: TButton + Left = 277 + Top = 216 + Width = 75 + Height = 25 + Anchors = [akRight, akBottom] + Cancel = True + Caption = 'Cancel' + ModalResult = 2 + TabOrder = 7 + end + object btnOK: TButton + Left = 196 + Top = 216 + Width = 75 + Height = 25 + Anchors = [akRight, akBottom] + Caption = 'OK' + Default = True + ModalResult = 1 + TabOrder = 6 + OnClick = SaveSettings + end + object editBackground: TButtonedEdit + Left = 277 + Top = 34 + Width = 156 + Height = 23 + Anchors = [akLeft, akTop, akRight] + Images = MainForm.VirtualImageListMain + RightButton.Hint = 'Color picker' + RightButton.ImageIndex = 33 + RightButton.Visible = True + TabOrder = 2 + OnExit = Modified + OnRightButtonClick = editColorRightButtonClick + end + object editForeground: TButtonedEdit + Left = 277 + Top = 62 + Width = 156 + Height = 23 + Anchors = [akLeft, akTop, akRight] + Images = MainForm.VirtualImageListMain + RightButton.Hint = 'Color picker' + RightButton.ImageIndex = 33 + RightButton.Visible = True + TabOrder = 3 + OnExit = Modified + OnRightButtonClick = editColorRightButtonClick + end + object btnApply: TButton + Left = 358 + Top = 216 + Width = 75 + Height = 25 + Anchors = [akRight, akBottom] + Caption = 'Apply' + TabOrder = 8 + OnClick = SaveSettings + end +end diff --git a/source/customize_highlighter.pas b/source/customize_highlighter.pas new file mode 100644 index 000000000..930e6af29 --- /dev/null +++ b/source/customize_highlighter.pas @@ -0,0 +1,195 @@ +unit customize_highlighter; + +interface + +uses + Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics, + Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ExtCtrls, Vcl.GraphUtil, System.Math, + System.StrUtils, SynEditHighlighter, gnugettext, apphelpers, extra_controls; + +type + TfrmCustomizeHighlighter = class(TExtForm) + comboHighlighter: TComboBox; + listboxAttributes: TListBox; + lblBackground: TLabel; + lblForeground: TLabel; + lblStyle: TLabel; + chkBold: TCheckBox; + chkItalic: TCheckBox; + btnCancel: TButton; + btnOK: TButton; + editBackground: TButtonedEdit; + editForeground: TButtonedEdit; + btnApply: TButton; + procedure listboxAttributesClick(Sender: TObject); + procedure FormCreate(Sender: TObject); + procedure comboHighlighterSelect(Sender: TObject); + procedure SaveSettings(Sender: TObject); + procedure editColorRightButtonClick(Sender: TObject); + procedure Modified(Sender: TObject); + procedure FormDestroy(Sender: TObject); + procedure FormShow(Sender: TObject); + private + { Private-Deklarationen } + FHighlighter: TSynCustomHighlighter; + FAttr: TSynHighlighterAttributes; + FOnChange: TNotifyEvent; + procedure SetFriendlyLanguageName(FriendlyLanguageName: String); + function GetFriendlyLanguageName: String; + public + { Public-Deklarationen } + property FriendlyLanguageName: String read GetFriendlyLanguageName write SetFriendlyLanguageName; + property OnChange: TNotifyEvent read FOnChange write FOnChange; + end; + + +implementation + +uses main; + +{$R *.dfm} + +procedure TfrmCustomizeHighlighter.SaveSettings(Sender: TObject); +begin + // Save highlighter settings + FHighlighter.SaveToFile(AppSettings.DirnameHighlighters + FHighlighter.LanguageName + '.ini'); + if Assigned(FOnChange) then + FOnChange(Self); +end; + +procedure TfrmCustomizeHighlighter.Modified(Sender: TObject); +begin + // Apply modification to current attribute + // Silence exception caused by invalid color strings + FAttr.Background := WebColorStrToColorDef(editBackground.Text, clNone); + FAttr.Foreground := WebColorStrToColorDef(editForeground.Text, clNone); + if chkBold.Checked then + FAttr.Style := FAttr.Style + [fsBold] + else + FAttr.Style := FAttr.Style - [fsBold]; + if chkItalic.Checked then + FAttr.Style := FAttr.Style + [fsItalic] + else + FAttr.Style := FAttr.Style - [fsItalic]; +end; + +procedure TfrmCustomizeHighlighter.comboHighlighterSelect(Sender: TObject); +var + i: Integer; + Highlighters: TSynHighlighterList; +begin + // Highlighter selected + listboxAttributes.Clear; + if Assigned(FHighlighter) then + FHighlighter.Free; + Highlighters := SynEditHighlighter.GetPlaceableHighlighters; + for i:=0 to Highlighters.Count-1 do begin + if Highlighters[i].GetFriendlyLanguageName = comboHighlighter.Text then begin + FHighlighter := Highlighters[i].Create(Self); + Break; + end; + end; + FHighlighter.LoadFromFile(AppSettings.DirnameHighlighters + FHighlighter.GetLanguageName + '.ini'); + for i:=0 to FHighlighter.AttrCount-1 do begin + listboxAttributes.Items.Add(FHighlighter.Attribute[i].FriendlyName); + end; +end; + +procedure TfrmCustomizeHighlighter.editColorRightButtonClick( + Sender: TObject); +var + Dialog: TColorDialog; + Edit: TButtonedEdit; +begin + // Color picker + Edit := Sender as TButtonedEdit; + Dialog := TColorDialog.Create(Self); + Dialog.Options := [cdFullOpen, cdAnyColor]; + Dialog.Color := WebColorStrToColorDef(Edit.Text, clNone); + if Dialog.Execute then begin + Edit.Text := ColorToWebColorStr(Dialog.Color); + end; + Dialog.Free; + Modified(Sender); +end; + +procedure TfrmCustomizeHighlighter.FormCreate(Sender: TObject); +var + Highlighters: TSynHighlighterList; + i: Integer; +begin + // Form created + FHighlighter := nil; + FAttr := nil; + FOnChange := nil; + Highlighters := SynEditHighlighter.GetPlaceableHighlighters; + for i:=0 to Highlighters.Count-1 do begin + comboHighlighter.Items.Add(Highlighters[i].GetFriendlyLanguageName); + end; +end; + +procedure TfrmCustomizeHighlighter.FormDestroy(Sender: TObject); +begin + // Form destroyed + if Assigned(FHighlighter) then + FHighlighter.Free; + // causes an exception when closing: + //if Assigned(FAttr) then + // FAttr.Free; +end; + +procedure TfrmCustomizeHighlighter.FormShow(Sender: TObject); +begin + // Ensure controls are disabled as long as no attribute is selected + listboxAttributes.OnClick(Sender); +end; + +procedure TfrmCustomizeHighlighter.listboxAttributesClick(Sender: TObject); +var + i: Integer; + AttrSelected: Boolean; +begin + // Attribute selected + FAttr := nil; + if listboxAttributes.ItemIndex > -1 then begin + for i:=0 to FHighlighter.AttrCount-1 do begin + if listboxAttributes.Items[listboxAttributes.ItemIndex] = FHighlighter.Attribute[i].FriendlyName then begin + FAttr := FHighlighter.Attribute[i]; + end; + end; + end; + // Enable/disable controls + AttrSelected := FAttr <> nil; + editBackground.Enabled := AttrSelected; + editForeground.Enabled := AttrSelected; + chkBold.Enabled := AttrSelected; + chkItalic.Enabled := AttrSelected; + // Overtake values + if AttrSelected then begin + editBackground.Text := IfThen(FAttr.Background <> clNone, ColorToWebColorStr(FAttr.Background), ''); + editForeground.Text := IfThen(FAttr.Foreground <> clNone, ColorToWebColorStr(FAttr.Foreground), ''); + chkBold.Checked := fsBold in FAttr.Style; + chkItalic.Checked := fsItalic in FAttr.Style; + end + else begin + editBackground.Text := ''; + editForeground.Text := ''; + chkBold.Checked := False; + chkItalic.Checked := False; + end; +end; + +procedure TfrmCustomizeHighlighter.SetFriendlyLanguageName(FriendlyLanguageName: String); +begin + // Set current highlighter by its language name + comboHighlighter.ItemIndex := comboHighlighter.Items.IndexOf(FriendlyLanguageName); + comboHighlighter.OnSelect(comboHighlighter); +end; + +function TfrmCustomizeHighlighter.GetFriendlyLanguageName: String; +begin + Result := FHighlighter.FriendlyLanguageName; +end; + + +end. diff --git a/source/data_sorting.dfm b/source/data_sorting.dfm index 30247d859..4db51878f 100644 --- a/source/data_sorting.dfm +++ b/source/data_sorting.dfm @@ -1,4 +1,4 @@ -object DataSortingForm: TDataSortingForm +object frmDataSorting: TfrmDataSorting Left = 0 Top = 0 BorderStyle = bsNone @@ -8,15 +8,13 @@ object DataSortingForm: TDataSortingForm Color = clBtnFace Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText - Font.Height = -11 + Font.Height = -12 Font.Name = 'Tahoma' Font.Style = [] - OldCreateOrder = False OnClose = FormClose OnCreate = FormCreate OnDeactivate = FormDeactivate - PixelsPerInch = 96 - TextHeight = 13 + TextHeight = 14 object pnlBevel: TPanel Left = 0 Top = 0 diff --git a/source/data_sorting.pas b/source/data_sorting.pas index 77dcc9ae8..935566134 100644 --- a/source/data_sorting.pas +++ b/source/data_sorting.pas @@ -3,12 +3,12 @@ interface uses - Windows, SysUtils, Classes, Controls, Forms, StdCtrls, ExtCtrls, ComCtrls, Buttons, - Vcl.Graphics, apphelpers, gnugettext, extra_controls; + Winapi.Windows, System.SysUtils, System.Classes, Vcl.Controls, Vcl.Forms, Vcl.StdCtrls, Vcl.ExtCtrls, Vcl.ComCtrls, Vcl.Buttons, + Vcl.Graphics, apphelpers, gnugettext, extra_controls, dbconnection; type - TDataSortingForm = class(TExtForm) + TfrmDataSorting = class(TExtForm) pnlBevel: TPanel; btnOK: TButton; btnCancel: TButton; @@ -23,12 +23,15 @@ TDataSortingForm = class(TExtForm) procedure DisplaySortingControls(Sender: TObject); private { Private declarations } - ColumnNames : TStringList; - OrderColumns : TOrderColArray; - OldOrderClause : String; - procedure comboColumnsChange( Sender: TObject ); - procedure btnOrderClick( Sender: TObject ); - procedure btnDeleteClick( Sender: TObject ); + FColumnNames: TStringList; + FSortItems: TSortItems; + FOldOrderClause: String; + FDeleteTimer: TTimer; + FDeleteButtonPressed: TButton; + procedure DeleteTimerTimer(Sender: TObject); + procedure comboColumnsChange(Sender: TObject); + procedure btnOrderClick(Sender: TObject); + procedure btnDeleteClick(Sender: TObject); procedure Modified; public { Public declarations } @@ -43,18 +46,24 @@ implementation {$R *.dfm} -procedure TDataSortingForm.FormCreate(Sender: TObject); +procedure TfrmDataSorting.FormCreate(Sender: TObject); var i: Integer; begin - ColumnNames := TStringList.Create; + FColumnNames := TStringList.Create; // Take column names from listColumns and add here for i:=0 to Mainform.SelectedTableColumns.Count-1 do begin - ColumnNames.Add(Mainform.SelectedTableColumns[i].Name); + FColumnNames.Add(Mainform.SelectedTableColumns[i].Name); end; - OrderColumns := Mainform.DataGridSortColumns; - OldOrderClause := ComposeOrderClause(OrderColumns); + FSortItems := TSortItems.Create(True); + FSortItems.Assign(MainForm.DataGridSortItems); + FOldOrderClause := FSortItems.ComposeOrderClause(MainForm.ActiveConnection); + + FDeleteTimer := TTimer.Create(Self); + FDeleteTimer.Interval := 100; + FDeleteTimer.Enabled := False; + FDeleteTimer.OnTimer := DeleteTimerTimer; // First creation of controls DisplaySortingControls(Sender); @@ -64,8 +73,9 @@ procedure TDataSortingForm.FormCreate(Sender: TObject); {** Create controls for order columns } -procedure TDataSortingForm.DisplaySortingControls(Sender: TObject); +procedure TfrmDataSorting.DisplaySortingControls(Sender: TObject); var + SortItem: TSortItem; lblNumber: TLabel; btnDelete: TButton; comboColumns: TComboBox; @@ -81,12 +91,12 @@ procedure TDataSortingForm.DisplaySortingControls(Sender: TObject); Components[i].Free; end; - Margin := 3; - MarginBig := Margin * 2; - Width1 := 15; - Width2 := 160; - Width3 := 23; - Width4 := 23; + Margin := ScaleSize(3); + MarginBig := ScaleSize(Margin * 2); + Width1 := ScaleSize(15); + Width2 := ScaleSize(160); + Width3 := ScaleSize(23); + Width4 := ScaleSize(23); // Set initial width to avoid resizing form to 0 TopPos := pnlBevel.BorderWidth + MarginBig; @@ -94,7 +104,8 @@ procedure TDataSortingForm.DisplaySortingControls(Sender: TObject); // Create line with controls for each order column // TODO: disable repaint on every created control. Sending WM_SETREDRAW=0 message creates artefacts. LockWindowUpdate(pnlBevel.Handle); - for i:=0 to Length(OrderColumns)-1 do begin + for i:=0 to FSortItems.Count-1 do begin + SortItem := FSortItems[i]; // 1. Label with number lblNumber := TLabel.Create(self); lblNumber.Parent := pnlBevel; @@ -107,15 +118,15 @@ procedure TDataSortingForm.DisplaySortingControls(Sender: TObject); lblNumber.Caption := IntToStr(i+1) + '.'; lblNumber.Tag := i+1; - // 2. Dropdown with columnnames + // 2. Dropdown with column names comboColumns := TComboBox.Create(self); comboColumns.Parent := pnlBevel; comboColumns.Width := Width2; comboColumns.Left := lblNumber.Left + lblNumber.Width + Margin; comboColumns.Top := TopPos; - comboColumns.Items.Text := ColumnNames.Text; + comboColumns.Items.Text := FColumnNames.Text; comboColumns.Style := csDropDownList; // Not editable - comboColumns.ItemIndex := ColumnNames.IndexOf(OrderColumns[i].ColumnName); + comboColumns.ItemIndex := FColumnNames.IndexOf(SortItem.Column); comboColumns.Tag := i+1; comboColumns.OnChange := comboColumnsChange; lblNumber.Height := comboColumns.Height; @@ -131,7 +142,7 @@ procedure TDataSortingForm.DisplaySortingControls(Sender: TObject); btnOrder.GroupIndex := i+1; // if > 0 enables Down = True btnOrder.Glyph.Transparent := True; btnOrder.Glyph.AlphaFormat := afDefined; - if OrderColumns[i].SortDirection = ORDER_DESC then begin + if SortItem.Order = sioDescending then begin MainForm.VirtualImageListMain.GetBitmap(110, btnOrder.Glyph); btnOrder.Down := True; end else begin @@ -195,12 +206,12 @@ procedure TDataSortingForm.DisplaySortingControls(Sender: TObject); {** Dropdown for column selection was changed } -procedure TDataSortingForm.comboColumnsChange( Sender: TObject ); +procedure TfrmDataSorting.comboColumnsChange( Sender: TObject ); var combo : TComboBox; begin combo := Sender as TComboBox; - OrderColumns[combo.Tag-1].ColumnName := combo.Text; + FSortItems[combo.Tag-1].Column := combo.Text; // Enables OK button Modified; @@ -210,18 +221,18 @@ procedure TDataSortingForm.comboColumnsChange( Sender: TObject ); {** Button for selecting sort-direction was clicked } -procedure TDataSortingForm.btnOrderClick( Sender: TObject ); +procedure TfrmDataSorting.btnOrderClick( Sender: TObject ); var btn: TSpeedButton; begin btn := Sender as TSpeedButton; btn.Glyph := nil; - if OrderColumns[btn.Tag-1].SortDirection = ORDER_ASC then begin + if FSortItems[btn.Tag-1].Order = sioAscending then begin MainForm.VirtualImageListMain.GetBitmap(110, btn.Glyph); - OrderColumns[btn.Tag-1].SortDirection := ORDER_DESC; + FSortItems[btn.Tag-1].Order := sioDescending; end else begin MainForm.VirtualImageListMain.GetBitmap(109, btn.Glyph); - OrderColumns[btn.Tag-1].SortDirection := ORDER_ASC; + FSortItems[btn.Tag-1].Order := sioAscending; end; // Enables OK button @@ -232,27 +243,19 @@ procedure TDataSortingForm.btnOrderClick( Sender: TObject ); {** Delete order column } -procedure TDataSortingForm.btnDeleteClick( Sender: TObject ); -var - btn : TButton; - i : Integer; +procedure TfrmDataSorting.btnDeleteClick(Sender: TObject); begin - btn := Sender as TButton; - - if Length(OrderColumns)>1 then - begin - // Move remaining items one up - for i := btn.Tag-1 to Length(OrderColumns) - 2 do - begin - OrderColumns[i] := OrderColumns[i+1]; - end; - end; - // Delete last item - SetLength(OrderColumns, Length(OrderColumns)-1); + FDeleteButtonPressed := Sender as TButton; + FDeleteTimer.Enabled := True; +end; - // Refresh controls - DisplaySortingControls(Sender); +procedure TfrmDataSorting.DeleteTimerTimer(Sender: TObject); +begin + FDeleteTimer.Enabled := False; + FSortItems.Delete(FDeleteButtonPressed.Tag-1); + // Refresh controls + DisplaySortingControls(Self); // Enables OK button Modified; end; @@ -261,32 +264,25 @@ procedure TDataSortingForm.btnDeleteClick( Sender: TObject ); {** Add a new order column } -procedure TDataSortingForm.btnAddColClick(Sender: TObject); +procedure TfrmDataSorting.btnAddColClick(Sender: TObject); var - i, new : Integer; - UnusedColumns : TStringList; + UnusedColumns: TStringList; + NewSortItem, SortItem: TSortItem; begin - SetLength( OrderColumns, Length(OrderColumns)+1 ); - new := Length(OrderColumns)-1; - OrderColumns[new] := TOrderCol.Create; + NewSortItem := FSortItems.AddNew; - // Take first unused column as default for new sort column + // Take first unused column as default for new sort item UnusedColumns := TStringList.Create; - UnusedColumns.AddStrings( ColumnNames ); - for i := 0 to Length(OrderColumns) - 1 do - begin - if UnusedColumns.IndexOf(OrderColumns[i].ColumnName) > -1 then - begin - UnusedColumns.Delete( UnusedColumns.IndexOf(OrderColumns[i].ColumnName) ); - end; + UnusedColumns.AddStrings(FColumnNames); + for SortItem in FSortItems do begin + if UnusedColumns.IndexOf(SortItem.Column) > -1 then + UnusedColumns.Delete(UnusedColumns.IndexOf(SortItem.Column)); end; if UnusedColumns.Count > 0 then - OrderColumns[new].ColumnName := UnusedColumns[0] + NewSortItem.Column := UnusedColumns[0] else - OrderColumns[new].ColumnName := ColumnNames[0]; - - // Sort ASC by default - OrderColumns[new].SortDirection := ORDER_ASC; + NewSortItem.Column := FColumnNames[0]; + MainForm.LogSQL('Created sorting for column '+NewSortItem.Column+'/'+Integer(NewSortItem.Order).ToString+' in TfrmDataSorting.btnAddColClick', lcDebug); // Refresh controls DisplaySortingControls(Sender); @@ -300,25 +296,25 @@ procedure TDataSortingForm.btnAddColClick(Sender: TObject); Gets called when any option has changed. Enables the OK button if ORDER options have changed } -procedure TDataSortingForm.Modified; +procedure TfrmDataSorting.Modified; begin - btnOk.Enabled := ComposeOrderClause(OrderColumns) <> OldOrderClause; + btnOk.Enabled := FSortItems.ComposeOrderClause(MainForm.ActiveConnection) <> FOldOrderClause; end; {** OK clicked: Write ORDER clause to registry } -procedure TDataSortingForm.btnOKClick(Sender: TObject); +procedure TfrmDataSorting.btnOKClick(Sender: TObject); begin // TODO: apply ordering - Mainform.DataGridSortColumns := OrderColumns; + MainForm.DataGridSortItems.Assign(FSortItems); InvalidateVT(Mainform.DataGrid, VTREE_NOTLOADED_PURGECACHE, False); btnCancel.OnClick(Sender); end; -procedure TDataSortingForm.btnCancelClick(Sender: TObject); +procedure TfrmDataSorting.btnCancelClick(Sender: TObject); begin Mainform.tbtnDataSorting.Down := False; Close; @@ -328,7 +324,7 @@ procedure TDataSortingForm.btnCancelClick(Sender: TObject); {** Be sure the form is destroyed after closing. } -procedure TDataSortingForm.FormClose(Sender: TObject; var Action: TCloseAction); +procedure TfrmDataSorting.FormClose(Sender: TObject; var Action: TCloseAction); begin Action := caFree; end; @@ -337,7 +333,7 @@ procedure TDataSortingForm.FormClose(Sender: TObject; var Action: TCloseAction); {** Cancel this dialog if the user clicks elsewhere on mainform } -procedure TDataSortingForm.FormDeactivate(Sender: TObject); +procedure TfrmDataSorting.FormDeactivate(Sender: TObject); begin btnCancel.OnClick(Sender); end; diff --git a/source/dbconnection.pas b/source/dbconnection.pas index 6ef31efee..4cfc0436a 100644 --- a/source/dbconnection.pas +++ b/source/dbconnection.pas @@ -3,9 +3,17 @@ interface uses - Classes, SysUtils, windows, dbstructures, SynRegExpr, Generics.Collections, Generics.Defaults, - DateUtils, Types, Math, Dialogs, ADODB, DB, DBCommon, ComObj, Graphics, ExtCtrls, StrUtils, - gnugettext, AnsiStrings, Controls, Forms, System.IOUtils; + System.Classes, System.SysUtils, Winapi.Windows, System.Generics.Collections, System.Generics.Defaults, + System.DateUtils, System.Types, System.Math, Vcl.Dialogs, Data.Win.ADODB, Data.DB, Data.DBCommon, System.Win.ComObj, Vcl.Graphics, Vcl.ExtCtrls, System.StrUtils, + System.AnsiStrings, Vcl.Controls, Vcl.Forms, System.IOUtils, System.IniFiles, System.Variants, Rtti, + SynRegExpr, gnugettext, generic_types, + dbstructures, dbstructures.mysql, dbstructures.mssql, dbstructures.postgresql, dbstructures.sqlite, dbstructures.interbase, + FireDAC.Stan.Intf, FireDAC.Stan.Option, + FireDAC.Stan.Error, FireDAC.UI.Intf, FireDAC.Phys.Intf, FireDAC.Stan.Def, + FireDAC.Phys, FireDAC.Stan.Pool, FireDAC.Stan.Async, FireDAC.Phys.IB, + FireDAC.Phys.FB, FireDAC.Phys.IBDef, FireDAC.VCLUI.Wait, FireDAC.Comp.Client, + FireDAC.Stan.Param, FireDAC.DatS, FireDAC.DApt.Intf, + FireDAC.DApt, FireDAC.Comp.DataSet; type @@ -21,7 +29,7 @@ TDBQuery = class; TDBQueryList = TObjectList; TDBObject = class; - TColumnPart = (cpAll, cpName, cpType, cpAllowNull, cpDefault, cpVirtuality, cpComment, cpCollation); + TColumnPart = (cpAll, cpName, cpType, cpAllowNull, cpSRID, cpDefault, cpVirtuality, cpComment, cpCollation, cpInvisible); TColumnParts = Set of TColumnPart; TColumnDefaultType = (cdtNothing, cdtText, cdtNull, cdtAutoInc, cdtExpression); // General purpose editing status flag @@ -31,18 +39,19 @@ TDBObject = class; TTableColumn = class(TPersistent) private FConnection: TDBConnection; + FStatus: TEditingStatus; procedure SetStatus(Value: TEditingStatus); public Name, OldName: String; DataType, OldDataType: TDBDatatype; LengthSet: String; - Unsigned, AllowNull, ZeroFill, LengthCustomized: Boolean; + Unsigned, AllowNull, ZeroFill, LengthCustomized, Invisible, Compressed: Boolean; DefaultType: TColumnDefaultType; DefaultText: String; OnUpdateType: TColumnDefaultType; OnUpdateText: String; - Comment, Charset, Collation, Expression, Virtuality: String; - FStatus: TEditingStatus; + Comment, Charset, Collation, GenerationExpression, Virtuality: String; + SRID: Cardinal; constructor Create(AOwner: TDBConnection; Serialized: String=''); destructor Destroy; override; procedure Assign(Source: TPersistent); override; @@ -53,13 +62,17 @@ TTableColumn = class(TPersistent) function CastAsText: String; property Status: TEditingStatus read FStatus write SetStatus; property Connection: TDBConnection read FConnection; + function FullDataType: String; end; PTableColumn = ^TTableColumn; TTableColumnList = class(TObjectList) public - Loaded: Boolean; procedure Assign(Source: TTableColumnList); + function FindByName(const Value: String): TTableColumn; + function HasInvisibleColumns: Boolean; + function QuoteIdents: String; end; + TColumnCache = TDictionary; TTableKey = class(TPersistent) const @@ -68,33 +81,48 @@ TTableKey = class(TPersistent) UNIQUE = 'UNIQUE'; FULLTEXT = 'FULLTEXT'; SPATIAL = 'SPATIAL'; + VECTOR = 'VECTOR'; private FConnection: TDBConnection; + function GetInsideCreateCode: Boolean; function GetImageIndex: Integer; public Name, OldName: String; IndexType, OldIndexType, Algorithm, Comment: String; - Columns, SubParts: TStringList; - Modified, Added: Boolean; + Size: Int64; + Columns, SubParts, Collations: TStringList; + Modified, Added, Visible: Boolean; constructor Create(AOwner: TDBConnection); destructor Destroy; override; procedure Assign(Source: TPersistent); override; + function IsPrimary: Boolean; + function IsIndex: Boolean; + function IsUnique: Boolean; + function IsFulltext: Boolean; + function IsSpatial: Boolean; + function IsVector: Boolean; + function IsExpression(KeyPart: Integer): Boolean; procedure Modification(Sender: TObject); - function SQLCode: String; + function SQLCode(TableName: String=''): String; + property InsideCreateCode: Boolean read GetInsideCreateCode; property ImageIndex: Integer read GetImageIndex; + property Connection: TDBConnection read FConnection; end; TTableKeyList = class(TObjectList) public - Loaded: Boolean; procedure Assign(Source: TTableKeyList); + function MaxSize: Int64; + // Retrieve key icon index for a column, or the normal field icon if it has no key + function ImageIndex(ColumnName: String): Integer; end; + TKeyCache = TDictionary; // Helper object to manage foreign keys in a TObjectList TForeignKey = class(TPersistent) private FConnection: TDBConnection; public - KeyName, OldKeyName, ReferenceTable, OnUpdate, OnDelete: String; + KeyName, OldKeyName, Db, ReferenceDb, ReferenceTable, OnUpdate, OnDelete: String; Columns, ForeignColumns: TStringList; Modified, Added, KeyNameWasCustomized: Boolean; constructor Create(AOwner: TDBConnection); @@ -102,12 +130,34 @@ TForeignKey = class(TPersistent) procedure Assign(Source: TPersistent); override; function SQLCode(IncludeSymbolName: Boolean): String; function ReferenceTableObj: TDBObject; + property Connection: TDBConnection read FConnection; end; TForeignKeyList = class(TObjectList) public - Loaded: Boolean; procedure Assign(Source: TForeignKeyList); end; + TForeignKeyCache = TDictionary; + + TCheckConstraint = class(TPersistent) + private + FConnection: TDBConnection; + FName, FCheckClause: String; + FModified, FAdded: Boolean; + public + constructor Create(AOwner: TDBConnection); + procedure Assign(Source: TPersistent); override; + function SQLCode: String; + property Connection: TDBConnection read FConnection; + property Name: String read FName write FName; + property CheckClause: String read FCheckClause write FCheckClause; + property Modified: Boolean read FModified write FModified; + property Added: Boolean read FAdded write FAdded; + end; + TCheckConstraintList = class(TObjectList) + public + procedure Assign(Source: TCheckConstraintList); + end; + TCheckConstraintCache = TDictionary; TRoutineParam = class(TObject) public @@ -121,9 +171,7 @@ TDBObject = class(TPersistent) FCreateCodeLoaded: Boolean; FWasSelected: Boolean; FConnection: TDBConnection; - FTableColumns: TTableColumnList; - FTableKeys: TTableKeyList; - FTableForeignKeys: TForeignKeyList; + FMap: TStringMap; function GetObjType: String; function GetImageIndex: Integer; function GetOverlayImageIndex: Integer; @@ -131,6 +179,7 @@ TDBObject = class(TPersistent) function GetTableColumns: TTableColumnList; function GetTableKeys: TTableKeyList; function GetTableForeignKeys: TForeignKeyList; + function GetTableCheckConstraints: TCheckConstraintList; public // Table options: Name, Schema, Database, Column, Engine, Comment, RowFormat, CreateOptions, Collation: String; @@ -138,10 +187,11 @@ TDBObject = class(TPersistent) Rows, Size, Version, AvgRowLen, MaxDataLen, IndexLen, DataLen, DataFree, AutoInc, CheckSum: Int64; // Routine options: Body, Definer, Returns, DataAccess, Security, ArgTypes: String; - Deterministic: Boolean; + Deterministic, RowsAreExact, IsMaterialized: Boolean; NodeType, GroupType: TListNodeType; constructor Create(OwnerConnection: TDBConnection); + destructor Destroy; procedure Assign(Source: TPersistent); override; procedure UnloadDetails; procedure Drop; @@ -150,9 +200,11 @@ TDBObject = class(TPersistent) function QuotedName(AlwaysQuote: Boolean=True; SeparateSegments: Boolean=True): String; function QuotedDbAndTableName(AlwaysQuote: Boolean=True): String; function QuotedColumn(AlwaysQuote: Boolean=True): String; - function RowCount(Reload: Boolean): Int64; + function SchemaClauseIS(Prefix: String): String; + function RowCount(Reload: Boolean; ForceExact: Boolean=False): Int64; function GetCreateCode: String; overload; function GetCreateCode(RemoveAutoInc, RemoveDefiner: Boolean): String; overload; + function AsStringMap: TStringMap; property ObjType: String read GetObjType; property ImageIndex: Integer read GetImageIndex; property OverlayImageIndex: Integer read GetOverlayImageIndex; @@ -163,6 +215,7 @@ TDBObject = class(TPersistent) property TableColumns: TTableColumnList read GetTableColumns; property TableKeys: TTableKeyList read GetTableKeys; property TableForeignKeys: TForeignKeyList read GetTableForeignKeys; + property TableCheckConstraints: TCheckConstraintList read GetTableCheckConstraints; end; PDBObject = ^TDBObject; TDBObjectList = class(TObjectList) @@ -172,12 +225,15 @@ TDBObjectList = class(TObjectList) FLargestObjectSize: Int64; FLastUpdate: TDateTime; FCollation: String; + FOnlyNodeType: TListNodeType; + FObjectsLoaded: Boolean; public property Database: String read FDatabase; property DataSize: Int64 read FDataSize; property LargestObjectSize: Int64 read FLargestObjectSize; property LastUpdate: TDateTime read FLastUpdate; property Collation: String read FCollation; + property OnlyNodeType: TListNodeType read FOnlyNodeType; end; TDatabaseCache = class(TObjectList); // A list of db object lists, used for caching TDBObjectComparer = class(TComparer) @@ -205,7 +261,7 @@ TGridRow = class(TObjectList) end; TGridRows = class(TObjectList); - // PLink.exe related + // SSH related TProcessPipe = class(TObject) public ReadHandle: THandle; @@ -213,7 +269,7 @@ TProcessPipe = class(TObject) constructor Create; destructor Destroy; override; end; - TPlink = class(TObject) + TSecureShellCmd = class(TObject) private FProcessInfo: TProcessInformation; FInPipe: TProcessPipe; @@ -230,76 +286,88 @@ TPlink = class(TObject) destructor Destroy; override; end; + TSQLFunction = class(TPersistent) + public + Name, Declaration, Category, Description: String; + end; + TSQLFunctionList = class(TObjectList) + private + FOwner: TDBConnection; + FCategories: TStringList; + FNames: TStringList; + public + constructor Create(AOwner: TDBConnection; SQLFunctionsFileOrder: String); + property Categories: TStringList read FCategories; + property Names: TStringList read FNames; + end; { TConnectionParameters and friends } - TNetType = ( - ntMySQL_TCPIP, - ntMySQL_NamedPipe, - ntMySQL_SSHtunnel, - ntMSSQL_NamedPipe, - ntMSSQL_TCPIP, - ntMSSQL_SPX, - ntMSSQL_VINES, - ntMSSQL_RPC, - ntPgSQL_TCPIP, - ntPgSQL_SSHtunnel, - ntSQLite, - ntMySQL_ProxySQLAdmin - ); - TNetTypeGroup = (ngMySQL, ngMSSQL, ngPgSQL, ngSQLite); - TNetGroupLibs = TDictionary; - TConnectionParameters = class(TObject) strict private + FDeleteAfterUse: Boolean; + FLoadedFromSettings: Boolean; FNetType: TNetType; FHostname, FUsername, FPassword, FAllDatabases, FLibraryOrProvider, FComment, FStartupScriptFilename, FSessionPath, FSSLPrivateKey, FSSLCertificate, FSSLCACertificate, FSSLCipher, FServerVersion, - FSSHHost, FSSHUser, FSSHPassword, FSSHPlinkExe, FSSHPrivateKey, + FSSHHost, FSSHUser, FSSHPassword, FSSHExe, FSSHPrivateKey, FIgnoreDatabasePattern: String; - FPort, FSSHPort, FSSHLocalPort, FSSHTimeout, FCounter, FQueryTimeout, FKeepAlive: Integer; - FLoginPrompt, FCompressed, FLocalTimeZone, FFullTableStatus, - FWindowsAuth, FWantSSL, FIsFolder, FCleartextPluginEnabled: Boolean; + FPort, FSSHPort, FSSHLocalPort, FSSHTimeout, FCounter, FQueryTimeout, FKeepAlive, FSSLVerification: Integer; + FSSHActive, FLoginPrompt, FCompressed, FLocalTimeZone, FFullTableStatus, + FWindowsAuth, FWantSSL, FIsFolder, FCleartextPluginEnabled, FForceUnicode: Boolean; FSessionColor: TColor; FLastConnect: TDateTime; - class var FLibraries: TNetGroupLibs; + FLogFileDdl: Boolean; + FLogFileDml: Boolean; + FLogFilePath: String; + class var FLibraries: TNetTypeLibs; function GetImageIndex: Integer; function GetSessionName: String; + function GetAllDatabasesList: TStringList; public constructor Create; overload; constructor Create(SessionRegPath: String); overload; + destructor Destroy; override; procedure SaveToRegistry; + property DeleteAfterUse: Boolean read FDeleteAfterUse write FDeleteAfterUse; function CreateConnection(AOwner: TComponent): TDBConnection; function CreateQuery(Connection: TDbConnection): TDBQuery; function NetTypeName(LongFormat: Boolean): String; - function IsCompatibleToWin10S: Boolean; function GetNetTypeGroup: TNetTypeGroup; + function SshSupport: Boolean; function IsAnyMySQL: Boolean; function IsAnyMSSQL: Boolean; function IsAnyPostgreSQL: Boolean; function IsAnySQLite: Boolean; + function IsAnyInterbase: Boolean; function IsMariaDB: Boolean; - function IsMySQL: Boolean; + function IsMySQL(StrictDetect: Boolean): Boolean; function IsPercona: Boolean; function IsTokudb: Boolean; function IsInfiniDB: Boolean; function IsInfobright: Boolean; function IsProxySQLAdmin: Boolean; + function IsMySQLonRDS: Boolean; function IsAzure: Boolean; function IsMemSQL: Boolean; function IsRedshift: Boolean; + function IsInterbase: Boolean; + function IsFirebird: Boolean; property ImageIndex: Integer read GetImageIndex; function GetLibraries: TStringList; function DefaultLibrary: String; + function DefaultHost: String; function DefaultPort: Integer; function DefaultUsername: String; function DefaultIgnoreDatabasePattern: String; + function DefaultSshActive: Boolean; + function GetExternalCliArguments(Connection: TDBConnection; ReplacePassword: TThreeStateBoolean): String; published property IsFolder: Boolean read FIsFolder write FIsFolder; property NetType: TNetType read FNetType write FNetType; property NetTypeGroup: TNetTypeGroup read GetNetTypeGroup; property ServerVersion: String read FServerVersion write FServerVersion; - property Counter: Integer read FCounter; + property Counter: Integer read FCounter write FCounter; property LastConnect: TDateTime read FLastConnect; property SessionPath: String read FSessionPath write FSessionPath; property SessionName: String read GetSessionName; @@ -311,7 +379,9 @@ TConnectionParameters = class(TObject) property LoginPrompt: Boolean read FLoginPrompt write FLoginPrompt; property WindowsAuth: Boolean read FWindowsAuth write FWindowsAuth; property CleartextPluginEnabled: Boolean read FCleartextPluginEnabled write FCleartextPluginEnabled; + property ForceUnicode: Boolean read FForceUnicode write FForceUnicode; property AllDatabasesStr: String read FAllDatabases write FAllDatabases; + property AllDatabasesList: TStringList read GetAllDatabasesList; property LibraryOrProvider: String read FLibraryOrProvider write FLibraryOrProvider; property Comment: String read FComment write FComment; property StartupScriptFilename: String read FStartupScriptFilename write FStartupScriptFilename; @@ -320,6 +390,7 @@ TConnectionParameters = class(TObject) property Compressed: Boolean read FCompressed write FCompressed; property LocalTimeZone: Boolean read FLocalTimeZone write FLocalTimeZone; property FullTableStatus: Boolean read FFullTableStatus write FFullTableStatus; + property SSHActive: Boolean read FSSHActive write FSSHActive; property SSHHost: String read FSSHHost write FSSHHost; property SSHPort: Integer read FSSHPort write FSSHPort; property SSHUser: String read FSSHUser write FSSHUser; @@ -327,13 +398,17 @@ TConnectionParameters = class(TObject) property SSHTimeout: Integer read FSSHTimeout write FSSHTimeout; property SSHPrivateKey: String read FSSHPrivateKey write FSSHPrivateKey; property SSHLocalPort: Integer read FSSHLocalPort write FSSHLocalPort; - property SSHPlinkExe: String read FSSHPlinkExe write FSSHPlinkExe; + property SSHExe: String read FSSHExe write FSSHExe; property WantSSL: Boolean read FWantSSL write FWantSSL; property SSLPrivateKey: String read FSSLPrivateKey write FSSLPrivateKey; property SSLCertificate: String read FSSLCertificate write FSSLCertificate; property SSLCACertificate: String read FSSLCACertificate write FSSLCACertificate; property SSLCipher: String read FSSLCipher write FSSLCipher; + property SSLVerification: Integer read FSSLVerification write FSSLVerification; property IgnoreDatabasePattern: String read FIgnoreDatabasePattern write FIgnoreDatabasePattern; + property LogFileDdl: Boolean read FLogFileDdl write FLogFileDdl; + property LogFileDml: Boolean read FLogFileDml write FLogFileDml; + property LogFilePath: String read FLogFilePath write FLogFilePath; end; PConnectionParameters = ^TConnectionParameters; @@ -351,15 +426,20 @@ TDBLogItem = class(TObject) TDBLogEvent = procedure(Msg: String; Category: TDBLogCategory=lcInfo; Connection: TDBConnection=nil) of object; TDBEvent = procedure(Connection: TDBConnection; Database: String) of object; TDBDataTypeArray = Array of TDBDataType; - TSQLSpecifityId = (spDatabaseTable, spDatabaseTableId, spDatabaseDrop, - spDbObjectsTable, spDbObjectsCreateCol, spDbObjectsUpdateCol, spDbObjectsTypeCol, - spEmptyTable, spRenameTable, spRenameView, spCurrentUserHost, spLikeCompare, - spAddColumn, spChangeColumn, - spGlobalStatus, spCommandsCounters, spSessionVariables, spGlobalVariables, - spISTableSchemaCol, - spUSEQuery, spKillQuery, spKillProcess, - spFuncLength, spFuncCeil, spFuncLeft, spFuncNow, - spLockedTables); + TFeatureOrRequirement = ( + frSrid, + frTemporalTypesFraction, + frIntegerDisplayWidth, + frColumnDefaultParentheses, + frEditVariables, + frCreateView, + frCreateProcedure, + frCreateFunction, + frCreateTrigger, + frCreateEvent, + frInvisibleColumns, + frCompressedColumns + ); TDBConnection = class(TComponent) private @@ -368,8 +448,8 @@ TDBConnection = class(TComponent) FServerUptime: Integer; FServerDateTimeOnStartup: String; FParameters: TConnectionParameters; - FPlink: TPlink; - FLoginPromptDone: Boolean; + FOwnsParameters: Boolean; + FSecureShellCmd: TSecureShellCmd; FDatabase: String; FAllDatabases: TStringList; FLogPrefix: String; @@ -394,22 +474,33 @@ TDBConnection = class(TComponent) FSessionVariables: TDBQuery; FInformationSchemaObjects: TStringList; FDatabaseCache: TDatabaseCache; + FColumnCache: TColumnCache; + FKeyCache: TKeyCache; + FForeignKeyCache: TForeignKeyCache; + FCheckConstraintCache: TCheckConstraintCache; FCurrentUserHostCombination: String; FAllUserHostCombinations: TStringList; FLockedByThread: TThread; + FStringQuoteChar: Char; FQuoteChar: Char; FQuoteChars: String; FDatatypes: TDBDataTypeArray; FThreadID: Int64; - FSQLSpecifities: Array[TSQLSpecifityId] of String; + FSqlProvider: TSqlProvider; FKeepAliveTimer: TTimer; FFavorites: TStringList; FPrefetchResults: TDBQueryList; FForeignKeyQueriesFailed: Boolean; FInfSch: String; FIdentCharsNoQuote: TSysCharSet; + FMaxRowsPerInsert: Int64; + FCaseSensitivity: Integer; + FSQLFunctions: TSQLFunctionList; + FNamedEnums: TStringList; procedure SetActive(Value: Boolean); virtual; abstract; procedure DoBeforeConnect; virtual; + procedure StartSSHTunnel(var FinalHost: String; var FinalPort: Integer); + procedure EndSSHTunnel; procedure DoAfterConnect; virtual; procedure DetectUSEQuery(SQL: String); virtual; procedure SetDatabase(Value: String); @@ -422,20 +513,18 @@ TDBConnection = class(TComponent) procedure ApplyIgnoreDatabasePattern(Dbs: TStringList); function GetTableEngines: TStringList; virtual; function GetCollationTable: TDBQuery; virtual; - function GetCollationList: TStringList; + function GetCollationList: TStringList; virtual; function GetCharsetTable: TDBQuery; virtual; function GetCharsetList: TStringList; - function GetInformationSchemaObjects: TStringList; virtual; function GetConnectionUptime: Integer; function GetServerUptime: Integer; function GetServerNow: TDateTime; function GetCurrentUserHostCombination: String; function GetAllUserHostCombinations: TStringList; function DecodeAPIString(a: AnsiString): String; - function GetRowCount(Obj: TDBObject): Int64; virtual; abstract; + function GetRowCount(Obj: TDBObject; ForceExact: Boolean=False): Int64; virtual; procedure ClearCache(IncludeDBObjects: Boolean); procedure FetchDbObjects(db: String; var Cache: TDBObjectList); virtual; abstract; - procedure SetLockedByThread(Value: TThread); virtual; procedure KeepAliveTimerEvent(Sender: TObject); procedure Drop(Obj: TDBObject); virtual; procedure PrefetchResults(SQL: String); @@ -444,18 +533,25 @@ TDBConnection = class(TComponent) public constructor Create(AOwner: TComponent); override; destructor Destroy; override; - procedure Query(SQL: String; DoStoreResult: Boolean=False; LogCategory: TDBLogCategory=lcSQL); virtual; abstract; + procedure Query(SQL: String; DoStoreResult: Boolean=False; LogCategory: TDBLogCategory=lcSQL); overload; virtual; + procedure Query(QueryId: TQueryId); overload; + procedure Query(QueryId: TQueryId; const Args: array of const); overload; procedure Log(Category: TDBLogCategory; Msg: String); - function EscapeString(Text: String; ProcessJokerChars: Boolean=False; DoQuote: Boolean=True): String; + function EscapeString(Text: String; ProcessJokerChars: Boolean=False; DoQuote: Boolean=True): String; overload; + function EscapeString(Text: String; Datatype: TDBDatatype): String; overload; + function EscapeBin(BinValue: String): String; overload; + function EscapeBin(var ByteData: TBytes): String; overload; function QuoteIdent(Identifier: String; AlwaysQuote: Boolean=True; Glue: Char=#0): String; function DeQuoteIdent(Identifier: String; Glue: Char=#0): String; + function CleanIdent(Identifier: String): String; function QuotedDbAndTableName(DB, Obj: String): String; function FindObject(DB, Obj: String): TDBObject; function escChars(const Text: String; EscChar, Char1, Char2, Char3, Char4: Char): String; function UnescapeString(Text: String): String; function ExtractLiteral(var SQL: String; Prefix: String): String; function GetResults(SQL: String): TDBQuery; - function GetCol(SQL: String; Column: Integer=0): TStringList; + // Query one column and return as StringList. Creates Name/Value pairs if NameColumn is 0 or greater. + function GetCol(SQL: String; ValueColumn: Integer=0; NameColumn: Integer=-1): TStringList; function GetVar(SQL: String; Column: Integer=0): String; overload; function GetVar(SQL: String; Column: String): String; overload; function Ping(Reconnect: Boolean): Boolean; virtual; abstract; @@ -463,7 +559,7 @@ TDBConnection = class(TComponent) function GetDBObjects(db: String; Refresh: Boolean=False; OnlyNodeType: TListNodeType=lntNone): TDBObjectList; function DbObjectsCached(db: String): Boolean; function ParseDateTime(Str: String): TDateTime; - function GetKeyColumns(Columns: TTableColumnList; Keys: TTableKeyList): TStringList; + function GetKeyColumns(Columns: TTableColumnList; Keys: TTableKeyList): TTableColumnList; function ConnectionInfo: TStringList; virtual; function GetLastResults: TDBQueryList; virtual; function GetCreateCode(Obj: TDBObject): String; virtual; @@ -471,9 +567,6 @@ TDBConnection = class(TComponent) function GetSessionVariables(Refresh: Boolean): TDBQuery; function GetSessionVariable(VarName: String; DefaultValue: String=''; Refresh: Boolean=False): String; function MaxAllowedPacket: Int64; virtual; - function GetSQLSpecifity(Specifity: TSQLSpecifityId): String; overload; - function GetSQLSpecifity(Specifity: TSQLSpecifityId; const Args: array of const): String; overload; - function ExplainAnalyzer(SQL, DatabaseName: String): Boolean; virtual; function GetDateTimeValue(Input: String; Datatype: TDBDatatypeIndex): String; procedure ClearDbObjects(db: String); procedure ClearAllDbObjects; @@ -486,6 +579,7 @@ TDBConnection = class(TComponent) function ApplyLimitClause(QueryType, QueryBody: String; Limit, Offset: Int64): String; function LikeClauseTail: String; property Parameters: TConnectionParameters read FParameters write FParameters; + property OwnsParameters: Boolean read FOwnsParameters write FOwnsParameters; property ThreadId: Int64 read GetThreadId; property ConnectionUptime: Integer read GetConnectionUptime; property ServerUptime: Integer read GetServerUptime; @@ -495,6 +589,12 @@ TDBConnection = class(TComponent) property LastErrorMsg: String read GetLastErrorMsg; property ServerOS: String read FServerOS; property ServerVersionUntouched: String read FServerVersionUntouched; + property ColumnCache: TColumnCache read FColumnCache; + property KeyCache: TKeyCache read FKeyCache; + property ForeignKeyCache: TForeignKeyCache read FForeignKeyCache; + property CheckConstraintCache: TCheckConstraintCache read FCheckConstraintCache; + property StringQuoteChar: Char read FStringQuoteChar; + property QuoteChar: Char read FQuoteChar; property QuoteChars: String read FQuoteChars; function ServerVersionStr: String; function ServerVersionInt: Integer; @@ -502,6 +602,7 @@ TDBConnection = class(TComponent) property RowsFound: Int64 read FRowsFound; property RowsAffected: Int64 read FRowsAffected; property WarningCount: Cardinal read FWarningCount; + procedure ShowWarnings; virtual; property LastQueryDuration: Cardinal read FLastQueryDuration; property LastQueryNetworkDuration: Cardinal read FLastQueryNetworkDuration; property IsUnicode: Boolean read FIsUnicode; @@ -513,11 +614,12 @@ TDBConnection = class(TComponent) property CollationList: TStringList read GetCollationList; property CharsetTable: TDBQuery read GetCharsetTable; property CharsetList: TStringList read GetCharsetList; - property InformationSchemaObjects: TStringList read GetInformationSchemaObjects; + property InformationSchemaObjects: TStringList read FInformationSchemaObjects; function ResultCount: Integer; property CurrentUserHostCombination: String read GetCurrentUserHostCombination; property AllUserHostCombinations: TStringList read GetAllUserHostCombinations; - property LockedByThread: TThread read FLockedByThread write SetLockedByThread; + function IsLockedByThread: Boolean; + procedure SetLockedByThread(Value: TThread); virtual; property Datatypes: TDBDataTypeArray read FDatatypes; property Favorites: TStringList read FFavorites; property InfSch: String read FInfSch; @@ -526,6 +628,15 @@ TDBConnection = class(TComponent) function GetTableColumns(Table: TDBObject): TTableColumnList; virtual; function GetTableKeys(Table: TDBObject): TTableKeyList; virtual; function GetTableForeignKeys(Table: TDBObject): TForeignKeyList; virtual; + function GetTableCheckConstraints(Table: TDBObject): TCheckConstraintList; virtual; + property MaxRowsPerInsert: Int64 read FMaxRowsPerInsert; + property SQLFunctions: TSQLFunctionList read FSQLFunctions; + function IsNumeric(Text: String): Boolean; + function IsHex(Text: String): Boolean; + function Has(Item: TFeatureOrRequirement): Boolean; + property SqlProvider: TSqlProvider read FSqlProvider; + property NamedEnums: TStringList read FNamedEnums; + procedure GetColumnDefaultExpressions(Items: TStrings); virtual; published property Active: Boolean read FActive write SetActive default False; property Database: String read FDatabase write SetDatabase; @@ -548,6 +659,7 @@ TMySQLConnection = class(TDBConnection) FLastRawResults: TMySQLRawResults; FStatementNum: Cardinal; procedure SetActive(Value: Boolean); override; + procedure SetOption(Option: Integer; Arg: Pointer); procedure DoBeforeConnect; override; procedure DoAfterConnect; override; function GetThreadId: Int64; override; @@ -557,12 +669,8 @@ TMySQLConnection = class(TDBConnection) function GetLastErrorMsg: String; override; function GetAllDatabases: TStringList; override; function GetTableEngines: TStringList; override; - function GetCollationTable: TDBQuery; override; - function GetCharsetTable: TDBQuery; override; function GetCreateViewCode(Database, Name: String): String; - function GetRowCount(Obj: TDBObject): Int64; override; procedure FetchDbObjects(db: String; var Cache: TDBObjectList); override; - procedure SetLockedByThread(Value: TThread); override; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; @@ -573,9 +681,10 @@ TMySQLConnection = class(TDBConnection) function GetCreateCode(Obj: TDBObject): String; override; property LastRawResults: TMySQLRawResults read FLastRawResults; function MaxAllowedPacket: Int64; override; - function ExplainAnalyzer(SQL, DatabaseName: String): Boolean; override; function GetTableColumns(Table: TDBObject): TTableColumnList; override; function GetTableKeys(Table: TDBObject): TTableKeyList; override; + procedure ShowWarnings; override; + procedure SetLockedByThread(Value: TThread); override; end; TAdoRawResults = Array of _RecordSet; @@ -590,10 +699,6 @@ TAdoDBConnection = class(TDBConnection) function GetLastErrorCode: Cardinal; override; function GetLastErrorMsg: String; override; function GetAllDatabases: TStringList; override; - function GetCollationTable: TDBQuery; override; - function GetCharsetTable: TDBQuery; override; - function GetInformationSchemaObjects: TStringList; override; - function GetRowCount(Obj: TDBObject): Int64; override; procedure FetchDbObjects(db: String; var Cache: TDBObjectList); override; public constructor Create(AOwner: TComponent); override; @@ -617,12 +722,12 @@ TPgConnection = class(TDBConnection) FRegClasses: TOidStringPairs; procedure SetActive(Value: Boolean); override; procedure DoBeforeConnect; override; + procedure DoAfterConnect; override; function GetThreadId: Int64; override; procedure SetCharacterSet(CharsetName: String); override; function GetLastErrorCode: Cardinal; override; function GetLastErrorMsg: String; override; function GetAllDatabases: TStringList; override; - function GetCharsetTable: TDBQuery; override; procedure FetchDbObjects(db: String; var Cache: TDBObjectList); override; procedure Drop(Obj: TDBObject); override; public @@ -631,11 +736,10 @@ TPgConnection = class(TDBConnection) property Lib: TPostgreSQLLib read FLib; procedure Query(SQL: String; DoStoreResult: Boolean=False; LogCategory: TDBLogCategory=lcSQL); override; function Ping(Reconnect: Boolean): Boolean; override; + function GetCreateCode(Obj: TDBObject): String; override; function ConnectionInfo: TStringList; override; - function GetRowCount(Obj: TDBObject): Int64; override; property LastRawResults: TPGRawResults read FLastRawResults; property RegClasses: TOidStringPairs read FRegClasses; - function GetTableColumns(Table: TDBObject): TTableColumnList; override; function GetTableKeys(Table: TDBObject): TTableKeyList; override; function GetTableForeignKeys(Table: TDBObject): TForeignKeyList; override; end; @@ -662,7 +766,6 @@ TSQLiteConnection = class(TDBConnection) function GetLastErrorCode: Cardinal; override; function GetLastErrorMsg: String; override; function GetAllDatabases: TStringList; override; - function GetCharsetTable: TDBQuery; override; procedure FetchDbObjects(db: String; var Cache: TDBObjectList); override; public constructor Create(AOwner: TComponent); override; @@ -671,11 +774,42 @@ TSQLiteConnection = class(TDBConnection) procedure Query(SQL: String; DoStoreResult: Boolean=False; LogCategory: TDBLogCategory=lcSQL); override; function Ping(Reconnect: Boolean): Boolean; override; function GetCreateCode(Obj: TDBObject): String; override; - function GetRowCount(Obj: TDBObject): Int64; override; property LastRawResults: TSQLiteRawResults read FLastRawResults; function GetTableColumns(Table: TDBObject): TTableColumnList; override; function GetTableKeys(Table: TDBObject): TTableKeyList; override; function GetTableForeignKeys(Table: TDBObject): TForeignKeyList; override; + procedure GetColumnDefaultExpressions(Items: TStrings); override; + end; + + TInterbaseRawResults = Array of TFDQuery; + TIbDrivers = TDictionary; + TFbDrivers = TDictionary; + TInterbaseConnection = class(TDBConnection) + private + FFDHandle: TFDConnection; + FLastError: String; + FLastErrorCode: Integer; + FLastRawResults: TInterbaseRawResults; + class var FIbDrivers: TIbDrivers; + class var FFbDrivers: TFbDrivers; + procedure SetActive(Value: Boolean); override; + procedure DoBeforeConnect; override; + function GetThreadId: Int64; override; + procedure OnFdError(ASender: TObject; AInitiator: TObject; var AException: Exception); + function GetLastErrorCode: Cardinal; override; + function GetLastErrorMsg: String; override; + function GetAllDatabases: TStringList; override; + procedure FetchDbObjects(db: String; var Cache: TDBObjectList); override; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure Query(SQL: String; DoStoreResult: Boolean=False; LogCategory: TDBLogCategory=lcSQL); override; + function Ping(Reconnect: Boolean): Boolean; override; + function GetCreateCode(Obj: TDBObject): String; override; + property LastRawResults: TInterbaseRawResults read FLastRawResults; + function GetTableColumns(Table: TDBObject): TTableColumnList; override; + function GetTableKeys(Table: TDBObject): TTableKeyList; override; + function GetTableForeignKeys(Table: TDBObject): TForeignKeyList; override; end; @@ -704,16 +838,18 @@ TDBQuery = class(TComponent) FDBObject: TDBObject; FFormatSettings: TFormatSettings; procedure SetRecNo(Value: Int64); virtual; abstract; - function ColumnExists(Column: Integer): Boolean; + function ColumnExists(Column: Integer): Boolean; overload; + function ColumnExists(ColumnName: String): Boolean; overload; procedure SetColumnOrgNames(Value: TStringList); procedure SetDBObject(Value: TDBObject); procedure CreateUpdateRow; - function GetKeyColumns: TStringList; + function GetKeyColumns: TTableColumnList; function GridQuery(QueryType, QueryBody: String): String; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure Execute(AddResult: Boolean=False; UseRawResult: Integer=-1); virtual; abstract; + procedure LogMetaInfo(NumResult: Integer); procedure First; procedure Next; function ColumnCount: Integer; @@ -721,9 +857,7 @@ TDBQuery = class(TComponent) function Col(Column: Integer; IgnoreErrors: Boolean=False): String; overload; virtual; abstract; function Col(ColumnName: String; IgnoreErrors: Boolean=False): String; overload; function ColumnLengths(Column: Integer): Int64; virtual; - function HexValue(Column: Integer; IgnoreErrors: Boolean=False): String; overload; - function HexValue(BinValue: String): String; overload; - function HexValue(var ByteData: TBytes): String; overload; + function HexValue(Column: Integer; IgnoreErrors: Boolean=False): String; function DataType(Column: Integer): TDBDataType; function MaxLength(Column: Integer): Int64; function ValueList(Column: Integer): TStringList; @@ -753,6 +887,7 @@ TDBQuery = class(TComponent) function DatabaseName: String; virtual; abstract; function TableName: String; overload; function TableName(Column: Integer): String; overload; virtual; abstract; + function ResultName: String; function QuotedDbAndTableName: String; procedure DiscardModifications; procedure PrepareColumnAttributes; @@ -854,6 +989,27 @@ TSQLiteQuery = class(TDBQuery) function TableName(Column: Integer): String; overload; override; end; + TInterbaseQuery = class(TDBQuery) + private + FConnection: TInterbaseConnection; + FCurrentResults: TFDDataSet; + FRecNoLocal: Integer; + FResultList: TInterbaseRawResults; + procedure SetRecNo(Value: Int64); override; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure Execute(AddResult: Boolean=False; UseRawResult: Integer=-1); override; + function Col(Column: Integer; IgnoreErrors: Boolean=False): String; overload; override; + function ColIsPrimaryKeyPart(Column: Integer): Boolean; override; + function ColIsUniqueKeyPart(Column: Integer): Boolean; override; + function ColIsKeyPart(Column: Integer): Boolean; override; + function IsNull(Column: Integer): Boolean; overload; override; + function HasResult: Boolean; override; + function DatabaseName: String; override; + function TableName(Column: Integer): String; overload; override; + end; + procedure SQLite_CollationNeededCallback(userData:Pointer; ppDb:Psqlite3; eTextRep:integer; zName:PAnsiChar); cdecl; function SQLite_Collation(userData: Pointer; lenA: Integer; strA: PAnsiChar; lenB: Integer; strB: PAnsiChar): Integer; cdecl; @@ -868,6 +1024,8 @@ function mysql_authentication_dialog_ask( exports mysql_authentication_dialog_ask; +var + WarningShownOldOleProvider: Boolean = False; {$I const.inc} @@ -913,9 +1071,9 @@ destructor TProcessPipe.Destroy; -{ TPlink } +{ TSecureShellCmd } -constructor TPlink.Create(Connection: TDBConnection); +constructor TSecureShellCmd.Create(Connection: TDBConnection); begin inherited Create; FConnection := Connection; @@ -925,9 +1083,9 @@ constructor TPlink.Create(Connection: TDBConnection); end; -destructor TPlink.Destroy; +destructor TSecureShellCmd.Destroy; begin - FConnection.Log(lcInfo, f_('Closing plink.exe process #%d ...', [FProcessInfo.dwProcessId])); + FConnection.Log(lcInfo, f_('Closing SSH process #%d ...', [FProcessInfo.dwProcessId])); TerminateProcess(FProcessInfo.hProcess, 0); CloseHandle(FProcessInfo.hProcess); CloseHandle(FProcessInfo.hThread); @@ -938,48 +1096,62 @@ destructor TPlink.Destroy; end; -procedure TPlink.Connect; +procedure TSecureShellCmd.Connect; var - PlinkCmd, PlinkCmdDisplay: String; - OutText, ErrorText, UserInput: String; + SshCmd, SshCmdDisplay, DialogTitle: String; + OutText, ErrorText, AllPipesText, UserInput: String; rx: TRegExpr; StartupInfo: TStartupInfo; ExitCode: LongWord; - Waited, PortChecks: Integer; + PortChecks: Integer; + CheckIntervalMs: Integer; + IsPlink: Boolean; + TimeStartedMs, WaitedMs, WaitedLeftMs, TimeOutMs: Int64; + PlinkVerMajor, PlinkVerMinor, PlinkVerRelease, PlinkVerRevision: Word; begin // Check if local port is open PortChecks := 0; while not PortOpen(FConnection.Parameters.SSHLocalPort) do begin Inc(PortChecks); if PortChecks >= 20 then - raise EDbError.CreateFmt(_('Could not execute PLink: Port %d already in use.'), [FConnection.Parameters.SSHLocalPort]); + raise EDbError.CreateFmt(_('Could not execute SSH command: Port %d already in use.'), [FConnection.Parameters.SSHLocalPort]); FConnection.Log(lcInfo, f_('Port #%d in use. Checking if #%d is available...', [FConnection.Parameters.SSHLocalPort, FConnection.Parameters.SSHLocalPort+1])); FConnection.Parameters.SSHLocalPort := FConnection.Parameters.SSHLocalPort + 1; end; - // Build plink.exe command line + // Build SSH command line // plink bob@domain.com -pw myPassw0rd1 -P 22 -i "keyfile.pem" -L 55555:localhost:3306 - PlinkCmd := FConnection.Parameters.SSHPlinkExe + ' -ssh '; + IsPlink := ExecRegExprI('([pk]link|putty)', FConnection.Parameters.SSHExe); + SshCmd := FConnection.Parameters.SSHExe; + if IsPlink then begin + SshCmd := SshCmd + ' -ssh'; + GetExecutableVersion(FConnection.Parameters.SSHExe, PlinkVerMajor, PlinkVerMinor, PlinkVerRelease, PlinkVerRevision); + if (PlinkVerMajor = 0) and (PlinkVerMinor >= 82) then + SshCmd := SshCmd + ' -legacy-stdio-prompts'; + end; + SshCmd := SshCmd + ' '; if FConnection.Parameters.SSHUser.Trim <> '' then - PlinkCmd := PlinkCmd + FConnection.Parameters.SSHUser.Trim + '@'; + SshCmd := SshCmd + FConnection.Parameters.SSHUser.Trim + '@'; if FConnection.Parameters.SSHHost.Trim <> '' then - PlinkCmd := PlinkCmd + FConnection.Parameters.SSHHost.Trim + SshCmd := SshCmd + FConnection.Parameters.SSHHost.Trim else - PlinkCmd := PlinkCmd + FConnection.Parameters.Hostname; + SshCmd := SshCmd + FConnection.Parameters.Hostname; if FConnection.Parameters.SSHPassword <> '' then begin // Escape double quote with backslash, see issue #261 - PlinkCmd := PlinkCmd + ' -pw "' + StringReplace(FConnection.Parameters.SSHPassword, '"', '\"', [rfReplaceAll]) + '"'; + SshCmd := SshCmd + ' -pw "' + StringReplace(FConnection.Parameters.SSHPassword, '"', '\"', [rfReplaceAll]) + '"'; end; if FConnection.Parameters.SSHPort > 0 then - PlinkCmd := PlinkCmd + ' -P ' + IntToStr(FConnection.Parameters.SSHPort); + SshCmd := SshCmd + IfThen(IsPlink, ' -P ', ' -p ') + IntToStr(FConnection.Parameters.SSHPort); if FConnection.Parameters.SSHPrivateKey <> '' then - PlinkCmd := PlinkCmd + ' -i "' + FConnection.Parameters.SSHPrivateKey + '"'; - PlinkCmd := PlinkCmd + ' -N -L ' + IntToStr(FConnection.Parameters.SSHLocalPort) + ':' + FConnection.Parameters.Hostname + ':' + IntToStr(FConnection.Parameters.Port); + SshCmd := SshCmd + ' -i "' + FConnection.Parameters.SSHPrivateKey + '"'; + if not IsPlink then + SshCmd := SshCmd + ' -o StrictHostKeyChecking=no'; + SshCmd := SshCmd + ' -N -L ' + IntToStr(FConnection.Parameters.SSHLocalPort) + ':' + FConnection.Parameters.Hostname + ':' + IntToStr(FConnection.Parameters.Port); rx := TRegExpr.Create; rx.Expression := '(-pw\s+")[^"]*(")'; - PlinkCmdDisplay := rx.Replace(PlinkCmd, '${1}******${2}', True); - FConnection.Log(lcInfo, f_('Attempt to create plink.exe process, waiting %ds for response ...', [FConnection.Parameters.SSHTimeout])); - FConnection.Log(lcInfo, PlinkCmdDisplay); + SshCmdDisplay := rx.Replace(SshCmd, '${1}******${2}', True); + FConnection.Log(lcInfo, f_('Attempt to create SSH process, waiting %ds for response ...', [FConnection.Parameters.SSHTimeout])); + FConnection.Log(lcInfo, SshCmdDisplay); // Prepare process FillChar(StartupInfo, SizeOf(StartupInfo), 0); @@ -994,7 +1166,7 @@ procedure TPlink.Connect; FillChar(FProcessInfo, SizeOf(FProcessInfo), 0); if not CreateProcess( nil, - PChar(PlinkCmd), + PChar(SshCmd), nil, nil, true, @@ -1003,60 +1175,78 @@ procedure TPlink.Connect; PChar(GetCurrentDir), StartupInfo, FProcessInfo) then begin - ErrorText := CRLF + CRLF + PlinkCmdDisplay + CRLF + CRLF + 'System message: ' + SysErrorMessage(GetLastError); - ErrorText := f_('Could not execute PLink: %s', [ErrorText]); + ErrorText := CRLF + CRLF + SshCmdDisplay + CRLF + CRLF + 'System message: ' + SysErrorMessage(GetLastError); + ErrorText := f_('Could not execute SSH command: %s', [ErrorText]); raise EDbError.Create(ErrorText); end; // Wait until timeout has finished. // Todo: Find a way to wait only until connection is established // Parse pipe output and probably show some message in a dialog. - Waited := 0; - while Waited < FConnection.Parameters.SSHTimeout*1000 do begin - Inc(Waited, 200); - WaitForSingleObject(FProcessInfo.hProcess, 200); + WaitedMs := 0; + DialogTitle := ExtractFileName(FConnection.Parameters.SSHExe); + TimeOutMs := FConnection.Parameters.SSHTimeout * 1000; + CheckIntervalMs := FConnection.Parameters.SSHTimeout * 100; + TimeStartedMs := GetTickCount64; + while WaitedMs < TimeOutMs do begin + WaitForSingleObject(FProcessInfo.hProcess, CheckIntervalMs); + WaitedMs := GetTickCount64 - TimeStartedMs; + // On Wine, WaitForSingleObject does not really seem to wait. See #1771 + WaitedLeftMs := TimeStartedMs + WaitedMs - GetTickCount64; + if WaitedLeftMs > 0 then begin + FConnection.Log(lcDebug, 'Wait additional '+WaitedLeftMs.ToString+'ms (see issue #1771)...'); + Sleep(WaitedLeftMs); + end; GetExitCodeProcess(FProcessInfo.hProcess, ExitCode); - if ExitCode <> STILL_ACTIVE then - raise EDbError.CreateFmt(_('PLink exited unexpected. Command line was: %s'), [CRLF+PlinkCmdDisplay]); + if ExitCode <> STILL_ACTIVE then begin + FConnection.Log(lcError, 'SSH process exited after '+WaitedMs.ToString+'ms with code '+ExitCode.ToString+'. Should be '+STILL_ACTIVE.ToString+' (STILL_ACTIVE)'); + raise EDbError.CreateFmt(_('SSH exited unexpected. Command line was: %s'), [CRLF+SshCmdDisplay]); + end; OutText := Trim(ReadPipe(FOutPipe)); ErrorText := ReadPipe(FErrorPipe); if (OutText <> '') or (ErrorText <> '') then begin - FConnection.Log(lcDebug, Format('PLink output after %d ms. OutPipe: "%s" ErrorPipe: "%s"', [Waited, OutText, ErrorText])); + FConnection.Log(lcDebug, Format('SSH output after %d ms. OutPipe: "%s" ErrorPipe: "%s"', [WaitedMs, OutText, ErrorText])); end; if OutText <> '' then begin + // Prepend error text in the dialog, e.g. "Unable to use keyfile" + AllPipesText := OutText; + if not ErrorText.IsEmpty then begin + FConnection.Log(lcError, 'SSH: '+ErrorText); + AllPipesText := Trim('Error: ' + ErrorText + sLineBreak + AllPipesText); + end; if ExecRegExpr('login as\s*\:', OutText) then begin // Prompt for username - UserInput := InputBox('PLink:', OutText, ''); + UserInput := InputBox(DialogTitle, AllPipesText, ''); SendText(UserInput + CRLF); end else if ExecRegExpr('(password|Passphrase for key "[^"]+")\s*\:', OutText) then begin // Prompt for sensitive input. Send * as first char of prompt param so InputBox hides input characters - UserInput := InputBox('PLink:', #31+OutText, ''); + UserInput := InputBox(DialogTitle, #31+AllPipesText, ''); SendText(UserInput + CRLF); end else begin // Informational message box rx.Expression := '^[^\.]+\.'; if rx.Exec(OutText) then begin // First words end with a dot - use it as caption - MessageDialog('PLink: '+rx.Match[0], OutText, mtInformation, [mbOK]) + MessageDialog(DialogTitle + ': ' + rx.Match[0], AllPipesText, mtInformation, [mbOK]) end else begin - MessageDialog('PLink:', OutText, mtInformation, [mbOK]); + MessageDialog(DialogTitle, AllPipesText, mtInformation, [mbOK]); end; end; - end; + end - if ErrorText <> '' then begin + else if ErrorText <> '' then begin rx.Expression := '([^\.]+\?)(\s*\(y\/n\s*(,[^\)]+)?\)\s*)$'; if rx.Exec(ErrorText) then begin // Prompt user with question case MessageDialog(Trim(rx.Match[1]), Copy(ErrorText, 1, Length(ErrorText)-rx.MatchLen[2]), mtConfirmation, [mbYes, mbNo, mbCancel]) of mrYes: - SendText('y'); + SendText('y'+CRLF); mrNo: - SendText('n'); + SendText('n'+CRLF); mrCancel: begin Destroy; - raise EDbError.Create(_('PLink cancelled')); + raise EDbError.Create(_('SSH command cancelled')); end; end; end else if @@ -1064,7 +1254,7 @@ procedure TPlink.Connect; or ErrorText.StartsWith('Pre-authentication banner ', True) // see issue #704 or ErrorText.StartsWith('Access granted. Press Return to begin session', True) // see issue #1114 then begin - FConnection.Log(lcError, 'PLink: '+ErrorText); + FConnection.Log(lcError, 'SSH: '+ErrorText); SendText(CRLF); end else begin // Any other error message goes here. @@ -1074,18 +1264,19 @@ procedure TPlink.Connect; raise EDbError.Create(ErrorText); end else begin // Just show error text and proceed looping - MessageDialog('PLink:', ErrorText, mtError, [mbOK]); + MessageDialog(DialogTitle, ErrorText, mtError, [mbOK]); end; end; end; - - Application.ProcessMessages; + + // Crashes in TMainForm.DBtreeGetText:12, but most likely not required anyway: + //Application.ProcessMessages; end; rx.Free; end; -function TPlink.ReadPipe(const Pipe: TProcessPipe): String; +function TSecureShellCmd.ReadPipe(const Pipe: TProcessPipe): String; var BufferReadCount, OutLen: Cardinal; BytesRemaining: Cardinal; @@ -1132,25 +1323,25 @@ function TPlink.ReadPipe(const Pipe: TProcessPipe): String; end; -function TPlink.AsciiToAnsi(Text: AnsiString): AnsiString; +function TSecureShellCmd.AsciiToAnsi(Text: AnsiString): AnsiString; const cMaxLength = 255; var PText: PAnsiChar; begin Result := ''; - PText := AnsiStrings.AnsiStrAlloc(cMaxLength); + PText := AnsiStrAlloc(cMaxLength); while Text <> '' do begin - AnsiStrings.StrPCopy(PText, copy(Text, 1, cMaxLength-1)); + System.AnsiStrings.StrPCopy(PText, copy(Text, 1, cMaxLength-1)); OemToAnsi(PText, PText); - Result := Result + AnsiStrings.StrPas(PText); + Result := Result + System.AnsiStrings.StrPas(PText); Delete(Text, 1, cMaxLength-1); end; - AnsiStrings.StrDispose(PText); + System.AnsiStrings.StrDispose(PText); end; -function TPlink.CleanEscSeq(const Buffer: String): String; +function TSecureShellCmd.CleanEscSeq(const Buffer: String): String; var i: Integer; chr: Char; @@ -1194,7 +1385,7 @@ function TPlink.CleanEscSeq(const Buffer: String): String; end; -procedure TPlink.SendText(Text: String); +procedure TSecureShellCmd.SendText(Text: String); var WrittenBytes: Cardinal; TextA: AnsiString; @@ -1214,12 +1405,15 @@ constructor TConnectionParameters.Create; begin inherited Create; FIsFolder := False; + FDeleteAfterUse := False; + FLoadedFromSettings := False; FNetType := TNetType(AppSettings.GetDefaultInt(asNetType)); - FHostname := AppSettings.GetDefaultString(asHost); + FHostname := DefaultHost; FLoginPrompt := AppSettings.GetDefaultBool(asLoginPrompt); FWindowsAuth := AppSettings.GetDefaultBool(asWindowsAuth); FCleartextPluginEnabled := AppSettings.GetDefaultBool(asCleartextPluginEnabled); + FForceUnicode := AppSettings.GetDefaultBool(asForceUnicode); FUsername := DefaultUsername; FPassword := AppSettings.GetDefaultString(asPassword); FPort := DefaultPort; @@ -1228,6 +1422,8 @@ constructor TConnectionParameters.Create; FLibraryOrProvider := DefaultLibrary; FComment := AppSettings.GetDefaultString(asComment); + FSSHActive := DefaultSshActive; + FSSHExe := AppSettings.GetDefaultString(asSshExecutable); FSSHHost := AppSettings.GetDefaultString(asSSHtunnelHost); FSSHPort := AppSettings.GetDefaultInt(asSSHtunnelHostPort); FSSHUser := AppSettings.GetDefaultString(asSSHtunnelUser); @@ -1241,6 +1437,7 @@ constructor TConnectionParameters.Create; FSSLCertificate := AppSettings.GetDefaultString(asSSLCert); FSSLCACertificate := AppSettings.GetDefaultString(asSSLCA); FSSLCipher := AppSettings.GetDefaultString(asSSLCipher); + FSSLVerification := AppSettings.GetDefaultInt(asSSLVerification); FStartupScriptFilename := AppSettings.GetDefaultString(asStartupScriptFilename); FQueryTimeout := AppSettings.GetDefaultInt(asQueryTimeout); FKeepAlive := AppSettings.GetDefaultInt(asKeepAlive); @@ -1249,9 +1446,9 @@ constructor TConnectionParameters.Create; FSessionColor := AppSettings.GetDefaultInt(asTreeBackground); FIgnoreDatabasePattern := DefaultIgnoreDatabasePattern; - - // Must be read without session path - FSSHPlinkExe := AppSettings.ReadString(asPlinkExecutable); + FLogFileDdl := AppSettings.GetDefaultBool(asLogFileDdl); + FLogFileDml := AppSettings.GetDefaultBool(asLogFileDml); + FLogFilePath := AppSettings.GetDefaultString(asLogFilePath); FLastConnect := 0; FCounter := 0; @@ -1278,24 +1475,31 @@ constructor TConnectionParameters.Create(SessionRegPath: String); FSessionColor := AppSettings.ReadInt(asTreeBackground); FNetType := TNetType(AppSettings.ReadInt(asNetType)); if (FNetType > High(TNetType)) or (FNetType < Low(TNetType)) then begin - ErrorDialog(f_('Broken "NetType" value (%d) found in settings for session "%s".', [Integer(FNetType), FSessionPath]) + ErrorDialog(f_('Unsupported "NetType" value (%d) found in settings for session "%s".', [Integer(FNetType), FSessionPath]) +CRLF+CRLF+ - f_('Please report that on %s', ['https://github.com/HeidiSQL/HeidiSQL']) + _('Loaded as MySQL/MariaDB session.') ); FNetType := ntMySQL_TCPIP; end; + FLoadedFromSettings := True; FHostname := AppSettings.ReadString(asHost); FUsername := AppSettings.ReadString(asUser); FPassword := decrypt(AppSettings.ReadString(asPassword)); FLoginPrompt := AppSettings.ReadBool(asLoginPrompt); FWindowsAuth := AppSettings.ReadBool(asWindowsAuth); FCleartextPluginEnabled := AppSettings.ReadBool(asCleartextPluginEnabled); + FForceUnicode := AppSettings.ReadBool(asForceUnicode); FPort := MakeInt(AppSettings.ReadString(asPort)); FCompressed := AppSettings.ReadBool(asCompressed); FAllDatabases := AppSettings.ReadString(asDatabases); FLibraryOrProvider := AppSettings.ReadString(asLibrary); + if not FileExists(GetLibDir + FLibraryOrProvider) then + FLibraryOrProvider := DefaultLibrary; // Catches empty string and any non-existant file FComment := AppSettings.ReadString(asComment); + // Auto-activate SSH for sessions created before asSSHtunnelActive was introduced + FSSHActive := AppSettings.ReadBool(asSSHtunnelActive, '', DefaultSshActive); + FSSHExe := AppSettings.ReadString(asSshExecutable); FSSHHost := AppSettings.ReadString(asSSHtunnelHost); FSSHPort := AppSettings.ReadInt(asSSHtunnelHostPort); FSSHUser := AppSettings.ReadString(asSSHtunnelUser); @@ -1312,12 +1516,16 @@ constructor TConnectionParameters.Create(SessionRegPath: String); FSSLCertificate := AppSettings.ReadString(asSSLCert); FSSLCACertificate := AppSettings.ReadString(asSSLCA); FSSLCipher := AppSettings.ReadString(asSSLCipher); + FSSLVerification := AppSettings.ReadInt(asSSLVerification); FStartupScriptFilename := AppSettings.ReadString(asStartupScriptFilename); FQueryTimeout := AppSettings.ReadInt(asQueryTimeout); FKeepAlive := AppSettings.ReadInt(asKeepAlive); FLocalTimeZone := AppSettings.ReadBool(asLocalTimeZone); FFullTableStatus := AppSettings.ReadBool(asFullTableStatus); FIgnoreDatabasePattern := AppSettings.ReadString(asIgnoreDatabasePattern); + FLogFileDdl := AppSettings.ReadBool(asLogFileDdl); + FLogFileDml := AppSettings.ReadBool(asLogFileDml); + FLogFilePath := AppSettings.ReadString(asLogFilePath); FServerVersion := AppSettings.ReadString(asServerVersionFull); DummyDate := 0; @@ -1325,8 +1533,21 @@ constructor TConnectionParameters.Create(SessionRegPath: String); FCounter := AppSettings.ReadInt(asConnectCount); AppSettings.ResetPath; - // Must be read without session path - FSSHPlinkExe := AppSettings.ReadString(asPlinkExecutable); + if FSSHExe.IsEmpty then begin + // Legacy support: was a global setting + // Globals must be read without session path + FSSHExe := AppSettings.ReadString(asPlinkExecutable); + end; + end; +end; + +destructor TConnectionParameters.Destroy; +begin + if FDeleteAfterUse and (not FLoadedFromSettings) and (not FSessionPath.IsEmpty) then begin + if AppSettings.SessionPathExists(FSessionPath) then begin + AppSettings.SessionPath := FSessionPath; + AppSettings.DeleteCurrentKey; + end; end; end; @@ -1346,6 +1567,7 @@ procedure TConnectionParameters.SaveToRegistry; AppSettings.WriteString(asHost, FHostname); AppSettings.WriteBool(asWindowsAuth, FWindowsAuth); AppSettings.WriteBool(asCleartextPluginEnabled, FCleartextPluginEnabled); + AppSettings.WriteBool(asForceUnicode, FForceUnicode); AppSettings.WriteString(asUser, FUsername); AppSettings.WriteString(asPassword, encrypt(FPassword)); AppSettings.WriteBool(asLoginPrompt, FLoginPrompt); @@ -1361,6 +1583,8 @@ procedure TConnectionParameters.SaveToRegistry; AppSettings.WriteString(asComment, FComment); AppSettings.WriteString(asStartupScriptFilename, FStartupScriptFilename); AppSettings.WriteInt(asTreeBackground, FSessionColor); + AppSettings.WriteBool(asSSHtunnelActive, FSSHActive); + AppSettings.WriteString(asSshExecutable, FSSHExe); AppSettings.WriteString(asSSHtunnelHost, FSSHHost); AppSettings.WriteInt(asSSHtunnelHostPort, FSSHPort); AppSettings.WriteString(asSSHtunnelUser, FSSHUser); @@ -1373,9 +1597,12 @@ procedure TConnectionParameters.SaveToRegistry; AppSettings.WriteString(asSSLCert, FSSLCertificate); AppSettings.WriteString(asSSLCA, FSSLCACertificate); AppSettings.WriteString(asSSLCipher, FSSLCipher); + AppSettings.WriteInt(asSSLVerification, FSSLVerification); AppSettings.WriteString(asIgnoreDatabasePattern, FIgnoreDatabasePattern); + AppSettings.WriteBool(asLogFileDdl, FLogFileDdl); + AppSettings.WriteBool(asLogFileDml, FLogFileDml); + AppSettings.WriteString(asLogFilePath, FLogFilePath); AppSettings.ResetPath; - AppSettings.WriteString(asPlinkExecutable, FSSHPlinkExe); end; end; @@ -1391,6 +1618,8 @@ function TConnectionParameters.CreateConnection(AOwner: TComponent): TDBConnecti Result := TPgConnection.Create(AOwner); ngSQLite: Result := TSQLiteConnection.Create(AOwner); + ngInterbase: + Result := TInterbaseConnection.Create(AOwner); else raise Exception.CreateFmt(_(MsgUnhandledNetType), [Integer(FNetType)]); end; @@ -1409,6 +1638,8 @@ function TConnectionParameters.CreateQuery(Connection: TDbConnection): TDBQuery; Result := TPGQuery.Create(Connection); ngSQLite: Result := TSQLiteQuery.Create(Connection); + ngInterbase: + Result := TInterbaseQuery.Create(Connection); else raise Exception.CreateFmt(_(MsgUnhandledNetType), [Integer(FNetType)]); end; @@ -1416,103 +1647,79 @@ function TConnectionParameters.CreateQuery(Connection: TDbConnection): TDBQuery; function TConnectionParameters.NetTypeName(LongFormat: Boolean): String; -var - Prefix: String; +const + PrefixMysql = 'MariaDB or MySQL'; + PrefixProxysql = 'ProxySQL Admin'; + PrefixMssql = 'Microsoft SQL Server'; + PrefixPostgres = 'PostgreSQL'; + PrefixRedshift = 'Redshift PG'; + PrefixSqlite = 'SQLite'; + PrefixInterbase = 'Interbase'; + PrefixFirebird = 'Firebird'; begin // Return the name of a net type, either in short or long format - case NetTypeGroup of - ngMySQL: begin - if IsMariaDB then - Prefix := 'MariaDB' - else if IsPercona then - Prefix := 'Percona' - else if IsTokudb then - Prefix := 'TokuDB' - else if IsInfiniDB then - Prefix := 'InfiniDB' - else if IsInfobright then - Prefix := 'Infobright' - else if IsMemSQL then - Prefix := 'MemSQL' - else if IsProxySQLAdmin then - Prefix := 'ProxySQL Admin' - else if IsMySQL then - Prefix := 'MySQL' - else - Prefix := 'MariaDB or MySQL'; - end; - ngMSSQL: begin - Prefix := 'Microsoft SQL Server'; - end; - ngPgSQL: begin - if IsRedshift then - Prefix := 'Redshift PG' - else - Prefix := 'PostgreSQL'; - end; - ngSQLite: begin - Prefix := 'SQLite'; - end; - end; - - case LongFormat of - True: case FNetType of - ntMySQL_TCPIP: - Result := Prefix+' (TCP/IP)'; - ntMySQL_NamedPipe: - Result := Prefix+' (named pipe)'; - ntMySQL_SSHtunnel: - Result := Prefix+' (SSH tunnel)'; - ntMySQL_ProxySQLAdmin: - Result := Prefix+' (Experimental)'; - ntMSSQL_NamedPipe: - Result := Prefix+' (named pipe)'; - ntMSSQL_TCPIP: - Result := Prefix+' (TCP/IP)'; - ntMSSQL_SPX: - Result := Prefix+' (SPX/IPX)'; - ntMSSQL_VINES: - Result := Prefix+' (Banyan VINES)'; - ntMSSQL_RPC: - Result := Prefix+' (Windows RPC)'; - ntPgSQL_TCPIP: - Result := Prefix+' (TCP/IP)'; - ntPgSQL_SSHtunnel: - Result := Prefix+' (SSH tunnel)'; - ntSQLite: - Result := Prefix+' (Experimental)'; - else - Result := Prefix; + Result := 'Unknown'; + + if LongFormat then begin + case FNetType of + ntMySQL_TCPIP: Result := PrefixMysql+' (TCP/IP)'; + ntMySQL_NamedPipe: Result := PrefixMysql+' (named pipe)'; + ntMySQL_SSHtunnel: Result := PrefixMysql+' (SSH tunnel)'; + ntMySQL_ProxySQLAdmin: Result := PrefixProxysql+' (Experimental)'; + ntMySQL_RDS: Result := 'MySQL on RDS'; + ntMSSQL_NamedPipe: Result := PrefixMssql+' (named pipe)'; + ntMSSQL_TCPIP: Result := PrefixMssql+' (TCP/IP)'; + ntMSSQL_SPX: Result := PrefixMssql+' (SPX/IPX)'; + ntMSSQL_VINES: Result := PrefixMssql+' (Banyan VINES)'; + ntMSSQL_RPC: Result := PrefixMssql+' (Windows RPC)'; + ntPgSQL_TCPIP: Result := PrefixPostgres+' (TCP/IP)'; + ntPgSQL_SSHtunnel: Result := PrefixPostgres+' (SSH tunnel)'; + ntSQLite: Result := PrefixSqlite; + ntSQLiteEncrypted: Result := PrefixSqlite+' (Encrypted)'; + ntInterbase_TCPIP: Result := PrefixInterbase+' (TCP/IP, experimental)'; + ntInterbase_Local: Result := PrefixInterbase+' (Local, experimental)'; + ntFirebird_TCPIP: Result := PrefixFirebird+' (TCP/IP, experimental)'; + ntFirebird_Local: Result := PrefixFirebird+' (Local, experimental)'; end; - - False: case NetTypeGroup of - ngMSSQL: - Result := 'MS SQL'; - else - Result := Prefix; + end + else begin + case NetTypeGroup of + ngMySQL: begin + if IsMariaDB then Result := 'MariaDB' + else if IsPercona then Result := 'Percona' + else if IsTokudb then Result := 'TokuDB' + else if IsInfiniDB then Result := 'InfiniDB' + else if IsInfobright then Result := 'Infobright' + else if IsMemSQL then Result := 'MemSQL' + else if IsProxySQLAdmin then Result := 'ProxySQL Admin' + else if IsMySQL(True) then Result := 'MySQL' + else Result := PrefixMysql; + end; + ngMSSQL: Result := 'MS SQL'; + ngPgSQL: begin + if IsRedshift then Result := PrefixRedshift + else Result := PrefixPostgres; + end; + ngSQLite: Result := PrefixSqlite; + ngInterbase: Result := PrefixInterbase; end; end; end; -function TConnectionParameters.IsCompatibleToWin10S: Boolean; -begin - // Using plink on 10S is not possible - Result := (FNetType <> ntMySQL_SSHtunnel) and (FNetType <> ntPgSQL_SSHtunnel); -end; - - function TConnectionParameters.GetNetTypeGroup: TNetTypeGroup; begin case FNetType of - ntMySQL_TCPIP, ntMySQL_NamedPipe, ntMySQL_SSHtunnel, ntMySQL_ProxySQLAdmin: + ntMySQL_TCPIP, ntMySQL_NamedPipe, ntMySQL_SSHtunnel, ntMySQL_ProxySQLAdmin, ntMySQL_RDS: Result := ngMySQL; ntMSSQL_NamedPipe, ntMSSQL_TCPIP, ntMSSQL_SPX, ntMSSQL_VINES, ntMSSQL_RPC: Result := ngMSSQL; ntPgSQL_TCPIP, ntPgSQL_SSHtunnel: Result := ngPgSQL; - ntSQLite: + ntSQLite, ntSQLiteEncrypted: Result := ngSQLite; + ntInterbase_TCPIP, ntInterbase_Local, ntFirebird_TCPIP, ntFirebird_Local: + Result := ngInterbase; else begin // Return default net group here. Raising an exception lets the app die for some reason. // Reproduction: click drop-down button on "Database(s)" session setting @@ -1523,6 +1730,12 @@ function TConnectionParameters.GetNetTypeGroup: TNetTypeGroup; end; +function TConnectionParameters.SshSupport: Boolean; +begin + Result := FNetType in [ntMySQL_SSHtunnel, ntMySQL_RDS, ntPgSQL_SSHtunnel, ntMSSQL_TCPIP]; +end; + + function TConnectionParameters.IsAnyMySQL: Boolean; begin Result := NetTypeGroup = ngMySQL; @@ -1547,22 +1760,38 @@ function TConnectionParameters.IsAnySQLite; end; +function TConnectionParameters.IsAnyInterbase; +begin + Result := NetTypeGroup = ngInterbase; +end; + + function TConnectionParameters.IsMariaDB: Boolean; begin Result := IsAnyMySQL and (Pos('-mariadb', LowerCase(ServerVersion)) > 0); end; -function TConnectionParameters.IsMySQL: Boolean; +function TConnectionParameters.IsMySQL(StrictDetect: Boolean): Boolean; +var + MajorVersionNum: String; begin - Result := IsAnyMySQL - and (not IsMariaDB) - and (not IsPercona) - and (not IsTokudb) - and (not IsInfiniDB) - and (not IsInfobright) - and (not IsProxySQLAdmin) - and (not IsMemSQL); + if StrictDetect then begin + MajorVersionNum := RegExprGetMatch('\b(\d+)\.\d+\.\d+', ServerVersion, 1); + Result := IsAnyMySQL and (not IsMariaDB) and ( + (ContainsText(ServerVersion, 'mysql') or IsMySQLonRDS) // RDS is always MySQL, but does not contain "mysql" + or (StrToIntDef(MajorVersionNum, -1) in [3,4,5,8]) // MySQL 8.0 does not contain "mysql", but major version only exists in MySQL + ); + end else begin + Result := IsAnyMySQL + and (not IsMariaDB) + and (not IsPercona) + and (not IsTokudb) + and (not IsInfiniDB) + and (not IsInfobright) + and (not IsProxySQLAdmin) + and (not IsMemSQL); + end; end; @@ -1596,6 +1825,12 @@ function TConnectionParameters.IsProxySQLAdmin: Boolean; end; +function TConnectionParameters.IsMySQLonRDS: Boolean; +begin + Result := NetType = ntMySQL_RDS; +end; + + function TConnectionParameters.IsAzure: Boolean; begin Result := IsAnyMSSQL and (Pos('azure', LowerCase(ServerVersion)) > 0); @@ -1614,20 +1849,33 @@ function TConnectionParameters.IsRedshift: Boolean; end; +function TConnectionParameters.IsInterbase: Boolean; +begin + Result := NetType in [ntInterbase_TCPIP, ntInterbase_Local]; +end; + + +function TConnectionParameters.IsFirebird: Boolean; +begin + Result := NetType in [ntFirebird_TCPIP, ntFirebird_Local]; +end; + + function TConnectionParameters.GetImageIndex: Integer; begin if IsFolder then Result := 174 else case NetTypeGroup of ngMySQL: begin - Result := 164; - if IsMariaDB then Result := 166 - else if IsPercona then Result := 169 + if IsPercona then Result := 169 else if IsTokudb then Result := 171 else if IsInfiniDB then Result := 172 else if IsInfobright then Result := 173 else if IsMemSQL then Result := 194 - else if IsProxySQLAdmin then Result := 197; + else if IsProxySQLAdmin then Result := 197 + else if IsMySQLonRDS then Result := 205 + else if IsMariaDB then Result := 166 + else Result := 164; end; ngMSSQL: begin Result := 123; @@ -1637,8 +1885,10 @@ function TConnectionParameters.GetImageIndex: Integer; Result := 187; if IsRedshift then Result := 195; end; - ngSQLite: begin - Result := 196; + ngSQLite: Result := 196; + ngInterbase: begin + Result := 203; + if IsFirebird then Result := 204; end else Result := ICONINDEX_SERVER; end; @@ -1656,6 +1906,7 @@ function TConnectionParameters.DefaultPort: Integer; end; ngMSSQL: Result := 0; // => autodetection by driver (previously 1433) ngPgSQL: Result := 5432; + ngInterbase: Result := 3050; else Result := 0; end; end; @@ -1667,6 +1918,7 @@ function TConnectionParameters.DefaultUsername: String; ngMySQL: Result := 'root'; ngMSSQL: Result := 'sa'; ngPgSQL: Result := 'postgres'; + ngInterbase: Result := 'sysdba'; else Result := ''; end; end; @@ -1674,12 +1926,34 @@ function TConnectionParameters.DefaultUsername: String; function TConnectionParameters.DefaultLibrary: String; begin + Result := ''; case NetTypeGroup of ngMySQL: Result := 'libmariadb.dll'; ngMSSQL: Result := 'MSOLEDBSQL'; // Prefer MSOLEDBSQL provider on newer systems ngPgSQL: Result := 'libpq.dll'; - ngSQLite: Result := 'sqlite3.dll'; - else Result := ''; + ngSQLite: begin + if NetType = ntSQLite then + Result := 'sqlite3.dll' + else + Result := 'sqlite3mc.dll'; + end; + ngInterbase: begin + if IsInterbase then + Result := IfThen(GetExecutableBits=64, 'ibclient64.dll', 'gds32.dll') + else if IsFirebird then + Result := 'fbclient.dll'; + end + end; +end; + + +function TConnectionParameters.DefaultHost: string; +begin + // See issue #1602: SQLite connecting to IP causes out-of-memory crash + Result := ''; + case NetTypeGroup of + ngSQLite: Result := ''; + else Result := '127.0.0.1'; end; end; @@ -1693,6 +1967,61 @@ function TConnectionParameters.DefaultIgnoreDatabasePattern: String; end; +function TConnectionParameters.DefaultSshActive: Boolean; +begin + Result := FNetType in [ntMySQL_SSHtunnel, ntMySQL_RDS, ntPgSQL_SSHtunnel]; +end; + + +function TConnectionParameters.GetExternalCliArguments(Connection: TDBConnection; ReplacePassword: TThreeStateBoolean): String; +var + Args: TStringList; +begin + // for mysql(dump) + Args := TStringList.Create; + Result := ''; + if WantSSL then + Args.Add('--ssl'); + if not SSLPrivateKey.IsEmpty then + Args.Add('--ssl-key="'+SSLPrivateKey+'"'); + if not SSLCertificate.IsEmpty then + Args.Add('--ssl-cert="'+SSLCertificate+'"'); + if not SSLCACertificate.IsEmpty then + Args.Add('--ssl-ca="'+SSLCACertificate+'"'); + + case NetType of + ntMySQL_NamedPipe: begin + Args.Add('--pipe'); + Args.Add('--socket="'+Hostname+'"'); + end; + ntMySQL_SSHtunnel, ntMySQL_RDS: begin + Args.Add('--host="localhost"'); + Args.Add('--port='+IntToStr(SSHLocalPort)); + end; + else begin + Args.Add('--host="'+Hostname+'"'); + Args.Add('--port='+IntToStr(Port)); + end; + end; + + Args.Add('--user="'+Username+'"'); + if Password <> '' then begin + case ReplacePassword of + nbTrue: Args.Add('--password="***"'); + nbFalse: Args.Add('--password="'+StringReplace(Password, '"', '\"', [rfReplaceAll])+'"'); + nbUnset: Args.Add('--password'); // will prompt + end; + end; + if Compressed then + Args.Add('--compress'); + if Assigned(Connection) and (Connection.Database <> '') then + Args.Add('--database="' + Connection.Database + '"'); + + Result := ' ' + Implode(' ', Args); + Args.Free; +end; + + function TConnectionParameters.GetLibraries: TStringList; var rx: TRegExpr; @@ -1702,10 +2031,10 @@ function TConnectionParameters.GetLibraries: TStringList; Provider: String; begin if not Assigned(FLibraries) then begin - FLibraries := TNetGroupLibs.Create; + FLibraries := TNetTypeLibs.Create; end; - if not FLibraries.ContainsKey(NetTypeGroup) then begin + if not FLibraries.ContainsKey(NetType) then begin FoundLibs := TStringList.Create; rx := TRegExpr.Create; rx.ModifierI := True; @@ -1713,15 +2042,21 @@ function TConnectionParameters.GetLibraries: TStringList; ngMySQL: rx.Expression := '^lib(mysql|mariadb).*\.dll$'; ngMSSQL: // Allow unsupported ADODB providers per registry hack - rx.Expression := IfThen(AppSettings.ReadBool(asAllProviders), '^', '^(MSOLEDBSQL|SQLOLEDB)$'); + rx.Expression := IfThen(AppSettings.ReadBool(asAllProviders), '^', '^(MSOLEDBSQL|SQLOLEDB)'); ngPgSQL: rx.Expression := '^libpq.*\.dll$'; - ngSQLite: - rx.Expression := '^sqlite.*\.dll$'; + ngSQLite: begin + if NetType = ntSQLite then + rx.Expression := '^sqlite.*\.dll$' + else + rx.Expression := '^sqlite3mc.*\.dll$'; + end; + ngInterbase: + rx.Expression := '^(gds32|ibclient|fbclient).*\.dll$'; end; case NetTypeGroup of - ngMySQL, ngPgSQL, ngSQLite: begin - Dlls := TDirectory.GetFiles(ExtractFilePath(ParamStr(0)), '*.dll'); + ngMySQL, ngPgSQL, ngSQLite, ngInterbase: begin + Dlls := TDirectory.GetFiles(GetLibDir, '*.dll'); for DllPath in Dlls do begin DllFile := ExtractFileName(DllPath); if rx.Exec(DllFile) then begin @@ -1731,20 +2066,25 @@ function TConnectionParameters.GetLibraries: TStringList; SetLength(Dlls, 0); end; ngMSSQL: begin - Providers := TStringList.Create; - GetProviderNames(Providers); - for Provider in Providers do begin - if rx.Exec(Provider) then begin - FoundLibs.Add(Provider); + try + Providers := TStringList.Create; + GetProviderNames(Providers); + for Provider in Providers do begin + if rx.Exec(Provider) then begin + FoundLibs.Add(Provider); + end; end; + Providers.Free; + except + on E:EOleSysError do + ErrorDialog('OLE provider names not available.' + sLineBreak + E.Message); end; - Providers.Free; end; end; rx.Free; - FLibraries.Add(NetTypeGroup, FoundLibs); + FLibraries.Add(NetType, FoundLibs); end; - FLibraries.TryGetValue(NetTypeGroup, Result); + FLibraries.TryGetValue(NetType, Result); end; @@ -1760,6 +2100,28 @@ function TConnectionParameters.GetSessionName: String; end; +function TConnectionParameters.GetAllDatabasesList: TStringList; +var + rx: TRegExpr; + dbname: String; +begin + Result := TStringList.Create; + if FAllDatabases <> '' then begin + rx := TRegExpr.Create; + rx.Expression := '[^;]+'; + rx.ModifierG := True; + if rx.Exec(FAllDatabases) then while true do begin + // Add if not a duplicate + dbname := Trim(rx.Match[0]); + if Result.IndexOf(dbname) = -1 then + Result.Add(dbname); + if not rx.ExecNext then + break; + end; + rx.Free; + end; +end; + { TMySQLConnection } @@ -1768,26 +2130,42 @@ constructor TDBConnection.Create(AOwner: TComponent); begin inherited; FParameters := TConnectionParameters.Create; + FOwnsParameters := True; FRowsFound := 0; FRowsAffected := 0; FWarningCount := 0; FConnectionStarted := 0; + FDatabase := ''; FLastQueryDuration := 0; FLastQueryNetworkDuration := 0; FThreadID := 0; FLogPrefix := ''; - FIsUnicode := False; + FIsUnicode := True; + FSecureShellCmd := nil; FIsSSL := False; FDatabaseCache := TDatabaseCache.Create(True); - FLoginPromptDone := False; + FColumnCache := TColumnCache.Create; + FKeyCache := TKeyCache.Create; + FForeignKeyCache := TForeignKeyCache.Create; + FCheckConstraintCache := TCheckConstraintCache.Create; FCurrentUserHostCombination := ''; FKeepAliveTimer := TTimer.Create(Self); FFavorites := TStringList.Create; FForeignKeyQueriesFailed := False; // System database/schema, should be uppercase on MSSQL only, see #855 FInfSch := 'information_schema'; + FInformationSchemaObjects := TStringList.Create; + FInformationSchemaObjects.CaseSensitive := False; // Characters in identifiers which don't need to be quoted FIdentCharsNoQuote := ['A'..'Z', 'a'..'z', '0'..'9', '_']; + FMaxRowsPerInsert := 10000; + FCaseSensitivity := 0; + FStringQuoteChar := ''''; + FCollationTable := nil; + FCharsetTable := nil; + FQuoteChar := '"'; + FQuoteChars := '"[]'; + FNamedEnums := TStringList.Create; end; @@ -1812,12 +2190,11 @@ constructor TAdoDBConnection.Create(AOwner: TComponent); i: Integer; begin inherited; - FQuoteChar := '"'; - FQuoteChars := '"[]'; SetLength(FDatatypes, Length(MSSQLDatatypes)); for i:=0 to High(MSSQLDatatypes) do FDatatypes[i] := MSSQLDatatypes[i]; FInfSch := 'INFORMATION_SCHEMA'; + FMaxRowsPerInsert := 1000; end; @@ -1826,7 +2203,6 @@ constructor TPgConnection.Create(AOwner: TComponent); i: Integer; begin inherited; - FQuoteChar := '"'; FQuoteChars := '"'; SetLength(FDatatypes, Length(PostGreSQLDatatypes)); for i:=0 to High(PostGreSQLDatatypes) do @@ -1843,8 +2219,6 @@ constructor TSQLiteConnection.Create(AOwner: TComponent); i: Integer; begin inherited; - FQuoteChar := '"'; - FQuoteChars := '"[]'; SetLength(FDatatypes, Length(SQLiteDatatypes)); for i:=0 to High(SQLiteDatatypes) do FDatatypes[i] := SQLiteDatatypes[i]; @@ -1853,11 +2227,28 @@ constructor TSQLiteConnection.Create(AOwner: TComponent); end; +constructor TInterbaseConnection.Create(AOwner: TComponent); +var + i: Integer; +begin + inherited; + SetLength(FDatatypes, Length(InterbaseDatatypes)); + for i:=0 to High(InterbaseDatatypes) do + FDatatypes[i] := InterbaseDatatypes[i]; + // Interbase does not have IS: + FInfSch := ''; +end; + + destructor TDBConnection.Destroy; begin ClearCache(True); FKeepAliveTimer.Free; FFavorites.Free; + FInformationSchemaObjects.Free; + FNamedEnums.Free; + if FOwnsParameters then + FreeAndNil(FParameters); inherited; end; @@ -1872,7 +2263,14 @@ destructor TMySQLConnection.Destroy; destructor TAdoDBConnection.Destroy; begin if Active then Active := False; - FreeAndNil(FAdoHandle); + try + FreeAndNil(FAdoHandle); + except + on E:Exception do begin + // Destroy > ClearRefs > GetDataSetCount throws some error, but max in Delphi 11.2 yet + Log(lcError, E.Message); + end; + end; inherited; end; @@ -1894,6 +2292,14 @@ destructor TSQLiteConnection.Destroy; end; +destructor TInterbaseConnection.Destroy; +begin + if Active then Active := False; + FreeAndNil(FFdHandle); + inherited; +end; + + function TDBConnection.GetDatatypeByName(var DataType: String; DeleteFromSource: Boolean; Identifier: String=''): TDBDatatype; var i, MatchLen: Integer; @@ -1905,6 +2311,8 @@ function TDBConnection.GetDatatypeByName(var DataType: String; DeleteFromSource: rx := TRegExpr.Create; rx.ModifierI := True; MatchLen := 0; + // Remove quotes around PG enums: "UserStatus" + DataType := DeQuoteIdent(DataType); for i:=0 to High(FDatatypes) do begin Types := FDatatypes[i].Name; if FDatatypes[i].Names <> '' then begin @@ -1912,7 +2320,7 @@ function TDBConnection.GetDatatypeByName(var DataType: String; DeleteFromSource: // Move more exact (longer) types to the beginning TypesSorted := Explode('|', Types); TypesSorted.CustomSort(StringListCompareByLength); - Types := ImplodeStr('|', TypesSorted); + Types := Implode('|', TypesSorted); TypesSorted.Free; end; @@ -1960,8 +2368,13 @@ function TDBConnection.GetDatatypeByNativeType(NativeType: Integer; Identifier: begin rx := TRegExpr.Create; TypeFound := False; + for i:=0 to High(Datatypes) do begin - if Datatypes[i].NativeTypes = '' then + // Skip if native ids / oid's are (yet) empty + if Datatypes[i].NativeTypes.IsEmpty then + Continue; + // Skip ? and e which have a special meaning + if Datatypes[i].NativeTypes.Length = 1 then Continue; rx.Expression := '\b('+Datatypes[i].NativeTypes+')\b'; if rx.Exec(IntToStr(NativeType)) then begin @@ -1970,6 +2383,16 @@ function TDBConnection.GetDatatypeByNativeType(NativeType: Integer; Identifier: break; end; end; + + { Dynamically retrieve data type from pg_type. + Problematic because we would not know which TDBDatatypeIndex to assign. + if (not TypeFound) and Parameters.IsAnyPostgreSQL then begin + PgType := GetResults('SELECT * FROM '+QuoteIdent('pg_type')+' WHERE '+QuoteIdent('oid')+'='+NativeType.ToString); + if PgType.RecordCount = 1 then begin + SetLength(FDatatypes, Length(FDatatypes)+1); + end; + end;} + if not TypeFound then begin // Fall back to unknown type Result := Datatypes[0]; @@ -2003,6 +2426,11 @@ procedure TMySQLConnection.SetLockedByThread(Value: TThread); end; end; +function TDBConnection.IsLockedByThread: Boolean; +begin + Result := FLockedByThread <> nil; +end; + {** (Dis-)Connect to/from server @@ -2010,23 +2438,18 @@ procedure TMySQLConnection.SetLockedByThread(Value: TThread); procedure TMySQLConnection.SetActive( Value: Boolean ); var Connected: PMYSQL; - ClientFlags, FinalPort: Integer; - Error, tmpdb, StatusName: String; + ClientFlags, FinalPort, SSLoption: Integer; + VerifyServerCert: Integer; + Error, StatusName: String; FinalHost, FinalSocket, FinalUsername, FinalPassword: String; - sslca, sslkey, sslcert, sslcipher: PAnsiChar; - PluginDir: AnsiString; + ErrorHint: String; + PluginDir, TlsVersions: AnsiString; Status: TDBQuery; PasswordChangeDialog: TfrmPasswordChange; - SetOptionResult: Integer; UserNameSize: DWORD; begin if Value and (FHandle = nil) then begin - // Die if trying to run plink on Win10S - if RunningOnWindows10S and (not FParameters.IsCompatibleToWin10S) then begin - raise EDbError.Create(_('The network type defined for this session is not compatible to your Windows 10 S')); - end; - DoBeforeConnect; // Get handle @@ -2038,27 +2461,48 @@ procedure TMySQLConnection.SetActive( Value: Boolean ); FinalPort := FParameters.Port; if FParameters.WantSSL then begin - // mysql_ssl_set() wants nil, while PAnsiChar(AnsiString()) is never nil - sslkey := nil; - sslcert := nil; - sslca := nil; - sslcipher := nil; + // Define which TLS protocol versions are allowed. + // See https://www.heidisql.com/forum.php?t=27158 + // See https://mariadb.com/kb/en/library/mysql_optionsv/ + // See issue #1768 + TlsVersions := 'TLSv1,TLSv1.1,TLSv1.2,TLSv1.3'; + //TlsVersions := 'TLSv1.1'; + if FLib.MARIADB_OPT_TLS_VERSION <> FLib.INVALID_OPT then + SetOption(FLib.MARIADB_OPT_TLS_VERSION, PAnsiChar(TlsVersions)); + SetOption(FLib.MYSQL_OPT_TLS_VERSION, PAnsiChar(TlsVersions)); if FParameters.SSLPrivateKey <> '' then - sslkey := PAnsiChar(AnsiString(FParameters.SSLPrivateKey)); + SetOption(FLib.MYSQL_OPT_SSL_KEY, PAnsiChar(AnsiString(FParameters.SSLPrivateKey))); if FParameters.SSLCertificate <> '' then - sslcert := PAnsiChar(AnsiString(FParameters.SSLCertificate)); + SetOption(FLib.MYSQL_OPT_SSL_CERT, PAnsiChar(AnsiString(FParameters.SSLCertificate))); if FParameters.SSLCACertificate <> '' then - sslca := PAnsiChar(AnsiString(FParameters.SSLCACertificate)); + SetOption(FLib.MYSQL_OPT_SSL_CA, PAnsiChar(AnsiString(FParameters.SSLCACertificate))); if FParameters.SSLCipher <> '' then - sslcipher := PAnsiChar(AnsiString(FParameters.SSLCipher)); - { TODO : Use Cipher and CAPath parameters } - FLib.mysql_ssl_set(FHandle, - sslkey, - sslcert, - sslca, - nil, - sslcipher); - Log(lcInfo, _('SSL parameters successfully set.')); + SetOption(FLib.MYSQL_OPT_SSL_CIPHER, PAnsiChar(AnsiString(FParameters.SSLCipher))); + if not FLib.IsLibMariadb then begin + // MySQL + Log(lcInfo, 'SSL parameters for MySQL'); + case FParameters.SSLVerification of + 0: SSLoption := FLib.SSL_MODE_PREFERRED; + 1: SSLoption := FLib.SSL_MODE_VERIFY_CA; + 2: SSLoption := FLib.SSL_MODE_VERIFY_IDENTITY; + end; + SetOption(FLib.MYSQL_OPT_SSL_MODE, @SSLoption); + end + else begin + // MariaDB + Log(lcInfo, 'SSL parameters for MariaDB'); + case FParameters.SSLVerification of + 0: VerifyServerCert := FLib.MYBOOL_FALSE; + 1,2: VerifyServerCert := FLib.MYBOOL_TRUE; + end; + SetOption(FLib.MYSQL_OPT_SSL_VERIFY_SERVER_CERT, @VerifyServerCert); + end; + end; + + // libmariadb v3.4.0+ enables MYSQL_OPT_SSL_VERIFY_SERVER_CERT by default, so we have to disable it. + // See https://mariadb.com/kb/en/mariadb-connector-c-3-4-0-release-notes/ + if not FParameters.WantSSL then begin + SetOption(FLib.MYSQL_OPT_SSL_VERIFY_SERVER_CERT, @(FLib.MYBOOL_FALSE)); end; case FParameters.NetType of @@ -2070,12 +2514,8 @@ procedure TMySQLConnection.SetActive( Value: Boolean ); FinalSocket := FParameters.Hostname; end; - ntMySQL_SSHtunnel: begin - // Create plink.exe process - FPlink := TPlink.Create(Self); - FPlink.Connect; - FinalHost := '127.0.0.1'; - FinalPort := FParameters.SSHLocalPort; + ntMySQL_SSHtunnel, ntMySQL_RDS: begin + StartSSHTunnel(FinalHost, FinalPort); end; end; @@ -2096,32 +2536,36 @@ procedure TMySQLConnection.SetActive( Value: Boolean ); end; // Gather client options - ClientFlags := CLIENT_LOCAL_FILES or CLIENT_INTERACTIVE or CLIENT_PROTOCOL_41 or CLIENT_MULTI_STATEMENTS or CLIENT_CAN_HANDLE_EXPIRED_PASSWORDS; + ClientFlags := CLIENT_LOCAL_FILES + or CLIENT_INTERACTIVE + or CLIENT_PROTOCOL_41 + or CLIENT_MULTI_STATEMENTS + or CLIENT_CAN_HANDLE_EXPIRED_PASSWORDS + or CLIENT_PLUGIN_AUTH_LENENC_CLIENT_DATA; if Parameters.Compressed then ClientFlags := ClientFlags or CLIENT_COMPRESS; - if Parameters.WantSSL then + if Parameters.WantSSL and (not FLib.IsLibMariadb) then ClientFlags := ClientFlags or CLIENT_SSL; - // Point libmysql to the folder with client plugins - PluginDir := AnsiString(ExtractFilePath(ParamStr(0))+'plugins'); - SetOptionResult := FLib.mysql_options(FHandle, Integer(MYSQL_PLUGIN_DIR), PAnsiChar(PluginDir)); - if SetOptionResult <> 0 then begin - raise EDbError.Create(f_('Plugin directory %s could not be set.', [PluginDir])); + if not GetPluginDir.IsEmpty then begin + // Point libmysql to the folder with client plugins + PluginDir := AnsiString(GetPluginDir); + SetOption(FLib.MYSQL_PLUGIN_DIR, PAnsiChar(PluginDir)); end; - // Define which TLS protocol versions are allowed. - // See https://www.heidisql.com/forum.php?t=27158 - // See https://mariadb.com/kb/en/library/mysql_optionsv/ - FLib.mysql_options(FHandle, Integer(MARIADB_OPT_TLS_VERSION), PAnsiChar('TLSv1,TLSv1.1,TLSv1.2,TLSv1.3')); - FLib.mysql_options(FHandle, Integer(MYSQL_OPT_TLS_VERSION), PAnsiChar('TLSv1,TLSv1.1,TLSv1.2,TLSv1.3')); - // Enable cleartext plugin if Parameters.CleartextPluginEnabled then - FLib.mysql_options(FHandle, Integer(MYSQL_ENABLE_CLEARTEXT_PLUGIN), PAnsiChar('1')); + SetOption(FLib.MYSQL_ENABLE_CLEARTEXT_PLUGIN, @(FLib.MYBOOL_TRUE)); // Tell server who we are if Assigned(FLib.mysql_optionsv) then - FLib.mysql_optionsv(FHandle, Integer(MYSQL_OPT_CONNECT_ATTR_ADD), 'program_name', APPNAME); + FLib.mysql_optionsv(FHandle, FLib.MYSQL_OPT_CONNECT_ATTR_ADD, 'program_name', APPNAME); + + // Seems to be still required on some systems, for importing CSV files + SetOption(FLib.MYSQL_OPT_LOCAL_INFILE, @(FLib.MYBOOL_TRUE)); + + // Ensure we have some connection timeout + SetOption(FLib.MYSQL_OPT_CONNECT_TIMEOUT, @(FParameters.QueryTimeout)); Connected := FLib.mysql_real_connect( FHandle, @@ -2138,9 +2582,24 @@ procedure TMySQLConnection.SetActive( Value: Boolean ); Log(lcError, Error); FConnectionStarted := 0; FHandle := nil; - if FPlink <> nil then - FPlink.Free; - raise EDbError.Create(Error); + EndSSHTunnel; + if Error.Contains('SEC_E_ALGORITHM_MISMATCH') then begin + ErrorHint := f_('This is a known issue with older libraries. Try a newer %s in the session settings.', + ['libmysql'] + ); + end + else if Error.Contains('certificate verif') then begin + ErrorHint := _('You might need to lower the certificate verification in the SSL settings.'); + end + else if (FParameters.DefaultLibrary <> '') and (FParameters.LibraryOrProvider <> FParameters.DefaultLibrary) then begin + ErrorHint := f_('You could try the default library %s in your session settings. (Current: %s)', + [FParameters.DefaultLibrary, FParameters.LibraryOrProvider] + ); + end + else begin + ErrorHint := ''; + end; + raise EDbError.Create(Error, LastErrorCode, ErrorHint); end else begin FActive := True; // Catch late init_connect error by firing mysql_ping(), which detects a broken @@ -2160,7 +2619,7 @@ procedure TMySQLConnection.SetActive( Value: Boolean ); ThreadId; except on E:EDbError do begin - if GetLastErrorCode = 1820 then begin + if GetLastErrorCode = ER_MUST_CHANGE_PASSWORD then begin PasswordChangeDialog := TfrmPasswordChange.Create(Self); PasswordChangeDialog.lblHeading.Caption := GetLastErrorMsg; PasswordChangeDialog.ShowModal; @@ -2176,21 +2635,38 @@ procedure TMySQLConnection.SetActive( Value: Boolean ); Raise; end; end; + + // We need the server version before checking the current character set + FServerVersionUntouched := GetSessionVariable('version') + ' - ' + GetSessionVariable('version_comment'); + FServerVersionUntouched := FServerVersionUntouched.Trim([' ', '-']); + if FServerVersionUntouched.IsEmpty then begin + FServerVersionUntouched := DecodeAPIString(FLib.mysql_get_server_info(FHandle)); + end; + // mysql_character_set_name() reports utf8* if in fact we're on some latin* charset on v5.1 servers + // See https://www.heidisql.com/forum.php?t=39278 try CharacterSet := 'utf8mb4'; except + // older servers without *mb4 support go here on E:EDbError do try Log(lcError, E.Message); CharacterSet := 'utf8'; except - on E:EDbError do + // v5.1 returned "Unknown character set: 'utf8mb3'" with libmariadb + on E:EDbError do try Log(lcError, E.Message); + Query('SET NAMES utf8'); + except + // give up + on E:EDbError do + Log(lcError, E.Message); + end; end; end; - Log(lcInfo, _('Characterset')+': '+GetCharacterSet); + Log(lcInfo, _('Characterset')+': '+CharacterSet); FConnectionStarted := GetTickCount div 1000; FServerUptime := -1; - Status := GetResults(GetSQLSpecifity(spGlobalStatus)); + Status := GetResults(FSqlProvider.GetSql(qGlobalStatus)); while not Status.Eof do begin StatusName := LowerCase(Status.Col(0)); if (StatusName = 'uptime') or (StatusName = 'proxysql_uptime') then @@ -2199,26 +2675,13 @@ procedure TMySQLConnection.SetActive( Value: Boolean ); FIsSSL := Status.Col(1) <> ''; Status.Next; end; - FServerDateTimeOnStartup := GetVar('SELECT ' + GetSQLSpecifity(spFuncNow)); + FServerDateTimeOnStartup := GetVar('SELECT ' + FSqlProvider.GetSql(qFuncNow)); FServerOS := GetSessionVariable('version_compile_os'); FRealHostname := GetSessionVariable('hostname'); - FServerVersionUntouched := GetSessionVariable('version') + ' - ' + GetSessionVariable('version_comment'); - FServerVersionUntouched := FServerVersionUntouched.Trim([' ', '-']); - if FServerVersionUntouched.IsEmpty then begin - FServerVersionUntouched := DecodeAPIString(FLib.mysql_get_server_info(FHandle)); - end; + FCaseSensitivity := MakeInt(GetSessionVariable('lower_case_table_names', IntToStr(FCaseSensitivity))); - if FDatabase <> '' then begin - tmpdb := FDatabase; - FDatabase := ''; - try - Database := tmpdb; - except - // Trigger OnDatabaseChange event for if wanted db is not available - FDatabase := tmpdb; - Database := ''; - end; - end; + // Triggers OnDatabaseChange event for + Database := ''; DoAfterConnect; end; end @@ -2234,8 +2697,7 @@ procedure TMySQLConnection.SetActive( Value: Boolean ); ClearCache(False); FConnectionStarted := 0; FHandle := nil; - if FPlink <> nil then - FPlink.Free; + EndSSHTunnel; Log(lcInfo, f_(MsgDisconnect, [FParameters.Hostname, DateTimeToStr(Now)])); end; @@ -2244,13 +2706,18 @@ procedure TMySQLConnection.SetActive( Value: Boolean ); procedure TAdoDBConnection.SetActive(Value: Boolean); var - tmpdb, Error, NetLib, DataSource, QuotedPassword, ServerVersion: String; + Error, NetLib, DataSource, QuotedPassword, ServerVersion, ErrorHint: String; + FinalHost: String; rx: TRegExpr; - i: Integer; + FinalPort, i: Integer; IsOldProvider: Boolean; begin if Value then begin DoBeforeConnect; + FinalHost := Parameters.Hostname; + FinalPort := Parameters.Port; + StartSSHTunnel(FinalHost, FinalPort); + try // Creating the ADO object throws exceptions if MDAC is missing, especially on Wine FAdoHandle := TAdoConnection.Create(Owner); @@ -2265,13 +2732,14 @@ procedure TAdoDBConnection.SetActive(Value: Boolean); end; IsOldProvider := Parameters.LibraryOrProvider = 'SQLOLEDB'; - if IsOldProvider then begin + if IsOldProvider and (not WarningShownOldOleProvider) then begin MessageDialog( f_('Security issue: Using %s %s with insecure %s.', [Parameters.LibraryOrProvider, 'ADO provider', 'TLS 1.0']) + f_('You should install %s from %s', ['Microsoft OLE DB Driver', 'https://www.microsoft.com/en-us/download/confirmation.aspx?id=56730']), mtWarning, [mbOK]); + WarningShownOldOleProvider := True; end; NetLib := ''; @@ -2283,9 +2751,9 @@ procedure TAdoDBConnection.SetActive(Value: Boolean); ntMSSQL_RPC: NetLib := 'DBMSRPCN'; end; - DataSource := Parameters.Hostname; - if (Parameters.NetType = ntMSSQL_TCPIP) and (Parameters.Port <> 0) then - DataSource := DataSource + ','+IntToStr(Parameters.Port); + DataSource := FinalHost; + if (Parameters.NetType = ntMSSQL_TCPIP) and (FinalPort <> 0) then + DataSource := DataSource + ','+IntToStr(FinalPort); // Quote password, just in case there is a semicolon or a double quote in it. // See http://forums.asp.net/t/1957484.aspx?Passwords+ending+with+semi+colon+as+the+terminal+element+in+connection+strings+ @@ -2302,7 +2770,7 @@ procedure TAdoDBConnection.SetActive(Value: Boolean); 'Data Source='+DataSource+';'+ 'Application Name='+AppName+';' ; - if Parameters.LibraryOrProvider = 'MSOLEDBSQL' then begin + if Parameters.LibraryOrProvider.StartsWith('MSOLEDBSQL', true) then begin // Issue #423: MSOLEDBSQL compatibility with new column types // See https://docs.microsoft.com/en-us/sql/connect/oledb/applications/using-ado-with-oledb-driver-for-sql-server?view=sql-server-2017 // Do not use with old driver, see https://www.heidisql.com/forum.php?t=35208 @@ -2329,7 +2797,6 @@ procedure TAdoDBConnection.SetActive(Value: Boolean); // CharacterSet := 'utf8'; // CurCharset := CharacterSet; // Log(lcDebug, 'Characterset: '+CurCharset); - FIsUnicode := True; FAdoHandle.CommandTimeout := Parameters.QueryTimeout; try // Gracefully accept failure on MS Azure (SQL Server 11), which does not have a sysprocesses table @@ -2337,7 +2804,7 @@ procedure TAdoDBConnection.SetActive(Value: Boolean); except FServerUptime := -1; end; - FServerDateTimeOnStartup := GetVar('SELECT ' + GetSQLSpecifity(spFuncNow)); + FServerDateTimeOnStartup := GetVar('SELECT ' + FSqlProvider.GetSql(qFuncNow)); // Microsoft SQL Server 2008 R2 (RTM) - 10.50.1600.1 (Intel X86) // Apr 2 2010 15:53:02 // Copyright (c) Microsoft Corporation @@ -2371,6 +2838,8 @@ procedure TAdoDBConnection.SetActive(Value: Boolean); for i:=0 to FAdoHandle.Properties.Count-1 do Log(lcDebug, f_('OLE DB property "%s": %s', [FAdoHandle.Properties[i].Name, String(FAdoHandle.Properties[i].Value)])); + // Triggers OnDatabaseChange event for + Database := ''; DoAfterConnect; // Reopen closed datasets after reconnecting @@ -2378,23 +2847,20 @@ procedure TAdoDBConnection.SetActive(Value: Boolean); //for i:=0 to FAdoHandle.DataSetCount-1 do // FAdoHandle.DataSets[i].Open; - if FDatabase <> '' then begin - tmpdb := FDatabase; - FDatabase := ''; - try - Database := tmpdb; - except - FDatabase := tmpdb; - Database := ''; - end; - end; except on E:Exception do begin FLastError := E.Message; Error := LastErrorMsg; Log(lcError, Error); FConnectionStarted := 0; - raise EDbError.Create(Error); + if (FParameters.DefaultLibrary <> '') and (FParameters.LibraryOrProvider <> FParameters.DefaultLibrary) then begin + ErrorHint := f_('You could try the default library %s in your session settings. (Current: %s)', + [FParameters.DefaultLibrary, FParameters.LibraryOrProvider] + ); + end else begin + ErrorHint := ''; + end; + raise EDbError.Create(Error, LastErrorCode, ErrorHint); end; end; end else begin @@ -2402,6 +2868,7 @@ procedure TAdoDBConnection.SetActive(Value: Boolean); FActive := False; ClearCache(False); FConnectionStarted := 0; + EndSSHTunnel; Log(lcInfo, f_(MsgDisconnect, [FParameters.Hostname, DateTimeToStr(Now)])); end; end; @@ -2409,56 +2876,59 @@ procedure TAdoDBConnection.SetActive(Value: Boolean); procedure TPgConnection.SetActive(Value: Boolean); var - dbname, ConnInfo, Error, tmpdb: String; - FinalHost: String; - FinalPort: Integer; - - function EscapeConnectOption(Option: String): String; - begin // See issue #704 - Result := StringReplace(Option, '\', '\\', [rfReplaceAll]); - end; + ConnectionString, OptionValue, Error: String; + ConnectOptions: TStringList; + FinalHost, ErrorHint: String; + FinalPort, i: Integer; begin if Value then begin DoBeforeConnect; - // Simon Riggs: - // "You should connect as "postgres" database by default, with an option to change. Don't use template1" - dbname := FParameters.AllDatabasesStr; - if dbname = '' then - dbname := 'postgres'; // Prepare special stuff for SSH tunnel FinalHost := FParameters.Hostname; FinalPort := FParameters.Port; - case FParameters.NetType of - ntPgSQL_SSHtunnel: begin - // Create plink.exe process - FPlink := TPlink.Create(Self); - FPlink.Connect; - FinalHost := '127.0.0.1'; - FinalPort := FParameters.SSHLocalPort; - end; - end; - - ConnInfo := 'host='''+FinalHost+''' '+ - 'port='''+IntToStr(FinalPort)+''' '+ - 'user='''+FParameters.Username+''' ' + - 'password='''+FParameters.Password+''' '+ - 'dbname='''+dbname+''' '+ - 'application_name='''+APPNAME+''''; + StartSSHTunnel(FinalHost, FinalPort); + + // Compose connection string + ConnectOptions := TStringList.Create; + ConnectOptions.Duplicates := dupIgnore; + ConnectOptions + .AddPair('host', FinalHost) + .AddPair('port', IntToStr(FinalPort)) + .AddPair('user', FParameters.Username) + .AddPair('password', FParameters.Password) + .AddPair('application_name', APPNAME) + .AddPair('sslmode', 'disable'); + if not FParameters.AllDatabasesStr.IsEmpty then + ConnectOptions.AddPair('dbname', FParameters.AllDatabasesStr); if FParameters.WantSSL then begin - ConnInfo := ConnInfo + ' sslmode=''require'''; + // Be aware .AddPair would add duplicates + case FParameters.SSLVerification of + 0: ConnectOptions.Values['sslmode'] := 'require'; + 1: ConnectOptions.Values['sslmode'] := 'verify-ca'; + 2: ConnectOptions.Values['sslmode'] := 'verify-full'; + end; if FParameters.SSLPrivateKey <> '' then - ConnInfo := ConnInfo + ' sslkey='''+EscapeConnectOption(FParameters.SSLPrivateKey)+''''; + ConnectOptions.AddPair('sslkey', FParameters.SSLPrivateKey); if FParameters.SSLCertificate <> '' then - ConnInfo := ConnInfo + ' sslcert='''+EscapeConnectOption(FParameters.SSLCertificate)+''''; + ConnectOptions.AddPair('sslcert', FParameters.SSLCertificate); if FParameters.SSLCACertificate <> '' then - ConnInfo := ConnInfo + ' sslrootcert='''+EscapeConnectOption(FParameters.SSLCACertificate)+''''; + ConnectOptions.AddPair('sslrootcert', FParameters.SSLCACertificate); //if FParameters.SSLCipher <> '' then ?? end; + ConnectionString := ''; + for i:=0 to ConnectOptions.Count-1 do begin + // Escape values. See issue #704 and #1417, and docs: https://www.postgresql.org/docs/current/libpq-connect.html#LIBPQ-CONNSTRING + OptionValue := ConnectOptions.ValueFromIndex[i]; + OptionValue := StringReplace(OptionValue, '\', '\\', [rfReplaceAll]); + OptionValue := StringReplace(OptionValue, '''', '\''', [rfReplaceAll]); + ConnectionString := ConnectionString + ConnectOptions.Names[i] + '=''' + OptionValue + ''' '; + end; + ConnectOptions.Free; + ConnectionString := ConnectionString.TrimRight; - - FHandle := FLib.PQconnectdb(PAnsiChar(AnsiString(ConnInfo))); + FHandle := FLib.PQconnectdb(PAnsiChar(UTF8Encode(ConnectionString))); if FLib.PQstatus(FHandle) = CONNECTION_BAD then begin Error := LastErrorMsg; Log(lcError, Error); @@ -2469,16 +2939,24 @@ procedure TPgConnection.SetActive(Value: Boolean); on E:EAccessViolation do; end; FHandle := nil; - if FPlink <> nil then - FPlink.Free; - raise EDbError.Create(Error); + EndSSHTunnel; + if (FParameters.DefaultLibrary <> '') and (FParameters.LibraryOrProvider <> FParameters.DefaultLibrary) then begin + ErrorHint := f_('You could try the default library %s in your session settings. (Current: %s)', + [FParameters.DefaultLibrary, FParameters.LibraryOrProvider] + ); + end else begin + ErrorHint := ''; + end; + raise EDbError.Create(Error, LastErrorCode, ErrorHint); end; FActive := True; - FServerDateTimeOnStartup := GetVar('SELECT ' + GetSQLSpecifity(spFuncNow)); + CharacterSet := 'UTF8'; + FServerDateTimeOnStartup := GetVar('SELECT ' + FSqlProvider.GetSql(qFuncNow)); FServerVersionUntouched := GetVar('SELECT VERSION()'); FConnectionStarted := GetTickCount div 1000; - FIsUnicode := True; Query('SET statement_timeout TO '+IntToStr(Parameters.QueryTimeout*1000)); + if ServerVersionInt >= 80300 then + Query('SET synchronize_seqscans TO off'); try FServerUptime := StrToIntDef(GetVar('SELECT EXTRACT(EPOCH FROM CURRENT_TIMESTAMP - pg_postmaster_start_time())::INTEGER'), -1); except @@ -2490,29 +2968,20 @@ procedure TPgConnection.SetActive(Value: Boolean); FIsSSL := False; end; + // Triggers OnDatabaseChange event for + Database := ''; DoAfterConnect; - - if FDatabase <> '' then begin - tmpdb := FDatabase; - FDatabase := ''; - try - Database := tmpdb; - except - FDatabase := tmpdb; - Database := ''; - end; - end; end else begin try - FLib.PQfinish(FHandle); + if FActive then + FLib.PQfinish(FHandle); except on E:EAccessViolation do; end; FActive := False; ClearCache(False); FConnectionStarted := 0; - if FPlink <> nil then - FPlink.Free; + EndSSHTunnel; Log(lcInfo, f_(MsgDisconnect, [FParameters.Hostname, DateTimeToStr(Now)])); end; end; @@ -2521,16 +2990,28 @@ procedure TPgConnection.SetActive(Value: Boolean); procedure TSQLiteConnection.SetActive(Value: Boolean); var ConnectResult: Integer; - tmpdb: String; - FileNames: TStringList; - MainFile, DbAlias: String; - i: Integer; + RawPassword: AnsiString; + ErrorHint: String; + FileNames, EncryptionParams: TStringList; + MainFile, DbAlias, Param, ParamName: String; + MainFileDir: String; + i, SplitPos, ParamValue: Integer; + CipherIndex, ConfigResult: Integer; + ParamWasSet: Boolean; begin // Support multiple filenames, and use first one as main database FileNames := Explode(DELIM, Parameters.Hostname); MainFile := IfThen(FileNames.Count>=1, FileNames[0], ''); if Value then begin + // Fixes "out of memory" crash in sqlite3_open, see issue #1367 + MainFileDir := ExtractFilePath(MainFile); + MainFileDir := IncludeTrailingPathDelimiter(MainFileDir); + if not DirectoryExists(MainFileDir) then + raise EDbError.Create(f_('Folder in path does not exist: %s', [MainFile])); + if not FileExists(MainFile) then + Log(lcInfo, f_('File does not yet exist, will be created now: %s', [MainFile])); + DoBeforeConnect; ConnectResult := FLib.sqlite3_open( @@ -2539,7 +3020,56 @@ procedure TSQLiteConnection.SetActive(Value: Boolean); if ConnectResult = SQLITE_OK then begin FActive := True; - FIsUnicode := True; + if Parameters.NetType = ntSQLiteEncrypted then begin + // Use encryption key + CipherIndex := FLib.sqlite3mc_cipher_index(PAnsiChar(AnsiString(Parameters.Username))); + //Log(lcinfo, 'CipherIndex:'+CipherIndex.ToString); + if CipherIndex = -1 then + raise EDbError.Create(f_('Warning: Given cipher scheme name "%s" could not be found', [Parameters.Username])); + ConfigResult := FLib.sqlite3mc_config(FHandle, PAnsiChar('default:cipher'), CipherIndex); + if ConfigResult = -1 then + raise EDbError.Create(f_('Warning: Configuring with cipher index %d failed', [CipherIndex])); + // Set encryption parameters: + EncryptionParams := Parameters.AllDatabasesList; + for Param in EncryptionParams do begin + Log(lcDebug, 'Cipher encryption parameter: "'+Param+'"'); + SplitPos := Param.IndexOf('='); + ParamWasSet := False; + if SplitPos > -1 then begin + ParamName := Copy(Param, 1, SplitPos); + ParamValue := StrToIntDef(Copy(Param, SplitPos+2, Length(Param)), -1); + if ParamValue > -1 then begin + ConfigResult := FLib.sqlite3mc_config_cipher( + FHandle, + PAnsiChar(AnsiString(Parameters.Username)), + PAnsiChar(AnsiString(ParamName)), + ParamValue + ); + if ConfigResult <> -1 then + ParamWasSet := True; + end + end; + if not ParamWasSet then + Log(lcError, f_('Warning: Failed to set cipher encryption parameter "%s"', [Param])) + else + Log(lcInfo, f_('Info: Cipher encryption parameter "%s" set', [Param])); + end; + // Set the main database key + RawPassword := AnsiString(Parameters.Password); + FLib.sqlite3_key(FHandle, Pointer(RawPassword), Length(RawPassword)); + // See https://utelle.github.io/SQLite3MultipleCiphers/docs/configuration/config_capi/ + // "These functions return SQLITE_OK even if the provided key isnt correct. This is because the key isnt + // actually used until a subsequent attempt to read or write the database is made. To check whether the + // provided key was actually correct, you must execute a simple query like e.g. SELECT * FROM sqlite_master; + // and check whether that succeeds." + try + Query(ApplyLimitClause('SELECT', '* FROM sqlite_master', 1, 0)); + except + on E:EDbError do + raise EDbError.Create(E.Message, 0, _('You have activated encryption on a probably non-encrypted database.')); + end; + end; + FLib.sqlite3_collation_needed(FHandle, Self, SQLite_CollationNeededCallback); Query('PRAGMA busy_timeout='+(Parameters.QueryTimeout*1000).ToString); // Override "main" database name with custom one @@ -2552,27 +3082,31 @@ procedure TSQLiteConnection.SetActive(Value: Boolean); DbAlias := TPath.GetFileNameWithoutExtension(FileNames[i]); Query('ATTACH DATABASE '+EscapeString(FileNames[i])+' AS '+QuoteIdent(DbAlias)); end; - FServerDateTimeOnStartup := GetVar('SELECT ' + GetSQLSpecifity(spFuncNow)); + // See issue #1186: + if FLib.sqlite3_enable_load_extension(FHandle, 1) <> SQLITE_OK then begin + Log(lcError, 'Could not enable load_extension()'); + end; + + FServerDateTimeOnStartup := GetVar('SELECT ' + FSqlProvider.GetSql(qFuncNow)); FServerVersionUntouched := GetVar('SELECT sqlite_version()'); FConnectionStarted := GetTickCount div 1000; FServerUptime := -1; + // Triggers OnDatabaseChange event for + Database := ''; DoAfterConnect; - if FDatabase <> '' then begin - tmpdb := FDatabase; - FDatabase := ''; - try - Database := tmpdb; - except - FDatabase := tmpdb; - Database := ''; - end; - end; end else begin Log(lcError, LastErrorMsg); FConnectionStarted := 0; FHandle := nil; + if (FParameters.DefaultLibrary <> '') and (FParameters.LibraryOrProvider <> FParameters.DefaultLibrary) then begin + ErrorHint := f_('You could try the default library %s in your session settings. (Current: %s)', + [FParameters.DefaultLibrary, FParameters.LibraryOrProvider] + ); + end else begin + ErrorHint := ''; + end; raise EDbError.Create(LastErrorMsg); end; end else begin @@ -2587,127 +3121,193 @@ procedure TSQLiteConnection.SetActive(Value: Boolean); end; +procedure TInterbaseConnection.SetActive(Value: Boolean); +var + DriverId: String; + IbDriver: TFDPhysIBDriverLink; + FbDriver: TFDPhysFBDriverLink; +begin + if Value then begin + DoBeforeConnect; + + FFDHandle := TFDConnection.Create(Owner); + FFDHandle.OnError := OnFdError; + //FFDHandle.DriverName := Parameters.LibraryOrProvider; // Auto-sets Params.DriverID + FFDHandle.LoginPrompt := False; + + // Create virtual Interbase or Firebird driver id, once + DriverId := Parameters.LibraryOrProvider; + if Parameters.IsInterbase then begin + if not Assigned(FIbDrivers) then begin + FIbDrivers := TIbDrivers.Create; + end; + if not FIbDrivers.ContainsKey(DriverId) then begin + Log(lcInfo, 'Creating virtual driver id with '+Parameters.LibraryOrProvider); + IbDriver := TFDPhysIBDriverLink.Create(Owner); + IbDriver.VendorLib := Parameters.LibraryOrProvider; + IbDriver.DriverID := DriverId; + FIbDrivers.Add(DriverId, IbDriver); + end; + FIbDrivers.TryGetValue(DriverId, IbDriver); + FFDHandle.Params.Values['DriverID'] := IbDriver.DriverID; + end + else if Parameters.IsFirebird then begin + if not Assigned(FFbDrivers) then begin + FFbDrivers := TFbDrivers.Create; + end; + if not FFbDrivers.ContainsKey(DriverId) then begin + Log(lcInfo, 'Creating virtual driver id link with '+Parameters.LibraryOrProvider); + FbDriver := TFDPhysFBDriverLink.Create(Owner); + FbDriver.VendorLib := Parameters.LibraryOrProvider; + FbDriver.DriverID := DriverId; + FFbDrivers.Add(DriverId, FbDriver); + end; + FFbDrivers.TryGetValue(DriverId, FbDriver); + FFDHandle.Params.Values['DriverID'] := FbDriver.DriverID; + end; + + // TCP/IP or local? + case Parameters.NetType of + ntInterbase_TCPIP, ntFirebird_TCPIP: begin + FFDHandle.Params.Values['Protocol'] := 'ipTCPIP'; + FFDHandle.Params.Values['Server'] := Parameters.Hostname; + FFDHandle.Params.Values['Port'] := Parameters.Port.ToString; + end; + ntInterbase_Local, ntFirebird_Local: begin + FFDHandle.Params.Values['Protocol'] := 'ipLocal'; + end; + end; + + FFDHandle.Params.Values['Database'] := Parameters.AllDatabasesStr; + FFDHandle.Params.Values['User_Name'] := Parameters.Username; + FFDHandle.Params.Values['Password'] := Parameters.Password; + FFDHandle.Params.Values['CharacterSet'] := 'UTF8'; + FFDHandle.Params.Values['ExtendedMetadata'] := 'True'; + + try + FFDHandle.Connected := True; + except + // Let OnFdError set FLastError + end; + + if FFDHandle.Connected then begin + FActive := True; + //! Query('PRAGMA busy_timeout='+(Parameters.QueryTimeout*1000).ToString); + + FServerDateTimeOnStartup := GetVar('SELECT ' + FSqlProvider.GetSql(qFuncNow)); + + if Parameters.IsInterbase then + FServerVersionUntouched := '' + else + FServerVersionUntouched := GetVar('SELECT rdb$get_context(''SYSTEM'', ''ENGINE_VERSION'') as version from rdb$database'); + FConnectionStarted := GetTickCount div 1000; + FServerUptime := -1; + + // Triggers OnDatabaseChange event for + Database := ''; + DoAfterConnect; + + end else begin + Log(lcError, LastErrorMsg); + FConnectionStarted := 0; + raise EDbError.Create(LastErrorMsg); + end; + end else begin + if FFdHandle <> nil then begin + ClearCache(False); + FFdHandle.Connected := False; + FActive := False; + Log(lcInfo, f_(MsgDisconnect, [Parameters.Hostname, DateTimeToStr(Now)])); + end; + end; +end; + + +procedure TMySQLConnection.SetOption(Option: Integer; Arg: Pointer); +var + SetOptionResult: Integer; + RttiContext: TRttiContext; + LibType: TRttiType; + LibField: TRttiField; + FieldName: String; +begin + // Set one of the MYSQL_* option and log a warning if that failed + FieldName := Option.ToString; + // Attempt to find readable name of option constant + RttiContext := TRttiContext.Create; + LibType := RttiContext.GetType(TypeInfo(TMySQLLib)); + for LibField in LibType.GetFields do begin + // Skip assigned procedures + if LibField.FieldType = nil then + Continue; + if LibField.DataType.TypeKind = tkInteger then begin + if LibField.GetValue(FLib).AsInteger = Option then begin + FieldName := LibField.Name; + end; + end; + end; + RttiContext.Free; + + Log(lcDebug, Format('Calling mysql_options(%s, ...)', [FieldName])); + SetOptionResult := FLib.mysql_options(FHandle, Option, Arg); + if SetOptionResult <> 0 then begin + Log(lcError, _(SLogPrefixWarning) + ': mysql_options(' + FieldName + ', ...) failed!'); + end; +end; + + procedure TDBConnection.DoBeforeConnect; var UsingPass: String; Dialog: TfrmLogin; begin - // Prompt for password on initial connect - if FParameters.LoginPrompt and (not FLoginPromptDone) then begin + // Don't remember prompt values + if FParameters.LoginPrompt then begin Dialog := TfrmLogin.Create(Self); Dialog.Caption := APPNAME + ' - ' + FParameters.SessionName; Dialog.lblPrompt.Caption := f_('Login to %s:', [FParameters.Hostname]); Dialog.editUsername.Text := FParameters.Username; Dialog.editPassword.Text := FParameters.Password; - Dialog.ShowModal; - FParameters.Username := Dialog.editUsername.Text; - FParameters.Password := Dialog.editPassword.Text; - Dialog.Free; - FLoginPromptDone := True; + if Dialog.ShowModal = mrOk then begin + FParameters.Username := Dialog.editUsername.Text; + FParameters.Password := Dialog.editPassword.Text; + Dialog.Free; + end + else begin + Dialog.Free; + raise EDbError.Create(_('Login cancelled')); + end; end; // Prepare connection - if FParameters.Password <> '' then UsingPass := 'Yes' else UsingPass := 'No'; - Log(lcInfo, f_('Connecting to %s via %s, username %s, using password: %s ...', - [FParameters.Hostname, FParameters.NetTypeName(True), FParameters.Username, UsingPass] - )); - - case Parameters.NetTypeGroup of - ngMySQL: begin - FSQLSpecifities[spDatabaseDrop] := 'DROP DATABASE %s'; - FSQLSpecifities[spEmptyTable] := 'TRUNCATE '; - FSQLSpecifities[spRenameTable] := 'RENAME TABLE %s TO %s'; - FSQLSpecifities[spRenameView] := FSQLSpecifities[spRenameTable]; - FSQLSpecifities[spCurrentUserHost] := 'SELECT CURRENT_USER()'; - FSQLSpecifities[spLikeCompare] := '%s LIKE %s'; - FSQLSpecifities[spAddColumn] := 'ADD COLUMN %s'; - FSQLSpecifities[spChangeColumn] := 'CHANGE COLUMN %s %s'; - FSQLSpecifities[spGlobalStatus] := IfThen( - Parameters.IsProxySQLAdmin, - 'SELECT * FROM stats_mysql_global', - 'SHOW /*!50002 GLOBAL */ STATUS' - ); - FSQLSpecifities[spCommandsCounters] := IfThen( - Parameters.IsProxySQLAdmin, - 'SELECT * FROM stats_mysql_commands_counters', - 'SHOW /*!50002 GLOBAL */ STATUS LIKE ''Com\_%''' - ); - FSQLSpecifities[spSessionVariables] := 'SHOW VARIABLES'; - FSQLSpecifities[spGlobalVariables] := 'SHOW GLOBAL VARIABLES'; - FSQLSpecifities[spISTableSchemaCol] := 'TABLE_SCHEMA'; - FSQLSpecifities[spUSEQuery] := 'USE %s'; - FSQLSpecifities[spKillQuery] := 'KILL %d'; - FSQLSpecifities[spKillProcess] := 'KILL %d'; - FSQLSpecifities[spFuncLength] := 'LENGTH'; - FSQLSpecifities[spFuncCeil] := 'CEIL'; - FSQLSpecifities[spFuncLeft] := IfThen(Parameters.IsProxySQLAdmin, 'SUBSTR(%s, 1, %d)', 'LEFT(%s, %d)'); - FSQLSpecifities[spFuncNow] := IfThen(Parameters.IsProxySQLAdmin, 'CURRENT_TIMESTAMP', 'NOW()'); - FSQLSpecifities[spLockedTables] := ''; - end; - ngMSSQL: begin - FSQLSpecifities[spDatabaseDrop] := 'DROP DATABASE %s'; - FSQLSpecifities[spEmptyTable] := 'DELETE FROM '; - FSQLSpecifities[spRenameTable] := 'EXEC sp_rename %s, %s'; - FSQLSpecifities[spRenameView] := FSQLSpecifities[spRenameTable]; - FSQLSpecifities[spCurrentUserHost] := 'SELECT SYSTEM_USER'; - FSQLSpecifities[spLikeCompare] := '%s LIKE %s'; - FSQLSpecifities[spAddColumn] := 'ADD %s'; - FSQLSpecifities[spChangeColumn] := 'ALTER COLUMN %s %s'; - FSQLSpecifities[spSessionVariables] := 'SELECT '+QuoteIdent('comment')+', '+QuoteIdent('value')+' FROM '+QuoteIdent('master')+'.'+QuoteIdent('dbo')+'.'+QuoteIdent('syscurconfigs')+' ORDER BY '+QuoteIdent('comment'); - FSQLSpecifities[spGlobalVariables] := FSQLSpecifities[spSessionVariables]; - FSQLSpecifities[spISTableSchemaCol] := 'TABLE_CATALOG'; - FSQLSpecifities[spUSEQuery] := 'USE %s'; - FSQLSpecifities[spKillQuery] := 'KILL %d'; - FSQLSpecifities[spKillProcess] := 'KILL %d'; - FSQLSpecifities[spFuncLength] := 'LEN'; - FSQLSpecifities[spFuncCeil] := 'CEILING'; - FSQLSpecifities[spFuncLeft] := 'LEFT(%s, %d)'; - FSQLSpecifities[spFuncNow] := 'GETDATE()'; - FSQLSpecifities[spLockedTables] := ''; - end; - ngPgSQL: begin - FSQLSpecifities[spDatabaseDrop] := 'DROP SCHEMA %s'; - FSQLSpecifities[spEmptyTable] := 'DELETE FROM '; - FSQLSpecifities[spRenameTable] := 'ALTER TABLE %s RENAME TO %s'; - FSQLSpecifities[spRenameView] := 'ALTER VIEW %s RENAME TO %s'; - FSQLSpecifities[spCurrentUserHost] := 'SELECT CURRENT_USER'; - FSQLSpecifities[spLikeCompare] := '%s ILIKE %s'; - FSQLSpecifities[spAddColumn] := 'ADD %s'; - FSQLSpecifities[spChangeColumn] := 'ALTER COLUMN %s %s'; - FSQLSpecifities[spSessionVariables] := 'SHOW ALL'; - FSQLSpecifities[spGlobalVariables] := FSQLSpecifities[spSessionVariables]; - FSQLSpecifities[spISTableSchemaCol] := 'table_schema'; - FSQLSpecifities[spUSEQuery] := 'SET search_path TO %s'; - FSQLSpecifities[spKillQuery] := 'SELECT pg_cancel_backend(%d)'; - FSQLSpecifities[spKillProcess] := 'SELECT pg_cancel_backend(%d)'; - FSQLSpecifities[spFuncLength] := 'LENGTH'; - FSQLSpecifities[spFuncCeil] := 'CEIL'; - FSQLSpecifities[spFuncLeft] := 'LEFT(%s, %d)'; - FSQLSpecifities[spFuncNow] := 'NOW()'; - FSQLSpecifities[spLockedTables] := ''; - end; + UsingPass := IfThen(FParameters.Password.IsEmpty, 'No', 'Yes'); + case FParameters.NetTypeGroup of ngSQLite: begin - FSQLSpecifities[spDatabaseDrop] := 'DROP DATABASE %s'; - FSQLSpecifities[spEmptyTable] := 'TRUNCATE '; - FSQLSpecifities[spRenameTable] := 'RENAME TABLE %s TO %s'; - FSQLSpecifities[spRenameView] := FSQLSpecifities[spRenameTable]; - FSQLSpecifities[spCurrentUserHost] := 'SELECT CURRENT_USER()'; - FSQLSpecifities[spLikeCompare] := '%s LIKE %s'; - FSQLSpecifities[spAddColumn] := 'ADD COLUMN %s'; - FSQLSpecifities[spChangeColumn] := 'CHANGE COLUMN %s %s'; - FSQLSpecifities[spSessionVariables] := 'SELECT null, null'; // Todo: combine "PRAGMA pragma_list" + "PRAGMA a; PRAGMY b; ..."? - FSQLSpecifities[spGlobalVariables] := 'SHOW GLOBAL VARIABLES'; - FSQLSpecifities[spISTableSchemaCol] := 'TABLE_SCHEMA'; - FSQLSpecifities[spUSEQuery] := '-- USE %s neither supported nor required'; // Cannot be empty without causing problems - FSQLSpecifities[spKillQuery] := 'KILL %d'; - FSQLSpecifities[spKillProcess] := 'KILL %d'; - FSQLSpecifities[spFuncLength] := 'LENGTH'; - FSQLSpecifities[spFuncCeil] := 'CEIL'; - FSQLSpecifities[spFuncLeft] := 'SUBSTR(%s, 1, %d)'; - FSQLSpecifities[spFuncNow] := 'DATETIME()'; - FSQLSpecifities[spLockedTables] := ''; + Log(lcInfo, f_('Connecting to %s via %s, cipher %s, using encryption key: %s ...', + [FParameters.Hostname, FParameters.NetTypeName(True), FParameters.Username, UsingPass] + )); end; + else begin + Log(lcInfo, f_('Connecting to %s via %s, username %s, using password: %s ...', + [FParameters.Hostname, FParameters.NetTypeName(True), FParameters.Username, UsingPass] + )); + end; + end; + // Create SQL provider + case FParameters.NetTypeGroup of + ngMySQL: + FSqlProvider := TMySqlProvider.Create(FParameters.NetType); + ngMSSQL: + FSqlProvider := TMsSqlProvider.Create(FParameters.NetType); + ngPgSQL: + FSqlProvider := TPostgreSQLProvider.Create(FParameters.NetType); + ngSQLite: + FSqlProvider := TSQLiteProvider.Create(FParameters.NetType); + ngInterbase: + FSqlProvider := TInterbaseProvider.Create(FParameters.NetType); + else + raise Exception.CreateFmt(_(MsgUnhandledNetType), [Integer(FParameters.NetType)]); end; end; @@ -2718,10 +3318,10 @@ procedure TMySQLConnection.DoBeforeConnect; LibraryPath: String; begin // Init libmysql before actually connecting. - LibraryPath := ExtractFilePath(ParamStr(0)) + Parameters.LibraryOrProvider; + LibraryPath := GetLibDir + Parameters.LibraryOrProvider; Log(lcDebug, f_('Loading library file %s ...', [LibraryPath])); // Throws EDbError on any failure: - FLib := TMySQLLib.Create(LibraryPath); + FLib := TMySQLLib.Create(LibraryPath, Parameters.DefaultLibrary); Log(lcDebug, FLib.DllFile + ' v' + DecodeApiString(FLib.mysql_get_client_info) + ' loaded.'); inherited; end; @@ -2733,10 +3333,10 @@ procedure TPgConnection.DoBeforeConnect; msg: String; begin // Init lib before actually connecting. - LibraryPath := ExtractFilePath(ParamStr(0)) + Parameters.LibraryOrProvider; + LibraryPath := GetLibDir + Parameters.LibraryOrProvider; Log(lcDebug, f_('Loading library file %s ...', [LibraryPath])); try - FLib := TPostgreSQLLib.Create(LibraryPath); + FLib := TPostgreSQLLib.Create(LibraryPath, Parameters.DefaultLibrary); Log(lcDebug, FLib.DllFile + ' v' + IntToStr(FLib.PQlibVersion) + ' loaded.'); except on E:EDbError do begin @@ -2764,17 +3364,102 @@ procedure TSQLiteConnection.DoBeforeConnect; LibraryPath: String; begin // Init lib before actually connecting. - LibraryPath := ExtractFilePath(ParamStr(0)) + Parameters.LibraryOrProvider; + LibraryPath := GetLibDir + Parameters.LibraryOrProvider; Log(lcDebug, f_('Loading library file %s ...', [LibraryPath])); // Throws EDbError on any failure: - FLib := TSQLiteLib.Create(LibraryPath); + if Parameters.NetType = ntSQLite then + FLib := TSQLiteLib.Create(LibraryPath, Parameters.DefaultLibrary) + else + FLib := TSQLiteLib.CreateWithMultipleCipherFunctions(LibraryPath, Parameters.DefaultLibrary); Log(lcDebug, FLib.DllFile + ' v' + ServerVersionUntouched + ' loaded.'); inherited; end; +procedure TInterbaseConnection.DoBeforeConnect; +begin + // Todo + inherited; +end; + + +procedure TDBConnection.StartSSHTunnel(var FinalHost: String; var FinalPort: Integer); +begin + // Create SSH process + if Parameters.SSHActive and (FSecureShellCmd = nil) then begin + FSecureShellCmd := TSecureShellCmd.Create(Self); + FSecureShellCmd.Connect; + FinalHost := '127.0.0.1'; + FinalPort := FParameters.SSHLocalPort; + end; +end; + + +procedure TDBConnection.EndSSHTunnel; +begin + if FSecureShellCmd <> nil then begin + FSecureShellCmd.Free; + FSecureShellCmd := nil; + end; +end; + + procedure TDBConnection.DoAfterConnect; +var + i: Integer; + TypeOid: String; + AllEnums: TDBQuery; + AllEnumsList: TStringList; + SQLFunctionsFileOrder: String; + MajorMinorVer, MajorVer: String; + StartupScript: String; + StartupBatch: TSQLBatch; + SqlQuery: TSQLSentence; + TZI: TTimeZoneInformation; + Minutes, Hours: Integer; + Offset: String; begin + FSqlProvider.ServerVersion := ServerVersionInt; + + for i:=0 to High(Datatypes) do begin + + if Datatypes[i].NativeTypes = '?' then begin + // PG oid is set to be populated via '?' + TypeOid := GetVar('SELECT oid FROM '+QuoteIdent('pg_type')+' WHERE '+QuoteIdent('typname')+' = '+EscapeString(Datatypes[i].Name.ToLower)); + if IsNumeric(TypeOid) then begin + Datatypes[i].NativeTypes := TypeOid; + Log(lcInfo, 'Found oid/NativeTypes of '+Datatypes[i].Name+' data type: '+Datatypes[i].NativeTypes); + end + else begin + Log(lcInfo, 'No support for '+Datatypes[i].Name+' data type on this server.'); + end; + end + + else if (Datatypes[i].NativeTypes = 'e') and FSqlProvider.Has(qGetEnumTypes) then begin + // PG ENUM types populated via 'e' + AllEnums := GetResults(FSqlProvider.GetSql(qGetEnumTypes)); + AllEnumsList := TStringList.Create; + while not AllEnums.Eof do begin + AllEnumsList.Add(AllEnums.Col('enum_name')); + AllEnumsList.Add(AllEnums.Col('enum_schema') + '.' + AllEnums.Col('enum_name')); + FNamedEnums.AddPair( + AllEnums.Col('enum_name'), + AllEnums.Col('enum_labels') + ); + FNamedEnums.AddPair( + AllEnums.Col('enum_schema') + '.' + AllEnums.Col('enum_name'), + AllEnums.Col('enum_labels') + ); + AllEnums.Next; + end; + AllEnums.Free; + Datatypes[i].Names := Implode('|', AllEnumsList); + AllEnumsList.Free; + end; + + end; + + AppSettings.SessionPath := FParameters.SessionPath; AppSettings.WriteString(asServerVersionFull, FServerVersionUntouched); FParameters.ServerVersion := FServerVersionUntouched; @@ -2785,19 +3470,30 @@ procedure TDBConnection.DoAfterConnect; FKeepAliveTimer.Interval := FParameters.KeepAlive * 1000; FKeepAliveTimer.OnTimer := KeepAliveTimerEvent; end; -end; - -procedure TMySQLConnection.DoAfterConnect; -var - TZI: TTimeZoneInformation; - Minutes, Hours, i: Integer; - Offset: String; -begin - inherited; + MajorMinorVer := RegExprGetMatch('^(\d+\.\d+)', ServerVersionStr, 1); + MajorVer := RegExprGetMatch('^(\d+)\.', ServerVersionStr, 1); + + if FParameters.IsMariaDB then + SQLFunctionsFileOrder := 'mariadb'+MajorMinorVer+',mariadb'+MajorVer+',mariadb,mysql' + else if FParameters.IsAnyMySQL then + SQLFunctionsFileOrder := 'mysql'+MajorMinorVer+',mysql'+MajorVer+',mysql' + else if FParameters.IsRedshift then + SQLFunctionsFileOrder := 'redshift'+MajorMinorVer+',redshift'+MajorVer+',redshift,postgresql' + else if FParameters.IsAnyPostgreSQL then + SQLFunctionsFileOrder := 'postgresql'+MajorMinorVer+',postgresql'+MajorVer+',postgresql' + else if FParameters.IsAnyMSSQL then + SQLFunctionsFileOrder := 'mssql'+MajorMinorVer+',mssql'+MajorVer+',mssql' + else if FParameters.IsAnySQLite then + SQLFunctionsFileOrder := 'sqlite'+MajorMinorVer+',sqlite'+MajorVer+',sqlite' + else if FParameters.IsAnyInterbase then + SQLFunctionsFileOrder := 'interbase'+MajorMinorVer+',interbase'+MajorVer+',interbase' + else + SQLFunctionsFileOrder := ''; + FSQLFunctions := TSQLFunctionList.Create(Self, SQLFunctionsFileOrder); // Set timezone offset to UTC - if (ServerVersionInt >= 40103) and Parameters.LocalTimeZone then begin + if FSqlProvider.Has(qSetTimezone) and Parameters.LocalTimeZone then begin Minutes := 0; case GetTimeZoneInformation(TZI) of TIME_ZONE_ID_STANDARD: Minutes := (TZI.Bias + TZI.StandardBias); @@ -2812,48 +3508,90 @@ procedure TMySQLConnection.DoAfterConnect; else Offset := '-'; Offset := Offset + Format('%.2d:%.2d', [Abs(Hours), Abs(Minutes)]); - Query('SET time_zone='+EscapeString(Offset)); + Query(qSetTimezone, [EscapeString(Offset)]); end; + // Process startup script + StartupScript := Trim(FParameters.StartupScriptFilename); + if StartupScript <> '' then begin + StartupScript := ExpandFileName(StartupScript); + if not FileExists(StartupScript) then + Log(lcError, f_('Startup script file not found: %s', [StartupScript])) + else begin + StartupBatch := TSQLBatch.Create(FParameters.NetTypeGroup); + StartupBatch.SQL := ReadTextfile(StartupScript, nil); + for SqlQuery in StartupBatch do try + Query(SqlQuery.SQL); + except + // Suppress popup, errors get logged into SQL log + end; + StartupBatch.Free; + end; + end; +end; + + +procedure TMySQLConnection.DoAfterConnect; +var + ObjNames: TStringList; + i: Integer; +begin + inherited; + // Support microseconds in some temporal datatypes of MariaDB 5.3+ and MySQL 5.6 - if ((ServerVersionInt >= 50300) and Parameters.IsMariaDB) or - ((ServerVersionInt >= 50604) and (not Parameters.IsMariaDB)) then begin + if Has(frTemporalTypesFraction) then begin for i:=Low(FDatatypes) to High(FDatatypes) do begin - if FDatatypes[i].Index in [dtDatetime, dtDatetime2, dtTime, dtTimestamp] then + if FDatatypes[i].Index in [dbdtDatetime, dbdtDatetime2, dbdtTime, dbdtTimestamp] then FDatatypes[i].HasLength := True; end; end; - if ServerVersionInt >= 50000 then - FSQLSpecifities[spKillQuery] := 'KILL QUERY %d'; - - if (ServerVersionInt >= 50124) and (not Parameters.IsProxySQLAdmin) then - FSQLSpecifities[spLockedTables] := 'SHOW OPEN TABLES FROM %s WHERE '+QuoteIdent('in_use')+'!=0'; + // List of IS tables + try + ObjNames := GetCol('SHOW TABLES FROM '+QuoteIdent(FInfSch)); + FInformationSchemaObjects.CommaText := ObjNames.CommaText; + ObjNames.Free; + except // silently fail if IS does not exist, on super old servers + end; end; procedure TAdoDBConnection.DoAfterConnect; begin inherited; - // See http://sqlserverbuilds.blogspot.de/ - case ServerVersionInt of - 0..899: begin - FSQLSpecifities[spDatabaseTable] := QuoteIdent('master')+'..'+QuoteIdent('sysdatabases'); - FSQLSpecifities[spDatabaseTableId] := QuoteIdent('dbid'); - FSQLSpecifities[spDbObjectsTable] := '..'+QuoteIdent('sysobjects'); - FSQLSpecifities[spDbObjectsCreateCol] := 'crdate'; - FSQLSpecifities[spDbObjectsUpdateCol] := ''; - FSQLSpecifities[spDbObjectsTypeCol] := 'xtype'; - end; - else begin - FSQLSpecifities[spDatabaseTable] := QuoteIdent('sys')+'.'+QuoteIdent('databases'); - FSQLSpecifities[spDatabaseTableId] := QuoteIdent('database_id'); - FSQLSpecifities[spDbObjectsTable] := '.'+QuoteIdent('sys')+'.'+QuoteIdent('objects'); - FSQLSpecifities[spDbObjectsCreateCol] := 'create_date'; - FSQLSpecifities[spDbObjectsUpdateCol] := 'modify_date'; - FSQLSpecifities[spDbObjectsTypeCol] := 'type'; - end; - end; + // List of known IS tables + FInformationSchemaObjects.CommaText := 'CHECK_CONSTRAINTS,'+ + 'COLUMN_DOMAIN_USAGE,'+ + 'COLUMN_PRIVILEGES,'+ + 'COLUMNS,'+ + 'CONSTRAINT_COLUMN_USAGE,'+ + 'CONSTRAINT_TABLE_USAGE,'+ + 'DOMAIN_CONSTRAINTS,'+ + 'DOMAINS,'+ + 'KEY_COLUMN_USAGE,'+ + 'PARAMETERS,'+ + 'REFERENTIAL_CONSTRAINTS,'+ + 'ROUTINES,'+ + 'ROUTINE_COLUMNS,'+ + 'SCHEMATA,'+ + 'TABLE_CONSTRAINTS,'+ + 'TABLE_PRIVILEGES,'+ + 'TABLES,'+ + 'VIEW_COLUMN_USAGE,'+ + 'VIEW_TABLE_USAGE,'+ + 'VIEWS'; +end; + + +procedure TPgConnection.DoAfterConnect; +var + ObjNames: TStringList; +begin + inherited; + // List of known IS tables + ObjNames := GetCol('SELECT table_name FROM information_schema.tables WHERE table_schema='+EscapeString(FInfSch)); + FInformationSchemaObjects.CommaText := ObjNames.CommaText; + ObjNames.Free; end; @@ -2897,6 +3635,11 @@ function TAdoDBConnection.Ping(Reconnect: Boolean): Boolean; if Reconnect then Active := True; end; + end + else begin + // Not active currently, reconnect + if Reconnect then + Active := True; end; Result := FActive; // Restart keep-alive timer @@ -2930,6 +3673,11 @@ function TPGConnection.Ping(Reconnect: Boolean): Boolean; if Reconnect then Active := True; end; + end + else begin + // Not active currently, reconnect + if Reconnect then + Active := True; end; Result := FActive; // Restart keep-alive timer @@ -2958,10 +3706,28 @@ function TSQLiteConnection.Ping(Reconnect: Boolean): Boolean; end; +function TInterbaseConnection.Ping(Reconnect: Boolean): Boolean; +begin + Log(lcDebug, 'Ping server ...'); + if FActive then begin + FFDHandle.Ping; + end + else begin + // Not active currently, reconnect + if Reconnect then + Active := True; + end; + Result := FActive; + // Restart keep-alive timer + FKeepAliveTimer.Enabled := False; + FKeepAliveTimer.Enabled := True; +end; + + procedure TDBConnection.KeepAliveTimerEvent(Sender: TObject); begin // Ping server in intervals, without automatically reconnecting - if Active and (FLockedByThread = nil) then + if Active and (not IsLockedByThread) then Ping(False); end; @@ -2969,14 +3735,9 @@ procedure TDBConnection.KeepAliveTimerEvent(Sender: TObject); {** Executes a query } -procedure TMySQLConnection.Query(SQL: String; DoStoreResult: Boolean=False; LogCategory: TDBLogCategory=lcSQL); -var - QueryStatus: Integer; - NativeSQL: AnsiString; - TimerStart: Cardinal; - QueryResult: PMYSQL_RES; +procedure TDBConnection.Query(SQL: String; DoStoreResult: Boolean=False; LogCategory: TDBLogCategory=lcSQL); begin - if (FLockedByThread <> nil) and (FLockedByThread.ThreadID <> GetCurrentThreadID) then begin + if IsLockedByThread and (FLockedByThread.ThreadID <> GetCurrentThreadID) then begin Log(lcDebug, _('Waiting for running query to finish ...')); try FLockedByThread.WaitFor; @@ -2984,10 +3745,35 @@ procedure TMySQLConnection.Query(SQL: String; DoStoreResult: Boolean=False; LogC on E:EThread do; end; end; - Ping(True); Log(LogCategory, SQL); FLastQuerySQL := SQL; + FRowsFound := 0; + FRowsAffected := 0; + FWarningCount := 0; +end; + + +procedure TDBConnection.Query(QueryId: TQueryId); +begin + Query(FSqlProvider.GetSql(QueryId)); +end; + +procedure TDBConnection.Query(QueryId: TQueryId; const Args: array of const); +begin + Query(FSqlProvider.GetSql(QueryId, Args)); +end; + + +procedure TMySQLConnection.Query(SQL: String; DoStoreResult: Boolean=False; LogCategory: TDBLogCategory=lcSQL); +var + QueryStatus: Integer; + NativeSQL: AnsiString; + TimerStart: Cardinal; + QueryResult: PMYSQL_RES; +begin + inherited; + if IsUnicode then NativeSQL := UTF8Encode(SQL) else @@ -3005,9 +3791,7 @@ procedure TMySQLConnection.Query(SQL: String; DoStoreResult: Boolean=False; LogC end else begin // We must call mysql_store_result() + mysql_free_result() to unblock the connection // See: http://dev.mysql.com/doc/refman/5.0/en/mysql-store-result.html - FRowsAffected := 0; FWarningCount := FLib.mysql_warning_count(FHandle); - FRowsFound := 0; TimerStart := GetTickCount; QueryResult := FLib.mysql_store_result(FHandle); FLastQueryNetworkDuration := GetTickCount - TimerStart; @@ -3044,7 +3828,9 @@ procedure TMySQLConnection.Query(SQL: String; DoStoreResult: Boolean=False; LogC end; // more results? -1 = no, >0 = error, 0 = yes (keep looping) Inc(FStatementNum); + TimerStart := GetTickCount; QueryStatus := FLib.mysql_next_result(FHandle); + Inc(FLastQueryDuration, GetTickCount - TimerStart); if QueryStatus = 0 then QueryResult := FLib.mysql_store_result(FHandle) else if QueryStatus > 0 then begin @@ -3066,22 +3852,10 @@ procedure TAdoDBConnection.Query(SQL: String; DoStoreResult: Boolean=False; LogC QueryResult, NextResult: _RecordSet; Affected: Int64; begin - if (FLockedByThread <> nil) and (FLockedByThread.ThreadID <> GetCurrentThreadID) then begin - Log(lcDebug, _('Waiting for running query to finish ...')); - try - FLockedByThread.WaitFor; - except - on E:EThread do; - end; - end; + inherited; - Ping(True); - Log(LogCategory, SQL); - FLastQuerySQL := SQL; TimerStart := GetTickCount; SetLength(FLastRawResults, 0); - FRowsFound := 0; - FRowsAffected := 0; try QueryResult := FAdoHandle.ConnectionObject.Execute(SQL, VarRowsAffected, 1); FLastQueryDuration := GetTickCount - TimerStart; @@ -3123,27 +3897,14 @@ procedure TPGConnection.Query(SQL: String; DoStoreResult: Boolean=False; LogCate QueryStatus: Integer; NativeSQL: AnsiString; begin - if (FLockedByThread <> nil) and (FLockedByThread.ThreadID <> GetCurrentThreadID) then begin - Log(lcDebug, _('Waiting for running query to finish ...')); - try - FLockedByThread.WaitFor; - except - on E:EThread do; - end; - end; + inherited; - Ping(True); - Log(LogCategory, SQL); - FLastQuerySQL := SQL; if IsUnicode then NativeSQL := UTF8Encode(SQL) else NativeSQL := AnsiString(SQL); TimerStart := GetTickCount; SetLength(FLastRawResults, 0); - FRowsFound := 0; - FRowsAffected := 0; - FWarningCount := 0; QueryStatus := FLib.PQsendQuery(FHandle, PAnsiChar(NativeSQL)); @@ -3205,24 +3966,11 @@ procedure TSQLiteConnection.Query(SQL: String; DoStoreResult: Boolean=False; Log CurrentSQL, NextSQL: PAnsiChar; StepResult: Integer; begin - if (FLockedByThread <> nil) and (FLockedByThread.ThreadID <> GetCurrentThreadID) then begin - Log(lcDebug, _('Waiting for running query to finish ...')); - try - FLockedByThread.WaitFor; - except - on E:EThread do; - end; - end; + inherited; - Ping(True); - Log(LogCategory, SQL); - FLastQuerySQL := SQL; CurrentSQL := PAnsiChar(UTF8Encode(SQL)); TimerStart := GetTickCount; SetLength(FLastRawResults, 0); - FRowsFound := 0; - FRowsAffected := 0; - FWarningCount := 0; OldRowsAffected := FLib.sqlite3_total_changes(FHandle); // Temporary: substract these later from total num QueryResult := nil; @@ -3278,6 +4026,48 @@ procedure TSQLiteConnection.Query(SQL: String; DoStoreResult: Boolean=False; Log end; +procedure TInterbaseConnection.Query(SQL: String; DoStoreResult: Boolean=False; LogCategory: TDBLogCategory=lcSQL); +var + TimerStart: Cardinal; + FdQuery: TFDQuery; +begin + inherited; + + TimerStart := GetTickCount; + SetLength(FLastRawResults, 0); + FdQuery := TFDQuery.Create(Self); + FdQuery.Connection := FFDHandle; + // Disable paging with 50 rows + FdQuery.FetchOptions.Mode := fmAll; + FdQuery.FetchOptions.RecsMax := -1; + // Todo: suppress mouse cursor updates + try + FdQuery.ResourceOptions.CmdExecTimeout := Parameters.QueryTimeout; + if DoStoreResult then begin + FdQuery.SQL.Text := SQL; + if FdQuery.OpenOrExecute then begin + FRowsFound := FdQuery.RecordCount; + SetLength(FLastRawResults, Length(FLastRawResults)+1); + FLastRawResults[Length(FLastRawResults)-1] := FdQuery; + end; + end else begin + FdQuery.ExecSQL(SQL); + FRowsAffected := FdQuery.RowsAffected; + FdQuery.Free; + end; + FLastQueryDuration := GetTickCount - TimerStart; + FLastQueryNetworkDuration := 0; + except + on E:EFDDBEngineException do begin + SetLength(FLastRawResults, 0); + Log(lcError, GetLastErrorMsg + ' :: ' + E.Message); + raise EDbError.Create(GetLastErrorMsg); + end; + end; + FLastQueryNetworkDuration := GetTickCount - TimerStart; +end; + + function TDBConnection.GetLastResults: TDBQueryList; var r: TDBQuery; @@ -3300,7 +4090,7 @@ function TAdoDBConnection.GetLastResults: TDBQueryList; Batch: TSQLBatch; begin Result := TDBQueryList.Create(False); - Batch := TSQLBatch.Create; + Batch := TSQLBatch.Create(FParameters.NetTypeGroup); Batch.SQL := FLastQuerySQL; for i:=Low(FLastRawResults) to High(FLastRawResults) do begin r := Parameters.CreateQuery(Self); @@ -3334,7 +4124,75 @@ function TMySQLConnection.GetCreateCode(Obj: TDBObject): String; end; +function TPgConnection.GetCreateCode(Obj: TDBObject): String; +var + ProcDetails: TDBQuery; + DataType: String; + ArgNames, ArgTypes, Arguments: TStringList; + i: Integer; +begin + Result := ''; + case Obj.NodeType of + lntView: begin + // Prefer pg_catalog tables. See http://www.heidisql.com/forum.php?t=16213#p16685 + Result := 'CREATE VIEW ' + QuoteIdent(Obj.Name) + ' AS '; + if not Obj.IsMaterialized then begin // normal view + Result := Result + GetVar('SELECT '+QuoteIdent('definition')+ + ' FROM '+QuoteIdent('pg_views')+ + ' WHERE '+QuoteIdent('viewname')+'='+EscapeString(Obj.Name)+ + ' AND '+QuoteIdent('schemaname')+'='+EscapeString(Obj.Schema) + ); + end + else begin // materialized view + Result := Result + GetVar('SELECT '+QuoteIdent('definition')+ + ' FROM '+QuoteIdent('pg_matviews')+ + ' WHERE '+QuoteIdent('matviewname')+'='+EscapeString(Obj.Name)+ + ' AND '+QuoteIdent('schemaname')+'='+EscapeString(Obj.Schema) + ); + end; + + end; + lntFunction, lntProcedure: begin + Result := 'CREATE '+Obj.GetObjType.ToUpper+' '+QuoteIdent(Obj.Name); + ProcDetails := GetResults('SELECT '+ + QuoteIdent('p')+'.'+QuoteIdent('prosrc')+', '+ + QuoteIdent('p')+'.'+QuoteIdent('proargnames')+', '+ + QuoteIdent('p')+'.'+QuoteIdent('proargtypes')+', '+ + QuoteIdent('p')+'.'+QuoteIdent('prorettype')+' '+ + 'FROM '+QuoteIdent('pg_catalog')+'.'+QuoteIdent('pg_namespace')+' AS '+QuoteIdent('n')+' '+ + 'JOIN '+QuoteIdent('pg_catalog')+'.'+QuoteIdent('pg_proc')+' AS '+QuoteIdent('p')+' ON '+QuoteIdent('p')+'.'+QuoteIdent('pronamespace')+' = '+QuoteIdent('n')+'.'+QuoteIdent('oid')+' '+ + 'WHERE '+ + QuoteIdent('n')+'.'+QuoteIdent('nspname')+'='+EscapeString(Obj.Database)+ + 'AND '+QuoteIdent('p')+'.'+QuoteIdent('proname')+'='+EscapeString(Obj.Name)+ + 'AND '+QuoteIdent('p')+'.'+QuoteIdent('proargtypes')+'='+EscapeString(Obj.ArgTypes) + ); + ArgNames := Explode(',', Copy(ProcDetails.Col('proargnames'), 2, Length(ProcDetails.Col('proargnames'))-2)); + ArgTypes := Explode(' ', Copy(ProcDetails.Col('proargtypes'), 1, Length(ProcDetails.Col('proargtypes')))); + Arguments := TStringList.Create; + for i:=0 to ArgNames.Count-1 do begin + if ArgTypes.Count > i then + DataType := GetDatatypeByNativeType(MakeInt(ArgTypes[i]), ArgNames[i]).Name + else + DataType := ''; + Arguments.Add(ArgNames[i] + ' ' + DataType); + end; + Result := Result + '(' + Implode(', ', Arguments) + ') '+ + 'RETURNS '+GetDatatypeByNativeType(MakeInt(ProcDetails.Col('prorettype'))).Name+' '+ + 'AS $$ '+ProcDetails.Col('prosrc')+' $$' + // TODO: 'LANGUAGE SQL IMMUTABLE STRICT' + ; + end + else begin + // Let the generic method try to return code + Result := inherited; + end; + end; +end; + + function TSQLiteConnection.GetCreateCode(Obj: TDBObject): String; +var + CreateList: TStringList; begin // PRAGMA table_info(customers): // cid name type notnull dflt_value pk @@ -3342,8 +4200,15 @@ function TSQLiteConnection.GetCreateCode(Obj: TDBObject): String; // 1 FirstName NVARCHAR(40) 1 null 0 case Obj.NodeType of lntTable: begin + CreateList := GetCol('SELECT '+QuoteIdent('sql')+' FROM '+QuoteIdent(Obj.Database)+'.sqlite_master'+ + ' WHERE '+QuoteIdent('type')+' IN('+EscapeString('table')+', '+EscapeString('index')+')'+ + ' AND tbl_name='+EscapeString(Obj.Name)); + Result := Implode(';'+sLineBreak, CreateList); + CreateList.Free; + end; + lntView, lntTrigger: begin Result := GetVar('SELECT '+QuoteIdent('sql')+' FROM '+QuoteIdent(Obj.Database)+'.sqlite_master'+ - ' WHERE '+QuoteIdent('type')+'='+EscapeString('table')+ + ' WHERE '+QuoteIdent('type')+'='+EscapeString(Obj.ObjType.ToLower)+ ' AND name='+EscapeString(Obj.Name)); end; else begin @@ -3354,6 +4219,12 @@ function TSQLiteConnection.GetCreateCode(Obj: TDBObject): String; end; +function TInterbaseConnection.GetCreateCode(Obj: TDBObject): String; +begin + // Todo +end; + + function TMySQLConnection.GetCreateViewCode(Database, Name: String): String; var ViewIS: TDBQuery; @@ -3414,65 +4285,61 @@ function TMySQLConnection.GetCreateViewCode(Database, Name: String): String; function TDBConnection.GetCreateCode(Obj: TDBObject): String; var - ProcDetails: TDBQuery; - DataType: String; - ArgNames, ArgTypes, Arguments: TStringList; Rows: TStringList; - i: Integer; TableCols: TTableColumnList; TableCol: TTableColumn; TableKeys: TTableKeyList; TableKey: TTableKey; TableForeignKeys: TForeignKeyList; TableForeignKey: TForeignKey; - - // Return fitting schema clause for queries in IS.TABLES, IS.ROUTINES etc. - // TODO: Does not work on MSSQL 2000 - function SchemaClauseIS(Prefix: String): String; - begin - if Obj.Schema <> '' then - Result := Prefix+'_SCHEMA='+EscapeString(Obj.Schema) - else - Result := Prefix+'_CATALOG='+EscapeString(Obj.Database); - end; - + TableCheckConstraints: TCheckConstraintList; + TableCheckConstraint: TCheckConstraint; begin case Obj.NodeType of lntTable: begin Result := 'CREATE TABLE '+QuoteIdent(Obj.Name)+' ('; TableCols := Obj.GetTableColumns; for TableCol in TableCols do begin - Result := Result + CRLF + #9 + TableCol.SQLCode + ','; + Result := Result + sLineBreak + CodeIndent + TableCol.SQLCode + ','; end; TableCols.Free; TableKeys := Obj.GetTableKeys; for TableKey in TableKeys do begin - Result := Result + CRLF + #9 + TableKey.SQLCode + ','; + if TableKey.InsideCreateCode then + Result := Result + sLineBreak + CodeIndent + TableKey.SQLCode + ','; end; TableKeys.Free; TableForeignKeys := Obj.GetTableForeignKeys; for TableForeignKey in TableForeignKeys do begin - Result := Result + CRLF + #9 + TableForeignKey.SQLCode(True) + ','; + Result := Result + sLineBreak + CodeIndent + TableForeignKey.SQLCode(True) + ','; end; TableForeignKeys.Free; + TableCheckConstraints := Obj.GetTableCheckConstraints; + for TableCheckConstraint in TableCheckConstraints do begin + Result := Result + sLineBreak + CodeIndent + TableCheckConstraint.SQLCode + ','; + end; + TableCheckConstraints.Free; + Delete(Result, Length(Result), 1); - Result := Result + CRLF + ')'; + Result := Result + sLineBreak + ')'; + + TableKeys := Obj.GetTableKeys; + for TableKey in TableKeys do begin + if not TableKey.InsideCreateCode then begin + if TableKeys.IndexOf(TableKey) = 0 then + Result := Result + ';'; + Result := Result + sLineBreak + TableKey.SQLCode + ';'; + end; + end; + TableKeys.Free; end; lntView: begin case FParameters.NetTypeGroup of - ngPgSQL: begin - // Prefer pg_catalog tables. See http://www.heidisql.com/forum.php?t=16213#p16685 - Result := 'CREATE VIEW ' + QuoteIdent(Obj.Name) + ' AS ' + GetVar('SELECT '+QuoteIdent('definition')+ - ' FROM '+QuoteIdent('pg_views')+ - ' WHERE '+QuoteIdent('viewname')+'='+EscapeString(Obj.Name)+ - ' AND '+QuoteIdent('schemaname')+'='+EscapeString(Obj.Schema) - ); - end; ngMSSQL: begin // Overcome 4000 character limit in IS.VIEW_DEFINITION // See http://www.heidisql.com/forum.php?t=21097 @@ -3486,11 +4353,17 @@ function TDBConnection.GetCreateCode(Obj: TDBObject): String; ); end; else begin - Result := GetVar('SELECT VIEW_DEFINITION'+ - ' FROM '+InfSch+'.VIEWS'+ - ' WHERE TABLE_NAME='+EscapeString(Obj.Name)+ - ' AND '+SchemaClauseIS('TABLE') - ); + if not Obj.FCreateCode.IsEmpty then begin + // SQlite views go here + Result := Obj.FCreateCode; + end + else begin + Result := GetVar('SELECT VIEW_DEFINITION'+ + ' FROM '+InfSch+'.VIEWS'+ + ' WHERE TABLE_NAME='+EscapeString(Obj.Name)+ + ' AND '+Obj.SchemaClauseIS('TABLE') + ); + end; end; end; end; @@ -3505,45 +4378,15 @@ function TDBConnection.GetCreateCode(Obj: TDBObject): String; else Rows := GetCol('EXEC sp_helptext '+EscapeString(Obj.Database+'.'+Obj.Name)); // Do not use Rows.Text, as the rows already include a trailing linefeed - Result := implodestr('', Rows); + Result := Implode('', Rows); Rows.Free; end; - ngPgSQL: begin - Result := 'CREATE FUNCTION '+QuoteIdent(Obj.Name); - ProcDetails := GetResults('SELECT '+ - QuoteIdent('p')+'.'+QuoteIdent('prosrc')+', '+ - QuoteIdent('p')+'.'+QuoteIdent('proargnames')+', '+ - QuoteIdent('p')+'.'+QuoteIdent('proargtypes')+', '+ - QuoteIdent('p')+'.'+QuoteIdent('prorettype')+' '+ - 'FROM '+QuoteIdent('pg_catalog')+'.'+QuoteIdent('pg_namespace')+' AS '+QuoteIdent('n')+' '+ - 'JOIN '+QuoteIdent('pg_catalog')+'.'+QuoteIdent('pg_proc')+' AS '+QuoteIdent('p')+' ON '+QuoteIdent('p')+'.'+QuoteIdent('pronamespace')+' = '+QuoteIdent('n')+'.'+QuoteIdent('oid')+' '+ - 'WHERE '+ - QuoteIdent('n')+'.'+QuoteIdent('nspname')+'='+EscapeString(Obj.Database)+ - 'AND '+QuoteIdent('p')+'.'+QuoteIdent('proname')+'='+EscapeString(Obj.Name)+ - 'AND '+QuoteIdent('p')+'.'+QuoteIdent('proargtypes')+'='+EscapeString(Obj.ArgTypes) - ); - ArgNames := Explode(',', Copy(ProcDetails.Col('proargnames'), 2, Length(ProcDetails.Col('proargnames'))-2)); - ArgTypes := Explode(' ', Copy(ProcDetails.Col('proargtypes'), 1, Length(ProcDetails.Col('proargtypes')))); - Arguments := TStringList.Create; - for i:=0 to ArgNames.Count-1 do begin - if ArgTypes.Count > i then - DataType := GetDatatypeByNativeType(MakeInt(ArgTypes[i]), ArgNames[i]).Name - else - DataType := ''; - Arguments.Add(ArgNames[i] + ' ' + DataType); - end; - Result := Result + '(' + implodestr(', ', Arguments) + ') '+ - 'RETURNS '+GetDatatypeByNativeType(MakeInt(ProcDetails.Col('prorettype'))).Name+' '+ - 'AS $$ '+ProcDetails.Col('prosrc')+' $$' - // TODO: 'LANGUAGE SQL IMMUTABLE STRICT' - ; - end; else begin Result := GetVar('SELECT ROUTINE_DEFINITION'+ ' FROM '+InfSch+'.ROUTINES'+ ' WHERE ROUTINE_NAME='+EscapeString(Obj.Name)+ ' AND ROUTINE_TYPE='+EscapeString('FUNCTION')+ - ' AND '+SchemaClauseIS('ROUTINE') + ' AND '+Obj.SchemaClauseIS('ROUTINE') ); end; end; @@ -3557,7 +4400,7 @@ function TDBConnection.GetCreateCode(Obj: TDBObject): String; Rows := GetCol('EXEC sp_helptext '+EscapeString(Obj.Schema+'.'+Obj.Name)) else Rows := GetCol('EXEC sp_helptext '+EscapeString(Obj.Database+'.'+Obj.Name)); - Result := implodestr('', Rows); + Result := Implode('', Rows); Rows.Free; end; else begin @@ -3565,7 +4408,7 @@ function TDBConnection.GetCreateCode(Obj: TDBObject): String; ' FROM '+InfSch+'.ROUTINES'+ ' WHERE ROUTINE_NAME='+EscapeString(Obj.Name)+ ' AND ROUTINE_TYPE='+EscapeString('PROCEDURE')+ - ' AND '+SchemaClauseIS('ROUTINE') + ' AND '+Obj.SchemaClauseIS('ROUTINE') ); end; end; @@ -3591,7 +4434,7 @@ procedure TDBConnection.PrefetchCreateCode(Objects: TDBObjectList); // SHOW CREATE TRIGGER was introduced in MySQL 5.1.21 // See #111 if Obj.NodeType = lntTrigger then - UseIt := UseIt and (ServerVersionInt >= 50121); + UseIt := UseIt and FSqlProvider.Has(qShowCreateTrigger); if UseIt then Queries.Add('SHOW CREATE '+UpperCase(Obj.ObjType)+' '+QuoteIdent(Obj.Database)+'.'+QuoteIdent(Obj.Name)); end; @@ -3609,7 +4452,7 @@ procedure TDBConnection.PrefetchCreateCode(Objects: TDBObjectList); end; end; if Queries.Count > 0 then try - PrefetchResults(implodestr(';', Queries)); + PrefetchResults(Implode(';', Queries)); except on E:EDbError do; end; @@ -3642,12 +4485,16 @@ procedure TDBConnection.SetDatabase(Value: String); s := s + ', ' + EscapeString('public'); end else s := QuoteIdent(Value); - Query(GetSQLSpecifity(spUSEQuery, [s]), False); - // FDatabase is set via DetectUSEQuery + if FSqlProvider.Has(qUSEQuery) then begin + Query(qUSEQuery, [s]); + end; + FDatabase := DeQuoteIdent(Value); + if Assigned(FOnDatabaseChanged) then + FOnDatabaseChanged(Self, Value); end; // Save last used database in session, see #983 - if not FParameters.SessionName.IsEmpty then begin + if not FParameters.SessionPath.Trim.IsEmpty then begin AppSettings.SessionPath := FParameters.SessionPath; AppSettings.WriteString(asLastUsedDB, Value); end; @@ -3665,20 +4512,24 @@ procedure TDBConnection.DetectUSEQuery(SQL: String); var rx: TRegExpr; Quotes: String; + NewDb: String; begin // Detect query for switching current working database or schema rx := TRegExpr.Create; rx.ModifierI := True; - rx.Expression := '^'+GetSQLSpecifity(spUSEQuery); + rx.Expression := '^'+FSqlProvider.GetSql(qUSEQuery); Quotes := QuoteRegExprMetaChars(FQuoteChars+''';'); rx.Expression := StringReplace(rx.Expression, ' ', '\s+', [rfReplaceAll]); rx.Expression := StringReplace(rx.Expression, '%s', '['+Quotes+']?([^'+Quotes+']+)['+Quotes+']*', [rfReplaceAll]); if rx.Exec(SQL) then begin - FDatabase := Trim(rx.Match[1]); - FDatabase := DeQuoteIdent(FDatabase); - Log(lcDebug, f_('Database "%s" selected', [FDatabase])); - if Assigned(FOnDatabaseChanged) then - FOnDatabaseChanged(Self, Database); + NewDb := Trim(rx.Match[1]); + NewDb := DeQuoteIdent(NewDb); + if (not NewDb.IsEmpty) and (NewDb <> FDatabase) then begin + FDatabase := NewDb; + Log(lcDebug, f_('Database "%s" selected', [FDatabase])); + if Assigned(FOnDatabaseChanged) then + FOnDatabaseChanged(Self, Database); + end; end; rx.Free; end; @@ -3731,12 +4582,19 @@ function TSQLiteConnection.GetThreadId: Int64; if FThreadId = 0 then begin Ping(False); if FActive then // We return the application process id, as there is no connection pid in SQLite - FThreadID := Windows.GetCurrentProcessId; + FThreadID := GetCurrentProcessId; end; Result := FThreadID; end; +function TInterbaseConnection.GetThreadId: Int64; +begin + // Todo + Result := 0; +end; + + {** Return currently used character set } @@ -3748,7 +4606,6 @@ function TDBConnection.GetCharacterSet: String; function TMySQLConnection.GetCharacterSet: String; begin - Result := inherited; Result := DecodeAPIString(FLib.mysql_character_set_name(FHandle)); end; @@ -3767,18 +4624,23 @@ procedure TMySQLConnection.SetCharacterSet(CharsetName: String); Return: Integer; begin FStatementNum := 0; + Log(lcInfo, 'Changing character set from '+CharacterSet+' to '+CharsetName); Return := FLib.mysql_set_character_set(FHandle, PAnsiChar(Utf8Encode(CharsetName))); + // Return value never seems to be <> 0, not even on v3.23 servers, we check it anyway: if Return <> 0 then - raise EDbError.Create(LastErrorMsg) - else - FIsUnicode := Pos('utf8', LowerCase(CharsetName)) = 1; + raise EDbError.Create(LastErrorMsg); + // Check opt-out setting: if disabled, align the internal IsUnicode flag to the connection charset + if not FParameters.ForceUnicode then begin + FIsUnicode := CharacterSet.StartsWith('utf', True); + Log(lcInfo, 'ForceUnicode disabled in settings. Internal IsUnicode flag is now: ' + FIsUnicode.ToInteger.ToString) + end; end; procedure TPGConnection.SetCharacterSet(CharsetName: String); begin // See issue #22 - Query('SET CLIENT_ENCODING TO ' + EscapeString('UTF8')); + Query('SET CLIENT_ENCODING TO ' + EscapeString(CharsetName)); end; @@ -3810,6 +4672,26 @@ function TSQLiteConnection.GetLastErrorCode: Cardinal; end; +function TInterbaseConnection.GetLastErrorCode: Cardinal; +begin + // Note: there seem to be negative codes + Result := Abs(FLastErrorCode); +end; + + +procedure TInterbaseConnection.OnFdError(ASender: TObject; AInitiator: TObject; var AException: Exception); +var + oExc: EFDDBEngineException; +begin + if AException is EFDDBEngineException then begin + oExc := EFDDBEngineException(AException); + FLastErrorCode := oExc.ErrorCode; + FLastError := oExc.Message; + end; +end; + + + {** Return the last error nicely formatted } @@ -3823,18 +4705,13 @@ function TMySQLConnection.GetLastErrorMsg: String; Msg := DecodeAPIString(FLib.mysql_error(FHandle)); - if SynRegExpr.ExecRegExpr('(Unknown SSL error|SSL connection error)', Msg) then begin - // Find specific strings in error message and provide helpful message - Additional := f_('Please select a different library in your session settings. (Current: "%s")', [FParameters.LibraryOrProvider]); - end else begin - // Find "(errno: 123)" in message and add more meaningful message from perror.exe - rx := TRegExpr.Create; - rx.Expression := '.+\(errno\:\s+(\d+)\)'; - if rx.Exec(Msg) then begin - Additional := MySQLErrorCodes.Values[rx.Match[1]]; - end; - rx.Free; + // Find "(errno: 123)" in message and add more meaningful message from perror.exe + rx := TRegExpr.Create; + rx.Expression := '.+\(errno\:\s+(\d+)\)'; + if rx.Exec(Msg) then begin + Additional := MySQLErrorCodes.Values[rx.Match[1]]; end; + rx.Free; if Additional <> '' then begin Msg := Msg + sLineBreak + sLineBreak + Additional; @@ -3886,6 +4763,13 @@ function TSQLiteConnection.GetLastErrorMsg: String; end; +function TInterbaseConnection.GetLastErrorMsg: String; +begin + Result := f_(MsgSQLError, [LastErrorCode, FLastError]); +end; + + + {** Get version string as normalized integer "5.1.12-beta-community-123" => 50112 @@ -3898,7 +4782,7 @@ function TDBConnection.ServerVersionInt: Integer; Result := 0; rx := TRegExpr.Create; case FParameters.NetTypeGroup of - ngMySQL, ngPgSQL, ngSQLite: begin + ngMySQL, ngPgSQL, ngSQLite, ngInterbase: begin rx.Expression := '(\d+)\.(\d+)(\.(\d+))?'; if rx.Exec(FServerVersionUntouched) then begin Result := StrToIntDef(rx.Match[1], 0) *10000 + @@ -3940,7 +4824,7 @@ function TDBConnection.ServerVersionStr: String; major, minor, build: Integer; begin case FParameters.NetTypeGroup of - ngMySQL, ngPgSQL, ngSQLite: begin + ngMySQL, ngPgSQL, ngSQLite, ngInterbase: begin v := IntToStr(ServerVersionInt); major := StrToIntDef(Copy(v, 1, Length(v)-4), 0); minor := StrToIntDef(Copy(v, Length(v)-3, 2), 0); @@ -3976,27 +4860,41 @@ function TDBConnection.NdbClusterVersionInt: Integer; end; -function TDBConnection.GetAllDatabases: TStringList; +procedure TDBConnection.ShowWarnings; +begin + // Do nothing by default. SHOW WARNINGS is MySQL only. +end; + + +procedure TMySQLConnection.ShowWarnings; var - rx: TRegExpr; - dbname: String; + Warnings: TDBQuery; + Info: String; +begin + // Log warnings + // SHOW WARNINGS is implemented as of MySQL 4.1.0 + if (WarningCount > 0) and FSqlProvider.Has(qShowWarnings) then begin + Warnings := GetResults(FSqlProvider.GetSql(qShowWarnings)); + while not Warnings.Eof do begin + Log(lcError, _(Warnings.Col('Level')) + ': ('+Warnings.Col('Code')+') ' + Warnings.Col('Message')); + Warnings.Next; + end; + Warnings.Free; + end; + Info := DecodeAPIString(FLib.mysql_info(FHandle)); + if not Info.IsEmpty then begin + Log(lcInfo, _(SLogPrefixInfo) + ': ' + Info); + end; +end; + + +function TDBConnection.GetAllDatabases: TStringList; begin // Get user passed delimited list + // Ignore value in case of ntSQLiteEncrypted, when AllDatabasesStr holds encryption parameters if not Assigned(FAllDatabases) then begin - if FParameters.AllDatabasesStr <> '' then begin - FAllDatabases := TStringList.Create; - rx := TRegExpr.Create; - rx.Expression := '[^;]+'; - rx.ModifierG := True; - if rx.Exec(FParameters.AllDatabasesStr) then while true do begin - // Add if not a duplicate - dbname := Trim(rx.Match[0]); - if FAllDatabases.IndexOf(dbname) = -1 then - FAllDatabases.Add(dbname); - if not rx.ExecNext then - break; - end; - rx.Free; + if (FParameters.AllDatabasesStr <> '') and (not FParameters.IsAnySQLite) then begin + FAllDatabases := FParameters.AllDatabasesList; ApplyIgnoreDatabasePattern(FAllDatabases); end; end; @@ -4031,7 +4929,7 @@ function TAdoDBConnection.GetAllDatabases: TStringList; Result := inherited; if not Assigned(Result) then begin try - FAllDatabases := GetCol('SELECT '+QuoteIdent('name')+' FROM '+GetSQLSpecifity(spDatabaseTable)+' ORDER BY '+QuoteIdent('name')); + FAllDatabases := GetCol('SELECT '+QuoteIdent('name')+' FROM '+FSqlProvider.GetSql(qDatabaseTable)+' ORDER BY '+QuoteIdent('name')); except on E:EDbError do FAllDatabases := TStringList.Create; end; @@ -4055,7 +4953,7 @@ function TPGConnection.GetAllDatabases: TStringList; ' FROM '+QuoteIdent('pg_catalog')+'.'+QuoteIdent('pg_namespace'); if Parameters.IsRedshift then begin DbQuery := DbQuery + ' WHERE '+QuoteIdent('nspowner')+' != 1'+ - ' OR '+QuoteIdent('nspname')+' IN ('+EscapeString('pg_catalog')+', '+EscapeString(InfSch)+')'; + ' OR '+QuoteIdent('nspname')+' IN ('+EscapeString('pg_catalog')+', '+EscapeString('public')+', '+EscapeString(InfSch)+')'; end; DbQuery := DbQuery + ' ORDER BY '+QuoteIdent('nspname'); FAllDatabases := GetCol(DbQuery); @@ -4086,6 +4984,18 @@ function TSQLiteConnection.GetAllDatabases: TStringList; end; +function TInterbaseConnection.GetAllDatabases: TStringList; +begin + Result := inherited; + if not Assigned(Result) then begin + FAllDatabases := TStringList.Create; + FFDHandle.GetCatalogNames('', FAllDatabases); + ApplyIgnoreDatabasePattern(FAllDatabases); + Result := FAllDatabases; + end; +end; + + function TDBConnection.RefreshAllDatabases: TStringList; begin FreeAndNil(FAllDatabases); @@ -4150,7 +5060,7 @@ procedure TDBConnection.PrefetchResults(SQL: String); i: Integer; begin Query(SQL, True); - Batch := TSQLBatch.Create; + Batch := TSQLBatch.Create(FParameters.NetTypeGroup); Batch.SQL := SQL; FreeAndNil(FPrefetchResults); FPrefetchResults := TDBQueryList.Create(True); @@ -4177,16 +5087,70 @@ procedure TDBConnection.FreeResults(Results: TDBQuery); If running a thread, log to queue and let the main thread later do logging } procedure TDBConnection.Log(Category: TDBLogCategory; Msg: String); +var + LogMessage, + FilePath: String; + DbObj: TDBObject; + LogFileStream: TStreamWriter; + + function IsDdlQuery: Boolean; + begin + Result := Msg.StartsWith('CREATE', True) + or Msg.StartsWith('ALTER', True) + or Msg.StartsWith('DROP', True) + or Msg.StartsWith('TRUNCATE', True) + or Msg.StartsWith('COMMENT', True) + or Msg.StartsWith('RENAME', True) + ; + end; + + function IsDmlQuery: Boolean; + begin + Result := Msg.StartsWith('INSERT', True) + or Msg.StartsWith('UPDATE', True) + or Msg.StartsWith('DELETE', True) + or Msg.StartsWith('UPSERT', True) + ; + end; + begin + // If in a thread, synchronize logging with the main thread. Logging within a thread + // causes SynEdit to throw exceptions left and right. + if IsLockedByThread and (FLockedByThread.ThreadID = GetCurrentThreadID) then begin + (FLockedByThread as TQueryThread).LogFromThread(Msg, Category); + Exit; + end; + if Assigned(FOnLog) then begin + LogMessage := Msg; if FLogPrefix <> '' then - Msg := '['+FLogPrefix+'] ' + Msg; - // If in a thread, synchronize logging with the main thread. Logging within a thread - // causes SynEdit to throw exceptions left and right. - if (FLockedByThread <> nil) and (FLockedByThread.ThreadID = GetCurrentThreadID) then - (FLockedByThread as TQueryThread).LogFromOutside(Msg, Category) - else - FOnLog(Msg, Category, Self); + LogMessage := '['+FLogPrefix+'] ' + LogMessage; + FOnLog(LogMessage, Category, Self); + end; + + if Category in [lcSQL, lcUserFiredSQL, lcScript] then begin + if (Parameters.LogFileDdl and IsDdlQuery) + or (Parameters.LogFileDml and IsDmlQuery) + then begin + // Log DDL queries to migration file + DbObj := TDBObject.Create(Self); + DbObj.Database := IfThen(FDatabase.IsEmpty, 'nodb', FDatabase); + FilePath := GetOutputFilename(Parameters.LogFilePath, DbObj); + DbObj.Free; + try + ForceDirectories(ExtractFileDir(FilePath)); + LogFileStream := TStreamWriter.Create(FilePath, True, UTF8NoBOMEncoding); + LogFileStream.Write(Msg + ';' + sLineBreak); + LogFileStream.Free; + except + on E:Exception do begin + Parameters.LogFileDdl := False; + Parameters.LogFileDml := False; + Log(lcError, E.Message); + Log(lcInfo, _('Logging disabled')); + end; + end; + end; end; end; @@ -4267,12 +5231,55 @@ function TDBConnection.EscapeString(Text: String; ProcessJokerChars: Boolean=fal Result := escChars(Result, '''', '''', '''', '''', ''''); end; + ngInterbase: begin + c1 := ''''; + c2 := ''''; + c3 := ''''; + c4 := ''''; + EscChar := '\'; + Result := escChars(Text, EscChar, c1, c2, c3, c4); + end; + end; if DoQuote then begin // Add surrounding single quotes - Result := Char(#39) + Result + Char(#39); + Result := FStringQuoteChar + Result + FStringQuoteChar; + + // Support international characters with National prefix on MSSQL, see #1115, #2250, #41. + // Previously only done in some callers of EscapeString(), and only for column types dbdtNchar, dbdtNvarchar, dbdtNtext. + if FParameters.IsAnyMSSQL and (ServerVersionInt >= 1100) then + Result := 'N' + Result; + end; +end; + + +function TDBConnection.EscapeString(Text: String; Datatype: TDBDatatype): String; +var + DoQuote: Boolean; + ValuePrefix: String; +const + CategoriesNeedQuote = [dtcText, dtcBinary, dtcTemporal, dtcSpatial, dtcOther]; +begin + // Quote text based on the passed datatype + DoQuote := Datatype.Category in CategoriesNeedQuote; + ValuePrefix := ''; + case Datatype.Category of + // Some special cases + dtcBinary: begin + if IsHex(Text) then + DoQuote := False; + end; + dtcInteger, dtcReal: begin + if (not IsNumeric(Text)) and (not IsHex(Text)) then + DoQuote := True; + if (Datatype.Index = dbdtBit) and FParameters.IsAnyMySQL then begin + DoQuote := True; + ValuePrefix := 'b'; + end; + end; end; + Result := ValuePrefix + EscapeString(Text, False, DoQuote); end; @@ -4323,22 +5330,69 @@ function TDBConnection.escChars(const Text: String; EscChar, Char1, Char2, Char3 Inc(respos); Result[respos] := next; end; - until bend = len; + until bend = len; +end; + + +function TDBConnection.UnescapeString(Text: String): String; +begin + // Return text with MySQL special sequences turned back to normal characters + Result := StringReplace(Text, '\\', '\', [rfReplaceAll]); + Result := StringReplace(Result, '\0', #0, [rfReplaceAll]); + Result := StringReplace(Result, '\b', #8, [rfReplaceAll]); + Result := StringReplace(Result, '\t', #9, [rfReplaceAll]); + Result := StringReplace(Result, '\n', #10, [rfReplaceAll]); + Result := StringReplace(Result, '\r', #13, [rfReplaceAll]); + Result := StringReplace(Result, '\Z', #26, [rfReplaceAll]); + Result := StringReplace(Result, '''''', '''', [rfReplaceAll]); + Result := StringReplace(Result, '\''', '''', [rfReplaceAll]); +end; + + +function TDBConnection.EscapeBin(BinValue: String): String; +var + BinLen: Integer; + Ansi: AnsiString; +begin + // Return a binary value as hex AnsiString + Ansi := AnsiString(BinValue); + BinLen := Length(Ansi); + if BinLen = 0 then begin + Result := EscapeString(''); + end else begin + if IsHex(BinValue) then begin + Result := BinValue; // Already hex encoded + end else begin + SetLength(Result, BinLen*2); + BinToHex(PAnsiChar(Ansi), PChar(Result), BinLen); + Result := '0x' + Result; + end; + if AppSettings.ReadBool(asLowercaseHex) then + Result := Result.ToLowerInvariant; + end; end; -function TDBConnection.UnescapeString(Text: String): String; +function TDBConnection.EscapeBin(var ByteData: TBytes): String; +var + BinLen: Integer; + Ansi: AnsiString; begin - // Return text with MySQL special sequences turned back to normal characters - Result := StringReplace(Text, '\\', '\', [rfReplaceAll]); - Result := StringReplace(Result, '\0', #0, [rfReplaceAll]); - Result := StringReplace(Result, '\b', #8, [rfReplaceAll]); - Result := StringReplace(Result, '\t', #9, [rfReplaceAll]); - Result := StringReplace(Result, '\n', #10, [rfReplaceAll]); - Result := StringReplace(Result, '\r', #13, [rfReplaceAll]); - Result := StringReplace(Result, '\Z', #26, [rfReplaceAll]); - Result := StringReplace(Result, '''''', '''', [rfReplaceAll]); - Result := StringReplace(Result, '\''', '''', [rfReplaceAll]); + BinLen := Length(ByteData); + SetString(Ansi, PAnsiChar(ByteData), BinLen); + if BinLen = 0 then begin + Result := EscapeString(''); + end else begin + if IsHex(String(Ansi)) then begin + Result := String(Ansi); // Already hex encoded + end else begin + SetLength(Result, BinLen*2); + BinToHex(PAnsiChar(Ansi), PChar(Result), BinLen); + Result := '0x' + Result; + end; + if AppSettings.ReadBool(asLowercaseHex) then + Result := Result.ToLowerInvariant; + end; end; @@ -4393,6 +5447,8 @@ function TDBConnection.QuoteIdent(Identifier: String; AlwaysQuote: Boolean=True; if not AlwaysQuote then begin if MySQLKeywords.IndexOf(Result) > -1 then AlwaysQuote := True + else if SQLFunctions.Names.IndexOf(Result) > -1 then + AlwaysQuote := True else for i:=1 to Length(Result) do begin if not CharInSet(Result[i], FIdentCharsNoQuote) then begin AlwaysQuote := True; @@ -4425,6 +5481,16 @@ function TDBConnection.DeQuoteIdent(Identifier: String; Glue: Char=#0): String; end; +function TDBConnection.CleanIdent(Identifier: string): string; +begin + Result := Trim(Identifier); + // See issue #1947: + //Result := LowerCase(Result); + Result := ReplaceRegExpr('[^A-Za-z0-9]', Result, '_'); + Result := ReplaceRegExpr('_+', Result, '_'); +end; + + function TDBConnection.QuotedDbAndTableName(DB, Obj: String): String; var o: TDBObject; @@ -4448,12 +5514,14 @@ function TDBConnection.FindObject(DB, Obj: String): TDBObject; var Objects: TDBObjectList; o: TDBObject; + fqname: String; begin // Find TDBObject by db and table string Objects := GetDBObjects(DB); Result := nil; for o in Objects do begin - if o.Name = Obj then begin + fqname := o.Schema + '.' + o.Name; // includes "dbo." schema + if (o.Name = Obj) or (fqname = Obj) then begin Result := o; Break; end; @@ -4464,16 +5532,20 @@ function TDBConnection.FindObject(DB, Obj: String): TDBObject; end; -function TDBConnection.GetCol(SQL: String; Column: Integer=0): TStringList; +function TDBConnection.GetCol(SQL: String; ValueColumn: Integer=0; NameColumn: Integer=-1): TStringList; var Results: TDBQuery; begin Results := GetResults(SQL); Result := TStringList.Create; - if Results.RecordCount > 0 then while not Results.Eof do begin - Result.Add(Results.Col(Column)); - Results.Next; - end; + if Results.RecordCount > 0 then + while not Results.Eof do begin + if NameColumn < 0 then + Result.Add(Results.Col(ValueColumn)) + else + Result.AddPair(Results.Col(NameColumn), Results.Col(ValueColumn)); + Results.Next; + end; FreeResults(Results); end; @@ -4571,29 +5643,15 @@ function TDBConnection.GetCollationTable: TDBQuery; begin Log(lcDebug, 'Fetching list of collations ...'); Ping(True); - Result := FCollationTable; -end; - - -function TMySQLConnection.GetCollationTable: TDBQuery; -begin - inherited; - if (not Assigned(FCollationTable)) and (ServerVersionInt >= 40100) then - FCollationTable := GetResults('SHOW COLLATION'); - if Assigned(FCollationTable) then - FCollationTable.First; - Result := FCollationTable; -end; - - -function TAdoDBConnection.GetCollationTable: TDBQuery; -begin - inherited; - if (not Assigned(FCollationTable)) then - FCollationTable := GetResults('SELECT '+EscapeString('')+' AS '+QuoteIdent('Collation')+', '+ - EscapeString('')+' AS '+QuoteIdent('Charset')+', 0 AS '+QuoteIdent('Id')+', '+ - EscapeString('')+' AS '+QuoteIdent('Default')+', '+EscapeString('')+' AS '+QuoteIdent('Compiled')+', '+ - '1 AS '+QuoteIdent('Sortlen')); + if (not Assigned(FCollationTable)) and FSqlProvider.Has(qGetCollations) then begin + if FSqlProvider.Has(qGetCollationsExtended) then try + FCollationTable := GetResults(FSqlProvider.GetSql(qGetCollationsExtended)); + except + on E:EDbError do; + end; + if not Assigned(FCollationTable) then + FCollationTable := GetResults(FSqlProvider.GetSql(qGetCollations)); + end; if Assigned(FCollationTable) then FCollationTable.First; Result := FCollationTable; @@ -4617,48 +5675,8 @@ function TDBConnection.GetCharsetTable: TDBQuery; begin Log(lcDebug, 'Fetching charset list ...'); Ping(True); - Result := nil; -end; - - -function TMySQLConnection.GetCharsetTable: TDBQuery; -begin - inherited; - if (not Assigned(FCharsetTable)) and (ServerVersionInt >= 40100) then - FCharsetTable := GetResults('SHOW CHARSET'); - Result := FCharsetTable; -end; - - -function TAdoDBConnection.GetCharsetTable: TDBQuery; -begin - inherited; - if not Assigned(FCharsetTable) then - FCharsetTable := GetResults('SELECT '+QuoteIdent('name')+' AS '+QuoteIdent('Charset')+', '+QuoteIdent('description')+' AS '+QuoteIdent('Description')+ - ' FROM '+QuotedDbAndTableName('master', 'syscharsets') - ); - Result := FCharsetTable; -end; - - -function TPgConnection.GetCharsetTable: TDBQuery; -begin - inherited; - if not Assigned(FCharsetTable) then - FCharsetTable := GetResults('SELECT PG_ENCODING_TO_CHAR('+QuoteIdent('encid')+') AS '+QuoteIdent('Charset')+', '+EscapeString('')+' AS '+QuoteIdent('Description')+' FROM ('+ - 'SELECT '+QuoteIdent('conforencoding')+' AS '+QuoteIdent('encid')+' FROM '+QuoteIdent('pg_conversion')+', '+QuoteIdent('pg_database')+' '+ - 'WHERE '+QuoteIdent('contoencoding')+'='+QuoteIdent('encoding')+' AND '+QuoteIdent('datname')+'=CURRENT_DATABASE()) AS '+QuoteIdent('e') - ); - Result := FCharsetTable; -end; - - -function TSQLiteConnection.GetCharsetTable; -begin - inherited; - if not Assigned(FCharsetTable) then begin - //FCharsetTable := // Todo! - end; + if (not Assigned(FCharsetTable)) and FSqlProvider.Has(qGetCharsets) then + FCharsetTable := GetResults(FSqlProvider.GetSql(qGetCharsets)); Result := FCharsetTable; end; @@ -4686,7 +5704,7 @@ function TDBConnection.GetSessionVariables(Refresh: Boolean): TDBQuery; if (not Assigned(FSessionVariables)) or Refresh then begin if Assigned(FSessionVariables) then FreeAndNil(FSessionVariables); - FSessionVariables := GetResults(GetSQLSpecifity(spSessionVariables)); + FSessionVariables := GetResults(FSqlProvider.GetSql(qSessionVariables)); end; FSessionVariables.First; Result := FSessionVariables; @@ -4741,7 +5759,7 @@ function TDBConnection.GetLockedTableCount(db: String): Integer; begin // Find tables which are currently locked. // Used to prevent waiting time in GetDBObjects. - sql := GetSQLSpecifity(spLockedTables); + sql := FSqlProvider.GetSql(qLockedTables); Result := 0; if not sql.IsEmpty then try LockedTables := GetCol(Format(sql, [QuoteIdent(db,False)])); @@ -4754,13 +5772,9 @@ function TDBConnection.GetLockedTableCount(db: String): Integer; function TDBConnection.IdentifierEquals(Ident1, Ident2: String): Boolean; -var - CaseSensitivity: Integer; begin // Compare only name of identifier, in the case fashion the server tells us - // 1 is probably a bad default value, as this expects the server to run on Windows - CaseSensitivity := MakeInt(GetSessionVariable('lower_case_table_names', '1')); - case CaseSensitivity of + case FCaseSensitivity of 0: Result := Ident1 = Ident2; else Result := CompareText(Ident1, Ident2) = 0; end; @@ -4779,13 +5793,27 @@ function TDBConnection.IsTextDefault(Value: String; Tp: TDBDatatype): Boolean; Result := Result or ((ServerVersionInt < 100201) and (not Value.StartsWith('CURRENT_TIMESTAMP', True))); // Inexact fallback detection, wrong if MariaDB allows "0+1" as expression at some point Result := Result or Value.IsEmpty or IsInt(Value[1]); - end else if FParameters.IsMySQL then begin + end else if FParameters.IsAnyMySQL then begin // Only MySQL case with expression in default value is as follows: if (Tp.Category = dtcTemporal) and Value.StartsWith('CURRENT_TIMESTAMP', True) then begin Result := False; - end else begin - Result := True; + end + else if Tp.Index = dbdtBit then + Result := False + else case ServerVersionInt of + 0..80013: Result := True; + else begin + // https://dev.mysql.com/doc/refman/8.0/en/data-type-defaults.html#data-type-defaults-explicit + // MySQL 8.0.13+ expect expressions to be wrapped in (..) when you create a table. + // But checking if first char is an opening parenthesis does not work here, as we get the expression + // from IS.COLUMNS, not from SHOW CREATE TABLE. So here's a workaround for distinguishing text + // from an expression: + Result := not Value.Contains('('); + end; end; + end else if FParameters.IsAnyPostgreSQL then begin + // text only if starting with ' + Result := Value.StartsWith(''''); end else begin // MS SQL, PG and SQLite: Result := True; @@ -4798,25 +5826,43 @@ function TDBConnection.GetTableColumns(Table: TDBObject): TTableColumnList; TableIdx: Integer; ColQuery: TDBQuery; Col: TTableColumn; - dt, SchemaClause, DefText, ExtraText, MaxLen: String; + dt, DefText, ExtraText, MaxLen, ColSQL: String; begin - // Generic: query table columns from IS.COLUMNS + // Generic: query table columns from IS.COLUMNS or query from provider + Log(lcDebug, 'Getting fresh columns for '+Table.QuotedDbAndTableName); Result := TTableColumnList.Create(True); - TableIdx := InformationSchemaObjects.IndexOf('columns'); - if Table.Schema <> '' then - SchemaClause := 'TABLE_SCHEMA='+EscapeString(Table.Schema) - else - SchemaClause := GetSQLSpecifity(spISTableSchemaCol)+'='+EscapeString(Table.Database); - ColQuery := GetResults('SELECT * FROM '+QuoteIdent(InfSch)+'.'+QuoteIdent(InformationSchemaObjects[TableIdx])+ - ' WHERE '+SchemaClause+' AND TABLE_NAME='+EscapeString(Table.Name)+ - ' ORDER BY ORDINAL_POSITION'); + + if FSqlProvider.Has(qGetTableColumns) then begin + ColSQL := FSqlProvider.GetSql(qGetTableColumns, [EscapeString(Table.Schema), EscapeString(Table.Name)]); + end + else begin + TableIdx := InformationSchemaObjects.IndexOf('columns'); + if TableIdx = -1 then begin + // No is.columns table available + Exit; + end; + ColSQL := 'SELECT * FROM '+QuoteIdent(InfSch)+'.'+QuoteIdent(InformationSchemaObjects[TableIdx])+ + ' WHERE '+Table.SchemaClauseIS('TABLE')+' AND TABLE_NAME='+EscapeString(Table.Name)+ + ' ORDER BY ORDINAL_POSITION'; + end; + ColQuery := GetResults(ColSQL); + while not ColQuery.Eof do begin Col := TTableColumn.Create(Self); Result.Add(Col); Col.Name := ColQuery.Col('COLUMN_NAME'); Col.OldName := Col.Name; - // PG/MySQL use different fields: - dt := IfThen(ColQuery.ColExists('COLUMN_TYPE'), 'COLUMN_TYPE', 'DATA_TYPE'); + // MySQL and most commonly used field: + if ColQuery.ColExists('COLUMN_TYPE') then + dt := 'COLUMN_TYPE' + // PostgreSQL: + else if ColQuery.ColExists('DATA_TYPE') then begin + // user defined types, like CITEXT: + if (ColQuery.Col('DATA_TYPE').ToLower = 'user-defined') and ColQuery.ColExists('UDT_NAME') then + dt := 'UDT_NAME' + else + dt := 'DATA_TYPE'; + end; Col.ParseDatatype(ColQuery.Col(dt)); // PG/MSSQL don't include length in data type if Col.LengthSet.IsEmpty and Col.DataType.HasLength then begin @@ -4830,7 +5876,8 @@ function TDBConnection.GetTableColumns(Table: TDBObject): TTableColumnList; end; end; dtcInteger: begin - if not ColQuery.IsNull('NUMERIC_PRECISION') then begin + if (not ColQuery.IsNull('NUMERIC_PRECISION')) and Has(frIntegerDisplayWidth) then begin + // Integer display width is deprecated as of MySQL 8.0.17 MaxLen := ColQuery.Col('NUMERIC_PRECISION'); end; end; @@ -4850,34 +5897,48 @@ function TDBConnection.GetTableColumns(Table: TDBObject): TTableColumnList; end; end; end; - if (not MaxLen.IsEmpty) and (MaxLen <> Col.DataType.MaxTextLen) then + if (not MaxLen.IsEmpty) and ((MaxLen <> Col.DataType.DefaultSize.ToString) or Col.DataType.RequiresLength) then Col.LengthSet := MaxLen; end; Col.Charset := ColQuery.Col('CHARACTER_SET_NAME'); Col.Collation := ColQuery.Col('COLLATION_NAME'); // MSSQL has no expression - Col.Expression := ColQuery.Col('GENERATION_EXPRESSION', True); + Col.GenerationExpression := ColQuery.Col('GENERATION_EXPRESSION', True); + Col.GenerationExpression := UnescapeString(Col.GenerationExpression); // PG has no extra: ExtraText := ColQuery.Col('EXTRA', True); + Col.Virtuality := RegExprGetMatch('\b(\w+)\s+generated\b', ExtraText.ToLowerInvariant, 1); + Col.Invisible := ExecRegExprI('\binvisible\b', ExtraText); Col.AllowNull := ColQuery.Col('IS_NULLABLE').ToLowerInvariant = 'yes'; + Col.SRID := StrToUIntDef(ColQuery.Col('SRS_ID', True), 0); DefText := ColQuery.Col('COLUMN_DEFAULT'); Col.OnUpdateType := cdtNothing; - if ExecRegExpr('\bauto_increment\b', ExtraText.ToLowerInvariant) then begin + if DefText.StartsWith('nextval(', True) then begin + // PG auto increment + Col.DefaultType := cdtAutoInc; + Col.DefaultText := DefText; + end + else if ExecRegExpr('\bauto_increment\b', ExtraText.ToLowerInvariant) then begin + // MySQL auto increment Col.DefaultType := cdtAutoInc; - Col.DefaultText := 'AUTO_INCREMENT'; - end else if DefText.ToLowerInvariant = 'null' then begin + Col.DefaultText := FSqlProvider.GetSql(qAutoInc); + end + else if DefText.ToLowerInvariant = 'null' then begin Col.DefaultType := cdtNull; - end else if ColQuery.IsNull('COLUMN_DEFAULT') then begin + end + else if ColQuery.IsNull('COLUMN_DEFAULT') then begin if Col.AllowNull then Col.DefaultType := cdtNull else Col.DefaultType := cdtNothing; - end else if IsTextDefault(DefText, Col.DataType) then begin + end + else if IsTextDefault(DefText, Col.DataType) then begin Col.DefaultType := cdtText; Col.DefaultText := IfThen(DefText.StartsWith(''''), ExtractLiteral(DefText, ''), DefText); - end else begin + end + else begin Col.DefaultType := cdtExpression; Col.DefaultText := DefText; end; @@ -4950,7 +6011,7 @@ function TMySQLConnection.GetTableColumns(Table: TDBObject): TTableColumnList; Col.OnUpdateType := cdtNothing; if ExecRegExpr('^auto_increment$', ExtraText.ToLowerInvariant) then begin Col.DefaultType := cdtAutoInc; - Col.DefaultText := 'AUTO_INCREMENT'; + Col.DefaultText := FSqlProvider.GetSql(qAutoInc); end else if ColQuery.IsNull('Default') then begin Col.DefaultType := cdtNothing; end else if IsTextDefault(DefText, Col.DataType) then begin @@ -5014,34 +6075,6 @@ function TAdoDBConnection.GetTableColumns(Table: TDBObject): TTableColumnList; end; -function TPgConnection.GetTableColumns(Table: TDBObject): TTableColumnList; -var - Comments: TDBQuery; - TableCol: TTableColumn; -begin - Result := inherited; - // Column comments in Postgre. See issue #859 - // Todo: add current schema to WHERE clause? - Comments := GetResults('SELECT a.attname AS column, des.description AS comment'+ - ' FROM pg_attribute AS a, pg_description AS des, pg_class AS pgc'+ - ' WHERE'+ - ' pgc.oid = a.attrelid'+ - ' AND des.objoid = pgc.oid'+ - ' AND pg_table_is_visible(pgc.oid)'+ - ' AND pgc.relname = '+EscapeString(Table.Name)+ - ' AND a.attnum = des.objsubid' - ); - while not Comments.Eof do begin - for TableCol in Result do begin - if TableCol.Name = Comments.Col('column') then begin - TableCol.Comment := Comments.Col('comment'); - Break; - end; - end; - Comments.Next; - end; -end; - function TSQLiteConnection.GetTableColumns(Table: TDBObject): TTableColumnList; var ColQuery: TDBQuery; @@ -5051,7 +6084,7 @@ function TSQLiteConnection.GetTableColumns(Table: TDBObject): TTableColumnList; // Todo: include database name // Todo: default values Result := TTableColumnList.Create(True); - ColQuery := GetResults('SELECT * FROM '+QuoteIdent(Table.Database)+'.pragma_table_info('+EscapeString(Table.Name)+')'); + ColQuery := GetResults(FSqlProvider.GetSql(qGetTableColumns, [EscapeString(Table.Name), EscapeString(Table.Database)])); while not ColQuery.Eof do begin Col := TTableColumn.Create(Self); Result.Add(Col); @@ -5061,6 +6094,41 @@ function TSQLiteConnection.GetTableColumns(Table: TDBObject): TTableColumnList; Col.AllowNull := ColQuery.Col('notnull') <> '1'; Col.DefaultType := cdtNothing; Col.DefaultText := ''; + if not ColQuery.Col('dflt_value').IsEmpty then begin + Col.DefaultType := cdtText; + Col.DefaultText := ColQuery.Col('dflt_value').DeQuotedString(FStringQuoteChar); + end; + Col.OnUpdateType := cdtNothing; + Col.OnUpdateText := ''; + case StrToIntDef(ColQuery.Col('hidden'), 0) of + 1: Col.Invisible := True; + 2: Col.Virtuality := 'VIRTUAL'; + 3: Col.Virtuality := 'STORED'; + end; + ColQuery.Next; + end; + ColQuery.Free; +end; + + +function TInterbaseConnection.GetTableColumns(Table: TDBObject): TTableColumnList; +var + ColQuery: TDBQuery; + Col: TTableColumn; +begin + // Todo + Result := TTableColumnList.Create(True); + ColQuery := GetResults(FSqlProvider.GetSql(qGetTableColumns, [EscapeString(Table.Name)])); + while not ColQuery.Eof do begin + Col := TTableColumn.Create(Self); + Result.Add(Col); + Col.Name := ColQuery.Col('FIELD_NAME'); + Col.OldName := Col.Name; + //Col.ParseDatatype(ColQuery.Col('type')); + Col.DataType := GetDatatypeByNativeType(MakeInt(ColQuery.Col('FIELD_TYPE'))); + Col.AllowNull := ColQuery.IsNull('NULL_FLAG'); + Col.DefaultType := cdtNothing; + Col.DefaultText := ''; Col.OnUpdateType := cdtNothing; Col.OnUpdateText := ''; ColQuery.Next; @@ -5105,6 +6173,7 @@ function TDBConnection.GetTableKeys(Table: TDBObject): TTableKeyList; end; NewKey.Columns.Add(KeyQuery.Col('COLUMN_NAME')); NewKey.SubParts.Add(''); + NewKey.Collations.Add(''); end; KeyQuery.Next; end; @@ -5116,6 +6185,8 @@ function TMySQLConnection.GetTableKeys(Table: TDBObject): TTableKeyList; var KeyQuery, ColQuery: TDBQuery; NewKey: TTableKey; + SizeQuery: String; + SizeByIndex: TStringList; begin Result := TTableKeyList.Create(True); @@ -5136,6 +6207,7 @@ function TMySQLConnection.GetTableKeys(Table: TDBObject): TTableKeyList; end; NewKey.Columns.Add(ColQuery.Col('name')); NewKey.SubParts.Add(''); + NewKey.Collations.Add(''); ColQuery.Next; end; ColQuery.Free; @@ -5155,6 +6227,7 @@ function TMySQLConnection.GetTableKeys(Table: TDBObject): TTableKeyList; while not ColQuery.Eof do begin NewKey.Columns.Add(ColQuery.Col('name')); NewKey.SubParts.Add(''); + NewKey.Collations.Add(''); ColQuery.Next; end; ColQuery.Free; @@ -5164,7 +6237,13 @@ function TMySQLConnection.GetTableKeys(Table: TDBObject): TTableKeyList; end else begin - KeyQuery := GetResults('SHOW INDEXES FROM '+QuoteIdent(Table.Name)+' FROM '+QuoteIdent(Table.Database)); + KeyQuery := GetResults('SHOW KEYS FROM '+QuoteIdent(Table.Name)+' FROM '+QuoteIdent(Table.Database)); + SizeByIndex := nil; + if FSqlProvider.Has(qIndexSize) then try + SizeQuery := FSqlProvider.GetSql(qIndexSize, [EscapeString(Table.Database), EscapeString(Table.Name)]); + SizeByIndex := GetCol(SizeQuery, 1, 0); + except + end; NewKey := nil; while not KeyQuery.Eof do begin if (not Assigned(NewKey)) or (NewKey.Name <> KeyQuery.Col('Key_name')) then begin @@ -5178,16 +6257,39 @@ function TMySQLConnection.GetTableKeys(Table: TDBObject): TTableKeyList; NewKey.IndexType := TTableKey.UNIQUE else if CompareText(KeyQuery.Col('Index_type'), TTableKey.FULLTEXT) = 0 then NewKey.IndexType := TTableKey.FULLTEXT + else if CompareText(KeyQuery.Col('Index_type'), TTableKey.SPATIAL) = 0 then + NewKey.IndexType := TTableKey.SPATIAL + else if CompareText(KeyQuery.Col('Index_type'), TTableKey.VECTOR) = 0 then + NewKey.IndexType := TTableKey.VECTOR else NewKey.IndexType := TTableKey.KEY; - // Todo: spatial keys NewKey.OldIndexType := NewKey.IndexType; if ExecRegExpr('(BTREE|HASH)', KeyQuery.Col('Index_type')) then NewKey.Algorithm := KeyQuery.Col('Index_type'); NewKey.Comment := KeyQuery.Col('Index_comment', True); + if KeyQuery.ColumnExists('Visible') then // mysql 8 + NewKey.Visible := SameText(KeyQuery.Col('Visible'), 'yes') + else if KeyQuery.ColumnExists('Ignored') then // mariadb 10.6 + NewKey.Visible := SameText(KeyQuery.Col('Ignored'), 'NO'); + + if Assigned(SizeByIndex) then + NewKey.Size := StrToInt64Def(SizeByIndex.Values[NewKey.Name], NewKey.Size); + + end; + + if KeyQuery.ColumnExists('Expression') and (not KeyQuery.IsNull('Expression')) then begin + // Functional key part: enclose expression within parentheses to distinguish them from columns (issue #1777) + NewKey.Columns.Add('('+KeyQuery.Col('Expression')+')'); + end + else begin + // Normal column + NewKey.Columns.Add(KeyQuery.Col('Column_name')); end; - NewKey.Columns.Add(KeyQuery.Col('Column_name')); - NewKey.SubParts.Add(KeyQuery.Col('Sub_part')); + NewKey.Collations.Add(KeyQuery.Col('Collation', True)); + if NewKey.IsSpatial then + NewKey.SubParts.Add('') // Keep in sync, prevent "Incorrect prefix key" + else + NewKey.SubParts.Add(KeyQuery.Col('Sub_part')); KeyQuery.Next; end; KeyQuery.Free; @@ -5259,6 +6361,7 @@ function TPGConnection.GetTableKeys(Table: TDBObject): TTableKeyList; end; NewKey.Columns.Add(KeyQuery.Col('COLUMN_NAME')); NewKey.SubParts.Add(''); + NewKey.Collations.Add(''); KeyQuery.Next; end; KeyQuery.Free; @@ -5272,7 +6375,7 @@ function TSQLiteConnection.GetTableKeys(Table: TDBObject): TTableKeyList; begin Result := TTableKeyList.Create(True); ColQuery := GetResults('SELECT * '+ - 'FROM '+QuoteIdent(Table.Database)+'.pragma_table_info('+EscapeString(Table.Name)+') '+ + 'FROM pragma_table_xinfo('+EscapeString(Table.Name)+', '+EscapeString(Table.Database)+') '+ 'WHERE pk!=0 ORDER BY pk'); NewKey := nil; while not ColQuery.Eof do begin @@ -5286,12 +6389,13 @@ function TSQLiteConnection.GetTableKeys(Table: TDBObject): TTableKeyList; end; NewKey.Columns.Add(ColQuery.Col('name')); NewKey.SubParts.Add(''); + NewKey.Collations.Add(''); ColQuery.Next; end; ColQuery.Free; KeyQuery := GetResults('SELECT * '+ - 'FROM '+QuoteIdent(Table.Database)+'.pragma_index_list('+EscapeString(Table.Name)+') '+ + 'FROM pragma_index_list('+EscapeString(Table.Name)+', '+EscapeString(Table.Database)+') '+ 'WHERE origin!='+EscapeString('pk')); while not KeyQuery.Eof do begin NewKey := TTableKey.Create(Self); @@ -5301,10 +6405,11 @@ function TSQLiteConnection.GetTableKeys(Table: TDBObject): TTableKeyList; NewKey.IndexType := IfThen(KeyQuery.Col('unique')='0', TTableKey.KEY, TTableKey.UNIQUE); NewKey.OldIndexType := NewKey.IndexType; ColQuery := GetResults('SELECT * '+ - 'FROM '+QuoteIdent(Table.Database)+'.pragma_index_info('+EscapeString(NewKey.Name)+')'); + 'FROM pragma_index_info('+EscapeString(NewKey.Name)+', '+EscapeString(Table.Database)+')'); while not ColQuery.Eof do begin NewKey.Columns.Add(ColQuery.Col('name')); NewKey.SubParts.Add(''); + NewKey.Collations.Add(''); ColQuery.Next; end; ColQuery.Free; @@ -5314,6 +6419,12 @@ function TSQLiteConnection.GetTableKeys(Table: TDBObject): TTableKeyList; end; +function TInterbaseConnection.GetTableKeys(Table: TDBObject): TTableKeyList; +begin + Result := TTableKeyList.Create(True); +end; + + function TDBConnection.GetTableForeignKeys(Table: TDBObject): TForeignKeyList; var ForeignQuery, ColQuery: TDBQuery; @@ -5347,6 +6458,8 @@ function TDBConnection.GetTableForeignKeys(Table: TDBObject): TForeignKeyList; Result.Add(ForeignKey); ForeignKey.KeyName := ForeignQuery.Col('CONSTRAINT_NAME'); ForeignKey.OldKeyName := ForeignKey.KeyName; + ForeignKey.Db := Table.Database; + ForeignKey.ReferenceDb := ForeignQuery.Col('UNIQUE_CONSTRAINT_SCHEMA'); ForeignKey.ReferenceTable := ForeignQuery.Col('UNIQUE_CONSTRAINT_SCHEMA') + '.' + ForeignQuery.Col('REFERENCED_TABLE_NAME'); ForeignKey.OnUpdate := ForeignQuery.Col('UPDATE_RULE'); @@ -5388,14 +6501,17 @@ function TAdoDbConnection.GetTableForeignKeys(Table: TDBObject): TForeignKeyList ForeignQuery := GetResults('SELECT'+ ' f.name AS foreign_key_name,'+ ' COL_NAME(fc.parent_object_id, fc.parent_column_id) AS constraint_column_name,'+ - ' OBJECT_NAME (f.referenced_object_id) AS referenced_object,'+ + ' SCHEMA_NAME(ro.schema_id) AS referenced_schema,'+ + ' OBJECT_NAME(f.referenced_object_id) AS referenced_object,'+ ' COL_NAME(fc.referenced_object_id, fc.referenced_column_id) AS referenced_column_name,'+ ' update_referential_action_desc,'+ ' delete_referential_action_desc'+ ' FROM sys.foreign_keys AS f'+ ' INNER JOIN sys.foreign_key_columns AS fc'+ ' ON f.object_id = fc.constraint_object_id'+ - ' WHERE f.parent_object_id = OBJECT_ID('+EscapeString(Table.Name)+')' + ' INNER JOIN sys.objects AS ro'+ + ' ON ro.object_id = f.referenced_object_id'+ + ' WHERE f.parent_object_id = OBJECT_ID('+EscapeString(Table.QuotedDbAndTableName)+')' ); ForeignKey := nil; while not ForeignQuery.Eof do begin @@ -5404,7 +6520,8 @@ function TAdoDbConnection.GetTableForeignKeys(Table: TDBObject): TForeignKeyList Result.Add(ForeignKey); ForeignKey.KeyName := ForeignQuery.Col('foreign_key_name'); ForeignKey.OldKeyName := ForeignKey.KeyName; - ForeignKey.ReferenceTable := ForeignQuery.Col('referenced_object'); + ForeignKey.ReferenceTable := + ForeignQuery.Col('referenced_schema') + '.' + ForeignQuery.Col('referenced_object'); ForeignKey.OnUpdate := ForeignQuery.Col('update_referential_action_desc'); ForeignKey.OnDelete := ForeignQuery.Col('delete_referential_action_desc'); end; @@ -5424,41 +6541,63 @@ function TPgConnection.GetTableForeignKeys(Table: TDBObject): TForeignKeyList; // see #158 Result := TForeignKeyList.Create(True); try - ForeignQuery := GetResults('SELECT'+ - ' refc.constraint_name,'+ - ' refc.update_rule,'+ - ' refc.delete_rule,'+ - ' kcu.table_name,'+ - ' STRING_AGG(distinct kcu.column_name, '','') AS columns,'+ - ' ccu.table_schema AS ref_schema,'+ - ' ccu.table_name AS ref_table,'+ - ' STRING_AGG(distinct ccu.column_name, '','') AS ref_columns,'+ - ' STRING_AGG(distinct kcu.ordinal_position::text, '','') AS ord_position'+ - ' FROM'+ - ' '+InfSch+'.referential_constraints AS refc,'+ - ' '+InfSch+'.key_column_usage AS kcu,'+ - ' '+InfSch+'.constraint_column_usage AS ccu'+ - ' WHERE'+ - ' refc.constraint_schema = '+EscapeString(Table.Schema)+ - ' AND refc.constraint_name = kcu.constraint_name'+ - ' AND refc.constraint_schema = kcu.table_schema'+ - ' AND ccu.constraint_name = refc.constraint_name'+ - ' AND kcu.table_name = '+EscapeString(Table.Name)+ - ' GROUP BY'+ - ' refc.constraint_name,'+ - ' refc.update_rule,'+ - ' refc.delete_rule,'+ - ' kcu.table_name,'+ - ' ccu.table_schema,'+ - ' ccu.table_name'+ - ' ORDER BY'+ - ' ord_position' - ); + ForeignQuery := GetResults( + 'SELECT ' + + ' con.conname AS constraint_name, ' + + ' CASE con.confupdtype ' + + ' WHEN ''a'' THEN ''NO ACTION'' ' + + ' WHEN ''r'' THEN ''RESTRICT'' ' + + ' WHEN ''c'' THEN ''CASCADE'' ' + + ' WHEN ''n'' THEN ''SET NULL'' ' + + ' WHEN ''d'' THEN ''SET DEFAULT'' ' + + ' END AS update_rule, ' + + ' CASE con.confdeltype ' + + ' WHEN ''a'' THEN ''NO ACTION'' ' + + ' WHEN ''r'' THEN ''RESTRICT'' ' + + ' WHEN ''c'' THEN ''CASCADE'' ' + + ' WHEN ''n'' THEN ''SET NULL'' ' + + ' WHEN ''d'' THEN ''SET DEFAULT'' ' + + ' END AS delete_rule, ' + + ' src_ns.nspname AS table_schema, ' + + ' src_tbl.relname AS table_name, ' + + ' string_agg(src_col.attname, '','' ORDER BY ord.pos) AS columns, ' + + ' ref_ns.nspname AS ref_schema, ' + + ' ref_tbl.relname AS ref_table, ' + + ' string_agg(ref_col.attname, '','' ORDER BY ord.pos) AS ref_columns, ' + + ' string_agg(ord.pos::text, '','' ORDER BY ord.pos) AS ord_position ' + + 'FROM pg_constraint con ' + + 'JOIN pg_class src_tbl ON src_tbl.oid = con.conrelid ' + + 'JOIN pg_namespace src_ns ON src_ns.oid = src_tbl.relnamespace ' + + 'JOIN LATERAL unnest(con.conkey) WITH ORDINALITY AS ord(attnum, pos) ON TRUE ' + + 'JOIN pg_attribute src_col ON src_col.attrelid = src_tbl.oid AND src_col.attnum = ord.attnum ' + + 'JOIN pg_class ref_tbl ON ref_tbl.oid = con.confrelid ' + + 'JOIN pg_namespace ref_ns ON ref_ns.oid = ref_tbl.relnamespace ' + + 'JOIN LATERAL unnest(con.confkey) WITH ORDINALITY AS ref_ord(attnum, pos) ' + + ' ON ref_ord.pos = ord.pos ' + + 'JOIN pg_attribute ref_col ON ref_col.attrelid = ref_tbl.oid AND ref_col.attnum = ref_ord.attnum ' + + 'WHERE ' + + ' con.contype = ''f'' ' + + ' AND src_ns.nspname = '+EscapeString(Table.Schema) + + ' AND src_tbl.relname = '+EscapeString(Table.Name) + + 'GROUP BY ' + + ' con.conname, ' + + ' con.confupdtype, ' + + ' con.confdeltype, ' + + ' src_ns.nspname, ' + + ' src_tbl.relname, ' + + ' ref_ns.nspname, ' + + ' ref_tbl.relname ' + + 'ORDER BY ' + + ' MIN(ord.pos)' + ); + while not ForeignQuery.Eof do begin ForeignKey := TForeignKey.Create(Self); Result.Add(ForeignKey); ForeignKey.KeyName := ForeignQuery.Col('constraint_name'); ForeignKey.OldKeyName := ForeignKey.KeyName; + ForeignKey.Db := Table.Schema; + ForeignKey.ReferenceDb := ForeignQuery.Col('ref_schema'); ForeignKey.ReferenceTable := ForeignQuery.Col('ref_schema')+'.'+ForeignQuery.Col('ref_table'); ForeignKey.OnUpdate := ForeignQuery.Col('update_rule'); ForeignKey.OnDelete := ForeignQuery.Col('delete_rule'); @@ -5485,7 +6624,7 @@ function TSQLiteConnection.GetTableForeignKeys(Table: TDBObject): TForeignKeyLis // SQLite: query PRAGMA foreign_key_list Result := TForeignKeyList.Create(True); ForeignQuery := GetResults('SELECT * '+ - 'FROM '+QuoteIdent(Table.Database)+'.pragma_foreign_key_list('+EscapeString(Table.Name)+')'); + 'FROM pragma_foreign_key_list('+EscapeString(Table.Name)+', '+EscapeString(Table.Database)+')'); ForeignKey := nil; while not ForeignQuery.Eof do begin if (not Assigned(ForeignKey)) or (ForeignKey.KeyName <> ForeignQuery.Col('id')) then begin @@ -5505,63 +6644,196 @@ function TSQLiteConnection.GetTableForeignKeys(Table: TDBObject): TForeignKeyLis end; -function TMySQLConnection.GetRowCount(Obj: TDBObject): Int64; +function TInterbaseConnection.GetTableForeignKeys(Table: TDBObject): TForeignKeyList; var - Rows: String; + ForeignQuery: TDBQuery; + ForeignKey: TForeignKey; begin - // Get row number from a mysql table - if Parameters.IsProxySQLAdmin then - Rows := GetVar('SELECT COUNT(*) FROM '+QuoteIdent(Obj.Database)+'.'+QuoteIdent(Obj.Name), 0) - else - Rows := GetVar('SHOW TABLE STATUS LIKE '+EscapeString(Obj.Name), 'Rows'); - Result := MakeInt(Rows); + // SQLite: query PRAGMA foreign_key_list + Result := TForeignKeyList.Create(True); + ForeignQuery := GetResults( + 'select strc.rdb$relation_name' +#13#10+ + ' , strc.rdb$constraint_name' +#13#10+ + ' , fkrc.rdb$relation_name as "ReferenceTable"' +#13#10+ + ' , stis.rdb$field_name as "from"' +#13#10+ + ' , fkis.rdb$field_name as "to"' +#13#10+ + ' , rdb$ref_constraints.rdb$update_rule' +#13#10+ + ' , rdb$ref_constraints.rdb$delete_rule' +#13#10+ + ' from rdb$relation_constraints strc' +#13#10+ + ' join rdb$ref_constraints on RDB$REF_CONSTRAINTS.rdb$constraint_name = strc.rdb$constraint_name' +#13#10+ + ' join rdb$relation_constraints fkrc on fkrc.rdb$constraint_name = rdb$ref_constraints.rdb$const_name_uq' +#13#10+ + ' join rdb$index_segments stis on stis.rdb$index_name = strc.rdb$index_name' +#13#10+ + ' join rdb$index_segments fkis on fkis.rdb$index_name = fkrc.rdb$index_name' +#13#10+ + ' where strc.rdb$relation_name = ' +QuotedStr(Table.Name)+#13#10+ + ' and strc.rdb$constraint_type = ''FOREIGN KEY'''); + + ForeignKey := nil; + while not ForeignQuery.Eof do begin + if (not Assigned(ForeignKey)) or (ForeignKey.KeyName <> ForeignQuery.Col('rdb$constraint_name')) then begin + ForeignKey := TForeignKey.Create(Self); + Result.Add(ForeignKey); + ForeignKey.KeyName := ForeignQuery.Col('rdb$constraint_name'); + ForeignKey.OldKeyName := ForeignKey.KeyName; + ForeignKey.ReferenceTable := ForeignQuery.Col('ReferenceTable'); + ForeignKey.OnUpdate := ForeignQuery.Col('rdb$update_rule'); + ForeignKey.OnDelete := ForeignQuery.Col('rdb$delete_rule'); + end; + ForeignKey.Columns.Add(ForeignQuery.Col('from')); + ForeignKey.ForeignColumns.Add(ForeignQuery.Col('to')); + ForeignQuery.Next; + end; + ForeignQuery.Free; end; +procedure TSQLiteConnection.GetColumnDefaultExpressions(Items: TStrings); +begin + // Add some extra default values allowed for SQLite + inherited; + Items.Add('CURRENT_TIME'); + Items.Add('CURRENT_DATE'); + Items.Add('CURRENT_TIMESTAMP'); +end; -function TAdoDBConnection.GetRowCount(Obj: TDBObject): Int64; +function TDBConnection.GetTableCheckConstraints(Table: TDBObject): TCheckConstraintList; var - Rows: String; + CheckQuery: TDBQuery; + CheckConstraint: TCheckConstraint; + ConTableIdx, TconTableIdx: Integer; begin - // Get row number from a mssql table - if ServerVersionInt >= 900 then begin - Rows := GetVar('SELECT SUM('+QuoteIdent('rows')+') FROM '+QuoteIdent('sys')+'.'+QuoteIdent('partitions')+ - ' WHERE '+QuoteIdent('index_id')+' IN (0, 1)'+ - ' AND '+QuoteIdent('object_id')+' = object_id('+EscapeString(Obj.Database+'.'+Obj.Schema+'.'+Obj.Name)+')' - ); - end else begin - Rows := GetVar('SELECT COUNT(*) FROM '+Obj.QuotedDbAndTableName); + Result := TCheckConstraintList.Create(True); + ConTableIdx := FInformationSchemaObjects.IndexOf('CHECK_CONSTRAINTS'); + TconTableIdx := FInformationSchemaObjects.IndexOf('TABLE_CONSTRAINTS'); + if (ConTableIdx = -1) or (TconTableIdx = -1) then + Exit; + + try + if FParameters.IsMariaDB then begin + CheckQuery := GetResults('SELECT CONSTRAINT_NAME, CHECK_CLAUSE'+ + ' FROM '+QuoteIdent(InfSch)+'.'+QuoteIdent(FInformationSchemaObjects[ConTableIdx])+ + ' WHERE'+ + ' '+Table.SchemaClauseIS('CONSTRAINT')+ + ' AND TABLE_NAME='+EscapeString(Table.Name) + ); + end + else begin + CheckQuery := GetResults('SELECT tc.CONSTRAINT_NAME, cc.CHECK_CLAUSE'+ + ' FROM '+QuoteIdent(InfSch)+'.'+QuoteIdent(FInformationSchemaObjects[ConTableIdx])+' AS cc, '+ + QuoteIdent(InfSch)+'.'+QuoteIdent(FInformationSchemaObjects[TconTableIdx])+' AS tc'+ + ' WHERE'+ + ' '+Table.SchemaClauseIS('tc.CONSTRAINT')+ + ' AND tc.TABLE_NAME='+EscapeString(Table.Name)+ + ' AND tc.CONSTRAINT_TYPE='+EscapeString('CHECK')+ + ' AND tc.CONSTRAINT_SCHEMA=cc.CONSTRAINT_SCHEMA'+ + ' AND tc.CONSTRAINT_NAME=cc.CONSTRAINT_NAME'+ + IfThen(FParameters.IsAnyPostgreSQL, ' AND cc.CONSTRAINT_NAME NOT LIKE '+EscapeString('%\_not\_null'), '') + ); + end; + while not CheckQuery.Eof do begin + CheckConstraint := TCheckConstraint.Create(Self); + Result.Add(CheckConstraint); + CheckConstraint.Name := CheckQuery.Col('CONSTRAINT_NAME'); + CheckConstraint.CheckClause := CheckQuery.Col('CHECK_CLAUSE'); + CheckQuery.Next; + end; + CheckQuery.Free; + except + on E:EDbError do begin + Log(lcError, 'Detection of check constraints disabled due to error in query'); + // Table is likely not there or does not have expected columns - prevent further queries with the same error: + FInformationSchemaObjects.Delete(ConTableIdx); + end; end; - Result := MakeInt(Rows); end; -function TPgConnection.GetRowCount(Obj: TDBObject): Int64; +function TDBConnection.IsNumeric(Text: String): Boolean; +begin + // Check if value is an integer or float number + Result := ExecRegExpr('^[+-]?\d+(\.\d+)?$', Text); +end; + + +function TDBConnection.IsHex(Text: String): Boolean; var - Rows: String; + i, Len: Integer; +const + HexChars: TSysCharSet = ['0'..'9','a'..'f', 'A'..'F']; begin - // Get row number from a postgres table - Rows := GetVar('SELECT '+QuoteIdent('reltuples')+'::bigint FROM '+QuoteIdent('pg_class')+ - ' LEFT JOIN '+QuoteIdent('pg_namespace')+ - ' ON ('+QuoteIdent('pg_namespace')+'.'+QuoteIdent('oid')+' = '+QuoteIdent('pg_class')+'.'+QuoteIdent('relnamespace')+')'+ - ' WHERE '+QuoteIdent('pg_class')+'.'+QuoteIdent('relkind')+'='+EscapeString('r')+ - ' AND '+QuoteIdent('pg_namespace')+'.'+QuoteIdent('nspname')+'='+EscapeString(Obj.Database)+ - ' AND '+QuoteIdent('pg_class')+'.'+QuoteIdent('relname')+'='+EscapeString(Obj.Name) - ); - Result := MakeInt(Rows); + // Check first kilobyte of passed text whether it's a hex encoded string. Hopefully faster than a regex. + Result := False; + Len := Length(Text); + if Len >= 3 then begin + Result := (Text[1] = '0') and (Text[2] = 'x'); + if Result then begin + for i:=3 to SIZE_KB do begin + if not CharInSet(Text[i], HexChars) then begin + Result := False; + Break; + end; + if i >= Len then + Break; + end; + end; + end; +end; + +function TDBConnection.Has(Item: TFeatureOrRequirement): Boolean; +begin + case FParameters.NetTypeGroup of + ngMySQL: + case Item of + frSrid: Result := FParameters.IsMySQL(True) and (ServerVersionInt >= 80000); + frTemporalTypesFraction: Result := (FParameters.IsMariaDB and (ServerVersionInt >= 50300)) or + (FParameters.IsMySQL(True) and (ServerVersionInt >= 50604)); + frIntegerDisplayWidth: Result := (FParameters.IsMySQL(True) and (ServerVersionInt < 80017)) or + (not FParameters.IsMySQL(True)); + frColumnDefaultParentheses: Result := FParameters.IsMySQL(True) and (ServerVersionInt >= 80013); + frEditVariables: Result := ServerVersionInt >= 40003; + frCreateView: Result := ServerVersionInt >= 50001; + frCreateProcedure: Result := ServerVersionInt >= 50003; + frCreateFunction: Result := ServerVersionInt >= 50003; + frCreateTrigger: Result := ServerVersionInt >= 50002; + frCreateEvent: Result := ServerVersionInt >= 50100; + frInvisibleColumns: Result := (FParameters.IsMariaDB and (ServerVersionInt >= 100303)) or + (FParameters.IsMySQL(True) and (ServerVersionInt >= 80023)); + frCompressedColumns: Result := (FParameters.IsMariaDB and (ServerVersionInt >= 100301)); + else Result := False; + end; + else Result := False; + end; +end; + + +procedure TDBConnection.GetColumnDefaultExpressions(Items: TStrings); +var + SQLFunc: TSQLFunction; +begin + for SQLFunc in SQLFunctions do begin + Items.Add(SQLFunc.Name + SQLFunc.Declaration); + end; end; -function TSQLiteConnection.GetRowCount(Obj: TDBObject): Int64; +function TDBConnection.GetRowCount(Obj: TDBObject; ForceExact: Boolean=False): Int64; var - Rows: String; + Rows, QueryApprox, QueryExact: String; + RowsColumn: Integer; begin // Get row number from a table - Rows := GetVar('SELECT COUNT(*) FROM '+QuoteIdent(Obj.Database)+'.'+QuoteIdent(Obj.Name), 0); + QueryApprox := FSqlProvider.GetSql(qGetRowCountApprox, Obj.AsStringMap); + if QueryApprox.IsEmpty or ForceExact then begin + QueryExact := FSqlProvider.GetSql(qGetRowCountExact, Obj.AsStringMap); + Rows := GetVar(QueryExact); + end + else begin + // This is ugly: in MySQL 4.x we only have SHOW TABLE STATUS, which cannot be limited to the "Rows" column + RowsColumn := IfThen(QueryApprox.StartsWith('SHOW ', True), 4, 0); + Rows := GetVar(QueryApprox, RowsColumn); + end; Result := MakeInt(Rows); end; - procedure TDBConnection.Drop(Obj: TDBObject); begin Query('DROP '+UpperCase(Obj.ObjType)+' '+Obj.QuotedName); @@ -5580,84 +6852,18 @@ procedure TPgConnection.Drop(Obj: TDBObject); Params := TRoutineParamList.Create; ParseRoutineStructure(Obj, Params); for i:=0 to Params.Count-1 do begin - if Obj.NodeType = lntProcedure then - sql := sql + Params[i].Context + ' '; - sql := sql + QuoteIdent(Params[i].Name) + ' ' + Params[i].Datatype; - if i < Params.Count-1 then - sql := sql + ', '; - end; - sql := sql + ')'; - Query(sql); - end; - else - inherited; - end; -end; - - -function TDBConnection.GetSQLSpecifity(Specifity: TSQLSpecifityId): String; -begin - // Return some version specific SQL clause or snippet - Result := FSQLSpecifities[Specifity]; -end; - - -function TDBConnection.GetSQLSpecifity(Specifity: TSQLSpecifityId; const Args: array of const): String; -begin - Result := GetSQLSpecifity(Specifity); - Result := Format(Result, Args); -end; - - -function TDBConnection.GetInformationSchemaObjects: TStringList; -var - Objects: TDBObjectList; - Obj: TDBObject; -begin - Log(lcDebug, 'Fetching objects in '+InfSch+' db ...'); - Ping(True); - if not Assigned(FInformationSchemaObjects) then begin - FInformationSchemaObjects := TStringList.Create; - // Need to find strings case insensitively: - FInformationSchemaObjects.CaseSensitive := False; - // Gracefully return an empty list on old servers - if AllDatabases.IndexOf(InfSch) > -1 then begin - Objects := GetDBObjects(InfSch); - for Obj in Objects do - FInformationSchemaObjects.Add(Obj.Name); + if Obj.NodeType = lntProcedure then + sql := sql + Params[i].Context + ' '; + sql := sql + QuoteIdent(Params[i].Name) + ' ' + Params[i].Datatype; + if i < Params.Count-1 then + sql := sql + ', '; + end; + sql := sql + ')'; + Query(sql); end; + else + inherited; end; - Result := FInformationSchemaObjects; -end; - - -function TAdoDBConnection.GetInformationSchemaObjects: TStringList; -begin - // MS SQL hides information_schema - inherited; - if FInformationSchemaObjects.Count = 0 then begin - FInformationSchemaObjects.CommaText := 'CHECK_CONSTRAINTS,'+ - 'COLUMN_DOMAIN_USAGE,'+ - 'COLUMN_PRIVILEGES,'+ - 'COLUMNS,'+ - 'CONSTRAINT_COLUMN_USAGE,'+ - 'CONSTRAINT_TABLE_USAGE,'+ - 'DOMAIN_CONSTRAINTS,'+ - 'DOMAINS,'+ - 'KEY_COLUMN_USAGE,'+ - 'PARAMETERS,'+ - 'REFERENTIAL_CONSTRAINTS,'+ - 'ROUTINES,'+ - 'ROUTINE_COLUMNS,'+ - 'SCHEMATA,'+ - 'TABLE_CONSTRAINTS,'+ - 'TABLE_PRIVILEGES,'+ - 'TABLES,'+ - 'VIEW_COLUMN_USAGE,'+ - 'VIEW_TABLE_USAGE,'+ - 'VIEWS'; - end; - Result := FInformationSchemaObjects; end; @@ -5672,6 +6878,8 @@ function TDBConnection.ResultCount; Result := Length(TPGConnection(Self).LastRawResults); ngSQLite: Result := Length(TSQLiteConnection(Self).LastRawResults); + ngInterbase: + Result := Length(TInterbaseConnection(Self).LastRawResults); else raise Exception.CreateFmt(_(MsgUnhandledNetType), [Integer(Parameters.NetType)]); end; @@ -5716,8 +6924,10 @@ function TDBConnection.GetCurrentUserHostCombination: String; // Return current user@host combination, used by various object editors for DEFINER clauses Log(lcDebug, 'Fetching user@host ...'); Ping(True); - if FCurrentUserHostCombination = '' then - FCurrentUserHostCombination := GetVar(GetSQLSpecifity(spCurrentUserHost)); + if FCurrentUserHostCombination.IsEmpty and (not FSqlProvider.GetSql(qCurrentUserHost).IsEmpty) then + FCurrentUserHostCombination := GetVar(FSqlProvider.GetSql(qCurrentUserHost)) + else + FCurrentUserHostCombination := ''; Result := FCurrentUserHostCombination; end; @@ -5739,41 +6949,6 @@ function TDBConnection.GetAllUserHostCombinations: TStringList; end; -function TDBConnection.ExplainAnalyzer(SQL, DatabaseName: String): Boolean; -begin - Result := False; - MessageDialog(_('Not implemented for this DBMS'), mtError, [mbOK]); -end; - - -function TMySQLConnection.ExplainAnalyzer(SQL, DatabaseName: String): Boolean; -var - Results: TDBQuery; - Raw, URL: String; - i: Integer; -begin - // Send EXPLAIN output to MariaDB.org - Result := True; - Database := DatabaseName; - Results := GetResults('EXPLAIN '+SQL); - Raw := '+' + CRLF + '|'; - for i:=0 to Results.ColumnCount-1 do begin - Raw := Raw + Results.ColumnNames[i] + '|'; - end; - Raw := Raw + CRLF + '+'; - while not Results.Eof do begin - Raw := Raw + CRLF + '|'; - for i:=0 to Results.ColumnCount-1 do begin - Raw := Raw + Results.Col(i) + '|'; - end; - Results.Next; - end; - Raw := Raw + CRLF; - URL := 'https://mariadb.org/explain_analyzer/analyze/?raw_explain='+EncodeURLParam(Raw)+'&client='+APPNAME; - ShellExec(URL); -end; - - function TDBConnection.GetDateTimeValue(Input: String; Datatype: TDBDatatypeIndex): String; var rx: TRegExpr; @@ -5805,9 +6980,13 @@ procedure TDBConnection.ClearCache(IncludeDBObjects: Boolean); FreeAndNil(FCharsetTable); FreeAndNil(FSessionVariables); FreeAndNil(FTableEngines); - FreeAndNil(FInformationSchemaObjects); - if IncludeDBObjects then + if IncludeDBObjects then begin ClearAllDbObjects; + FColumnCache.Clear; + FKeyCache.Clear; + FForeignKeyCache.Clear; + FCheckConstraintCache.Clear; + end; FTableEngineDefault := ''; FCurrentUserHostCombination := ''; FThreadID := 0; @@ -5879,54 +7058,106 @@ function TDBConnection.ParseDateTime(Str: String): TDateTime; function TDBConnection.GetDbObjects(db: String; Refresh: Boolean=False; OnlyNodeType: TListNodeType=lntNone): TDBObjectList; var - Cache: TDBObjectList; - i: Integer; + CacheAllTypes, TempList: TDBObjectList; + i, j, ObjIndex: Integer; + DbObjectCopy: TDBObject; begin // Cache and return a db's table list - if Refresh then - ClearDbObjects(db); - // Find list in cache - Cache := nil; + // Find all-types list in cache + CacheAllTypes := nil; for i:=0 to FDatabaseCache.Count-1 do begin - if FDatabaseCache[i].Database = db then begin - Cache := FDatabaseCache[i]; - break; + if (FDatabaseCache[i].Database = db) and (FDatabaseCache[i].OnlyNodeType=lntNone) then begin + CacheAllTypes := FDatabaseCache[i]; + Break; end; end; - // Fill cache if not yet fetched - if not Assigned(Cache) then begin - Cache := TDBObjectList.Create(TDBObjectComparer.Create); - Cache.OwnsObjects := True; - Cache.FLastUpdate := 0; - Cache.FDataSize := 0; - Cache.FDatabase := db; - FetchDbObjects(db, Cache); + // First time creation of all-types list + if CacheAllTypes = nil then begin + CacheAllTypes := TDBObjectList.Create(TDBObjectComparer.Create, True); + CacheAllTypes.FOnlyNodeType := lntNone; + CacheAllTypes.FDatabase := db; + CacheAllTypes.FObjectsLoaded := False; + FDatabaseCache.Add(CacheAllTypes); + end; + // Fill all-types list if not yet fetched + if (not CacheAllTypes.FObjectsLoaded) or Refresh then begin + TempList := TDBObjectList.Create(TDBObjectComparer.Create, False); + FetchDbObjects(db, TempList); // Find youngest last update - for i:=0 to Cache.Count-1 do - Cache.FLastUpdate := Max(Cache.FLastUpdate, Max(Cache[i].Updated, Cache[i].Created)); + for i:=0 to TempList.Count-1 do begin + TempList.FLastUpdate := Max(TempList.FLastUpdate, Max(TempList[i].Updated, TempList[i].Created)); + end; // Sort list like it get sorted in AnyGridCompareNodes - Cache.Sort; - // Add list of objects in this database to cached list of all databases - FDatabaseCache.Add(Cache); + TempList.Sort; + + CacheAllTypes.FLargestObjectSize := TempList.FLargestObjectSize; + CacheAllTypes.FLastUpdate := TempList.FLastUpdate; + CacheAllTypes.FDataSize := TempList.FDataSize; + CacheAllTypes.FObjectsLoaded := True; + // Assign templist properties to existing objects and add non existing + for i:=0 to TempList.Count-1 do begin + ObjIndex := -1; + for j:=0 to CacheAllTypes.Count-1 do begin + if CacheAllTypes[j].IsSameAs(TempList[i]) then begin + ObjIndex := j; + Break; + end; + end; + if ObjIndex > -1 then + CacheAllTypes[ObjIndex].Assign(TempList[i]) + else + CacheAllTypes.Add(TempList[i]); + end; + // Delete no longer existing + for i:=0 to CacheAllTypes.Count-1 do begin + ObjIndex := -1; + for j:=0 to TempList.Count-1 do begin + if TempList[j].IsSameAs(CacheAllTypes[i]) then begin + ObjIndex := j; + Break; + end; + end; + if ObjIndex = -1 then + CacheAllTypes.Delete(i); + end; + // Free list, clear detail caches and call change event + TempList.Free; + FColumnCache.Clear; + FKeyCache.Clear; + FForeignKeyCache.Clear; + FCheckConstraintCache.Clear; if Assigned(FOnObjectnamesChanged) then - FOnObjectnamesChanged(Self, FDatabase); + FOnObjectnamesChanged(Self, db); end; - if OnlyNodeType = lntNone then begin - Result := Cache; - end else begin - Result := TDBObjectList.Create(TDBObjectComparer.Create); - Result.OwnsObjects := False; - Result.FLastUpdate := Cache.FLastUpdate; - Result.FDataSize := Cache.FDataSize; - Result.FDatabase := Cache.FDatabase; - Result.FCollation := Cache.FCollation; - for i:=0 to Cache.Count-1 do begin - if Cache[i].NodeType = OnlyNodeType then - Result.Add(Cache[i]); + // Now we can see if we already have a result with the right type. + // All-types list is already there, so this first loop should find it. + Result := nil; + for i:=0 to FDatabaseCache.Count-1 do begin + if (FDatabaseCache[i].Database = db) and (FDatabaseCache[i].OnlyNodeType=OnlyNodeType) then begin + Result := FDatabaseCache[i]; + break; + end; + end; + // Certain-types list not yet in cache. Create and cache it + if Result = nil then begin + Result := TDBObjectList.Create(TDBObjectComparer.Create, True); + Result.FOnlyNodeType := OnlyNodeType; + Result.FLastUpdate := CacheAllTypes.FLastUpdate; + Result.FDataSize := CacheAllTypes.FDataSize; + Result.FObjectsLoaded := True; + Result.FDatabase := CacheAllTypes.FDatabase; + Result.FCollation := CacheAllTypes.FCollation; + for i:=0 to CacheAllTypes.Count-1 do begin + if CacheAllTypes[i].NodeType = OnlyNodeType then begin + DbObjectCopy := TDBObject.Create(Self); + DbObjectCopy.Assign(CacheAllTypes[i]); + Result.Add(DbObjectCopy); + end; end; + FDatabaseCache.Add(Result); end; end; @@ -5936,6 +7167,7 @@ procedure TMySQLConnection.FetchDbObjects(db: String; var Cache: TDBObjectList); obj: TDBObject; Results: TDBQuery; rx: TRegExpr; + SchemaBug41907Exists, DbNameMatches: Boolean; begin // Return a db's table list try @@ -6025,8 +7257,8 @@ procedure TMySQLConnection.FetchDbObjects(db: String; var Cache: TDBObjectList); end; // Stored functions - if (ServerVersionInt >= 50000) and (not Parameters.IsProxySQLAdmin) then try - Results := GetResults('SHOW FUNCTION STATUS WHERE '+QuoteIdent('Db')+'='+EscapeString(db)); + if FSqlProvider.Has(qShowFunctionStatus) then try + Results := GetResults(FSqlProvider.GetSql(qShowFunctionStatus, [EscapeString(db)])); except on E:EDbError do; end; @@ -6046,8 +7278,8 @@ procedure TMySQLConnection.FetchDbObjects(db: String; var Cache: TDBObjectList); end; // Stored procedures - if (ServerVersionInt >= 50000) and (not Parameters.IsProxySQLAdmin) then try - Results := GetResults('SHOW PROCEDURE STATUS WHERE '+QuoteIdent('Db')+'='+EscapeString(db)); + if FSqlProvider.Has(qShowProcedureStatus) then try + Results := GetResults(FSqlProvider.GetSql(qShowProcedureStatus, [EscapeString(db)])); except on E:EDbError do; end; @@ -6067,8 +7299,8 @@ procedure TMySQLConnection.FetchDbObjects(db: String; var Cache: TDBObjectList); end; // Triggers - if (ServerVersionInt >= 50010) and (not Parameters.IsProxySQLAdmin) then try - Results := GetResults('SHOW TRIGGERS FROM '+QuoteIdent(db)); + if FSqlProvider.Has(qShowTriggers) then try + Results := GetResults(FSqlProvider.GetSql(qShowTriggers, [QuoteIdent(db)])); except on E:EDbError do; end; @@ -6087,9 +7319,8 @@ procedure TMySQLConnection.FetchDbObjects(db: String; var Cache: TDBObjectList); end; // Events - if (ServerVersionInt >= 50100) and (not Parameters.IsProxySQLAdmin) then try - Results := GetResults('SELECT *, EVENT_SCHEMA AS '+QuoteIdent('Db')+', EVENT_NAME AS '+QuoteIdent('Name')+ - ' FROM '+InfSch+'.'+QuoteIdent('EVENTS')+' WHERE '+QuoteIdent('EVENT_SCHEMA')+'='+EscapeString(db)) + if FSqlProvider.Has(qShowEvents) then try + Results := GetResults(FSqlProvider.GetSql(qShowEvents, [EscapeString(db)])); except on E:EDbError do begin try @@ -6100,8 +7331,14 @@ procedure TMySQLConnection.FetchDbObjects(db: String; var Cache: TDBObjectList); end; end; if Assigned(Results) then begin + // Work around old MySQL bug: https://bugs.mysql.com/bug.php?id=41907#c360194 + // "Noted [fixed] in 5.1.57, 5.5.12, 5.6.3 changelogs." + SchemaBug41907Exists := (ServerVersionInt < 50157) or + ((ServerVersionInt >= 50500) and (ServerVersionInt < 50512)) or + ((ServerVersionInt >= 50600) and (ServerVersionInt < 50603)); while not Results.Eof do begin - if Results.Col('Db') = db then begin + DbNameMatches := CompareText(Results.Col('Db'), db) = 0; + if (SchemaBug41907Exists and DbNameMatches) or (not SchemaBug41907Exists) then begin Obj := TDBObject.Create(Self); Cache.Add(obj); Obj.Name := Results.Col('Name'); @@ -6129,13 +7366,19 @@ procedure TAdoDBConnection.FetchDbObjects(db: String; var Cache: TDBObjectList); // Tables, views and procedures Results := nil; // Schema support introduced in MSSQL 2005 (9.0). See issue #3212. + // RowsInTable added in 12.16 SchemaSelect := EscapeString(''); if ServerVersionInt >= 900 then SchemaSelect := 'SCHEMA_NAME('+QuoteIdent('schema_id')+')'; try - Results := GetResults('SELECT *, '+SchemaSelect+' AS '+EscapeString('schema')+ - ' FROM '+QuoteIdent(db)+GetSQLSpecifity(spDbObjectsTable)+ - ' WHERE '+QuoteIdent('type')+' IN ('+EscapeString('P')+', '+EscapeString('U')+', '+EscapeString('V')+', '+EscapeString('TR')+', '+EscapeString('FN')+', '+EscapeString('TF')+', '+EscapeString('IF')+')'); + Results := GetResults('SELECT o.*, '+SchemaSelect+' AS '+EscapeString('schema')+', rc.RowsInTable'+ + ' FROM '+QuoteIdent(db)+FSqlProvider.GetSql(qDbObjectsTable)+ ' AS o'+ + ' LEFT JOIN ('+ + ' SELECT object_id, SUM(rows) AS RowsInTable FROM '+QuoteIdent(db)+'.sys.partitions'+ + ' WHERE index_id IN (0,1)'+ // -- heap or clustered index + ' GROUP BY object_id'+ + ' ) AS rc ON rc.object_id = o.object_id'+ + ' WHERE o.'+QuoteIdent('type')+' IN ('+EscapeString('P')+', '+EscapeString('U')+', '+EscapeString('V')+', '+EscapeString('TR')+', '+EscapeString('FN')+', '+EscapeString('TF')+', '+EscapeString('IF')+')'); except on E:EDbError do; end; @@ -6144,11 +7387,11 @@ procedure TAdoDBConnection.FetchDbObjects(db: String; var Cache: TDBObjectList); obj := TDBObject.Create(Self); Cache.Add(obj); obj.Name := Results.Col('name'); - obj.Created := ParseDateTime(Results.Col(GetSQLSpecifity(spDbObjectsCreateCol), True)); - obj.Updated := ParseDateTime(Results.Col(GetSQLSpecifity(spDbObjectsUpdateCol), True)); + obj.Created := ParseDateTime(Results.Col(FSqlProvider.GetSql(qDbObjectsCreateCol), True)); + obj.Updated := ParseDateTime(Results.Col(FSqlProvider.GetSql(qDbObjectsUpdateCol), True)); obj.Schema := Results.Col('schema'); obj.Database := db; - tp := Trim(Results.Col(GetSQLSpecifity(spDbObjectsTypeCol), True)); + tp := Trim(Results.Col(FSqlProvider.GetSql(qDbObjectsTypeCol), True)); if tp = 'U' then obj.NodeType := lntTable else if tp = 'P' then @@ -6159,6 +7402,13 @@ procedure TAdoDBConnection.FetchDbObjects(db: String; var Cache: TDBObjectList); obj.NodeType := lntTrigger else if (tp = 'FN') or (tp = 'TF') or (tp = 'IF') then obj.NodeType := lntFunction; + obj.Rows := StrToInt64Def(Results.Col('RowsInTable'), -1); + obj.RowsAreExact := False; // approximate, not guaranteed exact. + // Set reasonable default value for calculation of export chunks. See #343 + // OFFSET..FETCH supported from v11.0/2012 + // Disabled, leave at -1 and prefer a generic calculation in TfrmTableTools.DoExport + //if ServerVersionInt >= 1100 then + // obj.AvgRowLen := 10*SIZE_KB; Results.Next; end; FreeAndNil(Results); @@ -6170,35 +7420,53 @@ procedure TPGConnection.FetchDbObjects(db: String; var Cache: TDBObjectList); var obj: TDBObject; Results: TDBQuery; - tp, SchemaTable: String; - DataLenClause, IndexLenClause: String; + tp: String; + DataLenClause, IndexLenClause, ProKindClause: String; begin // Tables, views and procedures Results := nil; try - // See http://www.heidisql.com/forum.php?t=16429 - if ServerVersionInt >= 70300 then - SchemaTable := 'QUOTE_IDENT(t.TABLE_SCHEMA) || '+EscapeString('.')+' || QUOTE_IDENT(t.TABLE_NAME)' - else - SchemaTable := EscapeString(FQuoteChar)+' || t.TABLE_SCHEMA || '+EscapeString(FQuoteChar+'.'+FQuoteChar)+' || t.TABLE_NAME || '+EscapeString(FQuoteChar); // See http://www.heidisql.com/forum.php?t=16996 if Parameters.FullTableStatus and (ServerVersionInt >= 90000) then - DataLenClause := 'pg_table_size('+SchemaTable+')::bigint' + DataLenClause := 'pg_table_size(format(''%I.%I'', n.nspname, c.relname))::bigint' else DataLenClause := 'NULL'; // See https://www.heidisql.com/forum.php?t=34635 if Parameters.FullTableStatus and (ServerVersionInt >= 80100) then - IndexLenClause := 'pg_relation_size('+SchemaTable+')::bigint' + IndexLenClause := 'pg_relation_size(format(''%I.%I'', n.nspname, c.relname))::bigint' else IndexLenClause := 'relpages::bigint * '+SIZE_KB.ToString; - Results := GetResults('SELECT *,'+ - ' '+DataLenClause+' AS data_length,'+ - ' '+IndexLenClause+' AS index_length,'+ - ' c.reltuples, obj_description(c.oid) AS comment'+ - ' FROM '+QuoteIdent(InfSch)+'.'+QuoteIdent('tables')+' AS t'+ - ' LEFT JOIN '+QuoteIdent('pg_namespace')+' n ON t.table_schema = n.nspname'+ - ' LEFT JOIN '+QuoteIdent('pg_class')+' c ON n.oid = c.relnamespace AND c.relname=t.table_name'+ - ' WHERE t.'+QuoteIdent('table_schema')+'='+EscapeString(db) // Use table_schema when using schemata + if ServerVersionInt >= 110000 then + ProKindClause := 'p.prokind' + else + ProKindClause := EscapeString('p'); + Results := GetResults('SELECT '+ + ' n.nspname AS schema_name, '+ + ' c.relname AS object_name, '+ + ' c.relkind AS object_kind, '+ + ' '+DataLenClause+' AS data_length, '+ + ' '+IndexLenClause+' AS index_length, '+ + ' c.reltuples, '+ + ' obj_description(c.oid) AS comment, '+ + ' NULL AS proargtypes '+ + 'FROM pg_class c '+ + 'JOIN pg_namespace n ON n.oid = c.relnamespace '+ + 'WHERE n.nspname = '+EscapeString(db)+' '+ + ' AND c.relkind IN (''r'',''v'',''m'') '+ + 'UNION ALL '+ + 'SELECT '+ + ' n.nspname AS schema_name, '+ + ' p.proname AS object_name, '+ + ' '+ProKindClause+' AS object_kind, '+ + ' NULL::bigint AS data_length, '+ + ' NULL::bigint AS index_length, '+ + ' NULL::real AS reltuples, '+ + ' obj_description(p.oid) AS comment, '+ + ' p.proargtypes '+ + 'FROM pg_proc p '+ + 'JOIN pg_namespace n ON n.oid = p.pronamespace '+ + 'WHERE n.nspname = '+EscapeString(db)+' '+ + ' AND '+ProKindClause+' IN (''f'',''p'') ' ); except on E:EDbError do; @@ -6207,11 +7475,11 @@ procedure TPGConnection.FetchDbObjects(db: String; var Cache: TDBObjectList); while not Results.Eof do begin obj := TDBObject.Create(Self); Cache.Add(obj); - obj.Name := Results.Col('table_name'); + obj.Name := Results.Col('object_name'); obj.Created := 0; obj.Updated := 0; obj.Database := db; - obj.Schema := Results.Col('table_schema'); // Remove when using schemata + obj.Schema := Results.Col('schema_name'); // Remove when using schemata obj.Comment := Results.Col('comment'); obj.Rows := StrToInt64Def(Results.Col('reltuples'), obj.Rows); obj.DataLen := StrToInt64Def(Results.Col('data_length'), obj.DataLen); @@ -6219,24 +7487,43 @@ procedure TPGConnection.FetchDbObjects(db: String; var Cache: TDBObjectList); obj.Size := obj.DataLen + obj.IndexLen; Inc(Cache.FDataSize, Obj.Size); Cache.FLargestObjectSize := Max(Cache.FLargestObjectSize, Obj.Size); - tp := Results.Col('table_type', True); - if tp = 'VIEW' then - obj.NodeType := lntView - else - obj.NodeType := lntTable; + tp := Results.Col('object_kind', True); + if tp = 'r' then + obj.NodeType := lntTable + else if tp = 'v' then begin + obj.NodeType := lntView; + obj.IsMaterialized := False; + end + else if tp = 'm' then begin + obj.NodeType := lntView; + obj.IsMaterialized := True; + end + else if tp = 'f' then + obj.NodeType := lntFunction + else if tp = 'p' then + obj.NodeType := lntProcedure; + obj.ArgTypes := Results.Col('proargtypes'); Results.Next; end; FreeAndNil(Results); end; - // Stored functions. No procedures in PostgreSQL. - // See http://dba.stackexchange.com/questions/2357/what-are-the-differences-between-stored-procedures-and-stored-functions +end; + + +procedure TSQLiteConnection.FetchDbObjects(db: String; var Cache: TDBObjectList); +var + obj: TDBObject; + Results: TDBQuery; + TypeS: String; + UnionRowCount: TStringList; +begin + // Tables, views and procedures + Results := nil; try - Results := GetResults('SELECT '+QuoteIdent('p')+'.'+QuoteIdent('proname')+', '+QuoteIdent('p')+'.'+QuoteIdent('proargtypes')+' '+ - 'FROM '+QuoteIdent('pg_catalog')+'.'+QuoteIdent('pg_namespace')+' AS '+QuoteIdent('n')+' '+ - 'JOIN '+QuoteIdent('pg_catalog')+'.'+QuoteIdent('pg_proc')+' AS '+QuoteIdent('p')+' ON '+QuoteIdent('p')+'.'+QuoteIdent('pronamespace')+' = '+QuoteIdent('n')+'.'+QuoteIdent('oid')+' '+ - 'WHERE '+QuoteIdent('n')+'.'+QuoteIdent('nspname')+'='+EscapeString(db) - ); + Results := GetResults('SELECT * FROM '+QuoteIdent(db)+'.sqlite_master '+ + 'WHERE type IN('+EscapeString('table')+', '+EscapeString('view')+', '+EscapeString('trigger')+') '+ + 'AND name NOT LIKE '+EscapeString('sqlite_%')); except on E:EDbError do; end; @@ -6244,78 +7531,208 @@ procedure TPGConnection.FetchDbObjects(db: String; var Cache: TDBObjectList); while not Results.Eof do begin obj := TDBObject.Create(Self); Cache.Add(obj); - obj.Name := Results.Col('proname'); - obj.ArgTypes := Results.Col('proargtypes'); + obj.Name := Results.Col('name'); + obj.Created := Now; + obj.Updated := Now; obj.Database := db; - obj.NodeType := lntFunction; + TypeS := Results.Col('type').ToLowerInvariant; + if TypeS = 'view' then begin + obj.NodeType := lntView; + obj.FCreateCode := Results.Col('sql'); + end else if TypeS = 'trigger' then begin + obj.NodeType := lntTrigger; + obj.FCreateCode := Results.Col('sql'); + end else + obj.NodeType := lntTable; Results.Next; end; FreeAndNil(Results); - end; + if FParameters.FullTableStatus then begin + UnionRowCount := TStringList.Create; + for obj in Cache do begin + if obj.NodeType <> lntTable then + Continue; + UnionRowCount.Add('SELECT '+EscapeString(obj.Name)+', COUNT(*) FROM '+QuoteIdent(obj.Database)+'.'+QuoteIdent(obj.Name)); + end; + if UnionRowCount.Count > 0 then + try + Results := GetResults(Implode(' UNION ', UnionRowCount)); + while not Results.Eof do begin + for obj in Cache do begin + if (obj.NodeType = lntTable) and (obj.Name = Results.Col(0)) then begin + obj.Rows := StrToInt64Def(Results.Col(1), -1); + obj.RowsAreExact := True; + break; + end; + end; + Results.Next; + end; + FreeAndNil(Results); + except + on E:EDbError do + Log(lcError, 'Full table status with row count not available in this database'); + end; + UnionRowCount.Free; + end; + end; end; -procedure TSQLiteConnection.FetchDbObjects(db: String; var Cache: TDBObjectList); +procedure TInterbaseConnection.FetchDbObjects(db: String; var Cache: TDBObjectList); var obj: TDBObject; Results: TDBQuery; begin - // Tables, views and procedures + // Tables and views Results := nil; try - Results := GetResults('SELECT * FROM '+QuoteIdent(db)+'.sqlite_master '+ - 'WHERE type='+EscapeString('table')+' AND name NOT LIKE '+EscapeString('sqlite_%')); + Results := GetResults('SELECT RDB$RELATION_NAME, RDB$DESCRIPTION, RDB$RELATION_TYPE AS '+QuoteIdent('ViewContext') + + ' FROM RDB$RELATIONS WHERE RDB$RELATIONS.RDB$SYSTEM_FLAG = 0'); + try + while not Results.Eof do begin + obj := TDBObject.Create(Self); + Cache.Add(obj); + obj.Name := Results.Col(0); + obj.Created := Now; + obj.Updated := Now; + obj.Database := db; + obj.Comment := Results.Col('RDB$DESCRIPTION'); + + if Parameters.IsInterbase then + begin + if Results.Col('ViewContext') = 'PERSISTENT' then + obj.NodeType := lntTable + else + obj.NodeType := lntView; + end + else + begin + if Results.Col('ViewContext') = '0' then + obj.NodeType := lntTable + else + obj.NodeType := lntView; + end; + Results.Next; + end; + finally + FreeAndNil(Results); + end; except on E:EDbError do; end; - if Assigned(Results) then begin + + // Procedures + try + Results := GetResults('SELECT RDB$PROCEDURE_NAME, RDB$DESCRIPTION FROM RDB$PROCEDURES WHERE RDB$SYSTEM_FLAG = 0'); + try + while not Results.Eof do begin obj := TDBObject.Create(Self); Cache.Add(obj); - obj.Name := Results.Col('name'); + obj.Name := Results.Col('RDB$PROCEDURE_NAME'); + obj.Database := db; + Obj.NodeType := lntProcedure; + obj.Created := Now; + obj.Updated := Now; + Obj.Comment := Results.Col('RDB$DESCRIPTION'); + Results.Next; + end; + finally + FreeAndNil(Results); + end; + except + on E:EDbError do; + end; + + // Triggers + try + Results := GetResults('SELECT RDB$TRIGGER_NAME, RDB$DESCRIPTION FROM RDB$TRIGGERS WHERE RDB$SYSTEM_FLAG = 0'); + try + + while not Results.Eof do begin + obj := TDBObject.Create(Self); + Cache.Add(obj); + obj.Name := Results.Col('RDB$TRIGGER_NAME'); + obj.Database := db; + Obj.NodeType := lntTrigger; obj.Created := Now; obj.Updated := Now; + Obj.Comment := Results.Col('RDB$DESCRIPTION'); + Results.Next; + end; + finally + FreeAndNil(Results); + end; + except + on E:EDbError do; + end; + + // Functions + try + Results := GetResults('SELECT rdb$function_name, RDB$DESCRIPTION FROM rdb$functions WHERE RDB$SYSTEM_FLAG = 0'); + try + + while not Results.Eof do begin + obj := TDBObject.Create(Self); + Cache.Add(obj); + obj.Name := Results.Col('RDB$function_name'); obj.Database := db; - obj.NodeType := lntTable; + Obj.NodeType := lntFunction; + obj.Created := Now; + obj.Updated := Now; + Obj.Comment := Results.Col('RDB$DESCRIPTION'); Results.Next; end; - FreeAndNil(Results); + finally + FreeAndNil(Results); + end; + except + on E:EDbError do; end; + end; -function TDBConnection.GetKeyColumns(Columns: TTableColumnList; Keys: TTableKeyList): TStringList; +function TDBConnection.GetKeyColumns(Columns: TTableColumnList; Keys: TTableKeyList): TTableColumnList; var - i: Integer; AllowsNull: Boolean; Key: TTableKey; Col: TTableColumn; + ColName: String; begin - Result := TStringList.Create; + Result := TTableColumnList.Create; // Find best key for updates // 1. round: find a primary key for Key in Keys do begin - if Key.IndexType = TTableKey.PRIMARY then - Result.Assign(Key.Columns); + if Key.IsPrimary then + begin + for ColName in Key.Columns do begin + Col := Columns.FindByName(ColName); + if Assigned(Col) then + Result.Add(Col); + end; + end; end; if Result.Count = 0 then begin // no primary key available -> 2. round: find a unique key for Key in Keys do begin - if Key.IndexType = TTableKey.UNIQUE then begin + if Key.IsUnique then begin // We found a UNIQUE key - better than nothing. Check if one of the key // columns allows NULLs which makes it dangerous to use in UPDATES + DELETES. AllowsNull := False; - for i:=0 to Key.Columns.Count-1 do begin - for Col in Columns do begin - if Col.Name = Key.Columns[i] then - AllowsNull := Col.AllowNull; - if AllowsNull then break; - end; - if AllowsNull then break; + for ColName in Key.Columns do begin + Col := Columns.FindByName(ColName); + AllowsNull := Assigned(Col) and Col.AllowNull; + if AllowsNull then + break; // Unusable, don't use this key end; if not AllowsNull then begin - Result.Assign(Key.Columns); + for ColName in Key.Columns do begin + Col := Columns.FindByName(ColName); + if Assigned(Col) then + Result.Add(Col); + end; break; end; end; @@ -6458,7 +7875,7 @@ procedure TDBConnection.ParseViewStructure(CreateCode: String; DBObj: TDBObject; CheckOption := Trim(rx.Match[11]); SelectCode := rx.Match[9]; end else - raise Exception.CreateFmt(_('Regular expression did not match the VIEW code in %s: %s'), ['ParseViewStructure()', CRLF+CRLF+CreateCode]); + Log(lcError, f_('Regular expression did not match the VIEW code in %s: %s', ['ParseViewStructure()', CRLF+CRLF+CreateCode])); rx.Free; end; @@ -6508,6 +7925,7 @@ procedure TDBConnection.ParseRoutineStructure(Obj: TDBObject; Parameters: TRouti if (CreateCode[i] = '(') and (not InLiteral) then Inc(ParenthesesCount); end; + Params := TSQLBatch.GetSQLWithoutComments(Params); // Extract parameters from left part rx.Expression := '(^|,)\s*((IN|OUT|INOUT)\s+)?(\S+)\s+([^\s,\(]+(\([^\)]*\))?[^,]*)'; @@ -6532,7 +7950,7 @@ procedure TDBConnection.ParseRoutineStructure(Obj: TDBObject; Parameters: TRouti // | SQL SECURITY { DEFINER | INVOKER } // | COMMENT 'string' rx.Expression := '^\s*('+ - 'RETURNS\s+(\S+(\s+UNSIGNED)?(\s+CHARSET\s+\S+)?(\s+COLLATE\s\S+)?)|'+ + 'RETURNS\s+((\S+\([^\)]+\)|\S+)(\s+UNSIGNED)?(\s+CHARSET\s+\S+)?(\s+COLLATE\s\S+)?)|'+ // MySQL function characteristics - see http://dev.mysql.com/doc/refman/5.1/de/create-procedure.html 'LANGUAGE\s+SQL|'+ '(NOT\s+)?DETERMINISTIC|'+ @@ -6560,7 +7978,7 @@ procedure TDBConnection.ParseRoutineStructure(Obj: TDBObject; Parameters: TRouti else if (Pos('CONTAINS SQL', Match) = 1) or (Pos('NO SQL', Match) = 1) or (Pos('READS SQL DATA', Match) = 1) or (Pos('MODIFIES SQL DATA', Match) = 1) then Obj.DataAccess := rx.Match[1] else if Pos('SQL SECURITY', Match) = 1 then - Obj.Security := rx.Match[7]; + Obj.Security := rx.Match[8]; Delete(Body, 1, rx.MatchLen[0]); @@ -6587,13 +8005,23 @@ function TDBConnection.ApplyLimitClause(QueryType, QueryBody: String; Limit, Off Result := QueryType + ' '; case FParameters.NetTypeGroup of ngMSSQL: begin - if QueryType = 'UPDATE' then begin + if (QueryType = 'UPDATE') or (QueryType = 'DELETE') then begin // TOP(x) clause for UPDATES + DELETES introduced in MSSQL 2005 if ServerVersionInt >= 900 then Result := Result + 'TOP('+IntToStr(Limit)+') '; - end else if QueryType = 'SELECT' then - Result := Result + 'TOP '+IntToStr(Limit)+' '; - Result := Result + QueryBody; + Result := Result + QueryBody; + end else if QueryType = 'SELECT' then begin + if ServerVersionInt >= 1100 then begin + Result := Result + QueryBody; + if not ContainsText(Result, ' ORDER BY ') then + Result := Result + ' ORDER BY 1'; // mandatory for using with OFFSET/FETCH + Result := Result + ' OFFSET '+Offset.ToString+' ROWS FETCH NEXT '+Limit.ToString+' ROWS ONLY'; + end else begin + // OFFSET not supported in < 2012 + Result := Result + 'TOP ' + IntToStr(Limit) + ' ' + QueryBody; + end; + end else + Result := Result + QueryBody; end; ngMySQL: begin Result := Result + QueryBody + ' LIMIT '; @@ -6620,6 +8048,10 @@ function TDBConnection.ApplyLimitClause(QueryType, QueryBody: String; Limit, Off Result := Result + IntToStr(Limit); end; end; + ngInterbase: begin + // No support for limit nor offset + Result := Result + QueryBody; + end; end; end; @@ -6674,6 +8106,13 @@ constructor TSQLiteQuery.Create(AOwner: TComponent); end; +constructor TInterbaseQuery.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + FConnection := AOwner as TInterbaseConnection; +end; + + destructor TDBQuery.Destroy; begin FreeAndNil(FColumnNames); @@ -6746,6 +8185,36 @@ destructor TSQLiteQuery.Destroy; end; +destructor TInterbaseQuery.Destroy; +var + i: Integer; +begin + if HasResult and (FConnection <> nil) and (FConnection.Active) then begin + for i:=Low(FResultList) to High(FResultList) do begin + FResultList[i].Close; + FResultList[i].Free; + end; + end; + SetLength(FResultList, 0); + inherited; +end; + + +procedure TDBQuery.LogMetaInfo(NumResult: Integer); +var + MetaInfo: String; +begin + // Debug log output after DBQuery.Execute with result + MetaInfo := 'Result #'+IntToStr(NumResult)+' fetched in '; + if Connection.LastQueryDuration < 60*1000 then + MetaInfo := MetaInfo + FormatNumber(Connection.LastQueryDuration/1000, 3) +' ' + _('sec.') + else + MetaInfo := MetaInfo + FormatTimeNumber(Connection.LastQueryDuration/1000, True); + if Connection.LastQueryNetworkDuration > 0 then + MetaInfo := MetaInfo + ' (+ '+FormatNumber(Connection.LastQueryNetworkDuration/1000, 3) +' ' + _('sec.') + ' ' + _('network') + ')'; + Connection.Log(lcDebug, MetaInfo); +end; + procedure TMySQLQuery.Execute(AddResult: Boolean=False; UseRawResult: Integer=-1); var i, j, NumFields, NumResults: Integer; @@ -6771,13 +8240,14 @@ procedure TMySQLQuery.Execute(AddResult: Boolean=False; UseRawResult: Integer=-1 for i:=Low(FResultList) to High(FResultList) do begin FConnection.Lib.mysql_free_result(FResultList[i]); end; + SetLength(FResultList, 0); NumResults := 1; FRecordCount := 0; FAutoIncrementColumn := -1; FEditingPrepared := False; end; if LastResult <> nil then begin - Connection.Log(lcDebug, 'Result #'+IntToStr(NumResults)+' fetched.'); + LogMetaInfo(NumResults); SetLength(FResultList, NumResults); FResultList[NumResults-1] := LastResult; FRecordCount := FRecordCount + LastResult.row_count; @@ -6805,10 +8275,10 @@ procedure TMySQLQuery.Execute(AddResult: Boolean=False; UseRawResult: Integer=-1 FAutoIncrementColumn := i; for j:=0 to High(FConnection.Datatypes) do begin if (Field.flags and ENUM_FLAG) = ENUM_FLAG then begin - if FConnection.Datatypes[j].Index = dtEnum then + if FConnection.Datatypes[j].Index = dbdtEnum then FColumnTypes[i] := FConnection.Datatypes[j]; end else if (Field.flags and SET_FLAG) = SET_FLAG then begin - if FConnection.Datatypes[j].Index = dtSet then + if FConnection.Datatypes[j].Index = dbdtSet then FColumnTypes[i] := FConnection.Datatypes[j]; end else if Field._type = Cardinal(FConnection.Datatypes[j].NativeType) then begin // Text and Blob types share the same constants (see FIELD_TYPEs) @@ -6817,13 +8287,13 @@ procedure TMySQLQuery.Execute(AddResult: Boolean=False; UseRawResult: Integer=-1 IsBinary := Field.charsetnr = COLLATION_BINARY else IsBinary := (Field.flags and BINARY_FLAG) = BINARY_FLAG; - if IsBinary and (FConnection.Datatypes[j].Index in [dtChar..dtLongtext]) then + if IsBinary and (FConnection.Datatypes[j].Category = dtcText) then continue; FColumnTypes[i] := FConnection.Datatypes[j]; - break; + Break; end; end; - FConnection.Log(lcDebug, 'Detected column type for '+FColumnNames[i]+': '+FColumnTypes[i].Name); + FConnection.Log(lcDebug, 'Detected column type for '+FColumnNames[i]+' ('+IntToStr(Field._type)+'): '+FColumnTypes[i].Name); end; FRecNo := -1; First; @@ -6869,7 +8339,7 @@ procedure TAdoDBQuery.Execute(AddResult: Boolean=False; UseRawResult: Integer=-1 FEditingPrepared := False; end; if LastResult <> nil then begin - Connection.Log(lcDebug, 'Result #'+IntToStr(NumResults)+' fetched.'); + LogMetaInfo(NumResults); SetLength(FResultList, NumResults); FResultList[NumResults-1] := LastResult; FRecordCount := FRecordCount + LastResult.RecordCount; @@ -6899,39 +8369,41 @@ procedure TAdoDBQuery.Execute(AddResult: Boolean=False; UseRawResult: Integer=-1 ftTimeStampOffset, ftObject, ftSingle //49..51 } case LastResult.Fields[i].DataType of ftSmallint, ftWord: - TypeIndex := dtMediumInt; + TypeIndex := dbdtMediumInt; ftInteger: - TypeIndex := dtInt; + TypeIndex := dbdtInt; ftAutoInc: begin - TypeIndex := dtInt; + TypeIndex := dbdtInt; FAutoIncrementColumn := i; end; ftLargeint: - TypeIndex := dtBigInt; + TypeIndex := dbdtBigInt; ftBCD, ftFMTBcd: - TypeIndex := dtDecimal; + TypeIndex := dbdtDecimal; ftFixedChar, ftFixedWideChar: - TypeIndex := dtChar; + TypeIndex := dbdtChar; ftString, ftWideString, ftBoolean, ftGuid: - TypeIndex := dtVarchar; + TypeIndex := dbdtVarchar; ftMemo, ftWideMemo: - TypeIndex := dtText; + TypeIndex := dbdtText; ftBlob, ftVariant: - TypeIndex := dtMediumBlob; + TypeIndex := dbdtMediumBlob; ftBytes: - TypeIndex := dtBinary; + TypeIndex := dbdtBinary; ftVarBytes: - TypeIndex := dtVarbinary; + TypeIndex := dbdtVarbinary; ftFloat: - TypeIndex := dtFloat; + TypeIndex := dbdtFloat; ftDate: - TypeIndex := dtDate; + TypeIndex := dbdtDate; ftTime: - TypeIndex := dtTime; + TypeIndex := dbdtTime; ftDateTime: - TypeIndex := dtDateTime; + TypeIndex := dbdtDateTime; //ftTimeStampOffset: // this is NOT data type DATETIMEOFFSET - // TypeIndex := dtDatetime; + // TypeIndex := dbdtDatetime; + ftCurrency: + TypeIndex := dbdtMoney; else raise EDbError.CreateFmt(_('Unknown data type for column #%d - %s: %d'), [i, FColumnNames[i], Integer(LastResult.Fields[i].DataType)]); end; @@ -6981,7 +8453,7 @@ procedure TPGQuery.Execute(AddResult: Boolean=False; UseRawResult: Integer=-1); FEditingPrepared := False; end; if LastResult <> nil then begin - Connection.Log(lcDebug, 'Result #'+IntToStr(NumResults)+' fetched.'); + LogMetaInfo(NumResults); SetLength(FResultList, NumResults); FResultList[NumResults-1] := LastResult; FRecordCount := FRecordCount + FConnection.Lib.PQntuples(LastResult); @@ -7013,19 +8485,102 @@ procedure TPGQuery.Execute(AddResult: Boolean=False; UseRawResult: Integer=-1); end; -procedure TSQLiteQuery.Execute(AddResult: Boolean=False; UseRawResult: Integer=-1); +procedure TSQLiteQuery.Execute(AddResult: Boolean=False; UseRawResult: Integer=-1); +var + i, NumFields, NumResults: Integer; + LastResult: TSQLiteGridRows; + ColName, ColOrgName, DataTypeStr: String; + StepResult: Integer; +begin + if UseRawResult = -1 then begin + Connection.Query(FSQL, FStoreResult); + UseRawResult := 0; + end; + if Connection.ResultCount > UseRawResult then begin + LastResult := TSQLiteConnection(Connection).LastRawResults[UseRawResult]; + end else begin + LastResult := nil; + end; + if AddResult and (Length(FResultList) = 0) then + AddResult := False; + if AddResult then + NumResults := Length(FResultList)+1 + else begin + for i:=Length(FResultList)-1 downto 0 do begin + FResultList[i].Free; + end; + NumResults := 1; + FRecordCount := 0; + FAutoIncrementColumn := -1; + FEditingPrepared := False; + end; + if LastResult <> nil then begin + LogMetaInfo(NumResults); + SetLength(FResultList, NumResults); + FResultList[NumResults-1] := LastResult; + FRecordCount := FRecordCount + LastResult.Count; + end; + if not AddResult then begin + if HasResult then begin + // FCurrentResults is normally done in SetRecNo, but never if result has no rows + FCurrentResults := LastResult; + NumFields := FConnection.Lib.sqlite3_column_count(LastResult.Statement); + SetLength(FColumnTypes, NumFields); + SetLength(FColumnLengths, NumFields); + SetLength(FColumnFlags, NumFields); + FColumnNames.Clear; + FColumnOrgNames.Clear; + StepResult := -1; + for i:=0 to NumFields-1 do begin + ColName := FConnection.DecodeAPIString(FConnection.Lib.sqlite3_column_name(LastResult.Statement, i)); + FColumnNames.Add(ColName); + ColOrgName := FConnection.DecodeAPIString(FConnection.Lib.sqlite3_column_origin_name(LastResult.Statement, i)); + FColumnOrgNames.Add(ColOrgName); + DataTypeStr := FConnection.DecodeAPIString(FConnection.Lib.sqlite3_column_decltype(LastResult.Statement, i)); + if DataTypeStr.IsEmpty then begin + if StepResult = -1 then + StepResult := FConnection.Lib.sqlite3_step(LastResult.Statement); + if StepResult = SQLITE_ROW then begin + case FConnection.Lib.sqlite3_column_type(LastResult.Statement, i) of + SQLITE_INTEGER: DataTypeStr := 'INTEGER'; + SQLITE_FLOAT: DataTypeStr := 'FLOAT'; + SQLITE_BLOB: DataTypeStr := 'BLOB'; + SQLITE3_TEXT: DataTypeStr := 'TEXT'; + // SQLITE_NULL gets "unknown" + end; + end else begin + // No row available, fall back to TEXT + DataTypeStr := 'TEXT'; + end; + end; + FColumnTypes[i] := FConnection.GetDatatypeByName(DataTypeStr, False); + end; + if StepResult <> -1 then begin + FConnection.Lib.sqlite3_reset(LastResult.Statement); + end; + FRecNo := -1; + First; + end else begin + SetLength(FColumnTypes, 0); + SetLength(FColumnLengths, 0); + SetLength(FColumnFlags, 0); + end; + end; +end; + + +procedure TInterbaseQuery.Execute(AddResult: Boolean; UseRawResult: Integer); var - i, NumFields, NumResults: Integer; - LastResult: TSQLiteGridRows; - ColName, ColOrgName, DataTypeStr: String; - StepResult: Integer; + i, j, NumFields, NumResults: Integer; + TypeIndex: TDBDatatypeIndex; + LastResult: TFDQuery; begin if UseRawResult = -1 then begin Connection.Query(FSQL, FStoreResult); UseRawResult := 0; end; if Connection.ResultCount > UseRawResult then begin - LastResult := TSQLiteConnection(Connection).LastRawResults[UseRawResult]; + LastResult := TInterbaseConnection(Connection).LastRawResults[UseRawResult] end else begin LastResult := nil; end; @@ -7034,7 +8589,7 @@ procedure TSQLiteQuery.Execute(AddResult: Boolean=False; UseRawResult: Integer=- if AddResult then NumResults := Length(FResultList)+1 else begin - for i:=Length(FResultList)-1 downto 0 do begin + for i:=Low(FResultList) to High(FResultList) do begin FResultList[i].Free; end; NumResults := 1; @@ -7043,48 +8598,64 @@ procedure TSQLiteQuery.Execute(AddResult: Boolean=False; UseRawResult: Integer=- FEditingPrepared := False; end; if LastResult <> nil then begin - Connection.Log(lcDebug, 'Result #'+IntToStr(NumResults)+' fetched.'); + LogMetaInfo(NumResults); SetLength(FResultList, NumResults); FResultList[NumResults-1] := LastResult; - FRecordCount := FRecordCount + LastResult.Count; + FRecordCount := FRecordCount + LastResult.RecordCount; end; if not AddResult then begin if HasResult then begin // FCurrentResults is normally done in SetRecNo, but never if result has no rows FCurrentResults := LastResult; - NumFields := FConnection.Lib.sqlite3_column_count(LastResult.Statement); + NumFields := LastResult.FieldCount; SetLength(FColumnTypes, NumFields); SetLength(FColumnLengths, NumFields); SetLength(FColumnFlags, NumFields); FColumnNames.Clear; FColumnOrgNames.Clear; - StepResult := -1; for i:=0 to NumFields-1 do begin - ColName := FConnection.DecodeAPIString(FConnection.Lib.sqlite3_column_name(LastResult.Statement, i)); - FColumnNames.Add(ColName); - ColOrgName := FConnection.DecodeAPIString(FConnection.Lib.sqlite3_column_origin_name(LastResult.Statement, i)); - FColumnOrgNames.Add(ColOrgName); - DataTypeStr := FConnection.DecodeAPIString(FConnection.Lib.sqlite3_column_decltype(LastResult.Statement, i)); - if DataTypeStr.IsEmpty then begin - if StepResult = -1 then - StepResult := FConnection.Lib.sqlite3_step(LastResult.Statement); - if StepResult = SQLITE_ROW then begin - case FConnection.Lib.sqlite3_column_type(LastResult.Statement, i) of - SQLITE_INTEGER: DataTypeStr := 'INTEGER'; - SQLITE_FLOAT: DataTypeStr := 'FLOAT'; - SQLITE_BLOB: DataTypeStr := 'BLOB'; - SQLITE3_TEXT: DataTypeStr := 'TEXT'; - // SQLITE_NULL gets "unknown" - end; - end else begin - // No row available, fall back to TEXT - DataTypeStr := 'TEXT'; + FColumnNames.Add(LastResult.Fields[i].FieldName); + FColumnOrgNames.Add(FColumnNames[FColumnNames.Count-1]); + case LastResult.Fields[i].DataType of + ftSmallint, ftWord: + TypeIndex := dbdtMediumInt; + ftInteger: + TypeIndex := dbdtInt; + ftAutoInc: begin + TypeIndex := dbdtInt; + FAutoIncrementColumn := i; end; + ftLargeint: + TypeIndex := dbdtBigInt; + ftBCD, ftFMTBcd: + TypeIndex := dbdtDecimal; + ftFixedChar, ftFixedWideChar: + TypeIndex := dbdtChar; + ftString, ftWideString, ftBoolean, ftGuid: + TypeIndex := dbdtVarchar; + ftMemo, ftWideMemo: + TypeIndex := dbdtText; + ftBlob, ftVariant: + TypeIndex := dbdtMediumBlob; + ftBytes: + TypeIndex := dbdtBinary; + ftVarBytes: + TypeIndex := dbdtVarbinary; + ftFloat, ftSingle: + TypeIndex := dbdtFloat; + ftDate: + TypeIndex := dbdtDate; + ftTime: + TypeIndex := dbdtTime; + ftDateTime, ftTimeStamp: + TypeIndex := dbdtDateTime; + else + raise EDbError.CreateFmt(_('Unknown data type for column #%d - %s: %d'), [i, FColumnNames[i], Integer(LastResult.Fields[i].DataType)]); + end; + for j:=0 to High(FConnection.DataTypes) do begin + if TypeIndex = FConnection.DataTypes[j].Index then + FColumnTypes[i] := FConnection.DataTypes[j]; end; - FColumnTypes[i] := FConnection.GetDatatypeByName(DataTypeStr, False); - end; - if StepResult <> -1 then begin - FConnection.Lib.sqlite3_reset(LastResult.Statement); end; FRecNo := -1; First; @@ -7126,7 +8697,7 @@ procedure TDBQuery.Next; procedure TMySQLQuery.SetRecNo(Value: Int64); var - LengthPointer: PLongInt; + LengthsPointer: PMYSQL_LENGTHS; i, j: Integer; NumRows, WantedLocalRecNo: Int64; Row: TGridRow; @@ -7168,9 +8739,9 @@ procedure TMySQLQuery.SetRecNo(Value: Int64); FCurrentRow := FConnection.Lib.mysql_fetch_row(FCurrentResults); FCurrentUpdateRow := nil; // Remember length of column contents. Important for Col() so contents of cells with #0 chars are not cut off - LengthPointer := FConnection.Lib.mysql_fetch_lengths(FCurrentResults); + LengthsPointer := FConnection.Lib.mysql_fetch_lengths(FCurrentResults); for j:=Low(FColumnLengths) to High(FColumnLengths) do - FColumnLengths[j] := PInteger(Integer(LengthPointer) + j * SizeOf(Integer))^; + FColumnLengths[j] := LengthsPointer^[j]; break; end; end; @@ -7342,10 +8913,69 @@ procedure TSQLiteQuery.SetRecNo(Value: Int64); end; +procedure TInterbaseQuery.SetRecNo(Value: Int64); +var + i, j: Integer; + RowFound: Boolean; + Row: TGridRow; + NumRows, WantedLocalRecNo: Int64; +begin + if Value = FRecNo then + Exit; + if (not FEditingPrepared) and (Value >= RecordCount) then begin + FRecNo := RecordCount; + FEof := True; + FCurrentResults.Last; + end else begin + + // Find row in edited data + RowFound := False; + if FEditingPrepared then begin + for Row in FUpdateData do begin + if Row.RecNo = Value then begin + FCurrentUpdateRow := Row; + for i:=Low(FColumnLengths) to High(FColumnLengths) do + FColumnLengths[i] := Length(FCurrentUpdateRow[i].NewText); + RowFound := True; + break; + end; + end; + end; + + // Row not edited data - find it in normal result + if not RowFound then begin + NumRows := 0; + try + for i:=Low(FResultList) to High(FResultList) do begin + Inc(NumRows, FResultList[i].RecordCount); + if NumRows > Value then begin + FCurrentResults := FResultList[i]; + WantedLocalRecNo := FCurrentResults.RecordCount-(NumRows-Value); + FCurrentResults.RecNo := WantedLocalRecNo+1; + FCurrentUpdateRow := nil; + for j:=Low(FColumnLengths) to High(FColumnLengths) do + FColumnLengths[j] := FCurrentResults.Fields[j].DataSize; + break; + end; + end; + except + // Catch broken connection + raise; + end; + end; + + FRecNo := Value; + FEof := False; + end; +end; + function TDBQuery.ColumnCount: Integer; begin - Result := ColumnNames.Count; + if Assigned(FColumnNames) then + Result := FColumnNames.Count + else + Result := -1; end; @@ -7360,6 +8990,12 @@ function TDBQuery.ColumnExists(Column: Integer): Boolean; end; +function TDBQuery.ColumnExists(ColumnName: String): Boolean; +begin + Result := FConnection.Active and ColumnNames.Contains(ColumnName); +end; + + function TDBQuery.GetColBinData(Column: Integer; var baData: TBytes): Boolean; begin Raise EDbError.Create(SNotImplemented); @@ -7411,7 +9047,7 @@ function TMySQLQuery.Col(Column: Integer; IgnoreErrors: Boolean=False): String; else Result := Connection.DecodeAPIString(AnsiStr); // Create string bitmask for BIT fields - if Datatype(Column).Index = dtBit then begin + if Datatype(Column).Index = dbdtBit then begin Field := FConnection.Lib.mysql_fetch_field_direct(FCurrentResults, column); // FConnection.Log(lcInfo, Field.name+': def: '+field.def+' length: '+inttostr(field.length)+' max_length: '+inttostr(field.max_length)+' decimals: '+inttostr(field.decimals)); for c in Result do begin @@ -7432,8 +9068,9 @@ function TMySQLQuery.Col(Column: Integer; IgnoreErrors: Boolean=False): String; end; end; - end else if not IgnoreErrors then - Raise EDbError.CreateFmt(_(MsgInvalidColumn), [Column, ColumnCount, RecordCount]); + end + else + Result := TextInvalidColumn; end; @@ -7455,15 +9092,16 @@ function TAdoDBQuery.Col(Column: Integer; IgnoreErrors: Boolean=False): String; except Result := String(FCurrentResults.Fields[Column].AsAnsiString); end; - if Datatype(Column).Index = dtBit then begin - if UpperCase(Result) = 'TRUE' then - Result := '1' - else - Result := '0'; - end end; - end else if not IgnoreErrors then - Raise EDbError.CreateFmt(_(MsgInvalidColumn), [Column, ColumnCount, RecordCount]); + if Datatype(Column).Index = dbdtBit then begin + if (UpperCase(Result) = 'TRUE') or (Result = '1') then + Result := '1' + else + Result := '0'; + end + end + else + Result := TextInvalidColumn; end; @@ -7478,13 +9116,14 @@ function TPGQuery.Col(Column: Integer; IgnoreErrors: Boolean=False): String; SetString(AnsiStr, FConnection.Lib.PQgetvalue(FCurrentResults, FRecNoLocal, Column), FColumnLengths[Column]); if Datatype(Column).Category in [dtcBinary, dtcSpatial] then Result := String(AnsiStr) - else if Datatype(Column).Index = dtbool then - if AnsiStr='t' then Result := 'true' else Result := 'false' + else if (Datatype(Column).Index = dbdtBool) and (Length(AnsiStr) > 0) then + Result := IfThen(AnsiStr='t', 'true', 'false') else Result := Connection.DecodeAPIString(AnsiStr); end; - end else if not IgnoreErrors then - Raise EDbError.CreateFmt(_(MsgInvalidColumn), [Column, ColumnCount, RecordCount]); + end + else + Result := TextInvalidColumn; end; @@ -7496,8 +9135,23 @@ function TSQLiteQuery.Col(Column: Integer; IgnoreErrors: Boolean=False): String; end else begin Result := FCurrentResults[FRecNoLocal][Column].OldText; end; - end else if not IgnoreErrors then - Raise EDbError.CreateFmt(_(MsgInvalidColumn), [Column, ColumnCount, RecordCount]); + end + else + Result := TextInvalidColumn; +end; + + +function TInterbaseQuery.Col(Column: Integer; IgnoreErrors: Boolean): String; +begin + if ColumnExists(Column) then begin + if FEditingPrepared and Assigned(FCurrentUpdateRow) then begin + Result := FCurrentUpdateRow[Column].NewText; + end else begin + Result := FCurrentResults.Fields[Column].AsString; + end; + end + else + Result := TextInvalidColumn; end; @@ -7510,8 +9164,8 @@ function TDBQuery.Col(ColumnName: String; IgnoreErrors: Boolean=False): String; idx := ColumnNames.IndexOf(ColumnName); if idx > -1 then Result := Col(idx) - else if not IgnoreErrors then - Raise EDbError.CreateFmt(_('Column "%s" not available.'), [ColumnName]); + else + Result := TextInvalidColumn; end; @@ -7528,46 +9182,12 @@ function TDBQuery.HexValue(Column: Integer; IgnoreErrors: Boolean=False): String // Return a binary column value as hex AnsiString if FConnection.Parameters.IsAnyMysql then begin GetColBinData(Column, baData); - Result := HexValue(baData); + Result := FConnection.EscapeBin(baData); end else - Result := HexValue(Col(Column, IgnoreErrors)); + Result := FConnection.EscapeBin(Col(Column, IgnoreErrors)); end; -function TDBQuery.HexValue(BinValue: String): String; -var - BinLen: Integer; - Ansi: AnsiString; -begin - // Return a binary value as hex AnsiString - Ansi := AnsiString(BinValue); - BinLen := Length(Ansi); - if BinLen = 0 then begin - Result := Connection.EscapeString(''); - end else begin - SetLength(Result, BinLen*2); - BinToHex(PAnsiChar(Ansi), PChar(Result), BinLen); - Result := '0x' + Result; - end; -end; - -function TDBQuery.HexValue(var ByteData: TBytes): String; -var - BinLen: Integer; - Ansi: AnsiString; -begin - BinLen := Length(ByteData); - SetString(Ansi, PAnsiChar(ByteData), BinLen); - if BinLen = 0 then begin - Result := Connection.EscapeString(''); - end else begin - SetLength(Result, BinLen*2); - BinToHex(PAnsiChar(Ansi), PChar(Result), BinLen); - Result := '0x' + Result; - end; - -end; - function TDBQuery.DataType(Column: Integer): TDBDataType; var Col: TTableColumn; @@ -7590,17 +9210,17 @@ function TDBQuery.MaxLength(Column: Integer): Int64; ColAttr := ColAttributes(Column); if Assigned(ColAttr) then begin case ColAttr.DataType.Index of - dtChar, dtVarchar, dtBinary, dtVarBinary, dtBit: Result := MakeInt(ColAttr.LengthSet); - dtTinyText, dtTinyBlob: Result := 255; - dtText, dtBlob: begin + dbdtChar, dbdtVarchar, dbdtBinary, dbdtVarBinary, dbdtBit: Result := MakeInt(ColAttr.LengthSet); + dbdtTinyText, dbdtTinyBlob: Result := 255; + dbdtText, dbdtBlob: begin case FConnection.Parameters.NetTypeGroup of ngMySQL: Result := 65535; ngMSSQL: Result := MaxInt; ngPgSQL: Result := High(Int64); end; end; - dtMediumText, dtMediumBlob: Result := 16777215; - dtLongText, dtLongBlob: Result := 4294967295; + dbdtMediumText, dbdtMediumBlob: Result := 16777215; + dbdtLongText, dbdtLongBlob: Result := 4294967295; end; end; end; @@ -7609,16 +9229,36 @@ function TDBQuery.MaxLength(Column: Integer): Int64; function TDBQuery.ValueList(Column: Integer): TStringList; var ColAttr: TTableColumn; + i: Integer; begin Result := TStringList.Create; - Result.QuoteChar := ''''; - Result.Delimiter := ','; ColAttr := ColAttributes(Column); if Assigned(ColAttr) then case ColAttr.DataType.Index of - dtEnum, dtSet: - Result.DelimitedText := ColAttr.LengthSet; - dtBool: + + dbdtEnum, dbdtSet: begin + // Lool up PostgreSQL enum labels in prefetched list + i := FConnection.NamedEnums.IndexOfName(ColAttr.LengthSet); + if i > -1 then begin + Result.Delimiter := '|'; + Result.DelimitedText := FConnection.NamedEnums.ValueFromIndex[i]; + end + else begin + // .. or in MySQL Length/Set + Result.QuoteChar := ''''; + Result.Delimiter := ','; + Result.DelimitedText := ColAttr.LengthSet; + end; + // In any case, take care for escaped ENUM definitions, see issue #799 + for i:=0 to Result.Count-1 do begin + Result[i] := FConnection.UnescapeString(Result[i]); + end; + end; + + dbdtBool: begin + Result.Delimiter := ','; Result.DelimitedText := 'true,false'; + end; + end; end; @@ -7628,8 +9268,9 @@ function TDBQuery.ColAttributes(Column: Integer): TTableColumn; i: Integer; begin Result := nil; - if (Column < 0) or (Column >= FColumnOrgNames.Count) then - raise EDbError.CreateFmt(_('Column #%s not available.'), [IntToStr(Column)]); + if (Column < 0) or (Column >= FColumnOrgNames.Count) then begin + // Just return nil + end; if FColumns <> nil then begin for i:=0 to FColumns.Count-1 do begin if FColumns[i].Name = FColumnOrgNames[Column] then begin @@ -7690,6 +9331,13 @@ function TSQLiteQuery.ColIsPrimaryKeyPart(Column: Integer): Boolean; end; +function TInterbaseQuery.ColIsPrimaryKeyPart(Column: Integer): Boolean; +begin + // Todo + Result := False; +end; + + function TMySQLQuery.ColIsUniqueKeyPart(Column: Integer): Boolean; begin Result := (FColumnFlags[Column] and UNIQUE_KEY_FLAG) = UNIQUE_KEY_FLAG; @@ -7714,6 +9362,13 @@ function TSQLiteQuery.ColIsUniqueKeyPart(Column: Integer): Boolean; end; +function TInterbaseQuery.ColIsUniqueKeyPart(Column: Integer): Boolean; +begin + // Todo + Result := False; +end; + + function TMySQLQuery.ColIsKeyPart(Column: Integer): Boolean; begin Result := (FColumnFlags[Column] and MULTIPLE_KEY_FLAG) = MULTIPLE_KEY_FLAG; @@ -7738,6 +9393,13 @@ function TSQLiteQuery.ColIsKeyPart(Column: Integer): Boolean; end; +function TInterbaseQuery.ColIsKeyPart(Column: Integer): Boolean; +begin + // Todo + Result := False; +end; + + function TDBQuery.ColIsVirtual(Column: Integer): Boolean; var Col: TTableColumn; @@ -7790,7 +9452,8 @@ function TAdoDBQuery.IsNull(Column: Integer): Boolean; except // Silence error: "Multiple-step operation generated errors. Check each status value." // @see #496 - on E:EOleException do; + //on E:EOleException do; + // Silence more: see #1724 end; end; end; @@ -7815,6 +9478,15 @@ function TSQLiteQuery.IsNull(Column: Integer): Boolean; end; +function TInterbaseQuery.IsNull(Column: Integer): Boolean; +begin + if FEditingPrepared and Assigned(FCurrentUpdateRow) then + Result := FCurrentUpdateRow[Column].NewIsNull + else + Result := FCurrentResults.Fields[Column].IsNull; +end; + + function TDBQuery.IsFunction(Column: Integer): Boolean; begin if FEditingPrepared and Assigned(FCurrentUpdateRow) then @@ -7848,6 +9520,12 @@ function TSQLiteQuery.HasResult: Boolean; end; +function TInterbaseQuery.HasResult: Boolean; +begin + Result := Length(FResultList) > 0; +end; + + procedure TDBQuery.PrepareColumnAttributes; var DB: String; @@ -7896,6 +9574,7 @@ procedure TDBQuery.DeleteRow; var sql: String; IsVirtual: Boolean; + TempRowsAffected: Int64; begin // Delete current row from result PrepareEditing; @@ -7903,8 +9582,10 @@ procedure TDBQuery.DeleteRow; if not IsVirtual then begin sql := GridQuery('DELETE', 'FROM ' + QuotedDbAndTableName + ' WHERE ' + GetWhereClause); Connection.Query(sql); - if Connection.RowsAffected = 0 then - raise EDbError.Create(FormatNumber(Connection.RowsAffected)+' rows deleted when that should have been 1.'); + TempRowsAffected := Connection.RowsAffected; + Connection.ShowWarnings; + if TempRowsAffected = 0 then + raise EDbError.Create(f_('The DELETE affected %s rows, but 1 was expected. On tables without a primary or unique key, HeidiSQL must match on all columns, so edits may not reliably target the intended row.', [FormatNumber(TempRowsAffected)])); end; if Assigned(FCurrentUpdateRow) then begin FUpdateData.Remove(FCurrentUpdateRow); @@ -7930,12 +9611,23 @@ function TDBQuery.InsertRow: Int64; Row.Add(c); c.OldText := ''; c.OldIsFunction := False; - c.OldIsNull := False; + c.OldIsNull := True; ColAttr := ColAttributes(i); if Assigned(ColAttr) then begin - c.OldIsNull := ColAttr.DefaultType in [cdtNull, cdtAutoInc]; - if ColAttr.DefaultType in [cdtText] then - c.OldText := FConnection.UnescapeString(ColAttr.DefaultText); + case ColAttr.DefaultType of + cdtText: begin + c.OldText := FConnection.UnescapeString(ColAttr.DefaultText); + c.OldIsNull := False; + end; + cdtExpression: begin + // Overtake expression, if it's a simple integer + if ColAttr.DefaultText = MakeInt(ColAttr.DefaultText).ToString then begin + c.OldText := ColAttr.DefaultText; + c.OldIsNull := False; + end; + end; + end; + end; c.NewText := c.OldText; c.NewIsFunction := c.OldIsFunction; @@ -8021,6 +9713,7 @@ function TDBQuery.EnsureFullRow(Refresh: Boolean): Boolean; sql := sql + ' FROM '+QuotedDbAndTableName+' WHERE '+GetWhereClause; sql := GridQuery('SELECT', sql); Data := Connection.GetResults(sql); + Connection.ShowWarnings; Result := Data.RecordCount = 1; if Result then begin if not Assigned(FCurrentUpdateRow) then @@ -8032,6 +9725,7 @@ function TDBQuery.EnsureFullRow(Refresh: Boolean): Boolean; FCurrentUpdateRow[i].NewIsNull := FCurrentUpdateRow[i].OldIsNull; FCurrentUpdateRow[i].OldIsFunction := False; FCurrentUpdateRow[i].NewIsFunction := FCurrentUpdateRow[i].OldIsFunction; + FColumnLengths[i] := Length(FCurrentUpdateRow[i].NewText); end; Data.Free; end; @@ -8041,22 +9735,44 @@ function TDBQuery.EnsureFullRow(Refresh: Boolean): Boolean; end; +// Issue #1351 and https://www.heidisql.com/forum.php?t=39239 +// Data view editor truncated for TEXT columns when emoji is present +// Issue #1658: Saving BLOB to file creates corrupted files +// Issue #1673: Truncated text in Postgres mode function TDBQuery.HasFullData: Boolean; var - Val: String; i: Integer; + NumChars: Integer; begin Result := True; - // In case we created a update-row we know for sure that we already loaded full contents - if Assigned(FCurrentUpdateRow) then - Result := True - else for i:=0 to ColumnCount-1 do begin - if not (Datatype(i).Category in [dtcText, dtcBinary]) then - continue; - Val := Col(i); - if Length(Val) = GRIDMAXDATA then begin - Result := False; - break; + if Assigned(FCurrentUpdateRow) then begin + // In case we created a update-row we know for sure that we already loaded full contents + Result := True; + end + else begin + // This is done only once, before EnsureFullRow creates an update-row which returns true above. + // Delphi's Length() likely counts characters different than SQL/LEFT(). + for i:=0 to ColumnCount-1 do begin + if not DataType(i).LoadPart then + Continue; + NumChars := Col(i).Length; + {if TableName.Contains('issue') then + FConnection.Log(lcInfo, 'HasFullData: RowNum:'+RecNo.ToString+ + ' ColumnNames['+i.ToString+']:'+ColumnNames[i]+ + ' ColumnOrgNames['+i.ToString+']:'+ColumnOrgNames[i]+ + ' NumChars:'+NumChars.ToString+ + ' ColumnLengths('+i.ToString+'):'+ColumnLengths(i).ToString + );} + if ColumnNames[i].StartsWith('LEFT', True) or ColumnNames[i].StartsWith('SUBSTR', True) then begin + // This works at least in MySQL, and fixes issue #1850 where NumChars is > 256 when text contains emojis. + // MSSQL does not provide the original column names with function calls like LEFT(..) + Result := False; + Break; + end; + if (NumChars <= GRIDMAXDATA) and (NumChars >= GRIDMAXDATA / SizeOf(Char)) then begin + Result := False; + Break; + end; end; end; end; @@ -8065,6 +9781,7 @@ function TDBQuery.HasFullData: Boolean; function TDBQuery.SaveModifications: Boolean; var i: Integer; + TempRowsAffected: Int64; Row: TGridRow; Cell: TGridValue; sqlUpdate, sqlInsertColumns, sqlInsertValues, Val: String; @@ -8097,21 +9814,14 @@ function TDBQuery.SaveModifications: Boolean; else if Cell.NewIsFunction then Val := Cell.NewText else case Datatype(i).Category of - dtcInteger, dtcReal: begin - Val := Connection.EscapeString(Cell.NewText); - if (Datatype(i).Index = dtBit) and FConnection.Parameters.IsAnyMySQL then - Val := 'b' + Val; - end; + dtcInteger, dtcReal: + Val := Connection.EscapeString(Cell.NewText, Datatype(i)); dtcBinary, dtcSpatial: - Val := HexValue(Cell.NewText); - else begin - if Datatype(i).Index in [dtNchar, dtNvarchar, dtNtext] then - Val := 'N' + Connection.EscapeString(Cell.NewText) - else if Datatype(i).Category = dtcTemporal then - Val := Connection.EscapeString(Connection.GetDateTimeValue(Cell.NewText, Datatype(i).Index)) - else - Val := Connection.EscapeString(Cell.NewText); - end; + Val := FConnection.EscapeBin(Cell.NewText); + dtcTemporal: + Val := Connection.EscapeString(Connection.GetDateTimeValue(Cell.NewText, Datatype(i).Index)) + else + Val := Connection.EscapeString(Cell.NewText, Datatype(i)); end; sqlUpdate := sqlUpdate + Connection.QuoteIdent(FColumnOrgNames[i]) + '=' + Val; sqlInsertColumns := sqlInsertColumns + Connection.QuoteIdent(FColumnOrgNames[i]); @@ -8122,12 +9832,13 @@ function TDBQuery.SaveModifications: Boolean; if RowModified then try if Row.Inserted then begin Connection.Query('INSERT INTO '+QuotedDbAndTableName+' ('+sqlInsertColumns+') VALUES ('+sqlInsertValues+')'); + Connection.ShowWarnings; for i:=0 to ColumnCount-1 do begin ColAttr := ColAttributes(i); if Assigned(ColAttr) and (ColAttr.DefaultType = cdtAutoInc) then begin Row[i].NewText := UnformatNumber(Row[i].NewText); if Row[i].NewText = '0' then - Row[i].NewText := Connection.GetVar('SELECT LAST_INSERT_ID()'); + Row[i].NewText := Connection.GetVar('SELECT ' + Connection.SqlProvider.GetSql(qFuncLastAutoIncNumber)); Row[i].NewIsNull := False; break; end; @@ -8136,8 +9847,10 @@ function TDBQuery.SaveModifications: Boolean; sqlUpdate := QuotedDbAndTableName+' SET '+sqlUpdate+' WHERE '+GetWhereClause; sqlUpdate := GridQuery('UPDATE', sqlUpdate); Connection.Query(sqlUpdate); - if Connection.RowsAffected = 0 then begin - raise EDbError.Create(FormatNumber(Connection.RowsAffected)+' rows updated when that should have been 1.'); + TempRowsAffected := Connection.RowsAffected; + Connection.ShowWarnings; + if TempRowsAffected = 0 then begin + raise EDbError.Create(f_('The UPDATE affected %s rows, but 1 was expected. On tables without a primary or unique key, HeidiSQL must match on all columns, so edits may not reliably target the intended row.', [FormatNumber(TempRowsAffected)])); Result := False; end; end; @@ -8259,9 +9972,16 @@ function TPGQuery.DatabaseName: String; end; -function TSQLiteQuery.DatabaseName: String; +function TSQLiteQuery.DatabaseName: String; +begin + // TODO + Result := Connection.Database; +end; + + +function TInterbaseQuery.DatabaseName: String; begin - // TODO + // Todo Result := Connection.Database; end; @@ -8298,31 +10018,37 @@ function TDBQuery.TableName: String; function TMySQLQuery.TableName(Column: Integer): String; var Field: PMYSQL_FIELD; - tbl: AnsiString; + FieldDb, FieldTable, FieldOrgTable: String; Objects: TDBObjectList; Obj: TDBObject; begin + Result := ''; Field := FConnection.Lib.mysql_fetch_field_direct(FCurrentResults, Column); + FieldDb := FConnection.DecodeAPIString(Field.db); + FieldTable := FConnection.DecodeAPIString(Field.table); + FieldOrgTable := FConnection.DecodeAPIString(Field.org_table); + // Connection.Log(lcInfo, FColumnNames[Column]+': org_table:'+FieldOrgTable+' table:'+FieldTable); - if Field.table^ <> Field.org_table^ then begin + if FieldTable <> FieldOrgTable then begin // Probably a VIEW, in which case we rely on the first column's table name. // TODO: This is unsafe when joining a view with a table/view. - if Field.db <> '' then begin - Objects := Connection.GetDBObjects(Connection.DecodeAPIString(Field.db)); + if FieldDb <> '' then begin + Objects := Connection.GetDBObjects(FieldDb); for Obj in Objects do begin - if (Obj.Name = Connection.DecodeAPIString(Field.table)) and (Obj.NodeType = lntView) then begin - tbl := Field.table; + if (Obj.Name = FieldTable) and (Obj.NodeType = lntView) then begin + Result := FieldTable; break; end; end; end; - end else begin + end; + + if Result.IsEmpty then begin // Normal table column // Note: this is empty on data tab TEXT columns with LEFT(..) clause - tbl := Field.org_table; + Result := FieldOrgTable; + StripNewLines(Result); end; - - Result := Connection.DecodeAPIString(tbl); end; @@ -8333,18 +10059,21 @@ function TAdoDBQuery.TableName(Column: Integer): String; function TPGQuery.TableName(Column: Integer): String; var - FieldTypeOID: POid; + TableOid: POid; begin // Get table name from a result set // "123::regclass" results are quoted if they contain special characters - Result := EmptyStr; - FieldTypeOID := FConnection.Lib.PQftable(FCurrentResults, Column); - if not FConnection.RegClasses.ContainsKey(FieldTypeOID) then begin - Result := FConnection.GetVar('SELECT '+IntToStr(FieldTypeOID)+'::regclass'); - Result := FConnection.DeQuoteIdent(Result); - FConnection.RegClasses.Add(FieldTypeOID, Result); + TableOid := FConnection.Lib.PQftable(FCurrentResults, Column); + if TableOid = InvalidOid then begin + // 0 => not a simple reference to a table column, e.g. on SUBSTRING(col, 1, 256) + Result := EmptyStr; + end + else if FConnection.RegClasses.ContainsKey(TableOid) then begin + FConnection.RegClasses.TryGetValue(TableOid, Result); end else begin - FConnection.RegClasses.TryGetValue(FieldTypeOID, Result); + Result := FConnection.GetVar('SELECT '+IntToStr(TableOid)+'::regclass'); + Result := FConnection.DeQuoteIdent(Result); + FConnection.RegClasses.Add(TableOid, Result); end; end; @@ -8359,6 +10088,12 @@ function TSQLiteQuery.TableName(Column: Integer): String; end; +function TInterbaseQuery.TableName(Column: Integer): String; +begin + // Todo +end; + + function TDBQuery.QuotedDbAndTableName: String; begin // Prefer TDBObject when quoting as it knows its schema @@ -8369,7 +10104,14 @@ function TDBQuery.QuotedDbAndTableName: String; end; -function TDBQuery.GetKeyColumns: TStringList; +function TDBQuery.ResultName: String; +begin + // Return name of query defined in a comment above the actual query + Result := RegExprGetMatch('--\s+name\:\s*([^\r\n]+)', FSQL, 1, False, True); + Result := Trim(Result); +end; + +function TDBQuery.GetKeyColumns: TTableColumnList; var i: Integer; begin @@ -8379,7 +10121,7 @@ function TDBQuery.GetKeyColumns: TStringList; if Result.Count = 0 then begin // No good key found. Just expect all columns to be present. for i:=0 to FColumns.Count-1 do - Result.Add(FColumns[i].Name); + Result.Add(FColumns[i]); end; end; @@ -8387,14 +10129,14 @@ function TDBQuery.GetKeyColumns: TStringList; procedure TDBQuery.CheckEditable; var i: Integer; - KeyCols: TStringList; + KeyCols: TTableColumnList; begin KeyCols := GetKeyColumns; if KeyCols.Count = 0 then raise EDbError.Create(_(MSG_NOGRIDEDITING)); // All column names must be present in order to send valid INSERT/UPDATE/DELETE queries for i:=0 to KeyCols.Count-1 do begin - if FColumnOrgNames.IndexOf(KeyCols[i]) = -1 then + if FColumnOrgNames.IndexOf(KeyCols[i].Name) = -1 then raise EDbError.Create(_(MSG_NOGRIDEDITING)); end; for i:=0 to FColumnOrgNames.Count-1 do begin @@ -8410,7 +10152,7 @@ function TDBQuery.IsEditable: Boolean; Result := True; except on E:EDbError do begin - FConnection.Log(lcDebug, E.Message); + FConnection.Log(lcInfo, E.Message); Result := False; end; end; @@ -8420,7 +10162,7 @@ function TDBQuery.IsEditable: Boolean; function TDBQuery.GetWhereClause: String; var i, j: Integer; - NeededCols: TStringList; + NeededCols: TTableColumnList; ColVal: String; ColIsNull: Boolean; begin @@ -8429,16 +10171,13 @@ function TDBQuery.GetWhereClause: String; Result := ''; for i:=0 to NeededCols.Count-1 do begin - j := FColumnOrgNames.IndexOf(NeededCols[i]); + j := FColumnOrgNames.IndexOf(NeededCols[i].Name); if j = -1 then - raise EDbError.CreateFmt(_('Cannot compose WHERE clause - column missing: %s'), [NeededCols[i]]); + raise EDbError.CreateFmt(_('Cannot compose WHERE clause - column missing: %s'), [NeededCols[i].Name]); if Result <> '' then Result := Result + ' AND'; - - Result := Result + ' ' + Connection.QuoteIdent(FColumnOrgNames[j]); - if (DataType(j).Index = dtJson) and (Self is TPGQuery) then begin - Result := Result + '::text'; - end; + // See issue #769 and #2031 for why we need CastAsText + Result := Result + ' ' + NeededCols[i].CastAsText; if Modified(j) then begin ColVal := FCurrentUpdateRow[j].OldText; @@ -8453,8 +10192,8 @@ function TDBQuery.GetWhereClause: String; else begin case DataType(j).Category of dtcInteger, dtcReal: begin - if DataType(j).Index = dtBit then - Result := Result + '=b' + Connection.EscapeString(ColVal) + if DataType(j).Index = dbdtBit then + Result := Result + '=' + Connection.EscapeString(ColVal, DataType(j)) else begin // Guess (!) the default value silently inserted by the server. This is likely // to be incomplete in cases where a UNIQUE key allows NULL here @@ -8465,17 +10204,11 @@ function TDBQuery.GetWhereClause: String; end; dtcTemporal: Result := Result + '=' + Connection.EscapeString(Connection.GetDateTimeValue(ColVal, DataType(j).Index)); - dtcBinary: - Result := Result + '=' + HexValue(ColVal); + dtcBinary, dtcSpatial: + Result := Result + '=' + FConnection.EscapeBin(ColVal); else begin // Any other data type goes here, including text: - case DataType(j).Index of - // Support international characters with N-prefix on MSSQL, see #1115: - dtNchar, dtNvarchar, dtNtext: - Result := Result + '=N' + Connection.EscapeString(ColVal); - else - Result := Result + '=' + Connection.EscapeString(ColVal); - end; + Result := Result + '=' + Connection.EscapeString(ColVal, DataType(j)); end; end; end; @@ -8485,7 +10218,7 @@ function TDBQuery.GetWhereClause: String; function TDBQuery.GridQuery(QueryType, QueryBody: String): String; var - KeyColumns: TStringList; + KeyColumns: TTableColumnList; begin // Return automatic grid UPDATE/DELETE/SELECT, and apply LIMIT clause if no good key is present KeyColumns := Connection.GetKeyColumns(FColumns, FKeys); @@ -8559,37 +10292,51 @@ function TDBObjectDropComparer.Compare(const Left, Right: TDBObject): Integer; constructor TDBObject.Create(OwnerConnection: TDBConnection); begin - NodeType := lntNone; + // Take care, when adding properties here, add them in Assign() below as well Name := ''; - Database := ''; Schema := ''; - Rows := -1; - Size := -1; - Created := 0; - Updated := 0; + Database := ''; + Column := ''; Engine := ''; Comment := ''; - Version := -1; - AutoInc := -1; RowFormat := ''; + CreateOptions := ''; + Collation := ''; + Created := 0; + Updated := 0; + LastChecked := 0; + Rows := -1; + Size := -1; + Version := -1; AvgRowLen := -1; MaxDataLen := -1; IndexLen := -1; DataLen := -1; DataFree := -1; - LastChecked := 0; - Collation := ''; + AutoInc := -1; CheckSum := -1; - CreateOptions := ''; + Body := ''; + Definer := ''; + Returns := ''; + DataAccess := ''; + Security := ''; + ArgTypes := ''; + Deterministic := False; + RowsAreExact := False; + IsMaterialized := False; + NodeType := lntNone; + GroupType := lntNone; FCreateCode := ''; FCreateCodeLoaded := False; + FWasSelected := False; FConnection := OwnerConnection; - FTableColumns := TTableColumnList.Create; - FTableColumns.Loaded := False; - FTableKeys := TTableKeyList.Create; - FTableKeys.Loaded := False; - FTableForeignKeys := TForeignKeyList.Create; - FTableForeignKeys.Loaded := False; + FMap := TStringMap.Create; +end; + +destructor TDBObject.Destroy; +begin + FMap.Free; + inherited; end; @@ -8600,24 +10347,41 @@ procedure TDBObject.Assign(Source: TPersistent); if Source is TDBObject then begin s := Source as TDBObject; Name := s.Name; - Column := s.Column; - Collation := s.Collation; - Engine := s.Engine; Schema := s.Schema; Database := s.Database; - NodeType := s.NodeType; - GroupType := s.GroupType; + Column := s.Column; + Engine := s.Engine; + Comment := s.Comment; + RowFormat := s.RowFormat; + CreateOptions := s.CreateOptions; + Collation := s.Collation; Created := s.Created; Updated := s.Updated; - Comment := s.Comment; + LastChecked := s.LastChecked; Rows := s.Rows; Size := s.Size; + Version := s.Version; + AvgRowLen := s.AvgRowLen; + MaxDataLen := s.MaxDataLen; + IndexLen := s.IndexLen; + DataLen := s.DataLen; + DataFree := s.DataFree; + AutoInc := s.AutoInc; + CheckSum := s.CheckSum; + Body := s.Body; + Definer := s.Definer; + Returns := s.Returns; + DataAccess := s.DataAccess; + Security := s.Security; ArgTypes := s.ArgTypes; + Deterministic := s.Deterministic; + RowsAreExact := s.RowsAreExact; + IsMaterialized := s.IsMaterialized; + NodeType := s.NodeType; + GroupType := s.GroupType; FCreateCode := s.FCreateCode; FCreateCodeLoaded := s.FCreateCodeLoaded; - FTableColumns.Assign(s.FTableColumns); - FTableKeys.Assign(s.FTableKeys); - FTableForeignKeys.Assign(s.FTableForeignKeys); + FWasSelected := s.FWasSelected; end else inherited; end; @@ -8625,12 +10389,14 @@ procedure TDBObject.Assign(Source: TPersistent); procedure TDBObject.UnloadDetails; begin - FTableColumns.Clear; - FTableColumns.Loaded := False; - FTableKeys.Clear; - FTableKeys.Loaded := False; - FTableForeignKeys.Clear; - FTableForeignKeys.Loaded := False; + if FConnection.FColumnCache.ContainsKey(QuotedDbAndTableName) then + FConnection.FColumnCache.Remove(QuotedDbAndTableName); + if FConnection.FKeyCache.ContainsKey(QuotedDbAndTableName) then + FConnection.FKeyCache.Remove(QuotedDbAndTableName); + if FConnection.FForeignKeyCache.ContainsKey(QuotedDbAndTableName) then + FConnection.FForeignKeyCache.Remove(QuotedDbAndTableName); + if FConnection.FCheckConstraintCache.ContainsKey(QuotedDbAndTableName) then + FConnection.FCheckConstraintCache.Remove(QuotedDbAndTableName); FCreateCode := ''; FCreateCodeLoaded := False; end; @@ -8642,13 +10408,19 @@ function TDBObject.IsSameAs(CompareTo: TDBObject): Boolean; if (not Assigned(CompareTo)) or (CompareTo = nil) then begin Result := False; end else begin - Result := (Name = CompareTo.Name) - and (NodeType = CompareTo.NodeType) - and (Database = CompareTo.Database) - and (Schema = CompareTo.Schema) - and (Column = CompareTo.Column) - and (ArgTypes = CompareTo.ArgTypes) - and (Connection = CompareTo.Connection); + try + Result := FConnection.IdentifierEquals(Name, CompareTo.Name) + and (NodeType = CompareTo.NodeType) + and (Database = CompareTo.Database) + and (Schema = CompareTo.Schema) + and (Column = CompareTo.Column) + and (ArgTypes = CompareTo.ArgTypes) + and (Connection = CompareTo.Connection); + except + // No reproduction recipe yet, but numerous crashes from above were reported + on E:EAccessViolation do + Result := False; + end; end; end; @@ -8670,13 +10442,16 @@ function TDBObject.GetObjType: String; function TDBObject.GetImageIndex: Integer; begin // Detect key icon index for specified db object (table, trigger, ...) + Result := -1; case NodeType of lntNone: begin - // Prevent AV with no connection - if FConnection <> nil then + // Prevent AV with no connection. Parameters may not have been initialized as well + if FConnection <> nil then try Result := FConnection.Parameters.ImageIndex - else - Result := -1; + except + on E:EAccessViolation do + Result := -1; + end; end; lntDb: Result := ICONINDEX_DB; @@ -8701,8 +10476,6 @@ function TDBObject.GetImageIndex: Integer; lntEvent: Result := ICONINDEX_EVENT; lntColumn: Result := ICONINDEX_FIELD; - - else Result := -1; end; end; @@ -8824,7 +10597,11 @@ function TDBObject.QuotedName(AlwaysQuote: Boolean=True; SeparateSegments: Boole function TDBObject.QuotedDbAndTableName(AlwaysQuote: Boolean=True): String; begin - Result := QuotedDatabase(AlwaysQuote) + '.' + QuotedName(AlwaysQuote); + // Used in data grid query, exclude database in Interbase mode + if FConnection.Parameters.IsAnyInterbase then + Result := QuotedName(AlwaysQuote) + else + Result := QuotedDatabase(AlwaysQuote) + '.' + QuotedName(AlwaysQuote); end; function TDBObject.QuotedColumn(AlwaysQuote: Boolean=True): String; @@ -8832,10 +10609,21 @@ function TDBObject.QuotedColumn(AlwaysQuote: Boolean=True): String; Result := Connection.QuoteIdent(Column, AlwaysQuote); end; -function TDBObject.RowCount(Reload: Boolean): Int64; +// Return fitting schema clause for queries in IS.TABLES, IS.ROUTINES etc. +// TODO: Does not work on MSSQL 2000 +function TDBObject.SchemaClauseIS(Prefix: String): String; +begin + if Schema <> '' then + Result := Prefix+'_SCHEMA' + '=' + Connection.EscapeString(Schema) + else + Result := Connection.SqlProvider.GetSql(qISSchemaCol, [Prefix]) + '=' + Connection.EscapeString(Database); +end; + +function TDBObject.RowCount(Reload: Boolean; ForceExact: Boolean=False): Int64; begin if (Rows = -1) or Reload then begin - Rows := Connection.GetRowCount(Self); + Rows := Connection.GetRowCount(Self, ForceExact); + RowsAreExact := ForceExact; end; Result := Rows; end; @@ -8848,90 +10636,73 @@ procedure TDBObject.Drop; function TDBObject.GetTableColumns: TTableColumnList; var - Db: TDBObjectList; - Table: TDBObject; + ColumnsInCache: TTableColumnList; begin // Return columns from table object - if not FTableColumns.Loaded then begin - for Db in Connection.FDatabaseCache do begin - for Table in Db do begin - if (Table <> Self) and Table.IsSameAs(Self) then begin - FConnection.Log(lcDebug, 'Getting columns from cached '+Table.QuotedDbAndTableName); - FTableColumns := Table.GetTableColumns; - Break; - end; - end; - if FTableColumns.Loaded then - Break; - end; - if not FTableColumns.Loaded then begin - FConnection.Log(lcDebug, 'Getting fresh columns for '+QuotedDbAndTableName); - FTableColumns := Connection.GetTableColumns(Self); - FTableColumns.Loaded := True; - end; + if not FConnection.FColumnCache.ContainsKey(QuotedDbAndTableName) then begin + FConnection.FColumnCache.AddOrSetValue(QuotedDbAndTableName, Connection.GetTableColumns(Self)); end; + FConnection.FColumnCache.TryGetValue(QuotedDbAndTableName, ColumnsInCache); Result := TTableColumnList.Create; - Result.Assign(FTableColumns); + Result.Assign(ColumnsInCache); end; function TDBObject.GetTableKeys: TTableKeyList; var - Db: TDBObjectList; - DbObj: TDBObject; + KeysInCache: TTableKeyList; begin // Return keys from table object - if not FTableKeys.Loaded then begin - for Db in Connection.FDatabaseCache do begin - for DbObj in Db do begin - if (DbObj <> Self) and DbObj.IsSameAs(Self) then begin - FConnection.Log(lcDebug, 'Getting keys from database cache for '+QuotedDbAndTableName); - FTableKeys := Dbobj.GetTableKeys; - Break; - end; - end; - if FTableKeys.Loaded then - Break; - end; - if not FTableKeys.Loaded then begin - FConnection.Log(lcDebug, 'Getting fresh keys for '+QuotedDbAndTableName); - FTableKeys := Connection.GetTableKeys(Self); - FTableKeys.Loaded := True; - end; + if not FConnection.FKeyCache.ContainsKey(QuotedDbAndTableName) then begin + FConnection.FKeyCache.AddOrSetValue(QuotedDbAndTableName, Connection.GetTableKeys(Self)); end; + FConnection.FKeyCache.TryGetValue(QuotedDbAndTableName, KeysInCache); Result := TTableKeyList.Create; - Result.Assign(FTableKeys); + Result.Assign(KeysInCache); end; function TDBObject.GetTableForeignKeys: TForeignKeyList; var - Db: TDBObjectList; - DbObj: TDBObject; + ForeignKeysInCache: TForeignKeyList; begin // Return foreign keys from table object - if not FTableForeignKeys.Loaded then begin - for Db in Connection.FDatabaseCache do begin - for DbObj in Db do begin - if (DbObj <> Self) and DbObj.IsSameAs(Self) then begin - FConnection.Log(lcDebug, 'Getting foreign keys from database cache for '+QuotedDbAndTableName); - FTableForeignKeys := Dbobj.GetTableForeignKeys; - Break; - end; - end; - if FTableForeignKeys.Loaded then - Break; - end; - if not FTableForeignKeys.Loaded then begin - FConnection.Log(lcDebug, 'Getting fresh foreign keys for '+QuotedDbAndTableName); - FTableForeignKeys := Connection.GetTableForeignKeys(Self); - FTableForeignKeys.Loaded := True; - end; + if not FConnection.FForeignKeyCache.ContainsKey(QuotedDbAndTableName) then begin + FConnection.FForeignKeyCache.AddOrSetValue(QuotedDbAndTableName, Connection.GetTableForeignKeys(Self)); end; + FConnection.FForeignKeyCache.TryGetValue(QuotedDbAndTableName, ForeignKeysInCache); Result := TForeignKeyList.Create; - Result.Assign(FTableForeignKeys); + Result.Assign(ForeignKeysInCache); +end; + +function TDBObject.GetTableCheckConstraints: TCheckConstraintList; +var + CheckConstraintsInCache: TCheckConstraintList; +begin + // Return check constraint from table object + if not FConnection.CheckConstraintCache.ContainsKey(QuotedDbAndTableName) then begin + FConnection.CheckConstraintCache.AddOrSetValue(QuotedDbAndTableName, Connection.GetTableCheckConstraints(Self)); + end; + FConnection.CheckConstraintCache.TryGetValue(QuotedDbAndTableName, CheckConstraintsInCache); + Result := TCheckConstraintList.Create; + Result.Assign(CheckConstraintsInCache); +end; + +function TDBObject.AsStringMap: TStringMap; +begin + FMap.Clear; + FMap.Add('EscapedName', FConnection.EscapeString(Name)); + FMap.Add('EscapedSchema', FConnection.EscapeString(Schema)); + FMap.Add('EscapedDatabase', FConnection.EscapeString(Database)); + FMap.Add('EscapedDbSchemaName', FConnection.EscapeString(Database+'.'+Schema+'.'+Name)); + FMap.Add('QuotedDatabase', QuotedDatabase); + FMap.Add('QuotedName', QuotedName); + FMap.Add('QuotedDbAndTableName', QuotedDbAndTableName); + FMap.Add('ObjType', UpperCase(ObjType)); + Result := FMap; end; + { *** TTableColumn } constructor TTableColumn.Create(AOwner: TDBConnection; Serialized: String=''); @@ -8960,9 +10731,9 @@ constructor TTableColumn.Create(AOwner: TDBConnection; Serialized: String=''); // Apply given or default attributes Name := FromSerialized('Name', ''); OldName := FromSerialized('OldName', ''); - NumVal := FromSerialized('DataType', Integer(dtUnknown).ToString); + NumVal := FromSerialized('DataType', Integer(dbdtUnknown).ToString); DataTypeIdx := TDBDatatypeIndex(NumVal.ToInteger); - NumVal := FromSerialized('OldDataType', Integer(dtUnknown).ToString); + NumVal := FromSerialized('OldDataType', Integer(dbdtUnknown).ToString); OldDataTypeIdx := TDBDatatypeIndex(NumVal.ToInteger); for i:=Low(Connection.Datatypes) to High(Connection.Datatypes) do begin if Connection.Datatypes[i].Index = DataTypeIdx then @@ -8984,10 +10755,13 @@ constructor TTableColumn.Create(AOwner: TDBConnection; Serialized: String=''); Comment := FromSerialized('Comment', ''); Charset := FromSerialized('Charset', ''); Collation := FromSerialized('Collation', ''); - Expression := FromSerialized('Expression', ''); + GenerationExpression := FromSerialized('Expression', ''); Virtuality := FromSerialized('Virtuality', ''); + Invisible := FromSerialized('Invisible', '0').ToInteger.ToBoolean; + SRID := FromSerialized('SRID', '0').ToInteger; NumVal := FromSerialized('Status', Integer(esUntouched).ToString); FStatus := TEditingStatus(NumVal.ToInteger); + Compressed := FromSerialized('Compressed', '0').ToInteger.ToBoolean; Attributes.Free; end; @@ -9019,8 +10793,11 @@ procedure TTableColumn.Assign(Source: TPersistent); Comment := s.Comment; Charset := s.Charset; Collation := s.Collation; - Expression := s.Expression; + GenerationExpression := s.GenerationExpression; Virtuality := s.Virtuality; + Invisible := s.Invisible; + SRID := s.SRID; + Compressed := s.Compressed; FStatus := s.FStatus; end else inherited; @@ -9051,11 +10828,14 @@ function TTableColumn.Serialize: String; s.AddPair('Comment', Comment); s.AddPair('Charset', Charset); s.AddPair('Collation', Collation); - s.AddPair('Expression', Expression); + s.AddPair('GenerationExpression', GenerationExpression); s.AddPair('Virtuality', Virtuality); + s.AddPair('Invisible', Invisible.ToInteger.ToString); + s.AddPair('SRID', SRID.ToString); + s.AddPair('Compressed', Compressed.ToInteger.ToString); s.AddPair('Status', Integer(FStatus).ToString); - Result := implodestr(DELIMITER, s); + Result := Implode(DELIMITER, s); s.Free; Result := StringReplace(Result, #13, CHR13REPLACEMENT, [rfReplaceAll]); Result := StringReplace(Result, #10, CHR10REPLACEMENT, [rfReplaceAll]); @@ -9074,6 +10854,7 @@ procedure TTableColumn.SetStatus(Value: TEditingStatus); function TTableColumn.SQLCode(OverrideCollation: String=''; Parts: TColumnParts=[cpAll]): String; var IsVirtual: Boolean; + QuoteCollation: Boolean; function InParts(Part: TColumnPart): Boolean; begin @@ -9081,54 +10862,90 @@ function TTableColumn.SQLCode(OverrideCollation: String=''; Parts: TColumnParts= end; begin Result := ''; - IsVirtual := (Expression <> '') and (Virtuality <> ''); + IsVirtual := (GenerationExpression <> '') and (Virtuality <> ''); if InParts(cpName) then begin Result := Result + FConnection.QuoteIdent(Name) + ' '; end; if InParts(cpType) then begin - Result := Result + DataType.Name; - if (LengthSet <> '') and DataType.HasLength then - Result := Result + '(' + LengthSet + ')'; - if (DataType.Category in [dtcInteger, dtcReal]) and Unsigned then - Result := Result + ' UNSIGNED'; - if (DataType.Category in [dtcInteger, dtcReal]) and ZeroFill then - Result := Result + ' ZEROFILL'; + + if FConnection.Parameters.IsAnyPostgreSQL and (DefaultType = cdtAutoInc) then begin + Result := Result + 'SERIAL'; + end + else begin + + if (DataType.Index = dbdtEnum) and (FConnection.NamedEnums.IndexOfName(LengthSet) > -1) then begin + Result := Result + LengthSet; + end + else begin + Result := Result + DataType.Name; + if (LengthSet <> '') and DataType.HasLength then + Result := Result + '(' + LengthSet + ')'; + end; + + if (DataType.Category in [dtcInteger, dtcReal]) and Unsigned then + Result := Result + ' UNSIGNED'; + if (DataType.Category in [dtcInteger, dtcReal]) and ZeroFill then + Result := Result + ' ZEROFILL'; + if Compressed and FConnection.Parameters.IsMariaDB then + Result := Result + ' /*!100301 COMPRESSED*/'; + end; + Result := Result + ' '; // Add space after each part end; - if InParts(cpAllowNull) then begin - if not IsVirtual then begin - if not AllowNull then - Result := Result + 'NOT '; + if InParts(cpAllowNull) and (not IsVirtual) and (not FConnection.Parameters.IsAnyMSSQL) then begin + if not AllowNull then + Result := Result + 'NOT NULL ' + else if not FConnection.Parameters.IsAnyInterbase then Result := Result + 'NULL '; - end; end; - if InParts(cpDefault) then begin + // SRID for spatial columns supported since MySQL 8.0 + if InParts(cpSRID) and (DataType.Category = dtcSpatial) and FConnection.Has(frSrid) then begin + Result := Result + 'SRID ' + SRID.ToString + ' '; + end; + + + if InParts(cpDefault) and (not IsVirtual) then begin if DefaultType <> cdtNothing then begin case DefaultType of // cdtNothing: leave out whole clause cdtText: Result := Result + 'DEFAULT '+FConnection.EscapeString(DefaultText); cdtNull: Result := Result + 'DEFAULT NULL'; - cdtAutoInc: Result := Result + 'AUTO_INCREMENT'; - cdtExpression: Result := Result + 'DEFAULT '+DefaultText; + cdtAutoInc: begin + case FConnection.Parameters.NetTypeGroup of + ngPgSQL:; + else Result := Result + FConnection.SqlProvider.GetSql(qAutoInc); + end; + end; + cdtExpression: begin + if FConnection.Has(frColumnDefaultParentheses) then + Result := Result + 'DEFAULT ('+DefaultText+')' + else + Result := Result + 'DEFAULT '+DefaultText; + end; end; case OnUpdateType of // cdtNothing: leave out whole clause // cdtText: not supported, but may be valid in MariaDB? // cdtNull: not supported, but may be valid in MariaDB? // cdtAutoInc: not valid in ON UPDATE - cdtExpression: Result := Result + ' ON UPDATE '+OnUpdateText; + cdtExpression: begin + Result := Result + ' ON UPDATE '+OnUpdateText; + end; end; Result := Result + ' '; end; end; - if InParts(cpVirtuality) then begin - if IsVirtual then - Result := Result + 'AS ('+Expression+') ' + Virtuality + ' '; + if InParts(cpVirtuality) and IsVirtual then begin + Result := Result + 'AS ('+GenerationExpression+') ' + Virtuality + ' '; + end; + + if InParts(cpInvisible) and Invisible and FConnection.Has(frInvisibleColumns) then begin + Result := Result + 'INVISIBLE '; end; if InParts(cpComment) then begin @@ -9136,13 +10953,14 @@ function TTableColumn.SQLCode(OverrideCollation: String=''; Parts: TColumnParts= Result := Result + 'COMMENT ' + FConnection.EscapeString(Comment) + ' '; end; - if InParts(cpCollation) then begin + if InParts(cpCollation) and (not IsVirtual) and (DataType.Index <> dbdtJson) then begin if Collation <> '' then begin Result := Result + 'COLLATE '; + QuoteCollation := not FConnection.Parameters.IsAnyMSSQL; if OverrideCollation <> '' then - Result := Result + FConnection.EscapeString(OverrideCollation) + ' ' + Result := Result + IfThen(QuoteCollation, FConnection.EscapeString(OverrideCollation), OverrideCollation) + ' ' else - Result := Result + FConnection.EscapeString(Collation) + ' '; + Result := Result + IfThen(QuoteCollation, FConnection.EscapeString(Collation), Collation) + ' '; end; end; @@ -9156,7 +10974,7 @@ function TTableColumn.ValueList: TStringList; Result := TStringList.Create; Result.QuoteChar := ''''; Result.Delimiter := ','; - if DataType.Index in [dtEnum, dtSet] then + if DataType.Index in [dbdtEnum, dbdtSet] then Result.DelimitedText := LengthSet; end; @@ -9165,7 +10983,9 @@ procedure TTableColumn.ParseDatatype(Source: String); var InLiteral: Boolean; ParenthLeft, i: Integer; + OrgSource: String; begin + OrgSource := Source; DataType := Connection.GetDatatypeByName(Source, True); // Length / Set // Various datatypes, e.g. BLOBs, don't have any length property @@ -9178,52 +10998,112 @@ procedure TTableColumn.ParseDatatype(Source: String); if Source[i] = '''' then InLiteral := not InLiteral; end; - LengthSet := Copy(Source, ParenthLeft+1, i-2); - if LengthSet = DataType.MaxTextLen then + LengthSet := Copy(Source, ParenthLeft+1, i-1-ParenthLeft); + if LengthSet = DataType.DefaultSize.ToString then LengthSet := ''; end else begin LengthSet := ''; + if DataType.Index = dbdtEnum then begin + // Assign PostgreSQL enum type to LengthSet, so we can provide it in table editor + // Some enum types are wrapped in double quotes + LengthSet := OrgSource.Trim([FConnection.QuoteChar]); + end; end; Unsigned := ExecRegExpr('\bunsigned\b', Source.ToLowerInvariant); ZeroFill := ExecRegExpr('\bzerofill\b', Source.ToLowerInvariant); + Compressed := ExecRegExpr('\bcompressed\W', Source.ToLowerInvariant); end; function TTableColumn.CastAsText: String; +var + ColTypeAllowsCast: Boolean; begin // Cast data types which are incompatible to string functions to text columns Result := FConnection.QuoteIdent(Name); + ColTypeAllowsCast := True; case FConnection.Parameters.NetTypeGroup of ngMySQL, ngSQLite: begin - if DataType.Index in [dtUnknown, dtDate, dtDatetime, dtTime, dtTimestamp] then - Result := 'CAST('+Result+' AS CHAR)'; + ColTypeAllowsCast := DataType.Index in [dbdtUnknown, dbdtDate, dbdtDatetime, dbdtTime, dbdtTimestamp, dbdtJson, dbdtJsonB]; end; ngMSSQL: begin // Be sure LEFT() and "col LIKE xyz" work with MSSQL // Also, prevent exceeding size limit of 8000 for NVARCHAR - if DataType.Index in [dtUnknown, dtNtext] then - Result := 'CAST('+Result+' AS NVARCHAR('+IntToStr(GRIDMAXDATA)+'))'; + ColTypeAllowsCast := DataType.Index in [dbdtUnknown, dbdtNtext, dbdtText]; end; ngPgSQL: begin - if (DataType.Index = dtUnknown) or (DataType.Category = dtcBinary) then - Result := Result + '::text'; + // Cast most datatypes, including VARCHAR and TEXT, which may have an [] array attribute + ColTypeAllowsCast := not (DataType.Category in [dtcInteger, dtcReal]); end; end; + if ColTypeAllowsCast and FConnection.SqlProvider.Has(qCastAsText) then + Result := FConnection.SqlProvider.GetSql(qCastAsText, [Result]); +end; + + +function TTableColumn.FullDataType: String; +begin + Result := DataType.Name; + if not LengthSet.IsEmpty then begin + if (DataType.Index = dbdtEnum) and (FConnection.NamedEnums.IndexOfName(LengthSet) > -1) then + Result := LengthSet + else + Result := Result + '(' + LengthSet + ')'; + end; end; + procedure TTableColumnList.Assign(Source: TTableColumnList); var Item, ItemCopy: TTableColumn; begin for Item in Source do begin - ItemCopy := TTableColumn.Create(Item.FConnection); + ItemCopy := TTableColumn.Create(Item.Connection); ItemCopy.Assign(Item); Add(ItemCopy); end; - Loaded := Source.Loaded; end; +function TTableColumnList.FindByName(const Value: String): TTableColumn; +var + Col: TTableColumn; +begin + Result := nil; + for Col in Self do begin + if Col.Name = Value then begin + Result := Col; + break; + end; + end; +end; + +function TTableColumnList.HasInvisibleColumns: Boolean; +var + Col: TTableColumn; +begin + Result := False; + for Col in Self do begin + if Col.Invisible then begin + Result := True; + Break; + end; + end; +end; + +function TTableColumnList.QuoteIdents: String; +var + Col: TTableColumn; + QuotedNames: TStringList; +begin + QuotedNames := TStringList.Create; + for Col in Self do begin + QuotedNames.Add(Col.Connection.QuoteIdent(Col.Name)); + end; + Result := Implode(', ', QuotedNames); + QuotedNames.Free; +end; + { *** TTableKey } @@ -9233,14 +11113,19 @@ constructor TTableKey.Create(AOwner: TDBConnection); FConnection := AOwner; Columns := TStringList.Create; SubParts := TStringList.Create; + Collations := TStringList.Create; Columns.OnChange := Modification; Subparts.OnChange := Modification; + Collations.OnChange := Modification; + Visible := True; + Size := -1 end; destructor TTableKey.Destroy; begin FreeAndNil(Columns); FreeAndNil(SubParts); + FreeAndNil(Collations); inherited Destroy; end; @@ -9256,14 +11141,53 @@ procedure TTableKey.Assign(Source: TPersistent); OldIndexType := s.OldIndexType; Algorithm := s.Algorithm; Comment := s.Comment; + Visible := s.Visible; + Size := s.Size; Columns.Assign(s.Columns); SubParts.Assign(s.SubParts); + Collations.Assign(s.Collations); Modified := s.Modified; Added := s.Added; end else inherited; end; +function TTableKey.IsPrimary: Boolean; +begin + Result := IndexType = PRIMARY; +end; + +function TTableKey.IsIndex: Boolean; +begin + Result := IndexType = KEY; +end; + +function TTableKey.IsUnique: Boolean; +begin + Result := IndexType = UNIQUE; +end; + +function TTableKey.IsFulltext: Boolean; +begin + Result := IndexType = FULLTEXT; +end; + +function TTableKey.IsSpatial: Boolean; +begin + Result := IndexType = SPATIAL; +end; + +function TTableKey.IsVector: Boolean; +begin + Result := IndexType = VECTOR; +end; + +function TTableKey.IsExpression(KeyPart: Integer): Boolean; +begin + Result := Columns[KeyPart].StartsWith('('); +end; + + procedure TTableKey.Modification(Sender: TObject); begin if not Added then @@ -9273,15 +11197,26 @@ procedure TTableKey.Modification(Sender: TObject); function TTableKey.GetImageIndex: Integer; begin // Detect key icon index for specified index - if IndexType = TTableKey.PRIMARY then Result := ICONINDEX_PRIMARYKEY - else if IndexType = TTableKey.KEY then Result := ICONINDEX_INDEXKEY - else if IndexType = TTableKey.UNIQUE then Result := ICONINDEX_UNIQUEKEY - else if IndexType = TTableKey.FULLTEXT then Result := ICONINDEX_FULLTEXTKEY - else if IndexType = TTableKey.SPATIAL then Result := ICONINDEX_SPATIALKEY + if IsPrimary then Result := ICONINDEX_PRIMARYKEY + else if IsIndex then Result := ICONINDEX_INDEXKEY + else if IsUnique then Result := ICONINDEX_UNIQUEKEY + else if IsFulltext then Result := ICONINDEX_FULLTEXTKEY + else if IsSpatial then Result := ICONINDEX_SPATIALKEY + else if IsVector then Result := ICONINDEX_VECTORKEY else Result := -1; end; -function TTableKey.SQLCode: String; +function TTableKey.GetInsideCreateCode: Boolean; +begin + case FConnection.Parameters.NetTypeGroup of + ngMySQL: Result := True; + ngSQLite: Result := IsPrimary; + ngPgSQL: Result := IsPrimary or IsUnique; + else Result := True; + end; +end; + +function TTableKey.SQLCode(TableName: String=''): String; var i: Integer; begin @@ -9289,27 +11224,61 @@ function TTableKey.SQLCode: String; // Supress SQL error trying index creation with 0 column if Columns.Count = 0 then Exit; - if IndexType = TTableKey.PRIMARY then - Result := Result + 'PRIMARY KEY ' + if InsideCreateCode then begin + if IsPrimary then + Result := Result + 'PRIMARY KEY ' + else begin + if FConnection.Parameters.IsAnyPostgreSQL then begin + Result := Result + IndexType + ' '; + end + else begin + if not IsIndex then + Result := Result + IndexType + ' '; + Result := Result + 'INDEX ' + FConnection.QuoteIdent(Name) + ' '; + end; + end; + Result := Result + '('; + for i:=0 to Columns.Count-1 do begin + if IsExpression(i) then + Result := Result + Columns[i] // Don't quote functional key part + else + Result := Result + FConnection.QuoteIdent(Columns[i]); + if (SubParts.Count > i) and (SubParts[i] <> '') then + Result := Result + '(' + SubParts[i] + ')'; + // Collation / sort order, see issue #1512 + if (Collations.Count > i) and (Collations[i].ToLower = 'd') then + Result := Result + ' DESC'; + Result := Result + ', '; + end; + if Columns.Count > 0 then + Delete(Result, Length(Result)-1, 2); + + Result := Result + ')'; + + if Algorithm <> '' then + Result := Result + ' USING ' + Algorithm; + + if not Comment.IsEmpty then + Result := Result + ' COMMENT ' + FConnection.EscapeString(Comment); + + end else begin - if IndexType <> TTableKey.KEY then + // SQLite syntax: + // CREATE INDEX myindex ON table1 ("Column 1") + // TODO: test on PG, MS, IB + Result := 'CREATE '; + if not IsIndex then Result := Result + IndexType + ' '; - Result := Result + 'INDEX ' + FConnection.QuoteIdent(Name) + ' '; - end; - Result := Result + '('; - for i:=0 to Columns.Count-1 do begin - Result := Result + FConnection.QuoteIdent(Columns[i]); - if SubParts[i] <> '' then - Result := Result + '(' + SubParts[i] + ')'; - Result := Result + ', '; + Result := Result + 'INDEX '+FConnection.QuoteIdent(Name)+' ON ' + FConnection.QuoteIdent(TableName) + ' ('; + for i:=0 to Columns.Count-1 do begin + Result := Result + FConnection.QuoteIdent(Columns[i]); + Result := Result + ', '; + end; + if Columns.Count > 0 then + Delete(Result, Length(Result)-1, 2); + Result := Result + ')'; end; - if Columns.Count > 0 then - Delete(Result, Length(Result)-1, 2); - - Result := Result + ')'; - if Algorithm <> '' then - Result := Result + ' USING ' + Algorithm; end; procedure TTableKeyList.Assign(Source: TTableKeyList); @@ -9317,14 +11286,34 @@ procedure TTableKeyList.Assign(Source: TTableKeyList); Item, ItemCopy: TTableKey; begin for Item in Source do begin - ItemCopy := TTableKey.Create(Item.FConnection); + ItemCopy := TTableKey.Create(Item.Connection); ItemCopy.Assign(Item); Add(ItemCopy); end; - Loaded := Source.Loaded; end; +function TTableKeyList.MaxSize: Int64; +var + Item: TTableKey; +begin + Result := -1; + for Item in Self do begin + Result := Max(Result, Item.Size); + end; +end; +function TTableKeyList.ImageIndex(ColumnName: String): Integer; +var + Key: TTableKey; +begin + Result := ICONINDEX_FIELD; + for Key in Self do begin + if Key.Columns.Contains(ColumnName) then begin + Result := Key.ImageIndex; + Break; + end; + end; +end; { *** TForeignKey } @@ -9337,6 +11326,9 @@ constructor TForeignKey.Create(AOwner: TDBConnection); Columns.StrictDelimiter := True; ForeignColumns := TStringList.Create; ForeignColumns.StrictDelimiter := True; + // Explicit default action required, since MariaDB and MySQL have different defaults if it's left away, see issue #1320 + OnUpdate := 'NO ACTION'; + OnDelete := 'NO ACTION'; end; destructor TForeignKey.Destroy; @@ -9354,6 +11346,8 @@ procedure TForeignKey.Assign(Source: TPersistent); s := Source as TForeignKey; KeyName := s.KeyName; OldKeyName := s.OldKeyName; + Db := s.Db; + ReferenceDb := s.ReferenceDb; ReferenceTable := s.ReferenceTable; OnUpdate := s.OnUpdate; OnDelete := s.OnDelete; @@ -9369,6 +11363,7 @@ procedure TForeignKey.Assign(Source: TPersistent); function TForeignKey.SQLCode(IncludeSymbolName: Boolean): String; var i: Integer; + TablePart: String; begin Result := ''; // Symbol names are unique in a db. In order to autocreate a valid name we leave the constraint clause away. @@ -9378,7 +11373,18 @@ function TForeignKey.SQLCode(IncludeSymbolName: Boolean): String; for i:=0 to Columns.Count-1 do Result := Result + FConnection.QuoteIdent(Columns[i]) + ', '; if Columns.Count > 0 then Delete(Result, Length(Result)-1, 2); - Result := Result + ') REFERENCES ' + FConnection.QuoteIdent(ReferenceTable, True, '.') + ' ('; + Result := Result + ') REFERENCES '; + if (not ReferenceDb.IsEmpty) and (ReferenceTable.StartsWith(ReferenceDb)) then begin + TablePart := ReferenceTable.Substring(Length(ReferenceDb) + 1); + if ReferenceDb <> Db then + Result := Result + FConnection.QuoteIdent(ReferenceDb) + '.' + FConnection.QuoteIdent(TablePart) + else + Result := Result + FConnection.QuoteIdent(TablePart); + end + else begin + Result := Result + FConnection.QuoteIdent(ReferenceTable, True, '.'); + end; + Result := Result + ' ('; for i:=0 to ForeignColumns.Count-1 do Result := Result + FConnection.QuoteIdent(ForeignColumns[i]) + ', '; if ForeignColumns.Count > 0 then Delete(Result, Length(Result)-1, 2); @@ -9395,13 +11401,19 @@ function TForeignKey.ReferenceTableObj: TDBObject; RefDb, RefTable: String; begin // Find database object of reference table - RefDb := ReferenceTable.Substring(0, Pos('.', ReferenceTable)-1); - if not RefDb.IsEmpty then begin - RefTable := ReferenceTable.Substring(Length(RefDb)+1); + if (not ReferenceDb.IsEmpty) and (ReferenceTable.StartsWith(ReferenceDb)) then begin + RefDb := ReferenceDb; + RefTable := ReferenceTable.Substring(Length(ReferenceDb) + 1); end else begin - RefDb := FConnection.Database; - RefTable := ReferenceTable; + RefDb := ReferenceTable.Substring(0, Pos('.', ReferenceTable)-1); + if (not RefDb.IsEmpty) and (FConnection.FAllDatabases.IndexOf(RefDb) > -1) then begin + RefTable := ReferenceTable.Substring(Length(RefDb)+1); + end else begin + RefDb := FConnection.Database; + RefTable := ReferenceTable; + end; end; + FConnection.Log(lcDebug, 'Find object "'+RefTable+'" in db "'+RefDb+'"'); Result := FConnection.FindObject(RefDb, RefTable); end; @@ -9411,14 +11423,99 @@ procedure TForeignKeyList.Assign(Source: TForeignKeyList); Item, ItemCopy: TForeignKey; begin for Item in Source do begin - ItemCopy := TForeignKey.Create(Item.FConnection); + ItemCopy := TForeignKey.Create(Item.Connection); + ItemCopy.Assign(Item); + Add(ItemCopy); + end; +end; + + +{ *** TCheckConstraint } + +constructor TCheckConstraint.Create(AOwner: TDBConnection); +begin + inherited Create; + FConnection := AOwner; +end; + + +procedure TCheckConstraint.Assign(Source: TPersistent); +var + s: TCheckConstraint; +begin + if Source is TCheckConstraint then begin + s := Source as TCheckConstraint; + FName := s.Name; + FCheckClause := s.CheckClause; + FModified := s.Modified; + FAdded := s.Added; + end else + inherited; +end; + +function TCheckConstraint.SQLCode: String; +begin + Result := 'CONSTRAINT '+FConnection.QuoteIdent(FName)+' CHECK ('+FCheckClause+')'; +end; + +procedure TCheckConstraintList.Assign(Source: TCheckConstraintList); +var + Item, ItemCopy: TCheckConstraint; +begin + for Item in Source do begin + ItemCopy := TCheckConstraint.Create(Item.Connection); ItemCopy.Assign(Item); Add(ItemCopy); end; - Loaded := Source.Loaded; end; +{ TSQLFunctionList } + +constructor TSQLFunctionList.Create(AOwner: TDBConnection; SQLFunctionsFileOrder: String); +var + TryFiles: TStringList; + TryFile: String; + Ini: TMemIniFile; + Sections: TStringList; + IniFilePath, Section: String; + SQLFunc: TSQLFunction; +begin + inherited Create(True); + FOwner := AOwner; + + FCategories := TStringList.Create; + FCategories.Duplicates := dupIgnore; + FCategories.Sorted := True; // ensures dupIgnore works + FNames := TStringList.Create; + FNames.Duplicates := dupIgnore; + FNames.Sorted := True; + + TryFiles := Explode(',', SQLFunctionsFileOrder); + for TryFile in TryFiles do begin + IniFilePath := GetAppDir + 'functions-'+TryFile+'.ini'; + FOwner.Log(lcDebug, 'Trying '+IniFilePath); + if FileExists(IniFilePath) then begin + FOwner.Log(lcInfo, 'Reading function definitions from '+IniFilePath); + Ini := TMemIniFile.Create(IniFilePath); + Sections := TStringList.Create; + Ini.ReadSections(Sections); + for Section in Sections do begin + SQLFunc := TSQLFunction.Create; + SQLFunc.Name := Ini.ReadString(Section, 'Name', Section); + SQLFunc.Declaration := '(' + Ini.ReadString(Section, 'Declaration', '') + ')'; + SQLFunc.Category := Ini.ReadString(Section, 'Category', ''); + SQLFunc.Description := Ini.ReadString(Section, 'Description', ''); + SQLFunc.Description := StringReplace(SQLFunc.Description, '\n', sLineBreak, [rfReplaceAll]); + Add(SQLFunc); + FCategories.Add(SQLFunc.Category); + FNames.Add(SQLFunc.Name); + end; + Ini.Free; + Break; + end; + end; +end; procedure SQLite_CollationNeededCallback(userData: Pointer; ppDb:Psqlite3; eTextRep:integer; zName:PAnsiChar); cdecl; diff --git a/source/dbstructures.interbase.pas b/source/dbstructures.interbase.pas new file mode 100644 index 000000000..cadd7e8b2 --- /dev/null +++ b/source/dbstructures.interbase.pas @@ -0,0 +1,242 @@ +unit dbstructures.interbase; + + +interface + +uses + dbstructures, StrUtils; + +type + TInterbaseProvider = class(TSqlProvider) + public + function GetSql(AId: TQueryId): string; override; + end; + +var + + // Interbase field types + // Taken from https://docwiki.embarcadero.com/InterBase/2020/en/RDB$FIELDS + InterbaseDatatypes: Array[0..13] of TDBDatatype = + ( + ( + Index: dbdtUnknown; + Name: 'UNKNOWN'; + Description: 'Unknown data type'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: False; + Category: dtcOther; + ), + ( + Index: dbdtBlob; + NativeTypes: '261'; + Name: 'BLOB'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: True; + Category: dtcBinary; + ), + ( + Index: dbdtBool; + NativeTypes: '17'; + Name: 'BOOLEAN'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: False; + Category: dtcOther; + ), + ( + Index: dbdtChar; + NativeTypes: '14'; + Name: 'CHAR'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: False; + Category: dtcText; + ), + ( + Index: dbdtVarchar; + NativeTypes: '37|40'; + Name: 'VARCHAR'; + HasLength: True; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: True; + Category: dtcText; + ), + ( + Index: dbdtFloat; + NativeTypes: '10|11'; + Name: 'FLOAT'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: False; + Category: dtcReal; + ), + ( + Index: dbdtDouble; + NativeTypes: '27'; + Name: 'DOUBLE PRECISION'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: False; + Category: dtcReal; + ), + ( + Index: dbdtBigint; + NativeTypes: '16'; + Name: 'INT64'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: False; + Category: dtcInteger; + ), + ( + Index: dbdtInt; + NativeTypes: '8'; + Name: 'INTEGER'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: False; + Category: dtcInteger; + ), + ( + Index: dbdtNumeric; + NativeTypes: '9'; + Name: 'QUAD'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: False; + Category: dtcInteger; + ), + ( + Index: dbdtSmallint; + NativeTypes: '7'; + Name: 'SMALLINT'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: False; + Category: dtcInteger; + ), + ( + Index: dbdtDate; + NativeTypes: '12'; + Name: 'DATE'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: False; + Category: dtcTemporal; + ), + ( + Index: dbdtTime; + NativeTypes: '13'; + Name: 'TIME'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: False; + Category: dtcTemporal; + ), + ( + Index: dbdtTimestamp; + NativeTypes: '35'; + Name: 'TIMESTAMP'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: False; + Category: dtcTemporal; + ) + ); + + +implementation + + +{ TInterbaseProvider } + +function TInterbaseProvider.GetSql(AId: TQueryId): string; +begin + case AId of + qDatabaseDrop: Result := 'DROP DATABASE %s'; + qEmptyTable: Result := 'TRUNCATE %s'; + qRenameTable: Result := 'RENAME TABLE %s TO %s'; + qRenameView: Result := 'RENAME TABLE %s TO %s'; + qCurrentUserHost: Result := IfThen( + FNetType in [ntInterbase_TCPIP, ntInterbase_Local], + 'select user from rdb$database', + 'select current_user || ''@'' || mon$attachments.mon$remote_host from mon$attachments where mon$attachments.mon$attachment_id = current_connection' + ); + qLikeCompare: Result := '%s LIKE %s'; + qAddColumn: Result := 'ADD COLUMN %s'; + qChangeColumn: Result := 'CHANGE COLUMN %s %s'; + qRenameColumn: Result := ''; + qSessionVariables: Result := 'SHOW VARIABLES'; + qGlobalVariables: Result := 'SHOW GLOBAL VARIABLES'; + qISSchemaCol: Result := '%s_SCHEMA'; + qUSEQuery: Result := ''; + qKillQuery: Result := 'KILL %d'; + qKillProcess: Result := 'KILL %d'; + qFuncLength: Result := 'LENGTH'; + qFuncCeil: Result := 'CEIL'; + qFuncLeft: Result := 'SUBSTR(%s, 1, %d)'; + qFuncNow: Result := ' cast(''now'' as timestamp) from rdb$database'; + qFuncLastAutoIncNumber: Result := 'LAST_INSERT_ID()'; + qLockedTables: Result := ''; + qDisableForeignKeyChecks: Result := ''; + qEnableForeignKeyChecks: Result := ''; + qForeignKeyDrop: Result := 'DROP FOREIGN KEY %s'; + qGetTableColumns: Result := 'SELECT r.RDB$FIELD_NAME AS field_name,'+ + ' r.RDB$DESCRIPTION AS field_description,'+ + ' r.RDB$DEFAULT_VALUE AS field_default_value,'+ + ' r.RDB$NULL_FLAG AS null_flag,'+ + ' f.RDB$FIELD_LENGTH AS field_length,'+ + ' f.RDB$FIELD_PRECISION AS field_precision,'+ + ' f.RDB$FIELD_SCALE AS field_scale,'+ + ' f.RDB$FIELD_TYPE AS field_type,'+ + ' f.RDB$FIELD_SUB_TYPE AS field_subtype,'+ + ' coll.RDB$COLLATION_NAME AS field_collation,'+ + ' cset.RDB$CHARACTER_SET_NAME AS field_charset'+ + ' FROM RDB$RELATION_FIELDS r'+ + ' LEFT JOIN RDB$FIELDS f ON r.RDB$FIELD_SOURCE = f.RDB$FIELD_NAME'+ + ' LEFT JOIN RDB$CHARACTER_SETS cset ON f.RDB$CHARACTER_SET_ID = cset.RDB$CHARACTER_SET_ID'+ + ' LEFT JOIN RDB$COLLATIONS coll ON f.RDB$COLLATION_ID = coll.RDB$COLLATION_ID'+ + ' AND F.RDB$CHARACTER_SET_ID = COLL.RDB$CHARACTER_SET_ID'+ + ' WHERE r.RDB$RELATION_NAME=%s'+ + ' ORDER BY r.RDB$FIELD_POSITION'; + qGetCollations: Result := 'SELECT RDB$COLLATION_NAME AS "Collation",'+ + ' RDB$COLLATION_ID AS "Id",'+ + ' RDB$CHARACTER_SET_ID'+ + ' FROM RDB$COLLATIONS'; + qGetCharsets: Result := 'SELECT RDB$CHARACTER_SET_NAME AS "Charset", RDB$CHARACTER_SET_NAME AS "Description" FROM RDB$CHARACTER_SETS'; + else Result := inherited; + end; +end; + + +end. \ No newline at end of file diff --git a/source/dbstructures.mssql.pas b/source/dbstructures.mssql.pas new file mode 100644 index 000000000..750e02b43 --- /dev/null +++ b/source/dbstructures.mssql.pas @@ -0,0 +1,515 @@ +unit dbstructures.mssql; + +interface + +uses + dbstructures, StrUtils, SysUtils; + +type + TMsSqlProvider = class(TSqlProvider) + public + function GetSql(AId: TQueryId): string; override; + end; + +var + + MSSQLDatatypes: array [0..33] of TDBDatatype = + ( + ( + Index: dbdtUnknown; + NativeTypes: '99999'; + Name: 'UNKNOWN'; + Description: 'Unknown data type'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: False; + Category: dtcOther; + ), + ( + Index: dbdtTinyint; + Name: 'TINYINT'; + Description: 'Integer data from 0 through 255.'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: True; + LoadPart: False; + Category: dtcInteger; + ), + ( + Index: dbdtSmallint; + Name: 'SMALLINT'; + Description: 'Integer data from -2^15 (-32,768) through 2^15 - 1 (32,767).'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: True; + LoadPart: False; + Category: dtcInteger; + ), + ( + Index: dbdtInt; + Name: 'INT'; + Description: 'Integer (whole number) data from -2^31 (-2,147,483,648) through 2^31 - 1 (2,147,483,647).'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: True; + LoadPart: False; + Category: dtcInteger; + ), + ( + Index: dbdtBigint; + Name: 'BIGINT'; + Description: 'Integer (whole number) data from -2^63 (-9,223,372,036,854,775,808) through 2^63-1 (9,223,372,036,854,775,807).'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: True; + LoadPart: False; + Category: dtcInteger; + ), + ( + Index: dbdtBit; + Name: 'BIT'; + Description: '0 or 1'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: True; + LoadPart: False; + Category: dtcInteger; + ), + ( + Index: dbdtDecimal; + Name: 'DECIMAL'; + Description: 'Fixed precision and scale numeric data from -10^38 +1 through 10^38 –1.'; + HasLength: True; + RequiresLength: True; + HasBinary: False; + HasDefault: True; + LoadPart: False; + DefLengthSet: '10,0'; + Category: dtcReal; + ), + ( + Index: dbdtNumeric; + Name: 'NUMERIC'; + Description: 'Functionally equivalent to decimal.'; + HasLength: True; + RequiresLength: True; + HasBinary: False; + HasDefault: True; + LoadPart: False; + DefLengthSet: '10,0'; + Category: dtcReal; + ), + ( + Index: dbdtMoney; + Name: 'MONEY'; + Description: 'Monetary data values from -2^63 (-922,337,203,685,477.5808) through 2^63 - 1 (+922,337,203,685,477.5807), with accuracy to a ten-thousandth of a monetary unit.'; + HasLength: True; + RequiresLength: False; + HasBinary: False; + HasDefault: True; + LoadPart: False; + Category: dtcReal; + ), + ( + Index: dbdtSmallmoney; + Name: 'SMALLMONEY'; + Description: 'Monetary data values from -214,748.3648 through +214,748.3647, with accuracy to a ten-thousandth of a monetary unit.'; + HasLength: True; + RequiresLength: False; + HasBinary: False; + HasDefault: True; + LoadPart: False; + Category: dtcReal; + ), + ( + Index: dbdtFloat; + Name: 'FLOAT'; + Description: 'Floating precision number data with the following valid values: -1.79E + 308 through -2.23E - 308, 0 and 2.23E + 308 through 1.79E + 308.'; + HasLength: True; + RequiresLength: False; + HasBinary: False; + HasDefault: True; + LoadPart: False; + Category: dtcReal; + ), + ( + Index: dbdtReal; + Name: 'REAL'; + Description: 'Floating precision number data with the following valid values: -3.40E + 38 through -1.18E - 38, 0 and 1.18E - 38 through 3.40E + 38.'; + HasLength: True; + RequiresLength: False; + HasBinary: False; + HasDefault: True; + LoadPart: False; + Category: dtcReal; + ), + ( + Index: dbdtTime; + Name: 'TIME'; + Description: 'The time data type stores time values only, based on a 24-hour clock. '+ + 'The time data type has a range of 00:00:00.0000000 through 23:59:59.9999999 with an '+ + 'accuracy of 100 nanoseconds. The default value is 00:00:00.0000000 (midnight). The '+ + 'time data type supports user-defined fractional second precision, and the storage '+ + 'size varies from 3 to 6 bytes, based on the precision specified.'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: True; + LoadPart: False; + Format: 'hh:nn:ss'; + Category: dtcTemporal; + ), + ( + Index: dbdtDate; + Name: 'DATE'; + Description: 'The date data type has a range of January 1, 01 through December 31, '+ + '9999 with an accuracy of 1 day. The default value is January 1, 1900. The storage size '+ + 'is 3 bytes.'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: True; + LoadPart: False; + Format: 'yyyy-mm-dd'; + Category: dtcTemporal; + ), + ( + Index: dbdtDatetime; + Name: 'DATETIME'; + Description: 'Date and time data from January 1, 1753, through December 31, 9999, with an accuracy of three-hundredths of a second, or 3.33 milliseconds.'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: True; + LoadPart: False; + Format: 'yyyy-mm-dd hh:nn:ss.zzz'; + Category: dtcTemporal; + ), + ( + Index: dbdtDatetime2; + Name: 'DATETIME2'; + Description: 'Date and time data from January 1,1 AD through December 31, 9999 AD, with an accuracy of three-hundredths of a second, or 3.33 milliseconds.'; + HasLength: True; + RequiresLength: False; + HasBinary: False; + HasDefault: True; + LoadPart: False; + Format: 'yyyy-mm-dd hh:nn:ss.zzzzzzz'; + Category: dtcTemporal; + ), + ( + Index: dbdtDatetimeOffset; + Name: 'DATETIMEOFFSET'; + Description: 'Defines a date that is combined with a time of a day that has time zone awareness and is based on a 24-hour clock.'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: True; + LoadPart: False; + Format: 'yyyy-mm-dd hh:nn:ss.zzzzzzz'; + Category: dtcTemporal; + ), + ( + Index: dbdtSmalldatetime; + Name: 'SMALLDATETIME'; + Description: 'Date and time data from January 1, 1900, through June 6, 2079, with an accuracy of one minute.'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: True; + LoadPart: False; + Format: 'yyyy-mm-dd hh:nn:ss'; + Category: dtcTemporal; + ), + ( + Index: dbdtTimestamp; + Name: 'TIMESTAMP'; + Description: 'A database-wide unique number that gets updated every time a row gets updated.'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: False; + Category: dtcInteger; + ), + ( + Index: dbdtChar; + Name: 'CHAR'; + Description: 'Fixed-length non-Unicode character data with a maximum length of 8,000 characters.'; + HasLength: True; + RequiresLength: True; + HasBinary: False; + HasDefault: True; + LoadPart: True; + DefLengthSet: '50'; + Category: dtcText; + ), + ( + Index: dbdtVarchar; + Name: 'VARCHAR'; + Description: 'Variable-length non-Unicode data with a maximum of 8,000 characters.'; + HasLength: True; + RequiresLength: True; + HasBinary: False; + HasDefault: True; + LoadPart: True; + DefLengthSet: '50'; + Category: dtcText; + ), + ( + Index: dbdtText; + Name: 'TEXT'; + Description: 'Variable-length non-Unicode data with a maximum length of 2^31 - 1 (2,147,483,647) characters.'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: True; + Category: dtcText; + ), + ( + Index: dbdtNchar; + Name: 'NCHAR'; + Description: 'Fixed-length Unicode data with a maximum length of 4,000 characters.'; + HasLength: True; + RequiresLength: True; + HasBinary: False; + HasDefault: True; + LoadPart: True; + DefLengthSet: '50'; + Category: dtcText; + ), + ( + Index: dbdtNvarchar; + Name: 'NVARCHAR'; + Description: 'Variable-length Unicode data with a maximum length of 4,000 characters. sysname is a system-supplied user-defined data type that is functionally equivalent to nvarchar(128) and is used to reference database object names.'; + HasLength: True; + RequiresLength: True; + HasBinary: False; + HasDefault: True; + LoadPart: True; + DefLengthSet: '50'; + Category: dtcText; + ), + ( + Index: dbdtNtext; + Name: 'NTEXT'; + Description: 'Variable-length Unicode data with a maximum length of 2^30 - 1 (1,073,741,823) characters.'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: True; + Category: dtcText; + ), + ( + Index: dbdtBinary; + Name: 'BINARY'; + Description: 'Fixed-length binary data with a maximum length of 8,000 bytes.'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: True; + Category: dtcBinary; + ), + ( + Index: dbdtVarbinary; + Name: 'VARBINARY'; + Description: 'Variable-length binary data with a maximum length of 8,000 bytes.'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: True; + Category: dtcBinary; + ), + ( + Index: dbdtImage; + Name: 'IMAGE'; + Description: 'Variable-length binary data with a maximum length of 2^31 - 1 (2,147,483,647) bytes.'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: False; + Category: dtcBinary; + ), + ( + Index: dbdtCursor; + Name: 'CURSOR'; + Description: 'A reference to a cursor.'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: False; + Category: dtcOther; + ), + ( + Index: dbdtSqlvariant; + Name: 'SQL_VARIANT'; + Description: 'A data type that stores values of various SQL Server-supported data types, except text, ntext, timestamp, and sql_variant.'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: False; + Category: dtcOther; + ), + ( + Index: dbdtTable; + Name: 'TABLE'; + Description: 'A special data type used to store a result set for later processing .'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: False; + Category: dtcOther; + ), + ( + Index: dbdtUniqueidentifier; + Name: 'UNIQUEIDENTIFIER'; + Description: 'A globally unique identifier (GUID).'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: False; + Category: dtcOther; + ), + ( + Index: dbdtHierarchyid; + Name: 'HIERARCHYID'; + Description: 'Represents a position in a hierarchy.'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: False; + Category: dtcOther; + ), + ( + Index: dbdtXML; + Name: 'XML'; + Description: 'Lets you store XML documents and fragments.'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: False; + Category: dtcOther; + ) + ); + + +implementation + +{$I const.inc} + +function TMsSqlProvider.GetSql(AId: TQueryId): string; +begin + case AId of + qDatabaseTable: Result := IfThen( + ServerVersion<=899, + 'master..sysdatabases', + 'sys.databases' + ); + qDatabaseTableId: Result := IfThen( + ServerVersion<=899, + 'dbid', + 'database_id' + ); + qDatabaseDrop: Result := 'DROP DATABASE %s'; + qDbObjectsTable: Result := IfThen( + ServerVersion<=899, + '..sysobjects', + '.sys.objects' + ); + qDbObjectsCreateCol: Result := IfThen( + ServerVersion<=899, + 'crdate', + 'create_date' + ); + qDbObjectsUpdateCol: Result := IfThen( + ServerVersion<=899, + '', + 'modify_date' + ); + qDbObjectsTypeCol: Result := IfThen( + ServerVersion<=899, + 'xtype', + 'type' + ); + qRenameTable: Result := 'EXEC sp_rename %s, %s'; + qRenameView: Result := 'EXEC sp_rename %s, %s'; + qCurrentUserHost: Result := 'SELECT SYSTEM_USER'; + qLikeCompare: Result := '%s LIKE %s'; + qAddColumn: Result := 'ADD %s'; + qChangeColumn: Result := 'ALTER COLUMN %s %s'; + qSetColumnComment: Result := 'IF NOT EXISTS (' + sLineBreak + + ' SELECT 1' + sLineBreak + + ' FROM fn_listextendedproperty (' + sLineBreak + + ' N''MS_Description'',' + sLineBreak + + ' N''SCHEMA'', :EscapedSchema,' + sLineBreak + + ' N''TABLE'', :EscapedName,' + sLineBreak + + ' N''COLUMN'', :TargetColumn' + sLineBreak + + ' )' + sLineBreak + + ')' + sLineBreak + + 'BEGIN' + sLineBreak + + ' EXEC sys.sp_addextendedproperty' + sLineBreak + + ' @name = N''MS_Description'',' + sLineBreak + + ' @value = :NewComment,' + sLineBreak + + ' @level0type = N''SCHEMA'', @level0name = :EscapedSchema,' + sLineBreak + + ' @level1type = N''TABLE'', @level1name = :EscapedName,' + sLineBreak + + ' @level2type = N''COLUMN'', @level2name = :TargetColumn' + sLineBreak + + 'END' + sLineBreak + + 'ELSE BEGIN' + sLineBreak + + ' EXEC sys.sp_updateextendedproperty' + sLineBreak + + ' @name = N''MS_Description'',' + sLineBreak + + ' @value = :NewComment,' + sLineBreak + + ' @level0type = N''SCHEMA'', @level0name = :EscapedSchema,' + sLineBreak + + ' @level1type = N''TABLE'', @level1name = :EscapedName,' + sLineBreak + + ' @level2type = N''COLUMN'', @level2name = :TargetColumn' + sLineBreak + + 'END'; + qSessionVariables: Result := 'SELECT comment, value FROM master.dbo.syscurconfigs ORDER BY comment'; + qGlobalVariables: Result := 'SELECT comment, value FROM master.dbo.syscurconfigs ORDER BY comment'; + qISSchemaCol: Result := '%s_CATALOG'; + qUSEQuery: Result := 'USE %s'; + qKillQuery: Result := 'KILL %d'; + qKillProcess: Result := 'KILL %d'; + qFuncLength: Result := 'LEN'; + qFuncCeil: Result := 'CEILING'; + qFuncLeft: Result := 'LEFT(%s, %d)'; + qFuncNow: Result := 'GETDATE()'; + qFuncLastAutoIncNumber: Result := 'LAST_INSERT_ID()'; + qLockedTables: Result := ''; + qDisableForeignKeyChecks: Result := ''; + qEnableForeignKeyChecks: Result := ''; + qForeignKeyDrop: Result := 'DROP FOREIGN KEY %s'; + qGetTableColumns: Result := ''; + qGetCollations: Result := 'SELECT '''' AS "Collation", '+ + ''''' AS "Charset", 0 AS "Id", '+ + ''''' AS "Default", '''' AS "Compiled", '+ + '1 AS "Sortlen"'; + qGetCharsets: Result := 'SELECT name AS Charset, description AS Description FROM master.sys.syscharsets'; + qGetRowCountApprox: Result := IfThen( + FServerVersion >= 900, + 'SELECT SUM("rows") FROM "sys"."partitions" WHERE "index_id" IN (0, 1) AND "object_id" = object_id(:EscapedDbSchemaName)', + '' + ); + qCastAsText: Result := 'CAST(%s AS NVARCHAR('+IntToStr(GRIDMAXDATA)+'))'; + else Result := inherited; + end; +end; + + +end. diff --git a/source/dbstructures.mysql.pas b/source/dbstructures.mysql.pas new file mode 100644 index 000000000..c872f0833 --- /dev/null +++ b/source/dbstructures.mysql.pas @@ -0,0 +1,3615 @@ +unit dbstructures.mysql; + + +interface + +uses + System.Classes, System.SysUtils, dbstructures, StrUtils; + + +const + // General declarations + MYSQL_ERRMSG_SIZE = 512; + SQLSTATE_LENGTH = 5; + SCRAMBLE_LENGTH = 20; + MYSQL_PORT = 3306; + LOCAL_HOST = 'localhost'; + NAME_LEN = 64; + PROTOCOL_VERSION = 10; + FRM_VER = 6; + + // Field's flags + NOT_NULL_FLAG = 1; + PRI_KEY_FLAG = 2; + UNIQUE_KEY_FLAG = 4; + MULTIPLE_KEY_FLAG = 8; + BLOB_FLAG = 16; + UNSIGNED_FLAG = 32; + ZEROFILL_FLAG = 64; + BINARY_FLAG = 128; + ENUM_FLAG = 256; + AUTO_INCREMENT_FLAG = 512; + TIMESTAMP_FLAG = 1024; + SET_FLAG = 2048; + NO_DEFAULT_VALUE_FLAG = 4096; // Field has no default value + ON_UPDATE_NOW_FLAG = 8192; // If a field is updated it will get the current time value (NOW()) + NUM_FLAG = 32768; // Field is numeric + PART_KEY_FLAG = 16384; // wrong from here on, where do these come from? + GROUP_FLAG = 32768; + UNIQUE_FLAG = 65536; + BINCMP_FLAG = 131072; + + // Client connection options + CLIENT_LONG_PASSWORD: Int64 = 0; // obsolete flag + CLIENT_MYSQL: Int64 = 1; // mysql/old mariadb server/client + CLIENT_FOUND_ROWS: Int64 = 2; // Found instead of affected rows + CLIENT_LONG_FLAG: Int64 = 4; // Get all column flags + CLIENT_CONNECT_WITH_DB: Int64 = 8; // One can specify db on connect + CLIENT_NO_SCHEMA: Int64 = 16; // Don't allow database.table.column + CLIENT_COMPRESS: Int64 = 32; // Can use compression protocol + CLIENT_ODBC: Int64 = 64; // Odbc client + CLIENT_LOCAL_FILES: Int64 = 128; // Can use LOAD DATA LOCAL + CLIENT_IGNORE_SPACE: Int64 = 256; // Ignore spaces before '(' + CLIENT_PROTOCOL_41: Int64 = 512; // New 4.1 protocol + CLIENT_INTERACTIVE: Int64 = 1024; // This is an interactive client + CLIENT_SSL: Int64 = 2048; // Switch to SSL after handshake + CLIENT_IGNORE_SIGPIPE: Int64 = 4096; // IGNORE sigpipes + CLIENT_TRANSACTIONS: Int64 = 8192; // Client knows about transactions + CLIENT_RESERVED: Int64 = 16384; // Old flag for 4.1 protocol + CLIENT_SECURE_CONNECTION: Int64 = 32768; // New 4.1 authentication + CLIENT_MULTI_STATEMENTS: Int64 = 1 Shl 16; // Enable/disable multi-stmt support + CLIENT_MULTI_RESULTS: Int64 = 1 Shl 17; // Enable/disable multi-results + CLIENT_PS_MULTI_RESULTS: Int64 = 1 Shl 18; // Multi-results in PS-protocol + CLIENT_PLUGIN_AUTH: Int64 = 1 Shl 19; // Client supports plugin authentication + CLIENT_CONNECT_ATTRS: Int64 = 1 Shl 20; // Client supports connection attributes + // Enable authentication response packet to be larger than 255 bytes. + CLIENT_PLUGIN_AUTH_LENENC_CLIENT_DATA: Int64 = 1 Shl 21; + // Don't close the connection for a connection with expired password. + CLIENT_CAN_HANDLE_EXPIRED_PASSWORDS: Int64 = 1 Shl 22; + { + Capable of handling server state change information. Its a hint to the + server to include the state change information in Ok packet. + } + CLIENT_SESSION_TRACK: Int64 = 1 Shl 23; + // Client no longer needs EOF packet + CLIENT_DEPRECATE_EOF: Int64 = 1 Shl 24; + CLIENT_PROGRESS_OBSOLETE: Int64 = 1 Shl 29; + CLIENT_SSL_VERIFY_SERVER_CERT: Int64 = 1 Shl 30; + { + It used to be that if mysql_real_connect() failed, it would delete any + options set by the client, unless the CLIENT_REMEMBER_OPTIONS flag was + given. + That behaviour does not appear very useful, and it seems unlikely that + any applications would actually depend on this. So from MariaDB 5.5 we + always preserve any options set in case of failed connect, and this + option is effectively always set. + } + CLIENT_REMEMBER_OPTIONS: Int64 = 1 Shl 31; + + COLLATION_BINARY = 63; + // Equivalent to COLLATION_BINARY, this is what a new driver returns when connected to a pre-4.1 server. + COLLATION_NONE = 0; + + // Relevant MySQL error codes, taken from include/mysql/server/mysqld_error.h + ER_MUST_CHANGE_PASSWORD = 1820; + ER_NO_SUCH_THREAD = 1094; + ER_NONEXISTING_GRANT = 1141; + ER_WRONG_AUTO_KEY = 1075; + +type + PUSED_MEM=^USED_MEM; + USED_MEM = packed record + next: PUSED_MEM; + left: Integer; + size: Integer; + end; + + PERR_PROC = ^ERR_PROC; + ERR_PROC = procedure; + + PMEM_ROOT = ^MEM_ROOT; + MEM_ROOT = packed record + free: PUSED_MEM; + used: PUSED_MEM; + pre_alloc: PUSED_MEM; + min_malloc: Integer; + block_size: Integer; + block_num: Integer; + first_block_usage: Integer; + error_handler: PERR_PROC; + end; + + NET = record + vio: Pointer; + buff: PAnsiChar; + buff_end: PAnsiChar; + write_pos: PAnsiChar; + read_pos: PAnsiChar; + fd: Integer; + max_packet: Cardinal; + max_packet_size: Cardinal; + pkt_nr: Cardinal; + compress_pkt_nr: Cardinal; + write_timeout: Cardinal; + read_timeout: Cardinal; + retry_count: Cardinal; + fcntl: Integer; + compress: Byte; + remain_in_buf: LongInt; + length: LongInt; + buf_length: LongInt; + where_b: LongInt; + return_status: Pointer; + reading_or_writing: Char; + save_char: Char; + no_send_ok: Byte; + last_error: array[1..MYSQL_ERRMSG_SIZE] of Char; + sqlstate: array[1..SQLSTATE_LENGTH + 1] of Char; + last_errno: Cardinal; + error: Char; + query_cache_query: Pointer; + report_error: Byte; + return_errno: Byte; + end; + + PMYSQL_FIELD = ^MYSQL_FIELD; + MYSQL_FIELD = record + name: PAnsiChar; // Name of column + org_name: PAnsiChar; // Name of original column (added after 3.23.58) + table: PAnsiChar; // Table of column if column was a field + org_table: PAnsiChar; // Name of original table (added after 3.23.58 + db: PAnsiChar; // table schema (added after 3.23.58) + catalog: PAnsiChar; // table catalog (added after 3.23.58) + def: PAnsiChar; // Default value (set by mysql_list_fields) + length: LongInt; // Width of column + max_length: LongInt; // Max width of selected set + // added after 3.23.58 + name_length: Cardinal; + org_name_length: Cardinal; + table_length: Cardinal; + org_table_length: Cardinal; + db_length: Cardinal; + catalog_length: Cardinal; + def_length: Cardinal; + //*********************** + flags: Cardinal; // Div flags + decimals: Cardinal; // Number of decimals in field + charsetnr: Cardinal; // char set number (added in 4.1) + _type: Cardinal; // Type of field. Se mysql_com.h for types + end; + + // Added in Oct 2023, to fix usage of mysql_fetch_lengths(). See issue #1863 + PMYSQL_LENGTHS = ^TMYSQL_LENGTHS; + TMYSQL_LENGTHS = array[0..MaxInt div SizeOf(LongWord) - 1] of LongWord; + + MYSQL_ROW = array[0..$ffff] of PAnsiChar; + PMYSQL_ROW = ^MYSQL_ROW; + + PMYSQL_ROWS = ^MYSQL_ROWS; + MYSQL_ROWS = record + next: PMYSQL_ROWS; + data: PMYSQL_ROW; + end; + + MYSQL_DATA = record + Rows: Int64; + Fields: Cardinal; + Data: PMYSQL_ROWS; + Alloc: MEM_ROOT; + end; + PMYSQL_DATA = ^MYSQL_DATA; + + PMYSQL = ^MYSQL; + MYSQL = record + _net: NET; + connector_fd: Pointer; + host: PAnsiChar; + user: PAnsiChar; + passwd: PAnsiChar; + unix_socket: PAnsiChar; + server_version: PAnsiChar; + host_info: PAnsiChar; + info: PAnsiChar; + db: PAnsiChar; + charset: PAnsiChar; + fields: PMYSQL_FIELD; + field_alloc: MEM_ROOT; + affected_rows: Int64; + insert_id: Int64; + extra_info: Int64; + thread_id: LongInt; + packet_length: LongInt; + port: Cardinal; + client_flag: LongInt; + server_capabilities: LongInt; + protocol_version: Cardinal; + field_count: Cardinal; + server_status: Cardinal; + server_language: Cardinal; + warning_count: Cardinal; + options: Cardinal; + status: Byte; + free_me: Byte; + reconnect: Byte; + scramble: array[1..SCRAMBLE_LENGTH+1] of Char; + rpl_pivot: Byte; + master: PMYSQL; + next_slave: PMYSQL; + last_used_slave: PMYSQL; + last_used_con: PMYSQL; + stmts: Pointer; + methods: Pointer; + thd: Pointer; + unbuffered_fetch_owner: PByte; + end; + + MYSQL_RES = record + row_count: Int64; + field_count, current_field: Integer; + fields: PMYSQL_FIELD; + data: PMYSQL_DATA; + data_cursor: PMYSQL_ROWS; + field_alloc: MEM_ROOT; + row: PMYSQL_ROW; // If unbuffered read + current_row: PMYSQL_ROW; // buffer to current row + lengths: PLongInt; // column lengths of current row + handle: PMYSQL; // for unbuffered reads + eof: Byte; // Used my mysql_fetch_row + is_ps: Byte; + end; + PMYSQL_RES = ^MYSQL_RES; + + TMySQLLib = class(TDbLib) + mysql_affected_rows: function(Handle: PMYSQL): Int64; stdcall; + mysql_character_set_name: function(Handle: PMYSQL): PAnsiChar; stdcall; + mysql_close: procedure(Handle: PMYSQL); stdcall; + mysql_data_seek: procedure(Result: PMYSQL_RES; Offset: Int64); stdcall; + mysql_errno: function(Handle: PMYSQL): Cardinal; stdcall; + mysql_error: function(Handle: PMYSQL): PAnsiChar; stdcall; + mysql_fetch_field_direct: function(Result: PMYSQL_RES; FieldNo: Cardinal): PMYSQL_FIELD; stdcall; + mysql_fetch_field: function(Result: PMYSQL_RES): PMYSQL_FIELD; stdcall; + mysql_fetch_lengths: function(Result: PMYSQL_RES): PMYSQL_LENGTHS; stdcall; + mysql_fetch_row: function(Result: PMYSQL_RES): PMYSQL_ROW; stdcall; + mysql_free_result: procedure(Result: PMYSQL_RES); stdcall; + mysql_get_client_info: function: PAnsiChar; stdcall; + mysql_get_server_info: function(Handle: PMYSQL): PAnsiChar; stdcall; + mysql_init: function(Handle: PMYSQL): PMYSQL; stdcall; + mysql_info: function(Handle: PMYSQL): PAnsiChar; stdcall; + mysql_num_fields: function(Result: PMYSQL_RES): Integer; stdcall; + mysql_num_rows: function(Result: PMYSQL_RES): Int64; stdcall; + mysql_options: function(Handle: PMYSQL; Option: Integer; arg: Pointer): Integer; stdcall; + mysql_optionsv: function(Handle: PMYSQL; Option: Integer; arg, val: PAnsiChar): Integer; stdcall; + mysql_ping: function(Handle: PMYSQL): Integer; stdcall; + mysql_real_connect: function(Handle: PMYSQL; const Host, User, Passwd, Db: PAnsiChar; Port: Cardinal; const UnixSocket: PAnsiChar; ClientFlag: Cardinal): PMYSQL; stdcall; + mysql_real_query: function(Handle: PMYSQL; const Query: PAnsiChar; Length: Cardinal): Integer; stdcall; + mysql_stat: function(Handle: PMYSQL): PAnsiChar; stdcall; + mysql_store_result: function(Handle: PMYSQL): PMYSQL_RES; stdcall; + mysql_thread_id: function(Handle: PMYSQL): Cardinal; stdcall; + mysql_next_result: function(Handle: PMYSQL): Integer; stdcall; + mysql_set_character_set: function(Handle: PMYSQL; csname: PAnsiChar): Integer; stdcall; + mysql_thread_init: function: Byte; stdcall; + mysql_thread_end: procedure; stdcall; + mysql_warning_count: function(Handle: PMYSQL): Cardinal; stdcall; + const + INVALID_OPT = -1; + MYBOOL_FALSE: Integer = 0; + MYBOOL_TRUE: Integer = 1; + protected + procedure AssignProcedures; override; + public + MYSQL_OPT_LOCAL_INFILE, + MYSQL_OPT_CONNECT_TIMEOUT, + MARIADB_OPT_TLS_VERSION, + MYSQL_OPT_TLS_VERSION, + MYSQL_PLUGIN_DIR, + MYSQL_OPT_SSL_KEY, + MYSQL_OPT_SSL_CERT, + MYSQL_OPT_SSL_CA, + MYSQL_OPT_SSL_CIPHER, + MYSQL_OPT_CONNECT_ATTR_ADD, + MYSQL_ENABLE_CLEARTEXT_PLUGIN, + MYSQL_OPT_SSL_MODE, + MYSQL_OPT_SSL_VERIFY_SERVER_CERT: Integer; + SSL_MODE_DISABLED, + SSL_MODE_PREFERRED, + SSL_MODE_REQUIRED, + SSL_MODE_VERIFY_CA, + SSL_MODE_VERIFY_IDENTITY: Integer; + constructor Create(DllFile, DefaultDll: String); override; + function IsLibMariadb: Boolean; + end; + + TMySqlProvider = class(TSqlProvider) + public + function GetSql(AId: TQueryId): string; override; + end; + + +var + MySQLKeywords: TStringList; + MySQLErrorCodes: TStringList; + + + // MySQL Data Type List and Properties + MySQLDatatypes: array [0..42] of TDBDatatype = + ( + ( + Index: dbdtUnknown; + NativeTypes: '99999'; + Name: 'UNKNOWN'; + Description: 'Unknown data type'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: False; + Category: dtcOther; + ), + ( + Index: dbdtTinyint; + NativeType: 1; + Name: 'TINYINT'; + Description: 'TINYINT[(M)] [UNSIGNED] [ZEROFILL]' + sLineBreak + + 'A very small integer. The signed range is -128 to 127. ' + + 'The unsigned range is 0 to 255.'; + HasLength: True; + RequiresLength: False; + MaxSize: 127; + HasBinary: False; + HasDefault: True; + LoadPart: False; + Category: dtcInteger; + ), + ( + Index: dbdtBool; + NativeType: 1; + Name: 'BOOLEAN'; + Description: 'Synonym of TINYINT(1)'; + HasLength: False; + RequiresLength: False; + MaxSize: 127; + HasBinary: False; + HasDefault: True; + LoadPart: False; + Category: dtcInteger; + ), + ( + Index: dbdtSmallint; + NativeType: 2; + Name: 'SMALLINT'; + Description: 'SMALLINT[(M)] [UNSIGNED] [ZEROFILL]' + sLineBreak + + 'A small integer. The signed range is -32768 to 32767. ' + + 'The unsigned range is 0 to 65535.'; + HasLength: True; + RequiresLength: False; + MaxSize: 32767; + HasBinary: False; + HasDefault: True; + LoadPart: False; + Category: dtcInteger; + ), + ( + Index: dbdtMediumint; + NativeType: 9; + Name: 'MEDIUMINT'; + Description: 'MEDIUMINT[(M)] [UNSIGNED] [ZEROFILL]' + sLineBreak + + 'A medium-sized integer. The signed range is -8388608 to 8388607. ' + + 'The unsigned range is 0 to 16777215.'; + HasLength: True; + RequiresLength: False; + MaxSize: 8388607; + HasBinary: False; + HasDefault: True; + LoadPart: False; + Category: dtcInteger; + ), + ( + Index: dbdtInt; + NativeType: 3; + Name: 'INT'; + Description: 'INT[(M)] [UNSIGNED] [ZEROFILL]' + sLineBreak + + 'A normal-size integer. The signed range is -2147483648 to 2147483647. ' + + 'The unsigned range is 0 to 4294967295.'; + HasLength: True; + RequiresLength: False; + MaxSize: 2147483647; + HasBinary: False; + HasDefault: True; + LoadPart: False; + Category: dtcInteger; + ), + ( + Index: dbdtBigint; + NativeType: 8; + Name: 'BIGINT'; + Description: 'BIGINT[(M)] [UNSIGNED] [ZEROFILL]' + sLineBreak + + 'A large integer. The signed range is -9223372036854775808 to ' + + '9223372036854775807. The unsigned range is 0 to 18446744073709551615.'; + HasLength: True; + RequiresLength: False; + MaxSize: 9223372036854775807; + HasBinary: False; + HasDefault: True; + LoadPart: False; + Category: dtcInteger; + ), + ( + Index: dbdtFloat; + NativeType: 4; + Name: 'FLOAT'; + Description: 'FLOAT[(M,D)] [UNSIGNED] [ZEROFILL]' + sLineBreak + + 'A small (single-precision) floating-point number. Allowable values are '+ + '-3.402823466E+38 to -1.175494351E-38, 0, and 1.175494351E-38 to '+ + '3.402823466E+38. These are the theoretical limits, based on the IEEE '+ + 'standard. The actual range might be slightly smaller depending on your '+ + 'hardware or operating system.'; + HasLength: True; + RequiresLength: False; + HasBinary: False; + HasDefault: True; + LoadPart: False; + Category: dtcReal; + ), + ( + Index: dbdtDouble; + NativeType: 5; + Name: 'DOUBLE'; + Description: 'DOUBLE[(M,D)] [UNSIGNED] [ZEROFILL]' + sLineBreak + + 'A normal-size (double-precision) floating-point number. Allowable ' + + 'values are -1.7976931348623157E+308 to -2.2250738585072014E-308, 0, and ' + + '2.2250738585072014E-308 to 1.7976931348623157E+308. These are the ' + + 'theoretical limits, based on the IEEE standard. The actual range might ' + + 'be slightly smaller depending on your hardware or operating system.'; + HasLength: True; + RequiresLength: False; + HasBinary: False; + HasDefault: True; + LoadPart: False; + Category: dtcReal; + ), + ( + Index: dbdtDecimal; + NativeType: 246; + Name: 'DECIMAL'; + Description: 'DECIMAL[(M[,D])] [UNSIGNED] [ZEROFILL]' + sLineBreak + + 'A packed "exact" fixed-point number. M is the total number of digits ' + + '(the precision) and D is the number of digits after the decimal point ' + + '(the scale). The decimal point and (for negative numbers) the "-" sign ' + + 'are not counted in M. If D is 0, values have no decimal point or ' + + 'fractional part. The maximum number of digits (M) for DECIMAL is 65. ' + + 'The maximum number of supported decimals (D) is 30. If D is omitted, ' + + 'the default is 0. If M is omitted, the default is 10.'; + HasLength: True; + RequiresLength: True; + MaxSize: 9223372036854775807; + HasBinary: False; + HasDefault: True; + LoadPart: False; + DefLengthSet: '20,6'; + Category: dtcReal; + ), + ( + Index: dbdtDate; + NativeType: 10; + Name: 'DATE'; + Description: 'DATE' + sLineBreak + + 'A date. The supported range is ''1000-01-01'' to ''9999-12-31''. MySQL ' + + 'displays DATE values in ''YYYY-MM-DD'' format, but allows assignment of ' + + 'values to DATE columns using either strings or numbers.'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: True; + LoadPart: False; + Format: 'yyyy-mm-dd'; + Category: dtcTemporal; + ), + ( + Index: dbdtTime; + NativeType: 11; + Name: 'TIME'; + Description: 'TIME' + sLineBreak + + 'A time. The range is ''-838:59:59'' to ''838:59:59''. MySQL displays TIME ' + + 'values in ''HH:MM:SS'' format, but allows assignment of values to TIME ' + + 'columns using either strings or numbers.'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: True; + LoadPart: False; + Format: 'hh:nn:ss'; + Category: dtcTemporal; + ), + ( + Index: dbdtYear; + NativeType: 13; + Name: 'YEAR'; + Description: 'YEAR[(2|4)]' + sLineBreak + + 'A year in two-digit or four-digit format. The default is four-digit ' + + 'format. In four-digit format, the allowable values are 1901 to 2155, ' + + 'and 0000. In two-digit format, the allowable values are 70 to 69, ' + + 'representing years from 1970 to 2069. MySQL displays YEAR values in ' + + 'YYYY format, but allows you to assign values to YEAR columns using ' + + 'either strings or numbers.'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: True; + LoadPart: False; + Format: 'yyyy'; + Category: dtcTemporal; + ), + ( + Index: dbdtDatetime; + NativeType: 12; + Name: 'DATETIME'; + Description: 'DATETIME' + sLineBreak + + 'A date and time combination. The supported range is ''1000-01-01 ' + + '00:00:00'' to ''9999-12-31 23:59:59''. MySQL displays DATETIME values in ' + + '''YYYY-MM-DD HH:MM:SS'' format, but allows assignment of values to ' + + 'DATETIME columns using either strings or numbers.'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: True; + LoadPart: False; + Format: 'yyyy-mm-dd hh:nn:ss'; + Category: dtcTemporal; + ), + ( + Index: dbdtTimestamp; + NativeType: 7; + Name: 'TIMESTAMP'; + Description: 'TIMESTAMP' + sLineBreak + + 'A timestamp. The range is ''1970-01-01 00:00:01'' UTC to ''2038-01-09 ' + + '03:14:07'' UTC. TIMESTAMP values are stored as the number of seconds ' + + 'since the epoch (''1970-01-01 00:00:00'' UTC). A TIMESTAMP cannot ' + + 'represent the value ''1970-01-01 00:00:00'' because that is equivalent to ' + + '0 seconds from the epoch and the value 0 is reserved for representing ' + + '''0000-00-00 00:00:00'', the "zero" TIMESTAMP value.'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: True; + LoadPart: False; + Format: 'yyyy-mm-dd hh:nn:ss'; + Category: dtcTemporal; + ), + ( + Index: dbdtVarchar; + NativeType: 253; + Name: 'VARCHAR'; + Description: 'VARCHAR(M)' + sLineBreak + + 'A variable-length string. M represents the maximum column length in ' + + 'characters. The range of M is 0 to 65,535. The effective maximum length ' + + 'of a VARCHAR is subject to the maximum row size (65,535 bytes, which is ' + + 'shared among all columns) and the character set used. For example, utf8 ' + + 'characters can require up to three bytes per character, so a VARCHAR ' + + 'column that uses the utf8 character set can be declared to be a maximum ' + + 'of 21,844 characters. ' + sLineBreak + sLineBreak + + '*Note*: MySQL 5.1 follows the standard SQL specification, and does not ' + + 'remove trailing spaces from VARCHAR values.'; + HasLength: True; + RequiresLength: True; + MaxSize: 255; + HasBinary: True; // MySQL-Help says the opposite but it's valid for older versions at least. + HasDefault: True; + LoadPart: True; + DefLengthSet: '50'; + Category: dtcText; + ), + ( + Index: dbdtChar; + NativeType: 254; + Name: 'CHAR'; + Description: 'CHAR[(M)]' + sLineBreak + + 'A fixed-length string that is always right-padded with spaces to the ' + + 'specified length when stored. M represents the column length in ' + + 'characters. The range of M is 0 to 255. If M is omitted, the length is 1.' + sLineBreak + sLineBreak + + '*Note*: Trailing spaces are removed when CHAR values are retrieved ' + + 'unless the PAD_CHAR_TO_FULL_LENGTH SQL mode is enabled.'; + HasLength: True; + RequiresLength: True; + MaxSize: 255; + HasBinary: True; + HasDefault: True; + LoadPart: False; + DefLengthSet: '50'; + Category: dtcText; + ), + ( + Index: dbdtTinytext; + NativeType: 249; + Name: 'TINYTEXT'; + Description: 'TINYTEXT' + sLineBreak + + 'A TEXT column with a maximum length of 255 (2^8 - 1) characters. The ' + + 'effective maximum length is less if the value contains multi-byte ' + + 'characters. Each TINYTEXT value is stored using a one-byte length ' + + 'prefix that indicates the number of bytes in the value.'; + HasLength: False; + RequiresLength: False; + MaxSize: 255; + HasBinary: True; + HasDefault: False; + LoadPart: False; + Category: dtcText; + ), + ( + Index: dbdtText; + NativeType: 252; + Name: 'TEXT'; + Description: 'TEXT[(M)]' + sLineBreak + + 'A TEXT column with a maximum length of 65,535 (2^16 - 1) characters. The ' + + 'effective maximum length is less if the value contains multi-byte ' + + 'characters. Each TEXT value is stored using a two-byte length prefix ' + + 'that indicates the number of bytes in the value. ' + sLineBreak + + 'An optional length M can be given for this type. If this is done, MySQL ' + + 'creates the column as the smallest TEXT type large enough to hold ' + + 'values M characters long.'; + HasLength: True; + RequiresLength: False; + MaxSize: 65535; + DefaultSize: 65535; + HasBinary: True; + HasDefault: False; + LoadPart: True; + Category: dtcText; + ), + ( + Index: dbdtMediumtext; + NativeType: 250; + Name: 'MEDIUMTEXT'; + Description: 'MEDIUMTEXT' + sLineBreak + + 'A TEXT column with a maximum length of 16,777,215 (2^24 - 1) characters. ' + + 'The effective maximum length is less if the value contains multi-byte ' + + 'characters. Each MEDIUMTEXT value is stored using a three-byte length ' + + 'prefix that indicates the number of bytes in the value.'; + HasLength: False; + RequiresLength: False; + HasBinary: True; + HasDefault: False; + LoadPart: True; + Category: dtcText; + ), + ( + Index: dbdtLongtext; + NativeType: 251; + Name: 'LONGTEXT'; + Description: 'LONGTEXT' + sLineBreak + + 'A TEXT column with a maximum length of 4,294,967,295 or 4GB (2^32 - 1) ' + + 'characters. The effective maximum length is less if the value contains ' + + 'multi-byte characters. The effective maximum length of LONGTEXT columns ' + + 'also depends on the configured maximum packet size in the client/server ' + + 'protocol and available memory. Each LONGTEXT value is stored using a ' + + 'four-byte length prefix that indicates the number of bytes in the ' + + 'value.'; + HasLength: False; + RequiresLength: False; + HasBinary: True; + HasDefault: False; + LoadPart: True; + Category: dtcText; + ), + ( + Index: dbdtJson; + NativeType: 245; + Name: 'JSON'; + Description: 'JSON' + sLineBreak + + 'Documents stored in JSON columns are converted to an internal format that '+ + 'permits quick read access to document elements. When the server later must '+ + 'read a JSON value stored in this binary format, the value need not be parsed '+ + 'from a text representation. The binary format is structured to enable the '+ + 'server to look up subobjects or nested values directly by key or array index '+ + 'without reading all values before or after them in the document.'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: True; + Category: dtcText; + ), + ( + Index: dbdtUniqueidentifier; + NativeType: 254; + Name: 'UUID'; + Description: 'UUID' + sLineBreak + + 'The UUID data type is intended for the storage of 128-bit UUID (Universally ' + + 'Unique Identifier) data. See the UUID function page for more details on UUIDs ' + + 'themselves.'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: False; + Category: dtcText; + ), + ( + Index: dbdtInet4; + NativeType: 255; + Name: 'INET4'; + Description: 'INET4' + sLineBreak + + 'INET4 is a data type to store IPv4 addresses, as 4-byte binary strings. '+ + 'It was added in MariaDB 10.10.0'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: True; + LoadPart: False; + Category: dtcText; + MinVersion: 10100; + ), + ( + Index: dbdtInet6; + NativeType: 255; + Name: 'INET6'; + Description: 'INET6' + sLineBreak + + 'The INET6 data type is intended for storage of IPv6 addresses, as well as ' + + 'IPv4 addresses assuming conventional mapping of IPv4 addresses into IPv6 ' + + 'addresses. ' + slineBreak + + 'Both short and long IPv6 notation are permitted, according to RFC-5952. '+ + 'It was added in MariaDB 10.5.0'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: True; + LoadPart: False; + Category: dtcText; + MinVersion: 10050; + ), + ( + Index: dbdtBinary; + NativeType: 254; + Name: 'BINARY'; + Description: 'BINARY(M)' + sLineBreak + + 'The BINARY type is similar to the CHAR type, but stores binary byte ' + + 'strings rather than non-binary character strings. M represents the ' + + 'column length in bytes.'; + HasLength: True; + RequiresLength: True; + HasBinary: False; + HasDefault: True; + LoadPart: False; + DefLengthSet: '50'; + Category: dtcBinary; + ), + ( + Index: dbdtVarbinary; + NativeType: 253; + Name: 'VARBINARY'; + Description: 'VARBINARY(M)' + sLineBreak + + 'The VARBINARY type is similar to the VARCHAR type, but stores binary ' + + 'byte strings rather than non-binary character strings. M represents the ' + + 'maximum column length in bytes.'; + HasLength: True; + RequiresLength: True; + HasBinary: False; + HasDefault: True; + LoadPart: True; + DefLengthSet: '50'; + Category: dtcBinary; + ), + ( + Index: dbdtTinyblob; + NativeType: 249; + Name: 'TINYBLOB'; + Description: 'TINYBLOB' + sLineBreak + + 'A BLOB column with a maximum length of 255 (2^8 - 1) bytes. Each ' + + 'TINYBLOB value is stored using a one-byte length prefix that indicates ' + + 'the number of bytes in the value.'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: False; + Category: dtcBinary; + ), + ( + Index: dbdtBlob; + NativeType: 252; + Name: 'BLOB'; + Description: 'BLOB[(M)]' + sLineBreak + + 'A BLOB column with a maximum length of 65,535 (2^16 - 1) bytes. Each ' + + 'BLOB value is stored using a two-byte length prefix that indicates the ' + + 'number of bytes in the value. ' + sLineBreak + + 'An optional length M can be given for this type. If this is done, MySQL ' + + 'creates the column as the smallest BLOB type large enough to hold ' + + 'values M bytes long.'; + HasLength: True; + RequiresLength: False; + MaxSize: 65535; + DefaultSize: 65535; + HasBinary: False; + HasDefault: False; + LoadPart: True; + Category: dtcBinary; + ), + ( + Index: dbdtMediumblob; + NativeType: 250; + Name: 'MEDIUMBLOB'; + Description: 'MEDIUMBLOB' + sLineBreak + + 'A BLOB column with a maximum length of 16,777,215 (2^24 - 1) bytes. Each ' + + 'MEDIUMBLOB value is stored using a three-byte length prefix that ' + + 'indicates the number of bytes in the value.'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: True; + Category: dtcBinary; + ), + ( + Index: dbdtLongblob; + NativeType: 251; + Name: 'LONGBLOB'; + Description: 'LONGBLOB' + sLineBreak + + 'A BLOB column with a maximum length of 4,294,967,295 or 4GB (2^32 - 1) ' + + 'bytes. The effective maximum length of LONGBLOB columns depends on the ' + + 'configured maximum packet size in the client/server protocol and ' + + 'available memory. Each LONGBLOB value is stored using a four-byte ' + + 'length prefix that indicates the number of bytes in the value.'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: True; + Category: dtcBinary; + ), + ( + Index: dbdtVector; + NativeType: 253; + Name: 'VECTOR'; + Description: 'VECTOR(N)' + sLineBreak + + 'VECTOR data type with a built-in data validation. N is the number of dimensions ' + + 'that all vector values in the column will have.'; + HasLength: True; + RequiresLength: True; + HasBinary: False; + HasDefault: False; + LoadPart: False; + Category: dtcBinary; + ), + ( + Index: dbdtEnum; + NativeType: 247; + Name: 'ENUM'; + Description: 'ENUM(''value1'',''value2'',...)' + sLineBreak + + 'An enumeration. A string object that can have only one value, chosen ' + + 'from the list of values ''value1'', ''value2'', ..., NULL or the special '''' ' + + 'error value. An ENUM column can have a maximum of 65,535 distinct ' + + 'values. ENUM values are represented internally as integers.'; + HasLength: True; // Obviously this is not meant as "length", but as "set of values" + RequiresLength: True; + HasBinary: False; + HasDefault: True; + LoadPart: False; + DefLengthSet: '''Y'',''N'''; + Category: dtcOther; + ), + ( + Index: dbdtSet; + NativeType: 248; + Name: 'SET'; + Description: 'SET(''value1'',''value2'',...)' + sLineBreak + + 'A set. A string object that can have zero or more values, each of which ' + + 'must be chosen from the list of values ''value1'', ''value2'', ... A SET ' + + 'column can have a maximum of 64 members. SET values are represented ' + + 'internally as integers.'; + HasLength: True; // Same as for ENUM + RequiresLength: True; + HasBinary: False; + HasDefault: True; + LoadPart: False; + DefLengthSet: '''Value A'',''Value B'''; + Category: dtcOther; + ), + ( + Index: dbdtBit; + NativeType: 16; + Name: 'BIT'; + Description: 'BIT[(M)]' + sLineBreak + + 'A bit-field type. M indicates the number of bits per value, from 1 to ' + + '64. The default is 1 if M is omitted.'; + HasLength: True; + RequiresLength: False; + HasBinary: False; + HasDefault: True; + LoadPart: False; + Category: dtcInteger; + ), + ( + Index: dbdtPoint; + NativeType: 255; + Name: 'POINT'; + Description: 'POINT(x,y)' + sLineBreak + + 'Constructs a WKB Point using its coordinates.'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: False; + Category: dtcSpatial; + ), + ( + Index: dbdtLinestring; + NativeType: 255; + Name: 'LINESTRING'; + Description: 'LINESTRING(pt1,pt2,...)' + sLineBreak + + 'Constructs a WKB LineString value from a number of WKB Point arguments. ' + + 'If any argument is not a WKB Point, the return value is NULL. If the ' + + 'number of Point arguments is less than two, the return value is NULL.'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: False; + Category: dtcSpatial; + ), + ( + Index: dbdtPolygon; + NativeType: 255; + Name: 'POLYGON'; + Description: 'POLYGON(ls1,ls2,...)' + sLineBreak + + 'Constructs a WKB Polygon value from a number of WKB LineString ' + + 'arguments. If any argument does not represent the WKB of a LinearRing ' + + '(that is, not a closed and simple LineString) the return value is NULL.'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: False; + Category: dtcSpatial; + ), + ( + Index: dbdtGeometry; + NativeType: 255; + Name: 'GEOMETRY'; + Description: ''; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: False; + Category: dtcSpatial; + ), + ( + Index: dbdtMultipoint; + NativeType: 255; + Name: 'MULTIPOINT'; + Description: 'MULTIPOINT(pt1,pt2,...)' + sLineBreak + + 'Constructs a WKB MultiPoint value using WKB Point arguments. If any ' + + 'argument is not a WKB Point, the return value is NULL.'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: False; + Category: dtcSpatial; + ), + ( + Index: dbdtMultilinestring; + NativeType: 255; + Name: 'MULTILINESTRING'; + Description: 'MULTILINESTRING(ls1,ls2,...)' + sLineBreak + + 'Constructs a WKB MultiLineString value using WKB LineString arguments. ' + + 'If any argument is not a WKB LineString, the return value is NULL.'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: False; + Category: dtcSpatial; + ), + ( + Index: dbdtMultipolygon; + NativeType: 255; + Name: 'MULTIPOLYGON'; + Description: 'MULTIPOLYGON(poly1,poly2,...)' + sLineBreak + + 'Constructs a WKB MultiPolygon value from a set of WKB Polygon ' + + 'arguments. If any argument is not a WKB Polygon, the return value is ' + + 'NULL.'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: False; + Category: dtcSpatial; + ), + ( + Index: dbdtGeometrycollection; + NativeType: 255; + Name: 'GEOMETRYCOLLECTION'; + Description: 'GEOMETRYCOLLECTION(g1,g2,...)' + sLineBreak + + 'Constructs a WKB GeometryCollection. If any argument is not a ' + + 'well-formed WKB representation of a geometry, the return value is NULL.'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: False; + Category: dtcSpatial; + ) + + ); + + + MySQLVariables: array [0..417] of TServerVariable = + ( + ( + Name: 'auto_increment_increment'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'auto_increment_offset'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'autocommit'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'automatic_sp_privileges'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'back_log'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'basedir'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'big_tables'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'binlog_cache_size'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'binlog_checksum'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'binlog_direct_non_transactional_updates'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'binlog_format'; + IsDynamic: True; + VarScope: vsBoth; + EnumValues: 'ROW,STATEMENT,MIXED'; + ), + ( + Name: 'binlog_row_image'; + IsDynamic: True; + VarScope: vsBoth; + EnumValues: 'FULL,MINIMAL,NOBLOB'; + ), + ( + Name: 'binlog_stmt_cache_size'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'bulk_insert_buffer_size'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'character_set_client'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'character_set_connection'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'character_set_database[a]'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'character_set_filesystem'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'character_set_results'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'character_set_server'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'character_set_system'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'character_sets_dir'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'collation_connection'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'collation_database[b]'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'collation_server'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'completion_type'; + IsDynamic: True; + VarScope: vsBoth; + EnumValues: 'NO_CHAIN,CHAIN,RELEASE,0,1,2'; + ), + ( + Name: 'concurrent_insert'; + IsDynamic: True; + VarScope: vsGlobal; + EnumValues: 'NEVER,AUTO,ALWAYS,0,1,2'; + ), + ( + Name: 'connect_timeout'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'datadir'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'date_format'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'datetime_format'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'debug'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'debug_sync'; + IsDynamic: True; + VarScope: vsSession; + ), + ( + Name: 'default_storage_engine'; + IsDynamic: True; + VarScope: vsBoth; + EnumValues: 'FEDERATED,MRG_MYISAM,MyISAM,BLACKHOLE,CSV,MEMORY,ARCHIVE,InnoDB'; + ), + ( + Name: 'default_tmp_storage_engine'; + IsDynamic: True; + VarScope: vsBoth; + EnumValues: 'FEDERATED,MRG_MYISAM,MyISAM,BLACKHOLE,CSV,MEMORY,ARCHIVE,InnoDB'; + ), + ( + Name: 'default_week_format'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'delay_key_write'; + IsDynamic: True; + VarScope: vsGlobal; + EnumValues: 'ON,OFF,ALL'; + ), + ( + Name: 'delayed_insert_limit'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'delayed_insert_timeout'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'delayed_queue_size'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'disable_gtid_unsafe_statements'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'div_precision_increment'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'end_markers_in_json'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'engine_condition_pushdown'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'eq_range_index_dive_limit'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'error_count'; + IsDynamic: False; + VarScope: vsSession; + ), + ( + Name: 'event_scheduler'; + IsDynamic: True; + VarScope: vsGlobal; + EnumValues: 'ON,OFF,DISABLED'; + ), + ( + Name: 'expire_logs_days'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'external_user'; + IsDynamic: False; + VarScope: vsSession; + ), + ( + Name: 'flush'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'flush_time'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'foreign_key_checks'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'ft_boolean_syntax'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'ft_max_word_len'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'ft_min_word_len'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'ft_query_expansion_limit'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'ft_stopword_file'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'general_log'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'general_log_file'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'group_concat_max_len'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'gtid_done'; + IsDynamic: False; + VarScope: vsBoth; + ), + ( + Name: 'gtid_lost'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'gtid_mode'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'gtid_mode'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'gtid_next'; + IsDynamic: True; + VarScope: vsSession; + EnumValues: 'AUTOMATIC,ANONYMOUS'; + ), + ( + Name: 'gtid_owned'; + IsDynamic: False; + VarScope: vsBoth; + ), + ( + Name: 'have_compress'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'have_crypt'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'have_csv'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'have_dynamic_loading'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'have_geometry'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'have_innodb'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'have_ndbcluster'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'have_openssl'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'have_partitioning'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'have_profiling'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'have_query_cache'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'have_rtree_keys'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'have_ssl'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'have_symlink'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'host_cache_size'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'hostname'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'identity'; + IsDynamic: True; + VarScope: vsSession; + ), + ( + Name: 'ignore_builtin_innodb'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'init_connect'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'init_file'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'init_slave'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_adaptive_flushing'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_adaptive_hash_index'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_adaptive_max_sleep_delay'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_additional_mem_pool_size'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_analyze_is_persistent'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_api_enable_binlog'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_api_enable_mdl'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_api_trx_level'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_autoextend_increment'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_autoinc_lock_mode'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_buffer_pool_dump_at_shutdown'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_buffer_pool_dump_now'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_buffer_pool_filename'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_buffer_pool_instances'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_buffer_pool_load_abort'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_buffer_pool_load_at_startup'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_buffer_pool_load_now'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_buffer_pool_size'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_change_buffer_max_size'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_change_buffering'; + IsDynamic: True; + VarScope: vsGlobal; + EnumValues: 'INSERTS,DELETES,PURGES,CHANGES,ALL,NONE'; + ), + ( + Name: 'innodb_checksum_algorithm'; + IsDynamic: True; + VarScope: vsGlobal; + EnumValues: 'INNODB,CRC32,NONE,STRICT_INNODB,STRICT_CRC32,STRICT_NONE'; + ), + ( + Name: 'innodb_checksums'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_commit_concurrency'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_concurrency_tickets'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_data_file_path'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_data_home_dir'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_doublewrite'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_fast_shutdown'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_file_format'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_file_format_check'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_file_format_max'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_file_per_table'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_flush_log_at_trx_commit'; + IsDynamic: True; + VarScope: vsGlobal; + EnumValues: '0,1,2'; + ), + ( + Name: 'innodb_flush_method'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_flush_neighbors'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_force_load_corrupted'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_force_recovery'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_ft_aux_table'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_ft_cache_size'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_ft_enable_stopword'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_ft_max_token_size'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_ft_min_token_size'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_ft_num_word_optimize'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_ft_server_stopword_table'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_ft_sort_pll_degree'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_ft_user_stopword_table'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_io_capacity'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_large_prefix'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_lock_wait_timeout'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'innodb_locks_unsafe_for_binlog'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_log_buffer_size'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_log_file_size'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_log_files_in_group'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_log_group_home_dir'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_lru_scan_depth'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_max_dirty_pages_pct'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_max_purge_lag'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_mirrored_log_groups'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_monitor_disable'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_monitor_enable'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_monitor_reset'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_monitor_reset_all'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_old_blocks_pct'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_old_blocks_time'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_open_files'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_optimize_fulltext_only'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_page_size'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_print_all_deadlocks'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_purge_batch_size'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_purge_threads'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_random_read_ahead'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_read_ahead_threshold'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_read_io_threads'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_replication_delay'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_rollback_on_timeout'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_rollback_segments'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_sort_buffer_size'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_spin_wait_delay'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_stats_method'; + IsDynamic: True; + VarScope: vsBoth; + EnumValues: 'NULLS_EQUAL,NULLS_UNEQUAL,NULLS_IGNORED'; + ), + ( + Name: 'innodb_stats_on_metadata'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_stats_persistent_sample_pages'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_stats_sample_pages'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_stats_transient_sample_pages'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_strict_mode'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'innodb_support_xa'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'innodb_sync_array_size'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_sync_spin_loops'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_table_locks'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'innodb_thread_concurrency'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_thread_sleep_delay'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_undo_directory'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_undo_logs'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_undo_tablespaces'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_use_native_aio'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_use_sys_malloc'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_version'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'innodb_write_io_threads'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'insert_id'; + IsDynamic: True; + VarScope: vsSession; + ), + ( + Name: 'interactive_timeout'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'join_buffer_size'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'keep_files_on_create'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'key_buffer_size'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'key_cache_age_threshold'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'key_cache_block_size'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'key_cache_division_limit'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'language'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'large_files_support'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'large_page_size'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'large_pages'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'last_insert_id'; + IsDynamic: True; + VarScope: vsSession; + ), + ( + Name: 'lc_messages'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'lc_messages_dir'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'lc_time_names'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'license'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'local_infile'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'lock_wait_timeout'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'locked_in_memory'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'log'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'log_bin'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'log_bin_basename'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'log_error'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'log_output'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'log_queries_not_using_indexes'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'log_slave_updates'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'log_slow_queries'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'log_throttle_queries_not_using_indexes'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'log_warnings'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'long_query_time'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'low_priority_updates'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'lower_case_file_system'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'lower_case_table_names'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'master_info_repository'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'master_verify_checksum'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'max_allowed_packet'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'max_binlog_cache_size'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'max_binlog_size'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'max_binlog_stmt_cache_size'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'max_connect_errors'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'max_connections'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'max_delayed_threads'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'max_error_count'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'max_heap_table_size'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'max_insert_delayed_threads'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'max_join_size'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'max_length_for_sort_data'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'max_prepared_stmt_count'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'max_relay_log_size'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'max_seeks_for_key'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'max_sort_length'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'max_sp_recursion_depth'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'max_tmp_tables'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'max_user_connections'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'max_write_lock_count'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'memlock'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'metadata_locks_cache_size'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'myisam_data_pointer_size'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'myisam_max_sort_file_size'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'myisam_mmap_size'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'myisam_recover_options'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'myisam_repair_threads'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'myisam_sort_buffer_size'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'myisam_stats_method'; + IsDynamic: True; + VarScope: vsBoth; + EnumValues: 'NULLS_EQUAL,NULLS_UNEQUAL,NULLS_IGNORED'; + ), + ( + Name: 'myisam_use_mmap'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'named_pipe'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'net_buffer_length'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'net_read_timeout'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'net_retry_count'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'net_write_timeout'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'new'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'old'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'old_alter_table'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'old_passwords'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'open_files_limit'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'optimizer_join_cache_level'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'optimizer_prune_level'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'optimizer_search_depth'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'optimizer_switch'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'optimizer_trace'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'optimizer_trace_features'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'optimizer_trace_limit'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'optimizer_trace_max_mem_size'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'optimizer_trace_offset'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'have_partitioning'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'performance_schema'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'performance_schema_accounts_size'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'performance_schema_digests_size'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'performance_schema_events_stages_history_long_size'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'performance_schema_events_stages_history_size'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'performance_schema_events_statements_history_long_size'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'performance_schema_events_statements_history_size'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'performance_schema_events_waits_history_long_size'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'performance_schema_events_waits_history_size'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'performance_schema_hosts_size'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'performance_schema_max_cond_classes'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'performance_schema_max_cond_instances'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'performance_schema_max_file_classes'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'performance_schema_max_file_handles'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'performance_schema_max_file_instances'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'performance_schema_max_mutex_classes'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'performance_schema_max_mutex_instances'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'performance_schema_max_rwlock_classes'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'performance_schema_max_rwlock_instances'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'performance_schema_max_socket_classes'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'performance_schema_max_socket_instances'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'performance_schema_max_stage_classes'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'performance_schema_max_statement_classes'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'performance_schema_max_table_handles'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'performance_schema_max_table_instances'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'performance_schema_max_thread_classes'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'performance_schema_max_thread_instances'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'performance_schema_setup_actors_size'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'performance_schema_setup_objects_size'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'performance_schema_users_size'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'pid_file'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'plugin_dir'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'port'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'preload_buffer_size'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'profiling'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'profiling_history_size'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'protocol_version'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'proxy_user'; + IsDynamic: False; + VarScope: vsSession; + ), + ( + Name: 'pseudo_thread_id'; + IsDynamic: True; + VarScope: vsSession; + ), + ( + Name: 'query_alloc_block_size'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'query_cache_limit'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'query_cache_min_res_unit'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'query_cache_size'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'query_cache_type'; + IsDynamic: True; + VarScope: vsBoth; + EnumValues: '0,1,2'; + ), + ( + Name: 'query_cache_wlock_invalidate'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'query_prealloc_size'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'rand_seed1'; + IsDynamic: True; + VarScope: vsSession; + ), + ( + Name: 'rand_seed2'; + IsDynamic: True; + VarScope: vsSession; + ), + ( + Name: 'range_alloc_block_size'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'read_buffer_size'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'read_only'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'read_rnd_buffer_size'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'relay_log_basename'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'relay_log_index'; + IsDynamic: False; + VarScope: vsBoth; + ), + ( + Name: 'relay_log_index'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'relay_log_info_file'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'relay_log_info_repository'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'relay_log_purge'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'relay_log_recovery'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'relay_log_space_limit'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'report_host'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'report_password'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'report_port'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'report_user'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'rpl_semi_sync_master_enabled'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'rpl_semi_sync_master_timeout'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'rpl_semi_sync_master_trace_level'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'rpl_semi_sync_master_wait_no_slave'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'rpl_semi_sync_slave_enabled'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'rpl_semi_sync_slave_trace_level'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'secure_auth'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'secure_file_priv'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'server_id'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'server_uuid'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'shared_memory'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'shared_memory_base_name'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'skip_external_locking'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'skip_name_resolve'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'skip_networking'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'skip_show_database'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'slave_compressed_protocol'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'slave_exec_mode'; + IsDynamic: True; + VarScope: vsGlobal; + EnumValues: 'IDEMPOTENT,STRICT'; + ), + ( + Name: 'slave_load_tmpdir'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'slave_net_timeout'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'slave_parallel_workers'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'slave_skip_errors'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'slave_sql_verify_checksum'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'slave_transaction_retries'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'slave_type_conversions'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'slow_launch_time'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'slow_query_log'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'slow_query_log_file'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'socket'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'sort_buffer_size'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'sql_auto_is_null'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'sql_big_selects'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'sql_big_tables'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'sql_buffer_result'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'sql_log_bin'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'sql_log_off'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'sql_low_priority_updates'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'sql_max_join_size'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'sql_mode'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'sql_notes'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'sql_quote_show_create'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'sql_safe_updates'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'sql_select_limit'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'sql_slave_skip_counter'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'sql_warnings'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'ssl_ca'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'ssl_capath'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'ssl_cert'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'ssl_cipher'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'ssl_crl'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'ssl_crlpath'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'ssl_key'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'storage_engine'; + IsDynamic: True; + VarScope: vsBoth; + EnumValues: 'FEDERATED,MRG_MYISAM,MyISAM,BLACKHOLE,CSV,MEMORY,ARCHIVE,InnoDB'; + ), + ( + Name: 'stored_program_cache'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'sync_binlog'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'sync_frm'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'sync_master_info'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'sync_relay_log'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'sync_relay_log_info'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'system_time_zone'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'table_definition_cache'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'table_open_cache'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'thread_cache_size'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'thread_concurrency'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'thread_handling'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'thread_stack'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'time_format'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'time_zone'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'timed_mutexes'; + IsDynamic: True; + VarScope: vsGlobal; + ), + ( + Name: 'timestamp'; + IsDynamic: True; + VarScope: vsSession; + ), + ( + Name: 'tmp_table_size'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'tmpdir'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'transaction_alloc_block_size'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'transaction_prealloc_size'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'tx_isolation'; + IsDynamic: True; + VarScope: vsBoth; + EnumValues: 'READ-UNCOMMITTED,READ-COMMITTED,REPEATABLE-READ,SERIALIZABLE'; + ), + ( + Name: 'tx_read_only'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'unique_checks'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'updatable_views_with_limit'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'version'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'version_comment'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'version_compile_machine'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'version_compile_os'; + IsDynamic: False; + VarScope: vsGlobal; + ), + ( + Name: 'wait_timeout'; + IsDynamic: True; + VarScope: vsBoth; + ), + ( + Name: 'warning_count'; + IsDynamic: False; + VarScope: vsSession; + ) + + ); + + +implementation + +uses apphelpers; + + +constructor TMySQLLib.Create(DllFile, DefaultDll: String); +begin + inherited; + // MYSQL_OPT_* constants + MYSQL_OPT_CONNECT_TIMEOUT := 0; + MYSQL_OPT_LOCAL_INFILE := 8; + MYSQL_PLUGIN_DIR := 22; + MYSQL_OPT_SSL_KEY := 25; + MYSQL_OPT_SSL_CERT := 26; + MYSQL_OPT_SSL_CA := 27; + MYSQL_OPT_SSL_CIPHER := 29; + MYSQL_OPT_CONNECT_ATTR_ADD := 33; + MYSQL_ENABLE_CLEARTEXT_PLUGIN := 36; + MYSQL_OPT_TLS_VERSION := 41; + MARIADB_OPT_TLS_VERSION := INVALID_OPT; + MYSQL_OPT_SSL_MODE := INVALID_OPT; + MYSQL_OPT_SSL_VERIFY_SERVER_CERT := INVALID_OPT; + // Option values + SSL_MODE_DISABLED := 1; + SSL_MODE_PREFERRED := 2; + SSL_MODE_REQUIRED := 3; + SSL_MODE_VERIFY_CA := 4; + SSL_MODE_VERIFY_IDENTITY := 5; + if IsLibMariadb then begin + // Differences in libmariadb + MYSQL_OPT_SSL_VERIFY_SERVER_CERT := 21; + MARIADB_OPT_TLS_VERSION := 7005; + end + else if String(mysql_get_client_info).StartsWith('8.') then begin + // Some constants were removed in MySQL 8.0, so the offsets differ + MYSQL_PLUGIN_DIR := 16; + MYSQL_OPT_SSL_KEY := 19; + MYSQL_OPT_SSL_CERT := 20; + MYSQL_OPT_SSL_CA := 21; + MYSQL_OPT_SSL_CIPHER := 23; + MYSQL_OPT_CONNECT_ATTR_ADD := 27; + MYSQL_ENABLE_CLEARTEXT_PLUGIN := 30; + MYSQL_OPT_TLS_VERSION := 34; + MYSQL_OPT_SSL_MODE := 35; + end; +end; + +function TMySQLLib.IsLibMariadb: Boolean; +begin + // libmariadb used (not libmysql) ? + Result := ExtractFileName(FDllFile).StartsWith('libmariadb', True); +end; + +procedure TMySQLLib.AssignProcedures; +begin + AssignProc(@mysql_affected_rows, 'mysql_affected_rows'); + AssignProc(@mysql_character_set_name, 'mysql_character_set_name'); + AssignProc(@mysql_close, 'mysql_close'); + AssignProc(@mysql_data_seek, 'mysql_data_seek'); + AssignProc(@mysql_errno, 'mysql_errno'); + AssignProc(@mysql_error, 'mysql_error'); + AssignProc(@mysql_fetch_field_direct, 'mysql_fetch_field_direct'); + AssignProc(@mysql_fetch_field, 'mysql_fetch_field'); + AssignProc(@mysql_fetch_lengths, 'mysql_fetch_lengths'); + AssignProc(@mysql_fetch_row, 'mysql_fetch_row'); + AssignProc(@mysql_free_result, 'mysql_free_result'); + AssignProc(@mysql_get_client_info, 'mysql_get_client_info'); + AssignProc(@mysql_get_server_info, 'mysql_get_server_info'); + AssignProc(@mysql_init, 'mysql_init'); + AssignProc(@mysql_info, 'mysql_info'); + AssignProc(@mysql_num_fields, 'mysql_num_fields'); + AssignProc(@mysql_num_rows, 'mysql_num_rows'); + AssignProc(@mysql_ping, 'mysql_ping'); + AssignProc(@mysql_options, 'mysql_options'); + AssignProc(@mysql_optionsv, 'mysql_optionsv', False); + AssignProc(@mysql_real_connect, 'mysql_real_connect'); + AssignProc(@mysql_real_query, 'mysql_real_query'); + AssignProc(@mysql_stat, 'mysql_stat'); + AssignProc(@mysql_store_result, 'mysql_store_result'); + AssignProc(@mysql_thread_id, 'mysql_thread_id'); + AssignProc(@mysql_next_result, 'mysql_next_result'); + AssignProc(@mysql_set_character_set, 'mysql_set_character_set'); + AssignProc(@mysql_thread_init, 'mysql_thread_init'); + AssignProc(@mysql_thread_end, 'mysql_thread_end'); + AssignProc(@mysql_warning_count, 'mysql_warning_count'); +end; + + +{ TMySqlProvider } + +function TMySqlProvider.GetSql(AId: TQueryId): string; +var + IsMariaDB, IsMySQL: Boolean; +begin + IsMariaDB := ServerVersion >= 100000; + IsMySQL := not IsMariaDB; + case AId of + qDatabaseDrop: Result := 'DROP DATABASE %s'; + qEmptyTable: Result := 'TRUNCATE %s'; + qRenameTable: Result := 'RENAME TABLE %s TO %s'; + qRenameView: Result := 'RENAME TABLE %s TO %s'; + qCurrentUserHost: Result := 'SELECT CURRENT_USER()'; + qLikeCompare: Result := '%s LIKE %s'; + qAddColumn: Result := 'ADD COLUMN %s'; + qChangeColumn: Result := 'CHANGE COLUMN %s %s'; + qGlobalStatus: Result := IfThen( + FNetType = ntMySQL_ProxySQLAdmin, + 'SELECT * FROM stats_mysql_global', + 'SHOW /*!50002 GLOBAL */ STATUS' + ); + qCommandsCounters: Result := IfThen( + FNetType = ntMySQL_ProxySQLAdmin, + 'SELECT * FROM stats_mysql_commands_counters', + 'SHOW /*!50002 GLOBAL */ STATUS LIKE ''Com\_%''' + ); + qSessionVariables: Result := 'SHOW VARIABLES'; + qGlobalVariables: Result := IfThen( + FServerVersion >= 40000, + 'SHOW GLOBAL VARIABLES', + '' + ); + qISSchemaCol: Result := '%s_SCHEMA'; + qUSEQuery: Result := 'USE %s'; + qKillQuery: Result := IfThen( + FNetType = ntMySQL_RDS, + 'CALL mysql.rds_kill_query(%d)', + IfThen( + FServerVersion >= 50000, + 'KILL QUERY %d', + 'KILL %d' + ) + ); + qKillProcess: Result := IfThen( + FNetType = ntMySQL_RDS, + 'CALL mysql.rds_kill(%d)', + 'KILL %d' + ); + qFuncLength: Result := 'LENGTH'; + qFuncCeil: Result := 'CEIL'; + qFuncLeft: Result := IfThen( + FNetType = ntMySQL_ProxySQLAdmin, + 'SUBSTR(%s, 1, %d)', + 'LEFT(%s, %d)' + ); + qFuncNow: Result := IfThen( + FNetType = ntMySQL_ProxySQLAdmin, + 'CURRENT_TIMESTAMP', + 'NOW()' + ); + qFuncLastAutoIncNumber: Result := 'LAST_INSERT_ID()'; + qLockedTables: Result := IfThen( + (FNetType <> ntMySQL_ProxySQLAdmin) and (FServerVersion >= 50124), + 'SHOW OPEN TABLES FROM %s WHERE in_use!=0', + '' + ); + qDisableForeignKeyChecks: Result := IfThen( + FServerVersion >= 40014, + 'SET @OLD_FOREIGN_KEY_CHECKS=@@FOREIGN_KEY_CHECKS, FOREIGN_KEY_CHECKS=0', + '' + ); + qEnableForeignKeyChecks: Result := IfThen( + FServerVersion >= 40014, + 'SET FOREIGN_KEY_CHECKS=IFNULL(@OLD_FOREIGN_KEY_CHECKS, 1)', + '' + ); + qForeignKeyDrop: Result := 'DROP FOREIGN KEY %s'; + qGetTableColumns: Result := ''; + qGetCollations: Result := IfThen( + FServerVersion >= 40100, + 'SHOW COLLATION', + '' + ); + // Issue #1917: MariaDB 10.10.1+ versions have additional collations in IS.COLLATION_CHARACTER_SET_APPLICABILITY + qGetCollationsExtended: Result := IfThen( + FServerVersion >= 101001, + 'SELECT'+ + ' FULL_COLLATION_NAME AS `Collation`'+ + ', CHARACTER_SET_NAME AS `Charset`'+ + ', ID AS `Id`'+ + ', IS_DEFAULT AS `Default`'+ + ', 0 AS `Sortlen`'+ + ' FROM INFORMATION_SCHEMA.COLLATION_CHARACTER_SET_APPLICABILITY'+ + ' ORDER BY `Collation`', + '' + ); + qGetCharsets: Result := IfThen( + FServerVersion >= 40100, + 'SHOW CHARSET', + '' + ); + qGetRowCountApprox: Result := IfThen( + FNetType <> ntMySQL_ProxySQLAdmin, + 'SHOW TABLE STATUS FROM :QuotedDatabase LIKE :EscapedName', + '' + ); + qGetReverseForeignKeys: Result := 'SELECT DISTINCT'+ + ' k.TABLE_SCHEMA, k.TABLE_NAME'+ + ' FROM INFORMATION_SCHEMA.KEY_COLUMN_USAGE k'+ + ' WHERE'+ + ' REFERENCED_TABLE_SCHEMA = :EscapedDatabase AND'+ + ' REFERENCED_TABLE_NAME = :EscapedName'; + qExplain: Result := IfThen( + (FServerVersion >= 80400) and (FServerVersion < 100000), // Not MariaDB + 'EXPLAIN FORMAT=TRADITIONAL %s', + 'EXPLAIN %s' + ); + qSetTimezone: Result := IfThen( + FServerVersion >= 40103, + 'SET time_zone=%s', + '' + ); + qShowFunctionStatus: Result := IfThen( + (FServerVersion >= 50000) and (FNetType <> ntMySQL_ProxySQLAdmin), + 'SHOW FUNCTION STATUS WHERE LOWER(Db) = LOWER(%s)', + '' + ); + qShowProcedureStatus: Result := IfThen( + (FServerVersion >= 50000) and (FNetType <> ntMySQL_ProxySQLAdmin), + 'SHOW PROCEDURE STATUS WHERE LOWER(Db) = LOWER(%s)', + '' + ); + qShowTriggers: Result := IfThen( + (FServerVersion >= 50010) and (FNetType <> ntMySQL_ProxySQLAdmin), + 'SHOW TRIGGERS FROM %s', + '' + ); + qShowEvents: Result := IfThen( + (FServerVersion >= 50010) and (FNetType <> ntMySQL_ProxySQLAdmin), + 'SELECT *, EVENT_SCHEMA AS `Db`, EVENT_NAME AS `Name` FROM INFORMATION_SCHEMA.`EVENTS` WHERE EVENT_SCHEMA=%s', + '' + ); + qHelpKeyword: Result := IfThen( + (FServerVersion >= 40100) and (FNetType <> ntMySQL_ProxySQLAdmin), + 'HELP %s', + '' + ); + qShowCreateTrigger: Result := IfThen( + FServerVersion >= 50121, + 'SHOW CREATE TRIGGER :QuotedDatabase.:QuotedName', + '' + ); + qShowWarnings: Result := IfThen( + FServerVersion >= 40100, + 'SHOW WARNINGS', + '' + ); + qDropUser: Result := IfThen( + FServerVersion < 40101, + 'DELETE FROM mysql.user WHERE User=%s AND Host=%s', + 'DROP USER %s@%s' + ); + qCreateRole: Result := 'CREATE ROLE %s'; + qDropRole: Result := 'DROP ROLE %s'; + qReloadPrivileges: Result := 'FLUSH PRIVILEGES'; + qGrantRole: Result := 'GRANT %s TO %s%s'; + qRevokeRole: Result := 'REVOKE %s FROM %s'; + qSetDefaultRole: Result := 'SET DEFAULT ROLE %s FOR %s'; + qIndexVisible: + if IsMariaDB and (FServerVersion >= 100600) then + Result := 'NOT IGNORED' + else if IsMySQL and (FServerVersion >= 80000) then + Result := 'VISIBLE' + else + Result := ''; + qIndexInvisible: + if IsMariaDB and (FServerVersion >= 100600) then + Result := 'IGNORED' + else if IsMySQL and (FServerVersion >= 80000) then + Result := 'INVISIBLE' + else + Result := ''; + qGetAuthPlugins: Result := IfThen( + (FServerVersion >= 50100) or IsMariaDB, // mysql 5.1+ and all mariadb versions + 'SELECT PLUGIN_NAME FROM INFORMATION_SCHEMA.PLUGINS WHERE PLUGIN_TYPE=''AUTHENTICATION'' AND PLUGIN_STATUS=''ACTIVE''', + '' + ); + qCastAsText: Result := IfThen( + FServerVersion >= 40002, + 'CAST(%s AS CHAR)', + '' + ); + qIndexSize: Result := IfThen( + (IsMySQL and (FServerVersion >= 50600)) or IsMariaDB, + 'SELECT index_name, stat_value * @@innodb_page_size AS bytes' + + ' FROM mysql.innodb_index_stats'+ + ' WHERE database_name=%s AND table_name=%s AND stat_name=''size''', + '' + ); + else Result := inherited; + end; +end; + + +initialization + +// Keywords copied from SynHighligherSQL +MySQLKeywords := TStringList.Create; +MySQLKeywords.CommaText := 'ACCESSIBLE,ACCOUNT,ACTION,ACTIVE,ADD,ADMIN,AFTER,AGAINST,AGGREGATE,' + + 'ALGORITHM,ALL,ALTER,ALWAYS,ANALYSE,ANALYZE,AND,ANY,ARRAY,AS,ASC,' + + 'ASENSITIVE,AT,ATTRIBUTE,AUTHENTICATION,AUTOEXTEND_SIZE,AUTO_INCREMENT,' + + 'AVG_ROW_LENGTH,BACKUP,BEFORE,BEGIN,BETWEEN,BINLOG,BIT,BLOCK,BOTH,BUCKETS,' + + 'BULK,BY,CACHE,CALL,CASCADE,CASCADED,CATALOG_NAME,CHAIN,CHALLENGE_RESPONSE,' + + 'CHANGE,CHANGED,CHANNEL,CHARACTER,CHARSET,CHECK,CHECKSUM,CIPHER,' + + 'CLASS_ORIGIN,CLIENT,CLONE,CODE,COLLATE,COLLATION,COLUMN,COLUMNS,' + + 'COLUMN_FORMAT,COLUMN_NAME,COMMENT,COMMIT,COMMITTED,COMPLETION,COMPONENT,' + + 'COMPRESSION,CONCURRENT,CONDITION,CONNECTION,CONSISTENT,CONSTRAINT,' + + 'CONSTRAINT_CATALOG,CONSTRAINT_NAME,CONSTRAINT_SCHEMA,CONTAINS,CONTEXT,' + + 'CONTINUE,CONVERT,CPU,CREATE,CROSS,CUBE,CUME_DIST,CURRENT,CURSOR,' + + 'CURSOR_NAME,DATA,DATABASE,DATABASES,DATAFILE,DAY_HOUR,DAY_MICROSECOND,' + + 'DAY_MINUTE,DAY_SECOND,DEALLOCATE,DEC,DECLARE,DEFAULT,DEFAULT_AUTH,DEFINER,' + + 'DEFINITION,DELAYED,DELAY_KEY_WRITE,DELETE,DENSE_RANK,DESC,DESCRIBE,' + + 'DESCRIPTION,DES_KEY_FILE,DETERMINISTIC,DIAGNOSTICS,DIRECTORY,DISABLE,' + + 'DISCARD,DISTINCT,DISTINCTROW,DIV,DO,DROP,DUAL,DUMPFILE,DUPLICATE,EACH,' + + 'ELSE,ELSEIF,EMPTY,ENABLE,ENCLOSED,ENCRYPTION,END,ENDS,ENFORCED,ENGINE,' + + 'ENGINES,ENGINE_ATTRIBUTE,ERROR,ERRORS,ESCAPE,ESCAPED,EVENT,EVENTS,EVERY,' + + 'EXCEPT,EXCHANGE,EXCLUDE,EXECUTE,EXISTS,EXPANSION,EXPIRE,EXPLAIN,EXPORT,' + + 'EXTENDED,EXTENT_SIZE,FACTOR,FAILED_LOGIN_ATTEMPTS,FALSE,FAST,FAULTS,' + + 'FIELDS,FILE,FILE_BLOCK_SIZE,FILTER,FINISH,FIRST,FIRST_VALUE,FLOAT4,FLOAT8,' + + 'FLUSH,FOLLOWING,FOLLOWS,FOR,FORCE,FOREIGN,FOUND,FROM,FULL,FULLTEXT,' + + 'FUNCTION,GENERAL,GENERATE,GENERATED,GEOMCOLLECTION,GET,' + + 'GET_MASTER_PUBLIC_KEY,GET_SOURCE_PUBLIC_KEY,GLOBAL,GRANT,GRANTS,GROUP,' + + 'GROUPING,GROUPS,GROUP_REPLICATION,GTID_ONLY,HAVING,HELP,HIGH_PRIORITY,' + + 'HISTOGRAM,HISTORY,HOST,HOSTS,HOUR_MICROSECOND,HOUR_MINUTE,HOUR_SECOND,' + + 'IDENTIFIED,IGNORE,IGNORE_SERVER_IDS,IMPORT,IN,INACTIVE,INDEX,INDEXES,' + + 'INFILE,INITIAL,INITIAL_SIZE,INITIATE,INNER,INOUT,INSENSITIVE,INSERT,' + + 'INSERT_METHOD,INSTALL,INSTANCE,INT1,INT2,INT3,INT4,INT8,INTERSECT,INTO,' + + 'INVISIBLE,INVOKER,IO,IO_AFTER_GTIDS,IO_BEFORE_GTIDS,IO_THREAD,IPC,IS,' + + 'ISOLATION,ISSUER,JOIN,JSON,JSON_TABLE,JSON_VALUE,KEY,KEYRING,KEYS,' + + 'KEY_BLOCK_SIZE,KILL,LAG,LANGUAGE,LAST,LAST_VALUE,LATERAL,LEAD,LEADING,' + + 'LEAVES,LESS,LEVEL,LIKE,LIMIT,LINEAR,LINES,LIST,LOAD,LOCAL,LOCK,LOCKED,' + + 'LOCKS,LOGFILE,LOGS,LONG,LOW_PRIORITY,MASTER,MASTER_AUTO_POSITION,' + + 'MASTER_BIND,MASTER_COMPRESSION_ALGORITHMS,MASTER_CONNECT_RETRY,' + + 'MASTER_DELAY,MASTER_HEARTBEAT_PERIOD,MASTER_HOST,MASTER_LOG_FILE,' + + 'MASTER_LOG_POS,MASTER_PASSWORD,MASTER_PORT,MASTER_PUBLIC_KEY_PATH,' + + 'MASTER_RETRY_COUNT,MASTER_SERVER_ID,MASTER_SSL,MASTER_SSL_CA,' + + 'MASTER_SSL_CAPATH,MASTER_SSL_CERT,MASTER_SSL_CIPHER,MASTER_SSL_CRL,' + + 'MASTER_SSL_CRLPATH,MASTER_SSL_KEY,MASTER_SSL_VERIFY_SERVER_CERT,' + + 'MASTER_TLS_CIPHERSUITES,MASTER_TLS_VERSION,MASTER_USER,' + + 'MASTER_ZSTD_COMPRESSION_LEVEL,MATCH,MAXVALUE,MAX_CONNECTIONS_PER_HOUR,' + + 'MAX_QUERIES_PER_HOUR,MAX_ROWS,MAX_SIZE,MAX_UPDATES_PER_HOUR,' + + 'MAX_USER_CONNECTIONS,MEDIUM,MEMBER,MESSAGE_TEXT,MIDDLEINT,MIGRATE,' + + 'MINUTE_MICROSECOND,MINUTE_SECOND,MIN_ROWS,MOD,MODE,MODIFIES,MODIFY,MUTEX,' + + 'MYSQL_ERRNO,NAME,NAMES,NATURAL,NCHAR,NESTED,NETWORK_NAMESPACE,NEVER,NEW,' + + 'NEXT,NO,NODEGROUP,NONE,NOT,NOWAIT,NO_WAIT,NO_WRITE_TO_BINLOG,NTH_VALUE,' + + 'NTILE,NULL,NULLS,NUMBER,NVARCHAR,OF,OFF,OFFSET,OJ,OLD,ON,ONE,ONLY,OPEN,' + + 'OPTIMIZE,OPTIMIZER_COSTS,OPTION,OPTIONAL,OPTIONALLY,OPTIONS,OR,ORDER,' + + 'ORDINALITY,ORGANIZATION,OTHERS,OUT,OUTER,OUTFILE,OVER,OWNER,PACK_KEYS,' + + 'PAGE,PARSER,PARSE_GCOL_EXPR,PARTIAL,PARTITION,PARTITIONING,PARTITIONS,' + + 'PASSWORD_LOCK_TIME,PATH,PERCENT_RANK,PERSIST,PERSIST_ONLY,PHASE,PLUGIN,' + + 'PLUGINS,PLUGIN_DIR,PORT,PRECEDES,PRECEDING,PREPARE,PRESERVE,PREV,PRIMARY,' + + 'PRIVILEGES,PRIVILEGE_CHECKS_USER,PROCEDURE,PROCESS,PROCESSLIST,PROFILE,' + + 'PROFILES,PROXY,PURGE,QUERY,QUICK,RANDOM,RANGE,RANK,READ,READS,READ_ONLY,' + + 'READ_WRITE,REBUILD,RECOVER,RECURSIVE,REDOFILE,REDO_BUFFER_SIZE,REFERENCE,' + + 'REFERENCES,REGEXP,REGISTRATION,RELAY,RELAYLOG,RELAY_LOG_FILE,' + + 'RELAY_LOG_POS,RELAY_THREAD,RELEASE,RELOAD,REMOTE,REMOVE,RENAME,REORGANIZE,' + + 'REPAIR,REPEATABLE,REPLACE,REPLICA,REPLICAS,REPLICATE_DO_DB,' + + 'REPLICATE_DO_TABLE,REPLICATE_IGNORE_DB,REPLICATE_IGNORE_TABLE,' + + 'REPLICATE_REWRITE_DB,REPLICATE_WILD_DO_TABLE,REPLICATE_WILD_IGNORE_TABLE,' + + 'REPLICATION,REQUIRE,REQUIRE_ROW_FORMAT,RESET,RESIGNAL,RESOURCE,RESPECT,' + + 'RESTART,RESTORE,RESTRICT,RESUME,RETAIN,RETURN,RETURNED_SQLSTATE,RETURNING,' + + 'RETURNS,REUSE,REVOKE,RLIKE,ROLE,ROLLBACK,ROLLUP,ROTATE,ROUTINE,ROW,ROWS,' + + 'ROW_FORMAT,ROW_NUMBER,RTREE,SAVEPOINT,SCHEDULE,SCHEMA,SCHEMAS,SCHEMA_NAME,' + + 'SECONDARY,SECONDARY_ENGINE,SECONDARY_ENGINE_ATTRIBUTE,SECONDARY_LOAD,' + + 'SECONDARY_UNLOAD,SECOND_MICROSECOND,SECURITY,SELECT,SENSITIVE,SEPARATOR,' + + 'SERIALIZABLE,SERVER,SESSION,SET,SHARE,SHOW,SHUTDOWN,SIGNAL,SIMPLE,SKIP,' + + 'SLAVE,SLOW,SNAPSHOT,SOCKET,SOME,SONAME,SOUNDS,SOURCE,SOURCE_AUTO_POSITION,' + + 'SOURCE_BIND,SOURCE_COMPRESSION_ALGORITHMS,SOURCE_CONNECT_RETRY,' + + 'SOURCE_DELAY,SOURCE_HEARTBEAT_PERIOD,SOURCE_HOST,SOURCE_LOG_FILE,' + + 'SOURCE_LOG_POS,SOURCE_PASSWORD,SOURCE_PORT,SOURCE_PUBLIC_KEY_PATH,' + + 'SOURCE_RETRY_COUNT,SOURCE_SSL,SOURCE_SSL_CA,SOURCE_SSL_CAPATH,' + + 'SOURCE_SSL_CERT,SOURCE_SSL_CIPHER,SOURCE_SSL_CRL,SOURCE_SSL_CRLPATH,' + + 'SOURCE_SSL_KEY,SOURCE_SSL_VERIFY_SERVER_CERT,SOURCE_TLS_CIPHERSUITES,' + + 'SOURCE_TLS_VERSION,SOURCE_USER,SOURCE_ZSTD_COMPRESSION_LEVEL,SPATIAL,' + + 'SPECIFIC,SQL,SQLEXCEPTION,SQLSTATE,SQLWARNING,SQL_AFTER_GTIDS,' + + 'SQL_AFTER_MTS_GAPS,SQL_BEFORE_GTIDS,SQL_BIG_RESULT,SQL_BUFFER_RESULT,' + + 'SQL_CACHE,SQL_CALC_FOUND_ROWS,SQL_NO_CACHE,SQL_SMALL_RESULT,SQL_THREAD,' + + 'SQL_TSI_DAY,SQL_TSI_HOUR,SQL_TSI_MINUTE,SQL_TSI_MONTH,SQL_TSI_QUARTER,' + + 'SQL_TSI_SECOND,SQL_TSI_WEEK,SQL_TSI_YEAR,SSL,STACKED,START,STARTING,' + + 'STARTS,STATS_AUTO_RECALC,STATS_PERSISTENT,STATS_SAMPLE_PAGES,STATUS,STOP,' + + 'STORAGE,STORED,STRAIGHT_JOIN,STREAM,SUBCLASS_ORIGIN,SUBJECT,SUBPARTITION,' + + 'SUBPARTITIONS,SUPER,SUSPEND,SWAPS,SWITCHES,SYSTEM,TABLE,TABLES,TABLESPACE,' + + 'TABLE_CHECKSUM,TABLE_NAME,TEMPORARY,TERMINATED,THAN,THREAD_PRIORITY,TIES,' + + 'TLS,TO,TRAILING,TRANSACTION,TRIGGER,TRIGGERS,TRUE,TYPE,TYPES,UNBOUNDED,' + + 'UNCOMMITTED,UNDO,UNDOFILE,UNDO_BUFFER_SIZE,UNINSTALL,UNION,UNIQUE,UNKNOWN,' + + 'UNLOCK,UNREGISTER,UPDATE,UPGRADE,URL,USAGE,USE,USER_RESOURCES,USE_FRM,' + + 'USING,VALIDATION,VALUE,VALUES,VARCHARACTER,VARIABLES,VARYING,VCPU,VIEW,' + + 'VIRTUAL,VISIBLE,WAIT,WARNINGS,WHERE,WINDOW,WITH,WITHOUT,WORK,WRAPPER,' + + 'WRITE,X509,XA,XID,XML,XOR,YEAR_MONTH,ZONE,' + // SQL Plus commands: + + 'CLOSE,CONDITION,CONTINUE,CURSOR,DECLARE,DO,EXIT,FETCH,FOUND,GOTO,' + + 'HANDLER,ITERATE,LANGUAGE,LEAVE,LOOP,UNTIL,WHILE'; + +// Error codes copied from perror.exe +MySQLErrorCodes := Explode(',', '0=No error,'+ + '1=Operation not permitted,'+ + '2=No such file or directory,'+ + '3=No such process,'+ + '4=Interrupted function call,'+ + '5=Input/output error,'+ + '6=No such device or address,'+ + '7=Arg list too long,'+ + '8=Exec format error,'+ + '9=Bad file descriptor,'+ + '10=No child processes,'+ + '11=Resource temporarily unavailable,'+ + '12=Not enough space,'+ + '13=Permission denied,'+ + '14=Bad address,'+ + '16=Resource device,'+ + '17=File exists,'+ + '18=Improper link,'+ + '19=No such device,'+ + '20=Not a directory,'+ + '21=Is a directory,'+ + '22=Invalid argument,'+ + '23=Too many open files in system,'+ + '24=Too many open files,'+ + '25=Inappropriate I/O control operation,'+ + '27=File too large,'+ + '28=No space left on device,'+ + '29=Invalid seek,'+ + '30=Read-only file system,'+ + '31=Too many links,'+ + '32=Broken pipe,'+ + '33=Domain error,'+ + '34=Result too large,'+ + '36=Resource deadlock avoided,'+ + '38=Filename too long,'+ + '39=No locks available,'+ + '40=Function not implemented,'+ + '41=Directory not empty,'+ + '42=Illegal byte sequence,'+ + '120=Didn''t find key on read or update,'+ + '121=Duplicate key on write or update,'+ + '123=Someone has changed the row since it was read (while the table was locked to prevent it),'+ + '124=Wrong index given to function,'+ + '126=Index file is crashed,'+ + '127=Record-file is crashed,'+ + '128=Out of memory,'+ + '130=Incorrect file format,'+ + '131=Command not supported by database,'+ + '132=Old database file,'+ + '133=No record read before update,'+ + '134=Record was already deleted (or record file crashed),'+ + '135=No more room in record file,'+ + '136=No more room in index file,'+ + '137=No more records (read after end of file),'+ + '138=Unsupported extension used for table,'+ + '139=Too big row,'+ + '140=Wrong create options,'+ + '141=Duplicate unique key or constraint on write or update,'+ + '142=Unknown character set used,'+ + '143=Conflicting table definitions in sub-tables of MERGE table,'+ + '144=Table is crashed and last repair failed,'+ + '145=Table was marked as crashed and should be repaired,'+ + '146=Lock timed out; Retry transaction,'+ + '147=Lock table is full; Restart program with a larger locktable,'+ + '148=Updates are not allowed under a read only transactions,'+ + '149=Lock deadlock; Retry transaction,'+ + '150=Foreign key constraint is incorrectly formed,'+ + '151=Cannot add a child row,'+ + '152=Cannot delete a parent row'); + + + +end. diff --git a/source/dbstructures.pas b/source/dbstructures.pas index f2a5f7e38..8056bca0c 100644 --- a/source/dbstructures.pas +++ b/source/dbstructures.pas @@ -1,437 +1,101 @@ unit dbstructures; -// ------------------------------------- -// Server constants, variables and data types -// ------------------------------------- +// Column structures, dll loading +// For server constants, variables and data types see dbstructures.XXX.pas interface uses - Classes, Graphics, Windows, SysUtils, gnugettext, Vcl.Forms; - - - -const - // Used in TMysqlFunction - SQL_VERSION_ANSI = -1; - - // General declarations - MYSQL_ERRMSG_SIZE = 512; - SQLSTATE_LENGTH = 5; - SCRAMBLE_LENGTH = 20; - MYSQL_PORT = 3306; - LOCAL_HOST = 'localhost'; - NAME_LEN = 64; - PROTOCOL_VERSION = 10; - FRM_VER = 6; - - // Field's flags - NOT_NULL_FLAG = 1; - PRI_KEY_FLAG = 2; - UNIQUE_KEY_FLAG = 4; - MULTIPLE_KEY_FLAG = 8; - BLOB_FLAG = 16; - UNSIGNED_FLAG = 32; - ZEROFILL_FLAG = 64; - BINARY_FLAG = 128; - ENUM_FLAG = 256; - AUTO_INCREMENT_FLAG = 512; - TIMESTAMP_FLAG = 1024; - SET_FLAG = 2048; - NUM_FLAG = 32768; - PART_KEY_FLAG = 16384; - GROUP_FLAG = 32768; - UNIQUE_FLAG = 65536; - BINCMP_FLAG = 131072; - - // Client connection options - CLIENT_LONG_PASSWORD = 1; - CLIENT_FOUND_ROWS = 2; // Found instead of affected rows - CLIENT_LONG_FLAG = 4; - CLIENT_CONNECT_WITH_DB = 8; - CLIENT_NO_SCHEMA = 16; // Don't allow database.table.column - CLIENT_COMPRESS = 32; - CLIENT_ODBC = 64; - CLIENT_LOCAL_FILES = 128; - CLIENT_IGNORE_SPACE = 256; // Ignore spaces before '(' - CLIENT_PROTOCOL_41 = 512; - CLIENT_INTERACTIVE = 1024; - CLIENT_SSL = 2048; // Switch to SSL after handshake - CLIENT_IGNORE_SIGPIPE = 4096; - CLIENT_TRANSACTIONS = 8192; - CLIENT_RESERVED = 16384; - CLIENT_SECURE_CONNECTION = 32768; - CLIENT_MULTI_STATEMENTS = 65536; - CLIENT_MULTI_RESULTS = 131072; - CLIENT_CAN_HANDLE_EXPIRED_PASSWORDS = 4194304; - CLIENT_SSL_VERIFY_SERVER_CERT = 67108864; - CLIENT_REMEMBER_OPTIONS = 134217728; - - COLLATION_BINARY = 63; - // Equivalent to COLLATION_BINARY, this is what a new driver returns when connected to a pre-4.1 server. - COLLATION_NONE = 0; - - { SQLite Result Codes - result code definitions - - Many SQLite functions return an integer result code from the set shown - here in order to indicate success or failure. - - New error codes may be added in future versions of SQLite. - - See also: [extended result code definitions] - } - SQLITE_OK = 0; // Successful result - // beginning-of-error-codes - SQLITE_ERROR = 1; // Generic error - SQLITE_INTERNAL = 2; // Internal logic error in SQLite - SQLITE_PERM = 3; // Access permission denied - SQLITE_ABORT = 4; // Callback routine requested an abort - SQLITE_BUSY = 5; // The database file is locked - SQLITE_LOCKED = 6; // A table in the database is locked - SQLITE_NOMEM = 7; // A malloc() failed - SQLITE_READONLY = 8; // Attempt to write a readonly database - SQLITE_INTERRUPT = 9; // Operation terminated by sqlite3_interrupt()*/ - SQLITE_IOERR = 10; // Some kind of disk I/O error occurred - SQLITE_CORRUPT = 11; // The database disk image is malformed - SQLITE_NOTFOUND = 12; // Unknown opcode in sqlite3_file_control() - SQLITE_FULL = 13; // Insertion failed because database is full - SQLITE_CANTOPEN = 14; // Unable to open the database file - SQLITE_PROTOCOL = 15; // Database lock protocol error - SQLITE_EMPTY = 16; // Internal use only - SQLITE_SCHEMA = 17; // The database schema changed - SQLITE_TOOBIG = 18; // String or BLOB exceeds size limit - SQLITE_CONSTRAINT = 19; // Abort due to constraint violation - SQLITE_MISMATCH = 20; // Data type mismatch - SQLITE_MISUSE = 21; // Library used incorrectly - SQLITE_NOLFS = 22; // Uses OS features not supported on host - SQLITE_AUTH = 23; // Authorization denied - SQLITE_FORMAT = 24; // Not used - SQLITE_RANGE = 25; // 2nd parameter to sqlite3_bind out of range - SQLITE_NOTADB = 26; // File opened that is not a database file - SQLITE_NOTICE = 27; // Notifications from sqlite3_log() - SQLITE_WARNING = 28; // Warnings from sqlite3_log() - SQLITE_ROW = 100; // sqlite3_step() has another row ready - SQLITE_DONE = 101; // sqlite3_step() has finished executing - - { SQLite Flags - These constants define various flags that can be passed into - "prepFlags" parameter of the [sqlite3_prepare_v3()] and - [sqlite3_prepare16_v3()] interfaces. - - New flags may be added in future releases of SQLite. - } - SQLITE_PREPARE_PERSISTENT = $01; // prepared statement will be retained for a long time and probably reused many times - SQLITE_PREPARE_NORMALIZE = $02; // no-op - SQLITE_PREPARE_NO_VTAB = $04; // return an error (error code SQLITE_ERROR) if the statement uses any virtual tables - - - { SQLite Fundamental Datatypes - Every value in SQLite has one of five fundamental datatypes: - 64-bit signed integer - 64-bit IEEE floating point number - string - BLOB - NULL - } - SQLITE_INTEGER = 1; - SQLITE_FLOAT = 2; - SQLITE_BLOB = 4; - SQLITE_NULL = 5; - SQLITE_TEXT = 3; - SQLITE3_TEXT = 3; - - { CAPI3REF: Database Connection Configuration Options - These constants are the available integer configuration options that - can be passed as the second argument to the [sqlite3_db_config()] interface. - } - SQLITE_DBCONFIG_MAINDBNAME = 1000; // const char* - SQLITE_DBCONFIG_LOOKASIDE = 1001; // void* int int - SQLITE_DBCONFIG_ENABLE_FKEY = 1002; // int int* - SQLITE_DBCONFIG_ENABLE_TRIGGER = 1003; // int int* - SQLITE_DBCONFIG_ENABLE_FTS3_TOKENIZER = 1004; // int int* - SQLITE_DBCONFIG_ENABLE_LOAD_EXTENSION = 1005; // int int* - SQLITE_DBCONFIG_NO_CKPT_ON_CLOSE = 1006; // int int* - SQLITE_DBCONFIG_ENABLE_QPSG = 1007; // int int* - SQLITE_DBCONFIG_TRIGGER_EQP = 1008; // int int* - SQLITE_DBCONFIG_RESET_DATABASE = 1009; // int int* - SQLITE_DBCONFIG_DEFENSIVE = 1010; // int int* - SQLITE_DBCONFIG_WRITABLE_SCHEMA = 1011; // int int* - SQLITE_DBCONFIG_LEGACY_ALTER_TABLE = 1012; // int int* - SQLITE_DBCONFIG_DQS_DML = 1013; // int int* - SQLITE_DBCONFIG_DQS_DDL = 1014; // int int* - SQLITE_DBCONFIG_ENABLE_VIEW = 1015; // int int* - SQLITE_DBCONFIG_MAX = 1015; // Largest DBCONFIG - - - - type - PUSED_MEM=^USED_MEM; - USED_MEM = packed record - next: PUSED_MEM; - left: Integer; - size: Integer; - end; - - PERR_PROC = ^ERR_PROC; - ERR_PROC = procedure; - - PMEM_ROOT = ^MEM_ROOT; - MEM_ROOT = packed record - free: PUSED_MEM; - used: PUSED_MEM; - pre_alloc: PUSED_MEM; - min_malloc: Integer; - block_size: Integer; - block_num: Integer; - first_block_usage: Integer; - error_handler: PERR_PROC; - end; - - NET = record - vio: Pointer; - buff: PAnsiChar; - buff_end: PAnsiChar; - write_pos: PAnsiChar; - read_pos: PAnsiChar; - fd: Integer; - max_packet: Cardinal; - max_packet_size: Cardinal; - pkt_nr: Cardinal; - compress_pkt_nr: Cardinal; - write_timeout: Cardinal; - read_timeout: Cardinal; - retry_count: Cardinal; - fcntl: Integer; - compress: Byte; - remain_in_buf: LongInt; - length: LongInt; - buf_length: LongInt; - where_b: LongInt; - return_status: Pointer; - reading_or_writing: Char; - save_char: Char; - no_send_ok: Byte; - last_error: array[1..MYSQL_ERRMSG_SIZE] of Char; - sqlstate: array[1..SQLSTATE_LENGTH + 1] of Char; - last_errno: Cardinal; - error: Char; - query_cache_query: Pointer; - report_error: Byte; - return_errno: Byte; - end; - - PMYSQL_FIELD = ^MYSQL_FIELD; - MYSQL_FIELD = record - name: PAnsiChar; // Name of column - org_name: PAnsiChar; // Name of original column (added after 3.23.58) - table: PAnsiChar; // Table of column if column was a field - org_table: PAnsiChar; // Name of original table (added after 3.23.58 - db: PAnsiChar; // table schema (added after 3.23.58) - catalog: PAnsiChar; // table catalog (added after 3.23.58) - def: PAnsiChar; // Default value (set by mysql_list_fields) - length: LongInt; // Width of column - max_length: LongInt; // Max width of selected set - // added after 3.23.58 - name_length: Cardinal; - org_name_length: Cardinal; - table_length: Cardinal; - org_table_length: Cardinal; - db_length: Cardinal; - catalog_length: Cardinal; - def_length: Cardinal; - //*********************** - flags: Cardinal; // Div flags - decimals: Cardinal; // Number of decimals in field - charsetnr: Cardinal; // char set number (added in 4.1) - _type: Cardinal; // Type of field. Se mysql_com.h for types - end; - - MYSQL_ROW = array[0..$ffff] of PAnsiChar; - PMYSQL_ROW = ^MYSQL_ROW; - - PMYSQL_ROWS = ^MYSQL_ROWS; - MYSQL_ROWS = record - next: PMYSQL_ROWS; - data: PMYSQL_ROW; - end; - - MYSQL_DATA = record - Rows: Int64; - Fields: Cardinal; - Data: PMYSQL_ROWS; - Alloc: MEM_ROOT; - end; - PMYSQL_DATA = ^MYSQL_DATA; - - PMYSQL = ^MYSQL; - MYSQL = record - _net: NET; - connector_fd: Pointer; - host: PAnsiChar; - user: PAnsiChar; - passwd: PAnsiChar; - unix_socket: PAnsiChar; - server_version: PAnsiChar; - host_info: PAnsiChar; - info: PAnsiChar; - db: PAnsiChar; - charset: PAnsiChar; - fields: PMYSQL_FIELD; - field_alloc: MEM_ROOT; - affected_rows: Int64; - insert_id: Int64; - extra_info: Int64; - thread_id: LongInt; - packet_length: LongInt; - port: Cardinal; - client_flag: LongInt; - server_capabilities: LongInt; - protocol_version: Cardinal; - field_count: Cardinal; - server_status: Cardinal; - server_language: Cardinal; - warning_count: Cardinal; - options: Cardinal; - status: Byte; - free_me: Byte; - reconnect: Byte; - scramble: array[1..SCRAMBLE_LENGTH+1] of Char; - rpl_pivot: Byte; - master: PMYSQL; - next_slave: PMYSQL; - last_used_slave: PMYSQL; - last_used_con: PMYSQL; - stmts: Pointer; - methods: Pointer; - thd: Pointer; - unbuffered_fetch_owner: PByte; - end; - - MYSQL_RES = record - row_count: Int64; - field_count, current_field: Integer; - fields: PMYSQL_FIELD; - data: PMYSQL_DATA; - data_cursor: PMYSQL_ROWS; - field_alloc: MEM_ROOT; - row: PMYSQL_ROW; // If unbuffered read - current_row: PMYSQL_ROW; // buffer to current row - lengths: PLongInt; // column lengths of current row - handle: PMYSQL; // for unbuffered reads - eof: Byte; // Used my mysql_fetch_row - is_ps: Byte; - end; - PMYSQL_RES = ^MYSQL_RES; - - TMySQLOption = ( - MYSQL_OPT_CONNECT_TIMEOUT, - MYSQL_OPT_COMPRESS, - MYSQL_OPT_NAMED_PIPE, - MYSQL_INIT_COMMAND, - MYSQL_READ_DEFAULT_FILE, - MYSQL_READ_DEFAULT_GROUP, - MYSQL_SET_CHARSET_DIR, - MYSQL_SET_CHARSET_NAME, - MYSQL_OPT_LOCAL_INFILE, - MYSQL_OPT_PROTOCOL, - MYSQL_SHARED_MEMORY_BASE_NAME, - MYSQL_OPT_READ_TIMEOUT, - MYSQL_OPT_WRITE_TIMEOUT, - MYSQL_OPT_USE_RESULT, - MYSQL_OPT_USE_REMOTE_CONNECTION, - MYSQL_OPT_USE_EMBEDDED_CONNECTION, - MYSQL_OPT_GUESS_CONNECTION, - MYSQL_SET_CLIENT_IP, - MYSQL_SECURE_AUTH, - MYSQL_REPORT_DATA_TRUNCATION, - MYSQL_OPT_RECONNECT, - MYSQL_OPT_SSL_VERIFY_SERVER_CERT, - MYSQL_PLUGIN_DIR, - MYSQL_DEFAULT_AUTH, - MYSQL_OPT_BIND, - MYSQL_OPT_SSL_KEY, - MYSQL_OPT_SSL_CERT, - MYSQL_OPT_SSL_CA, - MYSQL_OPT_SSL_CAPATH, - MYSQL_OPT_SSL_CIPHER, - MYSQL_OPT_SSL_CRL, - MYSQL_OPT_SSL_CRLPATH, - // Connection attribute options - MYSQL_OPT_CONNECT_ATTR_RESET, - MYSQL_OPT_CONNECT_ATTR_ADD, - MYSQL_OPT_CONNECT_ATTR_DELETE, - MYSQL_SERVER_PUBLIC_KEY, - MYSQL_ENABLE_CLEARTEXT_PLUGIN, - MYSQL_OPT_CAN_HANDLE_EXPIRED_PASSWORDS, - MYSQL_OPT_SSL_ENFORCE, - MYSQL_OPT_MAX_ALLOWED_PACKET, - MYSQL_OPT_NET_BUFFER_LENGTH, - MYSQL_OPT_TLS_VERSION, - MYSQL_OPT_SSL_MODE, - MYSQL_OPT_GET_SERVER_PUBLIC_KEY, - - // MariaDB specific - MYSQL_PROGRESS_CALLBACK=5999, - MYSQL_OPT_NONBLOCK, - // MariaDB Connector/C specific - MYSQL_DATABASE_DRIVER=7000, - MARIADB_OPT_SSL_FP, // deprecated, use MARIADB_OPT_TLS_PEER_FP instead - MARIADB_OPT_SSL_FP_LIST, // deprecated, use MARIADB_OPT_TLS_PEER_FP_LIST instead - MARIADB_OPT_TLS_PASSPHRASE, // passphrase for encrypted certificates - MARIADB_OPT_TLS_CIPHER_STRENGTH, - MARIADB_OPT_TLS_VERSION, - MARIADB_OPT_TLS_PEER_FP, // single finger print for server certificate verification - MARIADB_OPT_TLS_PEER_FP_LIST, // finger print white list for server certificate verification - MARIADB_OPT_CONNECTION_READ_ONLY, - MYSQL_OPT_CONNECT_ATTRS, // for mysql_get_optionv - MARIADB_OPT_USERDATA, - MARIADB_OPT_CONNECTION_HANDLER, - MARIADB_OPT_PORT, - MARIADB_OPT_UNIXSOCKET, - MARIADB_OPT_PASSWORD, - MARIADB_OPT_HOST, - MARIADB_OPT_USER, - MARIADB_OPT_SCHEMA, - MARIADB_OPT_DEBUG, - MARIADB_OPT_FOUND_ROWS, - MARIADB_OPT_MULTI_RESULTS, - MARIADB_OPT_MULTI_STATEMENTS, - MARIADB_OPT_INTERACTIVE, - MARIADB_OPT_PROXY_HEADER + gnugettext, Vcl.Graphics, Winapi.Windows, System.SysUtils, System.Classes, System.IOUtils, + System.Generics.Collections, StrUtils; + + +type + + TNetType = ( + ntMySQL_TCPIP, + ntMySQL_NamedPipe, + ntMySQL_SSHtunnel, + ntMSSQL_NamedPipe, + ntMSSQL_TCPIP, + ntMSSQL_SPX, + ntMSSQL_VINES, + ntMSSQL_RPC, + ntPgSQL_TCPIP, + ntPgSQL_SSHtunnel, + ntSQLite, + ntMySQL_ProxySQLAdmin, + ntInterbase_TCPIP, + ntInterbase_Local, + ntFirebird_TCPIP, + ntFirebird_Local, + ntMySQL_RDS, + ntSQLiteEncrypted ); + TNetTypeGroup = (ngMySQL, ngMSSQL, ngPgSQL, ngSQLite, ngInterbase); + TNetTypeLibs = TDictionary; + + // SQL query ids and provider + TStringMap = TDictionary; + TQueryId = (qDatabaseTable, qDatabaseTableId, qDatabaseDrop, + qDbObjectsTable, qDbObjectsCreateCol, qDbObjectsUpdateCol, qDbObjectsTypeCol, + qEmptyTable, qRenameTable, qRenameView, qCurrentUserHost, qLikeCompare, + qAddColumn, qChangeColumn, qRenameColumn, qSetColumnComment, qForeignKeyEventAction, + qGlobalStatus, qCommandsCounters, qSessionVariables, qGlobalVariables, + qISSchemaCol, + qUSEQuery, qKillQuery, qKillProcess, + qFuncLength, qFuncCeil, qFuncLeft, qFuncNow, qFuncLastAutoIncNumber, + qLockedTables, qDisableForeignKeyChecks, qEnableForeignKeyChecks, + qOrderAsc, qOrderDesc, qGetRowCountExact, qGetRowCountApprox, + qForeignKeyDrop, qGetTableColumns, qGetCollations, qGetCollationsExtended, qGetCharsets, + qGetReverseForeignKeys, qExplain, qSetTimezone, + qShowFunctionStatus, qShowProcedureStatus, qShowTriggers, qShowEvents, qShowCreateTrigger, + qHelpKeyword, qShowWarnings, qGetEnumTypes, + qDropUser, qCreateRole, qDropRole, qReloadPrivileges, qGrantRole, qRevokeRole, qSetDefaultRole, + qAutoInc, qIndexVisible, qIndexInvisible, qGetAuthPlugins, qCastAsText, qIndexSize); + TSqlProvider = class + strict protected + FNetType: TNetType; + FServerVersion: Integer; + public + constructor Create(ANetType: TNetType); + function Has(AId: TQueryId): Boolean; + // Base version, just returns the original SQL string + function GetSql(AId: TQueryId): string; overload; virtual; + // Version for simple strings passed to Format() + function GetSql(AId: TQueryId; const Args: array of const): string; overload; + // Version for named parameters + function GetSql(AId: TQueryId; NamedParameters: TStringMap): string; overload; + property ServerVersion: Integer read FServerVersion write FServerVersion; + end; - // MySQL data types - TDBDatatypeIndex = (dtTinyint, dtSmallint, dtMediumint, dtInt, dtBigint, dtSerial, dtBigSerial, - dtFloat, dtDouble, dtDecimal, dtNumeric, dtReal, dtDoublePrecision, dtMoney, dtSmallmoney, - dtDate, dtTime, dtYear, dtDatetime, dtDatetime2, dtDatetimeOffset, dtSmalldatetime, dtTimestamp, dtInterval, - dtChar, dtNchar, dtVarchar, dtNvarchar, dtTinytext, dtText, dtNtext, dtMediumtext, dtLongtext, - dtJson, dtCidr, dtInet, dtMacaddr, - dtBinary, dtVarbinary, dtTinyblob, dtBlob, dtMediumblob, dtLongblob, dtImage, - dtEnum, dtSet, dtBit, dtVarBit, dtBool, dtRegClass, dtUnknown, - dtCursor, dtSqlvariant, dtTable, dtUniqueidentifier, dtHierarchyid, dtXML, - dtPoint, dtLinestring, dtLineSegment, dtPolygon, dtGeometry, dtBox, dtPath, dtCircle, dtMultipoint, dtMultilinestring, dtMultipolygon, dtGeometrycollection + // Column types + TDBDatatypeIndex = (dbdtTinyint, dbdtSmallint, dbdtMediumint, dbdtInt, dbdtUint, dbdtBigint, dbdtSerial, dbdtBigSerial, + dbdtFloat, dbdtDouble, dbdtDecimal, dbdtNumeric, dbdtReal, dbdtDoublePrecision, dbdtMoney, dbdtSmallmoney, + dbdtDate, dbdtTime, dbdtYear, dbdtDatetime, dbdtDatetime2, dbdtDatetimeOffset, dbdtSmalldatetime, dbdtTimestamp, dbdtInterval, + dbdtChar, dbdtNchar, dbdtVarchar, dbdtNvarchar, dbdtTinytext, dbdtText, dbdtCiText, dbdtNtext, dbdtMediumtext, dbdtLongtext, + dbdtJson, dbdtJsonB, dbdtCidr, dbdtInet, dbdtMacaddr, + dbdtBinary, dbdtVarbinary, dbdtTinyblob, dbdtBlob, dbdtMediumblob, dbdtLongblob, dbdtVector, dbdtImage, + dbdtEnum, dbdtSet, dbdtBit, dbdtVarBit, dbdtBool, dbdtRegClass, dbdtRegProc, dbdtUnknown, + dbdtCursor, dbdtSqlvariant, dbdtTable, dbdtUniqueidentifier, dbdtInet4, dbdtInet6, dbdtHierarchyid, dbdtXML, + dbdtPoint, dbdtLinestring, dbdtLineSegment, dbdtPolygon, dbdtGeometry, dbdtBox, dbdtPath, dbdtCircle, dbdtMultipoint, dbdtMultilinestring, dbdtMultipolygon, dbdtGeometrycollection ); - // MySQL data type categorization + // Column type categorization TDBDatatypeCategoryIndex = (dtcInteger, dtcReal, dtcText, dtcBinary, dtcTemporal, dtcSpatial, dtcOther); - // MySQL native column type constants. See include/mysql.h.pp in the server code - TMySQLType = (mytDecimal, mytTiny, mytShort, mytLong, mytFloat, mytDouble, mytNull, mytTimestamp, - mytLonglong, mytInt24, mytDate, mytTime, mytDatetime, mytYear, mytNewdate, mytVarchar, - mytBit, mytTimestamp2, mytDatetime2, mytTime2, mytJson=245, mytNewdecimal, mytEnum, mytSet, mytTinyblob, - mytMediumblob, mytLongblob, mytBlob, mytVarstring, mytString, mytGeometry); - // MySQL data type structure + // Column type structure TDBDatatype = record Index: TDBDatatypeIndex; - NativeType: TMySQLType; // See above - NativeTypes: String; // Same as above, but for multiple postgresql oid's + NativeType: Integer; // MySQL column type constant (e.g. 1 = TINYINT). See include/mysql.h.pp. + NativeTypes: String; // Same as above, but for multiple ids (e.g. PostgreSQL oids). Prefer over NativeType. See GetDatatypeByNativeType. Name: String; Names: String; Description: String; HasLength: Boolean; // Can have Length- or Set-attribute? RequiresLength: Boolean; // Must have a Length- or Set-attribute? - MaxTextLen: String; // TEXT and BLOB allow custom length, but we want to leave the default max length away from ALTER TABLE's + MaxSize: Int64; + DefaultSize: Int64; // TEXT and BLOB allow custom length, but we want to leave the default max length away from ALTER TABLE's HasBinary: Boolean; // Can be binary? HasDefault: Boolean; // Can have a default value? LoadPart: Boolean; // Select per SUBSTR() or LEFT() @@ -439,9 +103,10 @@ TDBDatatype = record Format: String; // Used for date/time values when displaying and generating queries ValueMustMatch: String; Category: TDBDatatypeCategoryIndex; + MinVersion: Integer; end; - // MySQL data type category structure + // Column type category structure TDBDatatypeCategory = record Index: TDBDatatypeCategoryIndex; Name: String; @@ -449,25 +114,6 @@ TDBDatatypeCategory = record NullColor: TColor; end; - // MySQL functions structure - TMySQLFunction = record - Name: String; - Declaration: String; - Category: String; - Version: Integer; // Minimum MySQL version where function is available - Description: String; - end; - - // PostgreSQL structures - TPQConnectStatus = (CONNECTION_OK, CONNECTION_BAD, CONNECTION_STARTED, CONNECTION_MADE, CONNECTION_AWAITING_RESPONSE, CONNECTION_AUTH_OK, CONNECTION_SETENV, CONNECTION_SSL_STARTUP, CONNECTION_NEEDED); - PPGconn = Pointer; - PPGresult = Pointer; - POid = Cardinal; - - // SQLite structures - Psqlite3 = Pointer; - Psqlite3_stmt = Pointer; - // Server variables TVarScope = (vsGlobal, vsSession, vsBoth); TServerVariable = record @@ -479,9 +125,13 @@ TServerVariable = record // Custom exception class for any connection or database related error EDbError = class(Exception) + private + FErrorCode: Cardinal; + FHint: String; public - ErrorCode: Cardinal; - constructor Create(const Msg: string; const ErrorCode: Cardinal=0); + property ErrorCode: Cardinal read FErrorCode; + property Hint: String read FHint; + constructor Create(const Msg: string; const ErrorCode_: Cardinal=0; const Hint_: String=''); end; // DLL loading @@ -489,115 +139,22 @@ TDbLib = class(TObject) const LIB_PROC_ERROR: Cardinal = 1000; private - FDllFile: String; FHandle: HMODULE; + protected + FDllFile: String; procedure AssignProc(var Proc: FARPROC; Name: PAnsiChar; Mandantory: Boolean=True); procedure AssignProcedures; virtual; abstract; public property Handle: HMODULE read FHandle; property DllFile: String read FDllFile; - constructor Create(DllFile: String); + constructor Create(UsedDllFile, HintDefaultDll: String); virtual; destructor Destroy; override; end; - TMySQLLib = class(TDbLib) - mysql_affected_rows: function(Handle: PMYSQL): Int64; stdcall; - mysql_character_set_name: function(Handle: PMYSQL): PAnsiChar; stdcall; - mysql_close: procedure(Handle: PMYSQL); stdcall; - mysql_data_seek: procedure(Result: PMYSQL_RES; Offset: Int64); stdcall; - mysql_errno: function(Handle: PMYSQL): Cardinal; stdcall; - mysql_error: function(Handle: PMYSQL): PAnsiChar; stdcall; - mysql_fetch_field_direct: function(Result: PMYSQL_RES; FieldNo: Cardinal): PMYSQL_FIELD; stdcall; - mysql_fetch_field: function(Result: PMYSQL_RES): PMYSQL_FIELD; stdcall; - mysql_fetch_lengths: function(Result: PMYSQL_RES): PLongInt; stdcall; - mysql_fetch_row: function(Result: PMYSQL_RES): PMYSQL_ROW; stdcall; - mysql_free_result: procedure(Result: PMYSQL_RES); stdcall; - mysql_get_client_info: function: PAnsiChar; stdcall; - mysql_get_server_info: function(Handle: PMYSQL): PAnsiChar; stdcall; - mysql_init: function(Handle: PMYSQL): PMYSQL; stdcall; - mysql_num_fields: function(Result: PMYSQL_RES): Integer; stdcall; - mysql_num_rows: function(Result: PMYSQL_RES): Int64; stdcall; - mysql_options: function(Handle: PMYSQL; Option: Integer; arg: PAnsiChar): Integer; stdcall; - mysql_optionsv: function(Handle: PMYSQL; Option: Integer; arg, val: PAnsiChar): Integer; stdcall; - mysql_ping: function(Handle: PMYSQL): Integer; stdcall; - mysql_real_connect: function(Handle: PMYSQL; const Host, User, Passwd, Db: PAnsiChar; Port: Cardinal; const UnixSocket: PAnsiChar; ClientFlag: Cardinal): PMYSQL; stdcall; - mysql_real_query: function(Handle: PMYSQL; const Query: PAnsiChar; Length: Cardinal): Integer; stdcall; - mysql_ssl_set: function(Handle: PMYSQL; const key, cert, CA, CApath, cipher: PAnsiChar): Byte; stdcall; - mysql_stat: function(Handle: PMYSQL): PAnsiChar; stdcall; - mysql_store_result: function(Handle: PMYSQL): PMYSQL_RES; stdcall; - mysql_thread_id: function(Handle: PMYSQL): Cardinal; stdcall; - mysql_next_result: function(Handle: PMYSQL): Integer; stdcall; - mysql_set_character_set: function(Handle: PMYSQL; csname: PAnsiChar): Integer; stdcall; - mysql_thread_init: function: Byte; stdcall; - mysql_thread_end: procedure; stdcall; - mysql_warning_count: function(Handle: PMYSQL): Cardinal; stdcall; - private - procedure AssignProcedures; override; - end; - TPostgreSQLLib = class(TDbLib) - PQconnectdb: function(const ConnInfo: PAnsiChar): PPGconn cdecl; - PQerrorMessage: function(const Handle: PPGconn): PAnsiChar cdecl; - PQresultErrorMessage: function(const Result: PPGresult): PAnsiChar cdecl; - PQresultErrorField: function(const Result: PPGresult; fieldcode: Integer): PAnsiChar; - PQfinish: procedure(const Handle: PPGconn); - PQstatus: function(const Handle: PPGconn): TPQConnectStatus cdecl; - PQsendQuery: function(const Handle: PPGconn; command: PAnsiChar): Integer cdecl; - PQgetResult: function(const Handle: PPGconn): PPGresult cdecl; - PQbackendPID: function(const Handle: PPGconn): Integer cdecl; - PQcmdTuples: function(Result: PPGresult): PAnsiChar; cdecl; - PQntuples: function(Result: PPGresult): Integer; cdecl; - PQclear: procedure(Result: PPGresult); cdecl; - PQnfields: function(Result: PPGresult): Integer; cdecl; - PQfname: function(const Result: PPGresult; column_number: Integer): PAnsiChar; cdecl; - PQftype: function(const Result: PPGresult; column_number: Integer): POid; cdecl; - PQftable: function(const Result: PPGresult; column_number: Integer): POid; cdecl; - PQgetvalue: function(const Result: PPGresult; row_number: Integer; column_number: Integer): PAnsiChar; cdecl; - PQgetlength: function(const Result: PPGresult; row_number: Integer; column_number: Integer): Integer; cdecl; - PQgetisnull: function(const Result: PPGresult; row_number: Integer; column_number: Integer): Integer; cdecl; - PQlibVersion: function(): Integer; cdecl; - private - procedure AssignProcedures; override; - end; - TSQLiteCollationNeededCallback = procedure(userData: Pointer; ppDb:Psqlite3; eTextRep: Integer; zName: PAnsiChar); cdecl; - TSQLiteCollation = function(userData: Pointer; lenA: Integer; strA: PAnsiChar; lenB: Integer; strB: PAnsiChar): Integer; cdecl; - TSQLiteLib = class(TDbLib) - sqlite3_open: function(const filename: PAnsiChar; var ppDb: Psqlite3): Integer; cdecl; - sqlite3_libversion: function(): PAnsiChar; cdecl; - sqlite3_close: function(ppDb: Psqlite3): Integer; cdecl; - sqlite3_db_config: function (ppDb: Psqlite3; op: Integer): Integer; cdecl varargs; - sqlite3_errmsg: function(ppDb: Psqlite3): PAnsiChar; cdecl; - sqlite3_errcode: function(ppDb: Psqlite3): Integer; cdecl; - sqlite3_prepare_v2: function(ppDb: Psqlite3; zSql: PAnsiChar; nByte: Integer; var ppStmt: Psqlite3_stmt; var pzTail: PAnsiChar): Integer; cdecl; - sqlite3_prepare_v3: function(ppDb: Psqlite3; zSql: PAnsiChar; nByte: Integer; prepFlags: Cardinal; var ppStmt: Psqlite3_stmt; var pzTail: PAnsiChar): Integer; cdecl; - sqlite3_exec: function(ppDb: Psqlite3; sql: PAnsiChar; callback: Integer; callvack_arg: Pointer; errmsg: PAnsiChar): Integer; cdecl; - sqlite3_finalize: function(pStmt: Psqlite3_stmt): Integer; cdecl; - sqlite3_step: function(pStmt: Psqlite3_stmt): Integer; cdecl; - sqlite3_reset: function(pStmt: Psqlite3_stmt): Integer; cdecl; - sqlite3_total_changes: function(ppDb: Psqlite3): Integer; cdecl; - sqlite3_column_text: function(pStmt: Psqlite3_stmt; iCol: Integer): PAnsiChar; cdecl; - sqlite3_column_count: function(pStmt: Psqlite3_stmt): Integer; cdecl; - sqlite3_column_name: function(pStmt: Psqlite3_stmt; N: Integer): PAnsiChar; cdecl; - sqlite3_column_decltype: function(pStmt: Psqlite3_stmt; N: Integer): PAnsiChar; cdecl; - sqlite3_column_database_name: function(pStmt: Psqlite3_stmt; N: Integer): PAnsiChar; cdecl; - sqlite3_column_table_name: function(pStmt: Psqlite3_stmt; N: Integer): PAnsiChar; cdecl; - sqlite3_column_origin_name: function(pStmt: Psqlite3_stmt; N: Integer): PAnsiChar; cdecl; - sqlite3_column_type: function(pStmt: Psqlite3_stmt; iCol: Integer): Integer; cdecl; - sqlite3_next_stmt: function(ppDb: Psqlite3; pStmt: Psqlite3_stmt): Psqlite3_stmt; cdecl; - sqlite3_table_column_metadata: function(ppDb: Psqlite3; - zDbName, zTableName, zColumnName: PAnsiChar; - var pzDataType, pzCollSeq: PAnsiChar; var pNotNull, pPrimaryKey, pAutoinc: Integer - ): Integer; cdecl; - sqlite3_collation_needed: function(ppDb: Psqlite3; userData: Pointer; Func: TSQLiteCollationNeededCallback): Integer; cdecl; - sqlite3_create_collation: function(ppDb: Psqlite3; const zName: PAnsiChar; eTextRep: Integer; pArg: Pointer; xCompare: TSQLiteCollation): Integer; cdecl; - private - procedure AssignProcedures; override; - end; var - MySQLKeywords: TStringList; - MySQLErrorCodes: TStringList; - // MySQL data type categories + // Column type categories DatatypeCategories: array[TDBDatatypeCategoryIndex] of TDBDatatypeCategory = ( ( Index: dtcInteger; @@ -629,19134 +186,68 @@ TSQLiteLib = class(TDbLib) ) ); - // MySQL Data Type List and Properties - MySQLDatatypes: array [0..37] of TDBDatatype = - ( - ( - Index: dtUnknown; - NativeTypes: '99999'; - Name: 'UNKNOWN'; - Description: 'Unknown data type'; - HasLength: False; - RequiresLength: False; - HasBinary: False; - HasDefault: False; - LoadPart: False; - Category: dtcOther; - ), - ( - Index: dtTinyint; - NativeType: mytTiny; - Name: 'TINYINT'; - Description: 'TINYINT[(M)] [UNSIGNED] [ZEROFILL]' + sLineBreak + - 'A very small integer. The signed range is -128 to 127. ' + - 'The unsigned range is 0 to 255.'; - HasLength: True; - RequiresLength: False; - HasBinary: False; - HasDefault: True; - LoadPart: False; - Category: dtcInteger; - ), - ( - Index: dtSmallint; - NativeType: mytShort; - Name: 'SMALLINT'; - Description: 'SMALLINT[(M)] [UNSIGNED] [ZEROFILL]' + sLineBreak + - 'A small integer. The signed range is -32768 to 32767. ' + - 'The unsigned range is 0 to 65535.'; - HasLength: True; - RequiresLength: False; - HasBinary: False; - HasDefault: True; - LoadPart: False; - Category: dtcInteger; - ), - ( - Index: dtMediumint; - NativeType: mytInt24; - Name: 'MEDIUMINT'; - Description: 'MEDIUMINT[(M)] [UNSIGNED] [ZEROFILL]' + sLineBreak + - 'A medium-sized integer. The signed range is -8388608 to 8388607. ' + - 'The unsigned range is 0 to 16777215.'; - HasLength: True; - RequiresLength: False; - HasBinary: False; - HasDefault: True; - LoadPart: False; - Category: dtcInteger; - ), - ( - Index: dtInt; - NativeType: mytLong; - Name: 'INT'; - Description: 'INT[(M)] [UNSIGNED] [ZEROFILL]' + sLineBreak + - 'A normal-size integer. The signed range is -2147483648 to 2147483647. ' + - 'The unsigned range is 0 to 4294967295.'; - HasLength: True; - RequiresLength: False; - HasBinary: False; - HasDefault: True; - LoadPart: False; - Category: dtcInteger; - ), - ( - Index: dtBigint; - NativeType: mytLonglong; - Name: 'BIGINT'; - Description: 'BIGINT[(M)] [UNSIGNED] [ZEROFILL]' + sLineBreak + - 'A large integer. The signed range is -9223372036854775808 to ' + - '9223372036854775807. The unsigned range is 0 to 18446744073709551615.'; - HasLength: True; - RequiresLength: False; - HasBinary: False; - HasDefault: True; - LoadPart: False; - Category: dtcInteger; - ), - ( - Index: dtFloat; - NativeType: mytFloat; - Name: 'FLOAT'; - Description: 'FLOAT[(M,D)] [UNSIGNED] [ZEROFILL]' + sLineBreak + - 'A small (single-precision) floating-point number. Allowable values are '+ - '-3.402823466E+38 to -1.175494351E-38, 0, and 1.175494351E-38 to '+ - '3.402823466E+38. These are the theoretical limits, based on the IEEE '+ - 'standard. The actual range might be slightly smaller depending on your '+ - 'hardware or operating system.'; - HasLength: True; - RequiresLength: False; - HasBinary: False; - HasDefault: True; - LoadPart: False; - Category: dtcReal; - ), - ( - Index: dtDouble; - NativeType: mytDouble; - Name: 'DOUBLE'; - Description: 'DOUBLE[(M,D)] [UNSIGNED] [ZEROFILL]' + sLineBreak + - 'A normal-size (double-precision) floating-point number. Allowable ' + - 'values are -1.7976931348623157E+308 to -2.2250738585072014E-308, 0, and ' + - '2.2250738585072014E-308 to 1.7976931348623157E+308. These are the ' + - 'theoretical limits, based on the IEEE standard. The actual range might ' + - 'be slightly smaller depending on your hardware or operating system.'; - HasLength: True; - RequiresLength: False; - HasBinary: False; - HasDefault: True; - LoadPart: False; - Category: dtcReal; - ), - ( - Index: dtDecimal; - NativeType: mytNewdecimal; - Name: 'DECIMAL'; - Description: 'DECIMAL[(M[,D])] [UNSIGNED] [ZEROFILL]' + sLineBreak + - 'A packed "exact" fixed-point number. M is the total number of digits ' + - '(the precision) and D is the number of digits after the decimal point ' + - '(the scale). The decimal point and (for negative numbers) the "-" sign ' + - 'are not counted in M. If D is 0, values have no decimal point or ' + - 'fractional part. The maximum number of digits (M) for DECIMAL is 65. ' + - 'The maximum number of supported decimals (D) is 30. If D is omitted, ' + - 'the default is 0. If M is omitted, the default is 10.'; - HasLength: True; - RequiresLength: True; - HasBinary: False; - HasDefault: True; - LoadPart: False; - DefLengthSet: '10,0'; - Category: dtcReal; - ), - ( - Index: dtDate; - NativeType: mytDate; - Name: 'DATE'; - Description: 'DATE' + sLineBreak + - 'A date. The supported range is ''1000-01-01'' to ''9999-12-31''. MySQL ' + - 'displays DATE values in ''YYYY-MM-DD'' format, but allows assignment of ' + - 'values to DATE columns using either strings or numbers.'; - HasLength: False; - RequiresLength: False; - HasBinary: False; - HasDefault: True; - LoadPart: False; - Format: 'yyyy-mm-dd'; - Category: dtcTemporal; - ), - ( - Index: dtTime; - NativeType: mytTime; - Name: 'TIME'; - Description: 'TIME' + sLineBreak + - 'A time. The range is ''-838:59:59'' to ''838:59:59''. MySQL displays TIME ' + - 'values in ''HH:MM:SS'' format, but allows assignment of values to TIME ' + - 'columns using either strings or numbers.'; - HasLength: False; - RequiresLength: False; - HasBinary: False; - HasDefault: True; - LoadPart: False; - Format: 'hh:nn:ss'; - Category: dtcTemporal; - ), - ( - Index: dtYear; - NativeType: mytYear; - Name: 'YEAR'; - Description: 'YEAR[(2|4)]' + sLineBreak + - 'A year in two-digit or four-digit format. The default is four-digit ' + - 'format. In four-digit format, the allowable values are 1901 to 2155, ' + - 'and 0000. In two-digit format, the allowable values are 70 to 69, ' + - 'representing years from 1970 to 2069. MySQL displays YEAR values in ' + - 'YYYY format, but allows you to assign values to YEAR columns using ' + - 'either strings or numbers.'; - HasLength: False; - RequiresLength: False; - HasBinary: False; - HasDefault: True; - LoadPart: False; - Format: 'yyyy'; - Category: dtcTemporal; - ), - ( - Index: dtDatetime; - NativeType: mytDatetime; - Name: 'DATETIME'; - Description: 'DATETIME' + sLineBreak + - 'A date and time combination. The supported range is ''1000-01-01 ' + - '00:00:00'' to ''9999-12-31 23:59:59''. MySQL displays DATETIME values in ' + - '''YYYY-MM-DD HH:MM:SS'' format, but allows assignment of values to ' + - 'DATETIME columns using either strings or numbers.'; - HasLength: False; - RequiresLength: False; - HasBinary: False; - HasDefault: True; - LoadPart: False; - Format: 'yyyy-mm-dd hh:nn:ss'; - Category: dtcTemporal; - ), - ( - Index: dtTimestamp; - NativeType: mytTimestamp; - Name: 'TIMESTAMP'; - Description: 'TIMESTAMP' + sLineBreak + - 'A timestamp. The range is ''1970-01-01 00:00:01'' UTC to ''2038-01-09 ' + - '03:14:07'' UTC. TIMESTAMP values are stored as the number of seconds ' + - 'since the epoch (''1970-01-01 00:00:00'' UTC). A TIMESTAMP cannot ' + - 'represent the value ''1970-01-01 00:00:00'' because that is equivalent to ' + - '0 seconds from the epoch and the value 0 is reserved for representing ' + - '''0000-00-00 00:00:00'', the "zero" TIMESTAMP value.'; - HasLength: False; - RequiresLength: False; - HasBinary: False; - HasDefault: True; - LoadPart: False; - Format: 'yyyy-mm-dd hh:nn:ss'; - Category: dtcTemporal; - ), - ( - Index: dtChar; - NativeType: mytString; - Name: 'CHAR'; - Description: 'CHAR[(M)]' + sLineBreak + - 'A fixed-length string that is always right-padded with spaces to the ' + - 'specified length when stored. M represents the column length in ' + - 'characters. The range of M is 0 to 255. If M is omitted, the length is 1.' + sLineBreak + sLineBreak + - '*Note*: Trailing spaces are removed when CHAR values are retrieved ' + - 'unless the PAD_CHAR_TO_FULL_LENGTH SQL mode is enabled.'; - HasLength: True; - RequiresLength: True; - HasBinary: True; - HasDefault: True; - LoadPart: False; - DefLengthSet: '50'; - Category: dtcText; - ), - ( - Index: dtVarchar; - NativeType: mytVarstring; - Name: 'VARCHAR'; - Description: 'VARCHAR(M)' + sLineBreak + - 'A variable-length string. M represents the maximum column length in ' + - 'characters. The range of M is 0 to 65,535. The effective maximum length ' + - 'of a VARCHAR is subject to the maximum row size (65,535 bytes, which is ' + - 'shared among all columns) and the character set used. For example, utf8 ' + - 'characters can require up to three bytes per character, so a VARCHAR ' + - 'column that uses the utf8 character set can be declared to be a maximum ' + - 'of 21,844 characters. ' + sLineBreak + sLineBreak + - '*Note*: MySQL 5.1 follows the standard SQL specification, and does not ' + - 'remove trailing spaces from VARCHAR values.'; - HasLength: True; - RequiresLength: True; - HasBinary: True; // MySQL-Help says the opposite but it's valid for older versions at least. - HasDefault: True; - LoadPart: True; - DefLengthSet: '50'; - Category: dtcText; - ), - ( - Index: dtTinytext; - NativeType: mytTinyblob; - Name: 'TINYTEXT'; - Description: 'TINYTEXT' + sLineBreak + - 'A TEXT column with a maximum length of 255 (2^8 - 1) characters. The ' + - 'effective maximum length is less if the value contains multi-byte ' + - 'characters. Each TINYTEXT value is stored using a one-byte length ' + - 'prefix that indicates the number of bytes in the value.'; - HasLength: False; - RequiresLength: False; - HasBinary: True; - HasDefault: False; - LoadPart: False; - Category: dtcText; - ), - ( - Index: dtText; - NativeType: mytBlob; - Name: 'TEXT'; - Description: 'TEXT[(M)]' + sLineBreak + - 'A TEXT column with a maximum length of 65,535 (2^16 - 1) characters. The ' + - 'effective maximum length is less if the value contains multi-byte ' + - 'characters. Each TEXT value is stored using a two-byte length prefix ' + - 'that indicates the number of bytes in the value. ' + sLineBreak + - 'An optional length M can be given for this type. If this is done, MySQL ' + - 'creates the column as the smallest TEXT type large enough to hold ' + - 'values M characters long.'; - HasLength: True; - RequiresLength: False; - MaxTextLen: '65535'; - HasBinary: True; - HasDefault: False; - LoadPart: True; - Category: dtcText; - ), - ( - Index: dtMediumtext; - NativeType: mytMediumblob; - Name: 'MEDIUMTEXT'; - Description: 'MEDIUMTEXT' + sLineBreak + - 'A TEXT column with a maximum length of 16,777,215 (2^24 - 1) characters. ' + - 'The effective maximum length is less if the value contains multi-byte ' + - 'characters. Each MEDIUMTEXT value is stored using a three-byte length ' + - 'prefix that indicates the number of bytes in the value.'; - HasLength: False; - RequiresLength: False; - HasBinary: True; - HasDefault: False; - LoadPart: True; - Category: dtcText; - ), - ( - Index: dtLongtext; - NativeType: mytLongblob; - Name: 'LONGTEXT'; - Description: 'LONGTEXT' + sLineBreak + - 'A TEXT column with a maximum length of 4,294,967,295 or 4GB (2^32 - 1) ' + - 'characters. The effective maximum length is less if the value contains ' + - 'multi-byte characters. The effective maximum length of LONGTEXT columns ' + - 'also depends on the configured maximum packet size in the client/server ' + - 'protocol and available memory. Each LONGTEXT value is stored using a ' + - 'four-byte length prefix that indicates the number of bytes in the ' + - 'value.'; - HasLength: False; - RequiresLength: False; - HasBinary: True; - HasDefault: False; - LoadPart: True; - Category: dtcText; - ), - ( - Index: dtJson; - NativeType: mytJson; - Name: 'JSON'; - Description: 'JSON' + sLineBreak + - 'Documents stored in JSON columns are converted to an internal format that '+ - 'permits quick read access to document elements. When the server later must '+ - 'read a JSON value stored in this binary format, the value need not be parsed '+ - 'from a text representation. The binary format is structured to enable the '+ - 'server to look up subobjects or nested values directly by key or array index '+ - 'without reading all values before or after them in the document.'; - HasLength: False; - RequiresLength: False; - HasBinary: False; - HasDefault: False; - LoadPart: False; - Category: dtcText; - ), - ( - Index: dtBinary; - NativeType: mytString; - Name: 'BINARY'; - Description: 'BINARY(M)' + sLineBreak + - 'The BINARY type is similar to the CHAR type, but stores binary byte ' + - 'strings rather than non-binary character strings. M represents the ' + - 'column length in bytes.'; - HasLength: True; - RequiresLength: True; - HasBinary: False; - HasDefault: True; - LoadPart: False; - DefLengthSet: '50'; - Category: dtcBinary; - ), - ( - Index: dtVarbinary; - NativeType: mytVarstring; - Name: 'VARBINARY'; - Description: 'VARBINARY(M)' + sLineBreak + - 'The VARBINARY type is similar to the VARCHAR type, but stores binary ' + - 'byte strings rather than non-binary character strings. M represents the ' + - 'maximum column length in bytes.'; - HasLength: True; - RequiresLength: True; - HasBinary: False; - HasDefault: True; - LoadPart: True; - DefLengthSet: '50'; - Category: dtcBinary; - ), - ( - Index: dtTinyblob; - NativeType: mytTinyblob; - Name: 'TINYBLOB'; - Description: 'TINYBLOB' + sLineBreak + - 'A BLOB column with a maximum length of 255 (2^8 - 1) bytes. Each ' + - 'TINYBLOB value is stored using a one-byte length prefix that indicates ' + - 'the number of bytes in the value.'; - HasLength: False; - RequiresLength: False; - HasBinary: False; - HasDefault: False; - LoadPart: False; - Category: dtcBinary; - ), - ( - Index: dtBlob; - NativeType: mytBlob; - Name: 'BLOB'; - Description: 'BLOB[(M)]' + sLineBreak + - 'A BLOB column with a maximum length of 65,535 (2^16 - 1) bytes. Each ' + - 'BLOB value is stored using a two-byte length prefix that indicates the ' + - 'number of bytes in the value. ' + sLineBreak + - 'An optional length M can be given for this type. If this is done, MySQL ' + - 'creates the column as the smallest BLOB type large enough to hold ' + - 'values M bytes long.'; - HasLength: True; - RequiresLength: False; - MaxTextLen: '65535'; - HasBinary: False; - HasDefault: False; - LoadPart: True; - Category: dtcBinary; - ), - ( - Index: dtMediumblob; - NativeType: mytMediumblob; - Name: 'MEDIUMBLOB'; - Description: 'MEDIUMBLOB' + sLineBreak + - 'A BLOB column with a maximum length of 16,777,215 (2^24 - 1) bytes. Each ' + - 'MEDIUMBLOB value is stored using a three-byte length prefix that ' + - 'indicates the number of bytes in the value.'; - HasLength: False; - RequiresLength: False; - HasBinary: False; - HasDefault: False; - LoadPart: True; - Category: dtcBinary; - ), - ( - Index: dtLongblob; - NativeType: mytLongblob; - Name: 'LONGBLOB'; - Description: 'LONGBLOB' + sLineBreak + - 'A BLOB column with a maximum length of 4,294,967,295 or 4GB (2^32 - 1) ' + - 'bytes. The effective maximum length of LONGBLOB columns depends on the ' + - 'configured maximum packet size in the client/server protocol and ' + - 'available memory. Each LONGBLOB value is stored using a four-byte ' + - 'length prefix that indicates the number of bytes in the value.'; - HasLength: False; - RequiresLength: False; - HasBinary: False; - HasDefault: False; - LoadPart: True; - Category: dtcBinary; - ), - ( - Index: dtEnum; - NativeType: mytEnum; - Name: 'ENUM'; - Description: 'ENUM(''value1'',''value2'',...)' + sLineBreak + - 'An enumeration. A string object that can have only one value, chosen ' + - 'from the list of values ''value1'', ''value2'', ..., NULL or the special '''' ' + - 'error value. An ENUM column can have a maximum of 65,535 distinct ' + - 'values. ENUM values are represented internally as integers.'; - HasLength: True; // Obviously this is not meant as "length", but as "set of values" - RequiresLength: True; - HasBinary: False; - HasDefault: True; - LoadPart: False; - DefLengthSet: '''Y'',''N'''; - Category: dtcOther; - ), - ( - Index: dtSet; - NativeType: mytSet; - Name: 'SET'; - Description: 'SET(''value1'',''value2'',...)' + sLineBreak + - 'A set. A string object that can have zero or more values, each of which ' + - 'must be chosen from the list of values ''value1'', ''value2'', ... A SET ' + - 'column can have a maximum of 64 members. SET values are represented ' + - 'internally as integers.'; - HasLength: True; // Same as for ENUM - RequiresLength: True; - HasBinary: False; - HasDefault: True; - LoadPart: False; - DefLengthSet: '''Value A'',''Value B'''; - Category: dtcOther; - ), - ( - Index: dtBit; - NativeType: mytBit; - Name: 'BIT'; - Description: 'BIT[(M)]' + sLineBreak + - 'A bit-field type. M indicates the number of bits per value, from 1 to ' + - '64. The default is 1 if M is omitted.'; - HasLength: True; - RequiresLength: False; - HasBinary: False; - HasDefault: True; - LoadPart: False; - Category: dtcInteger; - ), - ( - Index: dtPoint; - NativeType: mytGeometry; - Name: 'POINT'; - Description: 'POINT(x,y)' + sLineBreak + - 'Constructs a WKB Point using its coordinates.'; - HasLength: False; - RequiresLength: False; - HasBinary: False; - HasDefault: False; - LoadPart: False; - Category: dtcSpatial; - ), - ( - Index: dtLinestring; - NativeType: mytGeometry; - Name: 'LINESTRING'; - Description: 'LINESTRING(pt1,pt2,...)' + sLineBreak + - 'Constructs a WKB LineString value from a number of WKB Point arguments. ' + - 'If any argument is not a WKB Point, the return value is NULL. If the ' + - 'number of Point arguments is less than two, the return value is NULL.'; - HasLength: False; - RequiresLength: False; - HasBinary: False; - HasDefault: False; - LoadPart: False; - Category: dtcSpatial; - ), - ( - Index: dtPolygon; - NativeType: mytGeometry; - Name: 'POLYGON'; - Description: 'POLYGON(ls1,ls2,...)' + sLineBreak + - 'Constructs a WKB Polygon value from a number of WKB LineString ' + - 'arguments. If any argument does not represent the WKB of a LinearRing ' + - '(that is, not a closed and simple LineString) the return value is NULL.'; - HasLength: False; - RequiresLength: False; - HasBinary: False; - HasDefault: False; - LoadPart: False; - Category: dtcSpatial; - ), - ( - Index: dtGeometry; - NativeType: mytGeometry; - Name: 'GEOMETRY'; - Description: ''; - HasLength: False; - RequiresLength: False; - HasBinary: False; - HasDefault: False; - LoadPart: False; - Category: dtcSpatial; - ), - ( - Index: dtMultipoint; - NativeType: mytGeometry; - Name: 'MULTIPOINT'; - Description: 'MULTIPOINT(pt1,pt2,...)' + sLineBreak + - 'Constructs a WKB MultiPoint value using WKB Point arguments. If any ' + - 'argument is not a WKB Point, the return value is NULL.'; - HasLength: False; - RequiresLength: False; - HasBinary: False; - HasDefault: False; - LoadPart: False; - Category: dtcSpatial; - ), - ( - Index: dtMultilinestring; - NativeType: mytGeometry; - Name: 'MULTILINESTRING'; - Description: 'MULTILINESTRING(ls1,ls2,...)' + sLineBreak + - 'Constructs a WKB MultiLineString value using WKB LineString arguments. ' + - 'If any argument is not a WKB LineString, the return value is NULL.'; - HasLength: False; - RequiresLength: False; - HasBinary: False; - HasDefault: False; - LoadPart: False; - Category: dtcSpatial; - ), - ( - Index: dtMultipolygon; - NativeType: mytGeometry; - Name: 'MULTIPOLYGON'; - Description: 'MULTIPOLYGON(poly1,poly2,...)' + sLineBreak + - 'Constructs a WKB MultiPolygon value from a set of WKB Polygon ' + - 'arguments. If any argument is not a WKB Polygon, the return value is ' + - 'NULL.'; - HasLength: False; - RequiresLength: False; - HasBinary: False; - HasDefault: False; - LoadPart: False; - Category: dtcSpatial; - ), - ( - Index: dtGeometrycollection; - NativeType: mytGeometry; - Name: 'GEOMETRYCOLLECTION'; - Description: 'GEOMETRYCOLLECTION(g1,g2,...)' + sLineBreak + - 'Constructs a WKB GeometryCollection. If any argument is not a ' + - 'well-formed WKB representation of a geometry, the return value is NULL.'; - HasLength: False; - RequiresLength: False; - HasBinary: False; - HasDefault: False; - LoadPart: False; - Category: dtcSpatial; - ) - ); - MSSQLDatatypes: array [0..33] of TDBDatatype = - ( - ( - Index: dtUnknown; - NativeTypes: '99999'; - Name: 'UNKNOWN'; - Description: 'Unknown data type'; - HasLength: False; - RequiresLength: False; - HasBinary: False; - HasDefault: False; - LoadPart: False; - Category: dtcOther; - ), - ( - Index: dtTinyint; - Name: 'TINYINT'; - Description: 'Integer data from 0 through 255.'; - HasLength: False; - RequiresLength: False; - HasBinary: False; - HasDefault: True; - LoadPart: False; - Category: dtcInteger; - ), - ( - Index: dtSmallint; - Name: 'SMALLINT'; - Description: 'Integer data from -2^15 (-32,768) through 2^15 - 1 (32,767).'; - HasLength: False; - RequiresLength: False; - HasBinary: False; - HasDefault: True; - LoadPart: False; - Category: dtcInteger; - ), - ( - Index: dtInt; - Name: 'INT'; - Description: 'Integer (whole number) data from -2^31 (-2,147,483,648) through 2^31 - 1 (2,147,483,647).'; - HasLength: False; - RequiresLength: False; - HasBinary: False; - HasDefault: True; - LoadPart: False; - Category: dtcInteger; - ), - ( - Index: dtBigint; - Name: 'BIGINT'; - Description: 'Integer (whole number) data from -2^63 (-9,223,372,036,854,775,808) through 2^63-1 (9,223,372,036,854,775,807).'; - HasLength: False; - RequiresLength: False; - HasBinary: False; - HasDefault: True; - LoadPart: False; - Category: dtcInteger; - ), - ( - Index: dtBit; - Name: 'BIT'; - Description: '0 or 1'; - HasLength: False; - RequiresLength: False; - HasBinary: False; - HasDefault: True; - LoadPart: False; - Category: dtcInteger; - ), - ( - Index: dtDecimal; - Name: 'DECIMAL'; - Description: 'Fixed precision and scale numeric data from -10^38 +1 through 10^38 –1.'; - HasLength: True; - RequiresLength: True; - HasBinary: False; - HasDefault: True; - LoadPart: False; - DefLengthSet: '10,0'; - Category: dtcReal; - ), - ( - Index: dtNumeric; - Name: 'NUMERIC'; - Description: 'Functionally equivalent to decimal.'; - HasLength: True; - RequiresLength: True; - HasBinary: False; - HasDefault: True; - LoadPart: False; - DefLengthSet: '10,0'; - Category: dtcReal; - ), - ( - Index: dtMoney; - Name: 'MONEY'; - Description: 'Monetary data values from -2^63 (-922,337,203,685,477.5808) through 2^63 - 1 (+922,337,203,685,477.5807), with accuracy to a ten-thousandth of a monetary unit.'; - HasLength: True; - RequiresLength: False; - HasBinary: False; - HasDefault: True; - LoadPart: False; - Category: dtcReal; - ), - ( - Index: dtSmallmoney; - Name: 'SMALLMONEY'; - Description: 'Monetary data values from -214,748.3648 through +214,748.3647, with accuracy to a ten-thousandth of a monetary unit.'; - HasLength: True; - RequiresLength: False; - HasBinary: False; - HasDefault: True; - LoadPart: False; - Category: dtcReal; - ), - ( - Index: dtFloat; - Name: 'FLOAT'; - Description: 'Floating precision number data with the following valid values: -1.79E + 308 through -2.23E - 308, 0 and 2.23E + 308 through 1.79E + 308.'; - HasLength: True; - RequiresLength: False; - HasBinary: False; - HasDefault: True; - LoadPart: False; - Category: dtcReal; - ), - ( - Index: dtReal; - Name: 'REAL'; - Description: 'Floating precision number data with the following valid values: -3.40E + 38 through -1.18E - 38, 0 and 1.18E - 38 through 3.40E + 38.'; - HasLength: True; - RequiresLength: False; - HasBinary: False; - HasDefault: True; - LoadPart: False; - Category: dtcReal; - ), - ( - Index: dtTime; - Name: 'TIME'; - Description: 'The time data type stores time values only, based on a 24-hour clock. '+ - 'The time data type has a range of 00:00:00.0000000 through 23:59:59.9999999 with an '+ - 'accuracy of 100 nanoseconds. The default value is 00:00:00.0000000 (midnight). The '+ - 'time data type supports user-defined fractional second precision, and the storage '+ - 'size varies from 3 to 6 bytes, based on the precision specified.'; - HasLength: False; - RequiresLength: False; - HasBinary: False; - HasDefault: True; - LoadPart: False; - Format: 'hh:nn:ss'; - Category: dtcTemporal; - ), - ( - Index: dtDate; - Name: 'DATE'; - Description: 'The date data type has a range of January 1, 01 through December 31, '+ - '9999 with an accuracy of 1 day. The default value is January 1, 1900. The storage size '+ - 'is 3 bytes.'; - HasLength: False; - RequiresLength: False; - HasBinary: False; - HasDefault: True; - LoadPart: False; - Format: 'yyyy-mm-dd'; - Category: dtcTemporal; - ), - ( - Index: dtDatetime; - Name: 'DATETIME'; - Description: 'Date and time data from January 1, 1753, through December 31, 9999, with an accuracy of three-hundredths of a second, or 3.33 milliseconds.'; - HasLength: False; - RequiresLength: False; - HasBinary: False; - HasDefault: True; - LoadPart: False; - Format: 'yyyy-mm-dd hh:nn:ss.zzz'; - Category: dtcTemporal; - ), - ( - Index: dtDatetime2; - Name: 'DATETIME2'; - Description: 'Date and time data from January 1,1 AD through December 31, 9999 AD, with an accuracy of three-hundredths of a second, or 3.33 milliseconds.'; - HasLength: True; - RequiresLength: False; - HasBinary: False; - HasDefault: True; - LoadPart: False; - Format: 'yyyy-mm-dd hh:nn:ss.zzzzzzz'; - Category: dtcTemporal; - ), - ( - Index: dtDatetimeOffset; - Name: 'DATETIMEOFFSET'; - Description: 'Defines a date that is combined with a time of a day that has time zone awareness and is based on a 24-hour clock.'; - HasLength: False; - RequiresLength: False; - HasBinary: False; - HasDefault: True; - LoadPart: False; - Format: 'yyyy-mm-dd hh:nn:ss.zzzzzzz'; - Category: dtcTemporal; - ), - ( - Index: dtSmalldatetime; - Name: 'SMALLDATETIME'; - Description: 'Date and time data from January 1, 1900, through June 6, 2079, with an accuracy of one minute.'; - HasLength: False; - RequiresLength: False; - HasBinary: False; - HasDefault: True; - LoadPart: False; - Format: 'yyyy-mm-dd hh:nn:ss'; - Category: dtcTemporal; - ), - ( - Index: dtTimestamp; - Name: 'TIMESTAMP'; - Description: 'A database-wide unique number that gets updated every time a row gets updated.'; - HasLength: False; - RequiresLength: False; - HasBinary: False; - HasDefault: False; - LoadPart: False; - Category: dtcInteger; - ), - ( - Index: dtChar; - Name: 'CHAR'; - Description: 'Fixed-length non-Unicode character data with a maximum length of 8,000 characters.'; - HasLength: True; - RequiresLength: True; - HasBinary: False; - HasDefault: True; - LoadPart: True; - DefLengthSet: '50'; - Category: dtcText; - ), - ( - Index: dtVarchar; - Name: 'VARCHAR'; - Description: 'Variable-length non-Unicode data with a maximum of 8,000 characters.'; - HasLength: True; - RequiresLength: True; - HasBinary: False; - HasDefault: True; - LoadPart: True; - DefLengthSet: '50'; - Category: dtcText; - ), - ( - Index: dtText; - Name: 'TEXT'; - Description: 'Variable-length non-Unicode data with a maximum length of 2^31 - 1 (2,147,483,647) characters.'; - HasLength: False; - RequiresLength: False; - HasBinary: False; - HasDefault: False; - LoadPart: True; - Category: dtcText; - ), - ( - Index: dtNchar; - Name: 'NCHAR'; - Description: 'Fixed-length Unicode data with a maximum length of 4,000 characters.'; - HasLength: True; - RequiresLength: True; - HasBinary: False; - HasDefault: True; - LoadPart: True; - DefLengthSet: '50'; - Category: dtcText; - ), - ( - Index: dtNvarchar; - Name: 'NVARCHAR'; - Description: 'Variable-length Unicode data with a maximum length of 4,000 characters. sysname is a system-supplied user-defined data type that is functionally equivalent to nvarchar(128) and is used to reference database object names.'; - HasLength: True; - RequiresLength: True; - HasBinary: False; - HasDefault: True; - LoadPart: True; - DefLengthSet: '50'; - Category: dtcText; - ), - ( - Index: dtNtext; - Name: 'NTEXT'; - Description: 'Variable-length Unicode data with a maximum length of 2^30 - 1 (1,073,741,823) characters.'; - HasLength: False; - RequiresLength: False; - HasBinary: False; - HasDefault: False; - LoadPart: True; - Category: dtcText; - ), - ( - Index: dtBinary; - Name: 'BINARY'; - Description: 'Fixed-length binary data with a maximum length of 8,000 bytes.'; - HasLength: False; - RequiresLength: False; - HasBinary: False; - HasDefault: False; - LoadPart: True; - Category: dtcBinary; - ), - ( - Index: dtVarbinary; - Name: 'VARBINARY'; - Description: 'Variable-length binary data with a maximum length of 8,000 bytes.'; - HasLength: False; - RequiresLength: False; - HasBinary: False; - HasDefault: False; - LoadPart: True; - Category: dtcBinary; - ), - ( - Index: dtImage; - Name: 'IMAGE'; - Description: 'Variable-length binary data with a maximum length of 2^31 - 1 (2,147,483,647) bytes.'; - HasLength: False; - RequiresLength: False; - HasBinary: False; - HasDefault: False; - LoadPart: False; - Category: dtcBinary; - ), - ( - Index: dtCursor; - Name: 'CURSOR'; - Description: 'A reference to a cursor.'; - HasLength: False; - RequiresLength: False; - HasBinary: False; - HasDefault: False; - LoadPart: False; - Category: dtcOther; - ), - ( - Index: dtSqlvariant; - Name: 'SQL_VARIANT'; - Description: 'A data type that stores values of various SQL Server-supported data types, except text, ntext, timestamp, and sql_variant.'; - HasLength: False; - RequiresLength: False; - HasBinary: False; - HasDefault: False; - LoadPart: False; - Category: dtcOther; - ), - ( - Index: dtTable; - Name: 'TABLE'; - Description: 'A special data type used to store a result set for later processing .'; - HasLength: False; - RequiresLength: False; - HasBinary: False; - HasDefault: False; - LoadPart: False; - Category: dtcOther; - ), - ( - Index: dtUniqueidentifier; - Name: 'UNIQUEIDENTIFIER'; - Description: 'A globally unique identifier (GUID).'; - HasLength: False; - RequiresLength: False; - HasBinary: False; - HasDefault: False; - LoadPart: False; - Category: dtcOther; - ), - ( - Index: dtHierarchyid; - Name: 'HIERARCHYID'; - Description: 'Represents a position in a hierarchy.'; - HasLength: False; - RequiresLength: False; - HasBinary: False; - HasDefault: False; - LoadPart: False; - Category: dtcOther; - ), - ( - Index: dtXML; - Name: 'XML'; - Description: 'Lets you store XML documents and fragments.'; - HasLength: False; - RequiresLength: False; - HasBinary: False; - HasDefault: False; - LoadPart: False; - Category: dtcOther; - ) - ); +implementation - PostgreSQLDatatypes: Array[0..35] of TDBDatatype = - ( - ( - Index: dtUnknown; - NativeTypes: '99999'; - Name: 'UNKNOWN'; - Description: 'Unknown data type'; - HasLength: False; - RequiresLength: False; - HasBinary: False; - HasDefault: False; - LoadPart: False; - Category: dtcOther; - ), - ( - Index: dtSmallint; - NativeTypes: '21'; - Name: 'SMALLINT'; - Names: 'smallint|int2'; - Description: 'Small-range integer. Range: -32768 to +32767. Storage Size: 2 Bytes.'; - HasLength: False; - RequiresLength: False; - HasBinary: False; - HasDefault: False; - LoadPart: False; - ValueMustMatch: '^\d{1,5}$'; - Category: dtcInteger; - ), - ( - Index: dtInt; - // 26 = oid, 28 = xid - NativeTypes: '23|26|28'; - Name: 'INTEGER'; - Names: 'integer|int4|int|oid|xid'; - Description: 'Typical choice for integer. Range: -2147483648 to +2147483647. Storage Size: 4 Bytes.'; - HasLength: False; - RequiresLength: False; - HasBinary: False; - HasDefault: False; - LoadPart: False; - ValueMustMatch: '^\d{1,10}$'; - Category: dtcInteger; - ), - ( - Index: dtBigint; - NativeTypes: '20'; - Name: 'BIGINT'; - Names: 'bigint|int8'; - Description: 'Large-range integer. Range: -9223372036854775808 to 9223372036854775807. Storage Size: 8 Bytes.'; - HasLength: False; - RequiresLength: False; - HasBinary: False; - HasDefault: False; - LoadPart: False; - ValueMustMatch: '^\d{1,19}$'; - Category: dtcInteger; - ), - ( - Index: dtSerial; - Name: 'SERIAL'; - Names: 'serial|serial4'; - Description: 'Autoincrementing integer. Range: 1 to 2147483647. Storage Size: 4 Bytes.'; - HasLength: False; - RequiresLength: False; - HasBinary: False; - HasDefault: False; - LoadPart: False; - Category: dtcInteger; - ), - ( - Index: dtBigSerial; - Name: 'BIGSERIAL'; - Names: 'bigserial|serial8'; - Description: 'Large autoincrementing integer. Range: 1 to 9223372036854775807. Storage Size: 8 Bytes.'; - HasLength: False; - RequiresLength: False; - HasBinary: False; - HasDefault: False; - LoadPart: False; - Category: dtcInteger; - ), - ( - Index: dtVarBit; - NativeTypes: '1562'; - Name: 'BIT VARYING'; - Names: 'bit varying|varbit'; - Description: 'Variable-length bit string.'; - HasLength: True; - RequiresLength: False; - HasBinary: False; - HasDefault: True; - LoadPart: False; - Category: dtcInteger; - ), - ( - Index: dtBit; - NativeTypes: '1560'; - Name: 'BIT'; - Names: 'bit'; - Description: 'Fixed-length bit string.'; - HasLength: True; - RequiresLength: False; - HasBinary: False; - HasDefault: True; - LoadPart: False; - Category: dtcInteger; - ), - ( - Index: dtNumeric; - NativeTypes: '1700'; - Name: 'NUMERIC'; - Names: 'numeric|float8|decimal'; - Description: 'User-specified precision, exact. Range: no limit. Storage Size: variable.'; - HasLength: True; - RequiresLength: False; - HasBinary: False; - HasDefault: False; - LoadPart: False; - Category: dtcReal; - ), - ( - Index: dtReal; - NativeTypes: '700'; - Name: 'REAL'; - Names: 'real|float4'; - Description: 'Variable-precision, inexact. Range: 6 decimal digits precision. Storage Size: 4 Bytes.'; - HasLength: True; - RequiresLength: False; - HasBinary: False; - HasDefault: False; - LoadPart: False; - Category: dtcReal; - ), - ( - Index: dtDoublePrecision; - NativeTypes: '701|1700'; - Name: 'DOUBLE PRECISION'; - Names: 'double precision|float8'; - Description: 'Variable-precision, inexact. Range: 15 decimal digits precision. Storage Size: 8 Bytes.'; - HasLength: True; - RequiresLength: False; - HasBinary: False; - HasDefault: False; - LoadPart: False; - Category: dtcReal; - ), - ( - Index: dtMoney; - NativeTypes: '790'; - Name: 'MONEY'; - Description: 'Currency amount. Range: -92233720368547758.08 to +92233720368547758.07. Storage Size: 8 Bytes.'; - HasLength: True; - RequiresLength: False; - HasBinary: False; - HasDefault: False; - LoadPart: False; - Category: dtcReal; - ), - ( - Index: dtChar; - NativeTypes: '18|1042'; - Name: 'CHAR'; - Names: 'CHARACTER'; - Description: 'Fixed-length, blank padded.'; - HasLength: True; - RequiresLength: False; - HasBinary: False; - HasDefault: False; - LoadPart: True; - Category: dtcText; - ), - ( - Index: dtVarchar; - NativeTypes: '18|19|24|1043|1043'; - Name: 'VARCHAR'; - Names: 'char|bpchar|varchar|name|enum|regproc|character varying'; - Description: 'Variable-length with limit.'; - HasLength: True; - RequiresLength: False; - HasBinary: False; - HasDefault: False; - LoadPart: True; - Category: dtcText; - ), - ( - Index: dtText; - NativeTypes: '25|22|30|143|629|651|719|791|1000|1028|1040|1041|1115|1182|1183|1185|1187|1231|1263|1270|1561|1563|2201|2207|2211|2949|2951|3643|3644|3645|3735|3770'; - Name: 'TEXT'; - Names: 'text|int2vector|oidvector|bool'; - Description: 'Variable unlimited length.'; - HasLength: False; - RequiresLength: False; - HasBinary: False; - HasDefault: False; - LoadPart: True; - Category: dtcText; - ), - ( - Index: dtCidr; - NativeTypes: '650'; - Name: 'CIDR'; - Names: 'cidr'; - Description: 'IPv4 and IPv6 networks. Storage size: 7 or 19 bytes'; - HasLength: False; - RequiresLength: False; - HasBinary: False; - HasDefault: False; - LoadPart: False; - Category: dtcText; - ), - ( - Index: dtInet; - NativeTypes: '869'; - Name: 'INET'; - Names: 'inet'; - Description: 'IPv4 and IPv6 hosts and networks. Storage size: 7 or 19 bytes'; - HasLength: False; - RequiresLength: False; - HasBinary: False; - HasDefault: False; - LoadPart: False; - Category: dtcText; - ), - ( - Index: dtMacaddr; - NativeTypes: '829'; - Name: 'MACADDR'; - Names: 'macaddr'; - Description: 'MAC addresses. Storage size: 6 bytes'; - HasLength: False; - RequiresLength: False; - HasBinary: False; - HasDefault: False; - LoadPart: False; - Category: dtcText; - ), - ( - Index: dtDate; - NativeTypes: '1082'; - Name: 'DATE'; - Description: 'Calendar date (year, month, day).'; - HasLength: False; - RequiresLength: False; - HasBinary: False; - HasDefault: False; - LoadPart: False; - Format: 'yyyy-mm-dd'; - Category: dtcTemporal; - ), - ( - Index: dtTime; - NativeTypes: '1083'; - Name: 'TIME'; - Description: 'Time of day.'; - HasLength: False; - RequiresLength: False; - HasBinary: False; - HasDefault: False; - LoadPart: False; - Format: 'hh:nn:ss'; - Category: dtcTemporal; - ), - ( - Index: dtDatetime; - NativeTypes: '1082|1114|702'; - Name: 'TIMESTAMP'; - Names: 'timestamp|datetime|abstime|timestamp without time zone'; - Description: 'Date and time without timezone, e.g. "2020-06-27 16:24:41".'; - HasLength: False; - RequiresLength: False; - HasBinary: False; - HasDefault: False; - LoadPart: False; - Format: 'yyyy-mm-dd hh:nn:ss'; - Category: dtcTemporal; - ), - ( - Index: dtDatetime2; - NativeTypes: '1184'; - Name: 'TIMESTAMPTZ'; - Names: 'timestamptz|timestamp with time zone'; - Description: 'Date and time with time zone, e.g. "2020-06-27 16:24:41+02".'; - HasLength: False; - RequiresLength: False; - HasBinary: False; - HasDefault: False; - LoadPart: False; - Format: 'yyyy-mm-dd hh:nn:ss'; - Category: dtcTemporal; - ), - ( - Index: dtDate; - NativeTypes: '1082'; - Name: 'DATE'; - Description: 'Calendar date (year, month, day).'; - HasLength: False; - RequiresLength: False; - HasBinary: False; - HasDefault: False; - LoadPart: False; - Format: 'yyyy-mm-dd'; - Category: dtcTemporal; - ), - ( - Index: dtInterval; - NativeTypes: '1186'; - Name: 'INTERVAL'; - Description: 'time interval from -178000000 years to 178000000 years'; - HasLength: False; - RequiresLength: False; - HasBinary: False; - HasDefault: False; - LoadPart: False; - Format: 'yyyy-mm-dd hh:nn:ss'; - Category: dtcTemporal; - ), - ( - Index: dtBlob; - NativeTypes: '17'; - Name: 'BYTEA'; - Description: 'Binary data ("byte array").'; - HasLength: False; - RequiresLength: False; - HasBinary: False; - HasDefault: False; - LoadPart: True; - Category: dtcBinary; - ), - ( - Index: dtPoint; - NativeTypes: '600'; - Name: 'POINT'; - Description: 'Point on a plane (x,y). Storage size: 16 bytes.'; - HasLength: True; - RequiresLength: False; - HasBinary: False; - HasDefault: False; - LoadPart: False; - Category: dtcSpatial; - ), - ( - Index: dtLinestring; - NativeTypes: '628'; - Name: 'LINE'; - Description: 'Infinite line ((x1,y1),(x2,y2)). Storage size: 32 bytes.'; - HasLength: True; - RequiresLength: False; - HasBinary: False; - HasDefault: False; - LoadPart: False; - Category: dtcSpatial; - ), - ( - Index: dtLineSegment; - NativeTypes: '601'; - Name: 'LSEG'; - Description: 'Finite line segment ((x1,y1),(x2,y2)). Storage size: 32 bytes.'; - HasLength: True; - RequiresLength: False; - HasBinary: False; - HasDefault: False; - LoadPart: False; - Category: dtcSpatial; - ), - ( - Index: dtBox; - NativeTypes: '603'; - Name: 'BOX'; - Description: 'Rectangular box ((x1,y1),(x2,y2)). Storage size: 32 bytes.'; - HasLength: True; - RequiresLength: False; - HasBinary: False; - HasDefault: False; - LoadPart: False; - Category: dtcSpatial; - ), - ( - Index: dtPath; - NativeTypes: '602'; - Name: 'PATH'; - Description: 'Closed path (similar to polygon) ((x1,y1),...). Storage size: 16+16n bytes.'; - HasLength: True; - RequiresLength: False; - HasBinary: False; - HasDefault: False; - LoadPart: False; - Category: dtcSpatial; - ), - ( - Index: dtPolygon; - NativeTypes: '604'; - Name: 'POLYGON'; - Description: 'Closed path (similar to polygon) ((x1,y1),...). Storage size: 40+16n bytes.'; - HasLength: True; - RequiresLength: False; - HasBinary: False; - HasDefault: False; - LoadPart: False; - Category: dtcSpatial; - ), - ( - Index: dtCircle; - NativeTypes: '718'; - Name: 'CIRCLE'; - Description: 'Circle <(x,y),r> (center point and radius). Storage size: 24 bytes.'; - HasLength: True; - RequiresLength: False; - HasBinary: False; - HasDefault: False; - LoadPart: False; - Category: dtcSpatial; - ), - ( - Index: dtBool; - NativeTypes: '16'; - Name: 'BOOLEAN'; - Names: 'boolean|bool'; - Description: 'State of true or false. Storage size: 1 byte.'; - HasLength: False; - RequiresLength: False; - HasBinary: False; - HasDefault: False; - LoadPart: False; - ValueMustMatch: '^(true|false)$'; - Category: dtcOther; - ), - ( - Index: dtRegClass; - NativeTypes: '2205'; - Name: 'REGCLASS'; - Names: 'regclass'; - Description: 'Relation name'; - HasLength: False; - RequiresLength: False; - HasBinary: False; - HasDefault: False; - LoadPart: False; - Category: dtcOther; - ), - ( - Index: dtJson; - NativeTypes: '114'; - Name: 'JSON'; - Names: 'json'; - Description: 'JavaScript Object Notation data'; - HasLength: False; - RequiresLength: False; - HasBinary: False; - HasDefault: False; - LoadPart: False; - Category: dtcText; - ), - ( - Index: dtUniqueidentifier; - NativeTypes: '2950'; - Name: 'UUID'; - Names: 'uuid'; - Description: 'The data type uuid stores Universally Unique Identifiers (UUID) as defined by RFC 4122, ISO/IEC 9834-8:2005, and related standards.'; - HasLength: False; - RequiresLength: False; - HasBinary: False; - HasDefault: False; - LoadPart: False; - ValueMustMatch: '^\{?[a-f0-9]{8}-?[a-f0-9]{4}-?[a-f0-9]{4}-?[a-f0-9]{4}-?[a-f0-9]{12}\}?$'; - Category: dtcText; - ) - ); - - SQLiteDatatypes: Array[0..14] of TDBDatatype = - ( - ( - Index: dtUnknown; - Name: 'UNKNOWN'; - Description: 'Unknown data type'; - HasLength: False; - RequiresLength: False; - HasBinary: False; - HasDefault: False; - LoadPart: False; - Category: dtcOther; - ), - ( - Index: dtTinyint; - Name: 'TINYINT'; - Names: 'INT2|BOOLEAN|BOOL'; - HasLength: False; - RequiresLength: False; - HasBinary: False; - HasDefault: False; - LoadPart: False; - Category: dtcInteger; - ), - ( - Index: dtInt; - Name: 'INTEGER'; - Names: 'INT|MEDIUMINT|INT8'; - HasLength: False; - RequiresLength: False; - HasBinary: False; - HasDefault: True; - LoadPart: False; - Category: dtcInteger; - ), - ( - Index: dtBigint; - Name: 'BIGINT'; - Names: 'UNSIGNED BIG INT'; - HasLength: False; - RequiresLength: False; - HasBinary: False; - HasDefault: True; - LoadPart: False; - Category: dtcInteger; - ), - ( - Index: dtChar; - Name: 'CHAR'; - Names: 'CHARACTER|CHAR|NCHAR|NATIVE CHARACTER'; - HasLength: True; - RequiresLength: True; - HasBinary: False; - HasDefault: True; - LoadPart: True; - DefLengthSet: '50'; - Category: dtcText; - ), - ( - Index: dtVarchar; - Name: 'VARCHAR'; - Names: 'VARCHAR|VARYING CHARACTER|NVARCHAR|CHARACTER|CHAR|NCHAR|NATIVE CHARACTER'; - HasLength: True; - RequiresLength: True; - HasBinary: False; - HasDefault: True; - LoadPart: True; - DefLengthSet: '50'; - Category: dtcText; - ), - ( - Index: dtText; - Name: 'TEXT'; - Names: 'CLOB'; - HasLength: False; - RequiresLength: False; - HasBinary: False; - HasDefault: True; - LoadPart: True; - Category: dtcText; - ), - ( - Index: dtUniqueidentifier; - Name: 'UNIQUEIDENTIFIER'; - HasLength: False; - RequiresLength: False; - HasBinary: False; - HasDefault: True; - LoadPart: False; - Category: dtcBinary; - ), - ( - Index: dtBlob; - Name: 'BLOB'; - HasLength: False; - RequiresLength: False; - HasBinary: False; - HasDefault: False; - LoadPart: True; - Category: dtcBinary; - ), - ( - Index: dtReal; - Name: 'REAL'; - Names: 'REAL|NUMERIC|DOUBLE|DOUBLE PRECISION|FLOAT|DECIMAL'; - HasLength: False; - RequiresLength: False; - HasBinary: False; - HasDefault: True; - LoadPart: False; - Category: dtcReal; - ), - ( - Index: dtDate; - Name: 'DATE'; - HasLength: False; - RequiresLength: False; - HasBinary: False; - HasDefault: True; - LoadPart: False; - Category: dtcTemporal; - ), - ( - Index: dtTime; - Name: 'TIME'; - HasLength: False; - RequiresLength: False; - HasBinary: False; - HasDefault: True; - LoadPart: False; - Category: dtcTemporal; - ), - ( - Index: dtDatetime; - Name: 'DATETIME'; - HasLength: False; - RequiresLength: False; - HasBinary: False; - HasDefault: True; - LoadPart: False; - Category: dtcTemporal; - ), - ( - Index: dtEnum; - NativeType: mytEnum; - Name: 'ENUM'; - HasLength: True; - RequiresLength: True; - HasBinary: False; - HasDefault: True; - LoadPart: False; - DefLengthSet: '''Y'',''N'''; - Category: dtcOther; - ), - ( - Index: dtSet; - NativeType: mytSet; - Name: 'SET'; - HasLength: True; - RequiresLength: True; - HasBinary: False; - HasDefault: True; - LoadPart: False; - DefLengthSet: '''Value A'',''Value B'''; - Category: dtcOther; - ) - ); - - - MySqlFunctions: Array [0..374] of TMysqlFunction = - ( - ( - Name: 'BIT_COUNT'; - Declaration: '(N)'; - Category: 'Bit Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the number of bits that are set in the argument N.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT BIT_COUNT(29), BIT_COUNT(b''101010'');'+sLineBreak - +'+---------------+----------------------+'+sLineBreak - +'| BIT_COUNT(29) | BIT_COUNT(b''101010'') |'+sLineBreak - +'+---------------+----------------------+'+sLineBreak - +'| 4 | 3 |'+sLineBreak - +'+---------------+----------------------+' - ), - - ( - Name: 'COALESCE'; - Declaration: '(value,...)'; - Category: 'Comparison Operators'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the first non-NULL value in the list, or NULL if'+sLineBreak - +'there are no'+sLineBreak - +'non-NULL values. At least one parameter must be passed.'+sLineBreak - +' '+sLineBreak - +'See also NULL Values in MariaDB.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT COALESCE(NULL,1);'+sLineBreak - +'+------------------+'+sLineBreak - +'| COALESCE(NULL,1) |'+sLineBreak - +'+------------------+'+sLineBreak - +'| 1 |'+sLineBreak - +'+------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT COALESCE(NULL,NULL,NULL);'+sLineBreak - +'+--------------------------+'+sLineBreak - +'| COALESCE(NULL,NULL,NULL) |'+sLineBreak - +'+--------------------------+'+sLineBreak - +'| NULL |'+sLineBreak - +'+--------------------------+'+sLineBreak - +' '+sLineBreak - +'When two arguments are given, COALESCE() is the same as'+sLineBreak - +'IFNULL():'+sLineBreak - +' '+sLineBreak - +'SET @a=NULL, @b=1;'+sLineBreak - +' '+sLineBreak - +'SELECT COALESCE(@a, @b), IFNULL(@a, @b);'+sLineBreak - +'+------------------+----------------+'+sLineBreak - +'| COALESCE(@a, @b) | IFNULL(@a, @b) |'+sLineBreak - +'+------------------+----------------+'+sLineBreak - +'| 1 | 1 |'+sLineBreak - +'+------------------+----------------+'+sLineBreak - +' '+sLineBreak - +'Hex type confusion:'+sLineBreak - +' '+sLineBreak - +'CREATE TABLE t1 (a INT, b VARCHAR(10));'+sLineBreak - +'INSERT INTO t1 VALUES (0x31, 0x61),(COALESCE(0x31),'+sLineBreak - +'COALESCE(0x61));'+sLineBreak - +' '+sLineBreak - +'SELECT * FROM t1;'+sLineBreak - +' '+sLineBreak - +'+------+------+'+sLineBreak - +'| a | b |'+sLineBreak - +'+------+------+'+sLineBreak - +'| 49 | a |'+sLineBreak - +'| 1 | a |'+sLineBreak - +'+------+------+'+sLineBreak - +' '+sLineBreak - +'The reason for the differing results above is that when 0x31'+sLineBreak - +'is inserted directly to the column, it''s treated as a'+sLineBreak - +'number (see Hexadecimal Literals), while when 0x31 is passed'+sLineBreak - +'to COALESCE(), it''s treated as a string, because:'+sLineBreak - +'HEX values have a string data type by default.'+sLineBreak - +'COALESCE() has the same data type as the argument.' - ), - - ( - Name: 'GREATEST'; - Declaration: '(value1,value2,...)'; - Category: 'Comparison Operators'; - Version: SQL_VERSION_ANSI; - Description: 'With two or more arguments, returns the largest'+sLineBreak - +'(maximum-valued)'+sLineBreak - +'argument. The arguments are compared using the same rules as'+sLineBreak - +'for'+sLineBreak - +'LEAST().'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT GREATEST(2,0);'+sLineBreak - +'+---------------+'+sLineBreak - +'| GREATEST(2,0) |'+sLineBreak - +'+---------------+'+sLineBreak - +'| 2 |'+sLineBreak - +'+---------------+'+sLineBreak - +' '+sLineBreak - +'SELECT GREATEST(34.0,3.0,5.0,767.0);'+sLineBreak - +'+------------------------------+'+sLineBreak - +'| GREATEST(34.0,3.0,5.0,767.0) |'+sLineBreak - +'+------------------------------+'+sLineBreak - +'| 767.0 |'+sLineBreak - +'+------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT GREATEST(''B'',''A'',''C'');'+sLineBreak - +'+-----------------------+'+sLineBreak - +'| GREATEST(''B'',''A'',''C'') |'+sLineBreak - +'+-----------------------+'+sLineBreak - +'| C |'+sLineBreak - +'+-----------------------+' - ), - - ( - Name: 'INTERVAL'; - Declaration: '(N,N1,N2,N3,...)'; - Category: 'Comparison Operators'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the index of the last argument that is less than the'+sLineBreak - +'first argument or is NULL. '+sLineBreak - +' '+sLineBreak - +'Returns 0 if N < N1, 1 if N < N2, 2 if N < N3 and so on or'+sLineBreak - +'-1 if N is NULL. All'+sLineBreak - +'arguments are treated as integers. It is required that N1 <'+sLineBreak - +'N2 < N3' - ), - - ( - Name: 'ISNULL'; - Declaration: '(expr)'; - Category: 'Comparison Operators'; - Version: SQL_VERSION_ANSI; - Description: 'If expr is NULL, ISNULL() returns 1, otherwise it returns 0.'+sLineBreak - +' '+sLineBreak - +'See also NULL Values in MariaDB.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT ISNULL(1+1);'+sLineBreak - +'+-------------+'+sLineBreak - +'| ISNULL(1+1) |'+sLineBreak - +'+-------------+'+sLineBreak - +'| 0 |'+sLineBreak - +'+-------------+'+sLineBreak - +' '+sLineBreak - +'SELECT ISNULL(1/0);'+sLineBreak - +'+-------------+'+sLineBreak - +'| ISNULL(1/0) |'+sLineBreak - +'+-------------+'+sLineBreak - +'| 1 |'+sLineBreak - +'+-------------+' - ), - - ( - Name: 'LEAST'; - Declaration: '(value1,value2,...)'; - Category: 'Comparison Operators'; - Version: SQL_VERSION_ANSI; - Description: 'With two or more arguments, returns the smallest'+sLineBreak - +'(minimum-valued)'+sLineBreak - +'argument. The arguments are compared using the following'+sLineBreak - +'rules:'+sLineBreak - +'If the return value is used in an INTEGER context or all'+sLineBreak - +'arguments are integer-valued, they are compared as integers.'+sLineBreak - +'If the return value is used in a REAL context or all'+sLineBreak - +'arguments are real-valued, they are compared as reals.'+sLineBreak - +'If any argument is a case-sensitive string, the arguments'+sLineBreak - +'are compared as case-sensitive strings.'+sLineBreak - +'In all other cases, the arguments are compared as'+sLineBreak - +'case-insensitive strings.'+sLineBreak - +' '+sLineBreak - +'LEAST() returns NULL if any argument is NULL.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT LEAST(2,0);'+sLineBreak - +'+------------+'+sLineBreak - +'| LEAST(2,0) |'+sLineBreak - +'+------------+'+sLineBreak - +'| 0 |'+sLineBreak - +'+------------+'+sLineBreak - +' '+sLineBreak - +'SELECT LEAST(34.0,3.0,5.0,767.0);'+sLineBreak - +'+---------------------------+'+sLineBreak - +'| LEAST(34.0,3.0,5.0,767.0) |'+sLineBreak - +'+---------------------------+'+sLineBreak - +'| 3.0 |'+sLineBreak - +'+---------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT LEAST(''B'',''A'',''C'');'+sLineBreak - +'+--------------------+'+sLineBreak - +'| LEAST(''B'',''A'',''C'') |'+sLineBreak - +'+--------------------+'+sLineBreak - +'| A |'+sLineBreak - +'+--------------------+' - ), - - ( - Name: 'IFNULL'; - Declaration: '(expr1,expr2)'; - Category: 'Control Flow Functions'; - Version: SQL_VERSION_ANSI; - Description: 'If expr1 is not NULL, IFNULL() returns expr1; otherwise it'+sLineBreak - +'returns'+sLineBreak - +'expr2. IFNULL() returns a numeric or string value, depending'+sLineBreak - +'on the'+sLineBreak - +'context in which it is used.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT IFNULL(1,0); '+sLineBreak - +'+-------------+'+sLineBreak - +'| IFNULL(1,0) |'+sLineBreak - +'+-------------+'+sLineBreak - +'| 1 |'+sLineBreak - +'+-------------+'+sLineBreak - +' '+sLineBreak - +'SELECT IFNULL(NULL,10);'+sLineBreak - +'+-----------------+'+sLineBreak - +'| IFNULL(NULL,10) |'+sLineBreak - +'+-----------------+'+sLineBreak - +'| 10 |'+sLineBreak - +'+-----------------+'+sLineBreak - +' '+sLineBreak - +'SELECT IFNULL(1/0,10);'+sLineBreak - +'+----------------+'+sLineBreak - +'| IFNULL(1/0,10) |'+sLineBreak - +'+----------------+'+sLineBreak - +'| 10.0000 |'+sLineBreak - +'+----------------+'+sLineBreak - +' '+sLineBreak - +'SELECT IFNULL(1/0,''yes'');'+sLineBreak - +'+-------------------+'+sLineBreak - +'| IFNULL(1/0,''yes'') |'+sLineBreak - +'+-------------------+'+sLineBreak - +'| yes |'+sLineBreak - +'+-------------------+' - ), - - ( - Name: 'NULLIF'; - Declaration: '(expr1,expr2)'; - Category: 'Control Flow Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns NULL if expr1 = expr2 is true, otherwise returns'+sLineBreak - +'expr1. This is'+sLineBreak - +'the same as CASE WHEN expr1 = expr2 THEN NULL ELSE expr1'+sLineBreak - +'END.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT NULLIF(1,1);'+sLineBreak - +'+-------------+'+sLineBreak - +'| NULLIF(1,1) |'+sLineBreak - +'+-------------+'+sLineBreak - +'| NULL |'+sLineBreak - +'+-------------+'+sLineBreak - +' '+sLineBreak - +'SELECT NULLIF(1,2);'+sLineBreak - +'+-------------+'+sLineBreak - +'| NULLIF(1,2) |'+sLineBreak - +'+-------------+'+sLineBreak - +'| 1 |'+sLineBreak - +'+-------------+' - ), - - ( - Name: 'BINARY'; - Declaration: '(M)'; - Category: 'Data Types'; - Version: SQL_VERSION_ANSI; - Description: 'The BINARY type is similar to the CHAR type, but stores'+sLineBreak - +'binary'+sLineBreak - +'byte strings rather than non-binary character strings. M'+sLineBreak - +'represents the'+sLineBreak - +'column length in bytes.'+sLineBreak - +' '+sLineBreak - +'It contains no character set, and comparison and sorting are'+sLineBreak - +'based on the numeric value of the bytes.'+sLineBreak - +' '+sLineBreak - +'If the maximum length is exceeded, and SQL strict mode is'+sLineBreak - +'not enabled , the extra characters will be dropped with a'+sLineBreak - +'warning. If strict mode is enabled, an error will occur.'+sLineBreak - +' '+sLineBreak - +'BINARY values are right-padded with 0x00 (the zero byte) to'+sLineBreak - +'the specified length when inserted. The padding is not'+sLineBreak - +'removed on select, so this needs to be taken into account'+sLineBreak - +'when sorting and comparing, where all bytes are significant.'+sLineBreak - +'The zero byte, 0x00 is less than a space for comparison'+sLineBreak - +'purposes.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'Inserting too many characters, first with strict mode off,'+sLineBreak - +'then with it on:'+sLineBreak - +' '+sLineBreak - +'CREATE TABLE bins (a BINARY(10));'+sLineBreak - +' '+sLineBreak - +'INSERT INTO bins VALUES(''12345678901'');'+sLineBreak - +'Query OK, 1 row affected, 1 warning (0.04 sec)'+sLineBreak - +' '+sLineBreak - +'SELECT * FROM bins;'+sLineBreak - +' '+sLineBreak - +'+------------+'+sLineBreak - +'| a |'+sLineBreak - +'+------------+'+sLineBreak - +'| 1234567890 |'+sLineBreak - +'+------------+'+sLineBreak - +' '+sLineBreak - +'SET sql_mode=''STRICT_ALL_TABLES'';'+sLineBreak - +' '+sLineBreak - +'INSERT INTO bins VALUES(''12345678901'');'+sLineBreak - +'ERROR 1406 (22001): Data too long for column ''a'' at row 1'+sLineBreak - +' '+sLineBreak - +'Sorting is performed with the byte value:'+sLineBreak - +' '+sLineBreak - +'TRUNCATE bins;'+sLineBreak - +' '+sLineBreak - +'INSERT INTO bins VALUES(''A''),(''B''),(''a''),(''b'');'+sLineBreak - +' '+sLineBreak - +'SELECT * FROM bins ORDER BY a;'+sLineBreak - +' '+sLineBreak - +'+------+'+sLineBreak - +'| a |'+sLineBreak - +'+------+'+sLineBreak - +'| A |'+sLineBreak - +'| B |'+sLineBreak - +'| a |'+sLineBreak - +'| b |'+sLineBreak - +'+------+'+sLineBreak - +' '+sLineBreak - +'Using CAST to sort as a CHAR instead:'+sLineBreak - +' '+sLineBreak - +'SELECT * FROM bins ORDER BY CAST(a AS CHAR);'+sLineBreak - +'+------+'+sLineBreak - +'| a |'+sLineBreak - +'+------+'+sLineBreak - +'| a |'+sLineBreak - +'| A |'+sLineBreak - +'| b |'+sLineBreak - +'| B |'+sLineBreak - +'+------+'+sLineBreak - +' '+sLineBreak - +'The field is a BINARY(10), so padding of two ''\0''s are'+sLineBreak - +'inserted, causing comparisons that don''t take this into'+sLineBreak - +'account to fail:'+sLineBreak - +' '+sLineBreak - +'TRUNCATE bins;'+sLineBreak - +' '+sLineBreak - +'INSERT INTO bins VALUES(''12345678'');'+sLineBreak - +' '+sLineBreak - +'SELECT a = ''12345678'', a = ''12345678\0\0'' from bins;'+sLineBreak - +' '+sLineBreak - +'+----------------+--------------------+'+sLineBreak - +'| a = ''12345678'' | a = ''12345678\0\0'' |'+sLineBreak - +'+----------------+--------------------+'+sLineBreak - +'| 0 | 1 |'+sLineBreak - +'+----------------+--------------------+' - ), - - ( - Name: 'ENUM'; - Declaration: '(''value1'',''value2'',...)'; - Category: 'Data Types'; - Version: SQL_VERSION_ANSI; - Description: 'An enumeration. A string object that can have only one'+sLineBreak - +'value, chosen'+sLineBreak - +'from the list of values ''value1'', ''value2'', ..., NULL or'+sLineBreak - +'the special '+sLineBreak - +''''' error value. In theory, an ENUM column can have a'+sLineBreak - +'maximum of 65,535 distinct'+sLineBreak - +'values; in practice, the real maximum depends on many'+sLineBreak - +'factors. ENUM values are represented internally as integers.'+sLineBreak - +' '+sLineBreak - +'Trailing spaces are automatically stripped from ENUM values'+sLineBreak - +'on table creation.'+sLineBreak - +' '+sLineBreak - +'ENUMs require relatively little storage space compared to'+sLineBreak - +'strings, either one or two bytes depending on the number of'+sLineBreak - +'enumeration values.'+sLineBreak - +' '+sLineBreak - +'NULL and empty values'+sLineBreak - +' '+sLineBreak - +'An ENUM can also contain NULL and empty values. If the ENUM'+sLineBreak - +'column is declared to permit NULL values, NULL becomes a'+sLineBreak - +'valid value, as well as the default value (see below). If'+sLineBreak - +'strict SQL Mode is not enabled, and an invalid value is'+sLineBreak - +'inserted into an ENUM, a special empty string, with an index'+sLineBreak - +'value of zero (see Numeric index, below), is inserted, with'+sLineBreak - +'a warning. This may be confusing, because the empty string'+sLineBreak - +'is also a possible value, and the only difference if that in'+sLineBreak - +'this case its index is not 0. Inserting will fail with an'+sLineBreak - +'error if strict mode is active.'+sLineBreak - +' '+sLineBreak - +'If a DEFAULT clause is missing, the default value will be:'+sLineBreak - +'NULL is the column is nullable;'+sLineBreak - +'otherwise, the first value in the enumaration.'+sLineBreak - +' '+sLineBreak - +'Numeric index'+sLineBreak - +' '+sLineBreak - +'ENUM values are indexed numerically in the order they are'+sLineBreak - +'defined, and sorting will be performed in this numeric'+sLineBreak - +'order. We suggest not using ENUM to store numerals, as there'+sLineBreak - +'is little to no storage space benefit, and it is easy to'+sLineBreak - +'confuse the enum integer with the enum numeral value by'+sLineBreak - +'leaving out the quotes.'+sLineBreak - +' '+sLineBreak - +'An ENUM defined as ENUM(''apple'',''orange'',''pear'') would'+sLineBreak - +'have the following index values:'+sLineBreak - +' '+sLineBreak - +'Index | Value | '+sLineBreak - +' '+sLineBreak - +'NULL | NULL | '+sLineBreak - +' '+sLineBreak - +'0 | '''' | '+sLineBreak - +' '+sLineBreak - +'1 | ''apple'' | '+sLineBreak - +' '+sLineBreak - +'2 | ''orange'' | '+sLineBreak - +' '+sLineBreak - +'3 | ''pear'' | '+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'CREATE TABLE fruits ('+sLineBreak - +' id INT NOT NULL auto_increment PRIMARY KEY,'+sLineBreak - +' fruit ENUM(''apple'',''orange'',''pear''),'+sLineBreak - +' bushels INT);'+sLineBreak - +' '+sLineBreak - +'DESCRIBE fruits;'+sLineBreak - +' '+sLineBreak - +'+---------+-------------------------------+------+-----+---------+----------------+'+sLineBreak - +'| Field | Type | Null | Key | Default | Extra |'+sLineBreak - +'+---------+-------------------------------+------+-----+---------+----------------+'+sLineBreak - +'| id | int(11) | NO | PRI | NULL | auto_increment |'+sLineBreak - +'| fruit | enum(''apple'',''orange'',''pear'') | YES | | NULL'+sLineBreak - +'| |'+sLineBreak - +'| bushels | int(11) | YES | | NULL | |'+sLineBreak - +'+---------+-------------------------------+------+-----+---------+----------------+'+sLineBreak - +' '+sLineBreak - +'INSERT INTO fruits'+sLineBreak - +' (fruit,bushels) VALUES'+sLineBreak - +' (''pear'',20),'+sLineBreak - +' (''apple'',100),'+sLineBreak - +' (''orange'',25);'+sLineBreak - +' '+sLineBreak - +'INSERT INTO fruits'+sLineBreak - +' (fruit,bushels) VALUES'+sLineBreak - +' (''avocado'',10);'+sLineBreak - +'ERROR 1265 (01000): Data truncated for column ''fruit'' at'+sLineBreak - +'row 1'+sLineBreak - +' '+sLineBreak - +'SELECT * FROM fruits;'+sLineBreak - +' '+sLineBreak - +'+----+--------+---------+'+sLineBreak - +'| id | fruit | bushels |'+sLineBreak - +'+----+--------+---------+'+sLineBreak - +'| 1 | pear | 20 |'+sLineBreak - +'| 2 | apple | 100 |'+sLineBreak - +'| 3 | orange | 25 |'+sLineBreak - +'+----+--------+---------+'+sLineBreak - +' '+sLineBreak - +'Selecting by numeric index:'+sLineBreak - +' '+sLineBreak - +'SELECT * FROM fruits WHERE fruit=2;'+sLineBreak - +' '+sLineBreak - +'+----+--------+---------+'+sLineBreak - +'| id | fruit | bushels |'+sLineBreak - +'+----+--------+---------+'+sLineBreak - +'| 3 | orange | 25 |'+sLineBreak - +'+----+--------+---------+'+sLineBreak - +' '+sLineBreak - +'Sorting is according to the index value:'+sLineBreak - +' '+sLineBreak - +'CREATE TABLE enums (a ENUM(''2'',''1''));'+sLineBreak - +' '+sLineBreak - +'INSERT INTO enums VALUES (''1''),(''2'');'+sLineBreak - +' '+sLineBreak - +'SELECT * FROM enums ORDER BY a ASC;'+sLineBreak - +' '+sLineBreak - +'+------+'+sLineBreak - +'| a |'+sLineBreak - +'+------+'+sLineBreak - +'| 2 |'+sLineBreak - +'| 1 |'+sLineBreak - +'+------+'+sLineBreak - +' '+sLineBreak - +'It''s easy to get confused between returning the enum'+sLineBreak - +'integer with the stored value, so we don''t suggest using'+sLineBreak - +'ENUM to store numerals. The first example returns the 1st'+sLineBreak - +'indexed field (''2'' has an index value of 1, as it''s'+sLineBreak - +'defined first), while the second example returns the string'+sLineBreak - +'value ''1''.'+sLineBreak - +' '+sLineBreak - +'SELECT * FROM enums WHERE a=1;'+sLineBreak - +' '+sLineBreak - +'+------+'+sLineBreak - +'| a |'+sLineBreak - +'+------+'+sLineBreak - +'| 2 |'+sLineBreak - +'+------+'+sLineBreak - +' '+sLineBreak - +'SELECT * FROM enums WHERE a=''1'';'+sLineBreak - +' '+sLineBreak - +'+------+'+sLineBreak - +'| a |'+sLineBreak - +'+------+'+sLineBreak - +'| 1 |'+sLineBreak - +'+------+' - ), - - ( - Name: 'VARBINARY'; - Declaration: '(M)'; - Category: 'Data Types'; - Version: SQL_VERSION_ANSI; - Description: 'The VARBINARY type is similar to the VARCHAR type, but'+sLineBreak - +'stores binary byte strings rather than non-binary character'+sLineBreak - +'strings. M represents the maximum column length in bytes. '+sLineBreak - +' '+sLineBreak - +'It contains no character set, and comparison and sorting are'+sLineBreak - +'based on the numeric value of the bytes.'+sLineBreak - +' '+sLineBreak - +'If the maximum length is exceeded, and SQL strict mode is'+sLineBreak - +'not enabled , the extra characters will be dropped with a'+sLineBreak - +'warning. If strict mode is enabled, an error will occur.'+sLineBreak - +' '+sLineBreak - +'Unlike BINARY values, VARBINARYs are not right-padded when'+sLineBreak - +'inserting.'+sLineBreak - +' '+sLineBreak - +'Oracle Mode'+sLineBreak - +' '+sLineBreak - +'In Oracle mode from MariaDB 10.3, RAW is a synonym for'+sLineBreak - +'VARBINARY.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'Inserting too many characters, first with strict mode off,'+sLineBreak - +'then with it on:'+sLineBreak - +' '+sLineBreak - +'CREATE TABLE varbins (a VARBINARY(10));'+sLineBreak - +' '+sLineBreak - +'INSERT INTO varbins VALUES(''12345678901'');'+sLineBreak - +'Query OK, 1 row affected, 1 warning (0.04 sec)'+sLineBreak - +' '+sLineBreak - +'SELECT * FROM varbins;'+sLineBreak - +' '+sLineBreak - +'+------------+'+sLineBreak - +'| a |'+sLineBreak - +'+------------+'+sLineBreak - +'| 1234567890 |'+sLineBreak - +'+------------+'+sLineBreak - +' '+sLineBreak - +'SET sql_mode=''STRICT_ALL_TABLES'';'+sLineBreak - +' '+sLineBreak - +'INSERT INTO varbins VALUES(''12345678901'');'+sLineBreak - +'ERROR 1406 (22001): Data too long for column ''a'' at row 1'+sLineBreak - +' '+sLineBreak - +'Sorting is performed with the byte value:'+sLineBreak - +' '+sLineBreak - +'TRUNCATE varbins;'+sLineBreak - +' '+sLineBreak - +'INSERT INTO varbins VALUES(''A''),(''B''),(''a''),(''b'');'+sLineBreak - +' '+sLineBreak - +'SELECT * FROM varbins ORDER BY a;'+sLineBreak - +' '+sLineBreak - +'+------+'+sLineBreak - +'| a |'+sLineBreak - +'+------+'+sLineBreak - +'| A |'+sLineBreak - +'| B |'+sLineBreak - +'| a |'+sLineBreak - +'| b |'+sLineBreak - +'+------+'+sLineBreak - +' '+sLineBreak - +'Using CAST to sort as a CHAR instead:'+sLineBreak - +' '+sLineBreak - +'SELECT * FROM varbins ORDER BY CAST(a AS CHAR);'+sLineBreak - +'+------+'+sLineBreak - +'| a |'+sLineBreak - +'+------+'+sLineBreak - +'| a |'+sLineBreak - +'| A |'+sLineBreak - +'| b |'+sLineBreak - +'| B |'+sLineBreak - +'+------+' - ), - - ( - Name: 'ADDDATE'; - Declaration: '(date,INTERVAL expr unit)'; - Category: 'Date and Time Functions'; - Version: SQL_VERSION_ANSI; - Description: 'When invoked with the INTERVAL form of the second argument,'+sLineBreak - +'ADDDATE()'+sLineBreak - +'is a synonym for DATE_ADD(). The related function'+sLineBreak - +'SUBDATE() is a synonym for DATE_SUB(). For'+sLineBreak - +'information on the INTERVAL unit argument, see the'+sLineBreak - +'discussion for'+sLineBreak - +'DATE_ADD().'+sLineBreak - +' '+sLineBreak - +'When invoked with the days form of the second argument,'+sLineBreak - +'MariaDB treats it as an'+sLineBreak - +'integer number of days to be added to expr.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT DATE_ADD(''2008-01-02'', INTERVAL 31 DAY);'+sLineBreak - +'+-----------------------------------------+'+sLineBreak - +'| DATE_ADD(''2008-01-02'', INTERVAL 31 DAY) |'+sLineBreak - +'+-----------------------------------------+'+sLineBreak - +'| 2008-02-02 |'+sLineBreak - +'+-----------------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT ADDDATE(''2008-01-02'', INTERVAL 31 DAY);'+sLineBreak - +'+----------------------------------------+'+sLineBreak - +'| ADDDATE(''2008-01-02'', INTERVAL 31 DAY) |'+sLineBreak - +'+----------------------------------------+'+sLineBreak - +'| 2008-02-02 |'+sLineBreak - +'+----------------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT ADDDATE(''2008-01-02'', 31);'+sLineBreak - +'+---------------------------+'+sLineBreak - +'| ADDDATE(''2008-01-02'', 31) |'+sLineBreak - +'+---------------------------+'+sLineBreak - +'| 2008-02-02 |'+sLineBreak - +'+---------------------------+'+sLineBreak - +' '+sLineBreak - +'CREATE TABLE t1 (d DATETIME);'+sLineBreak - +'INSERT INTO t1 VALUES'+sLineBreak - +' ("2007-01-30 21:31:07"),'+sLineBreak - +' ("1983-10-15 06:42:51"),'+sLineBreak - +' ("2011-04-21 12:34:56"),'+sLineBreak - +' ("2011-10-30 06:31:41"),'+sLineBreak - +' ("2011-01-30 14:03:25"),'+sLineBreak - +' ("2004-10-07 11:19:34");'+sLineBreak - +' '+sLineBreak - +'SELECT d, ADDDATE(d, 10) from t1;'+sLineBreak - +' '+sLineBreak - +'+---------------------+---------------------+'+sLineBreak - +'| d | ADDDATE(d, 10) |'+sLineBreak - +'+---------------------+---------------------+'+sLineBreak - +'| 2007-01-30 21:31:07 | 2007-02-09 21:31:07 |'+sLineBreak - +'| 1983-10-15 06:42:51 | 1983-10-25 06:42:51 |'+sLineBreak - +'| 2011-04-21 12:34:56 | 2011-05-01 12:34:56 |'+sLineBreak - +'| 2011-10-30 06:31:41 | 2011-11-09 06:31:41 |'+sLineBreak - +'| 2011-01-30 14:03:25 | 2011-02-09 14:03:25 |'+sLineBreak - +'| 2004-10-07 11:19:34 | 2004-10-17 11:19:34 |'+sLineBreak - +'+---------------------+---------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT d, ADDDATE(d, INTERVAL 10 HOUR) from t1;'+sLineBreak - +' '+sLineBreak - +'+---------------------+------------------------------+'+sLineBreak - +'| d | ADDDATE(d, INTERVAL 10 HOUR) |'+sLineBreak - +'+---------------------+------------------------------+'+sLineBreak - +'| 2007-01-30 21:31:07 | 2007-01-31 07:31:07 |'+sLineBreak - +'| 1983-10-15 06:42:51 | 1983-10-15 16:42:51 |'+sLineBreak - +'| 2011-04-21 12:34:56 | 2011-04-21 22:34:56 |'+sLineBreak - +'| 2011-10-30 06:31:41 | 2011-10-30 16:31:41 |'+sLineBreak - +'| 2011-01-30 14:03:25 | 2011-01-31 00:03:25 |'+sLineBreak - +'| 2004-10-07 11:19:34 | 2004-10-07 21:19:34 |'+sLineBreak - +'+---------------------+------------------------------+' - ), - - ( - Name: 'ADDDATE'; - Declaration: '(expr,days)'; - Category: 'Date and Time Functions'; - Version: SQL_VERSION_ANSI; - Description: 'When invoked with the INTERVAL form of the second argument,'+sLineBreak - +'ADDDATE()'+sLineBreak - +'is a synonym for DATE_ADD(). The related function'+sLineBreak - +'SUBDATE() is a synonym for DATE_SUB(). For'+sLineBreak - +'information on the INTERVAL unit argument, see the'+sLineBreak - +'discussion for'+sLineBreak - +'DATE_ADD().'+sLineBreak - +' '+sLineBreak - +'When invoked with the days form of the second argument,'+sLineBreak - +'MariaDB treats it as an'+sLineBreak - +'integer number of days to be added to expr.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT DATE_ADD(''2008-01-02'', INTERVAL 31 DAY);'+sLineBreak - +'+-----------------------------------------+'+sLineBreak - +'| DATE_ADD(''2008-01-02'', INTERVAL 31 DAY) |'+sLineBreak - +'+-----------------------------------------+'+sLineBreak - +'| 2008-02-02 |'+sLineBreak - +'+-----------------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT ADDDATE(''2008-01-02'', INTERVAL 31 DAY);'+sLineBreak - +'+----------------------------------------+'+sLineBreak - +'| ADDDATE(''2008-01-02'', INTERVAL 31 DAY) |'+sLineBreak - +'+----------------------------------------+'+sLineBreak - +'| 2008-02-02 |'+sLineBreak - +'+----------------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT ADDDATE(''2008-01-02'', 31);'+sLineBreak - +'+---------------------------+'+sLineBreak - +'| ADDDATE(''2008-01-02'', 31) |'+sLineBreak - +'+---------------------------+'+sLineBreak - +'| 2008-02-02 |'+sLineBreak - +'+---------------------------+'+sLineBreak - +' '+sLineBreak - +'CREATE TABLE t1 (d DATETIME);'+sLineBreak - +'INSERT INTO t1 VALUES'+sLineBreak - +' ("2007-01-30 21:31:07"),'+sLineBreak - +' ("1983-10-15 06:42:51"),'+sLineBreak - +' ("2011-04-21 12:34:56"),'+sLineBreak - +' ("2011-10-30 06:31:41"),'+sLineBreak - +' ("2011-01-30 14:03:25"),'+sLineBreak - +' ("2004-10-07 11:19:34");'+sLineBreak - +' '+sLineBreak - +'SELECT d, ADDDATE(d, 10) from t1;'+sLineBreak - +' '+sLineBreak - +'+---------------------+---------------------+'+sLineBreak - +'| d | ADDDATE(d, 10) |'+sLineBreak - +'+---------------------+---------------------+'+sLineBreak - +'| 2007-01-30 21:31:07 | 2007-02-09 21:31:07 |'+sLineBreak - +'| 1983-10-15 06:42:51 | 1983-10-25 06:42:51 |'+sLineBreak - +'| 2011-04-21 12:34:56 | 2011-05-01 12:34:56 |'+sLineBreak - +'| 2011-10-30 06:31:41 | 2011-11-09 06:31:41 |'+sLineBreak - +'| 2011-01-30 14:03:25 | 2011-02-09 14:03:25 |'+sLineBreak - +'| 2004-10-07 11:19:34 | 2004-10-17 11:19:34 |'+sLineBreak - +'+---------------------+---------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT d, ADDDATE(d, INTERVAL 10 HOUR) from t1;'+sLineBreak - +' '+sLineBreak - +'+---------------------+------------------------------+'+sLineBreak - +'| d | ADDDATE(d, INTERVAL 10 HOUR) |'+sLineBreak - +'+---------------------+------------------------------+'+sLineBreak - +'| 2007-01-30 21:31:07 | 2007-01-31 07:31:07 |'+sLineBreak - +'| 1983-10-15 06:42:51 | 1983-10-15 16:42:51 |'+sLineBreak - +'| 2011-04-21 12:34:56 | 2011-04-21 22:34:56 |'+sLineBreak - +'| 2011-10-30 06:31:41 | 2011-10-30 16:31:41 |'+sLineBreak - +'| 2011-01-30 14:03:25 | 2011-01-31 00:03:25 |'+sLineBreak - +'| 2004-10-07 11:19:34 | 2004-10-07 21:19:34 |'+sLineBreak - +'+---------------------+------------------------------+' - ), - - ( - Name: 'ADDTIME'; - Declaration: '(expr1,expr2)'; - Category: 'Date and Time Functions'; - Version: SQL_VERSION_ANSI; - Description: 'ADDTIME() adds expr2 to expr1 and returns the result. expr1'+sLineBreak - +'is a time'+sLineBreak - +'or datetime expression, and expr2 is a time expression.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT ADDTIME(''2007-12-31 23:59:59.999999'', ''1'+sLineBreak - +'1:1:1.000002'');'+sLineBreak - +'+---------------------------------------------------------+'+sLineBreak - +'| ADDTIME(''2007-12-31 23:59:59.999999'', ''1'+sLineBreak - +'1:1:1.000002'') |'+sLineBreak - +'+---------------------------------------------------------+'+sLineBreak - +'| 2008-01-02 01:01:01.000001 |'+sLineBreak - +'+---------------------------------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT ADDTIME(''01:00:00.999999'', ''02:00:00.999998'');'+sLineBreak - +'+-----------------------------------------------+'+sLineBreak - +'| ADDTIME(''01:00:00.999999'', ''02:00:00.999998'') |'+sLineBreak - +'+-----------------------------------------------+'+sLineBreak - +'| 03:00:01.999997 |'+sLineBreak - +'+-----------------------------------------------+' - ), - - ( - Name: 'CONVERT_TZ'; - Declaration: '(dt,from_tz,to_tz)'; - Category: 'Date and Time Functions'; - Version: SQL_VERSION_ANSI; - Description: 'CONVERT_TZ() converts a datetime value dt from the time zone'+sLineBreak - +'given by from_tz to the time zone given by to_tz and returns'+sLineBreak - +'the resulting value.'+sLineBreak - +' '+sLineBreak - +'In order to use named time zones, such as GMT, MET or'+sLineBreak - +'Africa/Johannesburg, the time_zone tables must be loaded'+sLineBreak - +'(see mysql_tzinfo_to_sql).'+sLineBreak - +' '+sLineBreak - +'No conversion will take place if the value falls outside of'+sLineBreak - +'the supported TIMESTAMP range (''1970-01-01 00:00:01'' to'+sLineBreak - +'''2038-01-19 05:14:07'' UTC) when converted from from_tz to'+sLineBreak - +'UTC.'+sLineBreak - +' '+sLineBreak - +'This function returns NULL if the arguments are invalid (or'+sLineBreak - +'named time zones have not been loaded).'+sLineBreak - +' '+sLineBreak - +'See time zones for more information.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT CONVERT_TZ(''2016-01-01'+sLineBreak - +'12:00:00'',''+00:00'',''+10:00'');'+sLineBreak - +'+-----------------------------------------------------+'+sLineBreak - +'| CONVERT_TZ(''2016-01-01 12:00:00'',''+00:00'',''+10:00'')'+sLineBreak - +'|'+sLineBreak - +'+-----------------------------------------------------+'+sLineBreak - +'| 2016-01-01 22:00:00 |'+sLineBreak - +'+-----------------------------------------------------+'+sLineBreak - +' '+sLineBreak - +'Using named time zones (with the time zone tables loaded):'+sLineBreak - +' '+sLineBreak - +'SELECT CONVERT_TZ(''2016-01-01'+sLineBreak - +'12:00:00'',''GMT'',''Africa/Johannesburg'');'+sLineBreak - +'+---------------------------------------------------------------+'+sLineBreak - +'| CONVERT_TZ(''2016-01-01'+sLineBreak - +'12:00:00'',''GMT'',''Africa/Johannesburg'') |'+sLineBreak - +'+---------------------------------------------------------------+'+sLineBreak - +'| 2016-01-01 14:00:00 |'+sLineBreak - +'+---------------------------------------------------------------+'+sLineBreak - +' '+sLineBreak - +'The value is out of the TIMESTAMP range, so no conversion'+sLineBreak - +'takes place:'+sLineBreak - +' '+sLineBreak - +'SELECT CONVERT_TZ(''1969-12-31'+sLineBreak - +'22:00:00'',''+00:00'',''+10:00'');'+sLineBreak - +'+-----------------------------------------------------+'+sLineBreak - +'| CONVERT_TZ(''1969-12-31 22:00:00'',''+00:00'',''+10:00'')'+sLineBreak - +'|'+sLineBreak - +'+-----------------------------------------------------+'+sLineBreak - +'| 1969-12-31 22:00:00 |'+sLineBreak - +'+-----------------------------------------------------+' - ), - - ( - Name: 'CURDATE'; - Declaration: '()'; - Category: 'Date and Time Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the current date as a value in ''YYYY-MM-DD'' or'+sLineBreak - +'YYYYMMDD'+sLineBreak - +'format, depending on whether the function is used in a'+sLineBreak - +'string or'+sLineBreak - +'numeric context.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT CURDATE();'+sLineBreak - +'+------------+'+sLineBreak - +'| CURDATE() |'+sLineBreak - +'+------------+'+sLineBreak - +'| 2019-03-05 |'+sLineBreak - +'+------------+'+sLineBreak - +' '+sLineBreak - +'In a numeric context (note this is not performing date'+sLineBreak - +'calculations):'+sLineBreak - +' '+sLineBreak - +'SELECT CURDATE() +0;'+sLineBreak - +' '+sLineBreak - +'+--------------+'+sLineBreak - +'| CURDATE() +0 |'+sLineBreak - +'+--------------+'+sLineBreak - +'| 20190305 |'+sLineBreak - +'+--------------+'+sLineBreak - +' '+sLineBreak - +'Data calculation:'+sLineBreak - +' '+sLineBreak - +'SELECT CURDATE() - INTERVAL 5 DAY;'+sLineBreak - +' '+sLineBreak - +'+----------------------------+'+sLineBreak - +'| CURDATE() - INTERVAL 5 DAY |'+sLineBreak - +'+----------------------------+'+sLineBreak - +'| 2019-02-28 |'+sLineBreak - +'+----------------------------+' - ), - - ( - Name: 'CURTIME'; - Declaration: '([precision])'; - Category: 'Date and Time Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the current time as a value in ''HH:MM:SS'' or'+sLineBreak - +'HHMMSS.uuuuuu format, depending on whether the function is'+sLineBreak - +'used in a string or numeric context. The value is expressed'+sLineBreak - +'in the current time zone.'+sLineBreak - +' '+sLineBreak - +'The optional precision determines the microsecond precision.'+sLineBreak - +'See Microseconds in MariaDB.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT CURTIME();'+sLineBreak - +'+-----------+'+sLineBreak - +'| CURTIME() |'+sLineBreak - +'+-----------+'+sLineBreak - +'| 12:45:39 |'+sLineBreak - +'+-----------+'+sLineBreak - +' '+sLineBreak - +'SELECT CURTIME() + 0;'+sLineBreak - +' '+sLineBreak - +'+---------------+'+sLineBreak - +'| CURTIME() + 0 |'+sLineBreak - +'+---------------+'+sLineBreak - +'| 124545.000000 |'+sLineBreak - +'+---------------+'+sLineBreak - +' '+sLineBreak - +'With precision:'+sLineBreak - +' '+sLineBreak - +'SELECT CURTIME(2);'+sLineBreak - +'+-------------+'+sLineBreak - +'| CURTIME(2) |'+sLineBreak - +'+-------------+'+sLineBreak - +'| 09:49:08.09 |'+sLineBreak - +'+-------------+' - ), - - ( - Name: 'DATEDIFF'; - Declaration: '(expr1,expr2)'; - Category: 'Date and Time Functions'; - Version: SQL_VERSION_ANSI; - Description: 'DATEDIFF() returns (expr1 ֠expr2) expressed'+sLineBreak - +'as a value in days from one date to the other. expr1 and'+sLineBreak - +'expr2 are date'+sLineBreak - +'or date-and-time expressions. Only the date parts of the'+sLineBreak - +'values are used in the'+sLineBreak - +'calculation.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT DATEDIFF(''2007-12-31 23:59:59'',''2007-12-30'');'+sLineBreak - +'+----------------------------------------------+'+sLineBreak - +'| DATEDIFF(''2007-12-31 23:59:59'',''2007-12-30'') |'+sLineBreak - +'+----------------------------------------------+'+sLineBreak - +'| 1 |'+sLineBreak - +'+----------------------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT DATEDIFF(''2010-11-30 23:59:59'',''2010-12-31'');'+sLineBreak - +'+----------------------------------------------+'+sLineBreak - +'| DATEDIFF(''2010-11-30 23:59:59'',''2010-12-31'') |'+sLineBreak - +'+----------------------------------------------+'+sLineBreak - +'| -31 |'+sLineBreak - +'+----------------------------------------------+'+sLineBreak - +' '+sLineBreak - +'CREATE TABLE t1 (d DATETIME);'+sLineBreak - +'INSERT INTO t1 VALUES'+sLineBreak - +' ("2007-01-30 21:31:07"),'+sLineBreak - +' ("1983-10-15 06:42:51"),'+sLineBreak - +' ("2011-04-21 12:34:56"),'+sLineBreak - +' ("2011-10-30 06:31:41"),'+sLineBreak - +' ("2011-01-30 14:03:25"),'+sLineBreak - +' ("2004-10-07 11:19:34");'+sLineBreak - +' '+sLineBreak - +'SELECT NOW();'+sLineBreak - +'+---------------------+'+sLineBreak - +'| NOW() |'+sLineBreak - +'+---------------------+'+sLineBreak - +'| 2011-05-23 10:56:05 |'+sLineBreak - +'+---------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT d, DATEDIFF(NOW(),d) FROM t1;'+sLineBreak - +' '+sLineBreak - +'+---------------------+-------------------+'+sLineBreak - +'| d | DATEDIFF(NOW(),d) |'+sLineBreak - +'+---------------------+-------------------+'+sLineBreak - +'| 2007-01-30 21:31:07 | 1574 |'+sLineBreak - +'| 1983-10-15 06:42:51 | 10082 |'+sLineBreak - +'| 2011-04-21 12:34:56 | 32 |'+sLineBreak - +'| 2011-10-30 06:31:41 | -160 |'+sLineBreak - +'| 2011-01-30 14:03:25 | 113 |'+sLineBreak - +'| 2004-10-07 11:19:34 | 2419 |'+sLineBreak - +'+---------------------+-------------------+' - ), - - ( - Name: 'DATE_ADD'; - Declaration: '(date,INTERVAL expr unit)'; - Category: 'Date and Time Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Performs date arithmetic. The date argument specifies the'+sLineBreak - +'starting date or datetime value. expr is an expression'+sLineBreak - +'specifying the'+sLineBreak - +'interval value to be added or subtracted from the starting'+sLineBreak - +'date. expr is a'+sLineBreak - +'string; it may start with a "-" for negative intervals.'+sLineBreak - +'unit is a'+sLineBreak - +'keyword indicating the units in which the expression should'+sLineBreak - +'be interpreted. See Date and Time Units for a complete list'+sLineBreak - +'of permitted units. '+sLineBreak - +' '+sLineBreak - +'See also DATE_SUB().'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT ''2008-12-31 23:59:59'' + INTERVAL 1 SECOND;'+sLineBreak - +' '+sLineBreak - +'+-------------------------------------------+'+sLineBreak - +'| ''2008-12-31 23:59:59'' + INTERVAL 1 SECOND |'+sLineBreak - +'+-------------------------------------------+'+sLineBreak - +'| 2009-01-01 00:00:00 |'+sLineBreak - +'+-------------------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT INTERVAL 1 DAY + ''2008-12-31'';'+sLineBreak - +' '+sLineBreak - +'+-------------------------------+'+sLineBreak - +'| INTERVAL 1 DAY + ''2008-12-31'' |'+sLineBreak - +'+-------------------------------+'+sLineBreak - +'| 2009-01-01 |'+sLineBreak - +'+-------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT ''2005-01-01'' - INTERVAL 1 SECOND;'+sLineBreak - +' '+sLineBreak - +'+----------------------------------+'+sLineBreak - +'| ''2005-01-01'' - INTERVAL 1 SECOND |'+sLineBreak - +'+----------------------------------+'+sLineBreak - +'| 2004-12-31 23:59:59 |'+sLineBreak - +'+----------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT DATE_ADD(''2000-12-31 23:59:59'', INTERVAL 1 SECOND);'+sLineBreak - +'+----------------------------------------------------+'+sLineBreak - +'| DATE_ADD(''2000-12-31 23:59:59'', INTERVAL 1 SECOND) |'+sLineBreak - +'+----------------------------------------------------+'+sLineBreak - +'| 2001-01-01 00:00:00 |'+sLineBreak - +'+----------------------------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT DATE_ADD(''2010-12-31 23:59:59'', INTERVAL 1 DAY);'+sLineBreak - +'+-------------------------------------------------+'+sLineBreak - +'| DATE_ADD(''2010-12-31 23:59:59'', INTERVAL 1 DAY) |'+sLineBreak - +'+-------------------------------------------------+'+sLineBreak - +'| 2011-01-01 23:59:59 |'+sLineBreak - +'+-------------------------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT DATE_ADD(''2100-12-31 23:59:59'', INTERVAL ''1:1'''+sLineBreak - +'MINUTE_SECOND);'+sLineBreak - +'+---------------------------------------------------------------+'+sLineBreak - +'| DATE_ADD(''2100-12-31 23:59:59'', INTERVAL ''1:1'''+sLineBreak - +'MINUTE_SECOND) |'+sLineBreak - +'+---------------------------------------------------------------+'+sLineBreak - +'| 2101-01-01 00:01:00 |'+sLineBreak - +'+---------------------------------------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT DATE_ADD(''1900-01-01 00:00:00'', INTERVAL ''-1 10'''+sLineBreak - +'DAY_HOUR);'+sLineBreak - +'+------------------------------------------------------------+'+sLineBreak - +'| DATE_ADD(''1900-01-01 00:00:00'', INTERVAL ''-1 10'''+sLineBreak - +'DAY_HOUR) |'+sLineBreak - +'+------------------------------------------------------------+'+sLineBreak - +'| 1899-12-30 14:00:00 |'+sLineBreak - +'+------------------------------------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT DATE_ADD(''1992-12-31 23:59:59.000002'', INTERVAL'+sLineBreak - +'''1.999999'' SECOND_MICROSECOND);'+sLineBreak - +'+--------------------------------------------------------------------------------+'+sLineBreak - +'| DATE_ADD(''1992-12-31 23:59:59.000002'', INTERVAL'+sLineBreak - +'''1.999999'' SECOND_MICROSECOND) |'+sLineBreak - +'+--------------------------------------------------------------------------------+'+sLineBreak - +'| 1993-01-01 00:00:01.000001 |'+sLineBreak - +'+--------------------------------------------------------------------------------+' - ), - - ( - Name: 'DATE_FORMAT'; - Declaration: '(date, format[, locale])'; - Category: 'Date and Time Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Formats the date value according to the format string. '+sLineBreak - +' '+sLineBreak - +'The language used for the names is controlled by the value'+sLineBreak - +'of the lc_time_names system variable. See server locale for'+sLineBreak - +'more on the supported locales.'+sLineBreak - +' '+sLineBreak - +'The options that can be used by DATE_FORMAT(), as well as'+sLineBreak - +'its inverse STR_TO_DATE() and the FROM_UNIXTIME() function,'+sLineBreak - +'are:'+sLineBreak - +' '+sLineBreak - +'Option | Description | '+sLineBreak - +' '+sLineBreak - +'%a | Short weekday name in current locale (Variable'+sLineBreak - +'lc_time_names). | '+sLineBreak - +' '+sLineBreak - +'%b | Short form month name in current locale. For locale'+sLineBreak - +'en_US this is one of:'+sLineBreak - +'Jan,Feb,Mar,Apr,May,Jun,Jul,Aug,Sep,Oct,Nov or Dec. | '+sLineBreak - +' '+sLineBreak - +'%c | Month with 1 or 2 digits. | '+sLineBreak - +' '+sLineBreak - +'%D | Day with English suffix ''th'', ''nd'', ''st'' or'+sLineBreak - +'''rd''''. (1st, 2nd, 3rd...). | '+sLineBreak - +' '+sLineBreak - +'%d | Day with 2 digits. | '+sLineBreak - +' '+sLineBreak - +'%e | Day with 1 or 2 digits. | '+sLineBreak - +' '+sLineBreak - +'%f | Sub seconds 6 digits. | '+sLineBreak - +' '+sLineBreak - +'%H | Hour with 2 digits between 00-23. | '+sLineBreak - +' '+sLineBreak - +'%h | Hour with 2 digits between 01-12. | '+sLineBreak - +' '+sLineBreak - +'%I | Hour with 2 digits between 01-12. | '+sLineBreak - +' '+sLineBreak - +'%i | Minute with 2 digits. | '+sLineBreak - +' '+sLineBreak - +'%j | Day of the year (001-366) | '+sLineBreak - +' '+sLineBreak - +'%k | Hour with 1 digits between 0-23. | '+sLineBreak - +' '+sLineBreak - +'%l | Hour with 1 digits between 1-12. | '+sLineBreak - +' '+sLineBreak - +'%M | Full month name in current locale (Variable'+sLineBreak - +'lc_time_names). | '+sLineBreak - +' '+sLineBreak - +'%m | Month with 2 digits. | '+sLineBreak - +' '+sLineBreak - +'%p | AM/PM according to current locale (Variable'+sLineBreak - +'lc_time_names). | '+sLineBreak - +' '+sLineBreak - +'%r | Time in 12 hour format, followed by AM/PM. Short for'+sLineBreak - +'''%I:%i:%S %p''. | '+sLineBreak - +' '+sLineBreak - +'%S | Seconds with 2 digits. | '+sLineBreak - +' '+sLineBreak - +'%s | Seconds with 2 digits. | '+sLineBreak - +' '+sLineBreak - +'%T | Time in 24 hour format. Short for ''%H:%i:%S''. | '+sLineBreak - +' '+sLineBreak - +'%U | Week number (00-53), when first day of the week is'+sLineBreak - +'Sunday. | '+sLineBreak - +' '+sLineBreak - +'%u | Week number (00-53), when first day of the week is'+sLineBreak - +'Monday. | '+sLineBreak - +' '+sLineBreak - +'%V | Week number (01-53), when first day of the week is'+sLineBreak - +'Sunday. Used with %X. | '+sLineBreak - +' '+sLineBreak - +'%v | Week number (01-53), when first day of the week is'+sLineBreak - +'Monday. Used with %x. | '+sLineBreak - +' '+sLineBreak - +'%W | Full weekday name in current locale (Variable'+sLineBreak - +'lc_time_names). | '+sLineBreak - +' '+sLineBreak - +'%w | Day of the week. 0 = Sunday, 6 = Saturday. | '+sLineBreak - +' '+sLineBreak - +'%X | Year with 4 digits when first day of the week is'+sLineBreak - +'Sunday. Used with %V. | '+sLineBreak - +' '+sLineBreak - +'%x | Year with 4 digits when first day of the week is'+sLineBreak - +'Monday. Used with %v. | '+sLineBreak - +' '+sLineBreak - +'%Y | Year with 4 digits. | '+sLineBreak - +' '+sLineBreak - +'%y | Year with 2 digits. | '+sLineBreak - +' '+sLineBreak - +'%# | For str_to_date(), skip all numbers. | '+sLineBreak - +' '+sLineBreak - +'%. | For str_to_date(), skip all punctation characters. | '+sLineBreak - +' '+sLineBreak - +'%@ | For str_to_date(), skip all alpha characters. | '+sLineBreak - +' '+sLineBreak - +'%% | A literal % character. | '+sLineBreak - +' '+sLineBreak - +'To get a date in one of the standard formats, GET_FORMAT()'+sLineBreak - +'can be used.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT DATE_FORMAT(''2009-10-04 22:23:00'', ''%W %M %Y'');'+sLineBreak - +'+------------------------------------------------+'+sLineBreak - +'| DATE_FORMAT(''2009-10-04 22:23:00'', ''%W %M %Y'') |'+sLineBreak - +'+------------------------------------------------+'+sLineBreak - +'| Sunday October 2009 |'+sLineBreak - +'+------------------------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT DATE_FORMAT(''2007-10-04 22:23:00'', ''%H:%i:%s'');'+sLineBreak - +'+------------------------------------------------+'+sLineBreak - +'| DATE_FORMAT(''2007-10-04 22:23:00'', ''%H:%i:%s'') |'+sLineBreak - +'+------------------------------------------------+'+sLineBreak - +'| 22:23:00 |'+sLineBreak - +'+------------------------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT DATE_FORMAT(''1900-10-04 22:23:00'', ''%D %y %a %d %m'+sLineBreak - +'%b %j'');'+sLineBreak - +'+------------------------------------------------------------+'+sLineBreak - +'| DATE_FORMAT(''1900-10-04 22:23:00'', ''%D %y %a %d %m %b'+sLineBreak - +'%j'') |'+sLineBreak - +'+------------------------------------------------------------+'+sLineBreak - +'| 4th 00 Thu 04 10 Oct 277 |'+sLineBreak - +'+------------------------------------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT DATE_FORMAT(''1997-10-04 22:23:00'', ''%H %k %I %r %T'+sLineBreak - +'%S %w'');'+sLineBreak - +'+------------------------------------------------------------+'+sLineBreak - +'| DATE_FORMAT(''1997-10-04 22:23:00'', ''%H %k %I %r %T %S'+sLineBreak - +'%w'') |'+sLineBreak - +'+------------------------------------------------------------+'+sLineBreak - +'| 22 22 10 10:23:00 PM 22:23:00 00 6 |'+sLineBreak - +'+------------------------------------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT DATE_FORMAT(''1999-01-01'', ''%X %V'');'+sLineBreak - +'+------------------------------------+'+sLineBreak - +'| DATE_FORMAT(''1999-01-01'', ''%X %V'') |'+sLineBreak - +'+------------------------------------+'+sLineBreak - +'| 1998 52 |'+sLineBreak - +'+------------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT DATE_FORMAT(''2006-06-00'', ''%d'');'+sLineBreak - +'+---------------------------------+'+sLineBreak - +'| DATE_FORMAT(''2006-06-00'', ''%d'') |'+sLineBreak - +'+---------------------------------+'+sLineBreak - +'| 00 |'+sLineBreak - +'+---------------------------------+'+sLineBreak - +' '+sLineBreak - +'Optionally, the locale can be explicitly specified as the'+sLineBreak - +'third DATE_FORMAT() argument. Doing so makes the function'+sLineBreak - +'independent from the session settings, and the three'+sLineBreak - +'argument version of DATE_FORMAT() can be used in virtual'+sLineBreak - +'indexed and persistent generated-columns:'+sLineBreak - +' '+sLineBreak - +'SELECT DATE_FORMAT(''2006-01-01'', ''%W'', ''el_GR'');'+sLineBreak - +'+------------------------------------------+'+sLineBreak - +'| DATE_FORMAT(''2006-01-01'', ''%W'', ''el_GR'') |'+sLineBreak - +'+------------------------------------------+'+sLineBreak - +'| ??????? |'+sLineBreak - +'+------------------------------------------+' - ), - - ( - Name: 'DATE_SUB'; - Declaration: '(date,INTERVAL expr unit)'; - Category: 'Date and Time Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Performs date arithmetic. The date argument specifies the'+sLineBreak - +'starting date or datetime value. expr is an expression'+sLineBreak - +'specifying the'+sLineBreak - +'interval value to be added or subtracted from the starting'+sLineBreak - +'date. expr is a'+sLineBreak - +'string; it may start with a "-" for negative intervals.'+sLineBreak - +'unit is a'+sLineBreak - +'keyword indicating the units in which the expression should'+sLineBreak - +'be interpreted. See Date and Time Units for a complete list'+sLineBreak - +'of permitted units. '+sLineBreak - +' '+sLineBreak - +'See also DATE_ADD().'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT DATE_SUB(''1998-01-02'', INTERVAL 31 DAY);'+sLineBreak - +'+-----------------------------------------+'+sLineBreak - +'| DATE_SUB(''1998-01-02'', INTERVAL 31 DAY) |'+sLineBreak - +'+-----------------------------------------+'+sLineBreak - +'| 1997-12-02 |'+sLineBreak - +'+-----------------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT DATE_SUB(''2005-01-01 00:00:00'', INTERVAL ''1'+sLineBreak - +'1:1:1'' DAY_SECOND);'+sLineBreak - +'+----------------------------------------------------------------+'+sLineBreak - +'| DATE_SUB(''2005-01-01 00:00:00'', INTERVAL ''1 1:1:1'''+sLineBreak - +'DAY_SECOND) |'+sLineBreak - +'+----------------------------------------------------------------+'+sLineBreak - +'| 2004-12-30 22:58:59 |'+sLineBreak - +'+----------------------------------------------------------------+' - ), - - ( - Name: 'DAY'; - Declaration: '(date)'; - Category: 'Date and Time Functions'; - Version: SQL_VERSION_ANSI; - Description: 'DAY() is a synonym for DAYOFMONTH().' - ), - - ( - Name: 'DAYNAME'; - Declaration: '(date)'; - Category: 'Date and Time Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the name of the weekday for date. The language used'+sLineBreak - +'for the name is controlled by the value'+sLineBreak - +'of the lc_time_names system variable. See server locale for'+sLineBreak - +'more on the supported locales.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT DAYNAME(''2007-02-03'');'+sLineBreak - +'+-----------------------+'+sLineBreak - +'| DAYNAME(''2007-02-03'') |'+sLineBreak - +'+-----------------------+'+sLineBreak - +'| Saturday |'+sLineBreak - +'+-----------------------+'+sLineBreak - +' '+sLineBreak - +'CREATE TABLE t1 (d DATETIME);'+sLineBreak - +'INSERT INTO t1 VALUES'+sLineBreak - +' ("2007-01-30 21:31:07"),'+sLineBreak - +' ("1983-10-15 06:42:51"),'+sLineBreak - +' ("2011-04-21 12:34:56"),'+sLineBreak - +' ("2011-10-30 06:31:41"),'+sLineBreak - +' ("2011-01-30 14:03:25"),'+sLineBreak - +' ("2004-10-07 11:19:34");'+sLineBreak - +' '+sLineBreak - +'SELECT d, DAYNAME(d) FROM t1;'+sLineBreak - +' '+sLineBreak - +'+---------------------+------------+'+sLineBreak - +'| d | DAYNAME(d) |'+sLineBreak - +'+---------------------+------------+'+sLineBreak - +'| 2007-01-30 21:31:07 | Tuesday |'+sLineBreak - +'| 1983-10-15 06:42:51 | Saturday |'+sLineBreak - +'| 2011-04-21 12:34:56 | Thursday |'+sLineBreak - +'| 2011-10-30 06:31:41 | Sunday |'+sLineBreak - +'| 2011-01-30 14:03:25 | Sunday |'+sLineBreak - +'| 2004-10-07 11:19:34 | Thursday |'+sLineBreak - +'+---------------------+------------+'+sLineBreak - +' '+sLineBreak - +'Changing the locale:'+sLineBreak - +' '+sLineBreak - +'SET lc_time_names = ''fr_CA'';'+sLineBreak - +' '+sLineBreak - +'SELECT DAYNAME(''2013-04-01'');'+sLineBreak - +'+-----------------------+'+sLineBreak - +'| DAYNAME(''2013-04-01'') |'+sLineBreak - +'+-----------------------+'+sLineBreak - +'| lundi |'+sLineBreak - +'+-----------------------+' - ), - - ( - Name: 'DAYOFMONTH'; - Declaration: '(date)'; - Category: 'Date and Time Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the day of the month for date, in the range 1 to 31,'+sLineBreak - +'or 0'+sLineBreak - +'for dates such as ''0000-00-00'' or ''2008-00-00'' which'+sLineBreak - +'have a zero day'+sLineBreak - +'part.'+sLineBreak - +' '+sLineBreak - +'DAY() is a synonym.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT DAYOFMONTH(''2007-02-03'');'+sLineBreak - +'+--------------------------+'+sLineBreak - +'| DAYOFMONTH(''2007-02-03'') |'+sLineBreak - +'+--------------------------+'+sLineBreak - +'| 3 |'+sLineBreak - +'+--------------------------+'+sLineBreak - +' '+sLineBreak - +'CREATE TABLE t1 (d DATETIME);'+sLineBreak - +'INSERT INTO t1 VALUES'+sLineBreak - +' ("2007-01-30 21:31:07"),'+sLineBreak - +' ("1983-10-15 06:42:51"),'+sLineBreak - +' ("2011-04-21 12:34:56"),'+sLineBreak - +' ("2011-10-30 06:31:41"),'+sLineBreak - +' ("2011-01-30 14:03:25"),'+sLineBreak - +' ("2004-10-07 11:19:34");'+sLineBreak - +' '+sLineBreak - +'SELECT d FROM t1 where DAYOFMONTH(d) = 30;'+sLineBreak - +' '+sLineBreak - +'+---------------------+'+sLineBreak - +'| d |'+sLineBreak - +'+---------------------+'+sLineBreak - +'| 2007-01-30 21:31:07 |'+sLineBreak - +'| 2011-10-30 06:31:41 |'+sLineBreak - +'| 2011-01-30 14:03:25 |'+sLineBreak - +'+---------------------+' - ), - - ( - Name: 'DAYOFWEEK'; - Declaration: '(date)'; - Category: 'Date and Time Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the day of the week index for the date (1 = Sunday,'+sLineBreak - +'2 = Monday, ..., 7 ='+sLineBreak - +'Saturday). These index values correspond to the ODBC'+sLineBreak - +'standard.'+sLineBreak - +' '+sLineBreak - +'This contrasts with WEEKDAY() which follows a different'+sLineBreak - +'index numbering'+sLineBreak - +'(0 = Monday, 1 = Tuesday, ... 6 = Sunday).'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT DAYOFWEEK(''2007-02-03'');'+sLineBreak - +'+-------------------------+'+sLineBreak - +'| DAYOFWEEK(''2007-02-03'') |'+sLineBreak - +'+-------------------------+'+sLineBreak - +'| 7 |'+sLineBreak - +'+-------------------------+'+sLineBreak - +' '+sLineBreak - +'CREATE TABLE t1 (d DATETIME);'+sLineBreak - +'INSERT INTO t1 VALUES'+sLineBreak - +' ("2007-01-30 21:31:07"),'+sLineBreak - +' ("1983-10-15 06:42:51"),'+sLineBreak - +' ("2011-04-21 12:34:56"),'+sLineBreak - +' ("2011-10-30 06:31:41"),'+sLineBreak - +' ("2011-01-30 14:03:25"),'+sLineBreak - +' ("2004-10-07 11:19:34");'+sLineBreak - +' '+sLineBreak - +'SELECT d, DAYNAME(d), DAYOFWEEK(d), WEEKDAY(d) from t1;'+sLineBreak - +' '+sLineBreak - +'+---------------------+------------+--------------+------------+'+sLineBreak - +'| d | DAYNAME(d) | DAYOFWEEK(d) | WEEKDAY(d) |'+sLineBreak - +'+---------------------+------------+--------------+------------+'+sLineBreak - +'| 2007-01-30 21:31:07 | Tuesday | 3 | 1 |'+sLineBreak - +'| 1983-10-15 06:42:51 | Saturday | 7 | 5 |'+sLineBreak - +'| 2011-04-21 12:34:56 | Thursday | 5 | 3 |'+sLineBreak - +'| 2011-10-30 06:31:41 | Sunday | 1 | 6 |'+sLineBreak - +'| 2011-01-30 14:03:25 | Sunday | 1 | 6 |'+sLineBreak - +'| 2004-10-07 11:19:34 | Thursday | 5 | 3 |'+sLineBreak - +'+---------------------+------------+--------------+------------+' - ), - - ( - Name: 'DAYOFYEAR'; - Declaration: '(date)'; - Category: 'Date and Time Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the day of the year for date, in the range 1 to 366.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT DAYOFYEAR(''2018-02-16'');'+sLineBreak - +'+-------------------------+'+sLineBreak - +'| DAYOFYEAR(''2018-02-16'') |'+sLineBreak - +'+-------------------------+'+sLineBreak - +'| 47 |'+sLineBreak - +'+-------------------------+' - ), - - ( - Name: 'EXTRACT'; - Declaration: '(unit FROM date)'; - Category: 'Date and Time Functions'; - Version: SQL_VERSION_ANSI; - Description: 'The EXTRACT() function extracts the required unit from the'+sLineBreak - +'date. See Date and Time Units for a complete list of'+sLineBreak - +'permitted units.'+sLineBreak - +' '+sLineBreak - +'In MariaDB 10.0.7 and MariaDB 5.5.35, EXTRACT (HOUR FROM'+sLineBreak - +'...) was changed to return a value from 0 to 23, adhering to'+sLineBreak - +'the SQL standard. Until MariaDB 10.0.6 and MariaDB 5.5.34,'+sLineBreak - +'and in all versions of MySQL at least as of MySQL 5.7, it'+sLineBreak - +'could return a value > 23. HOUR() is not a standard'+sLineBreak - +'function, so continues to adhere to the old behaviour'+sLineBreak - +'inherited from MySQL.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT EXTRACT(YEAR FROM ''2009-07-02'');'+sLineBreak - +'+---------------------------------+'+sLineBreak - +'| EXTRACT(YEAR FROM ''2009-07-02'') |'+sLineBreak - +'+---------------------------------+'+sLineBreak - +'| 2009 |'+sLineBreak - +'+---------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT EXTRACT(YEAR_MONTH FROM ''2009-07-02 01:02:03'');'+sLineBreak - +'+------------------------------------------------+'+sLineBreak - +'| EXTRACT(YEAR_MONTH FROM ''2009-07-02 01:02:03'') |'+sLineBreak - +'+------------------------------------------------+'+sLineBreak - +'| 200907 |'+sLineBreak - +'+------------------------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT EXTRACT(DAY_MINUTE FROM ''2009-07-02 01:02:03'');'+sLineBreak - +'+------------------------------------------------+'+sLineBreak - +'| EXTRACT(DAY_MINUTE FROM ''2009-07-02 01:02:03'') |'+sLineBreak - +'+------------------------------------------------+'+sLineBreak - +'| 20102 |'+sLineBreak - +'+------------------------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT EXTRACT(MICROSECOND FROM ''2003-01-02'+sLineBreak - +'10:30:00.000123'');'+sLineBreak - +'+--------------------------------------------------------+'+sLineBreak - +'| EXTRACT(MICROSECOND FROM ''2003-01-02 10:30:00.000123'') |'+sLineBreak - +'+--------------------------------------------------------+'+sLineBreak - +'| 123 |'+sLineBreak - +'+--------------------------------------------------------+'+sLineBreak - +' '+sLineBreak - +'From MariaDB 10.0.7 and MariaDB 5.5.35, EXTRACT (HOUR'+sLineBreak - +'FROM...) returns a value from 0 to 23, as per the SQL'+sLineBreak - +'standard. HOUR is not a standard function, so continues to'+sLineBreak - +'adhere to the old behaviour inherited from MySQL.'+sLineBreak - +' '+sLineBreak - +'SELECT EXTRACT(HOUR FROM ''26:30:00''), HOUR(''26:30:00'');'+sLineBreak - +'+-------------------------------+------------------+'+sLineBreak - +'| EXTRACT(HOUR FROM ''26:30:00'') | HOUR(''26:30:00'') |'+sLineBreak - +'+-------------------------------+------------------+'+sLineBreak - +'| 2 | 26 |'+sLineBreak - +'+-------------------------------+------------------+' - ), - - ( - Name: 'FROM_DAYS'; - Declaration: '(N)'; - Category: 'Date and Time Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Given a day number N, returns a DATE value. The day count is'+sLineBreak - +'based on the number of days from the start of the standard'+sLineBreak - +'calendar (0000-00-00). '+sLineBreak - +' '+sLineBreak - +'The function is not designed for use with dates before the'+sLineBreak - +'advent of the Gregorian calendar in October 1582. Results'+sLineBreak - +'will not be reliable since it doesn''t account for the lost'+sLineBreak - +'days when the calendar changed from the Julian calendar.'+sLineBreak - +' '+sLineBreak - +'This is the converse of the TO_DAYS() function.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT FROM_DAYS(730669);'+sLineBreak - +'+-------------------+'+sLineBreak - +'| FROM_DAYS(730669) |'+sLineBreak - +'+-------------------+'+sLineBreak - +'| 2000-07-03 |'+sLineBreak - +'+-------------------+' - ), - - ( - Name: 'FROM_UNIXTIME'; - Declaration: '(unix_timestamp)'; - Category: 'Date and Time Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns a representation of the unix_timestamp argument as a'+sLineBreak - +'value in'+sLineBreak - +'''YYYY-MM-DD HH:MM:SS'' or YYYYMMDDHHMMSS.uuuuuu format,'+sLineBreak - +'depending on'+sLineBreak - +'whether the function is used in a string or numeric context.'+sLineBreak - +'The value'+sLineBreak - +'is expressed in the current time zone. unix_timestamp is an'+sLineBreak - +'internal'+sLineBreak - +'timestamp value such as is produced by the UNIX_TIMESTAMP()'+sLineBreak - +'function.'+sLineBreak - +' '+sLineBreak - +'If format is given, the result is formatted according to the'+sLineBreak - +'format'+sLineBreak - +'string, which is used the same way as listed in the entry'+sLineBreak - +'for the'+sLineBreak - +'DATE_FORMAT() function.'+sLineBreak - +' '+sLineBreak - +'Timestamps in MariaDB have a maximum value of 2147483647,'+sLineBreak - +'equivalent to 2038-01-19 05:14:07. This is due to the'+sLineBreak - +'underlying 32-bit limitation. Using the function on a'+sLineBreak - +'timestamp beyond this will result in NULL being returned.'+sLineBreak - +'Use DATETIME as a storage type if you require dates beyond'+sLineBreak - +'this.'+sLineBreak - +' '+sLineBreak - +'The options that can be used by FROM_UNIXTIME(), as well as'+sLineBreak - +'DATE_FORMAT() and STR_TO_DATE(), are:'+sLineBreak - +' '+sLineBreak - +'Option | Description | '+sLineBreak - +' '+sLineBreak - +'%a | Short weekday name in current locale (Variable'+sLineBreak - +'lc_time_names). | '+sLineBreak - +' '+sLineBreak - +'%b | Short form month name in current locale. For locale'+sLineBreak - +'en_US this is one of:'+sLineBreak - +'Jan,Feb,Mar,Apr,May,Jun,Jul,Aug,Sep,Oct,Nov or Dec. | '+sLineBreak - +' '+sLineBreak - +'%c | Month with 1 or 2 digits. | '+sLineBreak - +' '+sLineBreak - +'%D | Day with English suffix ''th'', ''nd'', ''st'' or'+sLineBreak - +'''rd''''. (1st, 2nd, 3rd...). | '+sLineBreak - +' '+sLineBreak - +'%d | Day with 2 digits. | '+sLineBreak - +' '+sLineBreak - +'%e | Day with 1 or 2 digits. | '+sLineBreak - +' '+sLineBreak - +'%f | Sub seconds 6 digits. | '+sLineBreak - +' '+sLineBreak - +'%H | Hour with 2 digits between 00-23. | '+sLineBreak - +' '+sLineBreak - +'%h | Hour with 2 digits between 01-12. | '+sLineBreak - +' '+sLineBreak - +'%I | Hour with 2 digits between 01-12. | '+sLineBreak - +' '+sLineBreak - +'%i | Minute with 2 digits. | '+sLineBreak - +' '+sLineBreak - +'%j | Day of the year (001-366) | '+sLineBreak - +' '+sLineBreak - +'%k | Hour with 1 digits between 0-23. | '+sLineBreak - +' '+sLineBreak - +'%l | Hour with 1 digits between 1-12. | '+sLineBreak - +' '+sLineBreak - +'%M | Full month name in current locale (Variable'+sLineBreak - +'lc_time_names). | '+sLineBreak - +' '+sLineBreak - +'%m | Month with 2 digits. | '+sLineBreak - +' '+sLineBreak - +'%p | AM/PM according to current locale (Variable'+sLineBreak - +'lc_time_names). | '+sLineBreak - +' '+sLineBreak - +'%r | Time in 12 hour format, followed by AM/PM. Short for'+sLineBreak - +'''%I:%i:%S %p''. | '+sLineBreak - +' '+sLineBreak - +'%S | Seconds with 2 digits. | '+sLineBreak - +' '+sLineBreak - +'%s | Seconds with 2 digits. | '+sLineBreak - +' '+sLineBreak - +'%T | Time in 24 hour format. Short for ''%H:%i:%S''. | '+sLineBreak - +' '+sLineBreak - +'%U | Week number (00-53), when first day of the week is'+sLineBreak - +'Sunday. | '+sLineBreak - +' '+sLineBreak - +'%u | Week number (00-53), when first day of the week is'+sLineBreak - +'Monday. | '+sLineBreak - +' '+sLineBreak - +'%V | Week number (01-53), when first day of the week is'+sLineBreak - +'Sunday. Used with %X. | '+sLineBreak - +' '+sLineBreak - +'%v | Week number (01-53), when first day of the week is'+sLineBreak - +'Monday. Used with %x. | '+sLineBreak - +' '+sLineBreak - +'%W | Full weekday name in current locale (Variable'+sLineBreak - +'lc_time_names). | '+sLineBreak - +' '+sLineBreak - +'%w | Day of the week. 0 = Sunday, 1 = Saturday. | '+sLineBreak - +' '+sLineBreak - +'%X | Year with 4 digits when first day of the week is'+sLineBreak - +'Sunday. Used with %V. | '+sLineBreak - +' '+sLineBreak - +'%x | Year with 4 digits when first day of the week is'+sLineBreak - +'Sunday. Used with %v. | '+sLineBreak - +' '+sLineBreak - +'%Y | Year with 4 digits. | '+sLineBreak - +' '+sLineBreak - +'%y | Year with 2 digits. | '+sLineBreak - +' '+sLineBreak - +'%# | For str_to_date(), skip all numbers. | '+sLineBreak - +' '+sLineBreak - +'%. | For str_to_date(), skip all punctation characters. | '+sLineBreak - +' '+sLineBreak - +'%@ | For str_to_date(), skip all alpha characters. | '+sLineBreak - +' '+sLineBreak - +'%% | A literal % character. | '+sLineBreak - +' '+sLineBreak - +'Performance Considerations'+sLineBreak - +' '+sLineBreak - +'If your session time zone is set to SYSTEM (the default),'+sLineBreak - +'FROM_UNIXTIME() will call the OS function to convert the'+sLineBreak - +'data using the system time zone. At least on Linux, the'+sLineBreak - +'corresponding function (localtime_r) uses a global mutex'+sLineBreak - +'inside glibc that can cause contention under high concurrent'+sLineBreak - +'load.'+sLineBreak - +' '+sLineBreak - +'Set your time zone to a named time zone to avoid this issue.'+sLineBreak - +'See mysql time zone tables for details on how to do this.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT FROM_UNIXTIME(1196440219);'+sLineBreak - +'+---------------------------+'+sLineBreak - +'| FROM_UNIXTIME(1196440219) |'+sLineBreak - +'+---------------------------+'+sLineBreak - +'| 2007-11-30 11:30:19 |'+sLineBreak - +'+---------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT FROM_UNIXTIME(1196440219) + 0;'+sLineBreak - +' '+sLineBreak - +'+-------------------------------+'+sLineBreak - +'| FROM_UNIXTIME(1196440219) + 0 |'+sLineBreak - +'+-------------------------------+'+sLineBreak - +'| 20071130113019.000000 |'+sLineBreak - +'+-------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT FROM_UNIXTIME(UNIX_TIMESTAMP(), ''%Y %D %M %h:%i:%s'+sLineBreak - +'%x'');'+sLineBreak - +'+---------------------------------------------------------+'+sLineBreak - +'| FROM_UNIXTIME(UNIX_TIMESTAMP(), ''%Y %D %M %h:%i:%s %x'')'+sLineBreak - +'|'+sLineBreak - +'+---------------------------------------------------------+'+sLineBreak - +'| 2010 27th March 01:03:47 2010 |'+sLineBreak - +'+---------------------------------------------------------+' - ), - - ( - Name: 'FROM_UNIXTIME'; - Declaration: '(unix_timestamp,format)'; - Category: 'Date and Time Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns a representation of the unix_timestamp argument as a'+sLineBreak - +'value in'+sLineBreak - +'''YYYY-MM-DD HH:MM:SS'' or YYYYMMDDHHMMSS.uuuuuu format,'+sLineBreak - +'depending on'+sLineBreak - +'whether the function is used in a string or numeric context.'+sLineBreak - +'The value'+sLineBreak - +'is expressed in the current time zone. unix_timestamp is an'+sLineBreak - +'internal'+sLineBreak - +'timestamp value such as is produced by the UNIX_TIMESTAMP()'+sLineBreak - +'function.'+sLineBreak - +' '+sLineBreak - +'If format is given, the result is formatted according to the'+sLineBreak - +'format'+sLineBreak - +'string, which is used the same way as listed in the entry'+sLineBreak - +'for the'+sLineBreak - +'DATE_FORMAT() function.'+sLineBreak - +' '+sLineBreak - +'Timestamps in MariaDB have a maximum value of 2147483647,'+sLineBreak - +'equivalent to 2038-01-19 05:14:07. This is due to the'+sLineBreak - +'underlying 32-bit limitation. Using the function on a'+sLineBreak - +'timestamp beyond this will result in NULL being returned.'+sLineBreak - +'Use DATETIME as a storage type if you require dates beyond'+sLineBreak - +'this.'+sLineBreak - +' '+sLineBreak - +'The options that can be used by FROM_UNIXTIME(), as well as'+sLineBreak - +'DATE_FORMAT() and STR_TO_DATE(), are:'+sLineBreak - +' '+sLineBreak - +'Option | Description | '+sLineBreak - +' '+sLineBreak - +'%a | Short weekday name in current locale (Variable'+sLineBreak - +'lc_time_names). | '+sLineBreak - +' '+sLineBreak - +'%b | Short form month name in current locale. For locale'+sLineBreak - +'en_US this is one of:'+sLineBreak - +'Jan,Feb,Mar,Apr,May,Jun,Jul,Aug,Sep,Oct,Nov or Dec. | '+sLineBreak - +' '+sLineBreak - +'%c | Month with 1 or 2 digits. | '+sLineBreak - +' '+sLineBreak - +'%D | Day with English suffix ''th'', ''nd'', ''st'' or'+sLineBreak - +'''rd''''. (1st, 2nd, 3rd...). | '+sLineBreak - +' '+sLineBreak - +'%d | Day with 2 digits. | '+sLineBreak - +' '+sLineBreak - +'%e | Day with 1 or 2 digits. | '+sLineBreak - +' '+sLineBreak - +'%f | Sub seconds 6 digits. | '+sLineBreak - +' '+sLineBreak - +'%H | Hour with 2 digits between 00-23. | '+sLineBreak - +' '+sLineBreak - +'%h | Hour with 2 digits between 01-12. | '+sLineBreak - +' '+sLineBreak - +'%I | Hour with 2 digits between 01-12. | '+sLineBreak - +' '+sLineBreak - +'%i | Minute with 2 digits. | '+sLineBreak - +' '+sLineBreak - +'%j | Day of the year (001-366) | '+sLineBreak - +' '+sLineBreak - +'%k | Hour with 1 digits between 0-23. | '+sLineBreak - +' '+sLineBreak - +'%l | Hour with 1 digits between 1-12. | '+sLineBreak - +' '+sLineBreak - +'%M | Full month name in current locale (Variable'+sLineBreak - +'lc_time_names). | '+sLineBreak - +' '+sLineBreak - +'%m | Month with 2 digits. | '+sLineBreak - +' '+sLineBreak - +'%p | AM/PM according to current locale (Variable'+sLineBreak - +'lc_time_names). | '+sLineBreak - +' '+sLineBreak - +'%r | Time in 12 hour format, followed by AM/PM. Short for'+sLineBreak - +'''%I:%i:%S %p''. | '+sLineBreak - +' '+sLineBreak - +'%S | Seconds with 2 digits. | '+sLineBreak - +' '+sLineBreak - +'%s | Seconds with 2 digits. | '+sLineBreak - +' '+sLineBreak - +'%T | Time in 24 hour format. Short for ''%H:%i:%S''. | '+sLineBreak - +' '+sLineBreak - +'%U | Week number (00-53), when first day of the week is'+sLineBreak - +'Sunday. | '+sLineBreak - +' '+sLineBreak - +'%u | Week number (00-53), when first day of the week is'+sLineBreak - +'Monday. | '+sLineBreak - +' '+sLineBreak - +'%V | Week number (01-53), when first day of the week is'+sLineBreak - +'Sunday. Used with %X. | '+sLineBreak - +' '+sLineBreak - +'%v | Week number (01-53), when first day of the week is'+sLineBreak - +'Monday. Used with %x. | '+sLineBreak - +' '+sLineBreak - +'%W | Full weekday name in current locale (Variable'+sLineBreak - +'lc_time_names). | '+sLineBreak - +' '+sLineBreak - +'%w | Day of the week. 0 = Sunday, 1 = Saturday. | '+sLineBreak - +' '+sLineBreak - +'%X | Year with 4 digits when first day of the week is'+sLineBreak - +'Sunday. Used with %V. | '+sLineBreak - +' '+sLineBreak - +'%x | Year with 4 digits when first day of the week is'+sLineBreak - +'Sunday. Used with %v. | '+sLineBreak - +' '+sLineBreak - +'%Y | Year with 4 digits. | '+sLineBreak - +' '+sLineBreak - +'%y | Year with 2 digits. | '+sLineBreak - +' '+sLineBreak - +'%# | For str_to_date(), skip all numbers. | '+sLineBreak - +' '+sLineBreak - +'%. | For str_to_date(), skip all punctation characters. | '+sLineBreak - +' '+sLineBreak - +'%@ | For str_to_date(), skip all alpha characters. | '+sLineBreak - +' '+sLineBreak - +'%% | A literal % character. | '+sLineBreak - +' '+sLineBreak - +'Performance Considerations'+sLineBreak - +' '+sLineBreak - +'If your session time zone is set to SYSTEM (the default),'+sLineBreak - +'FROM_UNIXTIME() will call the OS function to convert the'+sLineBreak - +'data using the system time zone. At least on Linux, the'+sLineBreak - +'corresponding function (localtime_r) uses a global mutex'+sLineBreak - +'inside glibc that can cause contention under high concurrent'+sLineBreak - +'load.'+sLineBreak - +' '+sLineBreak - +'Set your time zone to a named time zone to avoid this issue.'+sLineBreak - +'See mysql time zone tables for details on how to do this.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT FROM_UNIXTIME(1196440219);'+sLineBreak - +'+---------------------------+'+sLineBreak - +'| FROM_UNIXTIME(1196440219) |'+sLineBreak - +'+---------------------------+'+sLineBreak - +'| 2007-11-30 11:30:19 |'+sLineBreak - +'+---------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT FROM_UNIXTIME(1196440219) + 0;'+sLineBreak - +' '+sLineBreak - +'+-------------------------------+'+sLineBreak - +'| FROM_UNIXTIME(1196440219) + 0 |'+sLineBreak - +'+-------------------------------+'+sLineBreak - +'| 20071130113019.000000 |'+sLineBreak - +'+-------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT FROM_UNIXTIME(UNIX_TIMESTAMP(), ''%Y %D %M %h:%i:%s'+sLineBreak - +'%x'');'+sLineBreak - +'+---------------------------------------------------------+'+sLineBreak - +'| FROM_UNIXTIME(UNIX_TIMESTAMP(), ''%Y %D %M %h:%i:%s %x'')'+sLineBreak - +'|'+sLineBreak - +'+---------------------------------------------------------+'+sLineBreak - +'| 2010 27th March 01:03:47 2010 |'+sLineBreak - +'+---------------------------------------------------------+' - ), - - ( - Name: 'GET_FORMAT'; - Declaration: '({DATE|DATETIME|TIME}, {''EUR''|''USA''|''JIS''|''ISO''|''INTERNAL''})'; - Category: 'Date and Time Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns a format string. This function is useful in'+sLineBreak - +'combination with'+sLineBreak - +'the DATE_FORMAT() and the STR_TO_DATE() functions.'+sLineBreak - +' '+sLineBreak - +'Possible result formats are:'+sLineBreak - +' '+sLineBreak - +'Function Call | Result Format | '+sLineBreak - +' '+sLineBreak - +'GET_FORMAT(DATE,''EUR'') | ''%d.%m.%Y'' | '+sLineBreak - +' '+sLineBreak - +'GET_FORMAT(DATE,''USA'') | ''%m.%d.%Y'' | '+sLineBreak - +' '+sLineBreak - +'GET_FORMAT(DATE,''JIS'') | ''%Y-%m-%d'' | '+sLineBreak - +' '+sLineBreak - +'GET_FORMAT(DATE,''ISO'') | ''%Y-%m-%d'' | '+sLineBreak - +' '+sLineBreak - +'GET_FORMAT(DATE,''INTERNAL'') | ''%Y%m%d'' | '+sLineBreak - +' '+sLineBreak - +'GET_FORMAT(DATETIME,''EUR'') | ''%Y-%m-%d %H.%i.%s'' | '+sLineBreak - +' '+sLineBreak - +'GET_FORMAT(DATETIME,''USA'') | ''%Y-%m-%d %H.%i.%s'' | '+sLineBreak - +' '+sLineBreak - +'GET_FORMAT(DATETIME,''JIS'') | ''%Y-%m-%d %H:%i:%s'' | '+sLineBreak - +' '+sLineBreak - +'GET_FORMAT(DATETIME,''ISO'') | ''%Y-%m-%d %H:%i:%s'' | '+sLineBreak - +' '+sLineBreak - +'GET_FORMAT(DATETIME,''INTERNAL'') | ''%Y%m%d%H%i%s'' | '+sLineBreak - +' '+sLineBreak - +'GET_FORMAT(TIME,''EUR'') | ''%H.%i.%s'' | '+sLineBreak - +' '+sLineBreak - +'GET_FORMAT(TIME,''USA'') | ''%h:%i:%s %p'' | '+sLineBreak - +' '+sLineBreak - +'GET_FORMAT(TIME,''JIS'') | ''%H:%i:%s'' | '+sLineBreak - +' '+sLineBreak - +'GET_FORMAT(TIME,''ISO'') | ''%H:%i:%s'' | '+sLineBreak - +' '+sLineBreak - +'GET_FORMAT(TIME,''INTERNAL'') | ''%H%i%s'' | '+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'Obtaining the string matching to the standard European date'+sLineBreak - +'format:'+sLineBreak - +' '+sLineBreak - +'SELECT GET_FORMAT(DATE, ''EUR'');'+sLineBreak - +'+-------------------------+'+sLineBreak - +'| GET_FORMAT(DATE, ''EUR'') |'+sLineBreak - +'+-------------------------+'+sLineBreak - +'| %d.%m.%Y |'+sLineBreak - +'+-------------------------+'+sLineBreak - +' '+sLineBreak - +'Using the same string to format a date:'+sLineBreak - +' '+sLineBreak - +'SELECT DATE_FORMAT(''2003-10-03'',GET_FORMAT(DATE,''EUR''));'+sLineBreak - +'+--------------------------------------------------+'+sLineBreak - +'| DATE_FORMAT(''2003-10-03'',GET_FORMAT(DATE,''EUR'')) |'+sLineBreak - +'+--------------------------------------------------+'+sLineBreak - +'| 03.10.2003 |'+sLineBreak - +'+--------------------------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT STR_TO_DATE(''10.31.2003'',GET_FORMAT(DATE,''USA''));'+sLineBreak - +'+--------------------------------------------------+'+sLineBreak - +'| STR_TO_DATE(''10.31.2003'',GET_FORMAT(DATE,''USA'')) |'+sLineBreak - +'+--------------------------------------------------+'+sLineBreak - +'| 2003-10-31 |'+sLineBreak - +'+--------------------------------------------------+' - ), - - ( - Name: 'HOUR'; - Declaration: '(time)'; - Category: 'Date and Time Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the hour for time. The range of the return value is'+sLineBreak - +'0 to 23'+sLineBreak - +'for time-of-day values. However, the range of TIME values'+sLineBreak - +'actually is'+sLineBreak - +'much larger, so HOUR can return values greater than 23.'+sLineBreak - +' '+sLineBreak - +'The return value is always positive, even if a negative TIME'+sLineBreak - +'value is provided.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT HOUR(''10:05:03'');'+sLineBreak - +'+------------------+'+sLineBreak - +'| HOUR(''10:05:03'') |'+sLineBreak - +'+------------------+'+sLineBreak - +'| 10 |'+sLineBreak - +'+------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT HOUR(''272:59:59'');'+sLineBreak - +'+-------------------+'+sLineBreak - +'| HOUR(''272:59:59'') |'+sLineBreak - +'+-------------------+'+sLineBreak - +'| 272 |'+sLineBreak - +'+-------------------+'+sLineBreak - +' '+sLineBreak - +'Difference between EXTRACT (HOUR FROM ...) (>= MariaDB'+sLineBreak - +'10.0.7 and MariaDB 5.5.35) and HOUR:'+sLineBreak - +' '+sLineBreak - +'SELECT EXTRACT(HOUR FROM ''26:30:00''), HOUR(''26:30:00'');'+sLineBreak - +'+-------------------------------+------------------+'+sLineBreak - +'| EXTRACT(HOUR FROM ''26:30:00'') | HOUR(''26:30:00'') |'+sLineBreak - +'+-------------------------------+------------------+'+sLineBreak - +'| 2 | 26 |'+sLineBreak - +'+-------------------------------+------------------+' - ), - - ( - Name: 'LAST_DAY'; - Declaration: '(date)'; - Category: 'Date and Time Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Takes a date or datetime value and returns the corresponding'+sLineBreak - +'value for'+sLineBreak - +'the last day of the month. Returns NULL if the argument is'+sLineBreak - +'invalid.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT LAST_DAY(''2003-02-05'');'+sLineBreak - +'+------------------------+'+sLineBreak - +'| LAST_DAY(''2003-02-05'') |'+sLineBreak - +'+------------------------+'+sLineBreak - +'| 2003-02-28 |'+sLineBreak - +'+------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT LAST_DAY(''2004-02-05'');'+sLineBreak - +'+------------------------+'+sLineBreak - +'| LAST_DAY(''2004-02-05'') |'+sLineBreak - +'+------------------------+'+sLineBreak - +'| 2004-02-29 |'+sLineBreak - +'+------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT LAST_DAY(''2004-01-01 01:01:01'');'+sLineBreak - +'+---------------------------------+'+sLineBreak - +'| LAST_DAY(''2004-01-01 01:01:01'') |'+sLineBreak - +'+---------------------------------+'+sLineBreak - +'| 2004-01-31 |'+sLineBreak - +'+---------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT LAST_DAY(''2003-03-32'');'+sLineBreak - +'+------------------------+'+sLineBreak - +'| LAST_DAY(''2003-03-32'') |'+sLineBreak - +'+------------------------+'+sLineBreak - +'| NULL |'+sLineBreak - +'+------------------------+'+sLineBreak - +'1 row in set, 1 warning (0.00 sec)'+sLineBreak - +' '+sLineBreak - +'Warning (Code 1292): Incorrect datetime value:'+sLineBreak - +'''2003-03-32''' - ), - - ( - Name: 'MAKEDATE'; - Declaration: '(year,dayofyear)'; - Category: 'Date and Time Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns a date, given year and day-of-year values. dayofyear'+sLineBreak - +'must be'+sLineBreak - +'greater than 0 or the result is NULL.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT MAKEDATE(2011,31), MAKEDATE(2011,32);'+sLineBreak - +'+-------------------+-------------------+'+sLineBreak - +'| MAKEDATE(2011,31) | MAKEDATE(2011,32) |'+sLineBreak - +'+-------------------+-------------------+'+sLineBreak - +'| 2011-01-31 | 2011-02-01 |'+sLineBreak - +'+-------------------+-------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT MAKEDATE(2011,365), MAKEDATE(2014,365);'+sLineBreak - +'+--------------------+--------------------+'+sLineBreak - +'| MAKEDATE(2011,365) | MAKEDATE(2014,365) |'+sLineBreak - +'+--------------------+--------------------+'+sLineBreak - +'| 2011-12-31 | 2014-12-31 |'+sLineBreak - +'+--------------------+--------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT MAKEDATE(2011,0);'+sLineBreak - +'+------------------+'+sLineBreak - +'| MAKEDATE(2011,0) |'+sLineBreak - +'+------------------+'+sLineBreak - +'| NULL |'+sLineBreak - +'+------------------+' - ), - - ( - Name: 'MAKETIME'; - Declaration: '(hour,minute,second)'; - Category: 'Date and Time Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns a time value calculated from the hour, minute, and'+sLineBreak - +'second arguments.'+sLineBreak - +' '+sLineBreak - +'If minute or second are out of the range 0 to 60, NULL is'+sLineBreak - +'returned. The hour can be in the range -838 to 838, outside'+sLineBreak - +'of which the value is truncated with a warning.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT MAKETIME(13,57,33);'+sLineBreak - +'+--------------------+'+sLineBreak - +'| MAKETIME(13,57,33) |'+sLineBreak - +'+--------------------+'+sLineBreak - +'| 13:57:33 |'+sLineBreak - +'+--------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT MAKETIME(-13,57,33);'+sLineBreak - +'+---------------------+'+sLineBreak - +'| MAKETIME(-13,57,33) |'+sLineBreak - +'+---------------------+'+sLineBreak - +'| -13:57:33 |'+sLineBreak - +'+---------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT MAKETIME(13,67,33);'+sLineBreak - +'+--------------------+'+sLineBreak - +'| MAKETIME(13,67,33) |'+sLineBreak - +'+--------------------+'+sLineBreak - +'| NULL |'+sLineBreak - +'+--------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT MAKETIME(-1000,57,33);'+sLineBreak - +'+-----------------------+'+sLineBreak - +'| MAKETIME(-1000,57,33) |'+sLineBreak - +'+-----------------------+'+sLineBreak - +'| -838:59:59 |'+sLineBreak - +'+-----------------------+'+sLineBreak - +'1 row in set, 1 warning (0.00 sec)'+sLineBreak - +' '+sLineBreak - +'SHOW WARNINGS;'+sLineBreak - +' '+sLineBreak - +'+---------+------+-----------------------------------------------+'+sLineBreak - +'| Level | Code | Message |'+sLineBreak - +'+---------+------+-----------------------------------------------+'+sLineBreak - +'| Warning | 1292 | Truncated incorrect time value:'+sLineBreak - +'''-1000:57:33'' |'+sLineBreak - +'+---------+------+-----------------------------------------------+' - ), - - ( - Name: 'MICROSECOND'; - Declaration: '(expr)'; - Category: 'Date and Time Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the microseconds from the time or datetime'+sLineBreak - +'expression expr as a number in the range from 0 to 999999.'+sLineBreak - +' '+sLineBreak - +'If expr is a time with no microseconds, zero is returned,'+sLineBreak - +'while if expr is a date with no time, zero with a warning is'+sLineBreak - +'returned.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT MICROSECOND(''12:00:00.123456'');'+sLineBreak - +'+--------------------------------+'+sLineBreak - +'| MICROSECOND(''12:00:00.123456'') |'+sLineBreak - +'+--------------------------------+'+sLineBreak - +'| 123456 |'+sLineBreak - +'+--------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT MICROSECOND(''2009-12-31 23:59:59.000010'');'+sLineBreak - +'+-------------------------------------------+'+sLineBreak - +'| MICROSECOND(''2009-12-31 23:59:59.000010'') |'+sLineBreak - +'+-------------------------------------------+'+sLineBreak - +'| 10 |'+sLineBreak - +'+-------------------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT MICROSECOND(''2013-08-07 12:13:14'');'+sLineBreak - +'+------------------------------------+'+sLineBreak - +'| MICROSECOND(''2013-08-07 12:13:14'') |'+sLineBreak - +'+------------------------------------+'+sLineBreak - +'| 0 |'+sLineBreak - +'+------------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT MICROSECOND(''2013-08-07'');'+sLineBreak - +'+---------------------------+'+sLineBreak - +'| MICROSECOND(''2013-08-07'') |'+sLineBreak - +'+---------------------------+'+sLineBreak - +'| 0 |'+sLineBreak - +'+---------------------------+'+sLineBreak - +'1 row in set, 1 warning (0.00 sec)'+sLineBreak - +' '+sLineBreak - +'SHOW WARNINGS;'+sLineBreak - +' '+sLineBreak - +'+---------+------+----------------------------------------------+'+sLineBreak - +'| Level | Code | Message |'+sLineBreak - +'+---------+------+----------------------------------------------+'+sLineBreak - +'| Warning | 1292 | Truncated incorrect time value:'+sLineBreak - +'''2013-08-07'' |'+sLineBreak - +'+---------+------+----------------------------------------------+' - ), - - ( - Name: 'MINUTE'; - Declaration: '(time)'; - Category: 'Date and Time Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the minute for time, in the range 0 to 59. '+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT MINUTE(''2013-08-03 11:04:03'');'+sLineBreak - +'+-------------------------------+'+sLineBreak - +'| MINUTE(''2013-08-03 11:04:03'') |'+sLineBreak - +'+-------------------------------+'+sLineBreak - +'| 4 |'+sLineBreak - +'+-------------------------------+'+sLineBreak - +' '+sLineBreak - +' SELECT MINUTE (''23:12:50'');'+sLineBreak - +'+---------------------+'+sLineBreak - +'| MINUTE (''23:12:50'') |'+sLineBreak - +'+---------------------+'+sLineBreak - +'| 12 |'+sLineBreak - +'+---------------------+' - ), - - ( - Name: 'MONTH'; - Declaration: '(date)'; - Category: 'Date and Time Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the month for date in the range 1 to 12 for January'+sLineBreak - +'to'+sLineBreak - +'December, or 0 for dates such as ''0000-00-00'' or'+sLineBreak - +'''2008-00-00'' that'+sLineBreak - +'have a zero month part.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT MONTH(''2019-01-03'');'+sLineBreak - +'+---------------------+'+sLineBreak - +'| MONTH(''2019-01-03'') |'+sLineBreak - +'+---------------------+'+sLineBreak - +'| 1 |'+sLineBreak - +'+---------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT MONTH(''2019-00-03'');'+sLineBreak - +'+---------------------+'+sLineBreak - +'| MONTH(''2019-00-03'') |'+sLineBreak - +'+---------------------+'+sLineBreak - +'| 0 |'+sLineBreak - +'+---------------------+' - ), - - ( - Name: 'MONTHNAME'; - Declaration: '(date)'; - Category: 'Date and Time Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the full name of the month for date. The language'+sLineBreak - +'used for the name is controlled by the value of the'+sLineBreak - +'lc_time_names system variable. See server locale for more on'+sLineBreak - +'the supported locales.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT MONTHNAME(''2019-02-03'');'+sLineBreak - +'+-------------------------+'+sLineBreak - +'| MONTHNAME(''2019-02-03'') |'+sLineBreak - +'+-------------------------+'+sLineBreak - +'| February |'+sLineBreak - +'+-------------------------+'+sLineBreak - +' '+sLineBreak - +'Changing the locale:'+sLineBreak - +' '+sLineBreak - +'SET lc_time_names = ''fr_CA'';'+sLineBreak - +' '+sLineBreak - +'SELECT MONTHNAME(''2019-05-21'');'+sLineBreak - +'+-------------------------+'+sLineBreak - +'| MONTHNAME(''2019-05-21'') |'+sLineBreak - +'+-------------------------+'+sLineBreak - +'| mai |'+sLineBreak - +'+-------------------------+' - ), - - ( - Name: 'NOW'; - Declaration: '([precision])'; - Category: 'Date and Time Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the current date and time as a value in ''YYYY-MM-DD'+sLineBreak - +'HH:MM:SS'''+sLineBreak - +'or YYYYMMDDHHMMSS.uuuuuu format, depending on whether the'+sLineBreak - +'function is'+sLineBreak - +'used in a string or numeric context. The value is expressed'+sLineBreak - +'in the'+sLineBreak - +'current time zone.'+sLineBreak - +' '+sLineBreak - +'The optional precision determines the microsecond precision.'+sLineBreak - +'See Microseconds in MariaDB.'+sLineBreak - +' '+sLineBreak - +'NOW() (or its synonyms) can be used as the default value for'+sLineBreak - +'TIMESTAMP columns as well as, since MariaDB 10.0.1, DATETIME'+sLineBreak - +'columns. Before MariaDB 10.0.1, it was only possible for a'+sLineBreak - +'single TIMESTAMP column per table to contain the'+sLineBreak - +'CURRENT_TIMESTAMP as its default.'+sLineBreak - +' '+sLineBreak - +'When displayed in the INFORMATION_SCHEMA.COLUMNS table, a'+sLineBreak - +'default CURRENT TIMESTAMP is displayed as CURRENT_TIMESTAMP'+sLineBreak - +'up until MariaDB 10.2.2, and as current_timestamp() from'+sLineBreak - +'MariaDB 10.2.3, due to to MariaDB 10.2 accepting expressions'+sLineBreak - +'in the DEFAULT clause.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT NOW();'+sLineBreak - +'+---------------------+'+sLineBreak - +'| NOW() |'+sLineBreak - +'+---------------------+'+sLineBreak - +'| 2010-03-27 13:13:25 |'+sLineBreak - +'+---------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT NOW() + 0;'+sLineBreak - +' '+sLineBreak - +'+-----------------------+'+sLineBreak - +'| NOW() + 0 |'+sLineBreak - +'+-----------------------+'+sLineBreak - +'| 20100327131329.000000 |'+sLineBreak - +'+-----------------------+'+sLineBreak - +' '+sLineBreak - +'With precision:'+sLineBreak - +' '+sLineBreak - +'SELECT CURRENT_TIMESTAMP(2);'+sLineBreak - +'+------------------------+'+sLineBreak - +'| CURRENT_TIMESTAMP(2) |'+sLineBreak - +'+------------------------+'+sLineBreak - +'| 2018-07-10 09:47:26.24 |'+sLineBreak - +'+------------------------+'+sLineBreak - +' '+sLineBreak - +'Used as a default TIMESTAMP:'+sLineBreak - +' '+sLineBreak - +'CREATE TABLE t (createdTS TIMESTAMP NOT NULL DEFAULT'+sLineBreak - +'CURRENT_TIMESTAMP);'+sLineBreak - +' '+sLineBreak - +'From MariaDB 10.2.2:'+sLineBreak - +' '+sLineBreak - +'SELECT * FROM INFORMATION_SCHEMA.COLUMNS WHERE'+sLineBreak - +'TABLE_SCHEMA=''test'''+sLineBreak - +' AND COLUMN_NAME LIKE ''%ts%''\G'+sLineBreak - +'*************************** 1. row'+sLineBreak - +'***************************'+sLineBreak - +' TABLE_CATALOG: def'+sLineBreak - +' TABLE_SCHEMA: test'+sLineBreak - +' TABLE_NAME: t'+sLineBreak - +' COLUMN_NAME: ts'+sLineBreak - +' ORDINAL_POSITION: 1'+sLineBreak - +' COLUMN_DEFAULT: current_timestamp()'+sLineBreak - +'...' - ), - - ( - Name: 'PERIOD_ADD'; - Declaration: '(P,N)'; - Category: 'Date and Time Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Adds N months to period P. P is in the format YYMM or'+sLineBreak - +'YYYYMM, and is not a date value. If P contains a two-digit'+sLineBreak - +'year, values from 00 to 69 are converted to from 2000 to'+sLineBreak - +'2069, while values from 70 are converted to 1970 upwards.'+sLineBreak - +' '+sLineBreak - +'Returns a value in the format YYYYMM.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT PERIOD_ADD(200801,2);'+sLineBreak - +'+----------------------+'+sLineBreak - +'| PERIOD_ADD(200801,2) |'+sLineBreak - +'+----------------------+'+sLineBreak - +'| 200803 |'+sLineBreak - +'+----------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT PERIOD_ADD(6910,2);'+sLineBreak - +'+--------------------+'+sLineBreak - +'| PERIOD_ADD(6910,2) |'+sLineBreak - +'+--------------------+'+sLineBreak - +'| 206912 |'+sLineBreak - +'+--------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT PERIOD_ADD(7010,2);'+sLineBreak - +'+--------------------+'+sLineBreak - +'| PERIOD_ADD(7010,2) |'+sLineBreak - +'+--------------------+'+sLineBreak - +'| 197012 |'+sLineBreak - +'+--------------------+' - ), - - ( - Name: 'PERIOD_DIFF'; - Declaration: '(P1,P2)'; - Category: 'Date and Time Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the number of months between periods P1 and P2. P1'+sLineBreak - +'and P2 '+sLineBreak - +'can be in the format YYMM or YYYYMM, and are not date'+sLineBreak - +'values.'+sLineBreak - +' '+sLineBreak - +'If P1 or P2 contains a two-digit year, values from 00 to 69'+sLineBreak - +'are converted to from 2000 to 2069, while values from 70 are'+sLineBreak - +'converted to 1970 upwards.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT PERIOD_DIFF(200802,200703);'+sLineBreak - +'+----------------------------+'+sLineBreak - +'| PERIOD_DIFF(200802,200703) |'+sLineBreak - +'+----------------------------+'+sLineBreak - +'| 11 |'+sLineBreak - +'+----------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT PERIOD_DIFF(6902,6803);'+sLineBreak - +'+------------------------+'+sLineBreak - +'| PERIOD_DIFF(6902,6803) |'+sLineBreak - +'+------------------------+'+sLineBreak - +'| 11 |'+sLineBreak - +'+------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT PERIOD_DIFF(7002,6803);'+sLineBreak - +'+------------------------+'+sLineBreak - +'| PERIOD_DIFF(7002,6803) |'+sLineBreak - +'+------------------------+'+sLineBreak - +'| -1177 |'+sLineBreak - +'+------------------------+' - ), - - ( - Name: 'QUARTER'; - Declaration: '(date)'; - Category: 'Date and Time Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the quarter of the year for date, in the range 1 to'+sLineBreak - +'4. Returns 0 if month contains a zero value, or NULL if the'+sLineBreak - +'given value is not otherwise a valid date (zero values are'+sLineBreak - +'accepted).'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT QUARTER(''2008-04-01'');'+sLineBreak - +'+-----------------------+'+sLineBreak - +'| QUARTER(''2008-04-01'') |'+sLineBreak - +'+-----------------------+'+sLineBreak - +'| 2 |'+sLineBreak - +'+-----------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT QUARTER(''2019-00-01'');'+sLineBreak - +'+-----------------------+'+sLineBreak - +'| QUARTER(''2019-00-01'') |'+sLineBreak - +'+-----------------------+'+sLineBreak - +'| 0 |'+sLineBreak - +'+-----------------------+' - ), - - ( - Name: 'SECOND'; - Declaration: '(time)'; - Category: 'Date and Time Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the second for a given time (which can include'+sLineBreak - +'microseconds), in the range 0 to 59, or NULL if not given a'+sLineBreak - +'valid time value.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT SECOND(''10:05:03'');'+sLineBreak - +'+--------------------+'+sLineBreak - +'| SECOND(''10:05:03'') |'+sLineBreak - +'+--------------------+'+sLineBreak - +'| 3 |'+sLineBreak - +'+--------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT SECOND(''10:05:01.999999'');'+sLineBreak - +'+---------------------------+'+sLineBreak - +'| SECOND(''10:05:01.999999'') |'+sLineBreak - +'+---------------------------+'+sLineBreak - +'| 1 |'+sLineBreak - +'+---------------------------+' - ), - - ( - Name: 'SEC_TO_TIME'; - Declaration: '(seconds)'; - Category: 'Date and Time Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the seconds argument, converted to hours, minutes,'+sLineBreak - +'and'+sLineBreak - +'seconds, as a TIME value. The range of the result is'+sLineBreak - +'constrained to'+sLineBreak - +'that of the TIME data type. A warning occurs if the argument'+sLineBreak - +'corresponds to a value outside that range.'+sLineBreak - +' '+sLineBreak - +'The time will be returned in the format hh:mm:ss, or hhmmss'+sLineBreak - +'if used in a numeric calculation.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT SEC_TO_TIME(12414);'+sLineBreak - +'+--------------------+'+sLineBreak - +'| SEC_TO_TIME(12414) |'+sLineBreak - +'+--------------------+'+sLineBreak - +'| 03:26:54 |'+sLineBreak - +'+--------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT SEC_TO_TIME(12414)+0;'+sLineBreak - +' '+sLineBreak - +'+----------------------+'+sLineBreak - +'| SEC_TO_TIME(12414)+0 |'+sLineBreak - +'+----------------------+'+sLineBreak - +'| 32654 |'+sLineBreak - +'+----------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT SEC_TO_TIME(9999999);'+sLineBreak - +'+----------------------+'+sLineBreak - +'| SEC_TO_TIME(9999999) |'+sLineBreak - +'+----------------------+'+sLineBreak - +'| 838:59:59 |'+sLineBreak - +'+----------------------+'+sLineBreak - +'1 row in set, 1 warning (0.00 sec)'+sLineBreak - +' '+sLineBreak - +'SHOW WARNINGS;'+sLineBreak - +' '+sLineBreak - +'+---------+------+-------------------------------------------+'+sLineBreak - +'| Level | Code | Message |'+sLineBreak - +'+---------+------+-------------------------------------------+'+sLineBreak - +'| Warning | 1292 | Truncated incorrect time value:'+sLineBreak - +'''9999999'' |'+sLineBreak - +'+---------+------+-------------------------------------------+' - ), - - ( - Name: 'STR_TO_DATE'; - Declaration: '(str,format)'; - Category: 'Date and Time Functions'; - Version: SQL_VERSION_ANSI; - Description: 'This is the inverse of the DATE_FORMAT() function. It takes'+sLineBreak - +'a string str and a format string format. STR_TO_DATE()'+sLineBreak - +'returns a'+sLineBreak - +'DATETIME value if the format string contains both date and'+sLineBreak - +'time parts, or a'+sLineBreak - +'DATE or TIME value if the string contains only date or time'+sLineBreak - +'parts.'+sLineBreak - +' '+sLineBreak - +'The date, time, or datetime values contained in str should'+sLineBreak - +'be given in the format indicated by format. If str contains'+sLineBreak - +'an illegal date, time, or datetime value, STR_TO_DATE()'+sLineBreak - +'returns NULL. An illegal value also produces a warning.'+sLineBreak - +' '+sLineBreak - +'The options that can be used by STR_TO_DATE(), as well as'+sLineBreak - +'its inverse DATE_FORMAT() and the FROM_UNIXTIME() function,'+sLineBreak - +'are:'+sLineBreak - +' '+sLineBreak - +'Option | Description | '+sLineBreak - +' '+sLineBreak - +'%a | Short weekday name in current locale (Variable'+sLineBreak - +'lc_time_names). | '+sLineBreak - +' '+sLineBreak - +'%b | Short form month name in current locale. For locale'+sLineBreak - +'en_US this is one of:'+sLineBreak - +'Jan,Feb,Mar,Apr,May,Jun,Jul,Aug,Sep,Oct,Nov or Dec. | '+sLineBreak - +' '+sLineBreak - +'%c | Month with 1 or 2 digits. | '+sLineBreak - +' '+sLineBreak - +'%D | Day with English suffix ''th'', ''nd'', ''st'' or'+sLineBreak - +'''rd''''. (1st, 2nd, 3rd...). | '+sLineBreak - +' '+sLineBreak - +'%d | Day with 2 digits. | '+sLineBreak - +' '+sLineBreak - +'%e | Day with 1 or 2 digits. | '+sLineBreak - +' '+sLineBreak - +'%f | Sub seconds 6 digits. | '+sLineBreak - +' '+sLineBreak - +'%H | Hour with 2 digits between 00-23. | '+sLineBreak - +' '+sLineBreak - +'%h | Hour with 2 digits between 01-12. | '+sLineBreak - +' '+sLineBreak - +'%I | Hour with 2 digits between 01-12. | '+sLineBreak - +' '+sLineBreak - +'%i | Minute with 2 digits. | '+sLineBreak - +' '+sLineBreak - +'%j | Day of the year (001-366) | '+sLineBreak - +' '+sLineBreak - +'%k | Hour with 1 digits between 0-23. | '+sLineBreak - +' '+sLineBreak - +'%l | Hour with 1 digits between 1-12. | '+sLineBreak - +' '+sLineBreak - +'%M | Full month name in current locale (Variable'+sLineBreak - +'lc_time_names). | '+sLineBreak - +' '+sLineBreak - +'%m | Month with 2 digits. | '+sLineBreak - +' '+sLineBreak - +'%p | AM/PM according to current locale (Variable'+sLineBreak - +'lc_time_names). | '+sLineBreak - +' '+sLineBreak - +'%r | Time in 12 hour format, followed by AM/PM. Short for'+sLineBreak - +'''%I:%i:%S %p''. | '+sLineBreak - +' '+sLineBreak - +'%S | Seconds with 2 digits. | '+sLineBreak - +' '+sLineBreak - +'%s | Seconds with 2 digits. | '+sLineBreak - +' '+sLineBreak - +'%T | Time in 24 hour format. Short for ''%H:%i:%S''. | '+sLineBreak - +' '+sLineBreak - +'%U | Week number (00-53), when first day of the week is'+sLineBreak - +'Sunday. | '+sLineBreak - +' '+sLineBreak - +'%u | Week number (00-53), when first day of the week is'+sLineBreak - +'Monday. | '+sLineBreak - +' '+sLineBreak - +'%V | Week number (01-53), when first day of the week is'+sLineBreak - +'Sunday. Used with %X. | '+sLineBreak - +' '+sLineBreak - +'%v | Week number (01-53), when first day of the week is'+sLineBreak - +'Monday. Used with %x. | '+sLineBreak - +' '+sLineBreak - +'%W | Full weekday name in current locale (Variable'+sLineBreak - +'lc_time_names). | '+sLineBreak - +' '+sLineBreak - +'%w | Day of the week. 0 = Sunday, 6 = Saturday. | '+sLineBreak - +' '+sLineBreak - +'%X | Year with 4 digits when first day of the week is'+sLineBreak - +'Sunday. Used with %V. | '+sLineBreak - +' '+sLineBreak - +'%x | Year with 4 digits when first day of the week is'+sLineBreak - +'Monday. Used with %v. | '+sLineBreak - +' '+sLineBreak - +'%Y | Year with 4 digits. | '+sLineBreak - +' '+sLineBreak - +'%y | Year with 2 digits. | '+sLineBreak - +' '+sLineBreak - +'%# | For str_to_date(), skip all numbers. | '+sLineBreak - +' '+sLineBreak - +'%. | For str_to_date(), skip all punctation characters. | '+sLineBreak - +' '+sLineBreak - +'%@ | For str_to_date(), skip all alpha characters. | '+sLineBreak - +' '+sLineBreak - +'%% | A literal % character. | '+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT STR_TO_DATE(''Wednesday, June 2, 2014'', ''%W, %M %e,'+sLineBreak - +'%Y'');'+sLineBreak - +'+---------------------------------------------------------+'+sLineBreak - +'| STR_TO_DATE(''Wednesday, June 2, 2014'', ''%W, %M %e,'+sLineBreak - +'%Y'') |'+sLineBreak - +'+---------------------------------------------------------+'+sLineBreak - +'| 2014-06-02 |'+sLineBreak - +'+---------------------------------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT STR_TO_DATE(''Wednesday23423, June 2, 2014'', ''%W,'+sLineBreak - +'%M %e, %Y'');'+sLineBreak - +'+--------------------------------------------------------------+'+sLineBreak - +'| STR_TO_DATE(''Wednesday23423, June 2, 2014'', ''%W, %M %e,'+sLineBreak - +'%Y'') |'+sLineBreak - +'+--------------------------------------------------------------+'+sLineBreak - +'| NULL |'+sLineBreak - +'+--------------------------------------------------------------+'+sLineBreak - +'1 row in set, 1 warning (0.00 sec)'+sLineBreak - +' '+sLineBreak - +'SHOW WARNINGS;'+sLineBreak - +' '+sLineBreak - +'+---------+------+-----------------------------------------------------------------------------------+'+sLineBreak - +'| Level | Code | Message |'+sLineBreak - +'+---------+------+-----------------------------------------------------------------------------------+'+sLineBreak - +'| Warning | 1411 | Incorrect datetime value:'+sLineBreak - +'''Wednesday23423, June 2, 2014'' for function str_to_date |'+sLineBreak - +'+---------+------+-----------------------------------------------------------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT STR_TO_DATE(''Wednesday23423, June 2, 2014'', ''%W%#,'+sLineBreak - +'%M %e, %Y'');'+sLineBreak - +'+----------------------------------------------------------------+'+sLineBreak - +'| STR_TO_DATE(''Wednesday23423, June 2, 2014'', ''%W%#, %M'+sLineBreak - +'%e, %Y'') |'+sLineBreak - +'+----------------------------------------------------------------+'+sLineBreak - +'| 2014-06-02 |'+sLineBreak - +'+----------------------------------------------------------------+' - ), - - ( - Name: 'SUBDATE'; - Declaration: '(date,INTERVAL expr unit)'; - Category: 'Date and Time Functions'; - Version: SQL_VERSION_ANSI; - Description: 'When invoked with the INTERVAL form of the second argument,'+sLineBreak - +'SUBDATE()'+sLineBreak - +'is a synonym for DATE_SUB(). See Date and Time Units for a'+sLineBreak - +'complete list of permitted units. '+sLineBreak - +' '+sLineBreak - +'The second form allows the use of an integer value for days.'+sLineBreak - +'In such'+sLineBreak - +'cases, it is interpreted as the number of days to be'+sLineBreak - +'subtracted from'+sLineBreak - +'the date or datetime expression expr.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT DATE_SUB(''2008-01-02'', INTERVAL 31 DAY);'+sLineBreak - +'+-----------------------------------------+'+sLineBreak - +'| DATE_SUB(''2008-01-02'', INTERVAL 31 DAY) |'+sLineBreak - +'+-----------------------------------------+'+sLineBreak - +'| 2007-12-02 |'+sLineBreak - +'+-----------------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT SUBDATE(''2008-01-02'', INTERVAL 31 DAY);'+sLineBreak - +'+----------------------------------------+'+sLineBreak - +'| SUBDATE(''2008-01-02'', INTERVAL 31 DAY) |'+sLineBreak - +'+----------------------------------------+'+sLineBreak - +'| 2007-12-02 |'+sLineBreak - +'+----------------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT SUBDATE(''2008-01-02 12:00:00'', 31);'+sLineBreak - +'+------------------------------------+'+sLineBreak - +'| SUBDATE(''2008-01-02 12:00:00'', 31) |'+sLineBreak - +'+------------------------------------+'+sLineBreak - +'| 2007-12-02 12:00:00 |'+sLineBreak - +'+------------------------------------+'+sLineBreak - +' '+sLineBreak - +'CREATE TABLE t1 (d DATETIME);'+sLineBreak - +'INSERT INTO t1 VALUES'+sLineBreak - +' ("2007-01-30 21:31:07"),'+sLineBreak - +' ("1983-10-15 06:42:51"),'+sLineBreak - +' ("2011-04-21 12:34:56"),'+sLineBreak - +' ("2011-10-30 06:31:41"),'+sLineBreak - +' ("2011-01-30 14:03:25"),'+sLineBreak - +' ("2004-10-07 11:19:34");'+sLineBreak - +' '+sLineBreak - +'SELECT d, SUBDATE(d, 10) from t1;'+sLineBreak - +' '+sLineBreak - +'+---------------------+---------------------+'+sLineBreak - +'| d | SUBDATE(d, 10) |'+sLineBreak - +'+---------------------+---------------------+'+sLineBreak - +'| 2007-01-30 21:31:07 | 2007-01-20 21:31:07 |'+sLineBreak - +'| 1983-10-15 06:42:51 | 1983-10-05 06:42:51 |'+sLineBreak - +'| 2011-04-21 12:34:56 | 2011-04-11 12:34:56 |'+sLineBreak - +'| 2011-10-30 06:31:41 | 2011-10-20 06:31:41 |'+sLineBreak - +'| 2011-01-30 14:03:25 | 2011-01-20 14:03:25 |'+sLineBreak - +'| 2004-10-07 11:19:34 | 2004-09-27 11:19:34 |'+sLineBreak - +'+---------------------+---------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT d, SUBDATE(d, INTERVAL 10 MINUTE) from t1;'+sLineBreak - +' '+sLineBreak - +'+---------------------+--------------------------------+'+sLineBreak - +'| d | SUBDATE(d, INTERVAL 10 MINUTE) |'+sLineBreak - +'+---------------------+--------------------------------+'+sLineBreak - +'| 2007-01-30 21:31:07 | 2007-01-30 21:21:07 |'+sLineBreak - +'| 1983-10-15 06:42:51 | 1983-10-15 06:32:51 |'+sLineBreak - +'| 2011-04-21 12:34:56 | 2011-04-21 12:24:56 |'+sLineBreak - +'| 2011-10-30 06:31:41 | 2011-10-30 06:21:41 |'+sLineBreak - +'| 2011-01-30 14:03:25 | 2011-01-30 13:53:25 |'+sLineBreak - +'| 2004-10-07 11:19:34 | 2004-10-07 11:09:34 |'+sLineBreak - +'+---------------------+--------------------------------+' - ), - - ( - Name: 'SUBDATE'; - Declaration: '(expr,days)'; - Category: 'Date and Time Functions'; - Version: SQL_VERSION_ANSI; - Description: 'When invoked with the INTERVAL form of the second argument,'+sLineBreak - +'SUBDATE()'+sLineBreak - +'is a synonym for DATE_SUB(). See Date and Time Units for a'+sLineBreak - +'complete list of permitted units. '+sLineBreak - +' '+sLineBreak - +'The second form allows the use of an integer value for days.'+sLineBreak - +'In such'+sLineBreak - +'cases, it is interpreted as the number of days to be'+sLineBreak - +'subtracted from'+sLineBreak - +'the date or datetime expression expr.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT DATE_SUB(''2008-01-02'', INTERVAL 31 DAY);'+sLineBreak - +'+-----------------------------------------+'+sLineBreak - +'| DATE_SUB(''2008-01-02'', INTERVAL 31 DAY) |'+sLineBreak - +'+-----------------------------------------+'+sLineBreak - +'| 2007-12-02 |'+sLineBreak - +'+-----------------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT SUBDATE(''2008-01-02'', INTERVAL 31 DAY);'+sLineBreak - +'+----------------------------------------+'+sLineBreak - +'| SUBDATE(''2008-01-02'', INTERVAL 31 DAY) |'+sLineBreak - +'+----------------------------------------+'+sLineBreak - +'| 2007-12-02 |'+sLineBreak - +'+----------------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT SUBDATE(''2008-01-02 12:00:00'', 31);'+sLineBreak - +'+------------------------------------+'+sLineBreak - +'| SUBDATE(''2008-01-02 12:00:00'', 31) |'+sLineBreak - +'+------------------------------------+'+sLineBreak - +'| 2007-12-02 12:00:00 |'+sLineBreak - +'+------------------------------------+'+sLineBreak - +' '+sLineBreak - +'CREATE TABLE t1 (d DATETIME);'+sLineBreak - +'INSERT INTO t1 VALUES'+sLineBreak - +' ("2007-01-30 21:31:07"),'+sLineBreak - +' ("1983-10-15 06:42:51"),'+sLineBreak - +' ("2011-04-21 12:34:56"),'+sLineBreak - +' ("2011-10-30 06:31:41"),'+sLineBreak - +' ("2011-01-30 14:03:25"),'+sLineBreak - +' ("2004-10-07 11:19:34");'+sLineBreak - +' '+sLineBreak - +'SELECT d, SUBDATE(d, 10) from t1;'+sLineBreak - +' '+sLineBreak - +'+---------------------+---------------------+'+sLineBreak - +'| d | SUBDATE(d, 10) |'+sLineBreak - +'+---------------------+---------------------+'+sLineBreak - +'| 2007-01-30 21:31:07 | 2007-01-20 21:31:07 |'+sLineBreak - +'| 1983-10-15 06:42:51 | 1983-10-05 06:42:51 |'+sLineBreak - +'| 2011-04-21 12:34:56 | 2011-04-11 12:34:56 |'+sLineBreak - +'| 2011-10-30 06:31:41 | 2011-10-20 06:31:41 |'+sLineBreak - +'| 2011-01-30 14:03:25 | 2011-01-20 14:03:25 |'+sLineBreak - +'| 2004-10-07 11:19:34 | 2004-09-27 11:19:34 |'+sLineBreak - +'+---------------------+---------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT d, SUBDATE(d, INTERVAL 10 MINUTE) from t1;'+sLineBreak - +' '+sLineBreak - +'+---------------------+--------------------------------+'+sLineBreak - +'| d | SUBDATE(d, INTERVAL 10 MINUTE) |'+sLineBreak - +'+---------------------+--------------------------------+'+sLineBreak - +'| 2007-01-30 21:31:07 | 2007-01-30 21:21:07 |'+sLineBreak - +'| 1983-10-15 06:42:51 | 1983-10-15 06:32:51 |'+sLineBreak - +'| 2011-04-21 12:34:56 | 2011-04-21 12:24:56 |'+sLineBreak - +'| 2011-10-30 06:31:41 | 2011-10-30 06:21:41 |'+sLineBreak - +'| 2011-01-30 14:03:25 | 2011-01-30 13:53:25 |'+sLineBreak - +'| 2004-10-07 11:19:34 | 2004-10-07 11:09:34 |'+sLineBreak - +'+---------------------+--------------------------------+' - ), - - ( - Name: 'SUBTIME'; - Declaration: '(expr1,expr2)'; - Category: 'Date and Time Functions'; - Version: SQL_VERSION_ANSI; - Description: 'SUBTIME() returns expr1 - expr2 expressed as a value in the'+sLineBreak - +'same'+sLineBreak - +'format as expr1. expr1 is a time or datetime expression, and'+sLineBreak - +'expr2 is'+sLineBreak - +'a time expression.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT SUBTIME(''2007-12-31 23:59:59.999999'',''1'+sLineBreak - +'1:1:1.000002'');'+sLineBreak - +'+--------------------------------------------------------+'+sLineBreak - +'| SUBTIME(''2007-12-31 23:59:59.999999'',''1 1:1:1.000002'')'+sLineBreak - +'|'+sLineBreak - +'+--------------------------------------------------------+'+sLineBreak - +'| 2007-12-30 22:58:58.999997 |'+sLineBreak - +'+--------------------------------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT SUBTIME(''01:00:00.999999'', ''02:00:00.999998'');'+sLineBreak - +'+-----------------------------------------------+'+sLineBreak - +'| SUBTIME(''01:00:00.999999'', ''02:00:00.999998'') |'+sLineBreak - +'+-----------------------------------------------+'+sLineBreak - +'| -00:59:59.999999 |'+sLineBreak - +'+-----------------------------------------------+' - ), - - ( - Name: 'SYSDATE'; - Declaration: '([precision])'; - Category: 'Date and Time Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the current date and time as a value in ''YYYY-MM-DD'+sLineBreak - +'HH:MM:SS'''+sLineBreak - +'or YYYYMMDDHHMMSS.uuuuuu format, depending on whether the'+sLineBreak - +'function is'+sLineBreak - +'used in a string or numeric context.'+sLineBreak - +' '+sLineBreak - +'The optional precision determines the microsecond precision.'+sLineBreak - +'See Microseconds in MariaDB.'+sLineBreak - +' '+sLineBreak - +'SYSDATE() returns the time at which it executes. This'+sLineBreak - +'differs from the'+sLineBreak - +'behavior for NOW(), which returns a constant time that'+sLineBreak - +'indicates the'+sLineBreak - +'time at which the statement began to execute. (Within a'+sLineBreak - +'stored routine'+sLineBreak - +'or trigger, NOW() returns the time at which the routine or'+sLineBreak - +'triggering'+sLineBreak - +'statement began to execute.)'+sLineBreak - +' '+sLineBreak - +'In addition, changing the timestamp system variable with a'+sLineBreak - +'SET timestamp statement affects the value returned by'+sLineBreak - +'NOW() but not by SYSDATE(). This means that timestamp'+sLineBreak - +'settings in the'+sLineBreak - +'binary log have no effect on invocations of SYSDATE().'+sLineBreak - +' '+sLineBreak - +'Because SYSDATE() can return different values even within'+sLineBreak - +'the same'+sLineBreak - +'statement, and is not affected by SET TIMESTAMP, it is'+sLineBreak - +'non-deterministic and therefore unsafe for replication if'+sLineBreak - +'statement-based binary logging is used. If that is a'+sLineBreak - +'problem, you can'+sLineBreak - +'use row-based logging, or start the server with the mysqld'+sLineBreak - +'option --sysdate-is-now to cause SYSDATE() to be an alias'+sLineBreak - +'for NOW(). The non-deterministic nature of SYSDATE() also'+sLineBreak - +'means that indexes cannot be used for evaluating expressions'+sLineBreak - +'that refer to it, and that statements using the SYSDATE()'+sLineBreak - +'function are unsafe for statement-based replication.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'Difference between NOW() and SYSDATE():'+sLineBreak - +' '+sLineBreak - +'SELECT NOW(), SLEEP(2), NOW();'+sLineBreak - +'+---------------------+----------+---------------------+'+sLineBreak - +'| NOW() | SLEEP(2) | NOW() |'+sLineBreak - +'+---------------------+----------+---------------------+'+sLineBreak - +'| 2010-03-27 13:23:40 | 0 | 2010-03-27 13:23:40 |'+sLineBreak - +'+---------------------+----------+---------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT SYSDATE(), SLEEP(2), SYSDATE();'+sLineBreak - +'+---------------------+----------+---------------------+'+sLineBreak - +'| SYSDATE() | SLEEP(2) | SYSDATE() |'+sLineBreak - +'+---------------------+----------+---------------------+'+sLineBreak - +'| 2010-03-27 13:23:52 | 0 | 2010-03-27 13:23:54 |'+sLineBreak - +'+---------------------+----------+---------------------+'+sLineBreak - +' '+sLineBreak - +'With precision:'+sLineBreak - +' '+sLineBreak - +'SELECT SYSDATE(4);'+sLineBreak - +'+--------------------------+'+sLineBreak - +'| SYSDATE(4) |'+sLineBreak - +'+--------------------------+'+sLineBreak - +'| 2018-07-10 10:17:13.1689 |'+sLineBreak - +'+--------------------------+' - ), - - ( - Name: 'TIMEDIFF'; - Declaration: '(expr1,expr2)'; - Category: 'Date and Time Functions'; - Version: SQL_VERSION_ANSI; - Description: 'TIMEDIFF() returns expr1 - expr2 expressed as a time value.'+sLineBreak - +'expr1 and'+sLineBreak - +'expr2 are time or date-and-time expressions, but both must'+sLineBreak - +'be of the'+sLineBreak - +'same type.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT TIMEDIFF(''2000:01:01 00:00:00'', ''2000:01:01'+sLineBreak - +'00:00:00.000001'');'+sLineBreak - +'+---------------------------------------------------------------+'+sLineBreak - +'| TIMEDIFF(''2000:01:01 00:00:00'', ''2000:01:01'+sLineBreak - +'00:00:00.000001'') |'+sLineBreak - +'+---------------------------------------------------------------+'+sLineBreak - +'| -00:00:00.000001 |'+sLineBreak - +'+---------------------------------------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT TIMEDIFF(''2008-12-31 23:59:59.000001'', ''2008-12-30'+sLineBreak - +'01:01:01.000002'');'+sLineBreak - +'+----------------------------------------------------------------------+'+sLineBreak - +'| TIMEDIFF(''2008-12-31 23:59:59.000001'', ''2008-12-30'+sLineBreak - +'01:01:01.000002'') |'+sLineBreak - +'+----------------------------------------------------------------------+'+sLineBreak - +'| 46:58:57.999999 |'+sLineBreak - +'+----------------------------------------------------------------------+' - ), - - ( - Name: 'TIMESTAMPADD'; - Declaration: '(unit,interval,datetime_expr)'; - Category: 'Date and Time Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Adds the integer expression interval to the date or datetime'+sLineBreak - +'expression datetime_expr. The unit for interval is given by'+sLineBreak - +'the unit'+sLineBreak - +'argument, which should be one of the following values:'+sLineBreak - +'MICROSECOND, SECOND, MINUTE, HOUR, DAY, WEEK, MONTH,'+sLineBreak - +'QUARTER, or YEAR.'+sLineBreak - +' '+sLineBreak - +'The unit value may be specified using one of keywords as'+sLineBreak - +'shown, or'+sLineBreak - +'with a prefix of SQL_TSI_. For example, DAY and SQL_TSI_DAY'+sLineBreak - +'both are'+sLineBreak - +'legal.'+sLineBreak - +' '+sLineBreak - +'Before MariaDB 5.5, FRAC_SECOND was permitted as a synonym'+sLineBreak - +'for MICROSECOND.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT TIMESTAMPADD(MINUTE,1,''2003-01-02'');'+sLineBreak - +'+-------------------------------------+'+sLineBreak - +'| TIMESTAMPADD(MINUTE,1,''2003-01-02'') |'+sLineBreak - +'+-------------------------------------+'+sLineBreak - +'| 2003-01-02 00:01:00 |'+sLineBreak - +'+-------------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT TIMESTAMPADD(WEEK,1,''2003-01-02'');'+sLineBreak - +'+-----------------------------------+'+sLineBreak - +'| TIMESTAMPADD(WEEK,1,''2003-01-02'') |'+sLineBreak - +'+-----------------------------------+'+sLineBreak - +'| 2003-01-09 |'+sLineBreak - +'+-----------------------------------+' - ), - - ( - Name: 'TIMESTAMPDIFF'; - Declaration: '(unit,datetime_expr1,datetime_expr2)'; - Category: 'Date and Time Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns datetime_expr2 - datetime_expr1, where'+sLineBreak - +'datetime_expr1 and'+sLineBreak - +'datetime_expr2 are date or datetime expressions. One'+sLineBreak - +'expression may be'+sLineBreak - +'a date and the other a datetime; a date value is treated as'+sLineBreak - +'a datetime'+sLineBreak - +'having the time part ''00:00:00'' where necessary. The unit'+sLineBreak - +'for the'+sLineBreak - +'result (an integer) is given by the unit argument. The legal'+sLineBreak - +'values'+sLineBreak - +'for unit are the same as those listed in the description of'+sLineBreak - +'the'+sLineBreak - +'TIMESTAMPADD() function, i.e MICROSECOND, SECOND, MINUTE,'+sLineBreak - +'HOUR, DAY, WEEK, MONTH, QUARTER, or YEAR.'+sLineBreak - +' '+sLineBreak - +'TIMESTAMPDIFF can also be used to calculate age.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT TIMESTAMPDIFF(MONTH,''2003-02-01'',''2003-05-01'');'+sLineBreak - +'+------------------------------------------------+'+sLineBreak - +'| TIMESTAMPDIFF(MONTH,''2003-02-01'',''2003-05-01'') |'+sLineBreak - +'+------------------------------------------------+'+sLineBreak - +'| 3 |'+sLineBreak - +'+------------------------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT TIMESTAMPDIFF(YEAR,''2002-05-01'',''2001-01-01'');'+sLineBreak - +'+-----------------------------------------------+'+sLineBreak - +'| TIMESTAMPDIFF(YEAR,''2002-05-01'',''2001-01-01'') |'+sLineBreak - +'+-----------------------------------------------+'+sLineBreak - +'| -1 |'+sLineBreak - +'+-----------------------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT TIMESTAMPDIFF(MINUTE,''2003-02-01'',''2003-05-01'+sLineBreak - +'12:05:55'');'+sLineBreak - +'+----------------------------------------------------------+'+sLineBreak - +'| TIMESTAMPDIFF(MINUTE,''2003-02-01'',''2003-05-01'+sLineBreak - +'12:05:55'') |'+sLineBreak - +'+----------------------------------------------------------+'+sLineBreak - +'| 128885 |'+sLineBreak - +'+----------------------------------------------------------+'+sLineBreak - +' '+sLineBreak - +'Calculating age:'+sLineBreak - +' '+sLineBreak - +'SELECT CURDATE();'+sLineBreak - +'+------------+'+sLineBreak - +'| CURDATE() |'+sLineBreak - +'+------------+'+sLineBreak - +'| 2019-05-27 |'+sLineBreak - +'+------------+'+sLineBreak - +' '+sLineBreak - +'SELECT TIMESTAMPDIFF(YEAR, ''1971-06-06'', CURDATE()) AS'+sLineBreak - +'age;'+sLineBreak - +' '+sLineBreak - +'+------+'+sLineBreak - +'| age |'+sLineBreak - +'+------+'+sLineBreak - +'| 47 |'+sLineBreak - +'+------+'+sLineBreak - +' '+sLineBreak - +'SELECT TIMESTAMPDIFF(YEAR, ''1971-05-06'', CURDATE()) AS'+sLineBreak - +'age;'+sLineBreak - +' '+sLineBreak - +'+------+'+sLineBreak - +'| age |'+sLineBreak - +'+------+'+sLineBreak - +'| 48 |'+sLineBreak - +'+------+'+sLineBreak - +' '+sLineBreak - +'Age as of 2014-08-02:'+sLineBreak - +' '+sLineBreak - +'SELECT name, date_of_birth,'+sLineBreak - +'TIMESTAMPDIFF(YEAR,date_of_birth,''2014-08-02'') AS age '+sLineBreak - +' FROM student_details;'+sLineBreak - +' '+sLineBreak - +'+---------+---------------+------+'+sLineBreak - +'| name | date_of_birth | age |'+sLineBreak - +'+---------+---------------+------+'+sLineBreak - +'| Chun | 1993-12-31 | 20 |'+sLineBreak - +'| Esben | 1946-01-01 | 68 |'+sLineBreak - +'| Kaolin | 1996-07-16 | 18 |'+sLineBreak - +'| Tatiana | 1988-04-13 | 26 |'+sLineBreak - +'+---------+---------------+------+' - ), - - ( - Name: 'TIME_FORMAT'; - Declaration: '(time,format)'; - Category: 'Date and Time Functions'; - Version: SQL_VERSION_ANSI; - Description: 'This is used like the DATE_FORMAT() function, but the format'+sLineBreak - +'string'+sLineBreak - +'may contain format specifiers only for hours, minutes, and'+sLineBreak - +'seconds.'+sLineBreak - +'Other specifiers produce a NULL value or 0.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT TIME_FORMAT(''100:00:00'', ''%H %k %h %I %l'');'+sLineBreak - +'+--------------------------------------------+'+sLineBreak - +'| TIME_FORMAT(''100:00:00'', ''%H %k %h %I %l'') |'+sLineBreak - +'+--------------------------------------------+'+sLineBreak - +'| 100 100 04 04 4 |'+sLineBreak - +'+--------------------------------------------+' - ), - - ( - Name: 'TIME_TO_SEC'; - Declaration: '(time)'; - Category: 'Date and Time Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the time argument, converted to seconds.'+sLineBreak - +' '+sLineBreak - +'The value returned by TIME_TO_SEC is of type DOUBLE. Before'+sLineBreak - +'MariaDB 5.3 (and MySQL 5.6), the type was INT. See'+sLineBreak - +'Microseconds in MariaDB.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT TIME_TO_SEC(''22:23:00'');'+sLineBreak - +'+-------------------------+'+sLineBreak - +'| TIME_TO_SEC(''22:23:00'') |'+sLineBreak - +'+-------------------------+'+sLineBreak - +'| 80580 |'+sLineBreak - +'+-------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT TIME_TO_SEC(''00:39:38'');'+sLineBreak - +'+-------------------------+'+sLineBreak - +'| TIME_TO_SEC(''00:39:38'') |'+sLineBreak - +'+-------------------------+'+sLineBreak - +'| 2378 |'+sLineBreak - +'+-------------------------+' - ), - - ( - Name: 'TO_DAYS'; - Declaration: '(date)'; - Category: 'Date and Time Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Given a date date, returns the number of days since the'+sLineBreak - +'start of the current calendar (0000-00-00).'+sLineBreak - +' '+sLineBreak - +'The function is not designed for use with dates before the'+sLineBreak - +'advent of the Gregorian calendar in October 1582. Results'+sLineBreak - +'will not be reliable since it doesn''t account for the lost'+sLineBreak - +'days when the calendar changed from the Julian calendar.'+sLineBreak - +' '+sLineBreak - +'This is the converse of the FROM_DAYS() function.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT TO_DAYS(''2007-10-07'');'+sLineBreak - +'+-----------------------+'+sLineBreak - +'| TO_DAYS(''2007-10-07'') |'+sLineBreak - +'+-----------------------+'+sLineBreak - +'| 733321 |'+sLineBreak - +'+-----------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT TO_DAYS(''0000-01-01'');'+sLineBreak - +'+-----------------------+'+sLineBreak - +'| TO_DAYS(''0000-01-01'') |'+sLineBreak - +'+-----------------------+'+sLineBreak - +'| 1 |'+sLineBreak - +'+-----------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT TO_DAYS(950501);'+sLineBreak - +'+-----------------+'+sLineBreak - +'| TO_DAYS(950501) |'+sLineBreak - +'+-----------------+'+sLineBreak - +'| 728779 |'+sLineBreak - +'+-----------------+' - ), - - ( - Name: 'TO_SECONDS'; - Declaration: '(expr)'; - Category: 'Date and Time Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the number of seconds from year 0 till expr, or NULL'+sLineBreak - +'if expr is not a valid date or datetime.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT TO_SECONDS(''2013-06-13'');'+sLineBreak - +'+--------------------------+'+sLineBreak - +'| TO_SECONDS(''2013-06-13'') |'+sLineBreak - +'+--------------------------+'+sLineBreak - +'| 63538300800 |'+sLineBreak - +'+--------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT TO_SECONDS(''2013-06-13 21:45:13'');'+sLineBreak - +'+-----------------------------------+'+sLineBreak - +'| TO_SECONDS(''2013-06-13 21:45:13'') |'+sLineBreak - +'+-----------------------------------+'+sLineBreak - +'| 63538379113 |'+sLineBreak - +'+-----------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT TO_SECONDS(NOW());'+sLineBreak - +'+-------------------+'+sLineBreak - +'| TO_SECONDS(NOW()) |'+sLineBreak - +'+-------------------+'+sLineBreak - +'| 63543530875 |'+sLineBreak - +'+-------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT TO_SECONDS(20130513);'+sLineBreak - +'+----------------------+'+sLineBreak - +'| TO_SECONDS(20130513) |'+sLineBreak - +'+----------------------+'+sLineBreak - +'| 63535622400 |'+sLineBreak - +'+----------------------+'+sLineBreak - +'1 row in set (0.00 sec)'+sLineBreak - +' '+sLineBreak - +'SELECT TO_SECONDS(130513);'+sLineBreak - +'+--------------------+'+sLineBreak - +'| TO_SECONDS(130513) |'+sLineBreak - +'+--------------------+'+sLineBreak - +'| 63535622400 |'+sLineBreak - +'+--------------------+' - ), - - ( - Name: 'UNIX_TIMESTAMP'; - Declaration: '()'; - Category: 'Date and Time Functions'; - Version: SQL_VERSION_ANSI; - Description: 'If called with no argument, returns a Unix timestamp'+sLineBreak - +'(seconds since'+sLineBreak - +'''1970-01-01 00:00:00'' UTC) as an unsigned integer. If'+sLineBreak - +'UNIX_TIMESTAMP()'+sLineBreak - +'is called with a date argument, it returns the value of the'+sLineBreak - +'argument as seconds'+sLineBreak - +'since ''1970-01-01 00:00:00'' UTC. date may be a DATE'+sLineBreak - +'string, a'+sLineBreak - +'DATETIME string, a TIMESTAMP, or a number in'+sLineBreak - +'the format YYMMDD or YYYYMMDD. The server interprets date as'+sLineBreak - +'a value in the'+sLineBreak - +'current time zone and converts it to an internal value in'+sLineBreak - +'UTC. Clients can set'+sLineBreak - +'their time zone as described in time zones.'+sLineBreak - +' '+sLineBreak - +'The inverse function of UNIX_TIMESTAMP() is FROM_UNIXTIME()'+sLineBreak - +' '+sLineBreak - +'UNIX_TIMESTAMP() supports microseconds.'+sLineBreak - +' '+sLineBreak - +'Timestamps in MariaDB have a maximum value of 2147483647,'+sLineBreak - +'equivalent to 2038-01-19 05:14:07. This is due to the'+sLineBreak - +'underlying 32-bit limitation. Using the function on a date'+sLineBreak - +'beyond this will result in NULL being returned. Use DATETIME'+sLineBreak - +'as a storage type if you require dates beyond this.'+sLineBreak - +' '+sLineBreak - +'Error Handling'+sLineBreak - +' '+sLineBreak - +'Returns NULL for wrong arguments to UNIX_TIMESTAMP(). In'+sLineBreak - +'MySQL and MariaDB before 5.3 wrong arguments to'+sLineBreak - +'UNIX_TIMESTAMP() returned 0. '+sLineBreak - +' '+sLineBreak - +'Compatibility'+sLineBreak - +' '+sLineBreak - +'As you can see in the examples above,'+sLineBreak - +'UNIX_TIMESTAMP(constant-date-string) returns a timestamp'+sLineBreak - +'with 6 decimals while MariaDB 5.2 and before returns it'+sLineBreak - +'without decimals. This can cause a problem if you are using'+sLineBreak - +'UNIX_TIMESTAMP() as a partitioning function. You can fix'+sLineBreak - +'this by using FLOOR(UNIX_TIMESTAMP(..)) or changing the date'+sLineBreak - +'string to a date number, like 20080101000000. '+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT UNIX_TIMESTAMP();'+sLineBreak - +'+------------------+'+sLineBreak - +'| UNIX_TIMESTAMP() |'+sLineBreak - +'+------------------+'+sLineBreak - +'| 1269711082 |'+sLineBreak - +'+------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT UNIX_TIMESTAMP(''2007-11-30 10:30:19'');'+sLineBreak - +'+---------------------------------------+'+sLineBreak - +'| UNIX_TIMESTAMP(''2007-11-30 10:30:19'') |'+sLineBreak - +'+---------------------------------------+'+sLineBreak - +'| 1196436619.000000 |'+sLineBreak - +'+---------------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT UNIX_TIMESTAMP("2007-11-30 10:30:19.123456");'+sLineBreak - +'+----------------------------------------------+'+sLineBreak - +'| unix_timestamp("2007-11-30 10:30:19.123456") |'+sLineBreak - +'+----------------------------------------------+'+sLineBreak - +'| 1196411419.123456 |'+sLineBreak - +'+----------------------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT FROM_UNIXTIME(UNIX_TIMESTAMP(''2007-11-30'+sLineBreak - +'10:30:19''));'+sLineBreak - +'+------------------------------------------------------+'+sLineBreak - +'| FROM_UNIXTIME(UNIX_TIMESTAMP(''2007-11-30 10:30:19'')) |'+sLineBreak - +'+------------------------------------------------------+'+sLineBreak - +'| 2007-11-30 10:30:19.000000 |'+sLineBreak - +'+------------------------------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT FROM_UNIXTIME(FLOOR(UNIX_TIMESTAMP(''2007-11-30'+sLineBreak - +'10:30:19'')));'+sLineBreak - +'+-------------------------------------------------------------+'+sLineBreak - +'| FROM_UNIXTIME(FLOOR(UNIX_TIMESTAMP(''2007-11-30'+sLineBreak - +'10:30:19''))) |'+sLineBreak - +'+-------------------------------------------------------------+'+sLineBreak - +'| 2007-11-30 10:30:19 |'+sLineBreak - +'+-------------------------------------------------------------+' - ), - - ( - Name: 'UNIX_TIMESTAMP'; - Declaration: '(date)'; - Category: 'Date and Time Functions'; - Version: SQL_VERSION_ANSI; - Description: 'If called with no argument, returns a Unix timestamp'+sLineBreak - +'(seconds since'+sLineBreak - +'''1970-01-01 00:00:00'' UTC) as an unsigned integer. If'+sLineBreak - +'UNIX_TIMESTAMP()'+sLineBreak - +'is called with a date argument, it returns the value of the'+sLineBreak - +'argument as seconds'+sLineBreak - +'since ''1970-01-01 00:00:00'' UTC. date may be a DATE'+sLineBreak - +'string, a'+sLineBreak - +'DATETIME string, a TIMESTAMP, or a number in'+sLineBreak - +'the format YYMMDD or YYYYMMDD. The server interprets date as'+sLineBreak - +'a value in the'+sLineBreak - +'current time zone and converts it to an internal value in'+sLineBreak - +'UTC. Clients can set'+sLineBreak - +'their time zone as described in time zones.'+sLineBreak - +' '+sLineBreak - +'The inverse function of UNIX_TIMESTAMP() is FROM_UNIXTIME()'+sLineBreak - +' '+sLineBreak - +'UNIX_TIMESTAMP() supports microseconds.'+sLineBreak - +' '+sLineBreak - +'Timestamps in MariaDB have a maximum value of 2147483647,'+sLineBreak - +'equivalent to 2038-01-19 05:14:07. This is due to the'+sLineBreak - +'underlying 32-bit limitation. Using the function on a date'+sLineBreak - +'beyond this will result in NULL being returned. Use DATETIME'+sLineBreak - +'as a storage type if you require dates beyond this.'+sLineBreak - +' '+sLineBreak - +'Error Handling'+sLineBreak - +' '+sLineBreak - +'Returns NULL for wrong arguments to UNIX_TIMESTAMP(). In'+sLineBreak - +'MySQL and MariaDB before 5.3 wrong arguments to'+sLineBreak - +'UNIX_TIMESTAMP() returned 0. '+sLineBreak - +' '+sLineBreak - +'Compatibility'+sLineBreak - +' '+sLineBreak - +'As you can see in the examples above,'+sLineBreak - +'UNIX_TIMESTAMP(constant-date-string) returns a timestamp'+sLineBreak - +'with 6 decimals while MariaDB 5.2 and before returns it'+sLineBreak - +'without decimals. This can cause a problem if you are using'+sLineBreak - +'UNIX_TIMESTAMP() as a partitioning function. You can fix'+sLineBreak - +'this by using FLOOR(UNIX_TIMESTAMP(..)) or changing the date'+sLineBreak - +'string to a date number, like 20080101000000. '+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT UNIX_TIMESTAMP();'+sLineBreak - +'+------------------+'+sLineBreak - +'| UNIX_TIMESTAMP() |'+sLineBreak - +'+------------------+'+sLineBreak - +'| 1269711082 |'+sLineBreak - +'+------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT UNIX_TIMESTAMP(''2007-11-30 10:30:19'');'+sLineBreak - +'+---------------------------------------+'+sLineBreak - +'| UNIX_TIMESTAMP(''2007-11-30 10:30:19'') |'+sLineBreak - +'+---------------------------------------+'+sLineBreak - +'| 1196436619.000000 |'+sLineBreak - +'+---------------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT UNIX_TIMESTAMP("2007-11-30 10:30:19.123456");'+sLineBreak - +'+----------------------------------------------+'+sLineBreak - +'| unix_timestamp("2007-11-30 10:30:19.123456") |'+sLineBreak - +'+----------------------------------------------+'+sLineBreak - +'| 1196411419.123456 |'+sLineBreak - +'+----------------------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT FROM_UNIXTIME(UNIX_TIMESTAMP(''2007-11-30'+sLineBreak - +'10:30:19''));'+sLineBreak - +'+------------------------------------------------------+'+sLineBreak - +'| FROM_UNIXTIME(UNIX_TIMESTAMP(''2007-11-30 10:30:19'')) |'+sLineBreak - +'+------------------------------------------------------+'+sLineBreak - +'| 2007-11-30 10:30:19.000000 |'+sLineBreak - +'+------------------------------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT FROM_UNIXTIME(FLOOR(UNIX_TIMESTAMP(''2007-11-30'+sLineBreak - +'10:30:19'')));'+sLineBreak - +'+-------------------------------------------------------------+'+sLineBreak - +'| FROM_UNIXTIME(FLOOR(UNIX_TIMESTAMP(''2007-11-30'+sLineBreak - +'10:30:19''))) |'+sLineBreak - +'+-------------------------------------------------------------+'+sLineBreak - +'| 2007-11-30 10:30:19 |'+sLineBreak - +'+-------------------------------------------------------------+' - ), - - ( - Name: 'WEEK'; - Declaration: '(date[,mode])'; - Category: 'Date and Time Functions'; - Version: SQL_VERSION_ANSI; - Description: 'This function returns the week number for date. The'+sLineBreak - +'two-argument form of'+sLineBreak - +'WEEK() allows you to specify whether the week starts on'+sLineBreak - +'Sunday or Monday'+sLineBreak - +'and whether the return value should be in the range from 0'+sLineBreak - +'to 53 or from 1 to'+sLineBreak - +'53. If the mode argument is omitted, the value of the'+sLineBreak - +'default_week_format system variable is used.'+sLineBreak - +' '+sLineBreak - +'Modes'+sLineBreak - +' '+sLineBreak - +'Mode | 1st day of week | Range | Week 1 is the 1st week with'+sLineBreak - +'| '+sLineBreak - +' '+sLineBreak - +'0 | Sunday | 0-53 | a Sunday in this year | '+sLineBreak - +' '+sLineBreak - +'1 | Monday | 0-53 | more than 3 days this year | '+sLineBreak - +' '+sLineBreak - +'2 | Sunday | 1-53 | a Sunday in this year | '+sLineBreak - +' '+sLineBreak - +'3 | Monday | 1-53 | more than 3 days this year | '+sLineBreak - +' '+sLineBreak - +'4 | Sunday | 0-53 | more than 3 days this year | '+sLineBreak - +' '+sLineBreak - +'5 | Monday | 0-53 | a Monday in this year | '+sLineBreak - +' '+sLineBreak - +'6 | Sunday | 1-53 | more than 3 days this year | '+sLineBreak - +' '+sLineBreak - +'7 | Monday | 1-53 | a Monday in this year | '+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT WEEK(''2008-02-20'');'+sLineBreak - +'+--------------------+'+sLineBreak - +'| WEEK(''2008-02-20'') |'+sLineBreak - +'+--------------------+'+sLineBreak - +'| 7 |'+sLineBreak - +'+--------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT WEEK(''2008-02-20'',0);'+sLineBreak - +'+----------------------+'+sLineBreak - +'| WEEK(''2008-02-20'',0) |'+sLineBreak - +'+----------------------+'+sLineBreak - +'| 7 |'+sLineBreak - +'+----------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT WEEK(''2008-02-20'',1);'+sLineBreak - +'+----------------------+'+sLineBreak - +'| WEEK(''2008-02-20'',1) |'+sLineBreak - +'+----------------------+'+sLineBreak - +'| 8 |'+sLineBreak - +'+----------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT WEEK(''2008-12-31'',0);'+sLineBreak - +'+----------------------+'+sLineBreak - +'| WEEK(''2008-12-31'',0) |'+sLineBreak - +'+----------------------+'+sLineBreak - +'| 52 |'+sLineBreak - +'+----------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT WEEK(''2008-12-31'',1);'+sLineBreak - +'+----------------------+'+sLineBreak - +'| WEEK(''2008-12-31'',1) |'+sLineBreak - +'+----------------------+'+sLineBreak - +'| 53 |'+sLineBreak - +'+----------------------+'+sLineBreak - +' '+sLineBreak - +'CREATE TABLE t1 (d DATETIME);'+sLineBreak - +'INSERT INTO t1 VALUES'+sLineBreak - +' ("2007-01-30 21:31:07"),'+sLineBreak - +' ("1983-10-15 06:42:51"),'+sLineBreak - +' ("2011-04-21 12:34:56"),'+sLineBreak - +' ("2011-10-30 06:31:41"),'+sLineBreak - +' ("2011-01-30 14:03:25"),'+sLineBreak - +' ("2004-10-07 11:19:34");'+sLineBreak - +' '+sLineBreak - +'SELECT d, WEEK(d,0), WEEK(d,1) from t1;'+sLineBreak - +' '+sLineBreak - +'+---------------------+-----------+-----------+'+sLineBreak - +'| d | WEEK(d,0) | WEEK(d,1) |'+sLineBreak - +'+---------------------+-----------+-----------+'+sLineBreak - +'| 2007-01-30 21:31:07 | 4 | 5 |'+sLineBreak - +'| 1983-10-15 06:42:51 | 41 | 41 |'+sLineBreak - +'| 2011-04-21 12:34:56 | 16 | 16 |'+sLineBreak - +'| 2011-10-30 06:31:41 | 44 | 43 |'+sLineBreak - +'| 2011-01-30 14:03:25 | 5 | 4 |'+sLineBreak - +'| 2004-10-07 11:19:34 | 40 | 41 |'+sLineBreak - +'+---------------------+-----------+-----------+' - ), - - ( - Name: 'WEEKDAY'; - Declaration: '(date)'; - Category: 'Date and Time Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the weekday index for date '+sLineBreak - +'(0 = Monday, 1 = Tuesday, ... 6 = Sunday).'+sLineBreak - +' '+sLineBreak - +'This contrasts with DAYOFWEEK() which follows the ODBC'+sLineBreak - +'standard'+sLineBreak - +'(1 = Sunday, 2 = Monday, ..., 7 = Saturday).'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT WEEKDAY(''2008-02-03 22:23:00'');'+sLineBreak - +'+--------------------------------+'+sLineBreak - +'| WEEKDAY(''2008-02-03 22:23:00'') |'+sLineBreak - +'+--------------------------------+'+sLineBreak - +'| 6 |'+sLineBreak - +'+--------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT WEEKDAY(''2007-11-06'');'+sLineBreak - +'+-----------------------+'+sLineBreak - +'| WEEKDAY(''2007-11-06'') |'+sLineBreak - +'+-----------------------+'+sLineBreak - +'| 1 |'+sLineBreak - +'+-----------------------+'+sLineBreak - +' '+sLineBreak - +'CREATE TABLE t1 (d DATETIME);'+sLineBreak - +'INSERT INTO t1 VALUES'+sLineBreak - +' ("2007-01-30 21:31:07"),'+sLineBreak - +' ("1983-10-15 06:42:51"),'+sLineBreak - +' ("2011-04-21 12:34:56"),'+sLineBreak - +' ("2011-10-30 06:31:41"),'+sLineBreak - +' ("2011-01-30 14:03:25"),'+sLineBreak - +' ("2004-10-07 11:19:34");'+sLineBreak - +' '+sLineBreak - +'SELECT d FROM t1 where WEEKDAY(d) = 6;'+sLineBreak - +' '+sLineBreak - +'+---------------------+'+sLineBreak - +'| d |'+sLineBreak - +'+---------------------+'+sLineBreak - +'| 2011-10-30 06:31:41 |'+sLineBreak - +'| 2011-01-30 14:03:25 |'+sLineBreak - +'+---------------------+' - ), - - ( - Name: 'WEEKOFYEAR'; - Declaration: '(date)'; - Category: 'Date and Time Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the calendar week of the date as a number in the'+sLineBreak - +'range from 1'+sLineBreak - +'to 53. WEEKOFYEAR() is a compatibility function that is'+sLineBreak - +'equivalent to'+sLineBreak - +'WEEK(date,3).'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT WEEKOFYEAR(''2008-02-20'');'+sLineBreak - +'+--------------------------+'+sLineBreak - +'| WEEKOFYEAR(''2008-02-20'') |'+sLineBreak - +'+--------------------------+'+sLineBreak - +'| 8 |'+sLineBreak - +'+--------------------------+'+sLineBreak - +' '+sLineBreak - +'CREATE TABLE t1 (d DATETIME);'+sLineBreak - +'INSERT INTO t1 VALUES'+sLineBreak - +' ("2007-01-30 21:31:07"),'+sLineBreak - +' ("1983-10-15 06:42:51"),'+sLineBreak - +' ("2011-04-21 12:34:56"),'+sLineBreak - +' ("2011-10-30 06:31:41"),'+sLineBreak - +' ("2011-01-30 14:03:25"),'+sLineBreak - +' ("2004-10-07 11:19:34");'+sLineBreak - +' '+sLineBreak - +' select * from t1;'+sLineBreak - +' '+sLineBreak - +'+---------------------+'+sLineBreak - +'| d |'+sLineBreak - +'+---------------------+'+sLineBreak - +'| 2007-01-30 21:31:07 |'+sLineBreak - +'| 1983-10-15 06:42:51 |'+sLineBreak - +'| 2011-04-21 12:34:56 |'+sLineBreak - +'| 2011-10-30 06:31:41 |'+sLineBreak - +'| 2011-01-30 14:03:25 |'+sLineBreak - +'| 2004-10-07 11:19:34 |'+sLineBreak - +'+---------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT d, WEEKOFYEAR(d), WEEK(d,3) from t1;'+sLineBreak - +' '+sLineBreak - +'+---------------------+---------------+-----------+'+sLineBreak - +'| d | WEEKOFYEAR(d) | WEEK(d,3) |'+sLineBreak - +'+---------------------+---------------+-----------+'+sLineBreak - +'| 2007-01-30 21:31:07 | 5 | 5 |'+sLineBreak - +'| 1983-10-15 06:42:51 | 41 | 41 |'+sLineBreak - +'| 2011-04-21 12:34:56 | 16 | 16 |'+sLineBreak - +'| 2011-10-30 06:31:41 | 43 | 43 |'+sLineBreak - +'| 2011-01-30 14:03:25 | 4 | 4 |'+sLineBreak - +'| 2004-10-07 11:19:34 | 41 | 41 |'+sLineBreak - +'+---------------------+---------------+-----------+' - ), - - ( - Name: 'YEAR'; - Declaration: '(date)'; - Category: 'Date and Time Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the year for the given date, in the range 1000 to'+sLineBreak - +'9999, or 0 for the'+sLineBreak - +'"zero" date.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'CREATE TABLE t1 (d DATETIME);'+sLineBreak - +'INSERT INTO t1 VALUES'+sLineBreak - +' ("2007-01-30 21:31:07"),'+sLineBreak - +' ("1983-10-15 06:42:51"),'+sLineBreak - +' ("2011-04-21 12:34:56"),'+sLineBreak - +' ("2011-10-30 06:31:41"),'+sLineBreak - +' ("2011-01-30 14:03:25"),'+sLineBreak - +' ("2004-10-07 11:19:34");'+sLineBreak - +' '+sLineBreak - +'SELECT * FROM t1;'+sLineBreak - +' '+sLineBreak - +'+---------------------+'+sLineBreak - +'| d |'+sLineBreak - +'+---------------------+'+sLineBreak - +'| 2007-01-30 21:31:07 |'+sLineBreak - +'| 1983-10-15 06:42:51 |'+sLineBreak - +'| 2011-04-21 12:34:56 |'+sLineBreak - +'| 2011-10-30 06:31:41 |'+sLineBreak - +'| 2011-01-30 14:03:25 |'+sLineBreak - +'| 2004-10-07 11:19:34 |'+sLineBreak - +'+---------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT * FROM t1 WHERE YEAR(d) = 2011;'+sLineBreak - +' '+sLineBreak - +'+---------------------+'+sLineBreak - +'| d |'+sLineBreak - +'+---------------------+'+sLineBreak - +'| 2011-04-21 12:34:56 |'+sLineBreak - +'| 2011-10-30 06:31:41 |'+sLineBreak - +'| 2011-01-30 14:03:25 |'+sLineBreak - +'+---------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT YEAR(''1987-01-01'');'+sLineBreak - +'+--------------------+'+sLineBreak - +'| YEAR(''1987-01-01'') |'+sLineBreak - +'+--------------------+'+sLineBreak - +'| 1987 |'+sLineBreak - +'+--------------------+' - ), - - ( - Name: 'YEARWEEK'; - Declaration: '(date)'; - Category: 'Date and Time Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns year and week for a date. The mode argument works'+sLineBreak - +'exactly like the mode'+sLineBreak - +'argument to WEEK(). The year in the result may be different'+sLineBreak - +'from the'+sLineBreak - +'year in the date argument for the first and the last week of'+sLineBreak - +'the year.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT YEARWEEK(''1987-01-01'');'+sLineBreak - +'+------------------------+'+sLineBreak - +'| YEARWEEK(''1987-01-01'') |'+sLineBreak - +'+------------------------+'+sLineBreak - +'| 198652 |'+sLineBreak - +'+------------------------+'+sLineBreak - +' '+sLineBreak - +'CREATE TABLE t1 (d DATETIME);'+sLineBreak - +'INSERT INTO t1 VALUES'+sLineBreak - +' ("2007-01-30 21:31:07"),'+sLineBreak - +' ("1983-10-15 06:42:51"),'+sLineBreak - +' ("2011-04-21 12:34:56"),'+sLineBreak - +' ("2011-10-30 06:31:41"),'+sLineBreak - +' ("2011-01-30 14:03:25"),'+sLineBreak - +' ("2004-10-07 11:19:34");'+sLineBreak - +' '+sLineBreak - +'SELECT * FROM t1;'+sLineBreak - +' '+sLineBreak - +'+---------------------+'+sLineBreak - +'| d |'+sLineBreak - +'+---------------------+'+sLineBreak - +'| 2007-01-30 21:31:07 |'+sLineBreak - +'| 1983-10-15 06:42:51 |'+sLineBreak - +'| 2011-04-21 12:34:56 |'+sLineBreak - +'| 2011-10-30 06:31:41 |'+sLineBreak - +'| 2011-01-30 14:03:25 |'+sLineBreak - +'| 2004-10-07 11:19:34 |'+sLineBreak - +'+---------------------+'+sLineBreak - +'6 rows in set (0.02 sec)'+sLineBreak - +' '+sLineBreak - +'SELECT YEARWEEK(d) FROM t1 WHERE YEAR(d) = 2011;'+sLineBreak - +' '+sLineBreak - +'+-------------+'+sLineBreak - +'| YEARWEEK(d) |'+sLineBreak - +'+-------------+'+sLineBreak - +'| 201116 |'+sLineBreak - +'| 201144 |'+sLineBreak - +'| 201105 |'+sLineBreak - +'+-------------+'+sLineBreak - +'3 rows in set (0.03 sec)' - ), - - ( - Name: 'YEARWEEK'; - Declaration: '(date,mode)'; - Category: 'Date and Time Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns year and week for a date. The mode argument works'+sLineBreak - +'exactly like the mode'+sLineBreak - +'argument to WEEK(). The year in the result may be different'+sLineBreak - +'from the'+sLineBreak - +'year in the date argument for the first and the last week of'+sLineBreak - +'the year.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT YEARWEEK(''1987-01-01'');'+sLineBreak - +'+------------------------+'+sLineBreak - +'| YEARWEEK(''1987-01-01'') |'+sLineBreak - +'+------------------------+'+sLineBreak - +'| 198652 |'+sLineBreak - +'+------------------------+'+sLineBreak - +' '+sLineBreak - +'CREATE TABLE t1 (d DATETIME);'+sLineBreak - +'INSERT INTO t1 VALUES'+sLineBreak - +' ("2007-01-30 21:31:07"),'+sLineBreak - +' ("1983-10-15 06:42:51"),'+sLineBreak - +' ("2011-04-21 12:34:56"),'+sLineBreak - +' ("2011-10-30 06:31:41"),'+sLineBreak - +' ("2011-01-30 14:03:25"),'+sLineBreak - +' ("2004-10-07 11:19:34");'+sLineBreak - +' '+sLineBreak - +'SELECT * FROM t1;'+sLineBreak - +' '+sLineBreak - +'+---------------------+'+sLineBreak - +'| d |'+sLineBreak - +'+---------------------+'+sLineBreak - +'| 2007-01-30 21:31:07 |'+sLineBreak - +'| 1983-10-15 06:42:51 |'+sLineBreak - +'| 2011-04-21 12:34:56 |'+sLineBreak - +'| 2011-10-30 06:31:41 |'+sLineBreak - +'| 2011-01-30 14:03:25 |'+sLineBreak - +'| 2004-10-07 11:19:34 |'+sLineBreak - +'+---------------------+'+sLineBreak - +'6 rows in set (0.02 sec)'+sLineBreak - +' '+sLineBreak - +'SELECT YEARWEEK(d) FROM t1 WHERE YEAR(d) = 2011;'+sLineBreak - +' '+sLineBreak - +'+-------------+'+sLineBreak - +'| YEARWEEK(d) |'+sLineBreak - +'+-------------+'+sLineBreak - +'| 201116 |'+sLineBreak - +'| 201144 |'+sLineBreak - +'| 201105 |'+sLineBreak - +'+-------------+'+sLineBreak - +'3 rows in set (0.03 sec)' - ), - - ( - Name: 'COLUMN_ADD'; - Declaration: '(dyncol_blob, column_nr, value [as type], [column_nr, value [as type]]...)'; - Category: 'Dynamic Column Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Adds or updates dynamic columns.'+sLineBreak - +'dyncol_blob must be either a valid dynamic columns blob (for'+sLineBreak - +'example, COLUMN_CREATE returns such blob), or an empty'+sLineBreak - +'string.'+sLineBreak - +'column_name specifies the name of the column to be added. If'+sLineBreak - +'dyncol_blob already has a column with this name, it will be'+sLineBreak - +'overwritten.'+sLineBreak - +'value specifies the new value for the column. Passing a NULL'+sLineBreak - +'value will cause the column to be deleted.'+sLineBreak - +'as type is optional. See #datatypes section for a discussion'+sLineBreak - +'about types.'+sLineBreak - +' '+sLineBreak - +'The return value is a dynamic column blob after the'+sLineBreak - +'modifications.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'-- MariaDB 5.3+:'+sLineBreak - +'UPDATE tbl SET dyncol_blob=COLUMN_ADD(dyncol_blob, 1'+sLineBreak - +'/*column id*/, "value") WHERE id=1;'+sLineBreak - +' '+sLineBreak - +'-- MariaDB 10.0.1+:'+sLineBreak - +'UPDATE t1 SET dyncol_blob=COLUMN_ADD(dyncol_blob,'+sLineBreak - +'"column_name", "value") WHERE id=1;'+sLineBreak - +' '+sLineBreak - +'Note: COLUMN_ADD() is a regular function (just like'+sLineBreak - +'CONCAT()), hence, in order to update the value in the table'+sLineBreak - +'you have to use the UPDATE ... SET'+sLineBreak - +'dynamic_col=COLUMN_ADD(dynamic_col,'+sLineBreak - +'....) pattern.' - ), - - ( - Name: 'COLUMN_ADD'; - Declaration: '(dyncol_blob, column_name, value [as type], [column_name, value [as type]]...)'; - Category: 'Dynamic Column Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Adds or updates dynamic columns.'+sLineBreak - +'dyncol_blob must be either a valid dynamic columns blob (for'+sLineBreak - +'example, COLUMN_CREATE returns such blob), or an empty'+sLineBreak - +'string.'+sLineBreak - +'column_name specifies the name of the column to be added. If'+sLineBreak - +'dyncol_blob already has a column with this name, it will be'+sLineBreak - +'overwritten.'+sLineBreak - +'value specifies the new value for the column. Passing a NULL'+sLineBreak - +'value will cause the column to be deleted.'+sLineBreak - +'as type is optional. See #datatypes section for a discussion'+sLineBreak - +'about types.'+sLineBreak - +' '+sLineBreak - +'The return value is a dynamic column blob after the'+sLineBreak - +'modifications.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'-- MariaDB 5.3+:'+sLineBreak - +'UPDATE tbl SET dyncol_blob=COLUMN_ADD(dyncol_blob, 1'+sLineBreak - +'/*column id*/, "value") WHERE id=1;'+sLineBreak - +' '+sLineBreak - +'-- MariaDB 10.0.1+:'+sLineBreak - +'UPDATE t1 SET dyncol_blob=COLUMN_ADD(dyncol_blob,'+sLineBreak - +'"column_name", "value") WHERE id=1;'+sLineBreak - +' '+sLineBreak - +'Note: COLUMN_ADD() is a regular function (just like'+sLineBreak - +'CONCAT()), hence, in order to update the value in the table'+sLineBreak - +'you have to use the UPDATE ... SET'+sLineBreak - +'dynamic_col=COLUMN_ADD(dynamic_col,'+sLineBreak - +'....) pattern.' - ), - - ( - Name: 'COLUMN_CHECK'; - Declaration: '(dyncol_blob)'; - Category: 'Dynamic Column Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Check if dyncol_blob is a valid packed dynamic columns blob.'+sLineBreak - +'Return value of 1 means the blob is valid, return value of 0'+sLineBreak - +'means it is not.'+sLineBreak - +' '+sLineBreak - +'Rationale:'+sLineBreak - +'Normally, one works with valid dynamic column blobs.'+sLineBreak - +'Functions like COLUMN_CREATE, COLUMN_ADD, COLUMN_DELETE'+sLineBreak - +'always return valid dynamic column blobs. However, if a'+sLineBreak - +'dynamic column blob is accidentally truncated, or transcoded'+sLineBreak - +'from one character set to another, it will be corrupted.'+sLineBreak - +'This function can be used to check if a value in a blob'+sLineBreak - +'field is a valid dynamic column blob.' - ), - - ( - Name: 'COLUMN_CREATE'; - Declaration: '(column_nr, value [as type], [column_nr, value [as type]]...)'; - Category: 'Dynamic Column Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns a dynamic columns blob that stores the specified'+sLineBreak - +'columns with values.'+sLineBreak - +' '+sLineBreak - +'The return value is suitable for '+sLineBreak - +'storing in a table'+sLineBreak - +'further modification with other dynamic columns functions'+sLineBreak - +' '+sLineBreak - +'The as type part allows one to specify the value type. In'+sLineBreak - +'most cases,'+sLineBreak - +'this is redundant because MariaDB will be able to deduce the'+sLineBreak - +'type of the'+sLineBreak - +'value. Explicit type specification may be needed when the'+sLineBreak - +'type of the value is'+sLineBreak - +'not apparent. For example, a literal ''2012-12-01'' has a'+sLineBreak - +'CHAR type by'+sLineBreak - +'default, one will need to specify ''2012-12-01'' AS DATE to'+sLineBreak - +'have it stored as'+sLineBreak - +'a date. See Dynamic Columns:Datatypes for further details.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'-- MariaDB 5.3+:'+sLineBreak - +'INSERT INTO tbl SET dyncol_blob=COLUMN_CREATE(1 /*column'+sLineBreak - +'id*/, "value");'+sLineBreak - +'-- MariaDB 10.0.1+:'+sLineBreak - +'INSERT INTO tbl SET'+sLineBreak - +'dyncol_blob=COLUMN_CREATE("column_name", "value");' - ), - - ( - Name: 'COLUMN_CREATE'; - Declaration: '(column_name, value [as type], [column_name, value [as type]]...)'; - Category: 'Dynamic Column Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns a dynamic columns blob that stores the specified'+sLineBreak - +'columns with values.'+sLineBreak - +' '+sLineBreak - +'The return value is suitable for '+sLineBreak - +'storing in a table'+sLineBreak - +'further modification with other dynamic columns functions'+sLineBreak - +' '+sLineBreak - +'The as type part allows one to specify the value type. In'+sLineBreak - +'most cases,'+sLineBreak - +'this is redundant because MariaDB will be able to deduce the'+sLineBreak - +'type of the'+sLineBreak - +'value. Explicit type specification may be needed when the'+sLineBreak - +'type of the value is'+sLineBreak - +'not apparent. For example, a literal ''2012-12-01'' has a'+sLineBreak - +'CHAR type by'+sLineBreak - +'default, one will need to specify ''2012-12-01'' AS DATE to'+sLineBreak - +'have it stored as'+sLineBreak - +'a date. See Dynamic Columns:Datatypes for further details.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'-- MariaDB 5.3+:'+sLineBreak - +'INSERT INTO tbl SET dyncol_blob=COLUMN_CREATE(1 /*column'+sLineBreak - +'id*/, "value");'+sLineBreak - +'-- MariaDB 10.0.1+:'+sLineBreak - +'INSERT INTO tbl SET'+sLineBreak - +'dyncol_blob=COLUMN_CREATE("column_name", "value");' - ), - - ( - Name: 'COLUMN_DELETE'; - Declaration: '(dyncol_blob, column_nr, column_nr...)'; - Category: 'Dynamic Column Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Deletes a dynamic column with the specified name. Multiple'+sLineBreak - +'names can be given. The return value is a dynamic column'+sLineBreak - +'blob after the modification.' - ), - - ( - Name: 'COLUMN_DELETE'; - Declaration: '(dyncol_blob, column_name, column_name...)'; - Category: 'Dynamic Column Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Deletes a dynamic column with the specified name. Multiple'+sLineBreak - +'names can be given. The return value is a dynamic column'+sLineBreak - +'blob after the modification.' - ), - - ( - Name: 'COLUMN_EXISTS'; - Declaration: '(dyncol_blob, column_nr)'; - Category: 'Dynamic Column Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Checks if a column with name column_name exists in'+sLineBreak - +'dyncol_blob. If yes, return 1, otherwise return 0. See'+sLineBreak - +'dynamic columns for more information.' - ), - - ( - Name: 'COLUMN_EXISTS'; - Declaration: '(dyncol_blob, column_name)'; - Category: 'Dynamic Column Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Checks if a column with name column_name exists in'+sLineBreak - +'dyncol_blob. If yes, return 1, otherwise return 0. See'+sLineBreak - +'dynamic columns for more information.' - ), - - ( - Name: 'COLUMN_GET'; - Declaration: '(dyncol_blob, column_nr as type)'; - Category: 'Dynamic Column Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Gets the value of a dynamic column by its name. If no column'+sLineBreak - +'with the given name exists, NULL will be returned.'+sLineBreak - +' '+sLineBreak - +'column_name as type requires that one specify the datatype'+sLineBreak - +'of the dynamic column they are reading. '+sLineBreak - +' '+sLineBreak - +'This may seem counter-intuitive: why would one need to'+sLineBreak - +'specify which datatype they''re retrieving? Can''t the'+sLineBreak - +'dynamic columns system figure the datatype from the data'+sLineBreak - +'being stored?'+sLineBreak - +' '+sLineBreak - +'The answer is: SQL is a statically-typed language. The SQL'+sLineBreak - +'interpreter needs to know the datatypes of all expressions'+sLineBreak - +'before the query is run (for example, when one is using'+sLineBreak - +'prepared statements and runs "select COLUMN_GET(...)", the'+sLineBreak - +'prepared statement API requires the server to inform the'+sLineBreak - +'client about the datatype of the column being read before'+sLineBreak - +'the query is executed and the server can see what datatype'+sLineBreak - +'the column actually has).'+sLineBreak - +' '+sLineBreak - +'A note about lengths'+sLineBreak - +' '+sLineBreak - +'If you''re running queries like:'+sLineBreak - +' '+sLineBreak - +'SELECT COLUMN_GET(blob, ''colname'' as CHAR) ...'+sLineBreak - +' '+sLineBreak - +'without specifying a maximum length (i.e. using #as CHAR#,'+sLineBreak - +'not as CHAR(n)), MariaDB will report the maximum length of'+sLineBreak - +'the resultset column to be 53,6870,911 for MariaDB'+sLineBreak - +'5.3-10.0.0 and 16,777,216 for MariaDB 10.0.1+. This may'+sLineBreak - +'cause excessive memory usage in some client libraries,'+sLineBreak - +'because they try to pre-allocate a buffer of maximum'+sLineBreak - +'resultset width. To avoid this problem, use CHAR(n) whenever'+sLineBreak - +'you''re using COLUMN_GET in the select list.'+sLineBreak - +' '+sLineBreak - +'See Dynamic Columns:Datatypes for more information about'+sLineBreak - +'datatypes.' - ), - - ( - Name: 'COLUMN_GET'; - Declaration: '(dyncol_blob, column_name as type)'; - Category: 'Dynamic Column Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Gets the value of a dynamic column by its name. If no column'+sLineBreak - +'with the given name exists, NULL will be returned.'+sLineBreak - +' '+sLineBreak - +'column_name as type requires that one specify the datatype'+sLineBreak - +'of the dynamic column they are reading. '+sLineBreak - +' '+sLineBreak - +'This may seem counter-intuitive: why would one need to'+sLineBreak - +'specify which datatype they''re retrieving? Can''t the'+sLineBreak - +'dynamic columns system figure the datatype from the data'+sLineBreak - +'being stored?'+sLineBreak - +' '+sLineBreak - +'The answer is: SQL is a statically-typed language. The SQL'+sLineBreak - +'interpreter needs to know the datatypes of all expressions'+sLineBreak - +'before the query is run (for example, when one is using'+sLineBreak - +'prepared statements and runs "select COLUMN_GET(...)", the'+sLineBreak - +'prepared statement API requires the server to inform the'+sLineBreak - +'client about the datatype of the column being read before'+sLineBreak - +'the query is executed and the server can see what datatype'+sLineBreak - +'the column actually has).'+sLineBreak - +' '+sLineBreak - +'A note about lengths'+sLineBreak - +' '+sLineBreak - +'If you''re running queries like:'+sLineBreak - +' '+sLineBreak - +'SELECT COLUMN_GET(blob, ''colname'' as CHAR) ...'+sLineBreak - +' '+sLineBreak - +'without specifying a maximum length (i.e. using #as CHAR#,'+sLineBreak - +'not as CHAR(n)), MariaDB will report the maximum length of'+sLineBreak - +'the resultset column to be 53,6870,911 for MariaDB'+sLineBreak - +'5.3-10.0.0 and 16,777,216 for MariaDB 10.0.1+. This may'+sLineBreak - +'cause excessive memory usage in some client libraries,'+sLineBreak - +'because they try to pre-allocate a buffer of maximum'+sLineBreak - +'resultset width. To avoid this problem, use CHAR(n) whenever'+sLineBreak - +'you''re using COLUMN_GET in the select list.'+sLineBreak - +' '+sLineBreak - +'See Dynamic Columns:Datatypes for more information about'+sLineBreak - +'datatypes.' - ), - - ( - Name: 'COLUMN_JSON'; - Declaration: '(dyncol_blob)'; - Category: 'Dynamic Column Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns a JSON representation of data in dyncol_blob. Can'+sLineBreak - +'also be used to display nested columns. See dynamic columns'+sLineBreak - +'for more information.'+sLineBreak - +' '+sLineBreak - +'Example'+sLineBreak - +' '+sLineBreak - +'select item_name, COLUMN_JSON(dynamic_cols) from assets;'+sLineBreak - +'+-----------------+----------------------------------------+'+sLineBreak - +'| item_name | COLUMN_JSON(dynamic_cols) |'+sLineBreak - +'+-----------------+----------------------------------------+'+sLineBreak - +'| MariaDB T-shirt | {"size":"XL","color":"blue"} |'+sLineBreak - +'| Thinkpad Laptop | {"color":"black","warranty":"3'+sLineBreak - +'years"} |'+sLineBreak - +'+-----------------+----------------------------------------+'+sLineBreak - +' '+sLineBreak - +'Limitation: COLUMN_JSON will decode nested dynamic columns'+sLineBreak - +'at a nesting level of not more than 10 levels deep. Dynamic'+sLineBreak - +'columns that are nested deeper than 10 levels will be shown'+sLineBreak - +'as BINARY string, without encoding.' - ), - - ( - Name: 'COLUMN_LIST'; - Declaration: '(dyncol_blob)'; - Category: 'Dynamic Column Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Since MariaDB 10.0.1, this function returns a'+sLineBreak - +'comma-separated list of column names. The names are quoted'+sLineBreak - +'with backticks.'+sLineBreak - +' '+sLineBreak - +'Before MariaDB 10.0.1, it returned a comma-separated list of'+sLineBreak - +'column numbers, not names.'+sLineBreak - +' '+sLineBreak - +'See dynamic columns for more information.' - ), - - ( - Name: 'AES_DECRYPT'; - Declaration: '(crypt_str,key_str)'; - Category: 'Encryption Functions'; - Version: SQL_VERSION_ANSI; - Description: 'This function allows decryption of data using the official'+sLineBreak - +'AES'+sLineBreak - +'(Advanced Encryption Standard) algorithm. For more'+sLineBreak - +'information, see'+sLineBreak - +'the description of AES_ENCRYPT().' - ), - - ( - Name: 'AES_ENCRYPT'; - Declaration: '(str,key_str)'; - Category: 'Encryption Functions'; - Version: SQL_VERSION_ANSI; - Description: 'AES_ENCRYPT() and AES_DECRYPT() allow encryption and'+sLineBreak - +'decryption of'+sLineBreak - +'data using the official AES (Advanced Encryption Standard)'+sLineBreak - +'algorithm,'+sLineBreak - +'previously known as "Rijndael." Encoding with a 128-bit'+sLineBreak - +'key length is'+sLineBreak - +'used, but you can extend it up to 256 bits by modifying the'+sLineBreak - +'source. We'+sLineBreak - +'chose 128 bits because it is much faster and it is secure'+sLineBreak - +'enough for'+sLineBreak - +'most purposes.'+sLineBreak - +' '+sLineBreak - +'AES_ENCRYPT() encrypts a string str using the key key_str,'+sLineBreak - +'and returns a binary string.'+sLineBreak - +' '+sLineBreak - +'AES_DECRYPT() decrypts the encrypted string and returns the'+sLineBreak - +'original'+sLineBreak - +'string.'+sLineBreak - +' '+sLineBreak - +'The input arguments may be any length. If either argument is'+sLineBreak - +'NULL, the result of this function is also NULL.'+sLineBreak - +' '+sLineBreak - +'Because AES is a block-level algorithm, padding is used to'+sLineBreak - +'encode'+sLineBreak - +'uneven length strings and so the result string length may be'+sLineBreak - +'calculated using this formula:'+sLineBreak - +' '+sLineBreak - +'16 x (trunc(string_length / 16) + 1)'+sLineBreak - +' '+sLineBreak - +'If AES_DECRYPT() detects invalid data or incorrect padding,'+sLineBreak - +'it returns'+sLineBreak - +'NULL. However, it is possible for AES_DECRYPT() to return a'+sLineBreak - +'non-NULL'+sLineBreak - +'value (possibly garbage) if the input data or the key is'+sLineBreak - +'invalid.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'INSERT INTO t VALUES'+sLineBreak - +'(AES_ENCRYPT(''text'',SHA2(''password'',512)));' - ), - - ( - Name: 'COMPRESS'; - Declaration: '(string_to_compress)'; - Category: 'Encryption Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Compresses a string and returns the result as a binary'+sLineBreak - +'string. This'+sLineBreak - +'function requires MariaDB to have been compiled with a'+sLineBreak - +'compression'+sLineBreak - +'library such as zlib. Otherwise, the return value is always'+sLineBreak - +'NULL. The'+sLineBreak - +'compressed string can be uncompressed with UNCOMPRESS().'+sLineBreak - +' '+sLineBreak - +'The have_compress server system variable indicates whether a'+sLineBreak - +'compression library is present. '+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT LENGTH(COMPRESS(REPEAT(''a'',1000)));'+sLineBreak - +'+------------------------------------+'+sLineBreak - +'| LENGTH(COMPRESS(REPEAT(''a'',1000))) |'+sLineBreak - +'+------------------------------------+'+sLineBreak - +'| 21 |'+sLineBreak - +'+------------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT LENGTH(COMPRESS(''''));'+sLineBreak - +'+----------------------+'+sLineBreak - +'| LENGTH(COMPRESS('''')) |'+sLineBreak - +'+----------------------+'+sLineBreak - +'| 0 |'+sLineBreak - +'+----------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT LENGTH(COMPRESS(''a''));'+sLineBreak - +'+-----------------------+'+sLineBreak - +'| LENGTH(COMPRESS(''a'')) |'+sLineBreak - +'+-----------------------+'+sLineBreak - +'| 13 |'+sLineBreak - +'+-----------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT LENGTH(COMPRESS(REPEAT(''a'',16)));'+sLineBreak - +'+----------------------------------+'+sLineBreak - +'| LENGTH(COMPRESS(REPEAT(''a'',16))) |'+sLineBreak - +'+----------------------------------+'+sLineBreak - +'| 15 |'+sLineBreak - +'+----------------------------------+' - ), - - ( - Name: 'DECODE'; - Declaration: '(crypt_str,pass_str)'; - Category: 'Encryption Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Decrypts the encrypted string crypt_str using pass_str as'+sLineBreak - +'the'+sLineBreak - +'password. crypt_str should be a string returned from'+sLineBreak - +'ENCODE(). The resulting string will be the original string'+sLineBreak - +'only if pass_str is the same.' - ), - - ( - Name: 'DES_DECRYPT'; - Declaration: '(crypt_str[,key_str])'; - Category: 'Encryption Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Decrypts a string encrypted with DES_ENCRYPT(). If an error'+sLineBreak - +'occurs,'+sLineBreak - +'this function returns NULL.'+sLineBreak - +' '+sLineBreak - +'This function works only if MariaDB has been configured with'+sLineBreak - +'TLS'+sLineBreak - +'support.'+sLineBreak - +' '+sLineBreak - +'If no key_str argument is given, DES_DECRYPT() examines the'+sLineBreak - +'first byte'+sLineBreak - +'of the encrypted string to determine the DES key number that'+sLineBreak - +'was used'+sLineBreak - +'to encrypt the original string, and then reads the key from'+sLineBreak - +'the DES'+sLineBreak - +'key file to decrypt the message. For this to work, the user'+sLineBreak - +'must have'+sLineBreak - +'the SUPER privilege. The key file can be specified with the'+sLineBreak - +'--des-key-file server option.'+sLineBreak - +' '+sLineBreak - +'If you pass this function a key_str argument, that string is'+sLineBreak - +'used as'+sLineBreak - +'the key for decrypting the message.'+sLineBreak - +' '+sLineBreak - +'If the crypt_str argument does not appear to be an encrypted'+sLineBreak - +'string,'+sLineBreak - +'MariaDB returns the given crypt_str.' - ), - - ( - Name: 'DES_ENCRYPT'; - Declaration: '(str[,{key_num|key_str}])'; - Category: 'Encryption Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Encrypts the string with the given key using the Triple-DES'+sLineBreak - +'algorithm.'+sLineBreak - +' '+sLineBreak - +'This function works only if MariaDB has been configured with'+sLineBreak - +'TLS support.'+sLineBreak - +' '+sLineBreak - +'The encryption key to use is chosen based on the second'+sLineBreak - +'argument to'+sLineBreak - +'DES_ENCRYPT(), if one was given. With no argument, the first'+sLineBreak - +'key from'+sLineBreak - +'the DES key file is used. With a key_num argument, the given'+sLineBreak - +'key '+sLineBreak - +'number (0-9) from the DES key file is used. With a key_str'+sLineBreak - +'argument,'+sLineBreak - +'the given key string is used to encrypt str. '+sLineBreak - +' '+sLineBreak - +'The key file can be specified with the --des-key-file server'+sLineBreak - +'option.'+sLineBreak - +' '+sLineBreak - +'The return string is a binary string where the first'+sLineBreak - +'character is '+sLineBreak - +'CHAR(128 | key_num). If an error occurs, DES_ENCRYPT()'+sLineBreak - +'returns NULL.'+sLineBreak - +' '+sLineBreak - +'The 128 is added to make it easier to recognize an encrypted'+sLineBreak - +'key. If'+sLineBreak - +'you use a string key, key_num is 127.'+sLineBreak - +' '+sLineBreak - +'The string length for the result is given by this formula:'+sLineBreak - +' '+sLineBreak - +'new_len = orig_len + (8 - (orig_len % 8)) + 1'+sLineBreak - +' '+sLineBreak - +'Each line in the DES key file has the following format:'+sLineBreak - +' '+sLineBreak - +'key_num des_key_str'+sLineBreak - +' '+sLineBreak - +'Each key_num value must be a number in the range from 0 to'+sLineBreak - +'9. Lines in'+sLineBreak - +'the file may be in any order. des_key_str is the string that'+sLineBreak - +'is used'+sLineBreak - +'to encrypt the message. There should be at least one space'+sLineBreak - +'between the'+sLineBreak - +'number and the key. The first key is the default key that is'+sLineBreak - +'used if'+sLineBreak - +'you do not specify any key argument to DES_ENCRYPT().'+sLineBreak - +' '+sLineBreak - +'You can tell MariaDB to read new key values from the key'+sLineBreak - +'file with the'+sLineBreak - +'FLUSH DES_KEY_FILE statement. This requires the RELOAD'+sLineBreak - +'privilege.'+sLineBreak - +' '+sLineBreak - +'One benefit of having a set of default keys is that it gives'+sLineBreak - +'applications a way to check for the existence of encrypted'+sLineBreak - +'column'+sLineBreak - +'values, without giving the end user the right to decrypt'+sLineBreak - +'those values.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT customer_address FROM customer_table '+sLineBreak - +' WHERE crypted_credit_card ='+sLineBreak - +'DES_ENCRYPT(''credit_card_number'');' - ), - - ( - Name: 'ENCODE'; - Declaration: '(str,pass_str)'; - Category: 'Encryption Functions'; - Version: SQL_VERSION_ANSI; - Description: 'ENCODE is not considered cryptographically secure, and'+sLineBreak - +'should not be used for password encryption.'+sLineBreak - +' '+sLineBreak - +'Encrypt str using pass_str as the password. To decrypt the'+sLineBreak - +'result, use'+sLineBreak - +'DECODE().'+sLineBreak - +' '+sLineBreak - +'The result is a binary string of the same length as str.'+sLineBreak - +' '+sLineBreak - +'The strength of the encryption is based on how good the'+sLineBreak - +'random generator is. '+sLineBreak - +' '+sLineBreak - +'It is not recommended to rely on the encryption performed by'+sLineBreak - +'the ENCODE function. Using a salt value (changed when a'+sLineBreak - +'password is updated) will improve matters somewhat, but for'+sLineBreak - +'storing passwords, consider a more cryptographically secure'+sLineBreak - +'function, such as SHA2().'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'ENCODE(''not so secret text'','+sLineBreak - +'CONCAT(''random_salt'',''password''))' - ), - - ( - Name: 'ENCRYPT'; - Declaration: '(str[,salt])'; - Category: 'Encryption Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Encrypts a string using the Unix crypt() system call,'+sLineBreak - +'returning an encrypted binary string. The salt argument'+sLineBreak - +'should be a string with at least two characters or the'+sLineBreak - +'returned result will be NULL. If no salt argument is given,'+sLineBreak - +'a random value of sufficient length is used.'+sLineBreak - +' '+sLineBreak - +'It is not recommended to use ENCRYPT() with utf16, utf32 or'+sLineBreak - +'ucs2 multi-byte character sets because the crypt() system'+sLineBreak - +'call expects a string terminated with a zero byte.'+sLineBreak - +' '+sLineBreak - +'Note that the underlying crypt() system call may have some'+sLineBreak - +'limitations, such as ignoring all but the first eight'+sLineBreak - +'characters.'+sLineBreak - +' '+sLineBreak - +'If the have_crypt system variable is set to NO (because the'+sLineBreak - +'crypt() system call is not available), the ENCRYPT function'+sLineBreak - +'will always return NULL.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT ENCRYPT(''encrypt me'');'+sLineBreak - +'+-----------------------+'+sLineBreak - +'| ENCRYPT(''encrypt me'') |'+sLineBreak - +'+-----------------------+'+sLineBreak - +'| 4I5BsEx0lqTDk |'+sLineBreak - +'+-----------------------+' - ), - - ( - Name: 'MD5'; - Declaration: '(str)'; - Category: 'Encryption Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Calculates an MD5 128-bit checksum for the string. '+sLineBreak - +' '+sLineBreak - +'The return value is a 32-hex digit string, and as of MariaDB'+sLineBreak - +'5.5, is a nonbinary string in the connection character set'+sLineBreak - +'and collation, determined by the values of the'+sLineBreak - +'character_set_connection and collation_connection system'+sLineBreak - +'variables. Before 5.5, the return value was a binary string.'+sLineBreak - +' '+sLineBreak - +'NULL is returned if the argument was NULL. '+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT MD5(''testing'');'+sLineBreak - +'+----------------------------------+'+sLineBreak - +'| MD5(''testing'') |'+sLineBreak - +'+----------------------------------+'+sLineBreak - +'| ae2b1fca515949e5d54fb22b8ed95575 |'+sLineBreak - +'+----------------------------------+' - ), - - ( - Name: 'OLD_PASSWORD'; - Declaration: '(str)'; - Category: 'Encryption Functions'; - Version: SQL_VERSION_ANSI; - Description: 'OLD_PASSWORD() was added to MySQL when the implementation of'+sLineBreak - +''+sLineBreak - +'PASSWORD() was changed to improve security. OLD_PASSWORD()'+sLineBreak - +'returns the'+sLineBreak - +'value of the old (pre-MySQL 4.1) implementation of'+sLineBreak - +'PASSWORD() as a'+sLineBreak - +'string, and is intended to permit you to reset passwords for'+sLineBreak - +'any'+sLineBreak - +'pre-4.1 clients that need to connect to a more recent MySQL'+sLineBreak - +'server version, or any version of MariaDB,'+sLineBreak - +'without locking them out.'+sLineBreak - +' '+sLineBreak - +'As of MariaDB 5.5, the return value is a nonbinary string in'+sLineBreak - +'the connection character set and collation, determined by'+sLineBreak - +'the values of the character_set_connection and'+sLineBreak - +'collation_connection system variables. Before 5.5, the'+sLineBreak - +'return value was a binary string.'+sLineBreak - +' '+sLineBreak - +'The return value is 16 bytes in length, or NULL if the'+sLineBreak - +'argument was NULL.' - ), - - ( - Name: 'PASSWORD'; - Declaration: '(str)'; - Category: 'Encryption Functions'; - Version: SQL_VERSION_ANSI; - Description: 'The PASSWORD() function is used for hashing passwords for'+sLineBreak - +'use in authentication by the MariaDB server. It is not'+sLineBreak - +'intended for use in other applications.'+sLineBreak - +' '+sLineBreak - +'Calculates and returns a hashed password string from the'+sLineBreak - +'plaintext password str. Returns an empty string (>= MariaDB'+sLineBreak - +'10.0.4) or NULL (' - ), - - ( - Name: 'SHA1'; - Declaration: '(str)'; - Category: 'Encryption Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Calculates an SHA-1 160-bit checksum for the string str, as'+sLineBreak - +'described in'+sLineBreak - +'RFC 3174 (Secure Hash Algorithm).'+sLineBreak - +' '+sLineBreak - +'The value is returned as a string of 40 hex digits, or NULL'+sLineBreak - +'if the argument was NULL. As of MariaDB 5.5, the return'+sLineBreak - +'value is a nonbinary string in the connection character set'+sLineBreak - +'and collation, determined by the values of the'+sLineBreak - +'character_set_connection and collation_connection system'+sLineBreak - +'variables. Before 5.5, the return value was a binary string.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT SHA1(''some boring text'');'+sLineBreak - +'+------------------------------------------+'+sLineBreak - +'| SHA1(''some boring text'') |'+sLineBreak - +'+------------------------------------------+'+sLineBreak - +'| af969fc2085b1bb6d31e517d5c456def5cdd7093 |'+sLineBreak - +'+------------------------------------------+' - ), - - ( - Name: 'SHA2'; - Declaration: '(str,hash_len)'; - Category: 'Encryption Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Given a string str, calculates an SHA-2 checksum, which is'+sLineBreak - +'considered more cryptographically secure than its SHA-1'+sLineBreak - +'equivalent. The SHA-2 family includes SHA-224, SHA-256,'+sLineBreak - +'SHA-384, and SHA-512, and the hash_len must correspond to'+sLineBreak - +'one of these, i.e. 224, 256, 384 or 512. 0 is equivalent to'+sLineBreak - +'256.'+sLineBreak - +' '+sLineBreak - +'The return value is a nonbinary string in the connection'+sLineBreak - +'character set and collation, determined by the values of the'+sLineBreak - +'character_set_connection and collation_connection system'+sLineBreak - +'variables. '+sLineBreak - +' '+sLineBreak - +'NULL is returned if the hash length is not valid, or the'+sLineBreak - +'string str is NULL.'+sLineBreak - +' '+sLineBreak - +'SHA2 will only work if MariaDB was has been configured with'+sLineBreak - +'TLS support. '+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT SHA2(''Maria'',224);'+sLineBreak - +'+----------------------------------------------------------+'+sLineBreak - +'| SHA2(''Maria'',224) |'+sLineBreak - +'+----------------------------------------------------------+'+sLineBreak - +'| 6cc67add32286412efcab9d0e1675a43a5c2ef3cec8879f81516ff83 |'+sLineBreak - +'+----------------------------------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT SHA2(''Maria'',256);'+sLineBreak - +'+------------------------------------------------------------------+'+sLineBreak - +'| SHA2(''Maria'',256) |'+sLineBreak - +'+------------------------------------------------------------------+'+sLineBreak - +'|'+sLineBreak - +'9ff18ebe7449349f358e3af0b57cf7a032c1c6b2272cb2656ff85eb112232f16'+sLineBreak - +'|'+sLineBreak - +'+------------------------------------------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT SHA2(''Maria'',0);'+sLineBreak - +'+------------------------------------------------------------------+'+sLineBreak - +'| SHA2(''Maria'',0) |'+sLineBreak - +'+------------------------------------------------------------------+'+sLineBreak - +'|'+sLineBreak - +'9ff18ebe7449349f358e3af0b57cf7a032c1c6b2272cb2656ff85eb112232f16'+sLineBreak - +'|'+sLineBreak - +'+------------------------------------------------------------------+' - ), - - ( - Name: 'UNCOMPRESS'; - Declaration: '(string_to_uncompress)'; - Category: 'Encryption Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Uncompresses a string compressed by the COMPRESS() function.'+sLineBreak - +'If the'+sLineBreak - +'argument is not a compressed value, the result is NULL. This'+sLineBreak - +'function'+sLineBreak - +'requires MariaDB to have been compiled with a compression'+sLineBreak - +'library such'+sLineBreak - +'as zlib. Otherwise, the return value is always NULL. The'+sLineBreak - +'have_compress server system variable indicates whether a'+sLineBreak - +'compression library is present. '+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT UNCOMPRESS(COMPRESS(''a string''));'+sLineBreak - +'+----------------------------------+'+sLineBreak - +'| UNCOMPRESS(COMPRESS(''a string'')) |'+sLineBreak - +'+----------------------------------+'+sLineBreak - +'| a string |'+sLineBreak - +'+----------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT UNCOMPRESS(''a string'');'+sLineBreak - +'+------------------------+'+sLineBreak - +'| UNCOMPRESS(''a string'') |'+sLineBreak - +'+------------------------+'+sLineBreak - +'| NULL |'+sLineBreak - +'+------------------------+' - ), - - ( - Name: 'UNCOMPRESSED_LENGTH'; - Declaration: '(compressed_string)'; - Category: 'Encryption Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the length that the compressed string had before'+sLineBreak - +'being'+sLineBreak - +'compressed with COMPRESS().'+sLineBreak - +' '+sLineBreak - +'UNCOMPRESSED_LENGTH() returns NULL or an incorrect result if'+sLineBreak - +'the string is not compressed.'+sLineBreak - +' '+sLineBreak - +'Until MariaDB 10.3.1, returns MYSQL_TYPE_LONGLONG, or'+sLineBreak - +'bigint(10), in all cases. From MariaDB 10.3.1, returns'+sLineBreak - +'MYSQL_TYPE_LONG, or int(10), when the result would fit'+sLineBreak - +'within 32-bits.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT UNCOMPRESSED_LENGTH(COMPRESS(REPEAT(''a'',30)));'+sLineBreak - +'+-----------------------------------------------+'+sLineBreak - +'| UNCOMPRESSED_LENGTH(COMPRESS(REPEAT(''a'',30))) |'+sLineBreak - +'+-----------------------------------------------+'+sLineBreak - +'| 30 |'+sLineBreak - +'+-----------------------------------------------+' - ), - - ( - Name: 'AVG'; - Declaration: '([DISTINCT] expr)'; - Category: 'Functions and Modifiers for Use with GROUP BY'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the average value of expr. The DISTINCT option can'+sLineBreak - +'be used to return the average of the distinct values of'+sLineBreak - +'expr. NULL values are ignored. It is an aggregate function,'+sLineBreak - +'and so can be used with the GROUP BY clause.'+sLineBreak - +' '+sLineBreak - +'AVG() returns NULL if there were no matching rows.'+sLineBreak - +' '+sLineBreak - +'From MariaDB 10.2.0, AVG() can be used as a window function.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'CREATE TABLE sales (sales_value INT);'+sLineBreak - +' '+sLineBreak - +'INSERT INTO sales VALUES(10),(20),(20),(40);'+sLineBreak - +' '+sLineBreak - +'SELECT AVG(sales_value) FROM sales;'+sLineBreak - +' '+sLineBreak - +'+------------------+'+sLineBreak - +'| AVG(sales_value) |'+sLineBreak - +'+------------------+'+sLineBreak - +'| 22.5000 |'+sLineBreak - +'+------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT AVG(DISTINCT(sales_value)) FROM sales;'+sLineBreak - +' '+sLineBreak - +'+----------------------------+'+sLineBreak - +'| AVG(DISTINCT(sales_value)) |'+sLineBreak - +'+----------------------------+'+sLineBreak - +'| 23.3333 |'+sLineBreak - +'+----------------------------+'+sLineBreak - +' '+sLineBreak - +'Commonly, AVG() is used with a GROUP BY clause:'+sLineBreak - +' '+sLineBreak - +'CREATE TABLE student (name CHAR(10), test CHAR(10), score'+sLineBreak - +'TINYINT); '+sLineBreak - +' '+sLineBreak - +'INSERT INTO student VALUES '+sLineBreak - +' (''Chun'', ''SQL'', 75), (''Chun'', ''Tuning'', 73), '+sLineBreak - +' (''Esben'', ''SQL'', 43), (''Esben'', ''Tuning'', 31), '+sLineBreak - +' (''Kaolin'', ''SQL'', 56), (''Kaolin'', ''Tuning'', 88), '+sLineBreak - +' (''Tatiana'', ''SQL'', 87), (''Tatiana'', ''Tuning'', 83);'+sLineBreak - +' '+sLineBreak - +'SELECT name, AVG(score) FROM student GROUP BY name;'+sLineBreak - +' '+sLineBreak - +'+---------+------------+'+sLineBreak - +'| name | AVG(score) |'+sLineBreak - +'+---------+------------+'+sLineBreak - +'| Chun | 74.0000 |'+sLineBreak - +'| Esben | 37.0000 |'+sLineBreak - +'| Kaolin | 72.0000 |'+sLineBreak - +'| Tatiana | 85.0000 |'+sLineBreak - +'+---------+------------+'+sLineBreak - +' '+sLineBreak - +'Be careful to avoid this common mistake, not grouping'+sLineBreak - +'correctly and returning mismatched data: '+sLineBreak - +' '+sLineBreak - +'SELECT name,test,AVG(score) FROM student;'+sLineBreak - +' '+sLineBreak - +'+------+------+------------+'+sLineBreak - +'| name | test | MIN(score) |'+sLineBreak - +'+------+------+------------+'+sLineBreak - +'| Chun | SQL | 31 |'+sLineBreak - +'+------+------+------------+'+sLineBreak - +' '+sLineBreak - +'As a window function:'+sLineBreak - +' '+sLineBreak - +'CREATE TABLE student_test (name CHAR(10), test CHAR(10),'+sLineBreak - +'score TINYINT); '+sLineBreak - +' '+sLineBreak - +'INSERT INTO student_test VALUES '+sLineBreak - +' (''Chun'', ''SQL'', 75), (''Chun'', ''Tuning'', 73), '+sLineBreak - +' (''Esben'', ''SQL'', 43), (''Esben'', ''Tuning'', 31), '+sLineBreak - +' (''Kaolin'', ''SQL'', 56), (''Kaolin'', ''Tuning'', 88), '+sLineBreak - +' (''Tatiana'', ''SQL'', 87), (''Tatiana'', ''Tuning'', 83);'+sLineBreak - +' '+sLineBreak - +'SELECT name, test, score, AVG(score) OVER (PARTITION BY'+sLineBreak - +'test) '+sLineBreak - +' AS average_by_test FROM student_test;'+sLineBreak - +' '+sLineBreak - +'+---------+--------+-------+-----------------+'+sLineBreak - +'| name | test | score | average_by_test |'+sLineBreak - +'+---------+--------+-------+-----------------+'+sLineBreak - +'| Chun | SQL | 75 | 65.2500 |'+sLineBreak - +'| Chun | Tuning | 73 | 68.7500 |'+sLineBreak - +'| Esben | SQL | 43 | 65.2500 |'+sLineBreak - +'| Esben | Tuning | 31 | 68.7500 |'+sLineBreak - +'| Kaolin | SQL | 56 | 65.2500 |'+sLineBreak - +'| Kaolin | Tuning | 88 | 68.7500 |'+sLineBreak - +'| Tatiana | SQL | 87 | 65.2500 |'+sLineBreak - +'| Tatiana | Tuning | 83 | 68.7500 |'+sLineBreak - +'+---------+--------+-------+-----------------+' - ), - - ( - Name: 'BIT_AND'; - Declaration: '(expr)'; - Category: 'Functions and Modifiers for Use with GROUP BY'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the bitwise AND of all bits in expr. The calculation'+sLineBreak - +'is performed with 64-bit (BIGINT) precision. It is an'+sLineBreak - +'aggregate function, and so can be used with the GROUP BY'+sLineBreak - +'clause.'+sLineBreak - +' '+sLineBreak - +'From MariaDB 10.2.0, BIT_AND() can be used as a window'+sLineBreak - +'function.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'CREATE TABLE vals (x INT);'+sLineBreak - +' '+sLineBreak - +'INSERT INTO vals VALUES(111),(110),(100);'+sLineBreak - +' '+sLineBreak - +'SELECT BIT_AND(x), BIT_OR(x), BIT_XOR(x) FROM vals;'+sLineBreak - +' '+sLineBreak - +'+------------+-----------+------------+'+sLineBreak - +'| BIT_AND(x) | BIT_OR(x) | BIT_XOR(x) |'+sLineBreak - +'+------------+-----------+------------+'+sLineBreak - +'| 100 | 111 | 101 |'+sLineBreak - +'+------------+-----------+------------+'+sLineBreak - +' '+sLineBreak - +'As an aggregate function:'+sLineBreak - +' '+sLineBreak - +'CREATE TABLE vals2 (category VARCHAR(1), x INT);'+sLineBreak - +' '+sLineBreak - +'INSERT INTO vals2 VALUES'+sLineBreak - +' (''a'',111),(''a'',110),(''a'',100),'+sLineBreak - +' (''b'',''000''),(''b'',001),(''b'',011);'+sLineBreak - +' '+sLineBreak - +'SELECT category, BIT_AND(x), BIT_OR(x), BIT_XOR(x) '+sLineBreak - +' FROM vals GROUP BY category;'+sLineBreak - +' '+sLineBreak - +'+----------+------------+-----------+------------+'+sLineBreak - +'| category | BIT_AND(x) | BIT_OR(x) | BIT_XOR(x) |'+sLineBreak - +'+----------+------------+-----------+------------+'+sLineBreak - +'| a | 100 | 111 | 101 |'+sLineBreak - +'| b | 0 | 11 | 10 |'+sLineBreak - +'+----------+------------+-----------+------------+' - ), - - ( - Name: 'BIT_OR'; - Declaration: '(expr)'; - Category: 'Functions and Modifiers for Use with GROUP BY'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the bitwise OR of all bits in expr. The calculation'+sLineBreak - +'is performed with 64-bit (BIGINT) precision. It is an'+sLineBreak - +'aggregate function, and so can be used with the GROUP BY'+sLineBreak - +'clause.'+sLineBreak - +' '+sLineBreak - +'From MariaDB 10.2.0, BIT_OR can be used as a window'+sLineBreak - +'function.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'CREATE TABLE vals (x INT);'+sLineBreak - +' '+sLineBreak - +'INSERT INTO vals VALUES(111),(110),(100);'+sLineBreak - +' '+sLineBreak - +'SELECT BIT_AND(x), BIT_OR(x), BIT_XOR(x) FROM vals;'+sLineBreak - +' '+sLineBreak - +'+------------+-----------+------------+'+sLineBreak - +'| BIT_AND(x) | BIT_OR(x) | BIT_XOR(x) |'+sLineBreak - +'+------------+-----------+------------+'+sLineBreak - +'| 100 | 111 | 101 |'+sLineBreak - +'+------------+-----------+------------+'+sLineBreak - +' '+sLineBreak - +'As an aggregate function:'+sLineBreak - +' '+sLineBreak - +'CREATE TABLE vals2 (category VARCHAR(1), x INT);'+sLineBreak - +' '+sLineBreak - +'INSERT INTO vals2 VALUES'+sLineBreak - +' (''a'',111),(''a'',110),(''a'',100),'+sLineBreak - +' (''b'',''000''),(''b'',001),(''b'',011);'+sLineBreak - +' '+sLineBreak - +'SELECT category, BIT_AND(x), BIT_OR(x), BIT_XOR(x) '+sLineBreak - +' FROM vals GROUP BY category;'+sLineBreak - +' '+sLineBreak - +'+----------+------------+-----------+------------+'+sLineBreak - +'| category | BIT_AND(x) | BIT_OR(x) | BIT_XOR(x) |'+sLineBreak - +'+----------+------------+-----------+------------+'+sLineBreak - +'| a | 100 | 111 | 101 |'+sLineBreak - +'| b | 0 | 11 | 10 |'+sLineBreak - +'+----------+------------+-----------+------------+' - ), - - ( - Name: 'BIT_XOR'; - Declaration: '(expr)'; - Category: 'Functions and Modifiers for Use with GROUP BY'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the bitwise XOR of all bits in expr. The calculation'+sLineBreak - +'is performed with 64-bit (BIGINT) precision. It is an'+sLineBreak - +'aggregate function, and so can be used with the GROUP BY'+sLineBreak - +'clause.'+sLineBreak - +' '+sLineBreak - +'From MariaDB 10.2.0, BIT_XOR() can be used as a window'+sLineBreak - +'function.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'CREATE TABLE vals (x INT);'+sLineBreak - +' '+sLineBreak - +'INSERT INTO vals VALUES(111),(110),(100);'+sLineBreak - +' '+sLineBreak - +'SELECT BIT_AND(x), BIT_OR(x), BIT_XOR(x) FROM vals;'+sLineBreak - +' '+sLineBreak - +'+------------+-----------+------------+'+sLineBreak - +'| BIT_AND(x) | BIT_OR(x) | BIT_XOR(x) |'+sLineBreak - +'+------------+-----------+------------+'+sLineBreak - +'| 100 | 111 | 101 |'+sLineBreak - +'+------------+-----------+------------+'+sLineBreak - +' '+sLineBreak - +'As an aggregate function:'+sLineBreak - +' '+sLineBreak - +'CREATE TABLE vals2 (category VARCHAR(1), x INT);'+sLineBreak - +' '+sLineBreak - +'INSERT INTO vals2 VALUES'+sLineBreak - +' (''a'',111),(''a'',110),(''a'',100),'+sLineBreak - +' (''b'',''000''),(''b'',001),(''b'',011);'+sLineBreak - +' '+sLineBreak - +'SELECT category, BIT_AND(x), BIT_OR(x), BIT_XOR(x) '+sLineBreak - +' FROM vals GROUP BY category;'+sLineBreak - +' '+sLineBreak - +'+----------+------------+-----------+------------+'+sLineBreak - +'| category | BIT_AND(x) | BIT_OR(x) | BIT_XOR(x) |'+sLineBreak - +'+----------+------------+-----------+------------+'+sLineBreak - +'| a | 100 | 111 | 101 |'+sLineBreak - +'| b | 0 | 11 | 10 |'+sLineBreak - +'+----------+------------+-----------+------------+' - ), - - ( - Name: 'COUNT'; - Declaration: '(expr)'; - Category: 'Functions and Modifiers for Use with GROUP BY'; - Version: SQL_VERSION_ANSI; - Description: 'Returns a count of the number of non-NULL values of expr in'+sLineBreak - +'the rows retrieved by a SELECT statement. The result is a'+sLineBreak - +'BIGINT value. It is an aggregate function, and so can be'+sLineBreak - +'used with the GROUP BY clause.'+sLineBreak - +' '+sLineBreak - +'COUNT(*) counts the total number of rows in a table.'+sLineBreak - +' '+sLineBreak - +'COUNT() returns 0 if there were no matching rows.'+sLineBreak - +' '+sLineBreak - +'From MariaDB 10.2.0, COUNT() can be used as a window'+sLineBreak - +'function.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'CREATE TABLE student (name CHAR(10), test CHAR(10), score'+sLineBreak - +'TINYINT); '+sLineBreak - +' '+sLineBreak - +'INSERT INTO student VALUES '+sLineBreak - +' (''Chun'', ''SQL'', 75), (''Chun'', ''Tuning'', 73), '+sLineBreak - +' (''Esben'', ''SQL'', 43), (''Esben'', ''Tuning'', 31), '+sLineBreak - +' (''Kaolin'', ''SQL'', 56), (''Kaolin'', ''Tuning'', 88), '+sLineBreak - +' (''Tatiana'', ''SQL'', 87), (''Tatiana'', ''Tuning'', 83);'+sLineBreak - +' '+sLineBreak - +'SELECT COUNT(*) FROM student;'+sLineBreak - +' '+sLineBreak - +'+----------+'+sLineBreak - +'| COUNT(*) |'+sLineBreak - +'+----------+'+sLineBreak - +'| 8 |'+sLineBreak - +'+----------+'+sLineBreak - +' '+sLineBreak - +'COUNT(DISTINCT) example:'+sLineBreak - +' '+sLineBreak - +'SELECT COUNT(DISTINCT (name)) FROM student;'+sLineBreak - +' '+sLineBreak - +'+------------------------+'+sLineBreak - +'| COUNT(DISTINCT (name)) |'+sLineBreak - +'+------------------------+'+sLineBreak - +'| 4 |'+sLineBreak - +'+------------------------+'+sLineBreak - +' '+sLineBreak - +'As a window function'+sLineBreak - +' '+sLineBreak - +'CREATE OR REPLACE TABLE student_test (name CHAR(10), test'+sLineBreak - +'CHAR(10), score TINYINT);'+sLineBreak - +' '+sLineBreak - +'INSERT INTO student_test VALUES '+sLineBreak - +' (''Chun'', ''SQL'', 75), (''Chun'', ''Tuning'', 73), '+sLineBreak - +' (''Esben'', ''SQL'', 43), (''Esben'', ''Tuning'', 31), '+sLineBreak - +' (''Kaolin'', ''SQL'', 56), (''Kaolin'', ''Tuning'', 88), '+sLineBreak - +' (''Tatiana'', ''SQL'', 87);'+sLineBreak - +' '+sLineBreak - +'SELECT name, test, score, COUNT(score) OVER (PARTITION BY'+sLineBreak - +'name) '+sLineBreak - +' AS tests_written FROM student_test;'+sLineBreak - +' '+sLineBreak - +'+---------+--------+-------+---------------+'+sLineBreak - +'| name | test | score | tests_written |'+sLineBreak - +'+---------+--------+-------+---------------+'+sLineBreak - +'| Chun | SQL | 75 | 2 |'+sLineBreak - +'| Chun | Tuning | 73 | 2 |'+sLineBreak - +'| Esben | SQL | 43 | 2 |'+sLineBreak - +'| Esben | Tuning | 31 | 2 |'+sLineBreak - +'| Kaolin | SQL | 56 | 2 |'+sLineBreak - +'| Kaolin | Tuning | 88 | 2 |'+sLineBreak - +'| Tatiana | SQL | 87 | 1 |'+sLineBreak - +'+---------+--------+-------+---------------+' - ), - - ( - Name: 'GROUP_CONCAT'; - Declaration: '(expr)'; - Category: 'Functions and Modifiers for Use with GROUP BY'; - Version: SQL_VERSION_ANSI; - Description: 'This function returns a string result with the concatenated'+sLineBreak - +'non-NULL'+sLineBreak - +'values from a group. It returns NULL if there are no'+sLineBreak - +'non-NULL values.'+sLineBreak - +' '+sLineBreak - +'The maximum returned length in bytes is determined by the'+sLineBreak - +'group_concat_max_len server system variable, which defaults'+sLineBreak - +'to 1M (>= MariaDB 10.2.4) or 1K (' - ), - - ( - Name: 'MAX'; - Declaration: '([DISTINCT] expr)'; - Category: 'Functions and Modifiers for Use with GROUP BY'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the largest, or maximum, value of expr. MAX() can'+sLineBreak - +'also take a string'+sLineBreak - +'argument in which case it returns the maximum string value.'+sLineBreak - +'The DISTINCT'+sLineBreak - +'keyword can be used to find the maximum of the distinct'+sLineBreak - +'values of expr,'+sLineBreak - +'however, this produces the same result as omitting DISTINCT.'+sLineBreak - +' '+sLineBreak - +'Note that SET and ENUM fields are currently compared by'+sLineBreak - +'their string value rather than their relative position in'+sLineBreak - +'the set, so MAX() may produce a different highest result'+sLineBreak - +'than ORDER BY DESC.'+sLineBreak - +' '+sLineBreak - +'It is an aggregate function, and so can be used with the'+sLineBreak - +'GROUP BY clause.'+sLineBreak - +' '+sLineBreak - +'From MariaDB 10.2.2, MAX() can be used as a window function.'+sLineBreak - +' '+sLineBreak - +'MAX() returns NULL if there were no matching rows.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'CREATE TABLE student (name CHAR(10), test CHAR(10), score'+sLineBreak - +'TINYINT); '+sLineBreak - +' '+sLineBreak - +'INSERT INTO student VALUES '+sLineBreak - +' (''Chun'', ''SQL'', 75), (''Chun'', ''Tuning'', 73), '+sLineBreak - +' (''Esben'', ''SQL'', 43), (''Esben'', ''Tuning'', 31), '+sLineBreak - +' (''Kaolin'', ''SQL'', 56), (''Kaolin'', ''Tuning'', 88), '+sLineBreak - +' (''Tatiana'', ''SQL'', 87), (''Tatiana'', ''Tuning'', 83);'+sLineBreak - +' '+sLineBreak - +'SELECT name, MAX(score) FROM student GROUP BY name;'+sLineBreak - +' '+sLineBreak - +'+---------+------------+'+sLineBreak - +'| name | MAX(score) |'+sLineBreak - +'+---------+------------+'+sLineBreak - +'| Chun | 75 |'+sLineBreak - +'| Esben | 43 |'+sLineBreak - +'| Kaolin | 88 |'+sLineBreak - +'| Tatiana | 87 |'+sLineBreak - +'+---------+------------+'+sLineBreak - +' '+sLineBreak - +'MAX string:'+sLineBreak - +' '+sLineBreak - +'SELECT MAX(name) FROM student;'+sLineBreak - +' '+sLineBreak - +'+-----------+'+sLineBreak - +'| MAX(name) |'+sLineBreak - +'+-----------+'+sLineBreak - +'| Tatiana |'+sLineBreak - +'+-----------+'+sLineBreak - +' '+sLineBreak - +'Be careful to avoid this common mistake, not grouping'+sLineBreak - +'correctly and returning mismatched data: '+sLineBreak - +' '+sLineBreak - +'SELECT name,test,MAX(SCORE) FROM student;'+sLineBreak - +' '+sLineBreak - +'+------+------+------------+'+sLineBreak - +'| name | test | MAX(SCORE) |'+sLineBreak - +'+------+------+------------+'+sLineBreak - +'| Chun | SQL | 88 |'+sLineBreak - +'+------+------+------------+'+sLineBreak - +' '+sLineBreak - +'Difference between ORDER BY DESC and MAX():'+sLineBreak - +' '+sLineBreak - +'CREATE TABLE student2(name CHAR(10),grade'+sLineBreak - +'ENUM(''b'',''c'',''a''));'+sLineBreak - +' '+sLineBreak - +'INSERT INTO student2'+sLineBreak - +'VALUES(''Chun'',''b''),(''Esben'',''c''),(''Kaolin'',''a'');'+sLineBreak - +' '+sLineBreak - +'SELECT MAX(grade) FROM student2;'+sLineBreak - +' '+sLineBreak - +'+------------+'+sLineBreak - +'| MAX(grade) |'+sLineBreak - +'+------------+'+sLineBreak - +'| c |'+sLineBreak - +'+------------+'+sLineBreak - +' '+sLineBreak - +'SELECT grade FROM student2 ORDER BY grade DESC LIMIT 1;'+sLineBreak - +' '+sLineBreak - +'+-------+'+sLineBreak - +'| grade |'+sLineBreak - +'+-------+'+sLineBreak - +'| a |'+sLineBreak - +'+-------+'+sLineBreak - +' '+sLineBreak - +'As a window function:'+sLineBreak - +' '+sLineBreak - +'CREATE OR REPLACE TABLE student_test (name CHAR(10), test'+sLineBreak - +'CHAR(10), score TINYINT);'+sLineBreak - +'INSERT INTO student_test VALUES '+sLineBreak - +' (''Chun'', ''SQL'', 75), (''Chun'', ''Tuning'', 73), '+sLineBreak - +' (''Esben'', ''SQL'', 43), (''Esben'', ''Tuning'', 31), '+sLineBreak - +' (''Kaolin'', ''SQL'', 56), (''Kaolin'', ''Tuning'', 88), '+sLineBreak - +' (''Tatiana'', ''SQL'', 87);'+sLineBreak - +' '+sLineBreak - +'SELECT name, test, score, MAX(score) '+sLineBreak - +' OVER (PARTITION BY name) AS highest_score FROM'+sLineBreak - +'student_test;'+sLineBreak - +' '+sLineBreak - +'+---------+--------+-------+---------------+'+sLineBreak - +'| name | test | score | highest_score |'+sLineBreak - +'+---------+--------+-------+---------------+'+sLineBreak - +'| Chun | SQL | 75 | 75 |'+sLineBreak - +'| Chun | Tuning | 73 | 75 |'+sLineBreak - +'| Esben | SQL | 43 | 43 |'+sLineBreak - +'| Esben | Tuning | 31 | 43 |'+sLineBreak - +'| Kaolin | SQL | 56 | 88 |'+sLineBreak - +'| Kaolin | Tuning | 88 | 88 |'+sLineBreak - +'| Tatiana | SQL | 87 | 87 |'+sLineBreak - +'+---------+--------+-------+---------------+' - ), - - ( - Name: 'MIN'; - Declaration: '([DISTINCT] expr)'; - Category: 'Functions and Modifiers for Use with GROUP BY'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the minimum value of expr. MIN() may take a string'+sLineBreak - +'argument, in which case it returns the minimum string value.'+sLineBreak - +'The DISTINCT'+sLineBreak - +'keyword can be used to find the minimum of the distinct'+sLineBreak - +'values of expr,'+sLineBreak - +'however, this produces the same result as omitting DISTINCT.'+sLineBreak - +' '+sLineBreak - +'Note that SET and ENUM fields are currently compared by'+sLineBreak - +'their string value rather than their relative position in'+sLineBreak - +'the set, so MIN() may produce a different lowest result than'+sLineBreak - +'ORDER BY ASC.'+sLineBreak - +' '+sLineBreak - +'It is an aggregate function, and so can be used with the'+sLineBreak - +'GROUP BY clause.'+sLineBreak - +' '+sLineBreak - +'From MariaDB 10.2.2, MIN() can be used as a window function.'+sLineBreak - +' '+sLineBreak - +'MIN() returns NULL if there were no matching rows.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'CREATE TABLE student (name CHAR(10), test CHAR(10), score'+sLineBreak - +'TINYINT); '+sLineBreak - +' '+sLineBreak - +'INSERT INTO student VALUES '+sLineBreak - +' (''Chun'', ''SQL'', 75), (''Chun'', ''Tuning'', 73), '+sLineBreak - +' (''Esben'', ''SQL'', 43), (''Esben'', ''Tuning'', 31), '+sLineBreak - +' (''Kaolin'', ''SQL'', 56), (''Kaolin'', ''Tuning'', 88), '+sLineBreak - +' (''Tatiana'', ''SQL'', 87), (''Tatiana'', ''Tuning'', 83);'+sLineBreak - +' '+sLineBreak - +'SELECT name, MIN(score) FROM student GROUP BY name;'+sLineBreak - +' '+sLineBreak - +'+---------+------------+'+sLineBreak - +'| name | MIN(score) |'+sLineBreak - +'+---------+------------+'+sLineBreak - +'| Chun | 73 |'+sLineBreak - +'| Esben | 31 |'+sLineBreak - +'| Kaolin | 56 |'+sLineBreak - +'| Tatiana | 83 |'+sLineBreak - +'+---------+------------+'+sLineBreak - +' '+sLineBreak - +'MIN() with a string:'+sLineBreak - +' '+sLineBreak - +'SELECT MIN(name) FROM student;'+sLineBreak - +' '+sLineBreak - +'+-----------+'+sLineBreak - +'| MIN(name) |'+sLineBreak - +'+-----------+'+sLineBreak - +'| Chun |'+sLineBreak - +'+-----------+'+sLineBreak - +' '+sLineBreak - +'Be careful to avoid this common mistake, not grouping'+sLineBreak - +'correctly and returning mismatched data: '+sLineBreak - +' '+sLineBreak - +'SELECT name,test,MIN(score) FROM student;'+sLineBreak - +' '+sLineBreak - +'+------+------+------------+'+sLineBreak - +'| name | test | MIN(score) |'+sLineBreak - +'+------+------+------------+'+sLineBreak - +'| Chun | SQL | 31 |'+sLineBreak - +'+------+------+------------+'+sLineBreak - +' '+sLineBreak - +'Difference between ORDER BY ASC and MIN():'+sLineBreak - +' '+sLineBreak - +'CREATE TABLE student2(name CHAR(10),grade'+sLineBreak - +'ENUM(''b'',''c'',''a''));'+sLineBreak - +' '+sLineBreak - +'INSERT INTO student2'+sLineBreak - +'VALUES(''Chun'',''b''),(''Esben'',''c''),(''Kaolin'',''a'');'+sLineBreak - +' '+sLineBreak - +'SELECT MIN(grade) FROM student2;'+sLineBreak - +' '+sLineBreak - +'+------------+'+sLineBreak - +'| MIN(grade) |'+sLineBreak - +'+------------+'+sLineBreak - +'| a |'+sLineBreak - +'+------------+'+sLineBreak - +' '+sLineBreak - +'SELECT grade FROM student2 ORDER BY grade ASC LIMIT 1;'+sLineBreak - +' '+sLineBreak - +'+-------+'+sLineBreak - +'| grade |'+sLineBreak - +'+-------+'+sLineBreak - +'| b |'+sLineBreak - +'+-------+'+sLineBreak - +' '+sLineBreak - +'As a window function:'+sLineBreak - +' '+sLineBreak - +'CREATE OR REPLACE TABLE student_test (name CHAR(10), test'+sLineBreak - +'CHAR(10), score TINYINT);'+sLineBreak - +'INSERT INTO student_test VALUES '+sLineBreak - +' (''Chun'', ''SQL'', 75), (''Chun'', ''Tuning'', 73), '+sLineBreak - +' (''Esben'', ''SQL'', 43), (''Esben'', ''Tuning'', 31), '+sLineBreak - +' (''Kaolin'', ''SQL'', 56), (''Kaolin'', ''Tuning'', 88), '+sLineBreak - +' (''Tatiana'', ''SQL'', 87);'+sLineBreak - +' '+sLineBreak - +'SELECT name, test, score, MIN(score) '+sLineBreak - +' OVER (PARTITION BY name) AS lowest_score FROM student_test;'+sLineBreak - +' '+sLineBreak - +'+---------+--------+-------+--------------+'+sLineBreak - +'| name | test | score | lowest_score |'+sLineBreak - +'+---------+--------+-------+--------------+'+sLineBreak - +'| Chun | SQL | 75 | 73 |'+sLineBreak - +'| Chun | Tuning | 73 | 73 |'+sLineBreak - +'| Esben | SQL | 43 | 31 |'+sLineBreak - +'| Esben | Tuning | 31 | 31 |'+sLineBreak - +'| Kaolin | SQL | 56 | 56 |'+sLineBreak - +'| Kaolin | Tuning | 88 | 56 |'+sLineBreak - +'| Tatiana | SQL | 87 | 87 |'+sLineBreak - +'+---------+--------+-------+--------------+' - ), - - ( - Name: 'STD'; - Declaration: '(expr)'; - Category: 'Functions and Modifiers for Use with GROUP BY'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the population standard deviation of expr. This is'+sLineBreak - +'an extension'+sLineBreak - +'to standard SQL. The standard SQL function STDDEV_POP() can'+sLineBreak - +'be used instead. '+sLineBreak - +' '+sLineBreak - +'It is an aggregate function, and so can be used with the'+sLineBreak - +'GROUP BY clause.'+sLineBreak - +' '+sLineBreak - +'From MariaDB 10.2.2, STD() can be used as a window function.'+sLineBreak - +' '+sLineBreak - +'This function returns NULL if there were no matching rows.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'As an aggregate function:'+sLineBreak - +' '+sLineBreak - +'CREATE OR REPLACE TABLE stats (category VARCHAR(2), x INT);'+sLineBreak - +' '+sLineBreak - +'INSERT INTO stats VALUES '+sLineBreak - +' (''a'',1),(''a'',2),(''a'',3),'+sLineBreak - +' (''b'',11),(''b'',12),(''b'',20),(''b'',30),(''b'',60);'+sLineBreak - +' '+sLineBreak - +'SELECT category, STDDEV_POP(x), STDDEV_SAMP(x), VAR_POP(x) '+sLineBreak - +' FROM stats GROUP BY category;'+sLineBreak - +' '+sLineBreak - +'+----------+---------------+----------------+------------+'+sLineBreak - +'| category | STDDEV_POP(x) | STDDEV_SAMP(x) | VAR_POP(x) |'+sLineBreak - +'+----------+---------------+----------------+------------+'+sLineBreak - +'| a | 0.8165 | 1.0000 | 0.6667 |'+sLineBreak - +'| b | 18.0400 | 20.1693 | 325.4400 |'+sLineBreak - +'+----------+---------------+----------------+------------+'+sLineBreak - +' '+sLineBreak - +'As a window function:'+sLineBreak - +' '+sLineBreak - +'CREATE OR REPLACE TABLE student_test (name CHAR(10), test'+sLineBreak - +'CHAR(10), score TINYINT);'+sLineBreak - +' '+sLineBreak - +'INSERT INTO student_test VALUES '+sLineBreak - +' (''Chun'', ''SQL'', 75), (''Chun'', ''Tuning'', 73), '+sLineBreak - +' (''Esben'', ''SQL'', 43), (''Esben'', ''Tuning'', 31), '+sLineBreak - +' (''Kaolin'', ''SQL'', 56), (''Kaolin'', ''Tuning'', 88), '+sLineBreak - +' (''Tatiana'', ''SQL'', 87);'+sLineBreak - +' '+sLineBreak - +'SELECT name, test, score, STDDEV_POP(score) '+sLineBreak - +' OVER (PARTITION BY test) AS stddev_results FROM'+sLineBreak - +'student_test;'+sLineBreak - +' '+sLineBreak - +'+---------+--------+-------+----------------+'+sLineBreak - +'| name | test | score | stddev_results |'+sLineBreak - +'+---------+--------+-------+----------------+'+sLineBreak - +'| Chun | SQL | 75 | 16.9466 |'+sLineBreak - +'| Chun | Tuning | 73 | 24.1247 |'+sLineBreak - +'| Esben | SQL | 43 | 16.9466 |'+sLineBreak - +'| Esben | Tuning | 31 | 24.1247 |'+sLineBreak - +'| Kaolin | SQL | 56 | 16.9466 |'+sLineBreak - +'| Kaolin | Tuning | 88 | 24.1247 |'+sLineBreak - +'| Tatiana | SQL | 87 | 16.9466 |'+sLineBreak - +'+---------+--------+-------+----------------+' - ), - - ( - Name: 'STDDEV'; - Declaration: '(expr)'; - Category: 'Functions and Modifiers for Use with GROUP BY'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the population standard deviation of expr. This'+sLineBreak - +'function is'+sLineBreak - +'provided for compatibility with Oracle. The standard SQL'+sLineBreak - +'function'+sLineBreak - +'STDDEV_POP() can be used instead.'+sLineBreak - +' '+sLineBreak - +'It is an aggregate function, and so can be used with the'+sLineBreak - +'GROUP BY clause.'+sLineBreak - +' '+sLineBreak - +'From MariaDB 10.2.2, STDDEV() can be used as a window'+sLineBreak - +'function.'+sLineBreak - +' '+sLineBreak - +'This function returns NULL if there were no matching rows.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'As an aggregate function:'+sLineBreak - +' '+sLineBreak - +'CREATE OR REPLACE TABLE stats (category VARCHAR(2), x INT);'+sLineBreak - +' '+sLineBreak - +'INSERT INTO stats VALUES '+sLineBreak - +' (''a'',1),(''a'',2),(''a'',3),'+sLineBreak - +' (''b'',11),(''b'',12),(''b'',20),(''b'',30),(''b'',60);'+sLineBreak - +' '+sLineBreak - +'SELECT category, STDDEV_POP(x), STDDEV_SAMP(x), VAR_POP(x) '+sLineBreak - +' FROM stats GROUP BY category;'+sLineBreak - +' '+sLineBreak - +'+----------+---------------+----------------+------------+'+sLineBreak - +'| category | STDDEV_POP(x) | STDDEV_SAMP(x) | VAR_POP(x) |'+sLineBreak - +'+----------+---------------+----------------+------------+'+sLineBreak - +'| a | 0.8165 | 1.0000 | 0.6667 |'+sLineBreak - +'| b | 18.0400 | 20.1693 | 325.4400 |'+sLineBreak - +'+----------+---------------+----------------+------------+'+sLineBreak - +' '+sLineBreak - +'As a window function:'+sLineBreak - +' '+sLineBreak - +'CREATE OR REPLACE TABLE student_test (name CHAR(10), test'+sLineBreak - +'CHAR(10), score TINYINT);'+sLineBreak - +' '+sLineBreak - +'INSERT INTO student_test VALUES '+sLineBreak - +' (''Chun'', ''SQL'', 75), (''Chun'', ''Tuning'', 73), '+sLineBreak - +' (''Esben'', ''SQL'', 43), (''Esben'', ''Tuning'', 31), '+sLineBreak - +' (''Kaolin'', ''SQL'', 56), (''Kaolin'', ''Tuning'', 88), '+sLineBreak - +' (''Tatiana'', ''SQL'', 87);'+sLineBreak - +' '+sLineBreak - +'SELECT name, test, score, STDDEV_POP(score) '+sLineBreak - +' OVER (PARTITION BY test) AS stddev_results FROM'+sLineBreak - +'student_test;'+sLineBreak - +' '+sLineBreak - +'+---------+--------+-------+----------------+'+sLineBreak - +'| name | test | score | stddev_results |'+sLineBreak - +'+---------+--------+-------+----------------+'+sLineBreak - +'| Chun | SQL | 75 | 16.9466 |'+sLineBreak - +'| Chun | Tuning | 73 | 24.1247 |'+sLineBreak - +'| Esben | SQL | 43 | 16.9466 |'+sLineBreak - +'| Esben | Tuning | 31 | 24.1247 |'+sLineBreak - +'| Kaolin | SQL | 56 | 16.9466 |'+sLineBreak - +'| Kaolin | Tuning | 88 | 24.1247 |'+sLineBreak - +'| Tatiana | SQL | 87 | 16.9466 |'+sLineBreak - +'+---------+--------+-------+----------------+' - ), - - ( - Name: 'STDDEV_POP'; - Declaration: '(expr)'; - Category: 'Functions and Modifiers for Use with GROUP BY'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the population standard deviation of expr (the'+sLineBreak - +'square root of'+sLineBreak - +'VAR_POP()). You can also use STD() or'+sLineBreak - +'STDDEV(), which are equivalent but not standard SQL.'+sLineBreak - +' '+sLineBreak - +'It is an aggregate function, and so can be used with the'+sLineBreak - +'GROUP BY clause.'+sLineBreak - +' '+sLineBreak - +'From MariaDB 10.2.2, STDDEV_POP() can be used as a window'+sLineBreak - +'function.'+sLineBreak - +' '+sLineBreak - +'STDDEV_POP() returns NULL if there were no matching rows.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'As an aggregate function:'+sLineBreak - +' '+sLineBreak - +'CREATE OR REPLACE TABLE stats (category VARCHAR(2), x INT);'+sLineBreak - +' '+sLineBreak - +'INSERT INTO stats VALUES '+sLineBreak - +' (''a'',1),(''a'',2),(''a'',3),'+sLineBreak - +' (''b'',11),(''b'',12),(''b'',20),(''b'',30),(''b'',60);'+sLineBreak - +' '+sLineBreak - +'SELECT category, STDDEV_POP(x), STDDEV_SAMP(x), VAR_POP(x) '+sLineBreak - +' FROM stats GROUP BY category;'+sLineBreak - +' '+sLineBreak - +'+----------+---------------+----------------+------------+'+sLineBreak - +'| category | STDDEV_POP(x) | STDDEV_SAMP(x) | VAR_POP(x) |'+sLineBreak - +'+----------+---------------+----------------+------------+'+sLineBreak - +'| a | 0.8165 | 1.0000 | 0.6667 |'+sLineBreak - +'| b | 18.0400 | 20.1693 | 325.4400 |'+sLineBreak - +'+----------+---------------+----------------+------------+'+sLineBreak - +' '+sLineBreak - +'As a window function:'+sLineBreak - +' '+sLineBreak - +'CREATE OR REPLACE TABLE student_test (name CHAR(10), test'+sLineBreak - +'CHAR(10), score TINYINT);'+sLineBreak - +' '+sLineBreak - +'INSERT INTO student_test VALUES '+sLineBreak - +' (''Chun'', ''SQL'', 75), (''Chun'', ''Tuning'', 73), '+sLineBreak - +' (''Esben'', ''SQL'', 43), (''Esben'', ''Tuning'', 31), '+sLineBreak - +' (''Kaolin'', ''SQL'', 56), (''Kaolin'', ''Tuning'', 88), '+sLineBreak - +' (''Tatiana'', ''SQL'', 87);'+sLineBreak - +' '+sLineBreak - +'SELECT name, test, score, STDDEV_POP(score) '+sLineBreak - +' OVER (PARTITION BY test) AS stddev_results FROM'+sLineBreak - +'student_test;'+sLineBreak - +' '+sLineBreak - +'+---------+--------+-------+----------------+'+sLineBreak - +'| name | test | score | stddev_results |'+sLineBreak - +'+---------+--------+-------+----------------+'+sLineBreak - +'| Chun | SQL | 75 | 16.9466 |'+sLineBreak - +'| Chun | Tuning | 73 | 24.1247 |'+sLineBreak - +'| Esben | SQL | 43 | 16.9466 |'+sLineBreak - +'| Esben | Tuning | 31 | 24.1247 |'+sLineBreak - +'| Kaolin | SQL | 56 | 16.9466 |'+sLineBreak - +'| Kaolin | Tuning | 88 | 24.1247 |'+sLineBreak - +'| Tatiana | SQL | 87 | 16.9466 |'+sLineBreak - +'+---------+--------+-------+----------------+' - ), - - ( - Name: 'STDDEV_SAMP'; - Declaration: '(expr)'; - Category: 'Functions and Modifiers for Use with GROUP BY'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the sample standard deviation of expr (the square'+sLineBreak - +'root of VAR_SAMP()).'+sLineBreak - +' '+sLineBreak - +'It is an aggregate function, and so can be used with the'+sLineBreak - +'GROUP BY clause.'+sLineBreak - +' '+sLineBreak - +'From MariaDB 10.2.2, STDDEV_SAMP() can be used as a window'+sLineBreak - +'function.'+sLineBreak - +' '+sLineBreak - +'STDDEV_SAMP() returns NULL if there were no matching rows.' - ), - - ( - Name: 'SUM'; - Declaration: '([DISTINCT] expr)'; - Category: 'Functions and Modifiers for Use with GROUP BY'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the sum of expr. If the return set has no rows,'+sLineBreak - +'SUM() returns'+sLineBreak - +'NULL. The DISTINCT keyword can be used to sum only the'+sLineBreak - +'distinct values'+sLineBreak - +'of expr.'+sLineBreak - +' '+sLineBreak - +'From MariaDB 10.2.0, SUM() can be used as a window function,'+sLineBreak - +'although not with the DISTINCT specifier.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'CREATE TABLE sales (sales_value INT);'+sLineBreak - +'INSERT INTO sales VALUES(10),(20),(20),(40);'+sLineBreak - +' '+sLineBreak - +'SELECT SUM(sales_value) FROM sales;'+sLineBreak - +' '+sLineBreak - +'+------------------+'+sLineBreak - +'| SUM(sales_value) |'+sLineBreak - +'+------------------+'+sLineBreak - +'| 90 |'+sLineBreak - +'+------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT SUM(DISTINCT(sales_value)) FROM sales;'+sLineBreak - +' '+sLineBreak - +'+----------------------------+'+sLineBreak - +'| SUM(DISTINCT(sales_value)) |'+sLineBreak - +'+----------------------------+'+sLineBreak - +'| 70 |'+sLineBreak - +'+----------------------------+'+sLineBreak - +' '+sLineBreak - +'Commonly, SUM is used with a GROUP BY clause:'+sLineBreak - +' '+sLineBreak - +'CREATE TABLE sales (name CHAR(10), month CHAR(10), units'+sLineBreak - +'INT);'+sLineBreak - +' '+sLineBreak - +'INSERT INTO sales VALUES '+sLineBreak - +' (''Chun'', ''Jan'', 75), (''Chun'', ''Feb'', 73),'+sLineBreak - +' (''Esben'', ''Jan'', 43), (''Esben'', ''Feb'', 31),'+sLineBreak - +' (''Kaolin'', ''Jan'', 56), (''Kaolin'', ''Feb'', 88),'+sLineBreak - +' (''Tatiana'', ''Jan'', 87), (''Tatiana'', ''Feb'', 83);'+sLineBreak - +' '+sLineBreak - +'SELECT name, SUM(units) FROM sales GROUP BY name;'+sLineBreak - +' '+sLineBreak - +'+---------+------------+'+sLineBreak - +'| name | SUM(units) |'+sLineBreak - +'+---------+------------+'+sLineBreak - +'| Chun | 148 |'+sLineBreak - +'| Esben | 74 |'+sLineBreak - +'| Kaolin | 144 |'+sLineBreak - +'| Tatiana | 170 |'+sLineBreak - +'+---------+------------+'+sLineBreak - +' '+sLineBreak - +'The GROUP BY clause is required when using an aggregate'+sLineBreak - +'function along with regular column data, otherwise the'+sLineBreak - +'result will be a mismatch, as in the following common type'+sLineBreak - +'of mistake:'+sLineBreak - +' '+sLineBreak - +'SELECT name,SUM(units) FROM sales'+sLineBreak - +';'+sLineBreak - +'+------+------------+'+sLineBreak - +'| name | SUM(units) |'+sLineBreak - +'+------+------------+'+sLineBreak - +'| Chun | 536 |'+sLineBreak - +'+------+------------+'+sLineBreak - +' '+sLineBreak - +'As a window function:'+sLineBreak - +' '+sLineBreak - +'CREATE OR REPLACE TABLE student_test (name CHAR(10), test'+sLineBreak - +'CHAR(10), score TINYINT);'+sLineBreak - +'INSERT INTO student_test VALUES '+sLineBreak - +' (''Chun'', ''SQL'', 75), (''Chun'', ''Tuning'', 73), '+sLineBreak - +' (''Esben'', ''SQL'', 43), (''Esben'', ''Tuning'', 31), '+sLineBreak - +' (''Kaolin'', ''SQL'', 56), (''Kaolin'', ''Tuning'', 88), '+sLineBreak - +' (''Tatiana'', ''SQL'', 87);'+sLineBreak - +' '+sLineBreak - +'SELECT name, test, score, SUM(score) OVER (PARTITION BY'+sLineBreak - +'name) AS total_score FROM student_test;'+sLineBreak - +' '+sLineBreak - +'+---------+--------+-------+-------------+'+sLineBreak - +'| name | test | score | total_score |'+sLineBreak - +'+---------+--------+-------+-------------+'+sLineBreak - +'| Chun | SQL | 75 | 148 |'+sLineBreak - +'| Chun | Tuning | 73 | 148 |'+sLineBreak - +'| Esben | SQL | 43 | 74 |'+sLineBreak - +'| Esben | Tuning | 31 | 74 |'+sLineBreak - +'| Kaolin | SQL | 56 | 144 |'+sLineBreak - +'| Kaolin | Tuning | 88 | 144 |'+sLineBreak - +'| Tatiana | SQL | 87 | 87 |'+sLineBreak - +'+---------+--------+-------+-------------+' - ), - - ( - Name: 'VARIANCE'; - Declaration: '(expr)'; - Category: 'Functions and Modifiers for Use with GROUP BY'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the population standard variance of expr. This is an'+sLineBreak - +'extension to'+sLineBreak - +'standard SQL. The standard SQL function VAR_POP() can be'+sLineBreak - +'used'+sLineBreak - +'instead.'+sLineBreak - +' '+sLineBreak - +'Variance is calculated by'+sLineBreak - +'working out the mean for the set'+sLineBreak - +'for each number, subtracting the mean and squaring the'+sLineBreak - +'result'+sLineBreak - +'calculate the average of the resulting differences'+sLineBreak - +' '+sLineBreak - +'It is an aggregate function, and so can be used with the'+sLineBreak - +'GROUP BY clause.'+sLineBreak - +' '+sLineBreak - +'From MariaDB 10.2.2, VARIANCE() can be used as a window'+sLineBreak - +'function.'+sLineBreak - +' '+sLineBreak - +'VARIANCE() returns NULL if there were no matching rows.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'CREATE TABLE v(i tinyint);'+sLineBreak - +' '+sLineBreak - +'INSERT INTO v VALUES(101),(99);'+sLineBreak - +' '+sLineBreak - +'SELECT VARIANCE(i) FROM v;'+sLineBreak - +' '+sLineBreak - +'+-------------+'+sLineBreak - +'| VARIANCE(i) |'+sLineBreak - +'+-------------+'+sLineBreak - +'| 1.0000 |'+sLineBreak - +'+-------------+'+sLineBreak - +' '+sLineBreak - +'INSERT INTO v VALUES(120),(80);'+sLineBreak - +' '+sLineBreak - +'SELECT VARIANCE(i) FROM v;'+sLineBreak - +' '+sLineBreak - +'+-------------+'+sLineBreak - +'| VARIANCE(i) |'+sLineBreak - +'+-------------+'+sLineBreak - +'| 200.5000 |'+sLineBreak - +'+-------------+'+sLineBreak - +' '+sLineBreak - +'As an aggregate function:'+sLineBreak - +' '+sLineBreak - +'CREATE OR REPLACE TABLE stats (category VARCHAR(2), x INT);'+sLineBreak - +' '+sLineBreak - +'INSERT INTO stats VALUES '+sLineBreak - +' (''a'',1),(''a'',2),(''a'',3),'+sLineBreak - +' (''b'',11),(''b'',12),(''b'',20),(''b'',30),(''b'',60);'+sLineBreak - +' '+sLineBreak - +'SELECT category, STDDEV_POP(x), STDDEV_SAMP(x), VAR_POP(x) '+sLineBreak - +' FROM stats GROUP BY category;'+sLineBreak - +' '+sLineBreak - +'+----------+---------------+----------------+------------+'+sLineBreak - +'| category | STDDEV_POP(x) | STDDEV_SAMP(x) | VAR_POP(x) |'+sLineBreak - +'+----------+---------------+----------------+------------+'+sLineBreak - +'| a | 0.8165 | 1.0000 | 0.6667 |'+sLineBreak - +'| b | 18.0400 | 20.1693 | 325.4400 |'+sLineBreak - +'+----------+---------------+----------------+------------+'+sLineBreak - +' '+sLineBreak - +'As a window function:'+sLineBreak - +' '+sLineBreak - +'CREATE OR REPLACE TABLE student_test (name CHAR(10), test'+sLineBreak - +'CHAR(10), score TINYINT);'+sLineBreak - +' '+sLineBreak - +'INSERT INTO student_test VALUES '+sLineBreak - +' (''Chun'', ''SQL'', 75), (''Chun'', ''Tuning'', 73), '+sLineBreak - +' (''Esben'', ''SQL'', 43), (''Esben'', ''Tuning'', 31), '+sLineBreak - +' (''Kaolin'', ''SQL'', 56), (''Kaolin'', ''Tuning'', 88), '+sLineBreak - +' (''Tatiana'', ''SQL'', 87);'+sLineBreak - +' '+sLineBreak - +'SELECT name, test, score, VAR_POP(score) '+sLineBreak - +' OVER (PARTITION BY test) AS variance_results FROM'+sLineBreak - +'student_test;'+sLineBreak - +' '+sLineBreak - +'+---------+--------+-------+------------------+'+sLineBreak - +'| name | test | score | variance_results |'+sLineBreak - +'+---------+--------+-------+------------------+'+sLineBreak - +'| Chun | SQL | 75 | 287.1875 |'+sLineBreak - +'| Chun | Tuning | 73 | 582.0000 |'+sLineBreak - +'| Esben | SQL | 43 | 287.1875 |'+sLineBreak - +'| Esben | Tuning | 31 | 582.0000 |'+sLineBreak - +'| Kaolin | SQL | 56 | 287.1875 |'+sLineBreak - +'| Kaolin | Tuning | 88 | 582.0000 |'+sLineBreak - +'| Tatiana | SQL | 87 | 287.1875 |'+sLineBreak - +'+---------+--------+-------+------------------+' - ), - - ( - Name: 'VAR_POP'; - Declaration: '(expr)'; - Category: 'Functions and Modifiers for Use with GROUP BY'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the population standard variance of expr. It'+sLineBreak - +'considers rows as'+sLineBreak - +'the whole population, not as a sample, so it has the number'+sLineBreak - +'of rows as'+sLineBreak - +'the denominator. You can also use VARIANCE(), which is'+sLineBreak - +'equivalent but'+sLineBreak - +'is not standard SQL.'+sLineBreak - +' '+sLineBreak - +'Variance is calculated by'+sLineBreak - +'working out the mean for the set'+sLineBreak - +'for each number, subtracting the mean and squaring the'+sLineBreak - +'result'+sLineBreak - +'calculate the average of the resulting differences'+sLineBreak - +' '+sLineBreak - +'It is an aggregate function, and so can be used with the'+sLineBreak - +'GROUP BY clause.'+sLineBreak - +' '+sLineBreak - +'From MariaDB 10.2.2, VAR_POP() can be used as a window'+sLineBreak - +'function.'+sLineBreak - +' '+sLineBreak - +'VAR_POP() returns NULL if there were no matching rows.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'CREATE TABLE v(i tinyint);'+sLineBreak - +' '+sLineBreak - +'INSERT INTO v VALUES(101),(99);'+sLineBreak - +' '+sLineBreak - +'SELECT VAR_POP(i) FROM v;'+sLineBreak - +' '+sLineBreak - +'+------------+'+sLineBreak - +'| VAR_POP(i) |'+sLineBreak - +'+------------+'+sLineBreak - +'| 1.0000 |'+sLineBreak - +'+------------+'+sLineBreak - +' '+sLineBreak - +'INSERT INTO v VALUES(120),(80);'+sLineBreak - +' '+sLineBreak - +'SELECT VAR_POP(i) FROM v;'+sLineBreak - +' '+sLineBreak - +'+------------+'+sLineBreak - +'| VAR_POP(i) |'+sLineBreak - +'+------------+'+sLineBreak - +'| 200.5000 |'+sLineBreak - +'+------------+'+sLineBreak - +' '+sLineBreak - +'As an aggregate function:'+sLineBreak - +' '+sLineBreak - +'CREATE OR REPLACE TABLE stats (category VARCHAR(2), x INT);'+sLineBreak - +' '+sLineBreak - +'INSERT INTO stats VALUES '+sLineBreak - +' (''a'',1),(''a'',2),(''a'',3),'+sLineBreak - +' (''b'',11),(''b'',12),(''b'',20),(''b'',30),(''b'',60);'+sLineBreak - +' '+sLineBreak - +'SELECT category, STDDEV_POP(x), STDDEV_SAMP(x), VAR_POP(x) '+sLineBreak - +' FROM stats GROUP BY category;'+sLineBreak - +' '+sLineBreak - +'+----------+---------------+----------------+------------+'+sLineBreak - +'| category | STDDEV_POP(x) | STDDEV_SAMP(x) | VAR_POP(x) |'+sLineBreak - +'+----------+---------------+----------------+------------+'+sLineBreak - +'| a | 0.8165 | 1.0000 | 0.6667 |'+sLineBreak - +'| b | 18.0400 | 20.1693 | 325.4400 |'+sLineBreak - +'+----------+---------------+----------------+------------+'+sLineBreak - +' '+sLineBreak - +'As a window function:'+sLineBreak - +' '+sLineBreak - +'CREATE OR REPLACE TABLE student_test (name CHAR(10), test'+sLineBreak - +'CHAR(10), score TINYINT);'+sLineBreak - +' '+sLineBreak - +'INSERT INTO student_test VALUES '+sLineBreak - +' (''Chun'', ''SQL'', 75), (''Chun'', ''Tuning'', 73), '+sLineBreak - +' (''Esben'', ''SQL'', 43), (''Esben'', ''Tuning'', 31), '+sLineBreak - +' (''Kaolin'', ''SQL'', 56), (''Kaolin'', ''Tuning'', 88), '+sLineBreak - +' (''Tatiana'', ''SQL'', 87);'+sLineBreak - +' '+sLineBreak - +'SELECT name, test, score, VAR_POP(score) '+sLineBreak - +' OVER (PARTITION BY test) AS variance_results FROM'+sLineBreak - +'student_test;'+sLineBreak - +' '+sLineBreak - +'+---------+--------+-------+------------------+'+sLineBreak - +'| name | test | score | variance_results |'+sLineBreak - +'+---------+--------+-------+------------------+'+sLineBreak - +'| Chun | SQL | 75 | 287.1875 |'+sLineBreak - +'| Chun | Tuning | 73 | 582.0000 |'+sLineBreak - +'| Esben | SQL | 43 | 287.1875 |'+sLineBreak - +'| Esben | Tuning | 31 | 582.0000 |'+sLineBreak - +'| Kaolin | SQL | 56 | 287.1875 |'+sLineBreak - +'| Kaolin | Tuning | 88 | 582.0000 |'+sLineBreak - +'| Tatiana | SQL | 87 | 287.1875 |'+sLineBreak - +'+---------+--------+-------+------------------+' - ), - - ( - Name: 'VAR_SAMP'; - Declaration: '(expr)'; - Category: 'Functions and Modifiers for Use with GROUP BY'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the sample variance of expr. That is, the'+sLineBreak - +'denominator is the number of rows minus one.'+sLineBreak - +' '+sLineBreak - +'It is an aggregate function, and so can be used with the'+sLineBreak - +'GROUP BY clause.'+sLineBreak - +' '+sLineBreak - +'From MariaDB 10.2.2, VAR_SAMP() can be used as a window'+sLineBreak - +'function.'+sLineBreak - +' '+sLineBreak - +'VAR_SAMP() returns NULL if there were no matching rows.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'As an aggregate function:'+sLineBreak - +' '+sLineBreak - +'CREATE OR REPLACE TABLE stats (category VARCHAR(2), x INT);'+sLineBreak - +' '+sLineBreak - +'INSERT INTO stats VALUES '+sLineBreak - +' (''a'',1),(''a'',2),(''a'',3),'+sLineBreak - +' (''b'',11),(''b'',12),(''b'',20),(''b'',30),(''b'',60);'+sLineBreak - +' '+sLineBreak - +'SELECT category, STDDEV_POP(x), STDDEV_SAMP(x), VAR_POP(x) '+sLineBreak - +' FROM stats GROUP BY category;'+sLineBreak - +' '+sLineBreak - +'+----------+---------------+----------------+------------+'+sLineBreak - +'| category | STDDEV_POP(x) | STDDEV_SAMP(x) | VAR_POP(x) |'+sLineBreak - +'+----------+---------------+----------------+------------+'+sLineBreak - +'| a | 0.8165 | 1.0000 | 0.6667 |'+sLineBreak - +'| b | 18.0400 | 20.1693 | 325.4400 |'+sLineBreak - +'+----------+---------------+----------------+------------+'+sLineBreak - +' '+sLineBreak - +'As a window function:'+sLineBreak - +' '+sLineBreak - +'CREATE OR REPLACE TABLE student_test (name CHAR(10), test'+sLineBreak - +'CHAR(10), score TINYINT);'+sLineBreak - +' '+sLineBreak - +'INSERT INTO student_test VALUES '+sLineBreak - +' (''Chun'', ''SQL'', 75), (''Chun'', ''Tuning'', 73), '+sLineBreak - +' (''Esben'', ''SQL'', 43), (''Esben'', ''Tuning'', 31), '+sLineBreak - +' (''Kaolin'', ''SQL'', 56), (''Kaolin'', ''Tuning'', 88), '+sLineBreak - +' (''Tatiana'', ''SQL'', 87);'+sLineBreak - +' '+sLineBreak - +'SELECT name, test, score, VAR_SAMP(score) '+sLineBreak - +' OVER (PARTITION BY test) AS variance_results FROM'+sLineBreak - +'student_test;'+sLineBreak - +' '+sLineBreak - +'+---------+--------+-------+------------------+'+sLineBreak - +'| name | test | score | variance_results |'+sLineBreak - +'+---------+--------+-------+------------------+'+sLineBreak - +'| Chun | SQL | 75 | 382.9167 |'+sLineBreak - +'| Chun | Tuning | 73 | 873.0000 |'+sLineBreak - +'| Esben | SQL | 43 | 382.9167 |'+sLineBreak - +'| Esben | Tuning | 31 | 873.0000 |'+sLineBreak - +'| Kaolin | SQL | 56 | 382.9167 |'+sLineBreak - +'| Kaolin | Tuning | 88 | 873.0000 |'+sLineBreak - +'| Tatiana | SQL | 87 | 382.9167 |'+sLineBreak - +'+---------+--------+-------+------------------+' - ), - - ( - Name: 'GEOMETRYCOLLECTION'; - Declaration: '(g1,g2,...)'; - Category: 'Geometry Constructors'; - Version: SQL_VERSION_ANSI; - Description: 'Constructs a WKB GeometryCollection. If any argument is not'+sLineBreak - +'a well-formed WKB representation of a geometry, the return'+sLineBreak - +'value is NULL.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'CREATE TABLE gis_geometrycollection (g GEOMETRYCOLLECTION);'+sLineBreak - +'SHOW FIELDS FROM gis_geometrycollection;'+sLineBreak - +' '+sLineBreak - +'INSERT INTO gis_geometrycollection VALUES'+sLineBreak - +' (GeomCollFromText(''GEOMETRYCOLLECTION(POINT(0 0),'+sLineBreak - +'LINESTRING(0 0,10 10))'')),'+sLineBreak - +' (GeometryFromWKB(AsWKB(GeometryCollection(Point(44, 6),'+sLineBreak - +'LineString(Point(3, 6), Point(7, 9)))))),'+sLineBreak - +' (GeomFromText(''GeometryCollection()'')),'+sLineBreak - +' (GeomFromText(''GeometryCollection EMPTY''));' - ), - - ( - Name: 'LINESTRING'; - Declaration: '(pt1,pt2,...)'; - Category: 'Geometry Constructors'; - Version: SQL_VERSION_ANSI; - Description: 'Constructs a WKB LineString value from a number of WKB Point'+sLineBreak - +'arguments. If any argument is not a WKB Point, the return'+sLineBreak - +'value is'+sLineBreak - +'NULL. If the number of Point arguments is less than two, the'+sLineBreak - +'return value is NULL.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SET @ls = ''LineString(1 1,2 2,3 3)'';'+sLineBreak - +' '+sLineBreak - +'SELECT AsText(EndPoint(GeomFromText(@ls)));'+sLineBreak - +'+-------------------------------------+'+sLineBreak - +'| AsText(EndPoint(GeomFromText(@ls))) |'+sLineBreak - +'+-------------------------------------+'+sLineBreak - +'| POINT(3 3) |'+sLineBreak - +'+-------------------------------------+'+sLineBreak - +' '+sLineBreak - +'CREATE TABLE gis_line (g LINESTRING);'+sLineBreak - +'INSERT INTO gis_line VALUES'+sLineBreak - +' (LineFromText(''LINESTRING(0 0,0 10,10 0)'')),'+sLineBreak - +' (LineStringFromText(''LINESTRING(10 10,20 10,20 20,10 20,10'+sLineBreak - +'10)'')),'+sLineBreak - +' (LineStringFromWKB(AsWKB(LineString(Point(10, 10),'+sLineBreak - +'Point(40, 10)))));' - ), - - ( - Name: 'MULTILINESTRING'; - Declaration: '(ls1,ls2,...)'; - Category: 'Geometry Constructors'; - Version: SQL_VERSION_ANSI; - Description: 'Constructs a WKB MultiLineString value using WKB LineString'+sLineBreak - +'arguments. If any argument is not a WKB LineString, the'+sLineBreak - +'return value is'+sLineBreak - +'NULL.'+sLineBreak - +' '+sLineBreak - +'Example'+sLineBreak - +' '+sLineBreak - +'CREATE TABLE gis_multi_line (g MULTILINESTRING);'+sLineBreak - +'INSERT INTO gis_multi_line VALUES'+sLineBreak - +' (MultiLineStringFromText(''MULTILINESTRING((10 48,10 21,10'+sLineBreak - +'0),(16 0,16 23,16 48))'')),'+sLineBreak - +' (MLineFromText(''MULTILINESTRING((10 48,10 21,10 0))'')),'+sLineBreak - +' (MLineFromWKB(AsWKB(MultiLineString(LineString(Point(1, 2),'+sLineBreak - +'Point(3, 5)), LineString(Point(2, 5),Point(5, 8),Point(21,'+sLineBreak - +'7))))));' - ), - - ( - Name: 'MULTIPOINT'; - Declaration: '(pt1,pt2,...)'; - Category: 'Geometry Constructors'; - Version: SQL_VERSION_ANSI; - Description: 'Constructs a WKB MultiPoint value using WKB Point arguments.'+sLineBreak - +'If any argument is not a WKB Point, the return value is'+sLineBreak - +'NULL.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SET @g = ST_GEOMFROMTEXT(''MultiPoint( 1 1, 2 2, 5 3, 7 2, 9'+sLineBreak - +'3, 8 4, 6 6, 6 9, 4 9, 1 5 )'');'+sLineBreak - +' '+sLineBreak - +'CREATE TABLE gis_multi_point (g MULTIPOINT);'+sLineBreak - +'INSERT INTO gis_multi_point VALUES'+sLineBreak - +' (MultiPointFromText(''MULTIPOINT(0 0,10 10,10 20,20'+sLineBreak - +'20)'')),'+sLineBreak - +' (MPointFromText(''MULTIPOINT(1 1,11 11,11 21,21 21)'')),'+sLineBreak - +' (MPointFromWKB(AsWKB(MultiPoint(Point(3, 6), Point(4,'+sLineBreak - +'10)))));' - ), - - ( - Name: 'MULTIPOLYGON'; - Declaration: '(poly1,poly2,...)'; - Category: 'Geometry Constructors'; - Version: SQL_VERSION_ANSI; - Description: 'Constructs a WKB MultiPolygon value from a set of WKB'+sLineBreak - +'Polygon arguments. If any argument is not a WKB Polygon, the'+sLineBreak - +'return value is NULL.'+sLineBreak - +' '+sLineBreak - +'Example'+sLineBreak - +' '+sLineBreak - +'CREATE TABLE gis_multi_polygon (g MULTIPOLYGON);'+sLineBreak - +'INSERT INTO gis_multi_polygon VALUES'+sLineBreak - +' (MultiPolygonFromText(''MULTIPOLYGON(((28 26,28 0,84 0,84'+sLineBreak - +'42,28 26),(52 18,66 23,73 9,48 6,52 18)),((59 18,67 18,67'+sLineBreak - +'13,59 13,59 18)))'')),'+sLineBreak - +' (MPolyFromText(''MULTIPOLYGON(((28 26,28 0,84 0,84 42,28'+sLineBreak - +'26),(52 18,66 23,73 9,48 6,52 18)),((59 18,67 18,67 13,59'+sLineBreak - +'13,59 18)))'')),'+sLineBreak - +' (MPolyFromWKB(AsWKB(MultiPolygon(Polygon(LineString(Point(0,'+sLineBreak - +'3), Point(3, 3), Point(3, 0), Point(0, 3)))))));' - ), - - ( - Name: 'POINT'; - Declaration: '(x,y)'; - Category: 'Geometry Constructors'; - Version: SQL_VERSION_ANSI; - Description: 'Constructs a WKB Point using the given coordinates.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SET @g = ST_GEOMFROMTEXT(''Point(1 1)'');'+sLineBreak - +' '+sLineBreak - +'CREATE TABLE gis_point (g POINT);'+sLineBreak - +'INSERT INTO gis_point VALUES'+sLineBreak - +' (PointFromText(''POINT(10 10)'')),'+sLineBreak - +' (PointFromText(''POINT(20 10)'')),'+sLineBreak - +' (PointFromText(''POINT(20 20)'')),'+sLineBreak - +' (PointFromWKB(AsWKB(PointFromText(''POINT(10 20)''))));' - ), - - ( - Name: 'POLYGON'; - Declaration: '(ls1,ls2,...)'; - Category: 'Geometry Constructors'; - Version: SQL_VERSION_ANSI; - Description: 'Constructs a WKB Polygon value from a number of WKB'+sLineBreak - +'LineString'+sLineBreak - +'arguments. If any argument does not represent the WKB of a'+sLineBreak - +'LinearRing (that is,'+sLineBreak - +'not a closed and simple LineString) the return value is'+sLineBreak - +'NULL.'+sLineBreak - +' '+sLineBreak - +'Note that according to the OpenGIS standard, a POLYGON'+sLineBreak - +'should have exactly one ExteriorRing and all other rings'+sLineBreak - +'should lie within that ExteriorRing and thus be the'+sLineBreak - +'InteriorRings. Practically, however, some systems, including'+sLineBreak - +'MariaDB''s, permit polygons to have several'+sLineBreak - +'''ExteriorRings''. In the case of there being multiple,'+sLineBreak - +'non-overlapping exterior rings ST_NUMINTERIORRINGS() will'+sLineBreak - +'return 1.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SET @g = ST_GEOMFROMTEXT(''POLYGON((1 1,1 5,4 9,6 9,9 3,7'+sLineBreak - +'2,1 1))'');'+sLineBreak - +' '+sLineBreak - +'CREATE TABLE gis_polygon (g POLYGON);'+sLineBreak - +'INSERT INTO gis_polygon VALUES'+sLineBreak - +' (PolygonFromText(''POLYGON((10 10,20 10,20 20,10 20,10'+sLineBreak - +'10))'')),'+sLineBreak - +' (PolyFromText(''POLYGON((0 0,50 0,50 50,0 50,0 0), (10'+sLineBreak - +'10,20 10,20 20,10 20,10 10))'')),'+sLineBreak - +' (PolyFromWKB(AsWKB(Polygon(LineString(Point(0, 0),'+sLineBreak - +'Point(30, 0), Point(30, 30), Point(0, 0))))));'+sLineBreak - +' '+sLineBreak - +'Non-overlapping ''polygon'':'+sLineBreak - +' '+sLineBreak - +'SELECT ST_NumInteriorRings(ST_PolyFromText(''POLYGON((0 0,10'+sLineBreak - +'0,10 10,0 10,0 0),'+sLineBreak - +' (-1 -1,-5 -1,-5 -5,-1 -5,-1 -1))'')) AS NumInteriorRings;'+sLineBreak - +' '+sLineBreak - +'+------------------+'+sLineBreak - +'| NumInteriorRings |'+sLineBreak - +'+------------------+'+sLineBreak - +'| 1 |'+sLineBreak - +'+------------------+' - ), - - ( - Name: 'ST_BUFFER'; - Declaration: '(g1,r)'; - Category: 'Geometry Constructors'; - Version: SQL_VERSION_ANSI; - Description: 'Returns a geometry that represents all points whose distance'+sLineBreak - +'from geometry g1 is less than or equal to distance, or'+sLineBreak - +'radius, r.'+sLineBreak - +' '+sLineBreak - +'Uses for this function could include creating for example a'+sLineBreak - +'new geometry representing a buffer zone around an island.'+sLineBreak - +' '+sLineBreak - +'BUFFER() is a synonym.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'Determining whether a point is within a buffer zone:'+sLineBreak - +' '+sLineBreak - +'SET @g1 = ST_GEOMFROMTEXT(''POLYGON((10 10, 10 20, 20 20, 20'+sLineBreak - +'10, 10 10))'');'+sLineBreak - +' '+sLineBreak - +'SET @g2 = ST_GEOMFROMTEXT(''POINT(8 8)'');'+sLineBreak - +' '+sLineBreak - +'SELECT ST_WITHIN(@g2,ST_BUFFER(@g1,5));'+sLineBreak - +'+---------------------------------+'+sLineBreak - +'| ST_WITHIN(@g2,ST_BUFFER(@g1,5)) |'+sLineBreak - +'+---------------------------------+'+sLineBreak - +'| 1 |'+sLineBreak - +'+---------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT ST_WITHIN(@g2,ST_BUFFER(@g1,1));'+sLineBreak - +'+---------------------------------+'+sLineBreak - +'| ST_WITHIN(@g2,ST_BUFFER(@g1,1)) |'+sLineBreak - +'+---------------------------------+'+sLineBreak - +'| 0 |'+sLineBreak - +'+---------------------------------+' - ), - - ( - Name: 'ST_CONVEXHULL'; - Declaration: '(g)'; - Category: 'Geometry Constructors'; - Version: SQL_VERSION_ANSI; - Description: 'Given a geometry, returns a geometry that is the minimum'+sLineBreak - +'convex geometry enclosing all geometries within the set.'+sLineBreak - +'Returns NULL if the geometry value is NULL or an empty'+sLineBreak - +'value.'+sLineBreak - +' '+sLineBreak - +'ST_ConvexHull() and ConvexHull() are synonyms.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'The ConvexHull of a single point is simply the single point:'+sLineBreak - +' '+sLineBreak - +'SET @g = ST_GEOMFROMTEXT(''Point(0 0)'');'+sLineBreak - +' '+sLineBreak - +'SELECT ST_ASTEXT(ST_CONVEXHULL(@g));'+sLineBreak - +'+------------------------------+'+sLineBreak - +'| ST_ASTEXT(ST_CONVEXHULL(@g)) |'+sLineBreak - +'+------------------------------+'+sLineBreak - +'| POINT(0 0) |'+sLineBreak - +'+------------------------------+'+sLineBreak - +' '+sLineBreak - +'SET @g = ST_GEOMFROMTEXT(''MultiPoint(0 0, 1 2, 2 3)'');'+sLineBreak - +' '+sLineBreak - +'SELECT ST_ASTEXT(ST_CONVEXHULL(@g));'+sLineBreak - +'+------------------------------+'+sLineBreak - +'| ST_ASTEXT(ST_CONVEXHULL(@g)) |'+sLineBreak - +'+------------------------------+'+sLineBreak - +'| POLYGON((0 0,1 2,2 3,0 0)) |'+sLineBreak - +'+------------------------------+'+sLineBreak - +' '+sLineBreak - +'SET @g = ST_GEOMFROMTEXT(''MultiPoint( 1 1, 2 2, 5 3, 7 2, 9'+sLineBreak - +'3, 8 4, 6 6, 6 9, 4 9, 1 5 )'');'+sLineBreak - +' '+sLineBreak - +'SELECT ST_ASTEXT(ST_CONVEXHULL(@g));'+sLineBreak - +'+----------------------------------------+'+sLineBreak - +'| ST_ASTEXT(ST_CONVEXHULL(@g)) |'+sLineBreak - +'+----------------------------------------+'+sLineBreak - +'| POLYGON((1 1,1 5,4 9,6 9,9 3,7 2,1 1)) |'+sLineBreak - +'+----------------------------------------+' - ), - - ( - Name: 'ST_INTERSECTION'; - Declaration: '(g1,g2)'; - Category: 'Geometry Constructors'; - Version: SQL_VERSION_ANSI; - Description: 'Returns a geometry that is the intersection, or shared'+sLineBreak - +'portion, of geometry g1 and geometry g2.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SET @g1 = ST_GEOMFROMTEXT(''POINT(2 1)'');'+sLineBreak - +' '+sLineBreak - +'SET @g2 = ST_GEOMFROMTEXT(''LINESTRING(2 1, 0 2)'');'+sLineBreak - +' '+sLineBreak - +'SELECT ASTEXT(ST_INTERSECTION(@g1,@g2));'+sLineBreak - +'+----------------------------------+'+sLineBreak - +'| ASTEXT(ST_INTERSECTION(@g1,@g2)) |'+sLineBreak - +'+----------------------------------+'+sLineBreak - +'| POINT(2 1) |'+sLineBreak - +'+----------------------------------+' - ), - - ( - Name: 'ST_POINTONSURFACE'; - Declaration: '(g)'; - Category: 'Geometry Constructors'; - Version: SQL_VERSION_ANSI; - Description: 'Given a geometry, returns a POINT guaranteed to intersect a'+sLineBreak - +'surface. However, see MDEV-7514.'+sLineBreak - +' '+sLineBreak - +'ST_PointOnSurface() and PointOnSurface() are synonyms.' - ), - - ( - Name: 'ST_SYMDIFFERENCE'; - Declaration: '(g1,g2)'; - Category: 'Geometry Constructors'; - Version: SQL_VERSION_ANSI; - Description: 'Returns a geometry that represents the portions of geometry'+sLineBreak - +'g1 and geometry g2 that don''t intersect.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SET @g1 = ST_GEOMFROMTEXT(''LINESTRING(10 20, 10 40)'');'+sLineBreak - +' '+sLineBreak - +'SET @g2 = ST_GEOMFROMTEXT(''LINESTRING(10 15, 10 25)'');'+sLineBreak - +' '+sLineBreak - +'SELECT ASTEXT(ST_SYMDIFFERENCE(@g1,@g2));'+sLineBreak - +'+----------------------------------------------+'+sLineBreak - +'| ASTEXT(ST_SYMDIFFERENCE(@g1,@g2)) |'+sLineBreak - +'+----------------------------------------------+'+sLineBreak - +'| MULTILINESTRING((10 15,10 20),(10 25,10 40)) |'+sLineBreak - +'+----------------------------------------------+'+sLineBreak - +' '+sLineBreak - +'SET @g2 = ST_GeomFromText(''LINESTRING(10 20, 10 41)'');'+sLineBreak - +' '+sLineBreak - +'SELECT ASTEXT(ST_SYMDIFFERENCE(@g1,@g2));'+sLineBreak - +'+-----------------------------------+'+sLineBreak - +'| ASTEXT(ST_SYMDIFFERENCE(@g1,@g2)) |'+sLineBreak - +'+-----------------------------------+'+sLineBreak - +'| LINESTRING(10 40,10 41) |'+sLineBreak - +'+-----------------------------------+' - ), - - ( - Name: 'ST_UNION'; - Declaration: '(g1,g2)'; - Category: 'Geometry Constructors'; - Version: SQL_VERSION_ANSI; - Description: 'Returns a geometry that is the union of the geometry g1 and'+sLineBreak - +'geometry g2.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SET @g1 = GEOMFROMTEXT(''POINT (0 2)'');'+sLineBreak - +' '+sLineBreak - +'SET @g2 = GEOMFROMTEXT(''POINT (2 0)'');'+sLineBreak - +' '+sLineBreak - +'SELECT ASTEXT(ST_UNION(@g1,@g2));'+sLineBreak - +'+---------------------------+'+sLineBreak - +'| ASTEXT(ST_UNION(@g1,@g2)) |'+sLineBreak - +'+---------------------------+'+sLineBreak - +'| MULTIPOINT(2 0,0 2) |'+sLineBreak - +'+---------------------------+'+sLineBreak - +' '+sLineBreak - +'SET @g1 = GEOMFROMTEXT(''POLYGON((0 0,0 3,3 3,3 0,0 0))'');'+sLineBreak - +' '+sLineBreak - +'SET @g2 = GEOMFROMTEXT(''POLYGON((2 2,4 2,4 4,2 4,2 2))'');'+sLineBreak - +' '+sLineBreak - +'SELECT ASTEXT(ST_UNION(@g1,@g2));'+sLineBreak - +'+------------------------------------------------+'+sLineBreak - +'| ASTEXT(ST_UNION(@g1,@g2)) |'+sLineBreak - +'+------------------------------------------------+'+sLineBreak - +'| POLYGON((0 0,0 3,2 3,2 4,4 4,4 2,3 2,3 0,0 0)) |'+sLineBreak - +'+------------------------------------------------+' - ), - - ( - Name: 'ST_BOUNDARY'; - Declaration: '(g)'; - Category: 'Geometry Properties'; - Version: SQL_VERSION_ANSI; - Description: 'Returns a geometry that is the closure of the combinatorial'+sLineBreak - +'boundary of the geometry value g.'+sLineBreak - +' '+sLineBreak - +'BOUNDARY() is a synonym.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT ST_AsText(ST_Boundary(ST_GeomFromText(''LINESTRING(3'+sLineBreak - +'3,0 0, -3 3)'')));'+sLineBreak - +'+----------------------------------------------------------------------+'+sLineBreak - +'| ST_AsText(ST_Boundary(ST_GeomFromText(''LINESTRING(3 3,0'+sLineBreak - +'0, -3 3)''))) |'+sLineBreak - +'+----------------------------------------------------------------------+'+sLineBreak - +'| MULTIPOINT(3 3,-3 3) |'+sLineBreak - +'+----------------------------------------------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT ST_AsText(ST_Boundary(ST_GeomFromText(''POLYGON((3'+sLineBreak - +'3,0 0, -3 3, 3 3))'')));'+sLineBreak - +'+--------------------------------------------------------------------------+'+sLineBreak - +'| ST_AsText(ST_Boundary(ST_GeomFromText(''POLYGON((3 3,0 0,'+sLineBreak - +'-3 3, 3 3))''))) |'+sLineBreak - +'+--------------------------------------------------------------------------+'+sLineBreak - +'| LINESTRING(3 3,0 0,-3 3,3 3) |'+sLineBreak - +'+--------------------------------------------------------------------------+' - ), - - ( - Name: 'ST_DIMENSION'; - Declaration: '(g)'; - Category: 'Geometry Properties'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the inherent dimension of the geometry value g. The'+sLineBreak - +'result can'+sLineBreak - +'be'+sLineBreak - +' '+sLineBreak - +'Dimension | Definition | '+sLineBreak - +' '+sLineBreak - +' -1 | empty geometry | '+sLineBreak - +' '+sLineBreak - +' 0 | geometry with no length or area | '+sLineBreak - +' '+sLineBreak - +' 1 | geometry with no area but nonzero length | '+sLineBreak - +' '+sLineBreak - +' 2 | geometry with nonzero area | '+sLineBreak - +' '+sLineBreak - +'ST_Dimension() and Dimension() are synonyms.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT Dimension(GeomFromText(''LineString(1 1,2 2)''));'+sLineBreak - +'+------------------------------------------------+'+sLineBreak - +'| Dimension(GeomFromText(''LineString(1 1,2 2)'')) |'+sLineBreak - +'+------------------------------------------------+'+sLineBreak - +'| 1 |'+sLineBreak - +'+------------------------------------------------+' - ), - - ( - Name: 'ST_ENVELOPE'; - Declaration: '(g)'; - Category: 'Geometry Properties'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the Minimum Bounding Rectangle (MBR) for the'+sLineBreak - +'geometry value g. The result is returned as a Polygon value.'+sLineBreak - +' '+sLineBreak - +'The polygon is defined by the corner points of the bounding'+sLineBreak - +'box:'+sLineBreak - +' '+sLineBreak - +'POLYGON((MINX MINY, MAXX MINY, MAXX MAXY, MINX MAXY, MINX'+sLineBreak - +'MINY))'+sLineBreak - +' '+sLineBreak - +'ST_ENVELOPE() and ENVELOPE() are synonyms.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT AsText(ST_ENVELOPE(GeomFromText(''LineString(1 1,4'+sLineBreak - +'4)'')));'+sLineBreak - +'+----------------------------------------------------------+'+sLineBreak - +'| AsText(ST_ENVELOPE(GeomFromText(''LineString(1 1,4 4)'')))'+sLineBreak - +'|'+sLineBreak - +'+----------------------------------------------------------+'+sLineBreak - +'| POLYGON((1 1,4 1,4 4,1 4,1 1)) |'+sLineBreak - +'+----------------------------------------------------------+' - ), - - ( - Name: 'ST_GEOMETRYN'; - Declaration: '(gc,N)'; - Category: 'Geometry Properties'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the N-th geometry in the GeometryCollection gc.'+sLineBreak - +'Geometries are numbered beginning with 1.'+sLineBreak - +' '+sLineBreak - +'ST_GeometryN() and GeometryN() are synonyms.'+sLineBreak - +' '+sLineBreak - +'Example'+sLineBreak - +' '+sLineBreak - +'SET @gc = ''GeometryCollection(Point(1 1),LineString(12 14,'+sLineBreak - +'9 11))'';'+sLineBreak - +' '+sLineBreak - +'SELECT AsText(GeometryN(GeomFromText(@gc),1));'+sLineBreak - +'+----------------------------------------+'+sLineBreak - +'| AsText(GeometryN(GeomFromText(@gc),1)) |'+sLineBreak - +'+----------------------------------------+'+sLineBreak - +'| POINT(1 1) |'+sLineBreak - +'+----------------------------------------+' - ), - - ( - Name: 'ST_GEOMETRYTYPE'; - Declaration: '(g)'; - Category: 'Geometry Properties'; - Version: SQL_VERSION_ANSI; - Description: 'Returns as a string the name of the geometry type of which'+sLineBreak - +'the'+sLineBreak - +'geometry instance g is a member. The name corresponds to one'+sLineBreak - +'of the'+sLineBreak - +'instantiable Geometry subclasses.'+sLineBreak - +' '+sLineBreak - +'ST_GeometryType() and GeometryType() are synonyms.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT GeometryType(GeomFromText(''POINT(1 1)''));'+sLineBreak - +'+------------------------------------------+'+sLineBreak - +'| GeometryType(GeomFromText(''POINT(1 1)'')) |'+sLineBreak - +'+------------------------------------------+'+sLineBreak - +'| POINT |'+sLineBreak - +'+------------------------------------------+' - ), - - ( - Name: 'ST_ISCLOSED'; - Declaration: '(g)'; - Category: 'Geometry Properties'; - Version: SQL_VERSION_ANSI; - Description: 'Returns 1 if a given LINESTRING''s start and end points are'+sLineBreak - +'the same, or 0 if they are not the same. Before MariaDB'+sLineBreak - +'10.1.5, returns NULL if not given a LINESTRING. After'+sLineBreak - +'MariaDB 10.1.5, returns -1.'+sLineBreak - +' '+sLineBreak - +'ST_IsClosed() and IsClosed() are synonyms.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SET @ls = ''LineString(0 0, 0 4, 4 4, 0 0)'';'+sLineBreak - +' '+sLineBreak - +'SELECT ST_ISCLOSED(GEOMFROMTEXT(@ls));'+sLineBreak - +'+--------------------------------+'+sLineBreak - +'| ST_ISCLOSED(GEOMFROMTEXT(@ls)) |'+sLineBreak - +'+--------------------------------+'+sLineBreak - +'| 1 |'+sLineBreak - +'+--------------------------------+'+sLineBreak - +' '+sLineBreak - +'SET @ls = ''LineString(0 0, 0 4, 4 4, 0 1)'';'+sLineBreak - +' '+sLineBreak - +'SELECT ST_ISCLOSED(GEOMFROMTEXT(@ls));'+sLineBreak - +'+--------------------------------+'+sLineBreak - +'| ST_ISCLOSED(GEOMFROMTEXT(@ls)) |'+sLineBreak - +'+--------------------------------+'+sLineBreak - +'| 0 |'+sLineBreak - +'+--------------------------------+' - ), - - ( - Name: 'ST_ISEMPTY'; - Declaration: '(g)'; - Category: 'Geometry Properties'; - Version: SQL_VERSION_ANSI; - Description: 'IsEmpty is a function defined by the OpenGIS specification,'+sLineBreak - +'but is not fully implemented by MariaDB or MySQL. '+sLineBreak - +' '+sLineBreak - +'Since MariaDB and MySQL do not support GIS EMPTY values such'+sLineBreak - +'as POINT EMPTY, as implemented it simply returns 1 if the'+sLineBreak - +'geometry value g is invalid, 0 if it is valid, and NULL if'+sLineBreak - +'the argument is NULL.'+sLineBreak - +' '+sLineBreak - +'ST_IsEmpty() and IsEmpty() are synonyms.' - ), - - ( - Name: 'ST_IsRing'; - Declaration: '(g)'; - Category: 'Geometry Properties'; - Version: SQL_VERSION_ANSI; - Description: 'Returns true if a given LINESTRING is a ring, that is, both'+sLineBreak - +'ST_IsClosed and ST_IsSimple. A simple curve does not pass'+sLineBreak - +'through the same point more than once. However, see'+sLineBreak - +'MDEV-7510.'+sLineBreak - +' '+sLineBreak - +'St_IsRing() and IsRing() are synonyms.' - ), - - ( - Name: 'ST_IsSimple'; - Declaration: '(g)'; - Category: 'Geometry Properties'; - Version: SQL_VERSION_ANSI; - Description: 'Returns true if the given Geometry has no anomalous'+sLineBreak - +'geometric points, false if it does, or NULL if given a NULL'+sLineBreak - +'value.'+sLineBreak - +' '+sLineBreak - +'ST_IsSimple() and IsSimple() are synonyms.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'A POINT is always simple.'+sLineBreak - +' '+sLineBreak - +'SET @g = ''Point(1 2)'';'+sLineBreak - +' '+sLineBreak - +'SELECT ST_ISSIMPLE(GEOMFROMTEXT(@g));'+sLineBreak - +'+-------------------------------+'+sLineBreak - +'| ST_ISSIMPLE(GEOMFROMTEXT(@g)) |'+sLineBreak - +'+-------------------------------+'+sLineBreak - +'| 1 |'+sLineBreak - +'+-------------------------------+' - ), - - ( - Name: 'ST_NUMGEOMETRIES'; - Declaration: '(gc)'; - Category: 'Geometry Properties'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the number of geometries in the GeometryCollection'+sLineBreak - +'gc.'+sLineBreak - +' '+sLineBreak - +'ST_NumGeometries() and NumGeometries() are synonyms.'+sLineBreak - +' '+sLineBreak - +'Example'+sLineBreak - +' '+sLineBreak - +'SET @gc = ''GeometryCollection(Point(1 1),LineString(2 2, 3'+sLineBreak - +'3))'';'+sLineBreak - +' '+sLineBreak - +'SELECT NUMGEOMETRIES(GeomFromText(@gc));'+sLineBreak - +'+----------------------------------+'+sLineBreak - +'| NUMGEOMETRIES(GeomFromText(@gc)) |'+sLineBreak - +'+----------------------------------+'+sLineBreak - +'| 2 |'+sLineBreak - +'+----------------------------------+' - ), - - ( - Name: 'ST_RELATE'; - Declaration: '(g1, g2, i)'; - Category: 'Geometry Properties'; - Version: SQL_VERSION_ANSI; - Description: 'Returns true if Geometry g1 is spatially related to'+sLineBreak - +'Geometryg2 by testing for intersections between the'+sLineBreak - +'interior, boundary and exterior of the two geometries as'+sLineBreak - +'specified by the values in intersection matrix pattern i.' - ), - - ( - Name: 'ST_SRID'; - Declaration: '(g)'; - Category: 'Geometry Properties'; - Version: SQL_VERSION_ANSI; - Description: 'Returns an integer indicating the Spatial Reference System'+sLineBreak - +'ID for the'+sLineBreak - +'geometry value g.'+sLineBreak - +' '+sLineBreak - +'In MariaDB, the SRID value is just an integer associated'+sLineBreak - +'with the'+sLineBreak - +'geometry value. All calculations are done assuming Euclidean'+sLineBreak - +'(planar)'+sLineBreak - +'geometry.'+sLineBreak - +' '+sLineBreak - +'ST_SRID() and SRID() are synonyms.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT SRID(GeomFromText(''LineString(1 1,2 2)'',101));'+sLineBreak - +'+-----------------------------------------------+'+sLineBreak - +'| SRID(GeomFromText(''LineString(1 1,2 2)'',101)) |'+sLineBreak - +'+-----------------------------------------------+'+sLineBreak - +'| 101 |'+sLineBreak - +'+-----------------------------------------------+' - ), - - ( - Name: 'CONTAINS'; - Declaration: '(g1,g2)'; - Category: 'Geometry Relations'; - Version: SQL_VERSION_ANSI; - Description: 'Returns 1 or 0 to indicate whether a geometry g1 completely'+sLineBreak - +'contains geometry g2. CONTAINS() is based on the original'+sLineBreak - +'MySQL implementation and uses object bounding rectangles,'+sLineBreak - +'while ST_CONTAINS() uses object shapes. '+sLineBreak - +' '+sLineBreak - +'This tests the opposite relationship to Within().' - ), - - ( - Name: 'CROSSES'; - Declaration: '(g1,g2)'; - Category: 'Geometry Relations'; - Version: SQL_VERSION_ANSI; - Description: 'Returns 1 if g1 spatially crosses g2. Returns NULL if g1 is'+sLineBreak - +'a Polygon or a MultiPolygon, or if g2 is a'+sLineBreak - +'Point or a MultiPoint. Otherwise, returns 0.'+sLineBreak - +' '+sLineBreak - +'The term spatially crosses denotes a spatial relation'+sLineBreak - +'between two'+sLineBreak - +'given geometries that has the following properties:'+sLineBreak - +'The two geometries intersect'+sLineBreak - +'Their intersection results in a geometry that has a'+sLineBreak - +'dimension that is one'+sLineBreak - +' less than the maximum dimension of the two given geometries'+sLineBreak - +'Their intersection is not equal to either of the two given'+sLineBreak - +'geometries'+sLineBreak - +' '+sLineBreak - +'CROSSES() is based on the original MySQL implementation, and'+sLineBreak - +'uses object bounding rectangles, while ST_CROSSES() uses'+sLineBreak - +'object shapes.' - ), - - ( - Name: 'DISJOINT'; - Declaration: '(g1,g2)'; - Category: 'Geometry Relations'; - Version: SQL_VERSION_ANSI; - Description: 'Returns 1 or 0 to indicate whether g1 is spatially disjoint'+sLineBreak - +'from'+sLineBreak - +'(does not intersect) g2.'+sLineBreak - +' '+sLineBreak - +'DISJOINT() tests the opposite relationship to INTERSECTS().'+sLineBreak - +' '+sLineBreak - +'DISJOINT() is based on the original MySQL implementation and'+sLineBreak - +'uses object bounding rectangles, while ST_DISJOINT() uses'+sLineBreak - +'object shapes.' - ), - - ( - Name: 'EQUALS'; - Declaration: '(g1,g2)'; - Category: 'Geometry Relations'; - Version: SQL_VERSION_ANSI; - Description: 'Returns 1 or 0 to indicate whether g1 is spatially equal to'+sLineBreak - +'g2.'+sLineBreak - +' '+sLineBreak - +'EQUALS() is based on the original MySQL implementation and'+sLineBreak - +'uses object bounding rectangles, while ST_EQUALS() uses'+sLineBreak - +'object shapes.'+sLineBreak - +' '+sLineBreak - +'From MariaDB 10.2.3, MBREQUALS is a synonym for Equals.' - ), - - ( - Name: 'INTERSECTS'; - Declaration: '(g1,g2)'; - Category: 'Geometry Relations'; - Version: SQL_VERSION_ANSI; - Description: 'Returns 1 or 0 to indicate whether geometry g1 spatially'+sLineBreak - +'intersects geometry g2.'+sLineBreak - +' '+sLineBreak - +'INTERSECTS() is based on the original MySQL implementation'+sLineBreak - +'and uses object bounding rectangles, while ST_INTERSECTS()'+sLineBreak - +'uses object shapes.'+sLineBreak - +' '+sLineBreak - +'INTERSECTS() tests the opposite relationship to DISJOINT().' - ), - - ( - Name: 'OVERLAPS'; - Declaration: '(g1,g2)'; - Category: 'Geometry Relations'; - Version: SQL_VERSION_ANSI; - Description: 'Returns 1 or 0 to indicate whether g1 spatially overlaps g2.'+sLineBreak - +'The term spatially overlaps is used if two geometries'+sLineBreak - +'intersect and their'+sLineBreak - +'intersection results in a geometry of the same dimension but'+sLineBreak - +'not equal to'+sLineBreak - +'either of the given geometries.'+sLineBreak - +' '+sLineBreak - +'OVERLAPS() is based on the original MySQL implementation and'+sLineBreak - +'uses object bounding rectangles, while ST_OVERLAPS() uses'+sLineBreak - +'object shapes.' - ), - - ( - Name: 'ST_CONTAINS'; - Declaration: '(g1,g2)'; - Category: 'Geometry Relations'; - Version: SQL_VERSION_ANSI; - Description: 'Returns 1 or 0 to indicate whether a geometry g1 completely'+sLineBreak - +'contains geometry g2.'+sLineBreak - +' '+sLineBreak - +'ST_CONTAINS() uses object shapes, while CONTAINS(), based on'+sLineBreak - +'the original MySQL implementation, uses object bounding'+sLineBreak - +'rectangles.'+sLineBreak - +' '+sLineBreak - +'ST_CONTAINS tests the opposite relationship to ST_WITHIN().'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SET @g1 = ST_GEOMFROMTEXT(''POLYGON((175 150, 20 40, 50 60,'+sLineBreak - +'125 100, 175 150))'');'+sLineBreak - +' '+sLineBreak - +'SET @g2 = ST_GEOMFROMTEXT(''POINT(174 149)'');'+sLineBreak - +' '+sLineBreak - +'SELECT ST_CONTAINS(@g1,@g2);'+sLineBreak - +'+----------------------+'+sLineBreak - +'| ST_CONTAINS(@g1,@g2) |'+sLineBreak - +'+----------------------+'+sLineBreak - +'| 1 |'+sLineBreak - +'+----------------------+'+sLineBreak - +' '+sLineBreak - +'SET @g2 = ST_GEOMFROMTEXT(''POINT(175 151)'');'+sLineBreak - +' '+sLineBreak - +'SELECT ST_CONTAINS(@g1,@g2);'+sLineBreak - +'+----------------------+'+sLineBreak - +'| ST_CONTAINS(@g1,@g2) |'+sLineBreak - +'+----------------------+'+sLineBreak - +'| 0 |'+sLineBreak - +'+----------------------+' - ), - - ( - Name: 'ST_CROSSES'; - Declaration: '(g1,g2)'; - Category: 'Geometry Relations'; - Version: SQL_VERSION_ANSI; - Description: 'Returns 1 if geometry g1 spatially crosses geometry g2.'+sLineBreak - +'Returns NULL if g1 is a Polygon or a MultiPolygon, or if g2'+sLineBreak - +'is a'+sLineBreak - +'Point or a MultiPoint. Otherwise, returns 0.'+sLineBreak - +' '+sLineBreak - +'The term spatially crosses denotes a spatial relation'+sLineBreak - +'between two'+sLineBreak - +'given geometries that has the following properties:'+sLineBreak - +'The two geometries intersect'+sLineBreak - +'Their intersection results in a geometry that has a'+sLineBreak - +'dimension that is one'+sLineBreak - +' less than the maximum dimension of the two given geometries'+sLineBreak - +'Their intersection is not equal to either of the two given'+sLineBreak - +'geometries'+sLineBreak - +' '+sLineBreak - +'ST_CROSSES() uses object shapes, while CROSSES(), based on'+sLineBreak - +'the original MySQL implementation, uses object bounding'+sLineBreak - +'rectangles.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SET @g1 = ST_GEOMFROMTEXT(''LINESTRING(174 149, 176 151)'');'+sLineBreak - +' '+sLineBreak - +'SET @g2 = ST_GEOMFROMTEXT(''POLYGON((175 150, 20 40, 50 60,'+sLineBreak - +'125 100, 175 150))'');'+sLineBreak - +' '+sLineBreak - +'SELECT ST_CROSSES(@g1,@g2);'+sLineBreak - +'+---------------------+'+sLineBreak - +'| ST_CROSSES(@g1,@g2) |'+sLineBreak - +'+---------------------+'+sLineBreak - +'| 1 |'+sLineBreak - +'+---------------------+'+sLineBreak - +' '+sLineBreak - +'SET @g1 = ST_GEOMFROMTEXT(''LINESTRING(176 149, 176 151)'');'+sLineBreak - +' '+sLineBreak - +'SELECT ST_CROSSES(@g1,@g2);'+sLineBreak - +'+---------------------+'+sLineBreak - +'| ST_CROSSES(@g1,@g2) |'+sLineBreak - +'+---------------------+'+sLineBreak - +'| 0 |'+sLineBreak - +'+---------------------+' - ), - - ( - Name: 'ST_DIFFERENCE'; - Declaration: '(g1,g2)'; - Category: 'Geometry Relations'; - Version: SQL_VERSION_ANSI; - Description: 'Returns a geometry representing the point set difference of'+sLineBreak - +'the given geometry values.'+sLineBreak - +' '+sLineBreak - +'Example'+sLineBreak - +' '+sLineBreak - +'SET @g1 = POINT(10,10), @g2 = POINT(20,20);'+sLineBreak - +' '+sLineBreak - +'SELECT ST_AsText(ST_Difference(@g1, @g2));'+sLineBreak - +'+------------------------------------+'+sLineBreak - +'| ST_AsText(ST_Difference(@g1, @g2)) |'+sLineBreak - +'+------------------------------------+'+sLineBreak - +'| POINT(10 10) |'+sLineBreak - +'+------------------------------------+' - ), - - ( - Name: 'ST_DISJOINT'; - Declaration: '(g1,g2)'; - Category: 'Geometry Relations'; - Version: SQL_VERSION_ANSI; - Description: 'Returns 1 or 0 to indicate whether geometry g1 is spatially'+sLineBreak - +'disjoint from'+sLineBreak - +'(does not intersect with) geometry g2.'+sLineBreak - +' '+sLineBreak - +'ST_DISJOINT() uses object shapes, while DISJOINT(), based on'+sLineBreak - +'the original MySQL implementation, uses object bounding'+sLineBreak - +'rectangles.'+sLineBreak - +' '+sLineBreak - +'ST_DISJOINT() tests the opposite relationship to'+sLineBreak - +'ST_INTERSECTS().'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SET @g1 = ST_GEOMFROMTEXT(''POINT(0 0)'');'+sLineBreak - +' '+sLineBreak - +'SET @g2 = ST_GEOMFROMTEXT(''LINESTRING(2 0, 0 2)'');'+sLineBreak - +' '+sLineBreak - +'SELECT ST_DISJOINT(@g1,@g2);'+sLineBreak - +'+----------------------+'+sLineBreak - +'| ST_DISJOINT(@g1,@g2) |'+sLineBreak - +'+----------------------+'+sLineBreak - +'| 1 |'+sLineBreak - +'+----------------------+'+sLineBreak - +' '+sLineBreak - +'SET @g2 = ST_GEOMFROMTEXT(''LINESTRING(0 0, 0 2)'');'+sLineBreak - +' '+sLineBreak - +'SELECT ST_DISJOINT(@g1,@g2);'+sLineBreak - +'+----------------------+'+sLineBreak - +'| ST_DISJOINT(@g1,@g2) |'+sLineBreak - +'+----------------------+'+sLineBreak - +'| 0 |'+sLineBreak - +'+----------------------+' - ), - - ( - Name: 'ST_DISTANCE'; - Declaration: '(g1,g2)'; - Category: 'Geometry Relations'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the distance between two geometries, or null if not'+sLineBreak - +'given valid inputs.'+sLineBreak - +' '+sLineBreak - +'Example'+sLineBreak - +' '+sLineBreak - +'SELECT ST_Distance(POINT(1,2),POINT(2,2));'+sLineBreak - +'+------------------------------------+'+sLineBreak - +'| ST_Distance(POINT(1,2),POINT(2,2)) |'+sLineBreak - +'+------------------------------------+'+sLineBreak - +'| 1 |'+sLineBreak - +'+------------------------------------+' - ), - - ( - Name: 'ST_EQUALS'; - Declaration: '(g1,g2)'; - Category: 'Geometry Relations'; - Version: SQL_VERSION_ANSI; - Description: 'Returns 1 or 0 to indicate whether geometry g1 is spatially'+sLineBreak - +'equal to geometry g2.'+sLineBreak - +' '+sLineBreak - +'ST_EQUALS() uses object shapes, while EQUALS(), based on the'+sLineBreak - +'original MySQL implementation, uses object bounding'+sLineBreak - +'rectangles.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SET @g1 = ST_GEOMFROMTEXT(''LINESTRING(174 149, 176 151)'');'+sLineBreak - +' '+sLineBreak - +'SET @g2 = ST_GEOMFROMTEXT(''LINESTRING(176 151, 174 149)'');'+sLineBreak - +' '+sLineBreak - +'SELECT ST_EQUALS(@g1,@g2);'+sLineBreak - +'+--------------------+'+sLineBreak - +'| ST_EQUALS(@g1,@g2) |'+sLineBreak - +'+--------------------+'+sLineBreak - +'| 1 |'+sLineBreak - +'+--------------------+'+sLineBreak - +' '+sLineBreak - +'SET @g1 = ST_GEOMFROMTEXT(''POINT(0 2)'');'+sLineBreak - +' '+sLineBreak - +'SET @g1 = ST_GEOMFROMTEXT(''POINT(2 0)'');'+sLineBreak - +' '+sLineBreak - +'SELECT ST_EQUALS(@g1,@g2);'+sLineBreak - +'+--------------------+'+sLineBreak - +'| ST_EQUALS(@g1,@g2) |'+sLineBreak - +'+--------------------+'+sLineBreak - +'| 0 |'+sLineBreak - +'+--------------------+' - ), - - ( - Name: 'ST_INTERSECTS'; - Declaration: '(g1,g2)'; - Category: 'Geometry Relations'; - Version: SQL_VERSION_ANSI; - Description: 'Returns 1 or 0 to indicate whether geometry g1 spatially'+sLineBreak - +'intersects geometry g2.'+sLineBreak - +' '+sLineBreak - +'ST_INTERSECTS() uses object shapes, while INTERSECTS(),'+sLineBreak - +'based on the original MySQL implementation, uses object'+sLineBreak - +'bounding rectangles.'+sLineBreak - +' '+sLineBreak - +'ST_INTERSECTS() tests the opposite relationship to'+sLineBreak - +'ST_DISJOINT().'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SET @g1 = ST_GEOMFROMTEXT(''POINT(0 0)'');'+sLineBreak - +' '+sLineBreak - +'SET @g2 = ST_GEOMFROMTEXT(''LINESTRING(0 0, 0 2)'');'+sLineBreak - +' '+sLineBreak - +'SELECT ST_INTERSECTS(@g1,@g2);'+sLineBreak - +'+------------------------+'+sLineBreak - +'| ST_INTERSECTS(@g1,@g2) |'+sLineBreak - +'+------------------------+'+sLineBreak - +'| 1 |'+sLineBreak - +'+------------------------+'+sLineBreak - +' '+sLineBreak - +'SET @g2 = ST_GEOMFROMTEXT(''LINESTRING(2 0, 0 2)'');'+sLineBreak - +' '+sLineBreak - +'SELECT ST_INTERSECTS(@g1,@g2);'+sLineBreak - +'+------------------------+'+sLineBreak - +'| ST_INTERSECTS(@g1,@g2) |'+sLineBreak - +'+------------------------+'+sLineBreak - +'| 0 |'+sLineBreak - +'+------------------------+' - ), - - ( - Name: 'ST_LENGTH'; - Declaration: '(ls)'; - Category: 'Geometry Relations'; - Version: SQL_VERSION_ANSI; - Description: 'Returns as a double-precision number the length of the'+sLineBreak - +'LineString value ls in its associated spatial reference.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SET @ls = ''LineString(1 1,2 2,3 3)'';'+sLineBreak - +' '+sLineBreak - +'SELECT ST_LENGTH(ST_GeomFromText(@ls));'+sLineBreak - +'+---------------------------------+'+sLineBreak - +'| ST_LENGTH(ST_GeomFromText(@ls)) |'+sLineBreak - +'+---------------------------------+'+sLineBreak - +'| 2.82842712474619 |'+sLineBreak - +'+---------------------------------+' - ), - - ( - Name: 'ST_OVERLAPS'; - Declaration: '(g1,g2)'; - Category: 'Geometry Relations'; - Version: SQL_VERSION_ANSI; - Description: 'Returns 1 or 0 to indicate whether geometry g1 spatially'+sLineBreak - +'overlaps geometry g2.'+sLineBreak - +' '+sLineBreak - +'The term spatially overlaps is used if two geometries'+sLineBreak - +'intersect and their'+sLineBreak - +'intersection results in a geometry of the same dimension but'+sLineBreak - +'not equal to'+sLineBreak - +'either of the given geometries.'+sLineBreak - +' '+sLineBreak - +'ST_OVERLAPS() uses object shapes, while OVERLAPS(), based on'+sLineBreak - +'the original MySQL implementation, uses object bounding'+sLineBreak - +'rectangles.' - ), - - ( - Name: 'ST_TOUCHES'; - Declaration: '(g1,g2)'; - Category: 'Geometry Relations'; - Version: SQL_VERSION_ANSI; - Description: 'Returns 1 or 0 to indicate whether geometry g1 spatially'+sLineBreak - +'touches geometry g2. Two geometries spatially touch if the'+sLineBreak - +'interiors of the geometries do not intersect,'+sLineBreak - +'but the boundary of one of the geometries intersects either'+sLineBreak - +'the boundary or the'+sLineBreak - +'interior of the other.'+sLineBreak - +' '+sLineBreak - +'ST_TOUCHES() uses object shapes, while TOUCHES(), based on'+sLineBreak - +'the original MySQL implementation, uses object bounding'+sLineBreak - +'rectangles.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SET @g1 = ST_GEOMFROMTEXT(''POINT(2 0)'');'+sLineBreak - +' '+sLineBreak - +'SET @g2 = ST_GEOMFROMTEXT(''LINESTRING(2 0, 0 2)'');'+sLineBreak - +' '+sLineBreak - +'SELECT ST_TOUCHES(@g1,@g2);'+sLineBreak - +'+---------------------+'+sLineBreak - +'| ST_TOUCHES(@g1,@g2) |'+sLineBreak - +'+---------------------+'+sLineBreak - +'| 1 |'+sLineBreak - +'+---------------------+'+sLineBreak - +' '+sLineBreak - +'SET @g1 = ST_GEOMFROMTEXT(''POINT(2 1)'');'+sLineBreak - +' '+sLineBreak - +'SELECT ST_TOUCHES(@g1,@g2);'+sLineBreak - +'+---------------------+'+sLineBreak - +'| ST_TOUCHES(@g1,@g2) |'+sLineBreak - +'+---------------------+'+sLineBreak - +'| 0 |'+sLineBreak - +'+---------------------+' - ), - - ( - Name: 'ST_WITHIN'; - Declaration: '(g1,g2)'; - Category: 'Geometry Relations'; - Version: SQL_VERSION_ANSI; - Description: 'Returns 1 or 0 to indicate whether geometry g1 is spatially'+sLineBreak - +'within geometry g2.'+sLineBreak - +' '+sLineBreak - +'This tests the opposite relationship as ST_CONTAINS().'+sLineBreak - +' '+sLineBreak - +'ST_WITHIN() uses object shapes, while WITHIN(), based on the'+sLineBreak - +'original MySQL implementation, uses object bounding'+sLineBreak - +'rectangles.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SET @g1 = ST_GEOMFROMTEXT(''POINT(174 149)'');'+sLineBreak - +' '+sLineBreak - +'SET @g2 = ST_GEOMFROMTEXT(''POLYGON((175 150, 20 40, 50 60,'+sLineBreak - +'125 100, 175 150))'');'+sLineBreak - +' '+sLineBreak - +'SELECT ST_WITHIN(@g1,@g2);'+sLineBreak - +'+--------------------+'+sLineBreak - +'| ST_WITHIN(@g1,@g2) |'+sLineBreak - +'+--------------------+'+sLineBreak - +'| 1 |'+sLineBreak - +'+--------------------+'+sLineBreak - +' '+sLineBreak - +'SET @g1 = ST_GEOMFROMTEXT(''POINT(176 151)'');'+sLineBreak - +' '+sLineBreak - +'SELECT ST_WITHIN(@g1,@g2);'+sLineBreak - +'+--------------------+'+sLineBreak - +'| ST_WITHIN(@g1,@g2) |'+sLineBreak - +'+--------------------+'+sLineBreak - +'| 0 |'+sLineBreak - +'+--------------------+' - ), - - ( - Name: 'TOUCHES'; - Declaration: '(g1,g2)'; - Category: 'Geometry Relations'; - Version: SQL_VERSION_ANSI; - Description: 'Returns 1 or 0 to indicate whether g1 spatially touches g2.'+sLineBreak - +'Two'+sLineBreak - +'geometries spatially touch if the interiors of the'+sLineBreak - +'geometries do not intersect,'+sLineBreak - +'but the boundary of one of the geometries intersects either'+sLineBreak - +'the boundary or the'+sLineBreak - +'interior of the other.'+sLineBreak - +' '+sLineBreak - +'TOUCHES() is based on the original MySQL implementation and'+sLineBreak - +'uses object bounding rectangles, while ST_TOUCHES() uses'+sLineBreak - +'object shapes.' - ), - - ( - Name: 'WITHIN'; - Declaration: '(g1,g2)'; - Category: 'Geometry Relations'; - Version: SQL_VERSION_ANSI; - Description: 'Returns 1 or 0 to indicate whether g1 is spatially within'+sLineBreak - +'g2.'+sLineBreak - +'This tests the opposite relationship as Contains().'+sLineBreak - +' '+sLineBreak - +'WITHIN() is based on the original MySQL implementation, and'+sLineBreak - +'uses object bounding rectangles, while ST_WITHIN() uses'+sLineBreak - +'object shapes.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SET @g1 = GEOMFROMTEXT(''POINT(174 149)'');'+sLineBreak - +'SET @g2 = GEOMFROMTEXT(''POINT(176 151)'');'+sLineBreak - +'SET @g3 = GEOMFROMTEXT(''POLYGON((175 150, 20 40, 50 60, 125'+sLineBreak - +'100, 175 150))'');'+sLineBreak - +' '+sLineBreak - +'SELECT within(@g1,@g3);'+sLineBreak - +'+-----------------+'+sLineBreak - +'| within(@g1,@g3) |'+sLineBreak - +'+-----------------+'+sLineBreak - +'| 1 |'+sLineBreak - +'+-----------------+'+sLineBreak - +' '+sLineBreak - +'SELECT within(@g2,@g3);'+sLineBreak - +'+-----------------+'+sLineBreak - +'| within(@g2,@g3) |'+sLineBreak - +'+-----------------+'+sLineBreak - +'| 0 |'+sLineBreak - +'+-----------------+' - ), - - ( - Name: 'BENCHMARK'; - Declaration: '(count,expr)'; - Category: 'Information Functions'; - Version: SQL_VERSION_ANSI; - Description: 'The BENCHMARK() function executes the expression expr'+sLineBreak - +'repeatedly count'+sLineBreak - +'times. It may be used to time how quickly MariaDB processes'+sLineBreak - +'the'+sLineBreak - +'expression. The result value is always 0. The intended use'+sLineBreak - +'is from'+sLineBreak - +'within the mysql client, which reports query execution'+sLineBreak - +'times.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT BENCHMARK(1000000,ENCODE(''hello'',''goodbye''));'+sLineBreak - +'+----------------------------------------------+'+sLineBreak - +'| BENCHMARK(1000000,ENCODE(''hello'',''goodbye'')) |'+sLineBreak - +'+----------------------------------------------+'+sLineBreak - +'| 0 |'+sLineBreak - +'+----------------------------------------------+'+sLineBreak - +'1 row in set (0.21 sec)' - ), - - ( - Name: 'BINLOG_GTID_POS'; - Declaration: '(binlog_filename,binlog_offset)'; - Category: 'Information Functions'; - Version: SQL_VERSION_ANSI; - Description: 'The BINLOG_GTID_POS() function takes as input an old-style'+sLineBreak - +'binary log position in the form of a file name and a file'+sLineBreak - +'offset. It looks up the position in the current binlog, and'+sLineBreak - +'returns a string representation of the corresponding GTID'+sLineBreak - +'position. If the position is not found in the current'+sLineBreak - +'binlog, NULL is returned.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT BINLOG_GTID_POS("master-bin.000001", 600);' - ), - - ( - Name: 'CHARSET'; - Declaration: '(str)'; - Category: 'Information Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the character set of the string argument. If str is'+sLineBreak - +'not a string, it is considered as a binary string (so the'+sLineBreak - +'function returns ''binary''). This applies to NULL, too. The'+sLineBreak - +'return value is a string in the utf8 character set.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT CHARSET(''abc'');'+sLineBreak - +'+----------------+'+sLineBreak - +'| CHARSET(''abc'') |'+sLineBreak - +'+----------------+'+sLineBreak - +'| latin1 |'+sLineBreak - +'+----------------+'+sLineBreak - +' '+sLineBreak - +'SELECT CHARSET(CONVERT(''abc'' USING utf8));'+sLineBreak - +'+------------------------------------+'+sLineBreak - +'| CHARSET(CONVERT(''abc'' USING utf8)) |'+sLineBreak - +'+------------------------------------+'+sLineBreak - +'| utf8 |'+sLineBreak - +'+------------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT CHARSET(USER());'+sLineBreak - +'+-----------------+'+sLineBreak - +'| CHARSET(USER()) |'+sLineBreak - +'+-----------------+'+sLineBreak - +'| utf8 |'+sLineBreak - +'+-----------------+' - ), - - ( - Name: 'COERCIBILITY'; - Declaration: '(str)'; - Category: 'Information Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the collation coercibility value of the string'+sLineBreak - +'argument. Coercibility defines what will be converted to'+sLineBreak - +'what in case of collation conflict, with an expression with'+sLineBreak - +'higher coercibility being converted to the collation of an'+sLineBreak - +'expression with lower coercibility.'+sLineBreak - +' '+sLineBreak - +'Coercibility | Description | Example | '+sLineBreak - +' '+sLineBreak - +'0 | Explicit | Value using a COLLATE clause | '+sLineBreak - +' '+sLineBreak - +'1 | No collation | Concatenated strings using different'+sLineBreak - +'collations | '+sLineBreak - +' '+sLineBreak - +'2 | Implicit | Column value | '+sLineBreak - +' '+sLineBreak - +'3 | Constant | USER() return value | '+sLineBreak - +' '+sLineBreak - +'4 | Coercible | Literal string | '+sLineBreak - +' '+sLineBreak - +'5 | Ignorable | NULL or derived from NULL | '+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT COERCIBILITY(''abc'' COLLATE latin1_swedish_ci);'+sLineBreak - +'+-----------------------------------------------+'+sLineBreak - +'| COERCIBILITY(''abc'' COLLATE latin1_swedish_ci) |'+sLineBreak - +'+-----------------------------------------------+'+sLineBreak - +'| 0 |'+sLineBreak - +'+-----------------------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT COERCIBILITY(USER());'+sLineBreak - +'+----------------------+'+sLineBreak - +'| COERCIBILITY(USER()) |'+sLineBreak - +'+----------------------+'+sLineBreak - +'| 3 |'+sLineBreak - +'+----------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT COERCIBILITY(''abc'');'+sLineBreak - +'+---------------------+'+sLineBreak - +'| COERCIBILITY(''abc'') |'+sLineBreak - +'+---------------------+'+sLineBreak - +'| 4 |'+sLineBreak - +'+---------------------+' - ), - - ( - Name: 'COLLATION'; - Declaration: '(str)'; - Category: 'Information Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the collation of the string argument. If str is not'+sLineBreak - +'a string, it is considered as a binary string (so the'+sLineBreak - +'function returns ''binary''). This applies to NULL, too. The'+sLineBreak - +'return value is a string in the utf8 character set.'+sLineBreak - +' '+sLineBreak - +'See Character Sets and Collations.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT COLLATION(''abc'');'+sLineBreak - +'+-------------------+'+sLineBreak - +'| COLLATION(''abc'') |'+sLineBreak - +'+-------------------+'+sLineBreak - +'| latin1_swedish_ci |'+sLineBreak - +'+-------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT COLLATION(_utf8''abc'');'+sLineBreak - +'+-----------------------+'+sLineBreak - +'| COLLATION(_utf8''abc'') |'+sLineBreak - +'+-----------------------+'+sLineBreak - +'| utf8_general_ci |'+sLineBreak - +'+-----------------------+' - ), - - ( - Name: 'CONNECTION_ID'; - Declaration: '()'; - Category: 'Information Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the connection ID (thread ID) for the connection.'+sLineBreak - +'Every'+sLineBreak - +'thread (including events) has an ID that is unique among the'+sLineBreak - +'set of currently'+sLineBreak - +'connected clients.'+sLineBreak - +' '+sLineBreak - +'Until MariaDB 10.3.1, returns MYSQL_TYPE_LONGLONG, or'+sLineBreak - +'bigint(10), in all cases. From MariaDB 10.3.1, returns'+sLineBreak - +'MYSQL_TYPE_LONG, or int(10), when the result would fit'+sLineBreak - +'within 32-bits.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT CONNECTION_ID();'+sLineBreak - +'+-----------------+'+sLineBreak - +'| CONNECTION_ID() |'+sLineBreak - +'+-----------------+'+sLineBreak - +'| 3 |'+sLineBreak - +'+-----------------+' - ), - - ( - Name: 'DATABASE'; - Declaration: '()'; - Category: 'Information Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the default (current) database name as a string in'+sLineBreak - +'the utf8 character set. If there is no default database,'+sLineBreak - +'DATABASE() returns NULL. Within a stored routine, the'+sLineBreak - +'default database is the database that the routine is'+sLineBreak - +'associated with, which is not necessarily the same as the'+sLineBreak - +'database that is the default in the calling context.'+sLineBreak - +' '+sLineBreak - +'SCHEMA() is a synonym for DATABASE().'+sLineBreak - +' '+sLineBreak - +'To select a default database, the USE statement can be run.'+sLineBreak - +'Another way to set the default database is specifying its'+sLineBreak - +'name at mysql command line client startup.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT DATABASE();'+sLineBreak - +'+------------+'+sLineBreak - +'| DATABASE() |'+sLineBreak - +'+------------+'+sLineBreak - +'| NULL |'+sLineBreak - +'+------------+'+sLineBreak - +' '+sLineBreak - +'USE test;'+sLineBreak - +' '+sLineBreak - +'Database changed'+sLineBreak - +' '+sLineBreak - +'SELECT DATABASE();'+sLineBreak - +'+------------+'+sLineBreak - +'| DATABASE() |'+sLineBreak - +'+------------+'+sLineBreak - +'| test |'+sLineBreak - +'+------------+' - ), - - ( - Name: 'DECODE_HISTOGRAM'; - Declaration: '(hist_type,histogram)'; - Category: 'Information Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns a string of comma separated numeric values'+sLineBreak - +'corresponding to a probability distribution represented by'+sLineBreak - +'the histogram of type hist_type (SINGLE_PREC_HB or'+sLineBreak - +'DOUBLE_PREC_HB). The hist_type and histogram would be'+sLineBreak - +'commonly used from the mysql.column_stats table.'+sLineBreak - +' '+sLineBreak - +'See Histogram Based Statistics for details.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'CREATE TABLE origin ('+sLineBreak - +' i INT UNSIGNED NOT NULL AUTO_INCREMENT PRIMARY KEY,'+sLineBreak - +' v INT UNSIGNED NOT NULL'+sLineBreak - +');'+sLineBreak - +' '+sLineBreak - +'INSERT INTO origin(v) VALUES '+sLineBreak - +' (1),(2),(3),(4),(5),(10),(20),'+sLineBreak - +' (30),(40),(50),(60),(70),(80),'+sLineBreak - +' (90),(100),(200),(400),(800);'+sLineBreak - +' '+sLineBreak - +'SET histogram_size=10,histogram_type=SINGLE_PREC_HB;'+sLineBreak - +' '+sLineBreak - +'ANALYZE TABLE origin PERSISTENT FOR ALL;'+sLineBreak - +' '+sLineBreak - +'+-------------+---------+----------+-----------------------------------------+'+sLineBreak - +'| Table | Op | Msg_type | Msg_text |'+sLineBreak - +'+-------------+---------+----------+-----------------------------------------+'+sLineBreak - +'| test.origin | analyze | status | Engine-independent'+sLineBreak - +'statistics collected |'+sLineBreak - +'| test.origin | analyze | status | OK |'+sLineBreak - +'+-------------+---------+----------+-----------------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT db_name,table_name,column_name,hist_type,'+sLineBreak - +' hex(histogram),decode_histogram(hist_type,histogram) '+sLineBreak - +' FROM mysql.column_stats WHERE db_name=''test'' and'+sLineBreak - +'table_name=''origin'';'+sLineBreak - +' '+sLineBreak - +'+---------+------------+-------------+----------------+----------------------+-------------------------------------------------------------------+'+sLineBreak - +'| db_name | table_name | column_name | hist_type |'+sLineBreak - +'hex(histogram) | decode_histogram(hist_type,histogram) |'+sLineBreak - +'+---------+------------+-------------+----------------+----------------------+-------------------------------------------------------------------+'+sLineBreak - +'| test | origin | i | SINGLE_PREC_HB | 0F2D3C5A7887A5C3D2F0'+sLineBreak - +'|'+sLineBreak - +'0.059,0.118,0.059,0.118,0.118,0.059,0.118,0.118,0.059,0.118,0.059'+sLineBreak - +'|'+sLineBreak - +'| test | origin | v | SINGLE_PREC_HB | 000001060C0F161C1F7F'+sLineBreak - +'|'+sLineBreak - +'0.000,0.000,0.004,0.020,0.024,0.012,0.027,0.024,0.012,0.376,0.502'+sLineBreak - +'|'+sLineBreak - +'+---------+------------+-------------+----------------+----------------------+-------------------------------------------------------------------+'+sLineBreak - +' '+sLineBreak - +'SET histogram_size=20,histogram_type=DOUBLE_PREC_HB;'+sLineBreak - +' '+sLineBreak - +'ANALYZE TABLE origin PERSISTENT FOR ALL;'+sLineBreak - +' '+sLineBreak - +'+-------------+---------+----------+-----------------------------------------+'+sLineBreak - +'| Table | Op | Msg_type | Msg_text |'+sLineBreak - +'+-------------+---------+----------+-----------------------------------------+'+sLineBreak - +'| test.origin | analyze | status | Engine-independent'+sLineBreak - +'statistics collected |'+sLineBreak - +'| test.origin | analyze | status | OK |'+sLineBreak - +'+-------------+---------+----------+-----------------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT db_name,table_name,column_name,'+sLineBreak - +' hist_type,hex(histogram),decode_histogram(hist_type,histogram)'+sLineBreak - +''+sLineBreak - +' FROM mysql.column_stats WHERE db_name=''test'' and'+sLineBreak - +'table_name=''origin'';'+sLineBreak - +' '+sLineBreak - +'+---------+------------+-------------+----------------+------------------------------------------+-----------------------------------------------------------------------------------------+'+sLineBreak - +'| db_name | table_name | column_name | hist_type |'+sLineBreak - +'hex(histogram) | decode_histogram(hist_type,histogram) |'+sLineBreak - +'+---------+------------+-------------+----------------+------------------------------------------+-----------------------------------------------------------------------------------------+'+sLineBreak - +'| test | origin | i | DOUBLE_PREC_HB |'+sLineBreak - +'0F0F2D2D3C3C5A5A78788787A5A5C3C3D2D2F0F0 |'+sLineBreak - +'0.05882,0.11765,0.05882,0.11765,0.11765,0.05882,0.11765,0.11765,0.05882,0.11765,0.05882'+sLineBreak - +'|'+sLineBreak - +'| test | origin | v | DOUBLE_PREC_HB |'+sLineBreak - +'5200F600480116067E0CB30F1B16831CB81FD67F |'+sLineBreak - +'0.00125,0.00250,0.00125,0.01877,0.02502,0.01253,0.02502,0.02502,0.01253,0.37546,0.50063'+sLineBreak - +'|' - ), - - ( - Name: 'DEFAULT'; - Declaration: '(col_name)'; - Category: 'Information Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the default value for a table column. If the column'+sLineBreak - +'has no default value, NULL is returned.'+sLineBreak - +'For integer columns using AUTO_INCREMENT, 0 is returned.'+sLineBreak - +' '+sLineBreak - +'When using DEFAULT as a value to set in an INSERT or UPDATE'+sLineBreak - +'statement, you can use the bare keyword DEFAULT without the'+sLineBreak - +'parentheses and argument to'+sLineBreak - +'refer to the column in context. You can only use DEFAULT as'+sLineBreak - +'a bare keyword if you are using it'+sLineBreak - +'alone without a surrounding expression or function.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'Select only non-default values for a column:'+sLineBreak - +' '+sLineBreak - +'SELECT i FROM t WHERE i != DEFAULT(i);'+sLineBreak - +' '+sLineBreak - +'Update values to be one greater than the default value:'+sLineBreak - +' '+sLineBreak - +'UPDATE t SET i = DEFAULT(i)+1 WHERE i' - ), - - ( - Name: 'FOUND_ROWS'; - Declaration: '()'; - Category: 'Information Functions'; - Version: SQL_VERSION_ANSI; - Description: 'A SELECT statement may include a LIMIT clause to restrict'+sLineBreak - +'the number'+sLineBreak - +'of rows the server returns to the client. In some cases, it'+sLineBreak - +'is'+sLineBreak - +'desirable to know how many rows the statement would have'+sLineBreak - +'returned'+sLineBreak - +'without the LIMIT, but without running the statement again.'+sLineBreak - +'To obtain'+sLineBreak - +'this row count, include a SQL_CALC_FOUND_ROWS option in the'+sLineBreak - +'SELECT'+sLineBreak - +'statement, and then invoke FOUND_ROWS() afterwards.'+sLineBreak - +' '+sLineBreak - +'You can also use FOUND_ROWS() to obtain the number of rows'+sLineBreak - +'returned by a SELECT which does not contain a LIMIT clause.'+sLineBreak - +'In this case you don''t need to use the SQL_CALC_FOUND_ROWS'+sLineBreak - +'option. This can be useful for example in a stored'+sLineBreak - +'procedure.'+sLineBreak - +' '+sLineBreak - +'Also, this function works with some other statements which'+sLineBreak - +'return a resultset, including SHOW, DESC and HELP. For'+sLineBreak - +'DELETE ... RETURNING you should use ROW_COUNT(). It also'+sLineBreak - +'works as a prepared statement, or after executing a prepared'+sLineBreak - +'statement.'+sLineBreak - +' '+sLineBreak - +'Statements which don''t return any results don''t affect'+sLineBreak - +'FOUND_ROWS() - the previous value will still be returned.'+sLineBreak - +' '+sLineBreak - +'Warning: When used after a CALL statement, this function'+sLineBreak - +'returns the number of rows selected by the last query in the'+sLineBreak - +'procedure, not by the whole procedure.'+sLineBreak - +' '+sLineBreak - +'Statements using the FOUND_ROWS() function are not safe for'+sLineBreak - +'replication.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SHOW ENGINES;'+sLineBreak - +' '+sLineBreak - +'+--------------------+---------+----------------------------------------------------------------+--------------+------+------------+'+sLineBreak - +'| Engine | Support | Comment | Transactions | XA |'+sLineBreak - +'Savepoints |'+sLineBreak - +'+--------------------+---------+----------------------------------------------------------------+--------------+------+------------+'+sLineBreak - +'| InnoDB | DEFAULT | Supports transactions, row-level'+sLineBreak - +'locking, and foreign keys | YES | YES | YES |'+sLineBreak - +'...'+sLineBreak - +'| SPHINX | YES | Sphinx storage engine | NO | NO | NO |'+sLineBreak - +'+--------------------+---------+----------------------------------------------------------------+--------------+------+------------+'+sLineBreak - +'11 rows in set (0.01 sec)'+sLineBreak - +' '+sLineBreak - +'SELECT FOUND_ROWS();'+sLineBreak - +'+--------------+'+sLineBreak - +'| FOUND_ROWS() |'+sLineBreak - +'+--------------+'+sLineBreak - +'| 11 |'+sLineBreak - +'+--------------+'+sLineBreak - +' '+sLineBreak - +'SELECT SQL_CALC_FOUND_ROWS * FROM tbl_name WHERE id > 100'+sLineBreak - +'LIMIT 10;'+sLineBreak - +' '+sLineBreak - +'SELECT FOUND_ROWS();'+sLineBreak - +'+--------------+'+sLineBreak - +'| FOUND_ROWS() |'+sLineBreak - +'+--------------+'+sLineBreak - +'| 23 |'+sLineBreak - +'+--------------+' - ), - - ( - Name: 'LAST_INSERT_ID'; - Declaration: '()'; - Category: 'Information Functions'; - Version: SQL_VERSION_ANSI; - Description: 'LAST_INSERT_ID() (no arguments) returns'+sLineBreak - +'the first automatically generated value successfully'+sLineBreak - +'inserted for an'+sLineBreak - +'AUTO_INCREMENT column as a result of the most recently'+sLineBreak - +'executed INSERT'+sLineBreak - +'statement. The value of LAST_INSERT_ID() remains unchanged'+sLineBreak - +'if no rows'+sLineBreak - +'are successfully inserted.'+sLineBreak - +' '+sLineBreak - +'If one gives an argument to LAST_INSERT_ID(), then it will'+sLineBreak - +'return the value of the expression and'+sLineBreak - +'the next call to LAST_INSERT_ID() will return the same'+sLineBreak - +'value. The value will also be sent to the client'+sLineBreak - +'and can be accessed by the mysql_insert_id function.'+sLineBreak - +' '+sLineBreak - +'For example, after inserting a row that generates an'+sLineBreak - +'AUTO_INCREMENT'+sLineBreak - +'value, you can get the value like this:'+sLineBreak - +' '+sLineBreak - +'SELECT LAST_INSERT_ID();'+sLineBreak - +'+------------------+'+sLineBreak - +'| LAST_INSERT_ID() |'+sLineBreak - +'+------------------+'+sLineBreak - +'| 9 |'+sLineBreak - +'+------------------+'+sLineBreak - +' '+sLineBreak - +'You can also use LAST_INSERT_ID() to delete the last'+sLineBreak - +'inserted row:'+sLineBreak - +' '+sLineBreak - +'DELETE FROM product WHERE id = LAST_INSERT_ID();'+sLineBreak - +' '+sLineBreak - +'If no rows were successfully inserted, LAST_INSERT_ID()'+sLineBreak - +'returns 0.'+sLineBreak - +' '+sLineBreak - +'The value of LAST_INSERT_ID() will be consistent across all'+sLineBreak - +'versions'+sLineBreak - +'if all rows in the INSERT or UPDATE statement were'+sLineBreak - +'successful.'+sLineBreak - +' '+sLineBreak - +'The currently executing statement does not affect the value'+sLineBreak - +'of'+sLineBreak - +'LAST_INSERT_ID(). Suppose that you generate an'+sLineBreak - +'AUTO_INCREMENT value'+sLineBreak - +'with one statement, and then refer to LAST_INSERT_ID() in a'+sLineBreak - +'multiple-row INSERT statement that inserts rows into a table'+sLineBreak - +'with its'+sLineBreak - +'own AUTO_INCREMENT column. The value of LAST_INSERT_ID()'+sLineBreak - +'will remain'+sLineBreak - +'stable in the second statement; its value for the second and'+sLineBreak - +'later'+sLineBreak - +'rows is not affected by the earlier row insertions.'+sLineBreak - +'(However, if you'+sLineBreak - +'mix references to LAST_INSERT_ID() and LAST_INSERT_ID(expr),'+sLineBreak - +'the'+sLineBreak - +'effect is undefined.)'+sLineBreak - +' '+sLineBreak - +'If the previous statement returned an error, the value of'+sLineBreak - +'LAST_INSERT_ID() is undefined. For transactional tables, if'+sLineBreak - +'the'+sLineBreak - +'statement is rolled back due to an error, the value of'+sLineBreak - +'LAST_INSERT_ID() is left undefined. For manual ROLLBACK, the'+sLineBreak - +'value of'+sLineBreak - +'LAST_INSERT_ID() is not restored to that before the'+sLineBreak - +'transaction; it'+sLineBreak - +'remains as it was at the point of the ROLLBACK.'+sLineBreak - +' '+sLineBreak - +'Within the body of a stored routine (procedure or function)'+sLineBreak - +'or a'+sLineBreak - +'trigger, the value of LAST_INSERT_ID() changes the same way'+sLineBreak - +'as for'+sLineBreak - +'statements executed outside the body of these kinds of'+sLineBreak - +'objects. The'+sLineBreak - +'effect of a stored routine or trigger upon the value of'+sLineBreak - +'LAST_INSERT_ID() that is seen by following statements'+sLineBreak - +'depends on the'+sLineBreak - +'kind of routine:'+sLineBreak - +'If a stored procedure executes statements that change the'+sLineBreak - +'value of LAST_INSERT_ID(), the new value will be seen by'+sLineBreak - +'statements that follow the procedure call.'+sLineBreak - +' '+sLineBreak - +'For stored functions and triggers that change the value, the'+sLineBreak - +'value is restored when the function or trigger ends, so'+sLineBreak - +'following statements will not see a changed value.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'CREATE TABLE t ('+sLineBreak - +' id INTEGER UNSIGNED AUTO_INCREMENT PRIMARY KEY, '+sLineBreak - +' f VARCHAR(1)) '+sLineBreak - +'ENGINE = InnoDB;'+sLineBreak - +' '+sLineBreak - +'INSERT INTO t(f) VALUES(''a'');'+sLineBreak - +' '+sLineBreak - +'SELECT LAST_INSERT_ID();'+sLineBreak - +'+------------------+'+sLineBreak - +'| LAST_INSERT_ID() |'+sLineBreak - +'+------------------+'+sLineBreak - +'| 1 |'+sLineBreak - +'+------------------+'+sLineBreak - +' '+sLineBreak - +'INSERT INTO t(f) VALUES(''b'');'+sLineBreak - +' '+sLineBreak - +'INSERT INTO t(f) VALUES(''c'');'+sLineBreak - +' '+sLineBreak - +'SELECT LAST_INSERT_ID();'+sLineBreak - +'+------------------+'+sLineBreak - +'| LAST_INSERT_ID() |'+sLineBreak - +'+------------------+'+sLineBreak - +'| 3 |'+sLineBreak - +'+------------------+'+sLineBreak - +' '+sLineBreak - +'INSERT INTO t(f) VALUES(''d''),(''e'');'+sLineBreak - +' '+sLineBreak - +'SELECT LAST_INSERT_ID();'+sLineBreak - +'+------------------+'+sLineBreak - +'| LAST_INSERT_ID() |'+sLineBreak - +'+------------------+'+sLineBreak - +'| 4 |'+sLineBreak - +'+------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT * FROM t;'+sLineBreak - +' '+sLineBreak - +'+----+------+'+sLineBreak - +'| id | f |'+sLineBreak - +'+----+------+'+sLineBreak - +'| 1 | a |'+sLineBreak - +'| 2 | b |'+sLineBreak - +'| 3 | c |'+sLineBreak - +'| 4 | d |'+sLineBreak - +'| 5 | e |'+sLineBreak - +'+----+------+'+sLineBreak - +' '+sLineBreak - +'SELECT LAST_INSERT_ID(12);'+sLineBreak - +'+--------------------+'+sLineBreak - +'| LAST_INSERT_ID(12) |'+sLineBreak - +'+--------------------+'+sLineBreak - +'| 12 |'+sLineBreak - +'+--------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT LAST_INSERT_ID();'+sLineBreak - +'+------------------+'+sLineBreak - +'| LAST_INSERT_ID() |'+sLineBreak - +'+------------------+'+sLineBreak - +'| 12 |'+sLineBreak - +'+------------------+'+sLineBreak - +' '+sLineBreak - +'INSERT INTO t(f) VALUES(''f'');'+sLineBreak - +' '+sLineBreak - +'SELECT LAST_INSERT_ID();'+sLineBreak - +'+------------------+'+sLineBreak - +'| LAST_INSERT_ID() |'+sLineBreak - +'+------------------+'+sLineBreak - +'| 6 |'+sLineBreak - +'+------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT * FROM t;'+sLineBreak - +' '+sLineBreak - +'+----+------+'+sLineBreak - +'| id | f |'+sLineBreak - +'+----+------+'+sLineBreak - +'| 1 | a |'+sLineBreak - +'| 2 | b |'+sLineBreak - +'| 3 | c |'+sLineBreak - +'| 4 | d |'+sLineBreak - +'| 5 | e |'+sLineBreak - +'| 6 | f |'+sLineBreak - +'+----+------+'+sLineBreak - +' '+sLineBreak - +'SELECT LAST_INSERT_ID(12);'+sLineBreak - +'+--------------------+'+sLineBreak - +'| LAST_INSERT_ID(12) |'+sLineBreak - +'+--------------------+'+sLineBreak - +'| 12 |'+sLineBreak - +'+--------------------+'+sLineBreak - +' '+sLineBreak - +'INSERT INTO t(f) VALUES(''g'');'+sLineBreak - +' '+sLineBreak - +'SELECT * FROM t;'+sLineBreak - +' '+sLineBreak - +'+----+------+'+sLineBreak - +'| id | f |'+sLineBreak - +'+----+------+'+sLineBreak - +'| 1 | a |'+sLineBreak - +'| 2 | b |'+sLineBreak - +'| 3 | c |'+sLineBreak - +'| 4 | d |'+sLineBreak - +'| 5 | e |'+sLineBreak - +'| 6 | f |'+sLineBreak - +'| 7 | g |'+sLineBreak - +'+----+------+' - ), - - ( - Name: 'LAST_INSERT_ID'; - Declaration: '(expr)'; - Category: 'Information Functions'; - Version: SQL_VERSION_ANSI; - Description: 'LAST_INSERT_ID() (no arguments) returns'+sLineBreak - +'the first automatically generated value successfully'+sLineBreak - +'inserted for an'+sLineBreak - +'AUTO_INCREMENT column as a result of the most recently'+sLineBreak - +'executed INSERT'+sLineBreak - +'statement. The value of LAST_INSERT_ID() remains unchanged'+sLineBreak - +'if no rows'+sLineBreak - +'are successfully inserted.'+sLineBreak - +' '+sLineBreak - +'If one gives an argument to LAST_INSERT_ID(), then it will'+sLineBreak - +'return the value of the expression and'+sLineBreak - +'the next call to LAST_INSERT_ID() will return the same'+sLineBreak - +'value. The value will also be sent to the client'+sLineBreak - +'and can be accessed by the mysql_insert_id function.'+sLineBreak - +' '+sLineBreak - +'For example, after inserting a row that generates an'+sLineBreak - +'AUTO_INCREMENT'+sLineBreak - +'value, you can get the value like this:'+sLineBreak - +' '+sLineBreak - +'SELECT LAST_INSERT_ID();'+sLineBreak - +'+------------------+'+sLineBreak - +'| LAST_INSERT_ID() |'+sLineBreak - +'+------------------+'+sLineBreak - +'| 9 |'+sLineBreak - +'+------------------+'+sLineBreak - +' '+sLineBreak - +'You can also use LAST_INSERT_ID() to delete the last'+sLineBreak - +'inserted row:'+sLineBreak - +' '+sLineBreak - +'DELETE FROM product WHERE id = LAST_INSERT_ID();'+sLineBreak - +' '+sLineBreak - +'If no rows were successfully inserted, LAST_INSERT_ID()'+sLineBreak - +'returns 0.'+sLineBreak - +' '+sLineBreak - +'The value of LAST_INSERT_ID() will be consistent across all'+sLineBreak - +'versions'+sLineBreak - +'if all rows in the INSERT or UPDATE statement were'+sLineBreak - +'successful.'+sLineBreak - +' '+sLineBreak - +'The currently executing statement does not affect the value'+sLineBreak - +'of'+sLineBreak - +'LAST_INSERT_ID(). Suppose that you generate an'+sLineBreak - +'AUTO_INCREMENT value'+sLineBreak - +'with one statement, and then refer to LAST_INSERT_ID() in a'+sLineBreak - +'multiple-row INSERT statement that inserts rows into a table'+sLineBreak - +'with its'+sLineBreak - +'own AUTO_INCREMENT column. The value of LAST_INSERT_ID()'+sLineBreak - +'will remain'+sLineBreak - +'stable in the second statement; its value for the second and'+sLineBreak - +'later'+sLineBreak - +'rows is not affected by the earlier row insertions.'+sLineBreak - +'(However, if you'+sLineBreak - +'mix references to LAST_INSERT_ID() and LAST_INSERT_ID(expr),'+sLineBreak - +'the'+sLineBreak - +'effect is undefined.)'+sLineBreak - +' '+sLineBreak - +'If the previous statement returned an error, the value of'+sLineBreak - +'LAST_INSERT_ID() is undefined. For transactional tables, if'+sLineBreak - +'the'+sLineBreak - +'statement is rolled back due to an error, the value of'+sLineBreak - +'LAST_INSERT_ID() is left undefined. For manual ROLLBACK, the'+sLineBreak - +'value of'+sLineBreak - +'LAST_INSERT_ID() is not restored to that before the'+sLineBreak - +'transaction; it'+sLineBreak - +'remains as it was at the point of the ROLLBACK.'+sLineBreak - +' '+sLineBreak - +'Within the body of a stored routine (procedure or function)'+sLineBreak - +'or a'+sLineBreak - +'trigger, the value of LAST_INSERT_ID() changes the same way'+sLineBreak - +'as for'+sLineBreak - +'statements executed outside the body of these kinds of'+sLineBreak - +'objects. The'+sLineBreak - +'effect of a stored routine or trigger upon the value of'+sLineBreak - +'LAST_INSERT_ID() that is seen by following statements'+sLineBreak - +'depends on the'+sLineBreak - +'kind of routine:'+sLineBreak - +'If a stored procedure executes statements that change the'+sLineBreak - +'value of LAST_INSERT_ID(), the new value will be seen by'+sLineBreak - +'statements that follow the procedure call.'+sLineBreak - +' '+sLineBreak - +'For stored functions and triggers that change the value, the'+sLineBreak - +'value is restored when the function or trigger ends, so'+sLineBreak - +'following statements will not see a changed value.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'CREATE TABLE t ('+sLineBreak - +' id INTEGER UNSIGNED AUTO_INCREMENT PRIMARY KEY, '+sLineBreak - +' f VARCHAR(1)) '+sLineBreak - +'ENGINE = InnoDB;'+sLineBreak - +' '+sLineBreak - +'INSERT INTO t(f) VALUES(''a'');'+sLineBreak - +' '+sLineBreak - +'SELECT LAST_INSERT_ID();'+sLineBreak - +'+------------------+'+sLineBreak - +'| LAST_INSERT_ID() |'+sLineBreak - +'+------------------+'+sLineBreak - +'| 1 |'+sLineBreak - +'+------------------+'+sLineBreak - +' '+sLineBreak - +'INSERT INTO t(f) VALUES(''b'');'+sLineBreak - +' '+sLineBreak - +'INSERT INTO t(f) VALUES(''c'');'+sLineBreak - +' '+sLineBreak - +'SELECT LAST_INSERT_ID();'+sLineBreak - +'+------------------+'+sLineBreak - +'| LAST_INSERT_ID() |'+sLineBreak - +'+------------------+'+sLineBreak - +'| 3 |'+sLineBreak - +'+------------------+'+sLineBreak - +' '+sLineBreak - +'INSERT INTO t(f) VALUES(''d''),(''e'');'+sLineBreak - +' '+sLineBreak - +'SELECT LAST_INSERT_ID();'+sLineBreak - +'+------------------+'+sLineBreak - +'| LAST_INSERT_ID() |'+sLineBreak - +'+------------------+'+sLineBreak - +'| 4 |'+sLineBreak - +'+------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT * FROM t;'+sLineBreak - +' '+sLineBreak - +'+----+------+'+sLineBreak - +'| id | f |'+sLineBreak - +'+----+------+'+sLineBreak - +'| 1 | a |'+sLineBreak - +'| 2 | b |'+sLineBreak - +'| 3 | c |'+sLineBreak - +'| 4 | d |'+sLineBreak - +'| 5 | e |'+sLineBreak - +'+----+------+'+sLineBreak - +' '+sLineBreak - +'SELECT LAST_INSERT_ID(12);'+sLineBreak - +'+--------------------+'+sLineBreak - +'| LAST_INSERT_ID(12) |'+sLineBreak - +'+--------------------+'+sLineBreak - +'| 12 |'+sLineBreak - +'+--------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT LAST_INSERT_ID();'+sLineBreak - +'+------------------+'+sLineBreak - +'| LAST_INSERT_ID() |'+sLineBreak - +'+------------------+'+sLineBreak - +'| 12 |'+sLineBreak - +'+------------------+'+sLineBreak - +' '+sLineBreak - +'INSERT INTO t(f) VALUES(''f'');'+sLineBreak - +' '+sLineBreak - +'SELECT LAST_INSERT_ID();'+sLineBreak - +'+------------------+'+sLineBreak - +'| LAST_INSERT_ID() |'+sLineBreak - +'+------------------+'+sLineBreak - +'| 6 |'+sLineBreak - +'+------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT * FROM t;'+sLineBreak - +' '+sLineBreak - +'+----+------+'+sLineBreak - +'| id | f |'+sLineBreak - +'+----+------+'+sLineBreak - +'| 1 | a |'+sLineBreak - +'| 2 | b |'+sLineBreak - +'| 3 | c |'+sLineBreak - +'| 4 | d |'+sLineBreak - +'| 5 | e |'+sLineBreak - +'| 6 | f |'+sLineBreak - +'+----+------+'+sLineBreak - +' '+sLineBreak - +'SELECT LAST_INSERT_ID(12);'+sLineBreak - +'+--------------------+'+sLineBreak - +'| LAST_INSERT_ID(12) |'+sLineBreak - +'+--------------------+'+sLineBreak - +'| 12 |'+sLineBreak - +'+--------------------+'+sLineBreak - +' '+sLineBreak - +'INSERT INTO t(f) VALUES(''g'');'+sLineBreak - +' '+sLineBreak - +'SELECT * FROM t;'+sLineBreak - +' '+sLineBreak - +'+----+------+'+sLineBreak - +'| id | f |'+sLineBreak - +'+----+------+'+sLineBreak - +'| 1 | a |'+sLineBreak - +'| 2 | b |'+sLineBreak - +'| 3 | c |'+sLineBreak - +'| 4 | d |'+sLineBreak - +'| 5 | e |'+sLineBreak - +'| 6 | f |'+sLineBreak - +'| 7 | g |'+sLineBreak - +'+----+------+' - ), - - ( - Name: 'LAST_VALUE'; - Declaration: '(expr,[expr,...])'; - Category: 'Information Functions'; - Version: SQL_VERSION_ANSI; - Description: 'LAST_VALUE() evaluates all expressions and returns the last.'+sLineBreak - +' '+sLineBreak - +'This is useful together with setting user variables to a'+sLineBreak - +'value with @var:=expr, for example when you want to get data'+sLineBreak - +'of rows updated/deleted without having to do two queries'+sLineBreak - +'against the table.'+sLineBreak - +' '+sLineBreak - +'Since MariaDB 10.2.2, LAST_VALUE can be used as a window'+sLineBreak - +'function.'+sLineBreak - +' '+sLineBreak - +'Returns NULL if no last value exists.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'CREATE TABLE t1 (a int, b int);'+sLineBreak - +'INSERT INTO t1 VALUES(1,10),(2,20);'+sLineBreak - +'DELETE FROM t1 WHERE a=1 AND last_value(@a:=a,@b:=b,1);'+sLineBreak - +'SELECT @a,@b;'+sLineBreak - +' '+sLineBreak - +'+------+------+'+sLineBreak - +'| @a | @b |'+sLineBreak - +'+------+------+'+sLineBreak - +'| 1 | 10 |'+sLineBreak - +'+------+------+'+sLineBreak - +' '+sLineBreak - +'As a window function:'+sLineBreak - +' '+sLineBreak - +'CREATE TABLE t1 ('+sLineBreak - +' pk int primary key,'+sLineBreak - +' a int,'+sLineBreak - +' b int,'+sLineBreak - +' c char(10),'+sLineBreak - +' d decimal(10, 3),'+sLineBreak - +' e real'+sLineBreak - +');'+sLineBreak - +' '+sLineBreak - +'INSERT INTO t1 VALUES'+sLineBreak - +'( 1, 0, 1, ''one'', 0.1, 0.001),'+sLineBreak - +'( 2, 0, 2, ''two'', 0.2, 0.002),'+sLineBreak - +'( 3, 0, 3, ''three'', 0.3, 0.003),'+sLineBreak - +'( 4, 1, 2, ''three'', 0.4, 0.004),'+sLineBreak - +'( 5, 1, 1, ''two'', 0.5, 0.005),'+sLineBreak - +'( 6, 1, 1, ''one'', 0.6, 0.006),'+sLineBreak - +'( 7, 2, NULL, ''n_one'', 0.5, 0.007),'+sLineBreak - +'( 8, 2, 1, ''n_two'', NULL, 0.008),'+sLineBreak - +'( 9, 2, 2, NULL, 0.7, 0.009),'+sLineBreak - +'(10, 2, 0, ''n_four'', 0.8, 0.010),'+sLineBreak - +'(11, 2, 10, NULL, 0.9, NULL);'+sLineBreak - +' '+sLineBreak - +'SELECT pk, FIRST_VALUE(pk) OVER (ORDER BY pk) AS first_asc,'+sLineBreak - +' LAST_VALUE(pk) OVER (ORDER BY pk) AS last_asc,'+sLineBreak - +' FIRST_VALUE(pk) OVER (ORDER BY pk DESC) AS first_desc,'+sLineBreak - +' LAST_VALUE(pk) OVER (ORDER BY pk DESC) AS last_desc'+sLineBreak - +'FROM t1'+sLineBreak - +'ORDER BY pk DESC;'+sLineBreak - +' '+sLineBreak - +'+----+-----------+----------+------------+-----------+'+sLineBreak - +'| pk | first_asc | last_asc | first_desc | last_desc |'+sLineBreak - +'+----+-----------+----------+------------+-----------+'+sLineBreak - +'| 11 | 1 | 11 | 11 | 11 |'+sLineBreak - +'| 10 | 1 | 10 | 11 | 10 |'+sLineBreak - +'| 9 | 1 | 9 | 11 | 9 |'+sLineBreak - +'| 8 | 1 | 8 | 11 | 8 |'+sLineBreak - +'| 7 | 1 | 7 | 11 | 7 |'+sLineBreak - +'| 6 | 1 | 6 | 11 | 6 |'+sLineBreak - +'| 5 | 1 | 5 | 11 | 5 |'+sLineBreak - +'| 4 | 1 | 4 | 11 | 4 |'+sLineBreak - +'| 3 | 1 | 3 | 11 | 3 |'+sLineBreak - +'| 2 | 1 | 2 | 11 | 2 |'+sLineBreak - +'| 1 | 1 | 1 | 11 | 1 |'+sLineBreak - +'+----+-----------+----------+------------+-----------+'+sLineBreak - +' '+sLineBreak - +'CREATE OR REPLACE TABLE t1 (i int);'+sLineBreak - +'INSERT INTO t1 VALUES'+sLineBreak - +'(1),(2),(3),(4),(5),(6),(7),(8),(9),(10);'+sLineBreak - +' '+sLineBreak - +'SELECT i,'+sLineBreak - +' FIRST_VALUE(i) OVER (ORDER BY i ROWS BETWEEN CURRENT ROW'+sLineBreak - +'and 1 FOLLOWING) AS f_1f,'+sLineBreak - +' LAST_VALUE(i) OVER (ORDER BY i ROWS BETWEEN CURRENT ROW and'+sLineBreak - +'1 FOLLOWING) AS l_1f,'+sLineBreak - +' FIRST_VALUE(i) OVER (ORDER BY i ROWS BETWEEN 1 PRECEDING'+sLineBreak - +'AND 1 FOLLOWING) AS f_1p1f,'+sLineBreak - +' LAST_VALUE(i) OVER (ORDER BY i ROWS BETWEEN 1 PRECEDING AND'+sLineBreak - +'1 FOLLOWING) AS f_1p1f,'+sLineBreak - +' FIRST_VALUE(i) OVER (ORDER BY i ROWS BETWEEN 2 PRECEDING'+sLineBreak - +'AND 1 PRECEDING) AS f_2p1p,'+sLineBreak - +' LAST_VALUE(i) OVER (ORDER BY i ROWS BETWEEN 2 PRECEDING AND'+sLineBreak - +'1 PRECEDING) AS f_2p1p,'+sLineBreak - +' FIRST_VALUE(i) OVER (ORDER BY i ROWS BETWEEN 1 FOLLOWING'+sLineBreak - +'AND 2 FOLLOWING) AS f_1f2f,'+sLineBreak - +' LAST_VALUE(i) OVER (ORDER BY i ROWS BETWEEN 1 FOLLOWING AND'+sLineBreak - +'2 FOLLOWING) AS f_1f2f'+sLineBreak - +'FROM t1;'+sLineBreak - +' '+sLineBreak - +'+------+------+------+--------+--------+--------+--------+--------+--------+'+sLineBreak - +'| i | f_1f | l_1f | f_1p1f | f_1p1f | f_2p1p | f_2p1p |'+sLineBreak - +'f_1f2f | f_1f2f |'+sLineBreak - +'+------+------+------+--------+--------+--------+--------+--------+--------+'+sLineBreak - +'| 1 | 1 | 2 | 1 | 2 | NULL | NULL | 2 | 3 |'+sLineBreak - +'| 2 | 2 | 3 | 1 | 3 | 1 | 1 | 3 | 4 |'+sLineBreak - +'| 3 | 3 | 4 | 2 | 4 | 1 | 2 | 4 | 5 |'+sLineBreak - +'| 4 | 4 | 5 | 3 | 5 | 2 | 3 | 5 | 6 |'+sLineBreak - +'| 5 | 5 | 6 | 4 | 6 | 3 | 4 | 6 | 7 |'+sLineBreak - +'| 6 | 6 | 7 | 5 | 7 | 4 | 5 | 7 | 8 |'+sLineBreak - +'| 7 | 7 | 8 | 6 | 8 | 5 | 6 | 8 | 9 |'+sLineBreak - +'| 8 | 8 | 9 | 7 | 9 | 6 | 7 | 9 | 10 |'+sLineBreak - +'| 9 | 9 | 10 | 8 | 10 | 7 | 8 | 10 | 10 |'+sLineBreak - +'| 10 | 10 | 10 | 9 | 10 | 8 | 9 | NULL | NULL |'+sLineBreak - +'+------+------+------+--------+--------+--------+--------+--------+--------+' - ), - - ( - Name: 'LAST_VALUE'; - Declaration: '(expr)'; - Category: 'Information Functions'; - Version: SQL_VERSION_ANSI; - Description: 'LAST_VALUE() evaluates all expressions and returns the last.'+sLineBreak - +' '+sLineBreak - +'This is useful together with setting user variables to a'+sLineBreak - +'value with @var:=expr, for example when you want to get data'+sLineBreak - +'of rows updated/deleted without having to do two queries'+sLineBreak - +'against the table.'+sLineBreak - +' '+sLineBreak - +'Since MariaDB 10.2.2, LAST_VALUE can be used as a window'+sLineBreak - +'function.'+sLineBreak - +' '+sLineBreak - +'Returns NULL if no last value exists.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'CREATE TABLE t1 (a int, b int);'+sLineBreak - +'INSERT INTO t1 VALUES(1,10),(2,20);'+sLineBreak - +'DELETE FROM t1 WHERE a=1 AND last_value(@a:=a,@b:=b,1);'+sLineBreak - +'SELECT @a,@b;'+sLineBreak - +' '+sLineBreak - +'+------+------+'+sLineBreak - +'| @a | @b |'+sLineBreak - +'+------+------+'+sLineBreak - +'| 1 | 10 |'+sLineBreak - +'+------+------+'+sLineBreak - +' '+sLineBreak - +'As a window function:'+sLineBreak - +' '+sLineBreak - +'CREATE TABLE t1 ('+sLineBreak - +' pk int primary key,'+sLineBreak - +' a int,'+sLineBreak - +' b int,'+sLineBreak - +' c char(10),'+sLineBreak - +' d decimal(10, 3),'+sLineBreak - +' e real'+sLineBreak - +');'+sLineBreak - +' '+sLineBreak - +'INSERT INTO t1 VALUES'+sLineBreak - +'( 1, 0, 1, ''one'', 0.1, 0.001),'+sLineBreak - +'( 2, 0, 2, ''two'', 0.2, 0.002),'+sLineBreak - +'( 3, 0, 3, ''three'', 0.3, 0.003),'+sLineBreak - +'( 4, 1, 2, ''three'', 0.4, 0.004),'+sLineBreak - +'( 5, 1, 1, ''two'', 0.5, 0.005),'+sLineBreak - +'( 6, 1, 1, ''one'', 0.6, 0.006),'+sLineBreak - +'( 7, 2, NULL, ''n_one'', 0.5, 0.007),'+sLineBreak - +'( 8, 2, 1, ''n_two'', NULL, 0.008),'+sLineBreak - +'( 9, 2, 2, NULL, 0.7, 0.009),'+sLineBreak - +'(10, 2, 0, ''n_four'', 0.8, 0.010),'+sLineBreak - +'(11, 2, 10, NULL, 0.9, NULL);'+sLineBreak - +' '+sLineBreak - +'SELECT pk, FIRST_VALUE(pk) OVER (ORDER BY pk) AS first_asc,'+sLineBreak - +' LAST_VALUE(pk) OVER (ORDER BY pk) AS last_asc,'+sLineBreak - +' FIRST_VALUE(pk) OVER (ORDER BY pk DESC) AS first_desc,'+sLineBreak - +' LAST_VALUE(pk) OVER (ORDER BY pk DESC) AS last_desc'+sLineBreak - +'FROM t1'+sLineBreak - +'ORDER BY pk DESC;'+sLineBreak - +' '+sLineBreak - +'+----+-----------+----------+------------+-----------+'+sLineBreak - +'| pk | first_asc | last_asc | first_desc | last_desc |'+sLineBreak - +'+----+-----------+----------+------------+-----------+'+sLineBreak - +'| 11 | 1 | 11 | 11 | 11 |'+sLineBreak - +'| 10 | 1 | 10 | 11 | 10 |'+sLineBreak - +'| 9 | 1 | 9 | 11 | 9 |'+sLineBreak - +'| 8 | 1 | 8 | 11 | 8 |'+sLineBreak - +'| 7 | 1 | 7 | 11 | 7 |'+sLineBreak - +'| 6 | 1 | 6 | 11 | 6 |'+sLineBreak - +'| 5 | 1 | 5 | 11 | 5 |'+sLineBreak - +'| 4 | 1 | 4 | 11 | 4 |'+sLineBreak - +'| 3 | 1 | 3 | 11 | 3 |'+sLineBreak - +'| 2 | 1 | 2 | 11 | 2 |'+sLineBreak - +'| 1 | 1 | 1 | 11 | 1 |'+sLineBreak - +'+----+-----------+----------+------------+-----------+'+sLineBreak - +' '+sLineBreak - +'CREATE OR REPLACE TABLE t1 (i int);'+sLineBreak - +'INSERT INTO t1 VALUES'+sLineBreak - +'(1),(2),(3),(4),(5),(6),(7),(8),(9),(10);'+sLineBreak - +' '+sLineBreak - +'SELECT i,'+sLineBreak - +' FIRST_VALUE(i) OVER (ORDER BY i ROWS BETWEEN CURRENT ROW'+sLineBreak - +'and 1 FOLLOWING) AS f_1f,'+sLineBreak - +' LAST_VALUE(i) OVER (ORDER BY i ROWS BETWEEN CURRENT ROW and'+sLineBreak - +'1 FOLLOWING) AS l_1f,'+sLineBreak - +' FIRST_VALUE(i) OVER (ORDER BY i ROWS BETWEEN 1 PRECEDING'+sLineBreak - +'AND 1 FOLLOWING) AS f_1p1f,'+sLineBreak - +' LAST_VALUE(i) OVER (ORDER BY i ROWS BETWEEN 1 PRECEDING AND'+sLineBreak - +'1 FOLLOWING) AS f_1p1f,'+sLineBreak - +' FIRST_VALUE(i) OVER (ORDER BY i ROWS BETWEEN 2 PRECEDING'+sLineBreak - +'AND 1 PRECEDING) AS f_2p1p,'+sLineBreak - +' LAST_VALUE(i) OVER (ORDER BY i ROWS BETWEEN 2 PRECEDING AND'+sLineBreak - +'1 PRECEDING) AS f_2p1p,'+sLineBreak - +' FIRST_VALUE(i) OVER (ORDER BY i ROWS BETWEEN 1 FOLLOWING'+sLineBreak - +'AND 2 FOLLOWING) AS f_1f2f,'+sLineBreak - +' LAST_VALUE(i) OVER (ORDER BY i ROWS BETWEEN 1 FOLLOWING AND'+sLineBreak - +'2 FOLLOWING) AS f_1f2f'+sLineBreak - +'FROM t1;'+sLineBreak - +' '+sLineBreak - +'+------+------+------+--------+--------+--------+--------+--------+--------+'+sLineBreak - +'| i | f_1f | l_1f | f_1p1f | f_1p1f | f_2p1p | f_2p1p |'+sLineBreak - +'f_1f2f | f_1f2f |'+sLineBreak - +'+------+------+------+--------+--------+--------+--------+--------+--------+'+sLineBreak - +'| 1 | 1 | 2 | 1 | 2 | NULL | NULL | 2 | 3 |'+sLineBreak - +'| 2 | 2 | 3 | 1 | 3 | 1 | 1 | 3 | 4 |'+sLineBreak - +'| 3 | 3 | 4 | 2 | 4 | 1 | 2 | 4 | 5 |'+sLineBreak - +'| 4 | 4 | 5 | 3 | 5 | 2 | 3 | 5 | 6 |'+sLineBreak - +'| 5 | 5 | 6 | 4 | 6 | 3 | 4 | 6 | 7 |'+sLineBreak - +'| 6 | 6 | 7 | 5 | 7 | 4 | 5 | 7 | 8 |'+sLineBreak - +'| 7 | 7 | 8 | 6 | 8 | 5 | 6 | 8 | 9 |'+sLineBreak - +'| 8 | 8 | 9 | 7 | 9 | 6 | 7 | 9 | 10 |'+sLineBreak - +'| 9 | 9 | 10 | 8 | 10 | 7 | 8 | 10 | 10 |'+sLineBreak - +'| 10 | 10 | 10 | 9 | 10 | 8 | 9 | NULL | NULL |'+sLineBreak - +'+------+------+------+--------+--------+--------+--------+--------+--------+' - ), - - ( - Name: 'LAST_VALUE'; - Declaration: '( [ PARTITION BY partition_expression ] [ ORDER BY order_list ] )'; - Category: 'Information Functions'; - Version: SQL_VERSION_ANSI; - Description: 'LAST_VALUE() evaluates all expressions and returns the last.'+sLineBreak - +' '+sLineBreak - +'This is useful together with setting user variables to a'+sLineBreak - +'value with @var:=expr, for example when you want to get data'+sLineBreak - +'of rows updated/deleted without having to do two queries'+sLineBreak - +'against the table.'+sLineBreak - +' '+sLineBreak - +'Since MariaDB 10.2.2, LAST_VALUE can be used as a window'+sLineBreak - +'function.'+sLineBreak - +' '+sLineBreak - +'Returns NULL if no last value exists.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'CREATE TABLE t1 (a int, b int);'+sLineBreak - +'INSERT INTO t1 VALUES(1,10),(2,20);'+sLineBreak - +'DELETE FROM t1 WHERE a=1 AND last_value(@a:=a,@b:=b,1);'+sLineBreak - +'SELECT @a,@b;'+sLineBreak - +' '+sLineBreak - +'+------+------+'+sLineBreak - +'| @a | @b |'+sLineBreak - +'+------+------+'+sLineBreak - +'| 1 | 10 |'+sLineBreak - +'+------+------+'+sLineBreak - +' '+sLineBreak - +'As a window function:'+sLineBreak - +' '+sLineBreak - +'CREATE TABLE t1 ('+sLineBreak - +' pk int primary key,'+sLineBreak - +' a int,'+sLineBreak - +' b int,'+sLineBreak - +' c char(10),'+sLineBreak - +' d decimal(10, 3),'+sLineBreak - +' e real'+sLineBreak - +');'+sLineBreak - +' '+sLineBreak - +'INSERT INTO t1 VALUES'+sLineBreak - +'( 1, 0, 1, ''one'', 0.1, 0.001),'+sLineBreak - +'( 2, 0, 2, ''two'', 0.2, 0.002),'+sLineBreak - +'( 3, 0, 3, ''three'', 0.3, 0.003),'+sLineBreak - +'( 4, 1, 2, ''three'', 0.4, 0.004),'+sLineBreak - +'( 5, 1, 1, ''two'', 0.5, 0.005),'+sLineBreak - +'( 6, 1, 1, ''one'', 0.6, 0.006),'+sLineBreak - +'( 7, 2, NULL, ''n_one'', 0.5, 0.007),'+sLineBreak - +'( 8, 2, 1, ''n_two'', NULL, 0.008),'+sLineBreak - +'( 9, 2, 2, NULL, 0.7, 0.009),'+sLineBreak - +'(10, 2, 0, ''n_four'', 0.8, 0.010),'+sLineBreak - +'(11, 2, 10, NULL, 0.9, NULL);'+sLineBreak - +' '+sLineBreak - +'SELECT pk, FIRST_VALUE(pk) OVER (ORDER BY pk) AS first_asc,'+sLineBreak - +' LAST_VALUE(pk) OVER (ORDER BY pk) AS last_asc,'+sLineBreak - +' FIRST_VALUE(pk) OVER (ORDER BY pk DESC) AS first_desc,'+sLineBreak - +' LAST_VALUE(pk) OVER (ORDER BY pk DESC) AS last_desc'+sLineBreak - +'FROM t1'+sLineBreak - +'ORDER BY pk DESC;'+sLineBreak - +' '+sLineBreak - +'+----+-----------+----------+------------+-----------+'+sLineBreak - +'| pk | first_asc | last_asc | first_desc | last_desc |'+sLineBreak - +'+----+-----------+----------+------------+-----------+'+sLineBreak - +'| 11 | 1 | 11 | 11 | 11 |'+sLineBreak - +'| 10 | 1 | 10 | 11 | 10 |'+sLineBreak - +'| 9 | 1 | 9 | 11 | 9 |'+sLineBreak - +'| 8 | 1 | 8 | 11 | 8 |'+sLineBreak - +'| 7 | 1 | 7 | 11 | 7 |'+sLineBreak - +'| 6 | 1 | 6 | 11 | 6 |'+sLineBreak - +'| 5 | 1 | 5 | 11 | 5 |'+sLineBreak - +'| 4 | 1 | 4 | 11 | 4 |'+sLineBreak - +'| 3 | 1 | 3 | 11 | 3 |'+sLineBreak - +'| 2 | 1 | 2 | 11 | 2 |'+sLineBreak - +'| 1 | 1 | 1 | 11 | 1 |'+sLineBreak - +'+----+-----------+----------+------------+-----------+'+sLineBreak - +' '+sLineBreak - +'CREATE OR REPLACE TABLE t1 (i int);'+sLineBreak - +'INSERT INTO t1 VALUES'+sLineBreak - +'(1),(2),(3),(4),(5),(6),(7),(8),(9),(10);'+sLineBreak - +' '+sLineBreak - +'SELECT i,'+sLineBreak - +' FIRST_VALUE(i) OVER (ORDER BY i ROWS BETWEEN CURRENT ROW'+sLineBreak - +'and 1 FOLLOWING) AS f_1f,'+sLineBreak - +' LAST_VALUE(i) OVER (ORDER BY i ROWS BETWEEN CURRENT ROW and'+sLineBreak - +'1 FOLLOWING) AS l_1f,'+sLineBreak - +' FIRST_VALUE(i) OVER (ORDER BY i ROWS BETWEEN 1 PRECEDING'+sLineBreak - +'AND 1 FOLLOWING) AS f_1p1f,'+sLineBreak - +' LAST_VALUE(i) OVER (ORDER BY i ROWS BETWEEN 1 PRECEDING AND'+sLineBreak - +'1 FOLLOWING) AS f_1p1f,'+sLineBreak - +' FIRST_VALUE(i) OVER (ORDER BY i ROWS BETWEEN 2 PRECEDING'+sLineBreak - +'AND 1 PRECEDING) AS f_2p1p,'+sLineBreak - +' LAST_VALUE(i) OVER (ORDER BY i ROWS BETWEEN 2 PRECEDING AND'+sLineBreak - +'1 PRECEDING) AS f_2p1p,'+sLineBreak - +' FIRST_VALUE(i) OVER (ORDER BY i ROWS BETWEEN 1 FOLLOWING'+sLineBreak - +'AND 2 FOLLOWING) AS f_1f2f,'+sLineBreak - +' LAST_VALUE(i) OVER (ORDER BY i ROWS BETWEEN 1 FOLLOWING AND'+sLineBreak - +'2 FOLLOWING) AS f_1f2f'+sLineBreak - +'FROM t1;'+sLineBreak - +' '+sLineBreak - +'+------+------+------+--------+--------+--------+--------+--------+--------+'+sLineBreak - +'| i | f_1f | l_1f | f_1p1f | f_1p1f | f_2p1p | f_2p1p |'+sLineBreak - +'f_1f2f | f_1f2f |'+sLineBreak - +'+------+------+------+--------+--------+--------+--------+--------+--------+'+sLineBreak - +'| 1 | 1 | 2 | 1 | 2 | NULL | NULL | 2 | 3 |'+sLineBreak - +'| 2 | 2 | 3 | 1 | 3 | 1 | 1 | 3 | 4 |'+sLineBreak - +'| 3 | 3 | 4 | 2 | 4 | 1 | 2 | 4 | 5 |'+sLineBreak - +'| 4 | 4 | 5 | 3 | 5 | 2 | 3 | 5 | 6 |'+sLineBreak - +'| 5 | 5 | 6 | 4 | 6 | 3 | 4 | 6 | 7 |'+sLineBreak - +'| 6 | 6 | 7 | 5 | 7 | 4 | 5 | 7 | 8 |'+sLineBreak - +'| 7 | 7 | 8 | 6 | 8 | 5 | 6 | 8 | 9 |'+sLineBreak - +'| 8 | 8 | 9 | 7 | 9 | 6 | 7 | 9 | 10 |'+sLineBreak - +'| 9 | 9 | 10 | 8 | 10 | 7 | 8 | 10 | 10 |'+sLineBreak - +'| 10 | 10 | 10 | 9 | 10 | 8 | 9 | NULL | NULL |'+sLineBreak - +'+------+------+------+--------+--------+--------+--------+--------+--------+' - ), - - ( - Name: 'ROW_COUNT'; - Declaration: '()'; - Category: 'Information Functions'; - Version: SQL_VERSION_ANSI; - Description: 'ROW_COUNT() returns the number of rows updated, inserted or'+sLineBreak - +'deleted'+sLineBreak - +'by the preceding statement. This is the same as the row'+sLineBreak - +'count that the'+sLineBreak - +'mysql client displays and the value from the'+sLineBreak - +'mysql_affected_rows() C'+sLineBreak - +'API function.'+sLineBreak - +' '+sLineBreak - +'Generally:'+sLineBreak - +'For statements which return a result set (such as SELECT,'+sLineBreak - +'SHOW, DESC or HELP), returns -1, even when the result set is'+sLineBreak - +'empty. This is also true for administrative statements, such'+sLineBreak - +'as OPTIMIZE.'+sLineBreak - +'For DML statements other than SELECT and for ALTER TABLE,'+sLineBreak - +'returns the number of affected rows.'+sLineBreak - +'For DDL statements (including TRUNCATE) and for other'+sLineBreak - +'statements which don''t return any result set (such as USE,'+sLineBreak - +'DO, SIGNAL or DEALLOCATE PREPARE), returns 0.'+sLineBreak - +' '+sLineBreak - +'For UPDATE, affected rows is by default the number of rows'+sLineBreak - +'that were actually changed. If the CLIENT_FOUND_ROWS flag to'+sLineBreak - +'mysql_real_connect() is specified when connecting to mysqld,'+sLineBreak - +'affected rows is instead the number of rows matched by the'+sLineBreak - +'WHERE clause. '+sLineBreak - +' '+sLineBreak - +'For REPLACE, deleted rows are also counted. So, if REPLACE'+sLineBreak - +'deletes a row and adds a new row, ROW_COUNT() returns 2.'+sLineBreak - +' '+sLineBreak - +'For INSERT ... ON DUPLICATE KEY, updated rows are counted'+sLineBreak - +'twice. So, if INSERT adds a new rows and modifies another'+sLineBreak - +'row, ROW_COUNT() returns 3.'+sLineBreak - +' '+sLineBreak - +'ROW_COUNT() does not take into account rows that are not'+sLineBreak - +'directly deleted/updated by the last statement. This means'+sLineBreak - +'that rows deleted by foreign keys or triggers are not'+sLineBreak - +'counted.'+sLineBreak - +' '+sLineBreak - +'Warning: You can use ROW_COUNT() with prepared statements,'+sLineBreak - +'but you need to call it after EXECUTE, not after DEALLOCATE'+sLineBreak - +'PREPARE, because the row count for allocate prepare is'+sLineBreak - +'always 0.'+sLineBreak - +' '+sLineBreak - +'Warning: When used after a CALL statement, this function'+sLineBreak - +'returns the number of rows affected by the last statement in'+sLineBreak - +'the procedure, not by the whole procedure.'+sLineBreak - +' '+sLineBreak - +'Warning: After INSERT DELAYED, ROW_COUNT() returns the'+sLineBreak - +'number of the rows you tried to insert, not the number of'+sLineBreak - +'the successful writes.'+sLineBreak - +' '+sLineBreak - +'This information can also be found in the diagnostics area.'+sLineBreak - +' '+sLineBreak - +'Statements using the ROW_COUNT() function are not safe for'+sLineBreak - +'replication.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'CREATE TABLE t (A INT);'+sLineBreak - +' '+sLineBreak - +'INSERT INTO t VALUES(1),(2),(3);'+sLineBreak - +' '+sLineBreak - +'SELECT ROW_COUNT();'+sLineBreak - +'+-------------+'+sLineBreak - +'| ROW_COUNT() |'+sLineBreak - +'+-------------+'+sLineBreak - +'| 3 |'+sLineBreak - +'+-------------+'+sLineBreak - +' '+sLineBreak - +'DELETE FROM t WHERE A IN(1,2);'+sLineBreak - +' '+sLineBreak - +'SELECT ROW_COUNT(); '+sLineBreak - +'+-------------+'+sLineBreak - +'| ROW_COUNT() |'+sLineBreak - +'+-------------+'+sLineBreak - +'| 2 |'+sLineBreak - +'+-------------+'+sLineBreak - +' '+sLineBreak - +'Example with prepared statements:'+sLineBreak - +' '+sLineBreak - +'SET @q = ''INSERT INTO t VALUES(1),(2),(3);'';'+sLineBreak - +' '+sLineBreak - +'PREPARE stmt FROM @q;'+sLineBreak - +' '+sLineBreak - +'EXECUTE stmt;'+sLineBreak - +' '+sLineBreak - +'Query OK, 3 rows affected (0.39 sec)'+sLineBreak - +'Records: 3 Duplicates: 0 Warnings: 0'+sLineBreak - +' '+sLineBreak - +'SELECT ROW_COUNT();'+sLineBreak - +'+-------------+'+sLineBreak - +'| ROW_COUNT() |'+sLineBreak - +'+-------------+'+sLineBreak - +'| 3 |'+sLineBreak - +'+-------------+' - ), - - ( - Name: 'SCHEMA'; - Declaration: '()'; - Category: 'Information Functions'; - Version: SQL_VERSION_ANSI; - Description: 'This function is a synonym for DATABASE().' - ), - - ( - Name: 'SESSION_USER'; - Declaration: '()'; - Category: 'Information Functions'; - Version: SQL_VERSION_ANSI; - Description: 'SESSION_USER() is a synonym for USER().' - ), - - ( - Name: 'SYSTEM_USER'; - Declaration: '()'; - Category: 'Information Functions'; - Version: SQL_VERSION_ANSI; - Description: 'SYSTEM_USER() is a synonym for USER().' - ), - - ( - Name: 'USER'; - Declaration: '()'; - Category: 'Information Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the current MariaDB user name and host name, given'+sLineBreak - +'when authenticating to MariaDB, as a string in the utf8'+sLineBreak - +'character set.'+sLineBreak - +' '+sLineBreak - +'Note that the value of USER() may differ from the value of'+sLineBreak - +'CURRENT_USER(), which is the user used to authenticate the'+sLineBreak - +'current client. '+sLineBreak - +'CURRENT_ROLE() returns the current active role.'+sLineBreak - +' '+sLineBreak - +'SYSTEM_USER() and SESSION_USER are synonyms for USER().'+sLineBreak - +' '+sLineBreak - +'Statements using the USER() function or one of its synonyms'+sLineBreak - +'are not safe for statement level replication.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'shell> mysql --user="anonymous"'+sLineBreak - +' '+sLineBreak - +'MariaDB [(none)]> select user(),current_user();'+sLineBreak - +'+---------------------+----------------+'+sLineBreak - +'| user() | current_user() |'+sLineBreak - +'+---------------------+----------------+'+sLineBreak - +'| anonymous@localhost | @localhost |'+sLineBreak - +'+---------------------+----------------+' - ), - - ( - Name: 'VERSION'; - Declaration: '()'; - Category: 'Information Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns a string that indicates the MariaDB server version.'+sLineBreak - +'The string'+sLineBreak - +'uses the utf8 character set.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT VERSION();'+sLineBreak - +'+------------------------------+'+sLineBreak - +'| VERSION() |'+sLineBreak - +'+------------------------------+'+sLineBreak - +'| 10.0.3-MariaDB-1~precise-log |'+sLineBreak - +'+------------------------------+'+sLineBreak - +' '+sLineBreak - +'The VERSION() string may have one or more of the following'+sLineBreak - +'suffixes:'+sLineBreak - +' '+sLineBreak - +'Suffix | Description | '+sLineBreak - +' '+sLineBreak - +'-embedded | The server is an embedded server (libmysqld). | '+sLineBreak - +' '+sLineBreak - +'-log | General logging, slow logging or binary (replication)'+sLineBreak - +'logging is enabled. | '+sLineBreak - +' '+sLineBreak - +'-debug | The server is compiled for debugging. | '+sLineBreak - +' '+sLineBreak - +'-valgrind | The server is compiled to be instrumented with'+sLineBreak - +'valgrind. | '+sLineBreak - +' '+sLineBreak - +'Changing the Version String'+sLineBreak - +' '+sLineBreak - +'Some old legacy code may break because they are parsing the'+sLineBreak - +'VERSION string and expecting a MySQL string or a simple'+sLineBreak - +'version'+sLineBreak - +'string like Joomla til API17, see MDEV-7780.'+sLineBreak - +' '+sLineBreak - +'In MariaDB 10.2 one can fool these applications by setting'+sLineBreak - +'the version string from the command line or the my.cnf files'+sLineBreak - +'with --version=....' - ), - - ( - Name: 'JSON_ARRAY'; - Declaration: '([value[, value2] ...])'; - Category: 'JSON Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns a JSON array containing the listed values. The list'+sLineBreak - +'can be empty.'+sLineBreak - +' '+sLineBreak - +'Example'+sLineBreak - +' '+sLineBreak - +'SELECT Json_Array(56, 3.1416, ''My name is "Foo"'', NULL);'+sLineBreak - +'+--------------------------------------------------+'+sLineBreak - +'| Json_Array(56, 3.1416, ''My name is "Foo"'', NULL) |'+sLineBreak - +'+--------------------------------------------------+'+sLineBreak - +'| [56, 3.1416, "My name is \"Foo\"", null] |'+sLineBreak - +'+--------------------------------------------------+' - ), - - ( - Name: 'JSON_ARRAY_APPEND'; - Declaration: '(json_doc, path, value[, path, value] ...)'; - Category: 'JSON Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Appends values to the end of the specified arrays within a'+sLineBreak - +'JSON document, returning the result, or NULL if any of the'+sLineBreak - +'arguments are NULL.'+sLineBreak - +' '+sLineBreak - +'Evaluation is performed from left to right, with the'+sLineBreak - +'resulting document from the previous pair becoming the new'+sLineBreak - +'value against which the next pair is evaluated.'+sLineBreak - +' '+sLineBreak - +'If the json_doc is not a valid JSON document, or if any of'+sLineBreak - +'the paths are not valid, or contain a * or ** wildcard, an'+sLineBreak - +'error is returned.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SET @json = ''[1, 2, [3, 4]]'';'+sLineBreak - +' '+sLineBreak - +'SELECT JSON_ARRAY_APPEND(@json, ''$[0]'', 5)'+sLineBreak - +'+-------------------------------------+'+sLineBreak - +'| JSON_ARRAY_APPEND(@json, ''$[0]'', 5) |'+sLineBreak - +'+-------------------------------------+'+sLineBreak - +'| [[1, 5], 2, [3, 4]] |'+sLineBreak - +'+-------------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT JSON_ARRAY_APPEND(@json, ''$[1]'', 6);'+sLineBreak - +'+-------------------------------------+'+sLineBreak - +'| JSON_ARRAY_APPEND(@json, ''$[1]'', 6) |'+sLineBreak - +'+-------------------------------------+'+sLineBreak - +'| [1, [2, 6], [3, 4]] |'+sLineBreak - +'+-------------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT JSON_ARRAY_APPEND(@json, ''$[1]'', 6, ''$[2]'', 7);'+sLineBreak - +'+------------------------------------------------+'+sLineBreak - +'| JSON_ARRAY_APPEND(@json, ''$[1]'', 6, ''$[2]'', 7) |'+sLineBreak - +'+------------------------------------------------+'+sLineBreak - +'| [1, [2, 6], [3, 4, 7]] |'+sLineBreak - +'+------------------------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT JSON_ARRAY_APPEND(@json, ''$'', 5);'+sLineBreak - +'+----------------------------------+'+sLineBreak - +'| JSON_ARRAY_APPEND(@json, ''$'', 5) |'+sLineBreak - +'+----------------------------------+'+sLineBreak - +'| [1, 2, [3, 4], 5] |'+sLineBreak - +'+----------------------------------+'+sLineBreak - +' '+sLineBreak - +'SET @json = ''{"A": 1, "B": [2], "C": [3, 4]}'';'+sLineBreak - +' '+sLineBreak - +'SELECT JSON_ARRAY_APPEND(@json, ''$.B'', 5);'+sLineBreak - +'+------------------------------------+'+sLineBreak - +'| JSON_ARRAY_APPEND(@json, ''$.B'', 5) |'+sLineBreak - +'+------------------------------------+'+sLineBreak - +'| {"A": 1, "B": [2, 5], "C": [3, 4]} |'+sLineBreak - +'+------------------------------------+' - ), - - ( - Name: 'JSON_ARRAY_INSERT'; - Declaration: '(json_doc, path, value[, path, value] ...)'; - Category: 'JSON Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Inserts a value into a JSON document, returning the modified'+sLineBreak - +'document, or NULL if any of the arguments are NULL.'+sLineBreak - +' '+sLineBreak - +'Evaluation is performed from left to right, with the'+sLineBreak - +'resulting document from the previous pair becoming the new'+sLineBreak - +'value against which the next pair is evaluated.'+sLineBreak - +' '+sLineBreak - +'If the json_doc is not a valid JSON document, or if any of'+sLineBreak - +'the paths are not valid, or contain a * or ** wildcard, an'+sLineBreak - +'error is returned.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SET @json = ''[1, 2, [3, 4]]'';'+sLineBreak - +' '+sLineBreak - +'SELECT JSON_ARRAY_INSERT(@json, ''$[0]'', 5);'+sLineBreak - +'+-------------------------------------+'+sLineBreak - +'| JSON_ARRAY_INSERT(@json, ''$[0]'', 5) |'+sLineBreak - +'+-------------------------------------+'+sLineBreak - +'| [5, 1, 2, [3, 4]] |'+sLineBreak - +'+-------------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT JSON_ARRAY_INSERT(@json, ''$[1]'', 6);'+sLineBreak - +'+-------------------------------------+'+sLineBreak - +'| JSON_ARRAY_INSERT(@json, ''$[1]'', 6) |'+sLineBreak - +'+-------------------------------------+'+sLineBreak - +'| [1, 6, 2, [3, 4]] |'+sLineBreak - +'+-------------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT JSON_ARRAY_INSERT(@json, ''$[1]'', 6, ''$[2]'', 7);'+sLineBreak - +'+------------------------------------------------+'+sLineBreak - +'| JSON_ARRAY_INSERT(@json, ''$[1]'', 6, ''$[2]'', 7) |'+sLineBreak - +'+------------------------------------------------+'+sLineBreak - +'| [1, 6, 7, 2, [3, 4]] |'+sLineBreak - +'+------------------------------------------------+' - ), - - ( - Name: 'JSON_COMPACT'; - Declaration: '(json_doc)'; - Category: 'JSON Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Removes all unnecessary spaces so the json document is as'+sLineBreak - +'short as possible.'+sLineBreak - +' '+sLineBreak - +'Example'+sLineBreak - +' '+sLineBreak - +'SET @j = ''{ "A": 1, "B": [2, 3]}'';'+sLineBreak - +' '+sLineBreak - +'SELECT JSON_COMPACT(@j), @j;'+sLineBreak - +'+-------------------+------------------------+'+sLineBreak - +'| JSON_COMPACT(@j) | @j |'+sLineBreak - +'+-------------------+------------------------+'+sLineBreak - +'| {"A":1,"B":[2,3]} | { "A": 1, "B": [2, 3]} |'+sLineBreak - +'+-------------------+------------------------+' - ), - - ( - Name: 'JSON_CONTAINS'; - Declaration: '(json_doc, val[, path])'; - Category: 'JSON Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns whether or not the specified value is found in the'+sLineBreak - +'given JSON document or, optionally, at the specified path'+sLineBreak - +'within the document. Returns 1 if it does, 0 if not and NULL'+sLineBreak - +'if any of the arguments are null. An error occurs if the'+sLineBreak - +'document or path is not valid, or contains the * or **'+sLineBreak - +'wildcards.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SET @json = ''{"A": 0, "B": {"C": 1}, "D": 2}'';'+sLineBreak - +' '+sLineBreak - +'SELECT JSON_CONTAINS(@json, ''2'', ''$.A'');'+sLineBreak - +'+----------------------------------+'+sLineBreak - +'| JSON_CONTAINS(@json, ''2'', ''$.A'') |'+sLineBreak - +'+----------------------------------+'+sLineBreak - +'| 0 |'+sLineBreak - +'+----------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT JSON_CONTAINS(@json, ''2'', ''$.D'');'+sLineBreak - +'+----------------------------------+'+sLineBreak - +'| JSON_CONTAINS(@json, ''2'', ''$.D'') |'+sLineBreak - +'+----------------------------------+'+sLineBreak - +'| 1 |'+sLineBreak - +'+----------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT JSON_CONTAINS(@json, ''{"C": 1}'', ''$.A'');'+sLineBreak - +'+-----------------------------------------+'+sLineBreak - +'| JSON_CONTAINS(@json, ''{"C": 1}'', ''$.A'') |'+sLineBreak - +'+-----------------------------------------+'+sLineBreak - +'| 0 |'+sLineBreak - +'+-----------------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT JSON_CONTAINS(@json, ''{"C": 1}'', ''$.B'');'+sLineBreak - +'+-----------------------------------------+'+sLineBreak - +'| JSON_CONTAINS(@json, ''{"C": 1}'', ''$.B'') |'+sLineBreak - +'+-----------------------------------------+'+sLineBreak - +'| 1 |'+sLineBreak - +'+-----------------------------------------+' - ), - - ( - Name: 'JSON_CONTAINS_PATH'; - Declaration: '(json_doc, return_arg, path[, path] ...)'; - Category: 'JSON Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Indicates whether the given JSON document contains data at'+sLineBreak - +'the specified path or paths. Returns 1 if it does, 0 if not'+sLineBreak - +'and NULL if any of the arguments are null.'+sLineBreak - +' '+sLineBreak - +'The return_arg can be one or all:'+sLineBreak - +'one - Returns 1 if at least one path exists within the JSON'+sLineBreak - +'document. '+sLineBreak - +'all - Returns 1 only if all paths exist within the JSON'+sLineBreak - +'document.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SET @json = ''{"A": 1, "B": [2], "C": [3, 4]}'';'+sLineBreak - +' '+sLineBreak - +'SELECT JSON_CONTAINS_PATH(@json, ''one'', ''$.A'', ''$.D'');'+sLineBreak - +'+------------------------------------------------+'+sLineBreak - +'| JSON_CONTAINS_PATH(@json, ''one'', ''$.A'', ''$.D'') |'+sLineBreak - +'+------------------------------------------------+'+sLineBreak - +'| 1 |'+sLineBreak - +'+------------------------------------------------+'+sLineBreak - +'1 row in set (0.00 sec)'+sLineBreak - +' '+sLineBreak - +'SELECT JSON_CONTAINS_PATH(@json, ''all'', ''$.A'', ''$.D'');'+sLineBreak - +'+------------------------------------------------+'+sLineBreak - +'| JSON_CONTAINS_PATH(@json, ''all'', ''$.A'', ''$.D'') |'+sLineBreak - +'+------------------------------------------------+'+sLineBreak - +'| 0 |'+sLineBreak - +'+------------------------------------------------+' - ), - - ( - Name: 'JSON_DEPTH'; - Declaration: '(json_doc)'; - Category: 'JSON Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the maximum depth of the given JSON document, or'+sLineBreak - +'NULL if the argument is null. An error will occur if the'+sLineBreak - +'argument is an invalid JSON document.'+sLineBreak - +'Scalar values or empty arrays or objects have a depth of 1.'+sLineBreak - +'Arrays or objects that are not empty but contain only'+sLineBreak - +'elements or member values of depth 1 will have a depth of 2.'+sLineBreak - +'In other cases, the depth will be greater than 2.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT JSON_DEPTH(''[]''), JSON_DEPTH(''true''),'+sLineBreak - +'JSON_DEPTH(''{}'');'+sLineBreak - +'+------------------+--------------------+------------------+'+sLineBreak - +'| JSON_DEPTH(''[]'') | JSON_DEPTH(''true'') |'+sLineBreak - +'JSON_DEPTH(''{}'') |'+sLineBreak - +'+------------------+--------------------+------------------+'+sLineBreak - +'| 1 | 1 | 1 |'+sLineBreak - +'+------------------+--------------------+------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT JSON_DEPTH(''[1, 2, 3]''), JSON_DEPTH(''[[], {},'+sLineBreak - +'[]]'');'+sLineBreak - +'+-------------------------+----------------------------+'+sLineBreak - +'| JSON_DEPTH(''[1, 2, 3]'') | JSON_DEPTH(''[[], {}, []]'') |'+sLineBreak - +'+-------------------------+----------------------------+'+sLineBreak - +'| 2 | 2 |'+sLineBreak - +'+-------------------------+----------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT JSON_DEPTH(''[1, 2, [3, 4, 5, 6], 7]'');'+sLineBreak - +'+---------------------------------------+'+sLineBreak - +'| JSON_DEPTH(''[1, 2, [3, 4, 5, 6], 7]'') |'+sLineBreak - +'+---------------------------------------+'+sLineBreak - +'| 3 |'+sLineBreak - +'+---------------------------------------+' - ), - - ( - Name: 'JSON_DETAILED'; - Declaration: '(json_doc[, tab_size])'; - Category: 'JSON Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Represents JSON in the most understandable way emphasizing'+sLineBreak - +'nested structures.'+sLineBreak - +' '+sLineBreak - +'Example'+sLineBreak - +' '+sLineBreak - +'SET @j = ''{ "A":1,"B":[2,3]}'';'+sLineBreak - +' '+sLineBreak - +'SELECT @j;'+sLineBreak - +'+--------------------+'+sLineBreak - +'| @j |'+sLineBreak - +'+--------------------+'+sLineBreak - +'| { "A":1,"B":[2,3]} |'+sLineBreak - +'+--------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT JSON_DETAILED(@j);'+sLineBreak - +'+------------------------------------------------------------+'+sLineBreak - +'| JSON_DETAILED(@j) |'+sLineBreak - +'+------------------------------------------------------------+'+sLineBreak - +'| {'+sLineBreak - +' "A": 1,'+sLineBreak - +' "B": '+sLineBreak - +' ['+sLineBreak - +' 2,'+sLineBreak - +' 3'+sLineBreak - +' ]'+sLineBreak - +'} |'+sLineBreak - +'+------------------------------------------------------------+' - ), - - ( - Name: 'JSON_EXTRACT'; - Declaration: '(json_doc, path[, path] ...)'; - Category: 'JSON Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Extracts data from a JSON document. The extracted data is'+sLineBreak - +'selected from the parts matching the path arguments. Returns'+sLineBreak - +'all matched values; either as a single matched value, or, if'+sLineBreak - +'the arguments could return multiple values, a result'+sLineBreak - +'autowrapped as an array in the matching order.'+sLineBreak - +' '+sLineBreak - +'Returns NULL if no paths match or if any of the arguments'+sLineBreak - +'are NULL. '+sLineBreak - +' '+sLineBreak - +'An error will occur if any path argument is not a valid'+sLineBreak - +'path, or if the json_doc argument is not a valid JSON'+sLineBreak - +'document.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SET @json = ''[1, 2, [3, 4]]'';'+sLineBreak - +' '+sLineBreak - +'SELECT JSON_EXTRACT(@json, ''$[1]'');'+sLineBreak - +'+-----------------------------+'+sLineBreak - +'| JSON_EXTRACT(@json, ''$[1]'') |'+sLineBreak - +'+-----------------------------+'+sLineBreak - +'| 2 |'+sLineBreak - +'+-----------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT JSON_EXTRACT(@json, ''$[2]'');'+sLineBreak - +'+-----------------------------+'+sLineBreak - +'| JSON_EXTRACT(@json, ''$[2]'') |'+sLineBreak - +'+-----------------------------+'+sLineBreak - +'| [3, 4] |'+sLineBreak - +'+-----------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT JSON_EXTRACT(@json, ''$[2][1]'');'+sLineBreak - +'+--------------------------------+'+sLineBreak - +'| JSON_EXTRACT(@json, ''$[2][1]'') |'+sLineBreak - +'+--------------------------------+'+sLineBreak - +'| 4 |'+sLineBreak - +'+--------------------------------+' - ), - - ( - Name: 'JSON_INSERT'; - Declaration: '(json_doc, path, val[, path, val] ...)'; - Category: 'JSON Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Inserts data into a JSON document, returning the resulting'+sLineBreak - +'document or NULL if any argument is null. '+sLineBreak - +' '+sLineBreak - +'An error will occur if the JSON document is not invalid, or'+sLineBreak - +'if any of the paths are invalid or contain a * or **'+sLineBreak - +'wildcard.'+sLineBreak - +' '+sLineBreak - +'JSON_INSERT can only insert data while JSON_REPLACE can only'+sLineBreak - +'update. JSON_SET can update or insert data. '+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SET @json = ''{ "A": 0, "B": [1, 2]}'';'+sLineBreak - +' '+sLineBreak - +'SELECT JSON_INSERT(@json, ''$.C'', ''[3, 4]'');'+sLineBreak - +'+--------------------------------------+'+sLineBreak - +'| JSON_INSERT(@json, ''$.C'', ''[3, 4]'') |'+sLineBreak - +'+--------------------------------------+'+sLineBreak - +'| { "A": 0, "B": [1, 2], "C":"[3, 4]"} |'+sLineBreak - +'+--------------------------------------+' - ), - - ( - Name: 'JSON_KEYS'; - Declaration: '(json_doc[, path])'; - Category: 'JSON Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the keys as a JSON array from the top-level value of'+sLineBreak - +'a JSON object or, if the optional path argument is provided,'+sLineBreak - +'the top-level keys from the path. '+sLineBreak - +' '+sLineBreak - +'Excludes keys from nested sub-objects in the top level'+sLineBreak - +'value. The resulting array will be empty if the selected'+sLineBreak - +'object is empty.'+sLineBreak - +' '+sLineBreak - +'Returns NULL if any of the arguments are null, a given path'+sLineBreak - +'does not locate an object, or if the json_doc argument is'+sLineBreak - +'not an object.'+sLineBreak - +' '+sLineBreak - +'An error will occur if JSON document is invalid, the path is'+sLineBreak - +'invalid or if the path contains a * or ** wildcard.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT JSON_KEYS(''{"A": 1, "B": {"C": 2}}'');'+sLineBreak - +'+--------------------------------------+'+sLineBreak - +'| JSON_KEYS(''{"A": 1, "B": {"C": 2}}'') |'+sLineBreak - +'+--------------------------------------+'+sLineBreak - +'| ["A", "B"] |'+sLineBreak - +'+--------------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT JSON_KEYS(''{"A": 1, "B": 2, "C": {"D":'+sLineBreak - +'3}}'', ''$.C'');'+sLineBreak - +'+-----------------------------------------------------+'+sLineBreak - +'| JSON_KEYS(''{"A": 1, "B": 2, "C": {"D": 3}}'','+sLineBreak - +'''$.C'') |'+sLineBreak - +'+-----------------------------------------------------+'+sLineBreak - +'| ["D"] |'+sLineBreak - +'+-----------------------------------------------------+' - ), - - ( - Name: 'JSON_LENGTH'; - Declaration: '(json_doc[, path])'; - Category: 'JSON Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the length of a JSON document, or, if the optional'+sLineBreak - +'path argument is given, the length of the value within the'+sLineBreak - +'document specified by the path. '+sLineBreak - +' '+sLineBreak - +'Returns NULL if any of the arguments argument are null or'+sLineBreak - +'the path argument does not identify a value in the document.'+sLineBreak - +''+sLineBreak - +' '+sLineBreak - +'An error will occur if the JSON document is invalid, the'+sLineBreak - +'path is invalid or if the path contains a * or ** wildcard.'+sLineBreak - +' '+sLineBreak - +'Length will be determined as follow:'+sLineBreak - +'A scalar''s length is always 1.'+sLineBreak - +'If an array, the number of elements in the array.'+sLineBreak - +'If an object, the number of members in the object.'+sLineBreak - +' '+sLineBreak - +'The length of nested arrays or objects are not counted.' - ), - - ( - Name: 'JSON_LOOSE'; - Declaration: '(json_doc)'; - Category: 'JSON Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Adds spaces to a JSON document to make it look more'+sLineBreak - +'readable.'+sLineBreak - +' '+sLineBreak - +'Example'+sLineBreak - +' '+sLineBreak - +'SET @j = ''{ "A":1,"B":[2,3]}'';'+sLineBreak - +' '+sLineBreak - +'SELECT JSON_LOOSE(@j), @j;'+sLineBreak - +'+-----------------------+--------------------+'+sLineBreak - +'| JSON_LOOSE(@j) | @j |'+sLineBreak - +'+-----------------------+--------------------+'+sLineBreak - +'| {"A": 1, "B": [2, 3]} | { "A":1,"B":[2,3]} |'+sLineBreak - +'+-----------------------+--------------------+' - ), - - ( - Name: 'JSON_MERGE'; - Declaration: '(json_doc, json_doc[, json_doc] ...)'; - Category: 'JSON Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Merges the given JSON documents.'+sLineBreak - +' '+sLineBreak - +'Returns the merged result,or NULL if any argument is NULL.'+sLineBreak - +' '+sLineBreak - +'An error occurs if any of the arguments are not valid JSON'+sLineBreak - +'documents.'+sLineBreak - +' '+sLineBreak - +'Example'+sLineBreak - +' '+sLineBreak - +'SET @json1 = ''[1, 2]'';'+sLineBreak - +' '+sLineBreak - +'SET @json2 = ''[3, 4]'';'+sLineBreak - +' '+sLineBreak - +'SELECT JSON_MERGE(@json1,@json2);'+sLineBreak - +'+---------------------------+'+sLineBreak - +'| JSON_MERGE(@json1,@json2) |'+sLineBreak - +'+---------------------------+'+sLineBreak - +'| [1, 2, 3, 4] |'+sLineBreak - +'+---------------------------+' - ), - - ( - Name: 'JSON_OBJECT'; - Declaration: '([key, value[, key, value] ...])'; - Category: 'JSON Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns a JSON object containing the given key/value pairs.'+sLineBreak - +'The key/value list can be empty.'+sLineBreak - +' '+sLineBreak - +'An error will occur if there are an odd number of arguments,'+sLineBreak - +'or any key name is NULL.'+sLineBreak - +' '+sLineBreak - +'Example'+sLineBreak - +' '+sLineBreak - +'SELECT JSON_OBJECT("id", 1, "name", "Monty");'+sLineBreak - +'+---------------------------------------+'+sLineBreak - +'| JSON_OBJECT("id", 1, "name", "Monty") |'+sLineBreak - +'+---------------------------------------+'+sLineBreak - +'| {"id": 1, "name": "Monty"} |'+sLineBreak - +'+---------------------------------------+' - ), - - ( - Name: 'JSON_QUERY'; - Declaration: '(json_doc, path)'; - Category: 'JSON Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Given a JSON document, returns an object or array specified'+sLineBreak - +'by the path. Returns NULL if not given a valid JSON'+sLineBreak - +'document, or if there is no match.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'select json_query(''{"key1":{"a":1, "b":[1,2]}}'','+sLineBreak - +'''$.key1'');'+sLineBreak - +'+-----------------------------------------------------+'+sLineBreak - +'| json_query(''{"key1":{"a":1, "b":[1,2]}}'','+sLineBreak - +'''$.key1'') |'+sLineBreak - +'+-----------------------------------------------------+'+sLineBreak - +'| {"a":1, "b":[1,2]} |'+sLineBreak - +'+-----------------------------------------------------+'+sLineBreak - +' '+sLineBreak - +'select json_query(''{"key1":123, "key1": [1,2,3]}'','+sLineBreak - +'''$.key1'');'+sLineBreak - +'+-------------------------------------------------------+'+sLineBreak - +'| json_query(''{"key1":123, "key1": [1,2,3]}'','+sLineBreak - +'''$.key1'') |'+sLineBreak - +'+-------------------------------------------------------+'+sLineBreak - +'| [1,2,3] |'+sLineBreak - +'+-------------------------------------------------------+' - ), - - ( - Name: 'JSON_QUOTE'; - Declaration: '(json_value)'; - Category: 'JSON Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Quotes a string as a JSON value, usually for producing valid'+sLineBreak - +'JSON string literals for inclusion in JSON documents. Wraps'+sLineBreak - +'the string with double quote characters and escapes interior'+sLineBreak - +'quotes and other special characters, returning a utf8mb4'+sLineBreak - +'string. '+sLineBreak - +' '+sLineBreak - +'Returns NULL if the argument is NULL.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT JSON_QUOTE(''A''), JSON_QUOTE("B"),'+sLineBreak - +'JSON_QUOTE(''"C"'');'+sLineBreak - +'+-----------------+-----------------+-------------------+'+sLineBreak - +'| JSON_QUOTE(''A'') | JSON_QUOTE("B") |'+sLineBreak - +'JSON_QUOTE(''"C"'') |'+sLineBreak - +'+-----------------+-----------------+-------------------+'+sLineBreak - +'| "A" | "B" | "\"C\"" |'+sLineBreak - +'+-----------------+-----------------+-------------------+' - ), - - ( - Name: 'JSON_REMOVE'; - Declaration: '(json_doc, path[, path] ...)'; - Category: 'JSON Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Removes data from a JSON document returning the result, or'+sLineBreak - +'NULL if any of the arguments are null. If the element does'+sLineBreak - +'not exist in the document, no changes are made.'+sLineBreak - +' '+sLineBreak - +'An error will occur if JSON document is invalid, the path is'+sLineBreak - +'invalid or if the path contains a * or ** wildcard.'+sLineBreak - +' '+sLineBreak - +'Path arguments are evaluated from left to right, with the'+sLineBreak - +'result from the earlier evaluation being used as the value'+sLineBreak - +'for the next.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT JSON_REMOVE(''{"A": 1, "B": 2, "C": {"D":'+sLineBreak - +'3}}'', ''$.C'');'+sLineBreak - +'+-------------------------------------------------------+'+sLineBreak - +'| JSON_REMOVE(''{"A": 1, "B": 2, "C": {"D": 3}}'','+sLineBreak - +'''$.C'') |'+sLineBreak - +'+-------------------------------------------------------+'+sLineBreak - +'| {"A": 1, "B": 2} |'+sLineBreak - +'+-------------------------------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT JSON_REMOVE(''["A", "B", ["C", "D"],'+sLineBreak - +'"E"]'', ''$[1]'');'+sLineBreak - +'+----------------------------------------------------+'+sLineBreak - +'| JSON_REMOVE(''["A", "B", ["C", "D"], "E"]'','+sLineBreak - +'''$[1]'') |'+sLineBreak - +'+----------------------------------------------------+'+sLineBreak - +'| ["A", ["C", "D"], "E"] |'+sLineBreak - +'+----------------------------------------------------+' - ), - - ( - Name: 'JSON_REPLACE'; - Declaration: '(json_doc, path, val[, path, val] ...)'; - Category: 'JSON Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Replaces existing values in a JSON document, returning the'+sLineBreak - +'result, or NULL if any of the arguments are NULL. '+sLineBreak - +' '+sLineBreak - +'An error will occur if the JSON document is invalid, the'+sLineBreak - +'path is invalid or if the path contains a * or ** wildcard.'+sLineBreak - +' '+sLineBreak - +'Paths and values are evaluated from left to right, with the'+sLineBreak - +'result from the earlier evaluation being used as the value'+sLineBreak - +'for the next.'+sLineBreak - +' '+sLineBreak - +'JSON_REPLACE can only update data, while JSON_INSERT can'+sLineBreak - +'only insert. JSON_SET can update or insert data. '+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT JSON_REPLACE(''{ "A": 1, "B": [2, 3]}'','+sLineBreak - +'''$.B[1]'', 4);'+sLineBreak - +'+-----------------------------------------------------+'+sLineBreak - +'| JSON_REPLACE(''{ "A": 1, "B": [2, 3]}'', ''$.B[1]'','+sLineBreak - +'4) |'+sLineBreak - +'+-----------------------------------------------------+'+sLineBreak - +'| { "A": 1, "B": [2, 4]} |'+sLineBreak - +'+-----------------------------------------------------+' - ), - - ( - Name: 'JSON_SEARCH'; - Declaration: '(json_doc, return_arg, search_str[, escape_char[, path] ...])'; - Category: 'JSON Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the path to the given string within a JSON document,'+sLineBreak - +'or NULL if any of json_doc, search_str or a path argument is'+sLineBreak - +'NULL; if the search string is not found, or if no path'+sLineBreak - +'exists within the document. '+sLineBreak - +' '+sLineBreak - +'A warning will occur if the JSON document is not valid, any'+sLineBreak - +'of the path arguments are not valid, if return_arg is'+sLineBreak - +'neither one nor all, or if the escape character is not a'+sLineBreak - +'constant. NULL will be returned.'+sLineBreak - +' '+sLineBreak - +'return_arg can be one of two values:'+sLineBreak - +'''one: Terminates after finding the first match, so will'+sLineBreak - +'return one path string. If there is more than one match, it'+sLineBreak - +'is undefined which is considered first.'+sLineBreak - +'all: Returns all matching path strings, without duplicates.'+sLineBreak - +'Multiple strings are autowrapped as an array. The order is'+sLineBreak - +'undefined.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SET @json = ''["A", [{"B": "1"}], {"C":"AB"},'+sLineBreak - +'{"D":"BC"}]'';'+sLineBreak - +' '+sLineBreak - +'SELECT JSON_SEARCH(@json, ''one'', ''AB'');'+sLineBreak - +'+---------------------------------+'+sLineBreak - +'| JSON_SEARCH(@json, ''one'', ''AB'') |'+sLineBreak - +'+---------------------------------+'+sLineBreak - +'| "$[2].C" |'+sLineBreak - +'+---------------------------------+' - ), - - ( - Name: 'JSON_SET'; - Declaration: '(json_doc, path, val[, path, val] ...)'; - Category: 'JSON Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Updates or inserts data into a JSON document, returning the'+sLineBreak - +'result, or NULL if any of the arguments are NULL or the'+sLineBreak - +'optional path fails to find an object.'+sLineBreak - +' '+sLineBreak - +'An error will occur if the JSON document is invalid, the'+sLineBreak - +'path is invalid or if the path contains a * or wildcard.'+sLineBreak - +' '+sLineBreak - +'JSON_SET can update or insert data, while JSON_REPLACE can'+sLineBreak - +'only update, and JSON_INSERT only insert.' - ), - - ( - Name: 'JSON_TYPE'; - Declaration: '(json_val)'; - Category: 'JSON Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the type of a JSON value, or NULL if the argument is'+sLineBreak - +'null.'+sLineBreak - +' '+sLineBreak - +'An error will occur if the argument is an invalid JSON'+sLineBreak - +'value.'+sLineBreak - +' '+sLineBreak - +'The following is a complete list of the possible return'+sLineBreak - +'types:'+sLineBreak - +' '+sLineBreak - +'Return type | Value | '+sLineBreak - +' '+sLineBreak - +'ARRAY | JSON array | '+sLineBreak - +' '+sLineBreak - +'BIT | MariaDB BIT scalar | '+sLineBreak - +' '+sLineBreak - +'BLOB | MariaDB binary types (BINARY, VARBINARY or BLOB) | '+sLineBreak - +' '+sLineBreak - +'BOOLEAN | JSON true/false literals | '+sLineBreak - +' '+sLineBreak - +'DATE | MariaDB DATE scalar | '+sLineBreak - +' '+sLineBreak - +'DATETIME | MariaDB DATETIME or TIMESTAMP scalar | '+sLineBreak - +' '+sLineBreak - +'DECIMAL | MariaDB DECIMAL or NUMERIC scalar | '+sLineBreak - +' '+sLineBreak - +'DOUBLE | MariaDB DOUBLE FLOAT scalar | '+sLineBreak - +' '+sLineBreak - +'INTEGER | MariaDB integer types (TINYINT, SMALLINT,'+sLineBreak - +'MEDIUMINT, INT or BIGINT) | '+sLineBreak - +' '+sLineBreak - +'NULL | JSON null literal or NULL argument | '+sLineBreak - +' '+sLineBreak - +'OBJECT | JSON object | '+sLineBreak - +' '+sLineBreak - +'OPAQUE | Any valid JSON value that is not one of the other'+sLineBreak - +'types. | '+sLineBreak - +' '+sLineBreak - +'STRING | MariaDB character types (CHAR, VARCHAR, TEXT, ENUM'+sLineBreak - +'or SET) | '+sLineBreak - +' '+sLineBreak - +'TIME | MariaDB TIME scalar | '+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT JSON_TYPE(''{"A": 1, "B": 2, "C": 3}'');'+sLineBreak - +'+---------------------------------------+'+sLineBreak - +'| JSON_TYPE(''{"A": 1, "B": 2, "C": 3}'') |'+sLineBreak - +'+---------------------------------------+'+sLineBreak - +'| OBJECT |'+sLineBreak - +'+---------------------------------------+' - ), - - ( - Name: 'JSON_UNQUOTE'; - Declaration: '(val)'; - Category: 'JSON Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Unquotes a JSON value, returning a string, or NULL if the'+sLineBreak - +'argument is null. '+sLineBreak - +' '+sLineBreak - +'An error will occur if the given value begins and ends with'+sLineBreak - +'double quotes and is an invalid JSON string literal.'+sLineBreak - +' '+sLineBreak - +'Certain character sequences have special meanings within a'+sLineBreak - +'string. Usually, a backspace is ignored, but the escape'+sLineBreak - +'sequences in the table below are recognised by MariaDB,'+sLineBreak - +'unless the SQL Mode is set to NO_BACKSLASH_ESCAPES SQL.'+sLineBreak - +' '+sLineBreak - +'Escape sequence | Character | '+sLineBreak - +' '+sLineBreak - +'\" | Double quote (") | '+sLineBreak - +' '+sLineBreak - +'\b | Backspace | '+sLineBreak - +' '+sLineBreak - +'\f | Formfeed | '+sLineBreak - +' '+sLineBreak - +'\n | Newline (linefeed) | '+sLineBreak - +' '+sLineBreak - +'\r | Carriage return | '+sLineBreak - +' '+sLineBreak - +'\t | Tab | '+sLineBreak - +' '+sLineBreak - +'\\ | Backslash (\) | '+sLineBreak - +' '+sLineBreak - +'\uXXXX | UTF-8 bytes for Unicode value XXXX | '+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT JSON_UNQUOTE(''"Monty"'');'+sLineBreak - +'+-------------------------+'+sLineBreak - +'| JSON_UNQUOTE(''"Monty"'') |'+sLineBreak - +'+-------------------------+'+sLineBreak - +'| Monty |'+sLineBreak - +'+-------------------------+'+sLineBreak - +' '+sLineBreak - +'With the default SQL Mode:'+sLineBreak - +' '+sLineBreak - +'SELECT JSON_UNQUOTE(''Si\bng\ting'');'+sLineBreak - +'+-----------------------------+'+sLineBreak - +'| JSON_UNQUOTE(''Si\bng\ting'') |'+sLineBreak - +'+-----------------------------+'+sLineBreak - +'| Sng ing |'+sLineBreak - +'+-----------------------------+'+sLineBreak - +' '+sLineBreak - +'Setting NO_BACKSLASH_ESCAPES:'+sLineBreak - +' '+sLineBreak - +'SET @@sql_mode = ''NO_BACKSLASH_ESCAPES'';'+sLineBreak - +' '+sLineBreak - +'SELECT JSON_UNQUOTE(''Si\bng\ting'');'+sLineBreak - +'+-----------------------------+'+sLineBreak - +'| JSON_UNQUOTE(''Si\bng\ting'') |'+sLineBreak - +'+-----------------------------+'+sLineBreak - +'| Si\bng\ting |'+sLineBreak - +'+-----------------------------+' - ), - - ( - Name: 'JSON_VALID'; - Declaration: '(value)'; - Category: 'JSON Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Indicates whether the given value is a valid JSON document'+sLineBreak - +'or not. Returns 1 if valid, 0 if not, and NULL if the'+sLineBreak - +'argument is NULL.'+sLineBreak - +' '+sLineBreak - +'From MariaDB 10.4.3, the JSON_VALID function is'+sLineBreak - +'automatically used as a CHECK constraint for the JSON data'+sLineBreak - +'type alias in order to ensure that a valid json document is'+sLineBreak - +'inserted. '+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT JSON_VALID(''{"id": 1, "name": "Monty"}'');'+sLineBreak - +'+------------------------------------------+'+sLineBreak - +'| JSON_VALID(''{"id": 1, "name": "Monty"}'') |'+sLineBreak - +'+------------------------------------------+'+sLineBreak - +'| 1 |'+sLineBreak - +'+------------------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT JSON_VALID(''{"id": 1, "name": "Monty",'+sLineBreak - +'"oddfield"}'');'+sLineBreak - +'+------------------------------------------------------+'+sLineBreak - +'| JSON_VALID(''{"id": 1, "name": "Monty",'+sLineBreak - +'"oddfield"}'') |'+sLineBreak - +'+------------------------------------------------------+'+sLineBreak - +'| 0 |'+sLineBreak - +'+------------------------------------------------------+' - ), - - ( - Name: 'JSON_VALUE'; - Declaration: '(json_doc, path)'; - Category: 'JSON Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Given a JSON document, returns the scalar specified by the'+sLineBreak - +'path. Returns NULL if not given a valid JSON document, or if'+sLineBreak - +'there is no match.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'select json_value(''{"key1":123}'', ''$.key1'');'+sLineBreak - +'+--------------------------------------+'+sLineBreak - +'| json_value(''{"key1":123}'', ''$.key1'') |'+sLineBreak - +'+--------------------------------------+'+sLineBreak - +'| 123 |'+sLineBreak - +'+--------------------------------------+'+sLineBreak - +' '+sLineBreak - +'select json_value(''{"key1": [1,2,3], "key1":123}'','+sLineBreak - +'''$.key1'');'+sLineBreak - +'+-------------------------------------------------------+'+sLineBreak - +'| json_value(''{"key1": [1,2,3], "key1":123}'','+sLineBreak - +'''$.key1'') |'+sLineBreak - +'+-------------------------------------------------------+'+sLineBreak - +'| 123 |'+sLineBreak - +'+-------------------------------------------------------+' - ), - - ( - Name: 'GLENGTH'; - Declaration: '(ls)'; - Category: 'LineString Properties'; - Version: SQL_VERSION_ANSI; - Description: 'Returns as a double-precision number the length of the'+sLineBreak - +'LineString value ls in its associated spatial reference.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SET @ls = ''LineString(1 1,2 2,3 3)'';'+sLineBreak - +' '+sLineBreak - +'SELECT GLength(GeomFromText(@ls));'+sLineBreak - +'+----------------------------+'+sLineBreak - +'| GLength(GeomFromText(@ls)) |'+sLineBreak - +'+----------------------------+'+sLineBreak - +'| 2.82842712474619 |'+sLineBreak - +'+----------------------------+' - ), - - ( - Name: 'ST_ENDPOINT'; - Declaration: '(ls)'; - Category: 'LineString Properties'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the Point that is the endpoint of the'+sLineBreak - +'LineString value ls.'+sLineBreak - +' '+sLineBreak - +'ST_EndPoint() and EndPoint() are synonyms.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SET @ls = ''LineString(1 1,2 2,3 3)'';'+sLineBreak - +' '+sLineBreak - +'SELECT AsText(EndPoint(GeomFromText(@ls)));'+sLineBreak - +'+-------------------------------------+'+sLineBreak - +'| AsText(EndPoint(GeomFromText(@ls))) |'+sLineBreak - +'+-------------------------------------+'+sLineBreak - +'| POINT(3 3) |'+sLineBreak - +'+-------------------------------------+' - ), - - ( - Name: 'ST_NUMPOINTS'; - Declaration: '(ls)'; - Category: 'LineString Properties'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the number of Point objects in the LineString'+sLineBreak - +'value ls.'+sLineBreak - +' '+sLineBreak - +'ST_NumPoints() and NumPoints() are synonyms.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SET @ls = ''LineString(1 1,2 2,3 3)'';'+sLineBreak - +' '+sLineBreak - +'SELECT NumPoints(GeomFromText(@ls));'+sLineBreak - +'+------------------------------+'+sLineBreak - +'| NumPoints(GeomFromText(@ls)) |'+sLineBreak - +'+------------------------------+'+sLineBreak - +'| 3 |'+sLineBreak - +'+------------------------------+' - ), - - ( - Name: 'ST_POINTN'; - Declaration: '(ls,N)'; - Category: 'LineString Properties'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the N-th Point in the LineString value ls.'+sLineBreak - +'Points are numbered beginning with 1.'+sLineBreak - +' '+sLineBreak - +'ST_PointN() and PointN() are synonyms.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SET @ls = ''LineString(1 1,2 2,3 3)'';'+sLineBreak - +' '+sLineBreak - +'SELECT AsText(PointN(GeomFromText(@ls),2));'+sLineBreak - +'+-------------------------------------+'+sLineBreak - +'| AsText(PointN(GeomFromText(@ls),2)) |'+sLineBreak - +'+-------------------------------------+'+sLineBreak - +'| POINT(2 2) |'+sLineBreak - +'+-------------------------------------+' - ), - - ( - Name: 'MBRContains'; - Declaration: '(g1,g2)'; - Category: 'MBR'; - Version: SQL_VERSION_ANSI; - Description: 'Returns 1 or 0 to indicate whether the Minimum Bounding'+sLineBreak - +'Rectangle of'+sLineBreak - +'g1 contains the Minimum Bounding Rectangle of g2. This tests'+sLineBreak - +'the'+sLineBreak - +'opposite relationship as MBRWithin().'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SET @g1 = GeomFromText(''Polygon((0 0,0 3,3 3,3 0,0 0))'');'+sLineBreak - +' '+sLineBreak - +'SET @g2 = GeomFromText(''Point(1 1)'');'+sLineBreak - +' '+sLineBreak - +'SELECT MBRContains(@g1,@g2), MBRContains(@g2,@g1);'+sLineBreak - +'+----------------------+----------------------+'+sLineBreak - +'| MBRContains(@g1,@g2) | MBRContains(@g2,@g1) |'+sLineBreak - +'+----------------------+----------------------+'+sLineBreak - +'| 1 | 0 |'+sLineBreak - +'+----------------------+----------------------+' - ), - - ( - Name: 'MBRDisjoint'; - Declaration: '(g1,g2)'; - Category: 'MBR'; - Version: SQL_VERSION_ANSI; - Description: 'Returns 1 or 0 to indicate whether the Minimum Bounding'+sLineBreak - +'Rectangles of the two geometries g1 and g2 are disjoint. Two'+sLineBreak - +'geometries are disjoint if they do not intersect, that is'+sLineBreak - +'touch or overlap.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SET @g1 = GeomFromText(''Polygon((0 0,0 3,3 3,3 0,0 0))'');'+sLineBreak - +'SET @g2 = GeomFromText(''Polygon((4 4,4 7,7 7,7 4,4 4))'');'+sLineBreak - +'SELECTmbrdisjoint(@g1,@g2);'+sLineBreak - +'+----------------------+'+sLineBreak - +'| mbrdisjoint(@g1,@g2) |'+sLineBreak - +'+----------------------+'+sLineBreak - +'| 1 |'+sLineBreak - +'+----------------------+'+sLineBreak - +' '+sLineBreak - +'SET @g1 = GeomFromText(''Polygon((0 0,0 3,3 3,3 0,0 0))'');'+sLineBreak - +'SET @g2 = GeomFromText(''Polygon((3 3,3 6,6 6,6 3,3 3))'');'+sLineBreak - +'SELECT mbrdisjoint(@g1,@g2);'+sLineBreak - +'+----------------------+'+sLineBreak - +'| mbrdisjoint(@g1,@g2) |'+sLineBreak - +'+----------------------+'+sLineBreak - +'| 0 |'+sLineBreak - +'+----------------------+' - ), - - ( - Name: 'MBREqual'; - Declaration: '(g1,g2)'; - Category: 'MBR'; - Version: SQL_VERSION_ANSI; - Description: 'Returns 1 or 0 to indicate whether the Minimum Bounding'+sLineBreak - +'Rectangles of'+sLineBreak - +'the two geometries g1 and g2 are the same.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SET @g1=GEOMFROMTEXT(''LINESTRING(0 0, 1 2)'');'+sLineBreak - +'SET @g2=GEOMFROMTEXT(''POLYGON((0 0, 0 2, 1 2, 1 0, 0'+sLineBreak - +'0))'');'+sLineBreak - +'SELECT MbrEqual(@g1,@g2);'+sLineBreak - +'+-------------------+'+sLineBreak - +'| MbrEqual(@g1,@g2) |'+sLineBreak - +'+-------------------+'+sLineBreak - +'| 1 |'+sLineBreak - +'+-------------------+'+sLineBreak - +' '+sLineBreak - +'SET @g1=GEOMFROMTEXT(''LINESTRING(0 0, 1 3)'');'+sLineBreak - +'SET @g2=GEOMFROMTEXT(''POLYGON((0 0, 0 2, 1 4, 1 0, 0'+sLineBreak - +'0))'');'+sLineBreak - +'SELECT MbrEqual(@g1,@g2);'+sLineBreak - +'+-------------------+'+sLineBreak - +'| MbrEqual(@g1,@g2) |'+sLineBreak - +'+-------------------+'+sLineBreak - +'| 0 |'+sLineBreak - +'+-------------------+' - ), - - ( - Name: 'MBRIntersects'; - Declaration: '(g1,g2)'; - Category: 'MBR'; - Version: SQL_VERSION_ANSI; - Description: 'Returns 1 or 0 to indicate whether the Minimum Bounding'+sLineBreak - +'Rectangles of the two geometries g1 and g2 intersect.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SET @g1 = GeomFromText(''Polygon((0 0,0 3,3 3,3 0,0 0))'');'+sLineBreak - +'SET @g2 = GeomFromText(''Polygon((3 3,3 6,6 6,6 3,3 3))'');'+sLineBreak - +'SELECT mbrintersects(@g1,@g2);'+sLineBreak - +'+------------------------+'+sLineBreak - +'| mbrintersects(@g1,@g2) |'+sLineBreak - +'+------------------------+'+sLineBreak - +'| 1 |'+sLineBreak - +'+------------------------+'+sLineBreak - +' '+sLineBreak - +'SET @g1 = GeomFromText(''Polygon((0 0,0 3,3 3,3 0,0 0))'');'+sLineBreak - +'SET @g2 = GeomFromText(''Polygon((4 4,4 7,7 7,7 4,4 4))'');'+sLineBreak - +'SELECT mbrintersects(@g1,@g2);'+sLineBreak - +'+------------------------+'+sLineBreak - +'| mbrintersects(@g1,@g2) |'+sLineBreak - +'+------------------------+'+sLineBreak - +'| 0 |'+sLineBreak - +'+------------------------+' - ), - - ( - Name: 'MBROverlaps'; - Declaration: '(g1,g2)'; - Category: 'MBR'; - Version: SQL_VERSION_ANSI; - Description: 'Returns 1 or 0 to indicate whether the Minimum Bounding'+sLineBreak - +'Rectangles of'+sLineBreak - +'the two geometries g1 and g2 overlap. The term spatially'+sLineBreak - +'overlaps is'+sLineBreak - +'used if two geometries intersect and their intersection'+sLineBreak - +'results in a'+sLineBreak - +'geometry of the same dimension but not equal to either of'+sLineBreak - +'the given'+sLineBreak - +'geometries.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SET @g1 = GeomFromText(''Polygon((0 0,0 3,3 3,3 0,0 0))'');'+sLineBreak - +'SET @g2 = GeomFromText(''Polygon((4 4,4 7,7 7,7 4,4 4))'');'+sLineBreak - +'SELECT mbroverlaps(@g1,@g2);'+sLineBreak - +'+----------------------+'+sLineBreak - +'| mbroverlaps(@g1,@g2) |'+sLineBreak - +'+----------------------+'+sLineBreak - +'| 0 |'+sLineBreak - +'+----------------------+'+sLineBreak - +' '+sLineBreak - +'SET @g1 = GeomFromText(''Polygon((0 0,0 3,3 3,3 0,0 0))'');'+sLineBreak - +'SET @g2 = GeomFromText(''Polygon((3 3,3 6,6 6,6 3,3 3))'');'+sLineBreak - +'SELECT mbroverlaps(@g1,@g2);'+sLineBreak - +'+----------------------+'+sLineBreak - +'| mbroverlaps(@g1,@g2) |'+sLineBreak - +'+----------------------+'+sLineBreak - +'| 0 |'+sLineBreak - +'+----------------------+'+sLineBreak - +' '+sLineBreak - +'SET @g1 = GeomFromText(''Polygon((0 0,0 4,4 4,4 0,0 0))'');'+sLineBreak - +'SET @g2 = GeomFromText(''Polygon((3 3,3 6,6 6,6 3,3 3))'');'+sLineBreak - +'SELECT mbroverlaps(@g1,@g2);'+sLineBreak - +'+----------------------+'+sLineBreak - +'| mbroverlaps(@g1,@g2) |'+sLineBreak - +'+----------------------+'+sLineBreak - +'| 1 |'+sLineBreak - +'+----------------------+' - ), - - ( - Name: 'MBRTouches'; - Declaration: '(g1,g2)'; - Category: 'MBR'; - Version: SQL_VERSION_ANSI; - Description: 'Returns 1 or 0 to indicate whether the Minimum Bounding'+sLineBreak - +'Rectangles of'+sLineBreak - +'the two geometries g1 and g2 touch. Two geometries spatially'+sLineBreak - +'touch if'+sLineBreak - +'the interiors of the geometries do not intersect, but the'+sLineBreak - +'boundary of'+sLineBreak - +'one of the geometries intersects either the boundary or the'+sLineBreak - +'interior'+sLineBreak - +'of the other.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SET @g1 = GeomFromText(''Polygon((0 0,0 3,3 3,3 0,0 0))'');'+sLineBreak - +'SET @g2 = GeomFromText(''Polygon((4 4,4 7,7 7,7 4,4 4))'');'+sLineBreak - +'SELECT mbrtouches(@g1,@g2);'+sLineBreak - +'+---------------------+'+sLineBreak - +'| mbrtouches(@g1,@g2) |'+sLineBreak - +'+---------------------+'+sLineBreak - +'| 0 |'+sLineBreak - +'+---------------------+'+sLineBreak - +' '+sLineBreak - +'SET @g1 = GeomFromText(''Polygon((0 0,0 3,3 3,3 0,0 0))'');'+sLineBreak - +'SET @g2 = GeomFromText(''Polygon((3 3,3 6,6 6,6 3,3 3))'');'+sLineBreak - +'SELECT mbrtouches(@g1,@g2);'+sLineBreak - +'+---------------------+'+sLineBreak - +'| mbrtouches(@g1,@g2) |'+sLineBreak - +'+---------------------+'+sLineBreak - +'| 1 |'+sLineBreak - +'+---------------------+'+sLineBreak - +' '+sLineBreak - +'SET @g1 = GeomFromText(''Polygon((0 0,0 4,4 4,4 0,0 0))'');'+sLineBreak - +'SET @g2 = GeomFromText(''Polygon((3 3,3 6,6 6,6 3,3 3))'');'+sLineBreak - +'SELECT mbrtouches(@g1,@g2);'+sLineBreak - +'+---------------------+'+sLineBreak - +'| mbrtouches(@g1,@g2) |'+sLineBreak - +'+---------------------+'+sLineBreak - +'| 0 |'+sLineBreak - +'+---------------------+' - ), - - ( - Name: 'MBRWithin'; - Declaration: '(g1,g2)'; - Category: 'MBR'; - Version: SQL_VERSION_ANSI; - Description: 'Returns 1 or 0 to indicate whether the Minimum Bounding'+sLineBreak - +'Rectangle of'+sLineBreak - +'g1 is within the Minimum Bounding Rectangle of g2. This'+sLineBreak - +'tests the'+sLineBreak - +'opposite relationship as MBRContains().'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SET @g1 = GeomFromText(''Polygon((0 0,0 3,3 3,3 0,0 0))'');'+sLineBreak - +'SET @g2 = GeomFromText(''Polygon((0 0,0 5,5 5,5 0,0 0))'');'+sLineBreak - +'SELECT MBRWithin(@g1,@g2), MBRWithin(@g2,@g1);'+sLineBreak - +'+--------------------+--------------------+'+sLineBreak - +'| MBRWithin(@g1,@g2) | MBRWithin(@g2,@g1) |'+sLineBreak - +'+--------------------+--------------------+'+sLineBreak - +'| 1 | 0 |'+sLineBreak - +'+--------------------+--------------------+' - ), - - ( - Name: 'GET_LOCK'; - Declaration: '(str,timeout)'; - Category: 'Miscellaneous Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Tries to obtain a lock with a name given by the string str,'+sLineBreak - +'using a timeout of timeout seconds. Returns 1 if the lock'+sLineBreak - +'was obtained successfully, 0 if the attempt timed out (for'+sLineBreak - +'example, because another client has previously locked the'+sLineBreak - +'name), or NULL if an error occurred (such as running out of'+sLineBreak - +'memory or the thread was killed with mysqladmin kill).'+sLineBreak - +' '+sLineBreak - +'A lock is released with RELEASE_LOCK(), when the connection'+sLineBreak - +'terminates (either normally or abnormally), or before'+sLineBreak - +'MariaDB 10.0.2, when the connection executes another'+sLineBreak - +'GET_LOCK statement. From MariaDB 10.0.2, a connection can'+sLineBreak - +'hold multiple locks at the same time, so a lock that is no'+sLineBreak - +'longer needed needs to be explicitly released.'+sLineBreak - +' '+sLineBreak - +'The IS_FREE_LOCK function returns whether a specified lock a'+sLineBreak - +'free or not, and the IS_USED_LOCK whether the function is in'+sLineBreak - +'use or not.'+sLineBreak - +' '+sLineBreak - +'Locks obtained with GET_LOCK() do not interact with'+sLineBreak - +'transactions. That is, committing a transaction does not'+sLineBreak - +'release any such locks obtained during the transaction.'+sLineBreak - +' '+sLineBreak - +'From MariaDB 10.0.2, it is also possible to recursively set'+sLineBreak - +'the same lock. If a lock with the same name is set n times,'+sLineBreak - +'it needs to be released n times as well. '+sLineBreak - +' '+sLineBreak - +'str is case insensitive for GET_LOCK() and related'+sLineBreak - +'functions. If str is an empty string or NULL, GET_LOCK()'+sLineBreak - +'returns NULL and does nothing. From MariaDB 10.2.2, timeout'+sLineBreak - +'supports microseconds. Before then, it was rounded to the'+sLineBreak - +'closest integer.'+sLineBreak - +' '+sLineBreak - +'If the metadata_lock_info plugin is installed, locks'+sLineBreak - +'acquired with this function are visible in the Information'+sLineBreak - +'Schema METADATA_LOCK_INFO table.'+sLineBreak - +' '+sLineBreak - +'This function can be used to implement application locks or'+sLineBreak - +'to simulate record locks. Names are locked on a server-wide'+sLineBreak - +'basis. If a name has been locked by one client, GET_LOCK()'+sLineBreak - +'blocks any request by another client for a lock with the'+sLineBreak - +'same name. This allows clients that agree on a given lock'+sLineBreak - +'name to use the name to perform cooperative advisory'+sLineBreak - +'locking. But be aware that it also allows a client that is'+sLineBreak - +'not among the set of cooperating clients to lock a name,'+sLineBreak - +'either inadvertently or deliberately, and thus prevent any'+sLineBreak - +'of the cooperating clients from locking that name. One way'+sLineBreak - +'to reduce the likelihood of this is to use lock names that'+sLineBreak - +'are database-specific or application-specific. For example,'+sLineBreak - +'use lock names of the form db_name.str or app_name.str.'+sLineBreak - +' '+sLineBreak - +'Statements using the GET_LOCK() function are not safe for'+sLineBreak - +'replication.'+sLineBreak - +' '+sLineBreak - +'The patch to permit multiple locks was contributed by'+sLineBreak - +'Konstantin "Kostja" Osipov (MDEV-3917).'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT GET_LOCK(''lock1'',10);'+sLineBreak - +'+----------------------+'+sLineBreak - +'| GET_LOCK(''lock1'',10) |'+sLineBreak - +'+----------------------+'+sLineBreak - +'| 1 |'+sLineBreak - +'+----------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT IS_FREE_LOCK(''lock1''), IS_USED_LOCK(''lock1'');'+sLineBreak - +'+-----------------------+-----------------------+'+sLineBreak - +'| IS_FREE_LOCK(''lock1'') | IS_USED_LOCK(''lock1'') |'+sLineBreak - +'+-----------------------+-----------------------+'+sLineBreak - +'| 0 | 46 |'+sLineBreak - +'+-----------------------+-----------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT IS_FREE_LOCK(''lock2''), IS_USED_LOCK(''lock2'');'+sLineBreak - +'+-----------------------+-----------------------+'+sLineBreak - +'| IS_FREE_LOCK(''lock2'') | IS_USED_LOCK(''lock2'') |'+sLineBreak - +'+-----------------------+-----------------------+'+sLineBreak - +'| 1 | NULL |'+sLineBreak - +'+-----------------------+-----------------------+'+sLineBreak - +' '+sLineBreak - +'From MariaDB 10.0.2, multiple locks can be held:'+sLineBreak - +' '+sLineBreak - +'SELECT GET_LOCK(''lock2'',10);'+sLineBreak - +'+----------------------+'+sLineBreak - +'| GET_LOCK(''lock2'',10) |'+sLineBreak - +'+----------------------+'+sLineBreak - +'| 1 |'+sLineBreak - +'+----------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT IS_FREE_LOCK(''lock1''), IS_FREE_LOCK(''lock2'');'+sLineBreak - +'+-----------------------+-----------------------+'+sLineBreak - +'| IS_FREE_LOCK(''lock1'') | IS_FREE_LOCK(''lock2'') |'+sLineBreak - +'+-----------------------+-----------------------+'+sLineBreak - +'| 0 | 0 |'+sLineBreak - +'+-----------------------+-----------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT RELEASE_LOCK(''lock1''), RELEASE_LOCK(''lock2'');'+sLineBreak - +'+-----------------------+-----------------------+'+sLineBreak - +'| RELEASE_LOCK(''lock1'') | RELEASE_LOCK(''lock2'') |'+sLineBreak - +'+-----------------------+-----------------------+'+sLineBreak - +'| 1 | 1 |'+sLineBreak - +'+-----------------------+-----------------------+'+sLineBreak - +' '+sLineBreak - +'Before MariaDB 10.0.2, a connection could only hold a single'+sLineBreak - +'lock:'+sLineBreak - +' '+sLineBreak - +'SELECT GET_LOCK(''lock2'',10);'+sLineBreak - +'+----------------------+'+sLineBreak - +'| GET_LOCK(''lock2'',10) |'+sLineBreak - +'+----------------------+'+sLineBreak - +'| 1 |'+sLineBreak - +'+----------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT IS_FREE_LOCK(''lock1''), IS_FREE_LOCK(''lock2'');'+sLineBreak - +'+-----------------------+-----------------------+'+sLineBreak - +'| IS_FREE_LOCK(''lock1'') | IS_FREE_LOCK(''lock2'') |'+sLineBreak - +'+-----------------------+-----------------------+'+sLineBreak - +'| 1 | 0 |'+sLineBreak - +'+-----------------------+-----------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT RELEASE_LOCK(''lock1''), RELEASE_LOCK(''lock2'');'+sLineBreak - +'+-----------------------+-----------------------+'+sLineBreak - +'| RELEASE_LOCK(''lock1'') | RELEASE_LOCK(''lock2'') |'+sLineBreak - +'+-----------------------+-----------------------+'+sLineBreak - +'| NULL | 1 |'+sLineBreak - +'+-----------------------+-----------------------+'+sLineBreak - +' '+sLineBreak - +'From MariaDB 10.0.2, it is possible to hold the same lock'+sLineBreak - +'recursively. This example is viewed using the'+sLineBreak - +'metadata_lock_info plugin:'+sLineBreak - +' '+sLineBreak - +'SELECT GET_LOCK(''lock3'',10);'+sLineBreak - +'+----------------------+'+sLineBreak - +'| GET_LOCK(''lock3'',10) |'+sLineBreak - +'+----------------------+'+sLineBreak - +'| 1 |'+sLineBreak - +'+----------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT GET_LOCK(''lock3'',10);'+sLineBreak - +'+----------------------+'+sLineBreak - +'| GET_LOCK(''lock3'',10) |'+sLineBreak - +'+----------------------+'+sLineBreak - +'| 1 |'+sLineBreak - +'+----------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT * FROM INFORMATION_SCHEMA.METADATA_LOCK_INFO;'+sLineBreak - +' '+sLineBreak - +'+-----------+---------------------+---------------+-----------+--------------+------------+'+sLineBreak - +'| THREAD_ID | LOCK_MODE | LOCK_DURATION | LOCK_TYPE |'+sLineBreak - +'TABLE_SCHEMA | TABLE_NAME |'+sLineBreak - +'+-----------+---------------------+---------------+-----------+--------------+------------+'+sLineBreak - +'| 46 | MDL_SHARED_NO_WRITE | NULL | User lock | lock3 | |'+sLineBreak - +'+-----------+---------------------+---------------+-----------+--------------+------------+'+sLineBreak - +' '+sLineBreak - +'SELECT RELEASE_LOCK(''lock3'');'+sLineBreak - +'+-----------------------+'+sLineBreak - +'| RELEASE_LOCK(''lock3'') |'+sLineBreak - +'+-----------------------+'+sLineBreak - +'| 1 |'+sLineBreak - +'+-----------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT * FROM INFORMATION_SCHEMA.METADATA_LOCK_INFO;'+sLineBreak - +' '+sLineBreak - +'+-----------+---------------------+---------------+-----------+--------------+------------+'+sLineBreak - +'| THREAD_ID | LOCK_MODE | LOCK_DURATION | LOCK_TYPE |'+sLineBreak - +'TABLE_SCHEMA | TABLE_NAME |'+sLineBreak - +'+-----------+---------------------+---------------+-----------+--------------+------------+'+sLineBreak - +'| 46 | MDL_SHARED_NO_WRITE | NULL | User lock | lock3 | |'+sLineBreak - +'+-----------+---------------------+---------------+-----------+--------------+------------+'+sLineBreak - +' '+sLineBreak - +'SELECT RELEASE_LOCK(''lock3'');'+sLineBreak - +'+-----------------------+'+sLineBreak - +'| RELEASE_LOCK(''lock3'') |'+sLineBreak - +'+-----------------------+'+sLineBreak - +'| 1 |'+sLineBreak - +'+-----------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT * FROM INFORMATION_SCHEMA.METADATA_LOCK_INFO;'+sLineBreak - +' '+sLineBreak - +'Empty set (0.000 sec)'+sLineBreak - +' '+sLineBreak - +'Timeout example: Connection 1:'+sLineBreak - +' '+sLineBreak - +'SELECT GET_LOCK(''lock4'',10);'+sLineBreak - +'+----------------------+'+sLineBreak - +'| GET_LOCK(''lock4'',10) |'+sLineBreak - +'+----------------------+'+sLineBreak - +'| 1 |'+sLineBreak - +'+----------------------+'+sLineBreak - +' '+sLineBreak - +'Connection 2:'+sLineBreak - +' '+sLineBreak - +'SELECT GET_LOCK(''lock4'',10);'+sLineBreak - +' '+sLineBreak - +'After 10 seconds...'+sLineBreak - +' '+sLineBreak - +'+----------------------+'+sLineBreak - +'| GET_LOCK(''lock4'',10) |'+sLineBreak - +'+----------------------+'+sLineBreak - +'| 0 |'+sLineBreak - +'+----------------------+'+sLineBreak - +' '+sLineBreak - +'Deadlocks are automatically detected and resolved.'+sLineBreak - +'Connection 1:'+sLineBreak - +' '+sLineBreak - +'SELECT GET_LOCK(''lock5'',10); '+sLineBreak - +'+----------------------+'+sLineBreak - +'| GET_LOCK(''lock5'',10) |'+sLineBreak - +'+----------------------+'+sLineBreak - +'| 1 |'+sLineBreak - +'+----------------------+'+sLineBreak - +' '+sLineBreak - +'Connection 2:'+sLineBreak - +' '+sLineBreak - +'SELECT GET_LOCK(''lock6'',10);'+sLineBreak - +'+----------------------+'+sLineBreak - +'| GET_LOCK(''lock6'',10) |'+sLineBreak - +'+----------------------+'+sLineBreak - +'| 1 |'+sLineBreak - +'+----------------------+'+sLineBreak - +' '+sLineBreak - +'Connection 1:'+sLineBreak - +' '+sLineBreak - +'SELECT GET_LOCK(''lock6'',10); '+sLineBreak - +'+----------------------+'+sLineBreak - +'| GET_LOCK(''lock6'',10) |'+sLineBreak - +'+----------------------+'+sLineBreak - +'| 0 |'+sLineBreak - +'+----------------------+'+sLineBreak - +' '+sLineBreak - +'Connection 2:'+sLineBreak - +' '+sLineBreak - +'SELECT GET_LOCK(''lock5'',10);'+sLineBreak - +'ERROR 1213 (40001): Deadlock found when trying to get lock;'+sLineBreak - +' try restarting transaction' - ), - - ( - Name: 'INET6_ATON'; - Declaration: '(expr)'; - Category: 'Miscellaneous Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Given an IPv6 or IPv4 network address as a string, returns a'+sLineBreak - +'binary string that represents the numeric value of the'+sLineBreak - +'address.'+sLineBreak - +' '+sLineBreak - +'No trailing zone ID''s or traling network masks are'+sLineBreak - +'permitted. For IPv4 addresses, or IPv6 addresses with IPv4'+sLineBreak - +'address parts, no classful addresses or trailing port'+sLineBreak - +'numbers are permitted and octal numbers are not supported.'+sLineBreak - +' '+sLineBreak - +'The returned binary string will be VARBINARY(16) or'+sLineBreak - +'VARBINARY(4) for IPv6 and IPv4 addresses respectively.'+sLineBreak - +' '+sLineBreak - +'Returns NULL if the argument is not understood.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT HEX(INET6_ATON(''10.0.1.1''));'+sLineBreak - +'+-----------------------------+'+sLineBreak - +'| HEX(INET6_ATON(''10.0.1.1'')) |'+sLineBreak - +'+-----------------------------+'+sLineBreak - +'| 0A000101 |'+sLineBreak - +'+-----------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT HEX(INET6_ATON(''48f3::d432:1431:ba23:846f''));'+sLineBreak - +'+----------------------------------------------+'+sLineBreak - +'| HEX(INET6_ATON(''48f3::d432:1431:ba23:846f'')) |'+sLineBreak - +'+----------------------------------------------+'+sLineBreak - +'| 48F3000000000000D4321431BA23846F |'+sLineBreak - +'+----------------------------------------------+' - ), - - ( - Name: 'INET6_NTOA'; - Declaration: '(expr)'; - Category: 'Miscellaneous Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Given an IPv6 or IPv4 network address as a numeric binary'+sLineBreak - +'string, returns the address as a nonbinary string in the'+sLineBreak - +'connection character set.'+sLineBreak - +' '+sLineBreak - +'The return string is lowercase, and is platform independent,'+sLineBreak - +'since it does not use functions specific to the operating'+sLineBreak - +'system. It has a maximum length of 39 characters.'+sLineBreak - +' '+sLineBreak - +'Returns NULL if the argument is not understood.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT INET6_NTOA(UNHEX(''0A000101''));'+sLineBreak - +'+-------------------------------+'+sLineBreak - +'| INET6_NTOA(UNHEX(''0A000101'')) |'+sLineBreak - +'+-------------------------------+'+sLineBreak - +'| 10.0.1.1 |'+sLineBreak - +'+-------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT'+sLineBreak - +'INET6_NTOA(UNHEX(''48F3000000000000D4321431BA23846F''));'+sLineBreak - +'+-------------------------------------------------------+'+sLineBreak - +'| INET6_NTOA(UNHEX(''48F3000000000000D4321431BA23846F'')) |'+sLineBreak - +'+-------------------------------------------------------+'+sLineBreak - +'| 48f3::d432:1431:ba23:846f |'+sLineBreak - +'+-------------------------------------------------------+' - ), - - ( - Name: 'INET_ATON'; - Declaration: '(expr)'; - Category: 'Miscellaneous Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Given the dotted-quad representation of an IPv4 network'+sLineBreak - +'address as a string,'+sLineBreak - +'returns an integer that represents the numeric value of the'+sLineBreak - +'address.'+sLineBreak - +'Addresses may be 4- or 8-byte addresses.'+sLineBreak - +' '+sLineBreak - +'Returns NULL if the argument is not understood.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT INET_ATON(''192.168.1.1'');'+sLineBreak - +'+--------------------------+'+sLineBreak - +'| INET_ATON(''192.168.1.1'') |'+sLineBreak - +'+--------------------------+'+sLineBreak - +'| 3232235777 |'+sLineBreak - +'+--------------------------+'+sLineBreak - +' '+sLineBreak - +'This is calculated as follows: 192 x 2563 + 168 x 256 2 + 1'+sLineBreak - +'x 256 + 1' - ), - - ( - Name: 'INET_NTOA'; - Declaration: '(expr)'; - Category: 'Miscellaneous Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Given a numeric IPv4 network address in network byte order'+sLineBreak - +'(4 or 8 byte),'+sLineBreak - +'returns the dotted-quad representation of the address as a'+sLineBreak - +'string.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT INET_NTOA(3232235777);'+sLineBreak - +'+-----------------------+'+sLineBreak - +'| INET_NTOA(3232235777) |'+sLineBreak - +'+-----------------------+'+sLineBreak - +'| 192.168.1.1 |'+sLineBreak - +'+-----------------------+'+sLineBreak - +' '+sLineBreak - +'192.168.1.1 corresponds to 3232235777 since 192 x 2563 + 168'+sLineBreak - +'x 256 2 + 1 x 256 + 1 = 3232235777' - ), - - ( - Name: 'IS_FREE_LOCK'; - Declaration: '(str)'; - Category: 'Miscellaneous Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Checks whether the lock named str is free to use (that is,'+sLineBreak - +'not locked).'+sLineBreak - +'Returns 1 if the lock is free (no one is using the lock),'+sLineBreak - +' 0 if the lock is in use, and NULL if an'+sLineBreak - +'error occurs (such as an incorrect argument, like an empty'+sLineBreak - +'string or NULL). str is case insensitive.'+sLineBreak - +' '+sLineBreak - +'If the metadata_lock_info plugin is installed, the'+sLineBreak - +'Information Schema metadata_lock_info table contains'+sLineBreak - +'information about locks of this kind (as well as metadata'+sLineBreak - +'locks).'+sLineBreak - +' '+sLineBreak - +'Statements using the IS_FREE_LOCK() function are not safe'+sLineBreak - +'for replication.' - ), - - ( - Name: 'IS_IPV4'; - Declaration: '(expr)'; - Category: 'Miscellaneous Functions'; - Version: SQL_VERSION_ANSI; - Description: 'If the expression is a valid IPv4 address, returns 1,'+sLineBreak - +'otherwise returns 0.'+sLineBreak - +' '+sLineBreak - +'IS_IPV4() is stricter than INET_ATON(), but as strict as'+sLineBreak - +'INET6_ATON(), in determining the validity of an IPv4'+sLineBreak - +'address. This implies that if IS_IPV4 returns 1, the same'+sLineBreak - +'expression will always return a non-NULL result when passed'+sLineBreak - +'to INET_ATON(), but that the reverse may not apply.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT IS_IPV4(''1110.0.1.1'');'+sLineBreak - +'+-----------------------+'+sLineBreak - +'| IS_IPV4(''1110.0.1.1'') |'+sLineBreak - +'+-----------------------+'+sLineBreak - +'| 0 |'+sLineBreak - +'+-----------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT IS_IPV4(''48f3::d432:1431:ba23:846f'');'+sLineBreak - +'+--------------------------------------+'+sLineBreak - +'| IS_IPV4(''48f3::d432:1431:ba23:846f'') |'+sLineBreak - +'+--------------------------------------+'+sLineBreak - +'| 0 |'+sLineBreak - +'+--------------------------------------+' - ), - - ( - Name: 'IS_IPV4_COMPAT'; - Declaration: '(expr)'; - Category: 'Miscellaneous Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns 1 if a given numeric binary string IPv6 address,'+sLineBreak - +'such as returned by INET6_ATON(), is IPv4-compatible,'+sLineBreak - +'otherwise returns 0. '+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT IS_IPV4_COMPAT(INET6_ATON(''::10.0.1.1''));'+sLineBreak - +'+------------------------------------------+'+sLineBreak - +'| IS_IPV4_COMPAT(INET6_ATON(''::10.0.1.1'')) |'+sLineBreak - +'+------------------------------------------+'+sLineBreak - +'| 1 |'+sLineBreak - +'+------------------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT'+sLineBreak - +'IS_IPV4_COMPAT(INET6_ATON(''::48f3::d432:1431:ba23:846f''));'+sLineBreak - +'+-----------------------------------------------------------+'+sLineBreak - +'|'+sLineBreak - +'IS_IPV4_COMPAT(INET6_ATON(''::48f3::d432:1431:ba23:846f''))'+sLineBreak - +'|'+sLineBreak - +'+-----------------------------------------------------------+'+sLineBreak - +'| 0 |'+sLineBreak - +'+-----------------------------------------------------------+' - ), - - ( - Name: 'IS_IPV4_MAPPED'; - Declaration: '(expr)'; - Category: 'Miscellaneous Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns 1 if a given a numeric binary string IPv6 address,'+sLineBreak - +'such as returned by INET6_ATON(), is a valid IPv4-mapped'+sLineBreak - +'address, otherwise returns 0.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT IS_IPV4_MAPPED(INET6_ATON(''::10.0.1.1''));'+sLineBreak - +'+------------------------------------------+'+sLineBreak - +'| IS_IPV4_MAPPED(INET6_ATON(''::10.0.1.1'')) |'+sLineBreak - +'+------------------------------------------+'+sLineBreak - +'| 0 |'+sLineBreak - +'+------------------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT IS_IPV4_MAPPED(INET6_ATON(''::ffff:10.0.1.1''));'+sLineBreak - +'+-----------------------------------------------+'+sLineBreak - +'| IS_IPV4_MAPPED(INET6_ATON(''::ffff:10.0.1.1'')) |'+sLineBreak - +'+-----------------------------------------------+'+sLineBreak - +'| 1 |'+sLineBreak - +'+-----------------------------------------------+' - ), - - ( - Name: 'IS_IPV6'; - Declaration: '(expr)'; - Category: 'Miscellaneous Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns 1 if the expression is a valid IPv6 address'+sLineBreak - +'specified as a string, otherwise returns 0. Does not'+sLineBreak - +'consider IPv4 addresses to be valid IPv6 addresses.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +' SELECT IS_IPV6(''48f3::d432:1431:ba23:846f'');'+sLineBreak - +'+--------------------------------------+'+sLineBreak - +'| IS_IPV6(''48f3::d432:1431:ba23:846f'') |'+sLineBreak - +'+--------------------------------------+'+sLineBreak - +'| 1 |'+sLineBreak - +'+--------------------------------------+'+sLineBreak - +'1 row in set (0.02 sec)'+sLineBreak - +' '+sLineBreak - +'SELECT IS_IPV6(''10.0.1.1'');'+sLineBreak - +'+---------------------+'+sLineBreak - +'| IS_IPV6(''10.0.1.1'') |'+sLineBreak - +'+---------------------+'+sLineBreak - +'| 0 |'+sLineBreak - +'+---------------------+' - ), - - ( - Name: 'IS_USED_LOCK'; - Declaration: '(str)'; - Category: 'Miscellaneous Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Checks whether the lock named str is in use (that is,'+sLineBreak - +'locked). If so,'+sLineBreak - +'it returns the connection identifier of the client that'+sLineBreak - +'holds the'+sLineBreak - +'lock. Otherwise, it returns NULL. str is case insensitive.'+sLineBreak - +' '+sLineBreak - +'If the metadata_lock_info plugin is installed, the'+sLineBreak - +'Information Schema metadata_lock_info table contains'+sLineBreak - +'information about locks of this kind (as well as metadata'+sLineBreak - +'locks).'+sLineBreak - +' '+sLineBreak - +'Statements using the IS_USED_LOCK() function are not safe'+sLineBreak - +'for replication.' - ), - - ( - Name: 'MASTER_GTID_WAIT'; - Declaration: '(gtid-list[, timeout)'; - Category: 'Miscellaneous Functions'; - Version: SQL_VERSION_ANSI; - Description: 'This function takes a string containing a comma-separated'+sLineBreak - +'list of global transaction id''s'+sLineBreak - +'(similar to the value of, for example, gtid_binlog_pos). It'+sLineBreak - +'waits until the value of gtid_slave_pos has the same or'+sLineBreak - +'higher seq_no within all replication domains specified in'+sLineBreak - +'the gtid-list; in other words, it waits until the slave has'+sLineBreak - +'reached the specified GTID position.'+sLineBreak - +' '+sLineBreak - +'An optional second argument gives a timeout in seconds. If'+sLineBreak - +'the timeout'+sLineBreak - +'expires before the specified GTID position is reached, then'+sLineBreak - +'the function'+sLineBreak - +'returns -1. Passing NULL or a negative number for the'+sLineBreak - +'timeout means no timeout, and the function will wait'+sLineBreak - +'indefinitely.'+sLineBreak - +' '+sLineBreak - +' If the wait completes without a timeout, 0 is returned.'+sLineBreak - +'Passing NULL for the'+sLineBreak - +' gtid-list makes the function return NULL immediately,'+sLineBreak - +'without waiting.'+sLineBreak - +' '+sLineBreak - +'The gtid-list may be the empty string, in which case'+sLineBreak - +'MASTER_GTID_WAIT()'+sLineBreak - +'returns immediately. If the gtid-list contains fewer domains'+sLineBreak - +'than'+sLineBreak - +'gtid_slave_pos, then only those domains are waited upon. If'+sLineBreak - +'gtid-list'+sLineBreak - +'contains a domain that is not present in @@gtid_slave_pos,'+sLineBreak - +'then'+sLineBreak - +'MASTER_GTID_WAIT() will wait until an event containing such'+sLineBreak - +'domain_id arrives'+sLineBreak - +'on the slave (or until timed out or killed).'+sLineBreak - +' '+sLineBreak - +'MASTER_GTID_WAIT() can be useful to ensure that a slave has'+sLineBreak - +'caught up to'+sLineBreak - +'a master. Simply take the value of gtid_binlog_pos on the'+sLineBreak - +'master, and use it in a MASTER_GTID_WAIT() call on the'+sLineBreak - +'slave; when the call completes, the slave'+sLineBreak - +'will have caught up with that master position.'+sLineBreak - +' '+sLineBreak - +'MASTER_GTID_WAIT() can also be used in client applications'+sLineBreak - +'together with the'+sLineBreak - +'last_gtid session variable. This is useful in a'+sLineBreak - +'read-scaleout replication setup, where the application'+sLineBreak - +'writes to a single master but divides the'+sLineBreak - +'reads out to a number of slaves to distribute the load. In'+sLineBreak - +'such a setup, there'+sLineBreak - +'is a risk that an application could first do an update on'+sLineBreak - +'the master, and then'+sLineBreak - +'a bit later do a read on a slave, and if the slave is not'+sLineBreak - +'fast enough, the'+sLineBreak - +'data read from the slave might not include the update just'+sLineBreak - +'made, possibly'+sLineBreak - +'confusing the application and/or the end-user. One way to'+sLineBreak - +'avoid this is to'+sLineBreak - +'request the value of last_gtid on the master just after the'+sLineBreak - +'update. Then'+sLineBreak - +'before doing the read on the slave, do a MASTER_GTID_WAIT()'+sLineBreak - +'on the value'+sLineBreak - +'obtained from the master; this will ensure that the read is'+sLineBreak - +'not performed'+sLineBreak - +'until the slave has replicated sufficiently far for the'+sLineBreak - +'update to have become'+sLineBreak - +'visible.'+sLineBreak - +' '+sLineBreak - +'Note that MASTER_GTID_WAIT() can be used even if the slave'+sLineBreak - +'is configured not'+sLineBreak - +'to use GTID for connections (CHANGE MASTER TO'+sLineBreak - +'master_use_gtid=no). This is'+sLineBreak - +'because from MariaDB 10, GTIDs are always logged on the'+sLineBreak - +'master server, and'+sLineBreak - +'always recorded on the slave servers.'+sLineBreak - +' '+sLineBreak - +'Differences to MASTER_POS_WAIT()'+sLineBreak - +' '+sLineBreak - +'MASTER_GTID_WAIT() is global; it waits for any master'+sLineBreak - +'connection to reach'+sLineBreak - +' the specified GTID position. MASTER_POS_WAIT() works only'+sLineBreak - +'against a'+sLineBreak - +' specific connection. This also means that while'+sLineBreak - +'MASTER_POS_WAIT() aborts if'+sLineBreak - +' its master connection is terminated with STOP SLAVE or due'+sLineBreak - +'to an error,'+sLineBreak - +' MASTER_GTID_WAIT() continues to wait while slaves are'+sLineBreak - +'stopped.'+sLineBreak - +' '+sLineBreak - +'MASTER_GTID_WAIT() can take its timeout as a floating-point'+sLineBreak - +'value, so a'+sLineBreak - +' timeout in fractional seconds is supported, eg.'+sLineBreak - +'MASTER_GTID_WAIT("0-1-100",'+sLineBreak - +' 0.5). (The minimum wait is one microsecond, 0.000001'+sLineBreak - +'seconds).'+sLineBreak - +' '+sLineBreak - +'MASTER_GTID_WAIT() allows one to specify a timeout of zero'+sLineBreak - +'in order to do a'+sLineBreak - +' non-blocking check to see if the slaves have progressed to'+sLineBreak - +'a specific GTID position'+sLineBreak - +' (MASTER_POS_WAIT() takes a zero timeout as meaning an'+sLineBreak - +'infinite wait). To do'+sLineBreak - +' an infinite MASTER_GTID_WAIT(), specify a negative timeout,'+sLineBreak - +'or omit the'+sLineBreak - +' timeout argument.'+sLineBreak - +' '+sLineBreak - +'MASTER_GTID_WAIT() does not return the number of events'+sLineBreak - +'executed since the'+sLineBreak - +' wait started, nor does it return NULL if a slave thread is'+sLineBreak - +'stopped. It'+sLineBreak - +' always returns either 0 for successful wait completed, or'+sLineBreak - +'-1 for timeout'+sLineBreak - +' reached (or NULL if the specified gtid-pos is NULL).'+sLineBreak - +' '+sLineBreak - +'Since MASTER_GTID_WAIT() looks only at the seq_no part of'+sLineBreak - +'the GTIDs, not the'+sLineBreak - +'server_id, care is needed if a slave becomes diverged from'+sLineBreak - +'another server so'+sLineBreak - +'that two different GTIDs with the same seq_no (in the same'+sLineBreak - +'domain) arrive at'+sLineBreak - +'the same server. This situation is in any case best avoided;'+sLineBreak - +'setting'+sLineBreak - +'gtid_strict_mode is recommended, as this will prevent any'+sLineBreak - +'such out-of-order sequence numbers from ever being'+sLineBreak - +'replicated on a slave.' - ), - - ( - Name: 'MASTER_POS_WAIT'; - Declaration: '(log_name,log_pos[,timeout,["connection_name"]])'; - Category: 'Miscellaneous Functions'; - Version: SQL_VERSION_ANSI; - Description: 'This function is useful in replication for controlling'+sLineBreak - +'master/slave synchronization. It blocks until the slave has'+sLineBreak - +'read and applied all updates up to the specified position'+sLineBreak - +'(log_name,log_pos) in the master log. The return value is'+sLineBreak - +'the number of log events the slave had to wait for to'+sLineBreak - +'advance to the specified position. The function returns NULL'+sLineBreak - +'if'+sLineBreak - +'the slave SQL thread is not started, the slave''s master'+sLineBreak - +'information is not'+sLineBreak - +'initialized, the arguments are incorrect, or an error'+sLineBreak - +'occurs. It returns -1 if'+sLineBreak - +'the timeout has been exceeded. If the slave SQL thread stops'+sLineBreak - +'while'+sLineBreak - +' MASTER_POS_WAIT() is waiting, the function returns NULL. If'+sLineBreak - +'the slave is past the specified position, the function'+sLineBreak - +'returns immediately.'+sLineBreak - +' '+sLineBreak - +'If a timeout value is specified, MASTER_POS_WAIT() stops'+sLineBreak - +'waiting when timeout seconds have elapsed. timeout must be'+sLineBreak - +'greater than 0; a'+sLineBreak - +'zero or negative timeout means no timeout.'+sLineBreak - +' '+sLineBreak - +'The connection_name is used when you are using'+sLineBreak - +'multi-source-replication. If you don''t specify it, it''s'+sLineBreak - +'set to the value of the default_master_connection system'+sLineBreak - +'variable.'+sLineBreak - +' '+sLineBreak - +'Statements using the MASTER_POS_WAIT() function are not safe'+sLineBreak - +'for replication.' - ), - - ( - Name: 'NAME_CONST'; - Declaration: '(name,value)'; - Category: 'Miscellaneous Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the given value. When used to produce a result set'+sLineBreak - +'column,'+sLineBreak - +' NAME_CONST() causes the column to have the given name. The'+sLineBreak - +'arguments should be constants.'+sLineBreak - +' '+sLineBreak - +'This function is used internally when replicating stored'+sLineBreak - +'procedures. It makes little sense to use it explicitly in'+sLineBreak - +'SQL statements, and it was not supposed to be used like'+sLineBreak - +'that.'+sLineBreak - +' '+sLineBreak - +'SELECT NAME_CONST(''myname'', 14);'+sLineBreak - +'+--------+'+sLineBreak - +'| myname |'+sLineBreak - +'+--------+'+sLineBreak - +'| 14 |'+sLineBreak - +'+--------+' - ), - - ( - Name: 'RELEASE_LOCK'; - Declaration: '(str)'; - Category: 'Miscellaneous Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Releases the lock named by the string str that was obtained'+sLineBreak - +'with GET_LOCK(). Returns 1 if the lock was released, 0 if'+sLineBreak - +'the lock was not established by this thread (in which case'+sLineBreak - +'the lock is not'+sLineBreak - +'released), and NULL if the named lock did not exist. The'+sLineBreak - +'lock does not exist if it was never obtained by a call to'+sLineBreak - +'GET_LOCK() or if it has previously been released.'+sLineBreak - +' '+sLineBreak - +'MariaDB until 10.0.1'+sLineBreak - +' '+sLineBreak - +'Before 10.0.2, GET_LOCK() released the existing lock, if'+sLineBreak - +'any. Since 10.0.2 this does not happen, because multiple'+sLineBreak - +'locks are allowed.'+sLineBreak - +' '+sLineBreak - +'str is case insensitive. If str is an empty string or NULL,'+sLineBreak - +'RELEASE_LOCK() returns NULL and does nothing.'+sLineBreak - +' '+sLineBreak - +'Statements using the RELEASE_LOCK() function are not safe'+sLineBreak - +'for replication.'+sLineBreak - +' '+sLineBreak - +'The DO statement is convenient to use with RELEASE_LOCK().'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'Connection1:'+sLineBreak - +' '+sLineBreak - +'SELECT GET_LOCK(''lock1'',10);'+sLineBreak - +'+----------------------+'+sLineBreak - +'| GET_LOCK(''lock1'',10) |'+sLineBreak - +'+----------------------+'+sLineBreak - +'| 1 |'+sLineBreak - +'+----------------------+'+sLineBreak - +' '+sLineBreak - +'Connection 2:'+sLineBreak - +' '+sLineBreak - +'SELECT GET_LOCK(''lock2'',10);'+sLineBreak - +'+----------------------+'+sLineBreak - +'| GET_LOCK(''lock2'',10) |'+sLineBreak - +'+----------------------+'+sLineBreak - +'| 1 |'+sLineBreak - +'+----------------------+'+sLineBreak - +' '+sLineBreak - +'Connection 1:'+sLineBreak - +' '+sLineBreak - +'SELECT RELEASE_LOCK(''lock1''), RELEASE_LOCK(''lock2''),'+sLineBreak - +'RELEASE_LOCK(''lock3'');'+sLineBreak - +'+-----------------------+-----------------------+-----------------------+'+sLineBreak - +'| RELEASE_LOCK(''lock1'') | RELEASE_LOCK(''lock2'') |'+sLineBreak - +'RELEASE_LOCK(''lock3'') |'+sLineBreak - +'+-----------------------+-----------------------+-----------------------+'+sLineBreak - +'| 1 | 0 | NULL |'+sLineBreak - +'+-----------------------+-----------------------+-----------------------+'+sLineBreak - +' '+sLineBreak - +'From MariaDB 10.0.2, it is possible to hold the same lock'+sLineBreak - +'recursively. This example is viewed using the'+sLineBreak - +'metadata_lock_info plugin:'+sLineBreak - +' '+sLineBreak - +'SELECT GET_LOCK(''lock3'',10);'+sLineBreak - +'+----------------------+'+sLineBreak - +'| GET_LOCK(''lock3'',10) |'+sLineBreak - +'+----------------------+'+sLineBreak - +'| 1 |'+sLineBreak - +'+----------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT GET_LOCK(''lock3'',10);'+sLineBreak - +'+----------------------+'+sLineBreak - +'| GET_LOCK(''lock3'',10) |'+sLineBreak - +'+----------------------+'+sLineBreak - +'| 1 |'+sLineBreak - +'+----------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT * FROM INFORMATION_SCHEMA.METADATA_LOCK_INFO;'+sLineBreak - +' '+sLineBreak - +'+-----------+---------------------+---------------+-----------+--------------+------------+'+sLineBreak - +'| THREAD_ID | LOCK_MODE | LOCK_DURATION | LOCK_TYPE |'+sLineBreak - +'TABLE_SCHEMA | TABLE_NAME |'+sLineBreak - +'+-----------+---------------------+---------------+-----------+--------------+------------+'+sLineBreak - +'| 46 | MDL_SHARED_NO_WRITE | NULL | User lock | lock3 | |'+sLineBreak - +'+-----------+---------------------+---------------+-----------+--------------+------------+'+sLineBreak - +' '+sLineBreak - +'SELECT RELEASE_LOCK(''lock3'');'+sLineBreak - +'+-----------------------+'+sLineBreak - +'| RELEASE_LOCK(''lock3'') |'+sLineBreak - +'+-----------------------+'+sLineBreak - +'| 1 |'+sLineBreak - +'+-----------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT * FROM INFORMATION_SCHEMA.METADATA_LOCK_INFO;'+sLineBreak - +' '+sLineBreak - +'+-----------+---------------------+---------------+-----------+--------------+------------+'+sLineBreak - +'| THREAD_ID | LOCK_MODE | LOCK_DURATION | LOCK_TYPE |'+sLineBreak - +'TABLE_SCHEMA | TABLE_NAME |'+sLineBreak - +'+-----------+---------------------+---------------+-----------+--------------+------------+'+sLineBreak - +'| 46 | MDL_SHARED_NO_WRITE | NULL | User lock | lock3 | |'+sLineBreak - +'+-----------+---------------------+---------------+-----------+--------------+------------+'+sLineBreak - +' '+sLineBreak - +'SELECT RELEASE_LOCK(''lock3'');'+sLineBreak - +'+-----------------------+'+sLineBreak - +'| RELEASE_LOCK(''lock3'') |'+sLineBreak - +'+-----------------------+'+sLineBreak - +'| 1 |'+sLineBreak - +'+-----------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT * FROM INFORMATION_SCHEMA.METADATA_LOCK_INFO;'+sLineBreak - +' '+sLineBreak - +'Empty set (0.000 sec)' - ), - - ( - Name: 'SLEEP'; - Declaration: '(duration)'; - Category: 'Miscellaneous Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Sleeps (pauses) for the number of seconds given by the'+sLineBreak - +'duration argument, then'+sLineBreak - +'returns 0. If SLEEP() is interrupted, it'+sLineBreak - +'returns 1. The duration may have a fractional part given in'+sLineBreak - +'microseconds.'+sLineBreak - +' '+sLineBreak - +'Statements using the SLEEP() function are not safe for'+sLineBreak - +'replication.'+sLineBreak - +' '+sLineBreak - +'Example'+sLineBreak - +' '+sLineBreak - +'SELECT SLEEP(5.5);'+sLineBreak - +'+------------+'+sLineBreak - +'| SLEEP(5.5) |'+sLineBreak - +'+------------+'+sLineBreak - +'| 0 |'+sLineBreak - +'+------------+'+sLineBreak - +'1 row in set (5.50 sec)' - ), - - ( - Name: 'UUID'; - Declaration: '()'; - Category: 'Miscellaneous Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns a Universal Unique Identifier (UUID) generated'+sLineBreak - +'according to "DCE 1.1:'+sLineBreak - +'Remote Procedure Call" (Appendix A) CAE (Common'+sLineBreak - +'Applications Environment)'+sLineBreak - +'Specifications published by The Open Group in October'+sLineBreak - +'1997 '+sLineBreak - +'(Document Number C706).'+sLineBreak - +' '+sLineBreak - +'A UUID is designed as a number that is globally unique in'+sLineBreak - +'space and time. Two'+sLineBreak - +'calls to UUID() are expected to generate two different'+sLineBreak - +'values, even if these calls are performed on two separate'+sLineBreak - +'computers that are'+sLineBreak - +'not connected to each other.'+sLineBreak - +' '+sLineBreak - +'A UUID is a 128-bit number represented by a utf8 string of'+sLineBreak - +'five'+sLineBreak - +'hexadecimal numbers in aaaaaaaa-bbbb-cccc-dddd-eeeeeeeeeeee'+sLineBreak - +'format:'+sLineBreak - +'The first three numbers are generated from a timestamp.'+sLineBreak - +'The fourth number preserves temporal uniqueness in case the'+sLineBreak - +'timestamp value'+sLineBreak - +' loses monotonicity (for example, due to daylight saving'+sLineBreak - +'time).'+sLineBreak - +'The fifth number is an IEEE 802 node number that provides'+sLineBreak - +'spatial uniqueness.'+sLineBreak - +' A random number is substituted if the latter is not'+sLineBreak - +'available (for example,'+sLineBreak - +' because the host computer has no Ethernet card, or we do'+sLineBreak - +'not know how to find'+sLineBreak - +' the hardware address of an interface on your operating'+sLineBreak - +'system). In this case,'+sLineBreak - +' spatial uniqueness cannot be guaranteed. Nevertheless, a'+sLineBreak - +'collision should'+sLineBreak - +' have very low probability.'+sLineBreak - +' '+sLineBreak - +'Currently, the MAC address of an interface is taken into'+sLineBreak - +'account only on FreeBSD and Linux. On other operating'+sLineBreak - +'systems, MariaDB uses a randomly generated 48-bit number.'+sLineBreak - +' '+sLineBreak - +'Statements using the UUID() function are not safe for'+sLineBreak - +'replication.'+sLineBreak - +' '+sLineBreak - +'UUID() results are intended to be unique, but cannot always'+sLineBreak - +'be relied upon to unpredictable and unguessable, so should'+sLineBreak - +'not be relied upon for these purposes.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT UUID();'+sLineBreak - +'+--------------------------------------+'+sLineBreak - +'| UUID() |'+sLineBreak - +'+--------------------------------------+'+sLineBreak - +'| cd41294a-afb0-11df-bc9b-00241dd75637 |'+sLineBreak - +'+--------------------------------------+' - ), - - ( - Name: 'UUID_SHORT'; - Declaration: '()'; - Category: 'Miscellaneous Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns a "short" universal identifier as a 64-bit'+sLineBreak - +'unsigned integer (rather'+sLineBreak - +'than a string-form 128-bit identifier as returned by the'+sLineBreak - +'UUID() function).'+sLineBreak - +' '+sLineBreak - +'The value of UUID_SHORT() is guaranteed to be unique if the'+sLineBreak - +'following conditions hold:'+sLineBreak - +'The server_id of the current host is unique among your set'+sLineBreak - +'of master and'+sLineBreak - +' slave servers'+sLineBreak - +'server_id is between 0 and 255'+sLineBreak - +'You don''t set back your system time for your server between'+sLineBreak - +'mysqld restarts'+sLineBreak - +'You do not invoke UUID_SHORT() on average more than 16'+sLineBreak - +' million times per second between mysqld restarts'+sLineBreak - +' '+sLineBreak - +'The UUID_SHORT() return value is constructed this way:'+sLineBreak - +' '+sLineBreak - +' (server_id & 255)' - ), - - ( - Name: 'ABS'; - Declaration: '(X)'; - Category: 'Numeric Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the absolute (non-negative) value of X. If X is not'+sLineBreak - +'a number, it is converted to a numeric type.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT ABS(42);'+sLineBreak - +'+---------+'+sLineBreak - +'| ABS(42) |'+sLineBreak - +'+---------+'+sLineBreak - +'| 42 |'+sLineBreak - +'+---------+'+sLineBreak - +' '+sLineBreak - +'SELECT ABS(-42);'+sLineBreak - +'+----------+'+sLineBreak - +'| ABS(-42) |'+sLineBreak - +'+----------+'+sLineBreak - +'| 42 |'+sLineBreak - +'+----------+'+sLineBreak - +' '+sLineBreak - +'SELECT ABS(DATE ''1994-01-01'');'+sLineBreak - +'+------------------------+'+sLineBreak - +'| ABS(DATE ''1994-01-01'') |'+sLineBreak - +'+------------------------+'+sLineBreak - +'| 19940101 |'+sLineBreak - +'+------------------------+' - ), - - ( - Name: 'ACOS'; - Declaration: '(X)'; - Category: 'Numeric Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the arc cosine of X, that is, the value whose cosine'+sLineBreak - +'is X.'+sLineBreak - +'Returns NULL if X is not in the range -1 to 1.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT ACOS(1);'+sLineBreak - +'+---------+'+sLineBreak - +'| ACOS(1) |'+sLineBreak - +'+---------+'+sLineBreak - +'| 0 |'+sLineBreak - +'+---------+'+sLineBreak - +' '+sLineBreak - +'SELECT ACOS(1.0001);'+sLineBreak - +'+--------------+'+sLineBreak - +'| ACOS(1.0001) |'+sLineBreak - +'+--------------+'+sLineBreak - +'| NULL |'+sLineBreak - +'+--------------+'+sLineBreak - +' '+sLineBreak - +'SELECT ACOS(0);'+sLineBreak - +'+-----------------+'+sLineBreak - +'| ACOS(0) |'+sLineBreak - +'+-----------------+'+sLineBreak - +'| 1.5707963267949 |'+sLineBreak - +'+-----------------+'+sLineBreak - +' '+sLineBreak - +'SELECT ACOS(0.234);'+sLineBreak - +'+------------------+'+sLineBreak - +'| ACOS(0.234) |'+sLineBreak - +'+------------------+'+sLineBreak - +'| 1.33460644244679 |'+sLineBreak - +'+------------------+' - ), - - ( - Name: 'ASIN'; - Declaration: '(X)'; - Category: 'Numeric Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the arc sine of X, that is, the value whose sine is'+sLineBreak - +'X. Returns'+sLineBreak - +'NULL if X is not in the range -1 to 1.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT ASIN(0.2);'+sLineBreak - +'+--------------------+'+sLineBreak - +'| ASIN(0.2) |'+sLineBreak - +'+--------------------+'+sLineBreak - +'| 0.2013579207903308 |'+sLineBreak - +'+--------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT ASIN(''foo'');'+sLineBreak - +'+-------------+'+sLineBreak - +'| ASIN(''foo'') |'+sLineBreak - +'+-------------+'+sLineBreak - +'| 0 |'+sLineBreak - +'+-------------+'+sLineBreak - +' '+sLineBreak - +'SHOW WARNINGS;'+sLineBreak - +' '+sLineBreak - +'+---------+------+-----------------------------------------+'+sLineBreak - +'| Level | Code | Message |'+sLineBreak - +'+---------+------+-----------------------------------------+'+sLineBreak - +'| Warning | 1292 | Truncated incorrect DOUBLE value: ''foo'''+sLineBreak - +'|'+sLineBreak - +'+---------+------+-----------------------------------------+' - ), - - ( - Name: 'ATAN'; - Declaration: '(X)'; - Category: 'Numeric Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the arc tangent of X, that is, the value whose'+sLineBreak - +'tangent is X.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT ATAN(2);'+sLineBreak - +'+--------------------+'+sLineBreak - +'| ATAN(2) |'+sLineBreak - +'+--------------------+'+sLineBreak - +'| 1.1071487177940904 |'+sLineBreak - +'+--------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT ATAN(-2);'+sLineBreak - +'+---------------------+'+sLineBreak - +'| ATAN(-2) |'+sLineBreak - +'+---------------------+'+sLineBreak - +'| -1.1071487177940904 |'+sLineBreak - +'+---------------------+' - ), - - ( - Name: 'CEIL'; - Declaration: '(X)'; - Category: 'Numeric Functions'; - Version: SQL_VERSION_ANSI; - Description: 'CEIL() is a synonym for CEILING().' - ), - - ( - Name: 'CEILING'; - Declaration: '(X)'; - Category: 'Numeric Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the smallest integer value not less than X.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT CEILING(1.23);'+sLineBreak - +'+---------------+'+sLineBreak - +'| CEILING(1.23) |'+sLineBreak - +'+---------------+'+sLineBreak - +'| 2 |'+sLineBreak - +'+---------------+'+sLineBreak - +' '+sLineBreak - +'SELECT CEILING(-1.23);'+sLineBreak - +'+----------------+'+sLineBreak - +'| CEILING(-1.23) |'+sLineBreak - +'+----------------+'+sLineBreak - +'| -1 |'+sLineBreak - +'+----------------+' - ), - - ( - Name: 'CONV'; - Declaration: '(N,from_base,to_base)'; - Category: 'Numeric Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Converts numbers between different number bases. Returns a'+sLineBreak - +'string'+sLineBreak - +'representation of the number N, converted from base'+sLineBreak - +'from_base'+sLineBreak - +'to base to_base.'+sLineBreak - +' '+sLineBreak - +'Returns NULL if any argument is NULL, or if the second or'+sLineBreak - +'third argument are not in the allowed range.'+sLineBreak - +' '+sLineBreak - +'The argument N is interpreted as an integer, but may be'+sLineBreak - +'specified as an'+sLineBreak - +'integer or a string. The minimum base is 2 and the maximum'+sLineBreak - +'base is 36. If'+sLineBreak - +'to_base is a negative number, N is regarded as a signed'+sLineBreak - +'number.'+sLineBreak - +'Otherwise, N is treated as unsigned. CONV() works with'+sLineBreak - +'64-bit'+sLineBreak - +'precision.'+sLineBreak - +' '+sLineBreak - +'Some shortcuts for this function are also available: BIN(),'+sLineBreak - +'OCT(), HEX(), UNHEX(). Also, MariaDB allows binary literal'+sLineBreak - +'values and hexadecimal literal values.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT CONV(''a'',16,2);'+sLineBreak - +'+----------------+'+sLineBreak - +'| CONV(''a'',16,2) |'+sLineBreak - +'+----------------+'+sLineBreak - +'| 1010 |'+sLineBreak - +'+----------------+'+sLineBreak - +' '+sLineBreak - +'SELECT CONV(''6E'',18,8);'+sLineBreak - +'+-----------------+'+sLineBreak - +'| CONV(''6E'',18,8) |'+sLineBreak - +'+-----------------+'+sLineBreak - +'| 172 |'+sLineBreak - +'+-----------------+'+sLineBreak - +' '+sLineBreak - +'SELECT CONV(-17,10,-18);'+sLineBreak - +'+------------------+'+sLineBreak - +'| CONV(-17,10,-18) |'+sLineBreak - +'+------------------+'+sLineBreak - +'| -H |'+sLineBreak - +'+------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT CONV(12+''10''+''10''+0xa,10,10);'+sLineBreak - +'+------------------------------+'+sLineBreak - +'| CONV(12+''10''+''10''+0xa,10,10) |'+sLineBreak - +'+------------------------------+'+sLineBreak - +'| 42 |'+sLineBreak - +'+------------------------------+' - ), - - ( - Name: 'COS'; - Declaration: '(X)'; - Category: 'Numeric Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the cosine of X, where X is given in radians.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT COS(PI());'+sLineBreak - +'+-----------+'+sLineBreak - +'| COS(PI()) |'+sLineBreak - +'+-----------+'+sLineBreak - +'| -1 |'+sLineBreak - +'+-----------' - ), - - ( - Name: 'COT'; - Declaration: '(X)'; - Category: 'Numeric Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the cotangent of X.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT COT(42);'+sLineBreak - +'+--------------------+'+sLineBreak - +'| COT(42) |'+sLineBreak - +'+--------------------+'+sLineBreak - +'| 0.4364167060752729 |'+sLineBreak - +'+--------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT COT(12);'+sLineBreak - +'+---------------------+'+sLineBreak - +'| COT(12) |'+sLineBreak - +'+---------------------+'+sLineBreak - +'| -1.5726734063976893 |'+sLineBreak - +'+---------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT COT(0);'+sLineBreak - +'ERROR 1690 (22003): DOUBLE value is out of range in'+sLineBreak - +'''cot(0)''' - ), - - ( - Name: 'CRC32'; - Declaration: '(expr)'; - Category: 'Numeric Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Computes a cyclic redundancy check value and returns a'+sLineBreak - +'32-bit unsigned'+sLineBreak - +'value. The result is NULL if the argument is NULL. The'+sLineBreak - +'argument is'+sLineBreak - +'expected to be a string and (if possible) is treated as one'+sLineBreak - +'if it is'+sLineBreak - +'not.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT CRC32(''MariaDB'');'+sLineBreak - +'+------------------+'+sLineBreak - +'| CRC32(''MariaDB'') |'+sLineBreak - +'+------------------+'+sLineBreak - +'| 4227209140 |'+sLineBreak - +'+------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT CRC32(''mariadb'');'+sLineBreak - +'+------------------+'+sLineBreak - +'| CRC32(''mariadb'') |'+sLineBreak - +'+------------------+'+sLineBreak - +'| 2594253378 |'+sLineBreak - +'+------------------+' - ), - - ( - Name: 'DEGREES'; - Declaration: '(X)'; - Category: 'Numeric Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the argument X, converted from radians to degrees.'+sLineBreak - +' '+sLineBreak - +'This is the converse of the RADIANS() function.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT DEGREES(PI());'+sLineBreak - +'+---------------+'+sLineBreak - +'| DEGREES(PI()) |'+sLineBreak - +'+---------------+'+sLineBreak - +'| 180 |'+sLineBreak - +'+---------------+'+sLineBreak - +' '+sLineBreak - +'SELECT DEGREES(PI() / 2);'+sLineBreak - +'+-------------------+'+sLineBreak - +'| DEGREES(PI() / 2) |'+sLineBreak - +'+-------------------+'+sLineBreak - +'| 90 |'+sLineBreak - +'+-------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT DEGREES(45);'+sLineBreak - +'+-----------------+'+sLineBreak - +'| DEGREES(45) |'+sLineBreak - +'+-----------------+'+sLineBreak - +'| 2578.3100780887 |'+sLineBreak - +'+-----------------+' - ), - - ( - Name: 'EXP'; - Declaration: '(X)'; - Category: 'Numeric Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the value of e (the base of natural logarithms)'+sLineBreak - +'raised to the'+sLineBreak - +'power of X. The inverse of this function is LOG() (using a'+sLineBreak - +'single'+sLineBreak - +'argument only) or LN().'+sLineBreak - +' '+sLineBreak - +'If X is NULL, this function returns NULL.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT EXP(2);'+sLineBreak - +'+------------------+'+sLineBreak - +'| EXP(2) |'+sLineBreak - +'+------------------+'+sLineBreak - +'| 7.38905609893065 |'+sLineBreak - +'+------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT EXP(-2);'+sLineBreak - +'+--------------------+'+sLineBreak - +'| EXP(-2) |'+sLineBreak - +'+--------------------+'+sLineBreak - +'| 0.1353352832366127 |'+sLineBreak - +'+--------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT EXP(0);'+sLineBreak - +'+--------+'+sLineBreak - +'| EXP(0) |'+sLineBreak - +'+--------+'+sLineBreak - +'| 1 |'+sLineBreak - +'+--------+'+sLineBreak - +' '+sLineBreak - +'SELECT EXP(NULL);'+sLineBreak - +'+-----------+'+sLineBreak - +'| EXP(NULL) |'+sLineBreak - +'+-----------+'+sLineBreak - +'| NULL |'+sLineBreak - +'+-----------+' - ), - - ( - Name: 'FLOOR'; - Declaration: '(X)'; - Category: 'Numeric Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the largest integer value not greater than X.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT FLOOR(1.23);'+sLineBreak - +'+-------------+'+sLineBreak - +'| FLOOR(1.23) |'+sLineBreak - +'+-------------+'+sLineBreak - +'| 1 |'+sLineBreak - +'+-------------+'+sLineBreak - +' '+sLineBreak - +'SELECT FLOOR(-1.23);'+sLineBreak - +'+--------------+'+sLineBreak - +'| FLOOR(-1.23) |'+sLineBreak - +'+--------------+'+sLineBreak - +'| -2 |'+sLineBreak - +'+--------------+' - ), - - ( - Name: 'LN'; - Declaration: '(X)'; - Category: 'Numeric Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the natural logarithm of X; that is, the base-e'+sLineBreak - +'logarithm of X.'+sLineBreak - +'If X is less than or equal to 0, or NULL, then NULL is'+sLineBreak - +'returned.'+sLineBreak - +' '+sLineBreak - +'The inverse of this function is EXP().'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT LN(2);'+sLineBreak - +'+-------------------+'+sLineBreak - +'| LN(2) |'+sLineBreak - +'+-------------------+'+sLineBreak - +'| 0.693147180559945 |'+sLineBreak - +'+-------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT LN(-2);'+sLineBreak - +'+--------+'+sLineBreak - +'| LN(-2) |'+sLineBreak - +'+--------+'+sLineBreak - +'| NULL |'+sLineBreak - +'+--------+' - ), - - ( - Name: 'LOG'; - Declaration: '(X)'; - Category: 'Numeric Functions'; - Version: SQL_VERSION_ANSI; - Description: 'If called with one parameter, this function returns the'+sLineBreak - +'natural'+sLineBreak - +'logarithm of X. If X is less than or equal to 0, then NULL'+sLineBreak - +'is'+sLineBreak - +'returned.'+sLineBreak - +' '+sLineBreak - +'If called with two parameters, it returns the logarithm of X'+sLineBreak - +'to the base B. If B is' - ), - - ( - Name: 'LOG'; - Declaration: '(B,X)'; - Category: 'Numeric Functions'; - Version: SQL_VERSION_ANSI; - Description: 'If called with one parameter, this function returns the'+sLineBreak - +'natural'+sLineBreak - +'logarithm of X. If X is less than or equal to 0, then NULL'+sLineBreak - +'is'+sLineBreak - +'returned.'+sLineBreak - +' '+sLineBreak - +'If called with two parameters, it returns the logarithm of X'+sLineBreak - +'to the base B. If B is' - ), - - ( - Name: 'LOG10'; - Declaration: '(X)'; - Category: 'Numeric Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the base-10 logarithm of X.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT LOG10(2);'+sLineBreak - +'+-------------------+'+sLineBreak - +'| LOG10(2) |'+sLineBreak - +'+-------------------+'+sLineBreak - +'| 0.301029995663981 |'+sLineBreak - +'+-------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT LOG10(100);'+sLineBreak - +'+------------+'+sLineBreak - +'| LOG10(100) |'+sLineBreak - +'+------------+'+sLineBreak - +'| 2 |'+sLineBreak - +'+------------+'+sLineBreak - +' '+sLineBreak - +'SELECT LOG10(-100);'+sLineBreak - +'+-------------+'+sLineBreak - +'| LOG10(-100) |'+sLineBreak - +'+-------------+'+sLineBreak - +'| NULL |'+sLineBreak - +'+-------------+' - ), - - ( - Name: 'LOG2'; - Declaration: '(X)'; - Category: 'Numeric Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the base-2 logarithm of X.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT LOG2(4398046511104);'+sLineBreak - +'+---------------------+'+sLineBreak - +'| LOG2(4398046511104) |'+sLineBreak - +'+---------------------+'+sLineBreak - +'| 42 |'+sLineBreak - +'+---------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT LOG2(65536);'+sLineBreak - +'+-------------+'+sLineBreak - +'| LOG2(65536) |'+sLineBreak - +'+-------------+'+sLineBreak - +'| 16 |'+sLineBreak - +'+-------------+'+sLineBreak - +' '+sLineBreak - +'SELECT LOG2(-100);'+sLineBreak - +'+------------+'+sLineBreak - +'| LOG2(-100) |'+sLineBreak - +'+------------+'+sLineBreak - +'| NULL |'+sLineBreak - +'+------------+' - ), - - ( - Name: 'MOD'; - Declaration: '(N,M)'; - Category: 'Numeric Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Modulo operation. Returns the remainder of N divided by M.'+sLineBreak - +'See also Modulo Operator.'+sLineBreak - +' '+sLineBreak - +'If the ERROR_ON_DIVISION_BY_ZERO SQL_MODE is used, any'+sLineBreak - +'number modulus zero produces an error. Otherwise, it returns'+sLineBreak - +'NULL.'+sLineBreak - +' '+sLineBreak - +'The integer part of a division can be obtained using DIV.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT 1042 % 50;'+sLineBreak - +' '+sLineBreak - +'+-----------+'+sLineBreak - +'| 1042 % 50 |'+sLineBreak - +'+-----------+'+sLineBreak - +'| 42 |'+sLineBreak - +'+-----------+'+sLineBreak - +' '+sLineBreak - +'SELECT MOD(234, 10);'+sLineBreak - +'+--------------+'+sLineBreak - +'| MOD(234, 10) |'+sLineBreak - +'+--------------+'+sLineBreak - +'| 4 |'+sLineBreak - +'+--------------+'+sLineBreak - +' '+sLineBreak - +'SELECT 253 % 7;'+sLineBreak - +' '+sLineBreak - +'+---------+'+sLineBreak - +'| 253 % 7 |'+sLineBreak - +'+---------+'+sLineBreak - +'| 1 |'+sLineBreak - +'+---------+'+sLineBreak - +' '+sLineBreak - +'SELECT MOD(29,9);'+sLineBreak - +'+-----------+'+sLineBreak - +'| MOD(29,9) |'+sLineBreak - +'+-----------+'+sLineBreak - +'| 2 |'+sLineBreak - +'+-----------+'+sLineBreak - +' '+sLineBreak - +'SELECT 29 MOD 9;'+sLineBreak - +' '+sLineBreak - +'+----------+'+sLineBreak - +'| 29 MOD 9 |'+sLineBreak - +'+----------+'+sLineBreak - +'| 2 |'+sLineBreak - +'+----------+' - ), - - ( - Name: 'OCT'; - Declaration: '(N)'; - Category: 'Numeric Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns a string representation of the octal value of N,'+sLineBreak - +'where N is a longlong (BIGINT) number. This is equivalent to'+sLineBreak - +'CONV(N,10,8). Returns NULL if N is NULL.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT OCT(34);'+sLineBreak - +'+---------+'+sLineBreak - +'| OCT(34) |'+sLineBreak - +'+---------+'+sLineBreak - +'| 42 |'+sLineBreak - +'+---------+'+sLineBreak - +' '+sLineBreak - +'SELECT OCT(12);'+sLineBreak - +'+---------+'+sLineBreak - +'| OCT(12) |'+sLineBreak - +'+---------+'+sLineBreak - +'| 14 |'+sLineBreak - +'+---------+' - ), - - ( - Name: 'PI'; - Declaration: '()'; - Category: 'Numeric Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the value of ? (pi). The default number of decimal'+sLineBreak - +'places'+sLineBreak - +'displayed is six, but MariaDB uses the full double-precision'+sLineBreak - +'value'+sLineBreak - +'internally.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT PI();'+sLineBreak - +'+----------+'+sLineBreak - +'| PI() |'+sLineBreak - +'+----------+'+sLineBreak - +'| 3.141593 |'+sLineBreak - +'+----------+'+sLineBreak - +' '+sLineBreak - +'SELECT PI()+0.0000000000000000000000;'+sLineBreak - +' '+sLineBreak - +'+-------------------------------+'+sLineBreak - +'| PI()+0.0000000000000000000000 |'+sLineBreak - +'+-------------------------------+'+sLineBreak - +'| 3.1415926535897931159980 |'+sLineBreak - +'+-------------------------------+' - ), - - ( - Name: 'POW'; - Declaration: '(X,Y)'; - Category: 'Numeric Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the value of X raised to the power of Y.'+sLineBreak - +' '+sLineBreak - +'POWER() is a synonym.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT POW(2,3);'+sLineBreak - +'+----------+'+sLineBreak - +'| POW(2,3) |'+sLineBreak - +'+----------+'+sLineBreak - +'| 8 |'+sLineBreak - +'+----------+'+sLineBreak - +' '+sLineBreak - +'SELECT POW(2,-2);'+sLineBreak - +'+-----------+'+sLineBreak - +'| POW(2,-2) |'+sLineBreak - +'+-----------+'+sLineBreak - +'| 0.25 |'+sLineBreak - +'+-----------+' - ), - - ( - Name: 'POWER'; - Declaration: '(X,Y)'; - Category: 'Numeric Functions'; - Version: SQL_VERSION_ANSI; - Description: 'This is a synonym for POW(), which returns the value of X'+sLineBreak - +'raised to the power of Y.' - ), - - ( - Name: 'RADIANS'; - Declaration: '(X)'; - Category: 'Numeric Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the argument X, converted from degrees to radians.'+sLineBreak - +'Note that'+sLineBreak - +'? radians equals 180 degrees. '+sLineBreak - +' '+sLineBreak - +'This is the converse of the DEGREES() function.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT RADIANS(45);'+sLineBreak - +'+-------------------+'+sLineBreak - +'| RADIANS(45) |'+sLineBreak - +'+-------------------+'+sLineBreak - +'| 0.785398163397448 |'+sLineBreak - +'+-------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT RADIANS(90);'+sLineBreak - +'+-----------------+'+sLineBreak - +'| RADIANS(90) |'+sLineBreak - +'+-----------------+'+sLineBreak - +'| 1.5707963267949 |'+sLineBreak - +'+-----------------+'+sLineBreak - +' '+sLineBreak - +'SELECT RADIANS(PI());'+sLineBreak - +'+--------------------+'+sLineBreak - +'| RADIANS(PI()) |'+sLineBreak - +'+--------------------+'+sLineBreak - +'| 0.0548311355616075 |'+sLineBreak - +'+--------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT RADIANS(180);'+sLineBreak - +'+------------------+'+sLineBreak - +'| RADIANS(180) |'+sLineBreak - +'+------------------+'+sLineBreak - +'| 3.14159265358979 |'+sLineBreak - +'+------------------+' - ), - - ( - Name: 'RAND'; - Declaration: '()'; - Category: 'Numeric Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns a random DOUBLE precision floating point value v in'+sLineBreak - +'the range 0' - ), - - ( - Name: 'RAND'; - Declaration: '(N)'; - Category: 'Numeric Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns a random DOUBLE precision floating point value v in'+sLineBreak - +'the range 0' - ), - - ( - Name: 'ROUND'; - Declaration: '(X)'; - Category: 'Numeric Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Rounds the argument X to D decimal places. The rounding'+sLineBreak - +'algorithm'+sLineBreak - +'depends on the data type of X. D defaults to 0 if not'+sLineBreak - +'specified.'+sLineBreak - +'D can be negative to cause D digits left of the decimal'+sLineBreak - +'point of the'+sLineBreak - +'value X to become zero.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT ROUND(-1.23);'+sLineBreak - +'+--------------+'+sLineBreak - +'| ROUND(-1.23) |'+sLineBreak - +'+--------------+'+sLineBreak - +'| -1 |'+sLineBreak - +'+--------------+'+sLineBreak - +' '+sLineBreak - +'SELECT ROUND(-1.58);'+sLineBreak - +'+--------------+'+sLineBreak - +'| ROUND(-1.58) |'+sLineBreak - +'+--------------+'+sLineBreak - +'| -2 |'+sLineBreak - +'+--------------+'+sLineBreak - +' '+sLineBreak - +'SELECT ROUND(1.58); '+sLineBreak - +'+-------------+'+sLineBreak - +'| ROUND(1.58) |'+sLineBreak - +'+-------------+'+sLineBreak - +'| 2 |'+sLineBreak - +'+-------------+'+sLineBreak - +' '+sLineBreak - +'SELECT ROUND(1.298, 1);'+sLineBreak - +'+-----------------+'+sLineBreak - +'| ROUND(1.298, 1) |'+sLineBreak - +'+-----------------+'+sLineBreak - +'| 1.3 |'+sLineBreak - +'+-----------------+'+sLineBreak - +' '+sLineBreak - +'SELECT ROUND(1.298, 0);'+sLineBreak - +'+-----------------+'+sLineBreak - +'| ROUND(1.298, 0) |'+sLineBreak - +'+-----------------+'+sLineBreak - +'| 1 |'+sLineBreak - +'+-----------------+'+sLineBreak - +' '+sLineBreak - +'SELECT ROUND(23.298, -1);'+sLineBreak - +'+-------------------+'+sLineBreak - +'| ROUND(23.298, -1) |'+sLineBreak - +'+-------------------+'+sLineBreak - +'| 20 |'+sLineBreak - +'+-------------------+' - ), - - ( - Name: 'ROUND'; - Declaration: '(X,D)'; - Category: 'Numeric Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Rounds the argument X to D decimal places. The rounding'+sLineBreak - +'algorithm'+sLineBreak - +'depends on the data type of X. D defaults to 0 if not'+sLineBreak - +'specified.'+sLineBreak - +'D can be negative to cause D digits left of the decimal'+sLineBreak - +'point of the'+sLineBreak - +'value X to become zero.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT ROUND(-1.23);'+sLineBreak - +'+--------------+'+sLineBreak - +'| ROUND(-1.23) |'+sLineBreak - +'+--------------+'+sLineBreak - +'| -1 |'+sLineBreak - +'+--------------+'+sLineBreak - +' '+sLineBreak - +'SELECT ROUND(-1.58);'+sLineBreak - +'+--------------+'+sLineBreak - +'| ROUND(-1.58) |'+sLineBreak - +'+--------------+'+sLineBreak - +'| -2 |'+sLineBreak - +'+--------------+'+sLineBreak - +' '+sLineBreak - +'SELECT ROUND(1.58); '+sLineBreak - +'+-------------+'+sLineBreak - +'| ROUND(1.58) |'+sLineBreak - +'+-------------+'+sLineBreak - +'| 2 |'+sLineBreak - +'+-------------+'+sLineBreak - +' '+sLineBreak - +'SELECT ROUND(1.298, 1);'+sLineBreak - +'+-----------------+'+sLineBreak - +'| ROUND(1.298, 1) |'+sLineBreak - +'+-----------------+'+sLineBreak - +'| 1.3 |'+sLineBreak - +'+-----------------+'+sLineBreak - +' '+sLineBreak - +'SELECT ROUND(1.298, 0);'+sLineBreak - +'+-----------------+'+sLineBreak - +'| ROUND(1.298, 0) |'+sLineBreak - +'+-----------------+'+sLineBreak - +'| 1 |'+sLineBreak - +'+-----------------+'+sLineBreak - +' '+sLineBreak - +'SELECT ROUND(23.298, -1);'+sLineBreak - +'+-------------------+'+sLineBreak - +'| ROUND(23.298, -1) |'+sLineBreak - +'+-------------------+'+sLineBreak - +'| 20 |'+sLineBreak - +'+-------------------+' - ), - - ( - Name: 'SIGN'; - Declaration: '(X)'; - Category: 'Numeric Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the sign of the argument as -1, 0, or 1, depending'+sLineBreak - +'on whether'+sLineBreak - +'X is negative, zero, or positive.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT SIGN(-32);'+sLineBreak - +'+-----------+'+sLineBreak - +'| SIGN(-32) |'+sLineBreak - +'+-----------+'+sLineBreak - +'| -1 |'+sLineBreak - +'+-----------+'+sLineBreak - +' '+sLineBreak - +'SELECT SIGN(0);'+sLineBreak - +'+---------+'+sLineBreak - +'| SIGN(0) |'+sLineBreak - +'+---------+'+sLineBreak - +'| 0 |'+sLineBreak - +'+---------+'+sLineBreak - +' '+sLineBreak - +'SELECT SIGN(234);'+sLineBreak - +'+-----------+'+sLineBreak - +'| SIGN(234) |'+sLineBreak - +'+-----------+'+sLineBreak - +'| 1 |'+sLineBreak - +'+-----------+' - ), - - ( - Name: 'SIN'; - Declaration: '(X)'; - Category: 'Numeric Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the sine of X, where X is given in radians.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT SIN(1.5707963267948966);'+sLineBreak - +'+-------------------------+'+sLineBreak - +'| SIN(1.5707963267948966) |'+sLineBreak - +'+-------------------------+'+sLineBreak - +'| 1 |'+sLineBreak - +'+-------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT SIN(PI());'+sLineBreak - +'+----------------------+'+sLineBreak - +'| SIN(PI()) |'+sLineBreak - +'+----------------------+'+sLineBreak - +'| 1.22460635382238e-16 |'+sLineBreak - +'+----------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT ROUND(SIN(PI()));'+sLineBreak - +'+------------------+'+sLineBreak - +'| ROUND(SIN(PI())) |'+sLineBreak - +'+------------------+'+sLineBreak - +'| 0 |'+sLineBreak - +'+------------------+' - ), - - ( - Name: 'SQRT'; - Declaration: '(X)'; - Category: 'Numeric Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the square root of X. If X is negative, NULL is'+sLineBreak - +'returned.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT SQRT(4);'+sLineBreak - +'+---------+'+sLineBreak - +'| SQRT(4) |'+sLineBreak - +'+---------+'+sLineBreak - +'| 2 |'+sLineBreak - +'+---------+'+sLineBreak - +' '+sLineBreak - +'SELECT SQRT(20);'+sLineBreak - +'+------------------+'+sLineBreak - +'| SQRT(20) |'+sLineBreak - +'+------------------+'+sLineBreak - +'| 4.47213595499958 |'+sLineBreak - +'+------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT SQRT(-16);'+sLineBreak - +'+-----------+'+sLineBreak - +'| SQRT(-16) |'+sLineBreak - +'+-----------+'+sLineBreak - +'| NULL |'+sLineBreak - +'+-----------+'+sLineBreak - +' '+sLineBreak - +'SELECT SQRT(1764);'+sLineBreak - +'+------------+'+sLineBreak - +'| SQRT(1764) |'+sLineBreak - +'+------------+'+sLineBreak - +'| 42 |'+sLineBreak - +'+------------+' - ), - - ( - Name: 'TAN'; - Declaration: '(X)'; - Category: 'Numeric Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the tangent of X, where X is given in radians.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT TAN(0.7853981633974483);'+sLineBreak - +'+-------------------------+'+sLineBreak - +'| TAN(0.7853981633974483) |'+sLineBreak - +'+-------------------------+'+sLineBreak - +'| 0.9999999999999999 |'+sLineBreak - +'+-------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT TAN(PI());'+sLineBreak - +'+-----------------------+'+sLineBreak - +'| TAN(PI()) |'+sLineBreak - +'+-----------------------+'+sLineBreak - +'| -1.22460635382238e-16 |'+sLineBreak - +'+-----------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT TAN(PI()+1);'+sLineBreak - +'+-----------------+'+sLineBreak - +'| TAN(PI()+1) |'+sLineBreak - +'+-----------------+'+sLineBreak - +'| 1.5574077246549 |'+sLineBreak - +'+-----------------+'+sLineBreak - +' '+sLineBreak - +'SELECT TAN(RADIANS(PI()));'+sLineBreak - +'+--------------------+'+sLineBreak - +'| TAN(RADIANS(PI())) |'+sLineBreak - +'+--------------------+'+sLineBreak - +'| 0.0548861508080033 |'+sLineBreak - +'+--------------------+' - ), - - ( - Name: 'TRUNCATE'; - Declaration: '(X,D)'; - Category: 'Numeric Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the number X, truncated to D decimal places. If D is'+sLineBreak - +'0, the'+sLineBreak - +'result has no decimal point or fractional part. D can be'+sLineBreak - +'negative to'+sLineBreak - +'cause D digits left of the decimal point of the value X to'+sLineBreak - +'become'+sLineBreak - +'zero.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT TRUNCATE(1.223,1);'+sLineBreak - +'+-------------------+'+sLineBreak - +'| TRUNCATE(1.223,1) |'+sLineBreak - +'+-------------------+'+sLineBreak - +'| 1.2 |'+sLineBreak - +'+-------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT TRUNCATE(1.999,1);'+sLineBreak - +'+-------------------+'+sLineBreak - +'| TRUNCATE(1.999,1) |'+sLineBreak - +'+-------------------+'+sLineBreak - +'| 1.9 |'+sLineBreak - +'+-------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT TRUNCATE(1.999,0); '+sLineBreak - +'+-------------------+'+sLineBreak - +'| TRUNCATE(1.999,0) |'+sLineBreak - +'+-------------------+'+sLineBreak - +'| 1 |'+sLineBreak - +'+-------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT TRUNCATE(-1.999,1);'+sLineBreak - +'+--------------------+'+sLineBreak - +'| TRUNCATE(-1.999,1) |'+sLineBreak - +'+--------------------+'+sLineBreak - +'| -1.9 |'+sLineBreak - +'+--------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT TRUNCATE(122,-2);'+sLineBreak - +'+------------------+'+sLineBreak - +'| TRUNCATE(122,-2) |'+sLineBreak - +'+------------------+'+sLineBreak - +'| 100 |'+sLineBreak - +'+------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT TRUNCATE(10.28*100,0);'+sLineBreak - +'+-----------------------+'+sLineBreak - +'| TRUNCATE(10.28*100,0) |'+sLineBreak - +'+-----------------------+'+sLineBreak - +'| 1028 |'+sLineBreak - +'+-----------------------+' - ), - - ( - Name: 'ST_X'; - Declaration: '(p)'; - Category: 'Point Properties'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the X-coordinate value for the point p as a'+sLineBreak - +'double-precision number.'+sLineBreak - +' '+sLineBreak - +'ST_X() and X() are synonyms.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SET @pt = ''Point(56.7 53.34)'';'+sLineBreak - +' '+sLineBreak - +'SELECT X(GeomFromText(@pt));'+sLineBreak - +'+----------------------+'+sLineBreak - +'| X(GeomFromText(@pt)) |'+sLineBreak - +'+----------------------+'+sLineBreak - +'| 56.7 |'+sLineBreak - +'+----------------------+' - ), - - ( - Name: 'ST_Y'; - Declaration: '(p)'; - Category: 'Point Properties'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the Y-coordinate value for the point p as a'+sLineBreak - +'double-precision number.'+sLineBreak - +' '+sLineBreak - +'ST_Y() and Y() are synonyms.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SET @pt = ''Point(56.7 53.34)'';'+sLineBreak - +' '+sLineBreak - +'SELECT Y(GeomFromText(@pt));'+sLineBreak - +'+----------------------+'+sLineBreak - +'| Y(GeomFromText(@pt)) |'+sLineBreak - +'+----------------------+'+sLineBreak - +'| 53.34 |'+sLineBreak - +'+----------------------+' - ), - - ( - Name: 'ST_AREA'; - Declaration: '(poly)'; - Category: 'Polygon Properties'; - Version: SQL_VERSION_ANSI; - Description: 'Returns as a double-precision number the area of the Polygon'+sLineBreak - +'value poly, as measured in its spatial reference system.'+sLineBreak - +' '+sLineBreak - +'ST_Area() and Area() are synonyms.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SET @poly = ''Polygon((0 0,0 3,3 0,0 0),(1 1,1 2,2 1,1'+sLineBreak - +'1))'';'+sLineBreak - +' '+sLineBreak - +'SELECT Area(GeomFromText(@poly));'+sLineBreak - +'+---------------------------+'+sLineBreak - +'| Area(GeomFromText(@poly)) |'+sLineBreak - +'+---------------------------+'+sLineBreak - +'| 4 |'+sLineBreak - +'+---------------------------+' - ), - - ( - Name: 'ST_CENTROID'; - Declaration: '(mpoly)'; - Category: 'Polygon Properties'; - Version: SQL_VERSION_ANSI; - Description: 'Returns a point reflecting the mathematical centroid'+sLineBreak - +'(geometric center) for the MultiPolygon mpoly. The resulting'+sLineBreak - +'point will not necessarily be on the MultiPolygon. '+sLineBreak - +' '+sLineBreak - +'ST_Centroid() and Centroid() are synonyms.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SET @poly = ST_GeomFromText(''POLYGON((0 0,20 0,20 20,0 20,0'+sLineBreak - +'0))'');'+sLineBreak - +'SELECT ST_AsText(ST_Centroid(@poly)) AS center;'+sLineBreak - +' '+sLineBreak - +'+--------------+'+sLineBreak - +'| center |'+sLineBreak - +'+--------------+'+sLineBreak - +'| POINT(10 10) |'+sLineBreak - +'+--------------+' - ), - - ( - Name: 'ST_ExteriorRing'; - Declaration: '(poly)'; - Category: 'Polygon Properties'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the exterior ring of the Polygon value poly as a'+sLineBreak - +'LineString.'+sLineBreak - +' '+sLineBreak - +'ST_ExteriorRing() and ExteriorRing() are synonyms.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SET @poly = ''Polygon((0 0,0 3,3 3,3 0,0 0),(1 1,1 2,2 2,2'+sLineBreak - +'1,1 1))'';'+sLineBreak - +' '+sLineBreak - +'SELECT AsText(ExteriorRing(GeomFromText(@poly)));'+sLineBreak - +'+-------------------------------------------+'+sLineBreak - +'| AsText(ExteriorRing(GeomFromText(@poly))) |'+sLineBreak - +'+-------------------------------------------+'+sLineBreak - +'| LINESTRING(0 0,0 3,3 3,3 0,0 0) |'+sLineBreak - +'+-------------------------------------------+' - ), - - ( - Name: 'ST_InteriorRingN'; - Declaration: '(poly,N)'; - Category: 'Polygon Properties'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the N-th interior ring for the Polygon value poly as'+sLineBreak - +'a LineString. Rings are numbered beginning with 1.'+sLineBreak - +' '+sLineBreak - +'ST_InteriorRingN() and InteriorRingN() are synonyms.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SET @poly = ''Polygon((0 0,0 3,3 3,3 0,0 0),(1 1,1 2,2 2,2'+sLineBreak - +'1,1 1))'';'+sLineBreak - +' '+sLineBreak - +'SELECT AsText(InteriorRingN(GeomFromText(@poly),1));'+sLineBreak - +'+----------------------------------------------+'+sLineBreak - +'| AsText(InteriorRingN(GeomFromText(@poly),1)) |'+sLineBreak - +'+----------------------------------------------+'+sLineBreak - +'| LINESTRING(1 1,1 2,2 2,2 1,1 1) |'+sLineBreak - +'+----------------------------------------------+' - ), - - ( - Name: 'ST_NumInteriorRings'; - Declaration: '(poly)'; - Category: 'Polygon Properties'; - Version: SQL_VERSION_ANSI; - Description: 'Returns an integer containing the number of interior rings'+sLineBreak - +'in the Polygon value poly.'+sLineBreak - +' '+sLineBreak - +'Note that according the the OpenGIS standard, a POLYGON'+sLineBreak - +'should have exactly one ExteriorRing and all other rings'+sLineBreak - +'should lie within that ExteriorRing and thus be the'+sLineBreak - +'InteriorRings. Practically, however, some systems, including'+sLineBreak - +'MariaDB''s, permit polygons to have several'+sLineBreak - +'''ExteriorRings''. In the case of there being multiple,'+sLineBreak - +'non-overlapping exterior rings ST_NumInteriorRings() will'+sLineBreak - +'return 1.'+sLineBreak - +' '+sLineBreak - +'ST_NumInteriorRings() and NumInteriorRings() are synonyms.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SET @poly = ''Polygon((0 0,0 3,3 3,3 0,0 0),(1 1,1 2,2 2,2'+sLineBreak - +'1,1 1))'';'+sLineBreak - +' '+sLineBreak - +'SELECT NumInteriorRings(GeomFromText(@poly));'+sLineBreak - +'+---------------------------------------+'+sLineBreak - +'| NumInteriorRings(GeomFromText(@poly)) |'+sLineBreak - +'+---------------------------------------+'+sLineBreak - +'| 1 |'+sLineBreak - +'+---------------------------------------+'+sLineBreak - +' '+sLineBreak - +'Non-overlapping ''polygon'':'+sLineBreak - +' '+sLineBreak - +'SELECT ST_NumInteriorRings(ST_PolyFromText(''POLYGON((0 0,10'+sLineBreak - +'0,10 10,0 10,0 0),'+sLineBreak - +' (-1 -1,-5 -1,-5 -5,-1 -5,-1 -1))'')) AS NumInteriorRings;'+sLineBreak - +' '+sLineBreak - +'+------------------+'+sLineBreak - +'| NumInteriorRings |'+sLineBreak - +'+------------------+'+sLineBreak - +'| 1 |'+sLineBreak - +'+------------------+' - ), - - ( - Name: 'SPIDER_BG_DIRECT_SQL'; - Declaration: '(''sql'', ''tmp_table_list'', ''parameters'')'; - Category: 'Spider Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Executes the given SQL statement in the background on the'+sLineBreak - +'remote server, as defined in the parameters listing. If the'+sLineBreak - +'query returns a result-set, it sttores the results in the'+sLineBreak - +'given temporary table. When the given SQL statement executes'+sLineBreak - +'successfully, this function returns the number of called'+sLineBreak - +'UDF''s. It returns 0 when the given SQL statement fails.'+sLineBreak - +' '+sLineBreak - +'This function is a UDF installed with the Spider storage'+sLineBreak - +'engine.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT SPIDER_BG_DIRECT_SQL(''SELECT * FROM example_table'','+sLineBreak - +''''', '+sLineBreak - +' ''srv "node1", port "8607"'') AS "Direct Query";'+sLineBreak - +'+--------------+'+sLineBreak - +'| Direct Query | '+sLineBreak - +'+--------------+'+sLineBreak - +'| 1 |'+sLineBreak - +'+--------------+'+sLineBreak - +' '+sLineBreak - +'Parameters'+sLineBreak - +' '+sLineBreak - +'error_rw_mode'+sLineBreak - +' '+sLineBreak - +'Description: Returns empty results on network error.'+sLineBreak - +'0 : Return error on getting network error.'+sLineBreak - +'1: Return 0 records on getting network error.'+sLineBreak - +' '+sLineBreak - +'Default Table Value: 0'+sLineBreak - +'DSN Parameter Name: erwm' - ), - - ( - Name: 'SPIDER_COPY_TABLES'; - Declaration: '(spider_table_name, source_link_id, destination_link_id_list [,parameters])'; - Category: 'Spider Functions'; - Version: SQL_VERSION_ANSI; - Description: 'A UDF installed with the Spider Storage Engine, this'+sLineBreak - +'function copies table data from source_link_id to'+sLineBreak - +'destination_link_id_list. The service does not need to be'+sLineBreak - +'stopped in order to copy.'+sLineBreak - +' '+sLineBreak - +'If the Spider table is partitioned, the name must be of the'+sLineBreak - +'format table_name#P#partition_name. The partition name can'+sLineBreak - +'be viewed in the mysql.spider_tables table, for example:'+sLineBreak - +' '+sLineBreak - +'SELECT table_name FROM mysql.spider_tables;'+sLineBreak - +'+-------------+'+sLineBreak - +'| table_name |'+sLineBreak - +'+-------------+'+sLineBreak - +'| spt_a#P#pt1 |'+sLineBreak - +'| spt_a#P#pt2 |'+sLineBreak - +'| spt_a#P#pt3 |'+sLineBreak - +'+-------------+'+sLineBreak - +' '+sLineBreak - +'Returns 1 if the data was copied successfully, or 0 if'+sLineBreak - +'copying the data failed.' - ), - - ( - Name: 'SPIDER_DIRECT_SQL'; - Declaration: '(''sql'', ''tmp_table_list'', ''parameters'')'; - Category: 'Spider Functions'; - Version: SQL_VERSION_ANSI; - Description: 'A UDF installed with the Spider Storage Engine, this'+sLineBreak - +'function is used to execute the SQL string sql on the remote'+sLineBreak - +'server, as defined in parameters. If any resultsets are'+sLineBreak - +'returned, they are stored in the tmp_table_list.'+sLineBreak - +' '+sLineBreak - +'The function returns 1 if the SQL executes successfully, or'+sLineBreak - +'0 if it fails.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT SPIDER_DIRECT_SQL(''SELECT * FROM s'', '''', ''srv'+sLineBreak - +'"node1", port "8607"'');'+sLineBreak - +'+----------------------------------------------------------------------+'+sLineBreak - +'| SPIDER_DIRECT_SQL(''SELECT * FROM s'', '''', ''srv'+sLineBreak - +'"node1", port "8607"'') |'+sLineBreak - +'+----------------------------------------------------------------------+'+sLineBreak - +'| 1 |'+sLineBreak - +'+----------------------------------------------------------------------+' - ), - - ( - Name: 'SPIDER_FLUSH_TABLE_MON_CACHE'; - Declaration: '()'; - Category: 'Spider Functions'; - Version: SQL_VERSION_ANSI; - Description: 'A UDF installed with the Spider Storage Engine, this'+sLineBreak - +'function is used for refreshing monitoring server'+sLineBreak - +'information. It returns a value of 1.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT SPIDER_FLUSH_TABLE_MON_CACHE();'+sLineBreak - +'+--------------------------------+'+sLineBreak - +'| SPIDER_FLUSH_TABLE_MON_CACHE() |'+sLineBreak - +'+--------------------------------+'+sLineBreak - +'| 1 |'+sLineBreak - +'+--------------------------------+' - ), - - ( - Name: 'ASCII'; - Declaration: '(str)'; - Category: 'String Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the numeric ASCII value of the leftmost character of'+sLineBreak - +'the string argument. Returns 0 if the given string is empty'+sLineBreak - +'and NULL if it is NULL.'+sLineBreak - +' '+sLineBreak - +'ASCII() works for 8-bit characters.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT ASCII(9);'+sLineBreak - +'+----------+'+sLineBreak - +'| ASCII(9) |'+sLineBreak - +'+----------+'+sLineBreak - +'| 57 |'+sLineBreak - +'+----------+'+sLineBreak - +' '+sLineBreak - +'SELECT ASCII(''9'');'+sLineBreak - +'+------------+'+sLineBreak - +'| ASCII(''9'') |'+sLineBreak - +'+------------+'+sLineBreak - +'| 57 |'+sLineBreak - +'+------------+'+sLineBreak - +' '+sLineBreak - +'SELECT ASCII(''abc'');'+sLineBreak - +'+--------------+'+sLineBreak - +'| ASCII(''abc'') |'+sLineBreak - +'+--------------+'+sLineBreak - +'| 97 |'+sLineBreak - +'+--------------+' - ), - - ( - Name: 'BIN'; - Declaration: '(N)'; - Category: 'String Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns a string representation of the binary value of the'+sLineBreak - +'given longlong (that is, BIGINT) number. This is equivalent'+sLineBreak - +'to CONV(N,10,2). The argument should be positive. If it is a'+sLineBreak - +'FLOAT, it will be truncated. Returns NULL if the argument is'+sLineBreak - +'NULL.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT BIN(12);'+sLineBreak - +'+---------+'+sLineBreak - +'| BIN(12) |'+sLineBreak - +'+---------+'+sLineBreak - +'| 1100 |'+sLineBreak - +'+---------+' - ), - - ( - Name: 'BIT_LENGTH'; - Declaration: '(str)'; - Category: 'String Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the length of the given string argument in bits. If'+sLineBreak - +'the argument is not a string, it will be converted to'+sLineBreak - +'string. If the argument is NULL, it returns NULL.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT BIT_LENGTH(''text'');'+sLineBreak - +'+--------------------+'+sLineBreak - +'| BIT_LENGTH(''text'') |'+sLineBreak - +'+--------------------+'+sLineBreak - +'| 32 |'+sLineBreak - +'+--------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT BIT_LENGTH('''');'+sLineBreak - +'+----------------+'+sLineBreak - +'| BIT_LENGTH('''') |'+sLineBreak - +'+----------------+'+sLineBreak - +'| 0 |'+sLineBreak - +'+----------------+'+sLineBreak - +' '+sLineBreak - +'Compatibility'+sLineBreak - +' '+sLineBreak - +'PostgreSQL and Sybase support BIT_LENGTH().' - ), - - ( - Name: 'CAST'; - Declaration: '(expr AS type)'; - Category: 'String Functions'; - Version: SQL_VERSION_ANSI; - Description: 'The CAST() function takes a value of one type and produces a'+sLineBreak - +'value of another type, similar to the CONVERT() function.'+sLineBreak - +'For more information, see the description of CONVERT(). '+sLineBreak - +' '+sLineBreak - +'The main difference between the CAST() and CONVERT() is that'+sLineBreak - +'CONVERT(expr,type) is ODBC syntax while CAST(expr as type)'+sLineBreak - +'and CONVERT(... USING ...) are SQL92 syntax.'+sLineBreak - +' '+sLineBreak - +'In MariaDB 10.4 and later, you can use the CAST() function'+sLineBreak - +'with the INTERVAL keyword.'+sLineBreak - +' '+sLineBreak - +'Until MariaDB 5.5.31, X''HHHH'', the standard SQL syntax for'+sLineBreak - +'binary string literals, erroneously worked in the same way'+sLineBreak - +'as 0xHHHH. In 5.5.31 it was intentionally changed to behave'+sLineBreak - +'as a string in all contexts (and never as a number).'+sLineBreak - +' '+sLineBreak - +'This introduces an incompatibility with previous versions of'+sLineBreak - +'MariaDB, and all versions of MySQL (see the example below). '+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'Simple casts:'+sLineBreak - +' '+sLineBreak - +'SELECT CAST("abc" AS BINARY);'+sLineBreak - +'SELECT CAST("1" AS UNSIGNED INTEGER);'+sLineBreak - +'SELECT CAST(123 AS CHAR CHARACTER SET utf8)'+sLineBreak - +' '+sLineBreak - +'Note that when one casts to CHAR without specifying the'+sLineBreak - +'character set, the collation_connection character set'+sLineBreak - +'collation will be used. When used with CHAR CHARACTER SET,'+sLineBreak - +'the default collation for that character set will be used.'+sLineBreak - +' '+sLineBreak - +'SELECT COLLATION(CAST(123 AS CHAR));'+sLineBreak - +'+------------------------------+'+sLineBreak - +'| COLLATION(CAST(123 AS CHAR)) |'+sLineBreak - +'+------------------------------+'+sLineBreak - +'| latin1_swedish_ci |'+sLineBreak - +'+------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT COLLATION(CAST(123 AS CHAR CHARACTER SET utf8));'+sLineBreak - +'+-------------------------------------------------+'+sLineBreak - +'| COLLATION(CAST(123 AS CHAR CHARACTER SET utf8)) |'+sLineBreak - +'+-------------------------------------------------+'+sLineBreak - +'| utf8_general_ci |'+sLineBreak - +'+-------------------------------------------------+'+sLineBreak - +' '+sLineBreak - +'If you also want to change the collation, you have to use'+sLineBreak - +'the COLLATE operator:'+sLineBreak - +' '+sLineBreak - +'SELECT COLLATION(CAST(123 AS CHAR CHARACTER SET utf8) '+sLineBreak - +' COLLATE utf8_unicode_ci);'+sLineBreak - +'+-------------------------------------------------------------------------+'+sLineBreak - +'| COLLATION(CAST(123 AS CHAR CHARACTER SET utf8) COLLATE'+sLineBreak - +'utf8_unicode_ci) |'+sLineBreak - +'+-------------------------------------------------------------------------+'+sLineBreak - +'| utf8_unicode_ci |'+sLineBreak - +'+-------------------------------------------------------------------------+'+sLineBreak - +' '+sLineBreak - +'Using CAST() to order an ENUM field as a CHAR rather than'+sLineBreak - +'the internal numerical value:'+sLineBreak - +' '+sLineBreak - +'CREATE TABLE enum_list (enum_field enum(''c'',''a'',''b''));'+sLineBreak - +' '+sLineBreak - +'INSERT INTO enum_list (enum_field) '+sLineBreak - +'VALUES(''c''),(''a''),(''c''),(''b'');'+sLineBreak - +' '+sLineBreak - +'SELECT * FROM enum_list '+sLineBreak - +'ORDER BY enum_field;'+sLineBreak - +' '+sLineBreak - +'+------------+'+sLineBreak - +'| enum_field |'+sLineBreak - +'+------------+'+sLineBreak - +'| c |'+sLineBreak - +'| c |'+sLineBreak - +'| a |'+sLineBreak - +'| b |'+sLineBreak - +'+------------+'+sLineBreak - +' '+sLineBreak - +'SELECT * FROM enum_list '+sLineBreak - +'ORDER BY CAST(enum_field AS CHAR);'+sLineBreak - +'+------------+'+sLineBreak - +'| enum_field |'+sLineBreak - +'+------------+'+sLineBreak - +'| a |'+sLineBreak - +'| b |'+sLineBreak - +'| c |'+sLineBreak - +'| c |'+sLineBreak - +'+------------+'+sLineBreak - +' '+sLineBreak - +'From MariaDB 5.5.31, the following will trigger warnings,'+sLineBreak - +'since x''aa'' and ''X''aa'' no longer behave as a number.'+sLineBreak - +'Previously, and in all versions of MySQL, no warnings are'+sLineBreak - +'triggered since they did erroneously behave as a number:'+sLineBreak - +' '+sLineBreak - +'SELECT CAST(0xAA AS UNSIGNED), CAST(x''aa'' AS UNSIGNED),'+sLineBreak - +'CAST(X''aa'' AS UNSIGNED);'+sLineBreak - +'+------------------------+-------------------------+-------------------------+'+sLineBreak - +'| CAST(0xAA AS UNSIGNED) | CAST(x''aa'' AS UNSIGNED) |'+sLineBreak - +'CAST(X''aa'' AS UNSIGNED) |'+sLineBreak - +'+------------------------+-------------------------+-------------------------+'+sLineBreak - +'| 170 | 0 | 0 |'+sLineBreak - +'+------------------------+-------------------------+-------------------------+'+sLineBreak - +'1 row in set, 2 warnings (0.00 sec)'+sLineBreak - +' '+sLineBreak - +'Warning (Code 1292): Truncated incorrect INTEGER value:'+sLineBreak - +'''\xAA'''+sLineBreak - +'Warning (Code 1292): Truncated incorrect INTEGER value:'+sLineBreak - +'''\xAA'''+sLineBreak - +' '+sLineBreak - +'Casting to intervals:'+sLineBreak - +' '+sLineBreak - +'SELECT CAST(2019-01-04 INTERVAL AS DAY_SECOND(2)) AS'+sLineBreak - +'"Cast";'+sLineBreak - +' '+sLineBreak - +'+-------------+'+sLineBreak - +'| Cast |'+sLineBreak - +'+-------------+'+sLineBreak - +'| 00:20:17.00 |'+sLineBreak - +'+-------------+' - ), - - ( - Name: 'CHARACTER_LENGTH'; - Declaration: '(str)'; - Category: 'String Functions'; - Version: SQL_VERSION_ANSI; - Description: 'CHARACTER_LENGTH() is a synonym for CHAR_LENGTH().' - ), - - ( - Name: 'CHAR_LENGTH'; - Declaration: '(str)'; - Category: 'String Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the length of the given string argument, measured in'+sLineBreak - +'characters. A multi-byte character counts as a single'+sLineBreak - +'character. This means that for a string containing five'+sLineBreak - +'two-byte characters, LENGTH() (or OCTET_LENGTH() in Oracle'+sLineBreak - +'mode) returns 10, whereas CHAR_LENGTH() returns 5. If the'+sLineBreak - +'argument is NULL, it returns NULL. '+sLineBreak - +' '+sLineBreak - +'If the argument is not a string value, it is converted into'+sLineBreak - +'a string.'+sLineBreak - +' '+sLineBreak - +'It is synonymous with the CHARACTER_LENGTH() function.'+sLineBreak - +' '+sLineBreak - +'Until MariaDB 10.3.1, returns MYSQL_TYPE_LONGLONG, or'+sLineBreak - +'bigint(10), in all cases. From MariaDB 10.3.1, returns'+sLineBreak - +'MYSQL_TYPE_LONG, or int(10), when the result would fit'+sLineBreak - +'within 32-bits.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT CHAR_LENGTH(''MariaDB'');'+sLineBreak - +'+------------------------+'+sLineBreak - +'| CHAR_LENGTH(''MariaDB'') |'+sLineBreak - +'+------------------------+'+sLineBreak - +'| 7 |'+sLineBreak - +'+------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT CHAR_LENGTH(''?'');'+sLineBreak - +'+-------------------+'+sLineBreak - +'| CHAR_LENGTH(''?'') |'+sLineBreak - +'+-------------------+'+sLineBreak - +'| 1 |'+sLineBreak - +'+-------------------+' - ), - - ( - Name: 'CHR'; - Declaration: '(N)'; - Category: 'String Functions'; - Version: SQL_VERSION_ANSI; - Description: 'CHR() interprets each argument N as an integer and returns a'+sLineBreak - +'VARCHAR(1) string consisting of the character given by the'+sLineBreak - +'code values of the integer. The character set and collation'+sLineBreak - +'of the string are set according to the values of the'+sLineBreak - +'character_set_database and collation_database system'+sLineBreak - +'variables.'+sLineBreak - +' '+sLineBreak - +'CHR() is similar to the CHAR() function, but only accepts a'+sLineBreak - +'single argument.'+sLineBreak - +' '+sLineBreak - +'CHR() is available in all sql_modes.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT CHR(67);'+sLineBreak - +'+---------+'+sLineBreak - +'| CHR(67) |'+sLineBreak - +'+---------+'+sLineBreak - +'| C |'+sLineBreak - +'+---------+'+sLineBreak - +' '+sLineBreak - +'SELECT CHR(''67'');'+sLineBreak - +'+-----------+'+sLineBreak - +'| CHR(''67'') |'+sLineBreak - +'+-----------+'+sLineBreak - +'| C |'+sLineBreak - +'+-----------+'+sLineBreak - +' '+sLineBreak - +'SELECT CHR(''C'');'+sLineBreak - +'+----------+'+sLineBreak - +'| CHR(''C'') |'+sLineBreak - +'+----------+'+sLineBreak - +'| |'+sLineBreak - +'+----------+'+sLineBreak - +'1 row in set, 1 warning (0.000 sec)'+sLineBreak - +' '+sLineBreak - +'SHOW WARNINGS;'+sLineBreak - +' '+sLineBreak - +'+---------+------+----------------------------------------+'+sLineBreak - +'| Level | Code | Message |'+sLineBreak - +'+---------+------+----------------------------------------+'+sLineBreak - +'| Warning | 1292 | Truncated incorrect INTEGER value: ''C'''+sLineBreak - +'|'+sLineBreak - +'+---------+------+----------------------------------------+' - ), - - ( - Name: 'CONCAT'; - Declaration: '(str1,str2,...)'; - Category: 'String Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the string that results from concatenating the'+sLineBreak - +'arguments. May have one or more arguments. If all arguments'+sLineBreak - +'are non-binary strings, the result is a non-binary string.'+sLineBreak - +'If the arguments include any binary strings, the result is a'+sLineBreak - +'binary string. A numeric argument is converted to its'+sLineBreak - +'equivalent binary string form; if you want to avoid that,'+sLineBreak - +'you can use an explicit type cast, as in this example:'+sLineBreak - +' '+sLineBreak - +'SELECT CONCAT(CAST(int_col AS CHAR), char_col);'+sLineBreak - +' '+sLineBreak - +'CONCAT() returns NULL if any argument is NULL.'+sLineBreak - +' '+sLineBreak - +'A NULL parameter hides all information contained in other'+sLineBreak - +'parameters from the result. Sometimes this is not desirable;'+sLineBreak - +'to avoid this, you can:'+sLineBreak - +'Use the CONCAT_WS() function with an empty separator,'+sLineBreak - +'because that function is NULL-safe.'+sLineBreak - +'Use IFNULL() to turn NULLs into empty strings.'+sLineBreak - +' '+sLineBreak - +'Oracle Mode'+sLineBreak - +' '+sLineBreak - +'In Oracle mode from MariaDB 10.3, CONCAT ignores NULL.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT CONCAT(''Ma'', ''ria'', ''DB'');'+sLineBreak - +'+---------------------------+'+sLineBreak - +'| CONCAT(''Ma'', ''ria'', ''DB'') |'+sLineBreak - +'+---------------------------+'+sLineBreak - +'| MariaDB |'+sLineBreak - +'+---------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT CONCAT(''Ma'', ''ria'', NULL, ''DB'');'+sLineBreak - +'+---------------------------------+'+sLineBreak - +'| CONCAT(''Ma'', ''ria'', NULL, ''DB'') |'+sLineBreak - +'+---------------------------------+'+sLineBreak - +'| NULL |'+sLineBreak - +'+---------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT CONCAT(42.0);'+sLineBreak - +'+--------------+'+sLineBreak - +'| CONCAT(42.0) |'+sLineBreak - +'+--------------+'+sLineBreak - +'| 42.0 |'+sLineBreak - +'+--------------+'+sLineBreak - +' '+sLineBreak - +'Using IFNULL() to handle NULLs:'+sLineBreak - +' '+sLineBreak - +'SELECT CONCAT(''The value of @v is: '', IFNULL(@v, ''''));'+sLineBreak - +'+------------------------------------------------+'+sLineBreak - +'| CONCAT(''The value of @v is: '', IFNULL(@v, '''')) |'+sLineBreak - +'+------------------------------------------------+'+sLineBreak - +'| The value of @v is: |'+sLineBreak - +'+------------------------------------------------+'+sLineBreak - +' '+sLineBreak - +'In Oracle mode, from MariaDB 10.3:'+sLineBreak - +' '+sLineBreak - +'SELECT CONCAT(''Ma'', ''ria'', NULL, ''DB'');'+sLineBreak - +'+---------------------------------+'+sLineBreak - +'| CONCAT(''Ma'', ''ria'', NULL, ''DB'') |'+sLineBreak - +'+---------------------------------+'+sLineBreak - +'| MariaDB |'+sLineBreak - +'+---------------------------------+' - ), - - ( - Name: 'CONCAT_WS'; - Declaration: '(separator,str1,str2,...)'; - Category: 'String Functions'; - Version: SQL_VERSION_ANSI; - Description: 'CONCAT_WS() stands for Concatenate With Separator and is a'+sLineBreak - +'special form of CONCAT(). The first argument is the'+sLineBreak - +'separator for the rest of the arguments. The separator is'+sLineBreak - +'added between the strings to be concatenated. The separator'+sLineBreak - +'can be a string, as can the rest of the arguments.'+sLineBreak - +' '+sLineBreak - +'If the separator is NULL, the result is NULL; all other NULL'+sLineBreak - +'values are skipped. This makes CONCAT_WS() suitable when you'+sLineBreak - +'want to concatenate some values and avoid losing all'+sLineBreak - +'information if one of them is NULL.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT CONCAT_WS('','',''First name'',''Second name'',''Last'+sLineBreak - +'Name'');'+sLineBreak - +'+-------------------------------------------------------+'+sLineBreak - +'| CONCAT_WS('','',''First name'',''Second name'',''Last'+sLineBreak - +'Name'') |'+sLineBreak - +'+-------------------------------------------------------+'+sLineBreak - +'| First name,Second name,Last Name |'+sLineBreak - +'+-------------------------------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT CONCAT_WS(''-'',''Floor'',NULL,''Room'');'+sLineBreak - +'+------------------------------------+'+sLineBreak - +'| CONCAT_WS(''-'',''Floor'',NULL,''Room'') |'+sLineBreak - +'+------------------------------------+'+sLineBreak - +'| Floor-Room |'+sLineBreak - +'+------------------------------------+'+sLineBreak - +' '+sLineBreak - +'In some cases, remember to include a space in the separator'+sLineBreak - +'string:'+sLineBreak - +' '+sLineBreak - +'SET @a = ''gnu'', @b = ''penguin'', @c = ''sea lion'';'+sLineBreak - +' '+sLineBreak - +'Query OK, 0 rows affected (0.00 sec)'+sLineBreak - +' '+sLineBreak - +'SELECT CONCAT_WS('', '', @a, @b, @c);'+sLineBreak - +'+-----------------------------+'+sLineBreak - +'| CONCAT_WS('', '', @a, @b, @c) |'+sLineBreak - +'+-----------------------------+'+sLineBreak - +'| gnu, penguin, sea lion |'+sLineBreak - +'+-----------------------------+'+sLineBreak - +' '+sLineBreak - +'Using CONCAT_WS() to handle NULLs:'+sLineBreak - +' '+sLineBreak - +'SET @a = ''a'', @b = NULL, @c = ''c'';'+sLineBreak - +' '+sLineBreak - +'SELECT CONCAT_WS('''', @a, @b, @c);'+sLineBreak - +'+---------------------------+'+sLineBreak - +'| CONCAT_WS('''', @a, @b, @c) |'+sLineBreak - +'+---------------------------+'+sLineBreak - +'| ac |'+sLineBreak - +'+---------------------------+' - ), - - ( - Name: 'CONVERT'; - Declaration: '(expr,type)'; - Category: 'String Functions'; - Version: SQL_VERSION_ANSI; - Description: 'The CONVERT() and CAST() functions take a value of one type'+sLineBreak - +'and produce a value of another type.'+sLineBreak - +' '+sLineBreak - +'The type can be one of the following values:'+sLineBreak - +'BINARY'+sLineBreak - +'CHAR'+sLineBreak - +'DATE'+sLineBreak - +'DATETIME '+sLineBreak - +'DECIMAL[(M[,D])]'+sLineBreak - +'DOUBLE '+sLineBreak - +'FLOAT נFrom MariaDB 10.4.5'+sLineBreak - +'INTEGER '+sLineBreak - +'Short for SIGNED INTEGER'+sLineBreak - +' '+sLineBreak - +'SIGNED [INTEGER]'+sLineBreak - +'TIME '+sLineBreak - +'UNSIGNED [INTEGER]'+sLineBreak - +' '+sLineBreak - +'Note that in MariaDB, INT and INTEGER are the same thing.'+sLineBreak - +' '+sLineBreak - +'BINARY produces a string with the BINARY data type. If the'+sLineBreak - +'optional length is given, BINARY(N) causes the cast to use'+sLineBreak - +'no more than N bytes of the argument. Values shorter than'+sLineBreak - +'the given number in bytes are padded with 0x00 bytes to make'+sLineBreak - +'them equal the length value.'+sLineBreak - +' '+sLineBreak - +'CHAR(N) causes the cast to use no more than the number of'+sLineBreak - +'characters given in the argument.'+sLineBreak - +' '+sLineBreak - +'The main difference between the CAST() and CONVERT() is that'+sLineBreak - +'CONVERT(expr,type) is ODBC syntax while CAST(expr as type)'+sLineBreak - +'and CONVERT(... USING ...) are SQL92 syntax.'+sLineBreak - +' '+sLineBreak - +'CONVERT() with USING is used to convert data between'+sLineBreak - +'different character sets. In MariaDB, transcoding names are'+sLineBreak - +'the same as the'+sLineBreak - +'corresponding character set names. For example, this'+sLineBreak - +'statement'+sLineBreak - +'converts the string ''abc'' in the default character set to'+sLineBreak - +'the'+sLineBreak - +'corresponding string in the utf8 character set:'+sLineBreak - +' '+sLineBreak - +'SELECT CONVERT(''abc'' USING utf8);'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT enum_col FROM tbl_name '+sLineBreak - +'ORDER BY CAST(enum_col AS CHAR);'+sLineBreak - +' '+sLineBreak - +'Converting a BINARY to string to permit the LOWER function'+sLineBreak - +'to work:'+sLineBreak - +' '+sLineBreak - +'SET @x = ''AardVark'';'+sLineBreak - +' '+sLineBreak - +'SET @x = BINARY ''AardVark'';'+sLineBreak - +' '+sLineBreak - +'SELECT LOWER(@x), LOWER(CONVERT (@x USING latin1));'+sLineBreak - +'+-----------+----------------------------------+'+sLineBreak - +'| LOWER(@x) | LOWER(CONVERT (@x USING latin1)) |'+sLineBreak - +'+-----------+----------------------------------+'+sLineBreak - +'| AardVark | aardvark |'+sLineBreak - +'+-----------+----------------------------------+' - ), - - ( - Name: 'CONVERT'; - Declaration: '(expr USING transcoding_name)'; - Category: 'String Functions'; - Version: SQL_VERSION_ANSI; - Description: 'The CONVERT() and CAST() functions take a value of one type'+sLineBreak - +'and produce a value of another type.'+sLineBreak - +' '+sLineBreak - +'The type can be one of the following values:'+sLineBreak - +'BINARY'+sLineBreak - +'CHAR'+sLineBreak - +'DATE'+sLineBreak - +'DATETIME '+sLineBreak - +'DECIMAL[(M[,D])]'+sLineBreak - +'DOUBLE '+sLineBreak - +'FLOAT נFrom MariaDB 10.4.5'+sLineBreak - +'INTEGER '+sLineBreak - +'Short for SIGNED INTEGER'+sLineBreak - +' '+sLineBreak - +'SIGNED [INTEGER]'+sLineBreak - +'TIME '+sLineBreak - +'UNSIGNED [INTEGER]'+sLineBreak - +' '+sLineBreak - +'Note that in MariaDB, INT and INTEGER are the same thing.'+sLineBreak - +' '+sLineBreak - +'BINARY produces a string with the BINARY data type. If the'+sLineBreak - +'optional length is given, BINARY(N) causes the cast to use'+sLineBreak - +'no more than N bytes of the argument. Values shorter than'+sLineBreak - +'the given number in bytes are padded with 0x00 bytes to make'+sLineBreak - +'them equal the length value.'+sLineBreak - +' '+sLineBreak - +'CHAR(N) causes the cast to use no more than the number of'+sLineBreak - +'characters given in the argument.'+sLineBreak - +' '+sLineBreak - +'The main difference between the CAST() and CONVERT() is that'+sLineBreak - +'CONVERT(expr,type) is ODBC syntax while CAST(expr as type)'+sLineBreak - +'and CONVERT(... USING ...) are SQL92 syntax.'+sLineBreak - +' '+sLineBreak - +'CONVERT() with USING is used to convert data between'+sLineBreak - +'different character sets. In MariaDB, transcoding names are'+sLineBreak - +'the same as the'+sLineBreak - +'corresponding character set names. For example, this'+sLineBreak - +'statement'+sLineBreak - +'converts the string ''abc'' in the default character set to'+sLineBreak - +'the'+sLineBreak - +'corresponding string in the utf8 character set:'+sLineBreak - +' '+sLineBreak - +'SELECT CONVERT(''abc'' USING utf8);'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT enum_col FROM tbl_name '+sLineBreak - +'ORDER BY CAST(enum_col AS CHAR);'+sLineBreak - +' '+sLineBreak - +'Converting a BINARY to string to permit the LOWER function'+sLineBreak - +'to work:'+sLineBreak - +' '+sLineBreak - +'SET @x = ''AardVark'';'+sLineBreak - +' '+sLineBreak - +'SET @x = BINARY ''AardVark'';'+sLineBreak - +' '+sLineBreak - +'SELECT LOWER(@x), LOWER(CONVERT (@x USING latin1));'+sLineBreak - +'+-----------+----------------------------------+'+sLineBreak - +'| LOWER(@x) | LOWER(CONVERT (@x USING latin1)) |'+sLineBreak - +'+-----------+----------------------------------+'+sLineBreak - +'| AardVark | aardvark |'+sLineBreak - +'+-----------+----------------------------------+' - ), - - ( - Name: 'ELT'; - Declaration: '(N, str1[, str2, str3,...])'; - Category: 'String Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Takes a numeric argument and a series of string arguments.'+sLineBreak - +'Returns the string that corresponds to the given numeric'+sLineBreak - +'position. For instance, it returns str1 if N is 1, str2 if N'+sLineBreak - +'is 2, and so on. If the numeric argument is a FLOAT, MariaDB'+sLineBreak - +'rounds it to the nearest INTEGER. If the numeric argument is'+sLineBreak - +'less than 1, greater than the total number of arguments, or'+sLineBreak - +'not a number, ELT() returns NULL. It must have at least two'+sLineBreak - +'arguments.'+sLineBreak - +' '+sLineBreak - +'It is complementary to the FIELD() function.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT ELT(1, ''ej'', ''Heja'', ''hej'', ''foo'');'+sLineBreak - +'+------------------------------------+'+sLineBreak - +'| ELT(1, ''ej'', ''Heja'', ''hej'', ''foo'') |'+sLineBreak - +'+------------------------------------+'+sLineBreak - +'| ej |'+sLineBreak - +'+------------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT ELT(4, ''ej'', ''Heja'', ''hej'', ''foo'');'+sLineBreak - +'+------------------------------------+'+sLineBreak - +'| ELT(4, ''ej'', ''Heja'', ''hej'', ''foo'') |'+sLineBreak - +'+------------------------------------+'+sLineBreak - +'| foo |'+sLineBreak - +'+------------------------------------+' - ), - - ( - Name: 'EXPORT_SET'; - Declaration: '(bits, on, off[, separator[, number_of_bits]])'; - Category: 'String Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Takes a minimum of three arguments. Returns a string where'+sLineBreak - +'each bit in the given bits argument is returned, with the'+sLineBreak - +'string values given for on and off. '+sLineBreak - +' '+sLineBreak - +'Bits are examined from right to left, (from low-order to'+sLineBreak - +'high-order bits). Strings are added to the result from left'+sLineBreak - +'to right, separated by a separator string (defaults as'+sLineBreak - +''',''). You can optionally limit the number of bits the'+sLineBreak - +'EXPORT_SET() function examines using the number_of_bits'+sLineBreak - +'option. '+sLineBreak - +' '+sLineBreak - +'If any of the arguments are set as NULL, the function'+sLineBreak - +'returns NULL.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT EXPORT_SET(5,''Y'',''N'','','',4);'+sLineBreak - +'+-----------------------------+'+sLineBreak - +'| EXPORT_SET(5,''Y'',''N'','','',4) |'+sLineBreak - +'+-----------------------------+'+sLineBreak - +'| Y,N,Y,N |'+sLineBreak - +'+-----------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT EXPORT_SET(6,''1'',''0'','','',10);'+sLineBreak - +'+------------------------------+'+sLineBreak - +'| EXPORT_SET(6,''1'',''0'','','',10) |'+sLineBreak - +'+------------------------------+'+sLineBreak - +'| 0,1,1,0,0,0,0,0,0,0 |'+sLineBreak - +'+------------------------------+' - ), - - ( - Name: 'EXTRACTVALUE'; - Declaration: '(xml_frag, xpath_expr)'; - Category: 'String Functions'; - Version: SQL_VERSION_ANSI; - Description: 'The EXTRACTVALUE() function takes two string arguments: a'+sLineBreak - +'fragment of XML markup and an XPath expression, (also known'+sLineBreak - +'as a locator). It returns the text (That is, CDDATA), of the'+sLineBreak - +'first text node which is a child of the element or elements'+sLineBreak - +'matching the XPath expression. '+sLineBreak - +' '+sLineBreak - +'In cases where a valid XPath expression does not match any'+sLineBreak - +'text nodes in a valid XML fragment, (including the implicit'+sLineBreak - +'/text() expression), the EXTRACTVALUE() function returns an'+sLineBreak - +'empty string.'+sLineBreak - +' '+sLineBreak - +'Invalid Arguments'+sLineBreak - +' '+sLineBreak - +'When either the XML fragment or the XPath expression is'+sLineBreak - +'NULL, the EXTRACTVALUE() function returns NULL. When the XML'+sLineBreak - +'fragment is invalid, it raises a warning Code 1525:'+sLineBreak - +' '+sLineBreak - +'Warning (Code 1525): Incorrect XML value: ''parse error at'+sLineBreak - +'line 1 pos 11: unexpected END-OF-INPUT'''+sLineBreak - +' '+sLineBreak - +'When the XPath value is invalid, it generates an Error 1105:'+sLineBreak - +' '+sLineBreak - +'ERROR 1105 (HY000): XPATH syntax error: '')'''+sLineBreak - +' '+sLineBreak - +'Explicit text() Expressions'+sLineBreak - +' '+sLineBreak - +'This function is the equivalent of performing a match using'+sLineBreak - +'the XPath expression after appending /text(). In other'+sLineBreak - +'words:'+sLineBreak - +' '+sLineBreak - +'SELECT'+sLineBreak - +' EXTRACTVALUE(''example'', ''/cases/case'') AS ''Base'+sLineBreak - +'Example'','+sLineBreak - +' EXTRACTVALUE(''example'', ''/cases/case/text()'') AS'+sLineBreak - +'''text() Example'';'+sLineBreak - +' '+sLineBreak - +'+--------------+----------------+'+sLineBreak - +'| Base Example | text() Example |'+sLineBreak - +'+--------------+----------------+'+sLineBreak - +'| example | example |'+sLineBreak - +'+--------------+----------------+'+sLineBreak - +' '+sLineBreak - +'Count Matches'+sLineBreak - +' '+sLineBreak - +'When EXTRACTVALUE() returns multiple matches, it returns the'+sLineBreak - +'content of the first child text node of each matching'+sLineBreak - +'element, in the matched order, as a single, space-delimited'+sLineBreak - +'string.'+sLineBreak - +' '+sLineBreak - +'By design, the EXTRACTVALUE() function makes no distinction'+sLineBreak - +'between a match on an empty element and no match at all. If'+sLineBreak - +'you need to determine whether no matching element was found'+sLineBreak - +'in the XML fragment or if an element was found that'+sLineBreak - +'contained no child text nodes, use the XPath count()'+sLineBreak - +'function. '+sLineBreak - +' '+sLineBreak - +'For instance, when looking for a value that exists, but'+sLineBreak - +'contains no child text nodes, you would get a count of the'+sLineBreak - +'number of matching instances:'+sLineBreak - +' '+sLineBreak - +'SELECT'+sLineBreak - +' EXTRACTVALUE('''', ''/cases/case'') AS ''Empty Example'','+sLineBreak - +' EXTRACTVALUE('''', ''/cases/case/count()'') AS ''count()'+sLineBreak - +'Example'';'+sLineBreak - +' '+sLineBreak - +'+---------------+-----------------+'+sLineBreak - +'| Empty Example | count() Example |'+sLineBreak - +'+---------------+-----------------+'+sLineBreak - +'| | 1 |'+sLineBreak - +'+---------------+-----------------+'+sLineBreak - +' '+sLineBreak - +'Alternatively, when looking for a value that doesn''t exist,'+sLineBreak - +'count() returns 0.'+sLineBreak - +' '+sLineBreak - +'SELECT'+sLineBreak - +' EXTRACTVALUE('''', ''/cases/person'') AS ''No Match'+sLineBreak - +'Example'','+sLineBreak - +' EXTRACTVALUE('''', ''/cases/person/count()'') AS ''count()'+sLineBreak - +'Example'';'+sLineBreak - +' '+sLineBreak - +'+------------------+-----------------+'+sLineBreak - +'| No Match Example | count() Example |'+sLineBreak - +'+------------------+-----------------+'+sLineBreak - +'| | 0|'+sLineBreak - +'+------------------+-----------------+'+sLineBreak - +' '+sLineBreak - +'Matches'+sLineBreak - +' '+sLineBreak - +'Important: The EXTRACTVALUE() function only returns CDDATA.'+sLineBreak - +'It does not return tags that the element might contain or'+sLineBreak - +'the text that these child elements contain.'+sLineBreak - +' '+sLineBreak - +'SELECT EXTRACTVALUE(''Personx@example.com'', ''/cases'') AS'+sLineBreak - +'Case;'+sLineBreak - +' '+sLineBreak - +'+--------+'+sLineBreak - +'| Case |'+sLineBreak - +'+--------+'+sLineBreak - +'| Person |'+sLineBreak - +'+--------+'+sLineBreak - +' '+sLineBreak - +'Note, in the above example, while the XPath expression'+sLineBreak - +'matches to the parent instance, it does not return the'+sLineBreak - +'contained tag or its content.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT'+sLineBreak - +' ExtractValue(''cccddd'', ''/a'') AS val1,'+sLineBreak - +' ExtractValue(''cccddd'', ''/a/b'') AS val2,'+sLineBreak - +' ExtractValue(''cccddd'', ''//b'') AS val3,'+sLineBreak - +' ExtractValue(''cccddd'', ''/b'') AS val4,'+sLineBreak - +' ExtractValue(''cccdddeee'', ''//b'') AS val5;'+sLineBreak - +' '+sLineBreak - +'+------+------+------+------+---------+'+sLineBreak - +'| val1 | val2 | val3 | val4 | val5 |'+sLineBreak - +'+------+------+------+------+---------+'+sLineBreak - +'| ccc | ddd | ddd | | ddd eee |'+sLineBreak - +'+------+------+------+------+---------+' - ), - - ( - Name: 'FIELD'; - Declaration: '(pattern, str1[,str2,...])'; - Category: 'String Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the index position of the string or number matching'+sLineBreak - +'the given pattern. Returns 0 in the event that none of the'+sLineBreak - +'arguments match the pattern. Raises an Error 1582 if not'+sLineBreak - +'given at least two arguments.'+sLineBreak - +' '+sLineBreak - +'When all arguments given to the FIELD() function are'+sLineBreak - +'strings, they are treated as case-insensitive. When all the'+sLineBreak - +'arguments are numbers, they are treated as numbers.'+sLineBreak - +'Otherwise, they are treated as doubles. '+sLineBreak - +' '+sLineBreak - +'If the given pattern occurs more than once, the FIELD()'+sLineBreak - +'function only returns the index of the first instance. If'+sLineBreak - +'the given pattern is NULL, the function returns 0, as a NULL'+sLineBreak - +'pattern always fails to match.'+sLineBreak - +' '+sLineBreak - +'This function is complementary to the ELT() function.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT FIELD(''ej'', ''Hej'', ''ej'', ''Heja'', ''hej'','+sLineBreak - +'''foo'') '+sLineBreak - +' AS ''Field Results'';'+sLineBreak - +' '+sLineBreak - +'+---------------+'+sLineBreak - +'| Field Results | '+sLineBreak - +'+---------------+'+sLineBreak - +'| 2 |'+sLineBreak - +'+---------------+'+sLineBreak - +' '+sLineBreak - +'SELECT FIELD(''fo'', ''Hej'', ''ej'', ''Heja'', ''hej'','+sLineBreak - +'''foo'')'+sLineBreak - +' AS ''Field Results'';'+sLineBreak - +' '+sLineBreak - +'+---------------+'+sLineBreak - +'| Field Results | '+sLineBreak - +'+---------------+'+sLineBreak - +'| 0 |'+sLineBreak - +'+---------------+'+sLineBreak - +' '+sLineBreak - +'SELECT FIELD(1, 2, 3, 4, 5, 1) AS ''Field Results'';'+sLineBreak - +' '+sLineBreak - +'+---------------+'+sLineBreak - +'| Field Results |'+sLineBreak - +'+---------------+'+sLineBreak - +'| 5 |'+sLineBreak - +'+---------------+'+sLineBreak - +' '+sLineBreak - +'SELECT FIELD(NULL, 2, 3) AS ''Field Results'';'+sLineBreak - +' '+sLineBreak - +'+---------------+'+sLineBreak - +'| Field Results |'+sLineBreak - +'+---------------+'+sLineBreak - +'| 0 |'+sLineBreak - +'+---------------+'+sLineBreak - +' '+sLineBreak - +'SELECT FIELD(''fail'') AS ''Field Results'';'+sLineBreak - +' '+sLineBreak - +'Error 1582 (42000): Incorrect parameter count in call'+sLineBreak - +'to native function ''field''' - ), - - ( - Name: 'FIND_IN_SET'; - Declaration: '(pattern, strlist)'; - Category: 'String Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the index position where the given pattern occurs in'+sLineBreak - +'a string list. The first argument is the pattern you want to'+sLineBreak - +'search for. The second argument is a string containing'+sLineBreak - +'comma-separated variables. If the second argument is of the'+sLineBreak - +'SET data-type, the function is optimized to use bit'+sLineBreak - +'arithmetic.'+sLineBreak - +' '+sLineBreak - +'If the pattern does not occur in the string list or if the'+sLineBreak - +'string list is an empty string, the function returns 0. If'+sLineBreak - +'either argument is NULL, the function returns NULL. The'+sLineBreak - +'function does not return the correct result if the pattern'+sLineBreak - +'contains a comma (",") character.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT FIND_IN_SET(''b'',''a,b,c,d'') AS "Found Results";'+sLineBreak - +' '+sLineBreak - +'+---------------+'+sLineBreak - +'| Found Results |'+sLineBreak - +'+---------------+'+sLineBreak - +'| 2 |'+sLineBreak - +'+---------------+' - ), - - ( - Name: 'FORMAT'; - Declaration: '(num, decimal_position[, locale])'; - Category: 'String Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Formats the given number for display as a string, adding'+sLineBreak - +'separators to appropriate position and rounding the results'+sLineBreak - +'to the given decimal position. For instance, it would format'+sLineBreak - +'15233.345 to 15,233.35.'+sLineBreak - +' '+sLineBreak - +'If the given decimal position is 0, it rounds to return no'+sLineBreak - +'decimal point or fractional part. You can optionally specify'+sLineBreak - +'a locale value to format numbers to the pattern appropriate'+sLineBreak - +'for the given region.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT FORMAT(1234567890.09876543210, 4) AS ''Format'';'+sLineBreak - +' '+sLineBreak - +'+--------------------+'+sLineBreak - +'| Format |'+sLineBreak - +'+--------------------+'+sLineBreak - +'| 1,234,567,890.0988 |'+sLineBreak - +'+--------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT FORMAT(1234567.89, 4) AS ''Format'';'+sLineBreak - +' '+sLineBreak - +'+----------------+'+sLineBreak - +'| Format |'+sLineBreak - +'+----------------+'+sLineBreak - +'| 1,234,567.8900 |'+sLineBreak - +'+----------------+'+sLineBreak - +' '+sLineBreak - +'SELECT FORMAT(1234567.89, 0) AS ''Format'';'+sLineBreak - +' '+sLineBreak - +'+-----------+'+sLineBreak - +'| Format |'+sLineBreak - +'+-----------+'+sLineBreak - +'| 1,234,568 |'+sLineBreak - +'+-----------+'+sLineBreak - +' '+sLineBreak - +'SELECT FORMAT(123456789,2,''rm_CH'') AS ''Format'';'+sLineBreak - +' '+sLineBreak - +'+----------------+'+sLineBreak - +'| Format |'+sLineBreak - +'+----------------+'+sLineBreak - +'| 123''456''789,00 |'+sLineBreak - +'+----------------+' - ), - - ( - Name: 'FROM_BASE64'; - Declaration: '(str)'; - Category: 'String Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Decodes the given base-64 encode string, returning the'+sLineBreak - +'result as a binary string. Returns NULL if the given string'+sLineBreak - +'is NULL or if it''s invalid.'+sLineBreak - +' '+sLineBreak - +'It is the reverse of the TO_BASE64 function.'+sLineBreak - +' '+sLineBreak - +'There are numerous methods to base-64 encode a string.'+sLineBreak - +'MariaDB uses the following:'+sLineBreak - +'It encodes alphabet value 64 as ''+''.'+sLineBreak - +'It encodes alphabet value 63 as ''/''.'+sLineBreak - +'It codes output in groups of four printable characters. Each'+sLineBreak - +'three byte of data encoded uses four characters. If the'+sLineBreak - +'final group is incomplete, it pads the difference with the'+sLineBreak - +'''='' character.'+sLineBreak - +'It divides long output, adding a new line very 76'+sLineBreak - +'characters.'+sLineBreak - +'In decoding, it recognizes and ignores newlines, carriage'+sLineBreak - +'returns, tabs and space whitespace characters.'+sLineBreak - +' '+sLineBreak - +'SELECT TO_BASE64(''Maria'') AS ''Input'';'+sLineBreak - +' '+sLineBreak - +'+-----------+'+sLineBreak - +'| Input |'+sLineBreak - +'+-----------+'+sLineBreak - +'| TWFyaWE= |'+sLineBreak - +'+-----------+'+sLineBreak - +' '+sLineBreak - +'SELECT FROM_BASE64(''TWFyaWE='') AS ''Output'';'+sLineBreak - +' '+sLineBreak - +'+--------+'+sLineBreak - +'| Output |'+sLineBreak - +'+--------+'+sLineBreak - +'| Maria |'+sLineBreak - +'+--------+' - ), - - ( - Name: 'HEX'; - Declaration: '(N_or_S)'; - Category: 'String Functions'; - Version: SQL_VERSION_ANSI; - Description: 'If N_or_S is a number, returns a string representation of'+sLineBreak - +'the hexadecimal'+sLineBreak - +'value of N, where N is a longlong (BIGINT) number. This is'+sLineBreak - +'equivalent to CONV(N,10,16).'+sLineBreak - +' '+sLineBreak - +'If N_or_S is a string, returns a hexadecimal string'+sLineBreak - +'representation of'+sLineBreak - +'N_or_S where each byte of each character in N_or_S is'+sLineBreak - +'converted to two hexadecimal'+sLineBreak - +'digits. If N_or_S is NULL, returns NULL. The inverse of this'+sLineBreak - +'operation is performed by the UNHEX()'+sLineBreak - +'function.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT HEX(255);'+sLineBreak - +'+----------+'+sLineBreak - +'| HEX(255) |'+sLineBreak - +'+----------+'+sLineBreak - +'| FF |'+sLineBreak - +'+----------+'+sLineBreak - +' '+sLineBreak - +'SELECT 0x4D617269614442;'+sLineBreak - +' '+sLineBreak - +'+------------------+'+sLineBreak - +'| 0x4D617269614442 |'+sLineBreak - +'+------------------+'+sLineBreak - +'| MariaDB |'+sLineBreak - +'+------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT HEX(''MariaDB'');'+sLineBreak - +'+----------------+'+sLineBreak - +'| HEX(''MariaDB'') |'+sLineBreak - +'+----------------+'+sLineBreak - +'| 4D617269614442 |'+sLineBreak - +'+----------------+' - ), - - ( - Name: 'INSTR'; - Declaration: '(str,substr)'; - Category: 'String Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the position of the first occurrence of substring'+sLineBreak - +'substr in'+sLineBreak - +'string str. This is the same as the two-argument form of'+sLineBreak - +'LOCATE(),'+sLineBreak - +'except that the order of the arguments is reversed.'+sLineBreak - +' '+sLineBreak - +'INSTR() performs a case-insensitive search.'+sLineBreak - +' '+sLineBreak - +'If any argument is NULL, returns NULL.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT INSTR(''foobarbar'', ''bar'');'+sLineBreak - +'+---------------------------+'+sLineBreak - +'| INSTR(''foobarbar'', ''bar'') |'+sLineBreak - +'+---------------------------+'+sLineBreak - +'| 4 |'+sLineBreak - +'+---------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT INSTR(''My'', ''Maria'');'+sLineBreak - +'+----------------------+'+sLineBreak - +'| INSTR(''My'', ''Maria'') |'+sLineBreak - +'+----------------------+'+sLineBreak - +'| 0 |'+sLineBreak - +'+----------------------+' - ), - - ( - Name: 'LCASE'; - Declaration: '(str)'; - Category: 'String Functions'; - Version: SQL_VERSION_ANSI; - Description: 'LCASE() is a synonym for LOWER().' - ), - - ( - Name: 'LEFT'; - Declaration: '(str,len)'; - Category: 'String Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the leftmost len characters from the string str, or'+sLineBreak - +'NULL if'+sLineBreak - +'any argument is NULL.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT LEFT(''MariaDB'', 5);'+sLineBreak - +'+--------------------+'+sLineBreak - +'| LEFT(''MariaDB'', 5) |'+sLineBreak - +'+--------------------+'+sLineBreak - +'| Maria |'+sLineBreak - +'+--------------------+' - ), - - ( - Name: 'LENGTH'; - Declaration: '(str)'; - Category: 'String Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the length of the string str, measured in bytes. A'+sLineBreak - +'multi-byte'+sLineBreak - +'character counts as multiple bytes. This means that for a'+sLineBreak - +'string'+sLineBreak - +'containing five two-byte characters, LENGTH() returns 10,'+sLineBreak - +'whereas'+sLineBreak - +'CHAR_LENGTH() returns 5. '+sLineBreak - +' '+sLineBreak - +'If str is not a string value, it is converted into a string.'+sLineBreak - +'If str is NULL, the function returns NULL.'+sLineBreak - +' '+sLineBreak - +'Until MariaDB 10.3.1, returns MYSQL_TYPE_LONGLONG, or'+sLineBreak - +'bigint(10), in all cases. From MariaDB 10.3.1, returns'+sLineBreak - +'MYSQL_TYPE_LONG, or int(10), when the result would fit'+sLineBreak - +'within 32-bits.'+sLineBreak - +' '+sLineBreak - +'Oracle Mode'+sLineBreak - +' '+sLineBreak - +'When running Oracle mode from MariaDB 10.3, LENGTH() is a'+sLineBreak - +'synonym for CHAR_LENGTH().'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT LENGTH(''MariaDB'');'+sLineBreak - +'+-------------------+'+sLineBreak - +'| LENGTH(''MariaDB'') |'+sLineBreak - +'+-------------------+'+sLineBreak - +'| 7 |'+sLineBreak - +'+-------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT LENGTH(''?'');'+sLineBreak - +'+--------------+'+sLineBreak - +'| LENGTH(''?'') |'+sLineBreak - +'+--------------+'+sLineBreak - +'| 2 |'+sLineBreak - +'+--------------+'+sLineBreak - +' '+sLineBreak - +'In Oracle mode from MariaDB 10.3:'+sLineBreak - +' '+sLineBreak - +'SELECT LENGTH(''?'');'+sLineBreak - +'+--------------+'+sLineBreak - +'| LENGTH(''?'') |'+sLineBreak - +'+--------------+'+sLineBreak - +'| 1 |'+sLineBreak - +'+--------------+' - ), - - ( - Name: 'LENGTHB'; - Declaration: '(str)'; - Category: 'String Functions'; - Version: SQL_VERSION_ANSI; - Description: 'LENGTHB() is a synonym for LENGTH().' - ), - - ( - Name: 'LOAD_FILE'; - Declaration: '(file_name)'; - Category: 'String Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Reads the file and returns the file contents as a string. To'+sLineBreak - +'use this function, the file must be located on the server'+sLineBreak - +'host, you must specify the full path name to the file, and'+sLineBreak - +'you must have the FILE privilege. The file must be readable'+sLineBreak - +'by all and it must be less than the size, in bytes, of the'+sLineBreak - +'max_allowed_packet system variable. If the secure_file_priv'+sLineBreak - +'system variable is set to a non-empty directory name, the'+sLineBreak - +'file to be loaded must be located in that directory.'+sLineBreak - +' '+sLineBreak - +'If the file does not exist or cannot be read because one of'+sLineBreak - +'the preceding conditions is not satisfied, the function'+sLineBreak - +'returns NULL.'+sLineBreak - +' '+sLineBreak - +'Since MariaDB 5.1, the character_set_filesystem system'+sLineBreak - +'variable has controlled interpretation of file names that'+sLineBreak - +'are given as literal strings.'+sLineBreak - +' '+sLineBreak - +'Statements using the LOAD_FILE() function are not safe for'+sLineBreak - +'statement based replication. This is because the slave will'+sLineBreak - +'execute the LOAD_FILE() command itself. If the file doesn''t'+sLineBreak - +'exist on the slave, the function will return NULL.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'UPDATE t SET blob_col=LOAD_FILE(''/tmp/picture'') WHERE'+sLineBreak - +'id=1;' - ), - - ( - Name: 'LOCATE'; - Declaration: '(substr,str)'; - Category: 'String Functions'; - Version: SQL_VERSION_ANSI; - Description: 'The first syntax returns the position of the first'+sLineBreak - +'occurrence of'+sLineBreak - +'substring substr in string str. The second syntax returns'+sLineBreak - +'the position'+sLineBreak - +'of the first occurrence of substring substr in string str,'+sLineBreak - +'starting at'+sLineBreak - +'position pos. Returns 0 if substr is not in str.'+sLineBreak - +' '+sLineBreak - +'LOCATE() performs a case-insensitive search.'+sLineBreak - +' '+sLineBreak - +'If any argument is NULL, returns NULL.'+sLineBreak - +' '+sLineBreak - +'INSTR() is a synonym of LOCATE() without the third argument.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT LOCATE(''bar'', ''foobarbar'');'+sLineBreak - +'+----------------------------+'+sLineBreak - +'| LOCATE(''bar'', ''foobarbar'') |'+sLineBreak - +'+----------------------------+'+sLineBreak - +'| 4 |'+sLineBreak - +'+----------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT LOCATE(''My'', ''Maria'');'+sLineBreak - +'+-----------------------+'+sLineBreak - +'| LOCATE(''My'', ''Maria'') |'+sLineBreak - +'+-----------------------+'+sLineBreak - +'| 0 |'+sLineBreak - +'+-----------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT LOCATE(''bar'', ''foobarbar'', 5);'+sLineBreak - +'+-------------------------------+'+sLineBreak - +'| LOCATE(''bar'', ''foobarbar'', 5) |'+sLineBreak - +'+-------------------------------+'+sLineBreak - +'| 7 |'+sLineBreak - +'+-------------------------------+' - ), - - ( - Name: 'LOCATE'; - Declaration: '(substr,str,pos)'; - Category: 'String Functions'; - Version: SQL_VERSION_ANSI; - Description: 'The first syntax returns the position of the first'+sLineBreak - +'occurrence of'+sLineBreak - +'substring substr in string str. The second syntax returns'+sLineBreak - +'the position'+sLineBreak - +'of the first occurrence of substring substr in string str,'+sLineBreak - +'starting at'+sLineBreak - +'position pos. Returns 0 if substr is not in str.'+sLineBreak - +' '+sLineBreak - +'LOCATE() performs a case-insensitive search.'+sLineBreak - +' '+sLineBreak - +'If any argument is NULL, returns NULL.'+sLineBreak - +' '+sLineBreak - +'INSTR() is a synonym of LOCATE() without the third argument.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT LOCATE(''bar'', ''foobarbar'');'+sLineBreak - +'+----------------------------+'+sLineBreak - +'| LOCATE(''bar'', ''foobarbar'') |'+sLineBreak - +'+----------------------------+'+sLineBreak - +'| 4 |'+sLineBreak - +'+----------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT LOCATE(''My'', ''Maria'');'+sLineBreak - +'+-----------------------+'+sLineBreak - +'| LOCATE(''My'', ''Maria'') |'+sLineBreak - +'+-----------------------+'+sLineBreak - +'| 0 |'+sLineBreak - +'+-----------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT LOCATE(''bar'', ''foobarbar'', 5);'+sLineBreak - +'+-------------------------------+'+sLineBreak - +'| LOCATE(''bar'', ''foobarbar'', 5) |'+sLineBreak - +'+-------------------------------+'+sLineBreak - +'| 7 |'+sLineBreak - +'+-------------------------------+' - ), - - ( - Name: 'LOWER'; - Declaration: '(str)'; - Category: 'String Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the string str with all characters changed to'+sLineBreak - +'lowercase'+sLineBreak - +'according to the current character set mapping. The default'+sLineBreak - +'is latin1'+sLineBreak - +'(cp1252 West European).'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +' SELECT LOWER(''QUADRATICALLY'');'+sLineBreak - +'+------------------------+'+sLineBreak - +'| LOWER(''QUADRATICALLY'') |'+sLineBreak - +'+------------------------+'+sLineBreak - +'| quadratically |'+sLineBreak - +'+------------------------+'+sLineBreak - +' '+sLineBreak - +'LOWER() (and UPPER()) are ineffective when applied to binary'+sLineBreak - +'strings (BINARY, VARBINARY, BLOB). '+sLineBreak - +'To perform lettercase conversion, CONVERT the string to a'+sLineBreak - +'non-binary string:'+sLineBreak - +' '+sLineBreak - +'SET @str = BINARY ''North Carolina'';'+sLineBreak - +' '+sLineBreak - +'SELECT LOWER(@str), LOWER(CONVERT(@str USING latin1));'+sLineBreak - +'+----------------+-----------------------------------+'+sLineBreak - +'| LOWER(@str) | LOWER(CONVERT(@str USING latin1)) |'+sLineBreak - +'+----------------+-----------------------------------+'+sLineBreak - +'| North Carolina | north carolina |'+sLineBreak - +'+----------------+-----------------------------------+' - ), - - ( - Name: 'LPAD'; - Declaration: '(str, len [,padstr])'; - Category: 'String Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the string str, left-padded with the string padstr'+sLineBreak - +'to a length'+sLineBreak - +'of len characters. If str is longer than len, the return'+sLineBreak - +'value is'+sLineBreak - +'shortened to len characters. If padstr is omitted, the LPAD'+sLineBreak - +'function pads spaces.'+sLineBreak - +' '+sLineBreak - +'Prior to MariaDB 10.3.1, the padstr parameter was mandatory.'+sLineBreak - +' '+sLineBreak - +'Returns NULL if given a NULL argument. If the result is'+sLineBreak - +'empty (zero length), returns either an empty string or, from'+sLineBreak - +'MariaDB 10.3.6 with SQL_MODE=Oracle, NULL.'+sLineBreak - +' '+sLineBreak - +'The Oracle mode version of the function can be accessed'+sLineBreak - +'outside of Oracle mode by using LPAD_ORACLE as the function'+sLineBreak - +'name.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT LPAD(''hello'',10,''.'');'+sLineBreak - +'+----------------------+'+sLineBreak - +'| LPAD(''hello'',10,''.'') |'+sLineBreak - +'+----------------------+'+sLineBreak - +'| .....hello |'+sLineBreak - +'+----------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT LPAD(''hello'',2,''.'');'+sLineBreak - +'+---------------------+'+sLineBreak - +'| LPAD(''hello'',2,''.'') |'+sLineBreak - +'+---------------------+'+sLineBreak - +'| he |'+sLineBreak - +'+---------------------+'+sLineBreak - +' '+sLineBreak - +'From MariaDB 10.3.1, with the pad string defaulting to'+sLineBreak - +'space.'+sLineBreak - +' '+sLineBreak - +'SELECT LPAD(''hello'',10);'+sLineBreak - +'+------------------+'+sLineBreak - +'| LPAD(''hello'',10) |'+sLineBreak - +'+------------------+'+sLineBreak - +'| hello |'+sLineBreak - +'+------------------+'+sLineBreak - +' '+sLineBreak - +'Oracle mode version from MariaDB 10.3.6:'+sLineBreak - +' '+sLineBreak - +'SELECT LPAD('''',0),LPAD_ORACLE('''',0);'+sLineBreak - +'+------------+-------------------+'+sLineBreak - +'| LPAD('''',0) | LPAD_ORACLE('''',0) |'+sLineBreak - +'+------------+-------------------+'+sLineBreak - +'| | NULL |'+sLineBreak - +'+------------+-------------------+' - ), - - ( - Name: 'LTRIM'; - Declaration: '(str)'; - Category: 'String Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the string str with leading space characters'+sLineBreak - +'removed.'+sLineBreak - +' '+sLineBreak - +'Returns NULL if given a NULL argument. If the result is'+sLineBreak - +'empty, returns either an empty string, or, from MariaDB'+sLineBreak - +'10.3.6 with SQL_MODE=Oracle, NULL.'+sLineBreak - +' '+sLineBreak - +'The Oracle mode version of the function can be accessed'+sLineBreak - +'outside of Oracle mode by using LTRIM_ORACLE as the function'+sLineBreak - +'name.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT QUOTE(LTRIM('' MariaDB ''));'+sLineBreak - +'+-------------------------------+'+sLineBreak - +'| QUOTE(LTRIM('' MariaDB '')) |'+sLineBreak - +'+-------------------------------+'+sLineBreak - +'| ''MariaDB '' |'+sLineBreak - +'+-------------------------------+'+sLineBreak - +' '+sLineBreak - +'Oracle mode version from MariaDB 10.3.6:'+sLineBreak - +' '+sLineBreak - +'SELECT LTRIM(''''),LTRIM_ORACLE('''');'+sLineBreak - +'+-----------+------------------+'+sLineBreak - +'| LTRIM('''') | LTRIM_ORACLE('''') |'+sLineBreak - +'+-----------+------------------+'+sLineBreak - +'| | NULL |'+sLineBreak - +'+-----------+------------------+' - ), - - ( - Name: 'MAKE_SET'; - Declaration: '(bits,str1,str2,...)'; - Category: 'String Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns a set value (a string containing substrings'+sLineBreak - +'separated by ","'+sLineBreak - +'characters) consisting of the strings that have the'+sLineBreak - +'corresponding bit'+sLineBreak - +'in bits set. str1 corresponds to bit 0, str2 to bit 1, and'+sLineBreak - +'so on. NULL'+sLineBreak - +'values in str1, str2, ... are not appended to the result.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT MAKE_SET(1,''a'',''b'',''c'');'+sLineBreak - +'+-------------------------+'+sLineBreak - +'| MAKE_SET(1,''a'',''b'',''c'') |'+sLineBreak - +'+-------------------------+'+sLineBreak - +'| a |'+sLineBreak - +'+-------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT MAKE_SET(1 | 4,''hello'',''nice'',''world'');'+sLineBreak - +'+----------------------------------------+'+sLineBreak - +'| MAKE_SET(1 | 4,''hello'',''nice'',''world'') |'+sLineBreak - +'+----------------------------------------+'+sLineBreak - +'| hello,world |'+sLineBreak - +'+----------------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT MAKE_SET(1 | 4,''hello'',''nice'',NULL,''world'');'+sLineBreak - +'+---------------------------------------------+'+sLineBreak - +'| MAKE_SET(1 | 4,''hello'',''nice'',NULL,''world'') |'+sLineBreak - +'+---------------------------------------------+'+sLineBreak - +'| hello |'+sLineBreak - +'+---------------------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT QUOTE(MAKE_SET(0,''a'',''b'',''c''));'+sLineBreak - +'+--------------------------------+'+sLineBreak - +'| QUOTE(MAKE_SET(0,''a'',''b'',''c'')) |'+sLineBreak - +'+--------------------------------+'+sLineBreak - +'| '''' |'+sLineBreak - +'+--------------------------------+' - ), - - ( - Name: 'MID'; - Declaration: '(str,pos,len)'; - Category: 'String Functions'; - Version: SQL_VERSION_ANSI; - Description: 'MID(str,pos,len) is a synonym for SUBSTRING(str,pos,len).'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT MID(''abcd'',4,1);'+sLineBreak - +'+-----------------+'+sLineBreak - +'| MID(''abcd'',4,1) |'+sLineBreak - +'+-----------------+'+sLineBreak - +'| d |'+sLineBreak - +'+-----------------+'+sLineBreak - +' '+sLineBreak - +'SELECT MID(''abcd'',2,2);'+sLineBreak - +'+-----------------+'+sLineBreak - +'| MID(''abcd'',2,2) |'+sLineBreak - +'+-----------------+'+sLineBreak - +'| bc |'+sLineBreak - +'+-----------------+'+sLineBreak - +' '+sLineBreak - +'A negative starting position:'+sLineBreak - +' '+sLineBreak - +'SELECT MID(''abcd'',-2,4);'+sLineBreak - +'+------------------+'+sLineBreak - +'| MID(''abcd'',-2,4) |'+sLineBreak - +'+------------------+'+sLineBreak - +'| cd |'+sLineBreak - +'+------------------+' - ), - - ( - Name: 'OCTET_LENGTH'; - Declaration: '(str)'; - Category: 'String Functions'; - Version: SQL_VERSION_ANSI; - Description: 'OCTET_LENGTH() is normally a synonym for LENGTH(). When'+sLineBreak - +'running Oracle mode from MariaDB 10.3, they are not'+sLineBreak - +'synonyms, but OCTET_LENGTH() behaves as LENGTH() would when'+sLineBreak - +'not in Oracle mode.' - ), - - ( - Name: 'ORD'; - Declaration: '(str)'; - Category: 'String Functions'; - Version: SQL_VERSION_ANSI; - Description: 'If the leftmost character of the string str is a multi-byte'+sLineBreak - +'character,'+sLineBreak - +'returns the code for that character, calculated from the'+sLineBreak - +'numeric'+sLineBreak - +'values of its constituent bytes using this formula:'+sLineBreak - +' '+sLineBreak - +' (1st byte code)'+sLineBreak - +'+ (2nd byte code x 256)'+sLineBreak - +'+ (3rd byte code x 256 x 256) ...'+sLineBreak - +' '+sLineBreak - +'If the leftmost character is not a multi-byte character,'+sLineBreak - +'ORD() returns'+sLineBreak - +'the same value as the ASCII() function.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT ORD(''2'');'+sLineBreak - +'+----------+'+sLineBreak - +'| ORD(''2'') |'+sLineBreak - +'+----------+'+sLineBreak - +'| 50 |'+sLineBreak - +'+----------+' - ), - - ( - Name: 'POSITION'; - Declaration: '(substr IN str)'; - Category: 'String Functions'; - Version: SQL_VERSION_ANSI; - Description: 'POSITION(substr IN str) is a synonym for LOCATE(substr,str).'+sLineBreak - +' '+sLineBreak - +'It''s part of ODBC 3.0.' - ), - - ( - Name: 'QUOTE'; - Declaration: '(str)'; - Category: 'String Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Quotes a string to produce a result that can be used as a'+sLineBreak - +'properly escaped data'+sLineBreak - +'value in an SQL statement. The string is returned enclosed'+sLineBreak - +'by single quotes and'+sLineBreak - +'with each instance of single quote ("''"), backslash'+sLineBreak - +'("\"),'+sLineBreak - +'ASCII NUL, and Control-Z preceded by a backslash. If the'+sLineBreak - +'argument'+sLineBreak - +'is NULL, the return value is the word "NULL" without'+sLineBreak - +'enclosing single'+sLineBreak - +'quotes.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT QUOTE("Don''t!");'+sLineBreak - +'+-----------------+'+sLineBreak - +'| QUOTE("Don''t!") |'+sLineBreak - +'+-----------------+'+sLineBreak - +'| ''Don\''t!'' |'+sLineBreak - +'+-----------------+'+sLineBreak - +' '+sLineBreak - +'SELECT QUOTE(NULL); '+sLineBreak - +'+-------------+'+sLineBreak - +'| QUOTE(NULL) |'+sLineBreak - +'+-------------+'+sLineBreak - +'| NULL |'+sLineBreak - +'+-------------+' - ), - - ( - Name: 'REGEXP_INSTR'; - Declaration: '(subject, pattern)'; - Category: 'String Functions'; - Version: SQL_VERSION_ANSI; - Description: '' - ), - - ( - Name: 'REGEXP_INSTR'; - Declaration: '(i.e. not in bytes)'; - Category: 'String Functions'; - Version: SQL_VERSION_ANSI; - Description: '' - ), - - ( - Name: 'REGEXP_INSTR'; - Declaration: '(?i)'; - Category: 'String Functions'; - Version: SQL_VERSION_ANSI; - Description: '' - ), - - ( - Name: 'REGEXP_INSTR'; - Declaration: '(?-i)'; - Category: 'String Functions'; - Version: SQL_VERSION_ANSI; - Description: '' - ), - - ( - Name: 'REGEXP_INSTR'; - Declaration: '(''abc'',''b'')'; - Category: 'String Functions'; - Version: SQL_VERSION_ANSI; - Description: '' - ), - - ( - Name: 'REGEXP_INSTR'; - Declaration: '(''abc'',''x'')'; - Category: 'String Functions'; - Version: SQL_VERSION_ANSI; - Description: '' - ), - - ( - Name: 'REGEXP_INSTR'; - Declaration: '(''BJגN'',''N'')'; - Category: 'String Functions'; - Version: SQL_VERSION_ANSI; - Description: '' - ), - - ( - Name: 'REGEXP_INSTR'; - Declaration: '(BINARY ''BJגN'',''N'')'; - Category: 'String Functions'; - Version: SQL_VERSION_ANSI; - Description: '' - ), - - ( - Name: 'REGEXP_INSTR'; - Declaration: '(''ABC'',''b'')'; - Category: 'String Functions'; - Version: SQL_VERSION_ANSI; - Description: '' - ), - - ( - Name: 'REGEXP_INSTR'; - Declaration: '(''ABC'' COLLATE utf8_bin,''b'')'; - Category: 'String Functions'; - Version: SQL_VERSION_ANSI; - Description: '' - ), - - ( - Name: 'REGEXP_INSTR'; - Declaration: '(BINARY''ABC'',''b'')'; - Category: 'String Functions'; - Version: SQL_VERSION_ANSI; - Description: '' - ), - - ( - Name: 'REGEXP_INSTR'; - Declaration: '(''ABC'',''(?-i)b'')'; - Category: 'String Functions'; - Version: SQL_VERSION_ANSI; - Description: '' - ), - - ( - Name: 'REGEXP_INSTR'; - Declaration: '(''ABC'' COLLATE utf8_bin,''(?i)b'')'; - Category: 'String Functions'; - Version: SQL_VERSION_ANSI; - Description: '' - ), - - ( - Name: 'REGEXP_REPLACE'; - Declaration: '(subject, pattern, replace)'; - Category: 'String Functions'; - Version: SQL_VERSION_ANSI; - Description: 'REGEXP_REPLACE returns the string subject with all'+sLineBreak - +'occurrences of the regular expression pattern replaced by'+sLineBreak - +'the string replace. If no occurrences are found, then'+sLineBreak - +'subject is returned as is.'+sLineBreak - +' '+sLineBreak - +'The replace string can have backreferences to the'+sLineBreak - +'subexpressions in the form \N, where N is a number from 1'+sLineBreak - +'to 9.'+sLineBreak - +' '+sLineBreak - +'The function follows the case sensitivity rules of the'+sLineBreak - +'effective collation. Matching is performed case'+sLineBreak - +'insensitively for case insensitive collations, and case'+sLineBreak - +'sensitively for case sensitive collations and for binary'+sLineBreak - +'data.'+sLineBreak - +' '+sLineBreak - +'The collation case sensitivity can be overwritten using the'+sLineBreak - +'(?i) and (?-i) PCRE flags.'+sLineBreak - +' '+sLineBreak - +'MariaDB 10.0.5 switched to the PCRE regular expression'+sLineBreak - +'library for enhanced regular expression performance, and'+sLineBreak - +'REGEXP_REPLACE was introduced as part of this enhancement.'+sLineBreak - +' '+sLineBreak - +'MariaDB 10.0.11 introduced the default_regex_flags variable'+sLineBreak - +'to address the remaining compatibilities between PCRE and'+sLineBreak - +'the old regex library. '+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT REGEXP_REPLACE(''ab12cd'',''[0-9]'','''') AS'+sLineBreak - +'remove_digits;'+sLineBreak - +'-> abcd'+sLineBreak - +' '+sLineBreak - +'SELECT REGEXP_REPLACE(''titlebody'', '''','' '')'+sLineBreak - +'AS strip_html;'+sLineBreak - +'-> title body'+sLineBreak - +' '+sLineBreak - +'Backreferences to the subexpressions in the form \N, where'+sLineBreak - +'N is a number from 1 to 9:'+sLineBreak - +' '+sLineBreak - +'SELECT REGEXP_REPLACE(''James Bond'',''^(.*)'+sLineBreak - +'(.*)$'',''\\2, \\1'') AS reorder_name;'+sLineBreak - +'-> Bond, James'+sLineBreak - +' '+sLineBreak - +'Case insensitive and case sensitive matches:'+sLineBreak - +' '+sLineBreak - +'SELECT REGEXP_REPLACE(''ABC'',''b'',''-'') AS'+sLineBreak - +'case_insensitive;'+sLineBreak - +'-> A-C'+sLineBreak - +' '+sLineBreak - +'SELECT REGEXP_REPLACE(''ABC'' COLLATE utf8_bin,''b'',''-'')'+sLineBreak - +'AS case_sensitive;'+sLineBreak - +'-> ABC'+sLineBreak - +' '+sLineBreak - +'SELECT REGEXP_REPLACE(BINARY ''ABC'',''b'',''-'') AS'+sLineBreak - +'binary_data;'+sLineBreak - +'-> ABC'+sLineBreak - +' '+sLineBreak - +'Overwriting the collation case sensitivity using the (?i)'+sLineBreak - +'and (?-i) PCRE flags.'+sLineBreak - +' '+sLineBreak - +'SELECT REGEXP_REPLACE(''ABC'',''(?-i)b'',''-'') AS'+sLineBreak - +'force_case_sensitive;'+sLineBreak - +'-> ABC'+sLineBreak - +' '+sLineBreak - +'SELECT REGEXP_REPLACE(BINARY ''ABC'',''(?i)b'',''-'') AS'+sLineBreak - +'force_case_insensitive;'+sLineBreak - +'-> A-C' - ), - - ( - Name: 'REGEXP_SUBSTR'; - Declaration: '(subject,pattern)'; - Category: 'String Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the part of the string subject that matches the'+sLineBreak - +'regular expression pattern, or an empty string if pattern'+sLineBreak - +'was not found.'+sLineBreak - +' '+sLineBreak - +'The function follows the case sensitivity rules of the'+sLineBreak - +'effective collation. Matching is performed case'+sLineBreak - +'insensitively for case insensitive collations, and case'+sLineBreak - +'sensitively for case sensitive collations and for binary'+sLineBreak - +'data.'+sLineBreak - +' '+sLineBreak - +'The collation case sensitivity can be overwritten using the'+sLineBreak - +'(?i) and (?-i) PCRE flags.'+sLineBreak - +' '+sLineBreak - +'MariaDB 10.0.5 switched to the PCRE regular expression'+sLineBreak - +'library for enhanced regular expression performance, and'+sLineBreak - +'REGEXP_SUBSTR was introduced as part of this enhancement.'+sLineBreak - +' '+sLineBreak - +'MariaDB 10.0.11 introduced the default_regex_flags variable'+sLineBreak - +'to address the remaining compatibilities between PCRE and'+sLineBreak - +'the old regex library. '+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT REGEXP_SUBSTR(''ab12cd'',''[0-9]+'');'+sLineBreak - +'-> 12'+sLineBreak - +' '+sLineBreak - +'SELECT REGEXP_SUBSTR('+sLineBreak - +' ''See https://mariadb.org/en/foundation/ for details'','+sLineBreak - +' ''https?://[^/]*'');'+sLineBreak - +'-> https://mariadb.org'+sLineBreak - +' '+sLineBreak - +'SELECT REGEXP_SUBSTR(''ABC'',''b'');'+sLineBreak - +'-> B'+sLineBreak - +' '+sLineBreak - +'SELECT REGEXP_SUBSTR(''ABC'' COLLATE utf8_bin,''b'');'+sLineBreak - +'->'+sLineBreak - +' '+sLineBreak - +'SELECT REGEXP_SUBSTR(BINARY''ABC'',''b'');'+sLineBreak - +'->'+sLineBreak - +' '+sLineBreak - +'SELECT REGEXP_SUBSTR(''ABC'',''(?i)b'');'+sLineBreak - +'-> B'+sLineBreak - +' '+sLineBreak - +'SELECT REGEXP_SUBSTR(''ABC'' COLLATE utf8_bin,''(?+i)b'');'+sLineBreak - +'-> B' - ), - - ( - Name: 'REVERSE'; - Declaration: '(str)'; - Category: 'String Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the string str with the order of the characters'+sLineBreak - +'reversed.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT REVERSE(''desserts'');'+sLineBreak - +'+---------------------+'+sLineBreak - +'| REVERSE(''desserts'') |'+sLineBreak - +'+---------------------+'+sLineBreak - +'| stressed |'+sLineBreak - +'+---------------------+' - ), - - ( - Name: 'RIGHT'; - Declaration: '(str,len)'; - Category: 'String Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the rightmost len characters from the string str, or'+sLineBreak - +'NULL if'+sLineBreak - +'any argument is NULL.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT RIGHT(''MariaDB'', 2);'+sLineBreak - +'+---------------------+'+sLineBreak - +'| RIGHT(''MariaDB'', 2) |'+sLineBreak - +'+---------------------+'+sLineBreak - +'| DB |'+sLineBreak - +'+---------------------+' - ), - - ( - Name: 'RPAD'; - Declaration: '(str, len [, padstr])'; - Category: 'String Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the string str, right-padded with the string padstr'+sLineBreak - +'to a'+sLineBreak - +'length of len characters. If str is longer than len, the'+sLineBreak - +'return value'+sLineBreak - +'is shortened to len characters. If padstr is omitted, the'+sLineBreak - +'RPAD function pads spaces.'+sLineBreak - +' '+sLineBreak - +'Prior to MariaDB 10.3.1, the padstr parameter was mandatory.'+sLineBreak - +' '+sLineBreak - +'Returns NULL if given a NULL argument. If the result is'+sLineBreak - +'empty (a length of zero), returns either an empty string,'+sLineBreak - +'or, from MariaDB 10.3.6 with SQL_MODE=Oracle, NULL.'+sLineBreak - +' '+sLineBreak - +'The Oracle mode version of the function can be accessed'+sLineBreak - +'outside of Oracle mode by using RPAD_ORACLE as the function'+sLineBreak - +'name.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT RPAD(''hello'',10,''.'');'+sLineBreak - +'+----------------------+'+sLineBreak - +'| RPAD(''hello'',10,''.'') |'+sLineBreak - +'+----------------------+'+sLineBreak - +'| hello..... |'+sLineBreak - +'+----------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT RPAD(''hello'',2,''.'');'+sLineBreak - +'+---------------------+'+sLineBreak - +'| RPAD(''hello'',2,''.'') |'+sLineBreak - +'+---------------------+'+sLineBreak - +'| he |'+sLineBreak - +'+---------------------+'+sLineBreak - +' '+sLineBreak - +'From MariaDB 10.3.1, with the pad string defaulting to'+sLineBreak - +'space.'+sLineBreak - +' '+sLineBreak - +'SELECT RPAD(''hello'',30);'+sLineBreak - +'+--------------------------------+'+sLineBreak - +'| RPAD(''hello'',30) |'+sLineBreak - +'+--------------------------------+'+sLineBreak - +'| hello |'+sLineBreak - +'+--------------------------------+'+sLineBreak - +' '+sLineBreak - +'Oracle mode version from MariaDB 10.3.6:'+sLineBreak - +' '+sLineBreak - +'SELECT RPAD('''',0),RPAD_ORACLE('''',0);'+sLineBreak - +'+------------+-------------------+'+sLineBreak - +'| RPAD('''',0) | RPAD_ORACLE('''',0) |'+sLineBreak - +'+------------+-------------------+'+sLineBreak - +'| | NULL |'+sLineBreak - +'+------------+-------------------+' - ), - - ( - Name: 'RTRIM'; - Declaration: '(str)'; - Category: 'String Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the string str with trailing space characters'+sLineBreak - +'removed.'+sLineBreak - +' '+sLineBreak - +'Returns NULL if given a NULL argument. If the result is'+sLineBreak - +'empty, returns either an empty string, or, from MariaDB'+sLineBreak - +'10.3.6 with SQL_MODE=Oracle, NULL.'+sLineBreak - +' '+sLineBreak - +'The Oracle mode version of the function can be accessed'+sLineBreak - +'outside of Oracle mode by using RTRIM_ORACLE as the function'+sLineBreak - +'name.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT QUOTE(RTRIM(''MariaDB ''));'+sLineBreak - +'+-----------------------------+'+sLineBreak - +'| QUOTE(RTRIM(''MariaDB '')) |'+sLineBreak - +'+-----------------------------+'+sLineBreak - +'| ''MariaDB'' |'+sLineBreak - +'+-----------------------------+'+sLineBreak - +' '+sLineBreak - +'Oracle mode version from MariaDB 10.3.6:'+sLineBreak - +' '+sLineBreak - +'SELECT RTRIM(''''),RTRIM_ORACLE('''');'+sLineBreak - +'+-----------+------------------+'+sLineBreak - +'| RTRIM('''') | RTRIM_ORACLE('''') |'+sLineBreak - +'+-----------+------------------+'+sLineBreak - +'| | NULL |'+sLineBreak - +'+-----------+------------------+' - ), - - ( - Name: 'SOUNDEX'; - Declaration: '(str)'; - Category: 'String Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns a soundex string from str. Two strings that sound'+sLineBreak - +'almost the'+sLineBreak - +'same should have identical soundex strings. A standard'+sLineBreak - +'soundex string is four'+sLineBreak - +'characters long, but the SOUNDEX() function returns an'+sLineBreak - +'arbitrarily long'+sLineBreak - +'string. You can use SUBSTRING() on the result to get a'+sLineBreak - +'standard soundex'+sLineBreak - +'string. All non-alphabetic characters in str are ignored.'+sLineBreak - +'All'+sLineBreak - +'international alphabetic characters outside the A-Z range'+sLineBreak - +'are treated as'+sLineBreak - +'vowels.'+sLineBreak - +' '+sLineBreak - +'Important: When using SOUNDEX(), you should be aware of the'+sLineBreak - +'following limitations:'+sLineBreak - +'This function, as currently implemented, is intended to work'+sLineBreak - +'well with'+sLineBreak - +' strings that are in the English language only. Strings in'+sLineBreak - +'other languages may'+sLineBreak - +' not produce reliable results.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SOUNDEX(''Hello'');'+sLineBreak - +'+------------------+'+sLineBreak - +'| SOUNDEX(''Hello'') |'+sLineBreak - +'+------------------+'+sLineBreak - +'| H400 |'+sLineBreak - +'+------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT SOUNDEX(''MariaDB'');'+sLineBreak - +'+--------------------+'+sLineBreak - +'| SOUNDEX(''MariaDB'') |'+sLineBreak - +'+--------------------+'+sLineBreak - +'| M631 |'+sLineBreak - +'+--------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT SOUNDEX(''Knowledgebase'');'+sLineBreak - +'+--------------------------+'+sLineBreak - +'| SOUNDEX(''Knowledgebase'') |'+sLineBreak - +'+--------------------------+'+sLineBreak - +'| K543212 |'+sLineBreak - +'+--------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT givenname, surname FROM users WHERE'+sLineBreak - +'SOUNDEX(givenname) = SOUNDEX("robert");'+sLineBreak - +'+-----------+---------+'+sLineBreak - +'| givenname | surname |'+sLineBreak - +'+-----------+---------+'+sLineBreak - +'| Roberto | Castro |'+sLineBreak - +'+-----------+---------+' - ), - - ( - Name: 'SPACE'; - Declaration: '(N)'; - Category: 'String Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns a string consisting of N space characters. If N is'+sLineBreak - +'NULL, returns NULL.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT QUOTE(SPACE(6));'+sLineBreak - +'+-----------------+'+sLineBreak - +'| QUOTE(SPACE(6)) |'+sLineBreak - +'+-----------------+'+sLineBreak - +'| '' '' |'+sLineBreak - +'+-----------------+' - ), - - ( - Name: 'STRCMP'; - Declaration: '(expr1,expr2)'; - Category: 'String Functions'; - Version: SQL_VERSION_ANSI; - Description: 'STRCMP() returns 0 if the strings are the same, -1 if the'+sLineBreak - +'first'+sLineBreak - +'argument is smaller than the second according to the current'+sLineBreak - +'sort order,'+sLineBreak - +'and 1 otherwise.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT STRCMP(''text'', ''text2'');'+sLineBreak - +'+-------------------------+'+sLineBreak - +'| STRCMP(''text'', ''text2'') |'+sLineBreak - +'+-------------------------+'+sLineBreak - +'| -1 |'+sLineBreak - +'+-------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT STRCMP(''text2'', ''text'');'+sLineBreak - +'+-------------------------+'+sLineBreak - +'| STRCMP(''text2'', ''text'') |'+sLineBreak - +'+-------------------------+'+sLineBreak - +'| 1 |'+sLineBreak - +'+-------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT STRCMP(''text'', ''text'');'+sLineBreak - +'+------------------------+'+sLineBreak - +'| STRCMP(''text'', ''text'') |'+sLineBreak - +'+------------------------+'+sLineBreak - +'| 0 |'+sLineBreak - +'+------------------------+' - ), - - ( - Name: 'SUBSTRING'; - Declaration: '(str,pos)'; - Category: 'String Functions'; - Version: SQL_VERSION_ANSI; - Description: 'The forms without a len argument return a substring from'+sLineBreak - +'string str starting at position pos.'+sLineBreak - +' '+sLineBreak - +'The forms with a len argument return a substring len'+sLineBreak - +'characters long from string str, starting at position pos.'+sLineBreak - +' '+sLineBreak - +'The forms that use FROM are standard SQL syntax.'+sLineBreak - +' '+sLineBreak - +'It is also possible to use a negative value for pos. In this'+sLineBreak - +'case, the beginning of the substring is pos characters from'+sLineBreak - +'the end of the string, rather than the beginning. A negative'+sLineBreak - +'value may be used for pos in any of the forms of this'+sLineBreak - +'function.'+sLineBreak - +' '+sLineBreak - +'By default, the position of the first character in the'+sLineBreak - +'string from which the substring is to be extracted is'+sLineBreak - +'reckoned as 1. For Oracle-compatibility, from MariaDB'+sLineBreak - +'10.3.3, when sql_mode is set to ''oracle'', position zero is'+sLineBreak - +'treated as position 1 (although the first character is still'+sLineBreak - +'reckoned as 1).'+sLineBreak - +' '+sLineBreak - +'If any argument is NULL, returns NULL.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT SUBSTRING(''Knowledgebase'',5);'+sLineBreak - +'+------------------------------+'+sLineBreak - +'| SUBSTRING(''Knowledgebase'',5) |'+sLineBreak - +'+------------------------------+'+sLineBreak - +'| ledgebase |'+sLineBreak - +'+------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT SUBSTRING(''MariaDB'' FROM 6);'+sLineBreak - +'+-----------------------------+'+sLineBreak - +'| SUBSTRING(''MariaDB'' FROM 6) |'+sLineBreak - +'+-----------------------------+'+sLineBreak - +'| DB |'+sLineBreak - +'+-----------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT SUBSTRING(''Knowledgebase'',3,7);'+sLineBreak - +'+--------------------------------+'+sLineBreak - +'| SUBSTRING(''Knowledgebase'',3,7) |'+sLineBreak - +'+--------------------------------+'+sLineBreak - +'| owledge |'+sLineBreak - +'+--------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT SUBSTRING(''Knowledgebase'', -4);'+sLineBreak - +'+--------------------------------+'+sLineBreak - +'| SUBSTRING(''Knowledgebase'', -4) |'+sLineBreak - +'+--------------------------------+'+sLineBreak - +'| base |'+sLineBreak - +'+--------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT SUBSTRING(''Knowledgebase'', -8, 4);'+sLineBreak - +'+-----------------------------------+'+sLineBreak - +'| SUBSTRING(''Knowledgebase'', -8, 4) |'+sLineBreak - +'+-----------------------------------+'+sLineBreak - +'| edge |'+sLineBreak - +'+-----------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT SUBSTRING(''Knowledgebase'' FROM -8 FOR 4);'+sLineBreak - +'+------------------------------------------+'+sLineBreak - +'| SUBSTRING(''Knowledgebase'' FROM -8 FOR 4) |'+sLineBreak - +'+------------------------------------------+'+sLineBreak - +'| edge |'+sLineBreak - +'+------------------------------------------+'+sLineBreak - +' '+sLineBreak - +'Oracle mode from MariaDB 10.3.3:'+sLineBreak - +' '+sLineBreak - +'SELECT SUBSTR(''abc'',0,3);'+sLineBreak - +'+-------------------+'+sLineBreak - +'| SUBSTR(''abc'',0,3) |'+sLineBreak - +'+-------------------+'+sLineBreak - +'| |'+sLineBreak - +'+-------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT SUBSTR(''abc'',1,2);'+sLineBreak - +'+-------------------+'+sLineBreak - +'| SUBSTR(''abc'',1,2) |'+sLineBreak - +'+-------------------+'+sLineBreak - +'| ab |'+sLineBreak - +'+-------------------+'+sLineBreak - +' '+sLineBreak - +'SET sql_mode=''oracle'';'+sLineBreak - +' '+sLineBreak - +'SELECT SUBSTR(''abc'',0,3);'+sLineBreak - +'+-------------------+'+sLineBreak - +'| SUBSTR(''abc'',0,3) |'+sLineBreak - +'+-------------------+'+sLineBreak - +'| abc |'+sLineBreak - +'+-------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT SUBSTR(''abc'',1,2);'+sLineBreak - +'+-------------------+'+sLineBreak - +'| SUBSTR(''abc'',1,2) |'+sLineBreak - +'+-------------------+'+sLineBreak - +'| ab |'+sLineBreak - +'+-------------------+' - ), - - ( - Name: 'SUBSTRING'; - Declaration: '(str FROM pos)'; - Category: 'String Functions'; - Version: SQL_VERSION_ANSI; - Description: 'The forms without a len argument return a substring from'+sLineBreak - +'string str starting at position pos.'+sLineBreak - +' '+sLineBreak - +'The forms with a len argument return a substring len'+sLineBreak - +'characters long from string str, starting at position pos.'+sLineBreak - +' '+sLineBreak - +'The forms that use FROM are standard SQL syntax.'+sLineBreak - +' '+sLineBreak - +'It is also possible to use a negative value for pos. In this'+sLineBreak - +'case, the beginning of the substring is pos characters from'+sLineBreak - +'the end of the string, rather than the beginning. A negative'+sLineBreak - +'value may be used for pos in any of the forms of this'+sLineBreak - +'function.'+sLineBreak - +' '+sLineBreak - +'By default, the position of the first character in the'+sLineBreak - +'string from which the substring is to be extracted is'+sLineBreak - +'reckoned as 1. For Oracle-compatibility, from MariaDB'+sLineBreak - +'10.3.3, when sql_mode is set to ''oracle'', position zero is'+sLineBreak - +'treated as position 1 (although the first character is still'+sLineBreak - +'reckoned as 1).'+sLineBreak - +' '+sLineBreak - +'If any argument is NULL, returns NULL.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT SUBSTRING(''Knowledgebase'',5);'+sLineBreak - +'+------------------------------+'+sLineBreak - +'| SUBSTRING(''Knowledgebase'',5) |'+sLineBreak - +'+------------------------------+'+sLineBreak - +'| ledgebase |'+sLineBreak - +'+------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT SUBSTRING(''MariaDB'' FROM 6);'+sLineBreak - +'+-----------------------------+'+sLineBreak - +'| SUBSTRING(''MariaDB'' FROM 6) |'+sLineBreak - +'+-----------------------------+'+sLineBreak - +'| DB |'+sLineBreak - +'+-----------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT SUBSTRING(''Knowledgebase'',3,7);'+sLineBreak - +'+--------------------------------+'+sLineBreak - +'| SUBSTRING(''Knowledgebase'',3,7) |'+sLineBreak - +'+--------------------------------+'+sLineBreak - +'| owledge |'+sLineBreak - +'+--------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT SUBSTRING(''Knowledgebase'', -4);'+sLineBreak - +'+--------------------------------+'+sLineBreak - +'| SUBSTRING(''Knowledgebase'', -4) |'+sLineBreak - +'+--------------------------------+'+sLineBreak - +'| base |'+sLineBreak - +'+--------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT SUBSTRING(''Knowledgebase'', -8, 4);'+sLineBreak - +'+-----------------------------------+'+sLineBreak - +'| SUBSTRING(''Knowledgebase'', -8, 4) |'+sLineBreak - +'+-----------------------------------+'+sLineBreak - +'| edge |'+sLineBreak - +'+-----------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT SUBSTRING(''Knowledgebase'' FROM -8 FOR 4);'+sLineBreak - +'+------------------------------------------+'+sLineBreak - +'| SUBSTRING(''Knowledgebase'' FROM -8 FOR 4) |'+sLineBreak - +'+------------------------------------------+'+sLineBreak - +'| edge |'+sLineBreak - +'+------------------------------------------+'+sLineBreak - +' '+sLineBreak - +'Oracle mode from MariaDB 10.3.3:'+sLineBreak - +' '+sLineBreak - +'SELECT SUBSTR(''abc'',0,3);'+sLineBreak - +'+-------------------+'+sLineBreak - +'| SUBSTR(''abc'',0,3) |'+sLineBreak - +'+-------------------+'+sLineBreak - +'| |'+sLineBreak - +'+-------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT SUBSTR(''abc'',1,2);'+sLineBreak - +'+-------------------+'+sLineBreak - +'| SUBSTR(''abc'',1,2) |'+sLineBreak - +'+-------------------+'+sLineBreak - +'| ab |'+sLineBreak - +'+-------------------+'+sLineBreak - +' '+sLineBreak - +'SET sql_mode=''oracle'';'+sLineBreak - +' '+sLineBreak - +'SELECT SUBSTR(''abc'',0,3);'+sLineBreak - +'+-------------------+'+sLineBreak - +'| SUBSTR(''abc'',0,3) |'+sLineBreak - +'+-------------------+'+sLineBreak - +'| abc |'+sLineBreak - +'+-------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT SUBSTR(''abc'',1,2);'+sLineBreak - +'+-------------------+'+sLineBreak - +'| SUBSTR(''abc'',1,2) |'+sLineBreak - +'+-------------------+'+sLineBreak - +'| ab |'+sLineBreak - +'+-------------------+' - ), - - ( - Name: 'SUBSTRING'; - Declaration: '(str,pos,len)'; - Category: 'String Functions'; - Version: SQL_VERSION_ANSI; - Description: 'The forms without a len argument return a substring from'+sLineBreak - +'string str starting at position pos.'+sLineBreak - +' '+sLineBreak - +'The forms with a len argument return a substring len'+sLineBreak - +'characters long from string str, starting at position pos.'+sLineBreak - +' '+sLineBreak - +'The forms that use FROM are standard SQL syntax.'+sLineBreak - +' '+sLineBreak - +'It is also possible to use a negative value for pos. In this'+sLineBreak - +'case, the beginning of the substring is pos characters from'+sLineBreak - +'the end of the string, rather than the beginning. A negative'+sLineBreak - +'value may be used for pos in any of the forms of this'+sLineBreak - +'function.'+sLineBreak - +' '+sLineBreak - +'By default, the position of the first character in the'+sLineBreak - +'string from which the substring is to be extracted is'+sLineBreak - +'reckoned as 1. For Oracle-compatibility, from MariaDB'+sLineBreak - +'10.3.3, when sql_mode is set to ''oracle'', position zero is'+sLineBreak - +'treated as position 1 (although the first character is still'+sLineBreak - +'reckoned as 1).'+sLineBreak - +' '+sLineBreak - +'If any argument is NULL, returns NULL.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT SUBSTRING(''Knowledgebase'',5);'+sLineBreak - +'+------------------------------+'+sLineBreak - +'| SUBSTRING(''Knowledgebase'',5) |'+sLineBreak - +'+------------------------------+'+sLineBreak - +'| ledgebase |'+sLineBreak - +'+------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT SUBSTRING(''MariaDB'' FROM 6);'+sLineBreak - +'+-----------------------------+'+sLineBreak - +'| SUBSTRING(''MariaDB'' FROM 6) |'+sLineBreak - +'+-----------------------------+'+sLineBreak - +'| DB |'+sLineBreak - +'+-----------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT SUBSTRING(''Knowledgebase'',3,7);'+sLineBreak - +'+--------------------------------+'+sLineBreak - +'| SUBSTRING(''Knowledgebase'',3,7) |'+sLineBreak - +'+--------------------------------+'+sLineBreak - +'| owledge |'+sLineBreak - +'+--------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT SUBSTRING(''Knowledgebase'', -4);'+sLineBreak - +'+--------------------------------+'+sLineBreak - +'| SUBSTRING(''Knowledgebase'', -4) |'+sLineBreak - +'+--------------------------------+'+sLineBreak - +'| base |'+sLineBreak - +'+--------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT SUBSTRING(''Knowledgebase'', -8, 4);'+sLineBreak - +'+-----------------------------------+'+sLineBreak - +'| SUBSTRING(''Knowledgebase'', -8, 4) |'+sLineBreak - +'+-----------------------------------+'+sLineBreak - +'| edge |'+sLineBreak - +'+-----------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT SUBSTRING(''Knowledgebase'' FROM -8 FOR 4);'+sLineBreak - +'+------------------------------------------+'+sLineBreak - +'| SUBSTRING(''Knowledgebase'' FROM -8 FOR 4) |'+sLineBreak - +'+------------------------------------------+'+sLineBreak - +'| edge |'+sLineBreak - +'+------------------------------------------+'+sLineBreak - +' '+sLineBreak - +'Oracle mode from MariaDB 10.3.3:'+sLineBreak - +' '+sLineBreak - +'SELECT SUBSTR(''abc'',0,3);'+sLineBreak - +'+-------------------+'+sLineBreak - +'| SUBSTR(''abc'',0,3) |'+sLineBreak - +'+-------------------+'+sLineBreak - +'| |'+sLineBreak - +'+-------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT SUBSTR(''abc'',1,2);'+sLineBreak - +'+-------------------+'+sLineBreak - +'| SUBSTR(''abc'',1,2) |'+sLineBreak - +'+-------------------+'+sLineBreak - +'| ab |'+sLineBreak - +'+-------------------+'+sLineBreak - +' '+sLineBreak - +'SET sql_mode=''oracle'';'+sLineBreak - +' '+sLineBreak - +'SELECT SUBSTR(''abc'',0,3);'+sLineBreak - +'+-------------------+'+sLineBreak - +'| SUBSTR(''abc'',0,3) |'+sLineBreak - +'+-------------------+'+sLineBreak - +'| abc |'+sLineBreak - +'+-------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT SUBSTR(''abc'',1,2);'+sLineBreak - +'+-------------------+'+sLineBreak - +'| SUBSTR(''abc'',1,2) |'+sLineBreak - +'+-------------------+'+sLineBreak - +'| ab |'+sLineBreak - +'+-------------------+' - ), - - ( - Name: 'SUBSTRING'; - Declaration: '(str FROM pos FOR len)'; - Category: 'String Functions'; - Version: SQL_VERSION_ANSI; - Description: 'The forms without a len argument return a substring from'+sLineBreak - +'string str starting at position pos.'+sLineBreak - +' '+sLineBreak - +'The forms with a len argument return a substring len'+sLineBreak - +'characters long from string str, starting at position pos.'+sLineBreak - +' '+sLineBreak - +'The forms that use FROM are standard SQL syntax.'+sLineBreak - +' '+sLineBreak - +'It is also possible to use a negative value for pos. In this'+sLineBreak - +'case, the beginning of the substring is pos characters from'+sLineBreak - +'the end of the string, rather than the beginning. A negative'+sLineBreak - +'value may be used for pos in any of the forms of this'+sLineBreak - +'function.'+sLineBreak - +' '+sLineBreak - +'By default, the position of the first character in the'+sLineBreak - +'string from which the substring is to be extracted is'+sLineBreak - +'reckoned as 1. For Oracle-compatibility, from MariaDB'+sLineBreak - +'10.3.3, when sql_mode is set to ''oracle'', position zero is'+sLineBreak - +'treated as position 1 (although the first character is still'+sLineBreak - +'reckoned as 1).'+sLineBreak - +' '+sLineBreak - +'If any argument is NULL, returns NULL.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT SUBSTRING(''Knowledgebase'',5);'+sLineBreak - +'+------------------------------+'+sLineBreak - +'| SUBSTRING(''Knowledgebase'',5) |'+sLineBreak - +'+------------------------------+'+sLineBreak - +'| ledgebase |'+sLineBreak - +'+------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT SUBSTRING(''MariaDB'' FROM 6);'+sLineBreak - +'+-----------------------------+'+sLineBreak - +'| SUBSTRING(''MariaDB'' FROM 6) |'+sLineBreak - +'+-----------------------------+'+sLineBreak - +'| DB |'+sLineBreak - +'+-----------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT SUBSTRING(''Knowledgebase'',3,7);'+sLineBreak - +'+--------------------------------+'+sLineBreak - +'| SUBSTRING(''Knowledgebase'',3,7) |'+sLineBreak - +'+--------------------------------+'+sLineBreak - +'| owledge |'+sLineBreak - +'+--------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT SUBSTRING(''Knowledgebase'', -4);'+sLineBreak - +'+--------------------------------+'+sLineBreak - +'| SUBSTRING(''Knowledgebase'', -4) |'+sLineBreak - +'+--------------------------------+'+sLineBreak - +'| base |'+sLineBreak - +'+--------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT SUBSTRING(''Knowledgebase'', -8, 4);'+sLineBreak - +'+-----------------------------------+'+sLineBreak - +'| SUBSTRING(''Knowledgebase'', -8, 4) |'+sLineBreak - +'+-----------------------------------+'+sLineBreak - +'| edge |'+sLineBreak - +'+-----------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT SUBSTRING(''Knowledgebase'' FROM -8 FOR 4);'+sLineBreak - +'+------------------------------------------+'+sLineBreak - +'| SUBSTRING(''Knowledgebase'' FROM -8 FOR 4) |'+sLineBreak - +'+------------------------------------------+'+sLineBreak - +'| edge |'+sLineBreak - +'+------------------------------------------+'+sLineBreak - +' '+sLineBreak - +'Oracle mode from MariaDB 10.3.3:'+sLineBreak - +' '+sLineBreak - +'SELECT SUBSTR(''abc'',0,3);'+sLineBreak - +'+-------------------+'+sLineBreak - +'| SUBSTR(''abc'',0,3) |'+sLineBreak - +'+-------------------+'+sLineBreak - +'| |'+sLineBreak - +'+-------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT SUBSTR(''abc'',1,2);'+sLineBreak - +'+-------------------+'+sLineBreak - +'| SUBSTR(''abc'',1,2) |'+sLineBreak - +'+-------------------+'+sLineBreak - +'| ab |'+sLineBreak - +'+-------------------+'+sLineBreak - +' '+sLineBreak - +'SET sql_mode=''oracle'';'+sLineBreak - +' '+sLineBreak - +'SELECT SUBSTR(''abc'',0,3);'+sLineBreak - +'+-------------------+'+sLineBreak - +'| SUBSTR(''abc'',0,3) |'+sLineBreak - +'+-------------------+'+sLineBreak - +'| abc |'+sLineBreak - +'+-------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT SUBSTR(''abc'',1,2);'+sLineBreak - +'+-------------------+'+sLineBreak - +'| SUBSTR(''abc'',1,2) |'+sLineBreak - +'+-------------------+'+sLineBreak - +'| ab |'+sLineBreak - +'+-------------------+' - ), - - ( - Name: 'SUBSTRING_INDEX'; - Declaration: '(str,delim,count)'; - Category: 'String Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the substring from string str before count'+sLineBreak - +'occurrences of the'+sLineBreak - +'delimiter delim. If count is positive, everything to the'+sLineBreak - +'left'+sLineBreak - +'of the final delimiter (counting from the left) is returned.'+sLineBreak - +'If count'+sLineBreak - +'is negative, everything to the right of the final delimiter'+sLineBreak - +'(counting from the'+sLineBreak - +'right) is returned. SUBSTRING_INDEX() performs a'+sLineBreak - +'case-sensitive match when'+sLineBreak - +'searching for delim.'+sLineBreak - +' '+sLineBreak - +'If any argument is NULL, returns NULL.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT SUBSTRING_INDEX(''www.mariadb.org'', ''.'', 2);'+sLineBreak - +'+--------------------------------------------+'+sLineBreak - +'| SUBSTRING_INDEX(''www.mariadb.org'', ''.'', 2) |'+sLineBreak - +'+--------------------------------------------+'+sLineBreak - +'| www.mariadb |'+sLineBreak - +'+--------------------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT SUBSTRING_INDEX(''www.mariadb.org'', ''.'', -2);'+sLineBreak - +'+---------------------------------------------+'+sLineBreak - +'| SUBSTRING_INDEX(''www.mariadb.org'', ''.'', -2) |'+sLineBreak - +'+---------------------------------------------+'+sLineBreak - +'| mariadb.org |'+sLineBreak - +'+---------------------------------------------+' - ), - - ( - Name: 'TO_BASE64'; - Declaration: '(str)'; - Category: 'String Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Converts the string argument str to its base-64 encoded'+sLineBreak - +'form, returning the result as a character string in the'+sLineBreak - +'connection character set and collation.'+sLineBreak - +' '+sLineBreak - +'The argument str will be converted to string first if it is'+sLineBreak - +'not a string. A NULL argument will return a NULL result.'+sLineBreak - +' '+sLineBreak - +'The reverse function, FROM_BASE64(), decodes an encoded'+sLineBreak - +'base-64 string.'+sLineBreak - +' '+sLineBreak - +'There are a numerous different methods to base-64 encode a'+sLineBreak - +'string. The following are used by MariaDB and MySQL:'+sLineBreak - +'Alphabet value 64 is encoded as ''+''.'+sLineBreak - +'Alphabet value 63 is encoded as ''/''.'+sLineBreak - +'Encoding output is made up of groups of four printable'+sLineBreak - +'characters, with each three bytes of data encoded using four'+sLineBreak - +'characters. If the final group is not complete, it is padded'+sLineBreak - +'with ''='' characters to make up a length of four.'+sLineBreak - +'To divide long output, a newline is added after every 76'+sLineBreak - +'characters.'+sLineBreak - +'Decoding will recognize and ignore newlines, carriage'+sLineBreak - +'returns, tabs, and spaces. '+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT TO_BASE64(''Maria'');'+sLineBreak - +'+--------------------+'+sLineBreak - +'| TO_BASE64(''Maria'') |'+sLineBreak - +'+--------------------+'+sLineBreak - +'| TWFyaWE= |'+sLineBreak - +'+--------------------+' - ), - - ( - Name: 'TRIM'; - Declaration: '([{BOTH | LEADING | TRAILING} [remstr] FROM] str)'; - Category: 'String Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the string str with all remstr prefixes or suffixes'+sLineBreak - +'removed. If none of the specifiers BOTH, LEADING, or'+sLineBreak - +'TRAILING is given, BOTH is assumed. remstr is optional and,'+sLineBreak - +'if not specified, spaces are removed.'+sLineBreak - +' '+sLineBreak - +'Returns NULL if given a NULL argument. If the result is'+sLineBreak - +'empty, returns either an empty string, or, from MariaDB'+sLineBreak - +'10.3.6 with SQL_MODE=Oracle, NULL.'+sLineBreak - +' '+sLineBreak - +'The Oracle mode version of the function can be accessed'+sLineBreak - +'outside of Oracle mode by using TRIM_ORACLE as the function'+sLineBreak - +'name.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT TRIM('' bar '')\G'+sLineBreak - +'*************************** 1. row'+sLineBreak - +'***************************'+sLineBreak - +'TRIM('' bar ''): bar'+sLineBreak - +' '+sLineBreak - +'SELECT TRIM(LEADING ''x'' FROM ''xxxbarxxx'')\G'+sLineBreak - +'*************************** 1. row'+sLineBreak - +'***************************'+sLineBreak - +'TRIM(LEADING ''x'' FROM ''xxxbarxxx''): barxxx'+sLineBreak - +' '+sLineBreak - +'SELECT TRIM(BOTH ''x'' FROM ''xxxbarxxx'')\G'+sLineBreak - +'*************************** 1. row'+sLineBreak - +'***************************'+sLineBreak - +'TRIM(BOTH ''x'' FROM ''xxxbarxxx''): bar'+sLineBreak - +' '+sLineBreak - +'SELECT TRIM(TRAILING ''xyz'' FROM ''barxxyz'')\G'+sLineBreak - +'*************************** 1. row'+sLineBreak - +'***************************'+sLineBreak - +'TRIM(TRAILING ''xyz'' FROM ''barxxyz''): barx'+sLineBreak - +' '+sLineBreak - +'Oracle mode version from MariaDB 10.3.6:'+sLineBreak - +' '+sLineBreak - +'SELECT TRIM(''''),TRIM_ORACLE('''');'+sLineBreak - +'+----------+-----------------+'+sLineBreak - +'| TRIM('''') | TRIM_ORACLE('''') |'+sLineBreak - +'+----------+-----------------+'+sLineBreak - +'| | NULL |'+sLineBreak - +'+----------+-----------------+' - ), - - ( - Name: 'TRIM'; - Declaration: '([remstr FROM] str)'; - Category: 'String Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the string str with all remstr prefixes or suffixes'+sLineBreak - +'removed. If none of the specifiers BOTH, LEADING, or'+sLineBreak - +'TRAILING is given, BOTH is assumed. remstr is optional and,'+sLineBreak - +'if not specified, spaces are removed.'+sLineBreak - +' '+sLineBreak - +'Returns NULL if given a NULL argument. If the result is'+sLineBreak - +'empty, returns either an empty string, or, from MariaDB'+sLineBreak - +'10.3.6 with SQL_MODE=Oracle, NULL.'+sLineBreak - +' '+sLineBreak - +'The Oracle mode version of the function can be accessed'+sLineBreak - +'outside of Oracle mode by using TRIM_ORACLE as the function'+sLineBreak - +'name.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT TRIM('' bar '')\G'+sLineBreak - +'*************************** 1. row'+sLineBreak - +'***************************'+sLineBreak - +'TRIM('' bar ''): bar'+sLineBreak - +' '+sLineBreak - +'SELECT TRIM(LEADING ''x'' FROM ''xxxbarxxx'')\G'+sLineBreak - +'*************************** 1. row'+sLineBreak - +'***************************'+sLineBreak - +'TRIM(LEADING ''x'' FROM ''xxxbarxxx''): barxxx'+sLineBreak - +' '+sLineBreak - +'SELECT TRIM(BOTH ''x'' FROM ''xxxbarxxx'')\G'+sLineBreak - +'*************************** 1. row'+sLineBreak - +'***************************'+sLineBreak - +'TRIM(BOTH ''x'' FROM ''xxxbarxxx''): bar'+sLineBreak - +' '+sLineBreak - +'SELECT TRIM(TRAILING ''xyz'' FROM ''barxxyz'')\G'+sLineBreak - +'*************************** 1. row'+sLineBreak - +'***************************'+sLineBreak - +'TRIM(TRAILING ''xyz'' FROM ''barxxyz''): barx'+sLineBreak - +' '+sLineBreak - +'Oracle mode version from MariaDB 10.3.6:'+sLineBreak - +' '+sLineBreak - +'SELECT TRIM(''''),TRIM_ORACLE('''');'+sLineBreak - +'+----------+-----------------+'+sLineBreak - +'| TRIM('''') | TRIM_ORACLE('''') |'+sLineBreak - +'+----------+-----------------+'+sLineBreak - +'| | NULL |'+sLineBreak - +'+----------+-----------------+' - ), - - ( - Name: 'UCASE'; - Declaration: '(str)'; - Category: 'String Functions'; - Version: SQL_VERSION_ANSI; - Description: 'UCASE() is a synonym for UPPER().' - ), - - ( - Name: 'UNHEX'; - Declaration: '(str)'; - Category: 'String Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Performs the inverse operation of HEX(str). That is, it'+sLineBreak - +'interprets'+sLineBreak - +'each pair of hexadecimal digits in the argument as a number'+sLineBreak - +'and'+sLineBreak - +'converts it to the character represented by the number. The'+sLineBreak - +'resulting'+sLineBreak - +'characters are returned as a binary string.'+sLineBreak - +' '+sLineBreak - +'If str is NULL, UNHEX() returns NULL.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT HEX(''MariaDB'');'+sLineBreak - +'+----------------+'+sLineBreak - +'| HEX(''MariaDB'') |'+sLineBreak - +'+----------------+'+sLineBreak - +'| 4D617269614442 |'+sLineBreak - +'+----------------+'+sLineBreak - +' '+sLineBreak - +'SELECT UNHEX(''4D617269614442'');'+sLineBreak - +'+-------------------------+'+sLineBreak - +'| UNHEX(''4D617269614442'') |'+sLineBreak - +'+-------------------------+'+sLineBreak - +'| MariaDB |'+sLineBreak - +'+-------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT 0x4D617269614442;'+sLineBreak - +' '+sLineBreak - +'+------------------+'+sLineBreak - +'| 0x4D617269614442 |'+sLineBreak - +'+------------------+'+sLineBreak - +'| MariaDB |'+sLineBreak - +'+------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT UNHEX(HEX(''string''));'+sLineBreak - +'+----------------------+'+sLineBreak - +'| UNHEX(HEX(''string'')) |'+sLineBreak - +'+----------------------+'+sLineBreak - +'| string |'+sLineBreak - +'+----------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT HEX(UNHEX(''1267''));'+sLineBreak - +'+--------------------+'+sLineBreak - +'| HEX(UNHEX(''1267'')) |'+sLineBreak - +'+--------------------+'+sLineBreak - +'| 1267 |'+sLineBreak - +'+--------------------+' - ), - - ( - Name: 'UPDATEXML'; - Declaration: '(xml_target, xpath_expr, new_xml)'; - Category: 'String Functions'; - Version: SQL_VERSION_ANSI; - Description: 'This function replaces a single portion of a given fragment'+sLineBreak - +'of XML markup'+sLineBreak - +'xml_target with a new XML fragment new_xml, and then returns'+sLineBreak - +'the'+sLineBreak - +'changed XML. The portion of xml_target that is replaced'+sLineBreak - +'matches an XPath'+sLineBreak - +'expression xpath_expr supplied by the user. If no expression'+sLineBreak - +'matching'+sLineBreak - +'xpath_expr is found, or if multiple matches are found, the'+sLineBreak - +'function returns'+sLineBreak - +'the original xml_target XML fragment. All three arguments'+sLineBreak - +'should be'+sLineBreak - +'strings.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SELECT'+sLineBreak - +' UpdateXML(''ccc'', ''/a'', ''fff'') AS val1,'+sLineBreak - +' UpdateXML(''ccc'', ''/b'', ''fff'') AS val2,'+sLineBreak - +' UpdateXML(''ccc'', ''//b'', ''fff'') AS val3,'+sLineBreak - +' UpdateXML(''ccc'', ''/a/d'', ''fff'') AS val4,'+sLineBreak - +' UpdateXML(''ccc'', ''/a/d'', ''fff'') AS val5'+sLineBreak - +' \G'+sLineBreak - +'*************************** 1. row'+sLineBreak - +'***************************'+sLineBreak - +'val1: fff'+sLineBreak - +'val2: ccc'+sLineBreak - +'val3: fff'+sLineBreak - +'val4: cccfff'+sLineBreak - +'val5: ccc'+sLineBreak - +'1 row in set (0.00 sec)' - ), - - ( - Name: 'UPPER'; - Declaration: '(str)'; - Category: 'String Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns the string str with all characters changed to'+sLineBreak - +'uppercase'+sLineBreak - +'according to the current character set mapping. The default'+sLineBreak - +'is latin1'+sLineBreak - +'(cp1252 West European).'+sLineBreak - +' '+sLineBreak - +'SELECT UPPER(surname), givenname FROM users ORDER BY'+sLineBreak - +'surname;'+sLineBreak - +' '+sLineBreak - +'+----------------+------------+'+sLineBreak - +'| UPPER(surname) | givenname |'+sLineBreak - +'+----------------+------------+'+sLineBreak - +'| ABEL | Jacinto |'+sLineBreak - +'| CASTRO | Robert |'+sLineBreak - +'| COSTA | Phestos |'+sLineBreak - +'| MOSCHELLA | Hippolytos |'+sLineBreak - +'+----------------+------------+'+sLineBreak - +' '+sLineBreak - +'UPPER() is ineffective when applied to binary strings'+sLineBreak - +'(BINARY,'+sLineBreak - +'VARBINARY, BLOB). The description of '+sLineBreak - +'LOWER() shows how to'+sLineBreak - +'perform lettercase conversion of binary strings.' - ), - - ( - Name: 'WEIGHT_STRING'; - Declaration: '(str [AS {CHAR|BINARY}(N)] [LEVEL levels] [flags])'; - Category: 'String Functions'; - Version: SQL_VERSION_ANSI; - Description: 'Returns a binary string representing the string''s sorting'+sLineBreak - +'and comparison value. A string with a lower result means'+sLineBreak - +'that for sorting purposes the string appears before a string'+sLineBreak - +'with a higher result.'+sLineBreak - +' '+sLineBreak - +'WEIGHT_STRING() is particularly useful when adding new'+sLineBreak - +'collations, for testing purposes.'+sLineBreak - +' '+sLineBreak - +'If str is a non-binary string (CHAR, VARCHAR or TEXT),'+sLineBreak - +'WEIGHT_STRING returns the string''s collation weight. If str'+sLineBreak - +'is a binary string (BINARY, VARBINARY or BLOB), the return'+sLineBreak - +'value is simply the input value, since the weight for each'+sLineBreak - +'byte in a binary string is the byte value.'+sLineBreak - +' '+sLineBreak - +'WEIGHT_STRING() returns NULL if given a NULL input. '+sLineBreak - +' '+sLineBreak - +'The optional AS clause permits casting the input string to a'+sLineBreak - +'binary or non-binary string, as well as to a particular'+sLineBreak - +'length.'+sLineBreak - +' '+sLineBreak - +'AS BINARY(N) measures the length in bytes rather than'+sLineBreak - +'characters, and right pads with 0x00 bytes to the desired'+sLineBreak - +'length. '+sLineBreak - +' '+sLineBreak - +'AS CHAR(N) measures the length in characters, and right pads'+sLineBreak - +'with spaces to the desired length.'+sLineBreak - +' '+sLineBreak - +'N has a minimum value of 1, and if it is less than the'+sLineBreak - +'length of the input string, the string is truncated without'+sLineBreak - +'warning.'+sLineBreak - +' '+sLineBreak - +'The optional LEVEL clause specifies that the return value'+sLineBreak - +'should contain weights for specific collation levels. The'+sLineBreak - +'levels specifier can either be a single integer, a'+sLineBreak - +'comma-separated list of integers, or a range of integers'+sLineBreak - +'separated by a dash (whitespace is ignored). Integers can'+sLineBreak - +'range from 1 to a maximum of 6, dependent on the collation,'+sLineBreak - +'and need to be listed in ascending order.'+sLineBreak - +' '+sLineBreak - +'If the LEVEL clause is no provided, a default of 1 to the'+sLineBreak - +'maximum for the collation is assumed.'+sLineBreak - +' '+sLineBreak - +'If the LEVEL is specified without using a range, an optional'+sLineBreak - +'modifier is permitted.'+sLineBreak - +' '+sLineBreak - +'ASC, the default, returns the weights without any'+sLineBreak - +'modification.'+sLineBreak - +' '+sLineBreak - +'DESC returns bitwise-inverted weights.'+sLineBreak - +' '+sLineBreak - +'REVERSE returns the weights in reverse order.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'The examples below use the HEX() function to represent'+sLineBreak - +'non-printable results in hexadecimal format.'+sLineBreak - +' '+sLineBreak - +'SELECT HEX(WEIGHT_STRING(''x''));'+sLineBreak - +'+-------------------------+'+sLineBreak - +'| HEX(WEIGHT_STRING(''x'')) |'+sLineBreak - +'+-------------------------+'+sLineBreak - +'| 0058 |'+sLineBreak - +'+-------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT HEX(WEIGHT_STRING(''x'' AS BINARY(4)));'+sLineBreak - +'+--------------------------------------+'+sLineBreak - +'| HEX(WEIGHT_STRING(''x'' AS BINARY(4))) |'+sLineBreak - +'+--------------------------------------+'+sLineBreak - +'| 78000000 |'+sLineBreak - +'+--------------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT HEX(WEIGHT_STRING(''x'' AS CHAR(4)));'+sLineBreak - +'+------------------------------------+'+sLineBreak - +'| HEX(WEIGHT_STRING(''x'' AS CHAR(4))) |'+sLineBreak - +'+------------------------------------+'+sLineBreak - +'| 0058002000200020 |'+sLineBreak - +'+------------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT HEX(WEIGHT_STRING(0xaa22ee LEVEL 1));'+sLineBreak - +'+--------------------------------------+'+sLineBreak - +'| HEX(WEIGHT_STRING(0xaa22ee LEVEL 1)) |'+sLineBreak - +'+--------------------------------------+'+sLineBreak - +'| AA22EE |'+sLineBreak - +'+--------------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT HEX(WEIGHT_STRING(0xaa22ee LEVEL 1 DESC));'+sLineBreak - +'+-------------------------------------------+'+sLineBreak - +'| HEX(WEIGHT_STRING(0xaa22ee LEVEL 1 DESC)) |'+sLineBreak - +'+-------------------------------------------+'+sLineBreak - +'| 55DD11 |'+sLineBreak - +'+-------------------------------------------+'+sLineBreak - +' '+sLineBreak - +'SELECT HEX(WEIGHT_STRING(0xaa22ee LEVEL 1 REVERSE));'+sLineBreak - +'+----------------------------------------------+'+sLineBreak - +'| HEX(WEIGHT_STRING(0xaa22ee LEVEL 1 REVERSE)) |'+sLineBreak - +'+----------------------------------------------+'+sLineBreak - +'| EE22AA |'+sLineBreak - +'+----------------------------------------------+' - ), - - ( - Name: 'CUME_DIST'; - Declaration: '()'; - Category: 'Window Functions'; - Version: SQL_VERSION_ANSI; - Description: 'CUME_DIST() is a window function that returns the cumulative'+sLineBreak - +'distribution of a given row. The following formula is used'+sLineBreak - +'to calculate the value:'+sLineBreak - +' '+sLineBreak - +'(number of rows' - ), - - ( - Name: 'CUME_DIST'; - Declaration: '( [ PARTITION BY partition_expression ] [ ORDER BY order_list ] )'; - Category: 'Window Functions'; - Version: SQL_VERSION_ANSI; - Description: 'CUME_DIST() is a window function that returns the cumulative'+sLineBreak - +'distribution of a given row. The following formula is used'+sLineBreak - +'to calculate the value:'+sLineBreak - +' '+sLineBreak - +'(number of rows' - ), - - ( - Name: 'DENSE_RANK'; - Declaration: '()'; - Category: 'Window Functions'; - Version: SQL_VERSION_ANSI; - Description: 'DENSE_RANK() is a window function that displays the number'+sLineBreak - +'of a given row, starting at one and following the ORDER BY'+sLineBreak - +'sequence of the window function, with identical values'+sLineBreak - +'receiving the same result. Unlike the RANK() function, there'+sLineBreak - +'are no skipped values if the preceding results are'+sLineBreak - +'identical. It is also similar to the ROW_NUMBER() function'+sLineBreak - +'except that in that function, identical values will receive'+sLineBreak - +'a different row number for each result.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'The distinction between DENSE_RANK(), RANK() and'+sLineBreak - +'ROW_NUMBER():'+sLineBreak - +' '+sLineBreak - +'CREATE TABLE student(course VARCHAR(10), mark int, name'+sLineBreak - +'varchar(10));'+sLineBreak - +' '+sLineBreak - +'INSERT INTO student VALUES '+sLineBreak - +' (''Maths'', 60, ''Thulile''),'+sLineBreak - +' (''Maths'', 60, ''Pritha''),'+sLineBreak - +' (''Maths'', 70, ''Voitto''),'+sLineBreak - +' (''Maths'', 55, ''Chun''),'+sLineBreak - +' (''Biology'', 60, ''Bilal''),'+sLineBreak - +' (''Biology'', 70, ''Roger'');'+sLineBreak - +' '+sLineBreak - +'SELECT '+sLineBreak - +' RANK() OVER (PARTITION BY course ORDER BY mark DESC) AS'+sLineBreak - +'rank, '+sLineBreak - +' DENSE_RANK() OVER (PARTITION BY course ORDER BY mark DESC)'+sLineBreak - +'AS dense_rank, '+sLineBreak - +' ROW_NUMBER() OVER (PARTITION BY course ORDER BY mark DESC)'+sLineBreak - +'AS row_num, '+sLineBreak - +' course, mark, name '+sLineBreak - +'FROM student ORDER BY course, mark DESC;'+sLineBreak - +' '+sLineBreak - +'+------+------------+---------+---------+------+---------+'+sLineBreak - +'| rank | dense_rank | row_num | course | mark | name |'+sLineBreak - +'+------+------------+---------+---------+------+---------+'+sLineBreak - +'| 1 | 1 | 1 | Biology | 70 | Roger |'+sLineBreak - +'| 2 | 2 | 2 | Biology | 60 | Bilal |'+sLineBreak - +'| 1 | 1 | 1 | Maths | 70 | Voitto |'+sLineBreak - +'| 2 | 2 | 2 | Maths | 60 | Thulile |'+sLineBreak - +'| 2 | 2 | 3 | Maths | 60 | Pritha |'+sLineBreak - +'| 4 | 3 | 4 | Maths | 55 | Chun |'+sLineBreak - +'+------+------------+---------+---------+------+---------+' - ), - - ( - Name: 'DENSE_RANK'; - Declaration: '( [ PARTITION BY partition_expression ] [ ORDER BY order_list ] )'; - Category: 'Window Functions'; - Version: SQL_VERSION_ANSI; - Description: 'DENSE_RANK() is a window function that displays the number'+sLineBreak - +'of a given row, starting at one and following the ORDER BY'+sLineBreak - +'sequence of the window function, with identical values'+sLineBreak - +'receiving the same result. Unlike the RANK() function, there'+sLineBreak - +'are no skipped values if the preceding results are'+sLineBreak - +'identical. It is also similar to the ROW_NUMBER() function'+sLineBreak - +'except that in that function, identical values will receive'+sLineBreak - +'a different row number for each result.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'The distinction between DENSE_RANK(), RANK() and'+sLineBreak - +'ROW_NUMBER():'+sLineBreak - +' '+sLineBreak - +'CREATE TABLE student(course VARCHAR(10), mark int, name'+sLineBreak - +'varchar(10));'+sLineBreak - +' '+sLineBreak - +'INSERT INTO student VALUES '+sLineBreak - +' (''Maths'', 60, ''Thulile''),'+sLineBreak - +' (''Maths'', 60, ''Pritha''),'+sLineBreak - +' (''Maths'', 70, ''Voitto''),'+sLineBreak - +' (''Maths'', 55, ''Chun''),'+sLineBreak - +' (''Biology'', 60, ''Bilal''),'+sLineBreak - +' (''Biology'', 70, ''Roger'');'+sLineBreak - +' '+sLineBreak - +'SELECT '+sLineBreak - +' RANK() OVER (PARTITION BY course ORDER BY mark DESC) AS'+sLineBreak - +'rank, '+sLineBreak - +' DENSE_RANK() OVER (PARTITION BY course ORDER BY mark DESC)'+sLineBreak - +'AS dense_rank, '+sLineBreak - +' ROW_NUMBER() OVER (PARTITION BY course ORDER BY mark DESC)'+sLineBreak - +'AS row_num, '+sLineBreak - +' course, mark, name '+sLineBreak - +'FROM student ORDER BY course, mark DESC;'+sLineBreak - +' '+sLineBreak - +'+------+------------+---------+---------+------+---------+'+sLineBreak - +'| rank | dense_rank | row_num | course | mark | name |'+sLineBreak - +'+------+------------+---------+---------+------+---------+'+sLineBreak - +'| 1 | 1 | 1 | Biology | 70 | Roger |'+sLineBreak - +'| 2 | 2 | 2 | Biology | 60 | Bilal |'+sLineBreak - +'| 1 | 1 | 1 | Maths | 70 | Voitto |'+sLineBreak - +'| 2 | 2 | 2 | Maths | 60 | Thulile |'+sLineBreak - +'| 2 | 2 | 3 | Maths | 60 | Pritha |'+sLineBreak - +'| 4 | 3 | 4 | Maths | 55 | Chun |'+sLineBreak - +'+------+------------+---------+---------+------+---------+' - ), - - ( - Name: 'FIRST_VALUE'; - Declaration: '(expr)'; - Category: 'Window Functions'; - Version: SQL_VERSION_ANSI; - Description: 'FIRST_VALUE returns the first result from an ordered set, or'+sLineBreak - +'NULL if no such result exists.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'CREATE TABLE t1 ('+sLineBreak - +' pk int primary key,'+sLineBreak - +' a int,'+sLineBreak - +' b int,'+sLineBreak - +' c char(10),'+sLineBreak - +' d decimal(10, 3),'+sLineBreak - +' e real'+sLineBreak - +');'+sLineBreak - +' '+sLineBreak - +'INSERT INTO t1 VALUES'+sLineBreak - +'( 1, 0, 1, ''one'', 0.1, 0.001),'+sLineBreak - +'( 2, 0, 2, ''two'', 0.2, 0.002),'+sLineBreak - +'( 3, 0, 3, ''three'', 0.3, 0.003),'+sLineBreak - +'( 4, 1, 2, ''three'', 0.4, 0.004),'+sLineBreak - +'( 5, 1, 1, ''two'', 0.5, 0.005),'+sLineBreak - +'( 6, 1, 1, ''one'', 0.6, 0.006),'+sLineBreak - +'( 7, 2, NULL, ''n_one'', 0.5, 0.007),'+sLineBreak - +'( 8, 2, 1, ''n_two'', NULL, 0.008),'+sLineBreak - +'( 9, 2, 2, NULL, 0.7, 0.009),'+sLineBreak - +'(10, 2, 0, ''n_four'', 0.8, 0.010),'+sLineBreak - +'(11, 2, 10, NULL, 0.9, NULL);'+sLineBreak - +' '+sLineBreak - +'SELECT pk, FIRST_VALUE(pk) OVER (ORDER BY pk) AS first_asc,'+sLineBreak - +' LAST_VALUE(pk) OVER (ORDER BY pk) AS last_asc,'+sLineBreak - +' FIRST_VALUE(pk) OVER (ORDER BY pk DESC) AS first_desc,'+sLineBreak - +' LAST_VALUE(pk) OVER (ORDER BY pk DESC) AS last_desc'+sLineBreak - +'FROM t1'+sLineBreak - +'ORDER BY pk DESC;'+sLineBreak - +' '+sLineBreak - +'+----+-----------+----------+------------+-----------+'+sLineBreak - +'| pk | first_asc | last_asc | first_desc | last_desc |'+sLineBreak - +'+----+-----------+----------+------------+-----------+'+sLineBreak - +'| 11 | 1 | 11 | 11 | 11 |'+sLineBreak - +'| 10 | 1 | 10 | 11 | 10 |'+sLineBreak - +'| 9 | 1 | 9 | 11 | 9 |'+sLineBreak - +'| 8 | 1 | 8 | 11 | 8 |'+sLineBreak - +'| 7 | 1 | 7 | 11 | 7 |'+sLineBreak - +'| 6 | 1 | 6 | 11 | 6 |'+sLineBreak - +'| 5 | 1 | 5 | 11 | 5 |'+sLineBreak - +'| 4 | 1 | 4 | 11 | 4 |'+sLineBreak - +'| 3 | 1 | 3 | 11 | 3 |'+sLineBreak - +'| 2 | 1 | 2 | 11 | 2 |'+sLineBreak - +'| 1 | 1 | 1 | 11 | 1 |'+sLineBreak - +'+----+-----------+----------+------------+-----------+'+sLineBreak - +' '+sLineBreak - +'CREATE OR REPLACE TABLE t1 (i int);'+sLineBreak - +'INSERT INTO t1 VALUES'+sLineBreak - +'(1),(2),(3),(4),(5),(6),(7),(8),(9),(10);'+sLineBreak - +' '+sLineBreak - +'SELECT i,'+sLineBreak - +' FIRST_VALUE(i) OVER (ORDER BY i ROWS BETWEEN CURRENT ROW'+sLineBreak - +'and 1 FOLLOWING) AS f_1f,'+sLineBreak - +' LAST_VALUE(i) OVER (ORDER BY i ROWS BETWEEN CURRENT ROW and'+sLineBreak - +'1 FOLLOWING) AS l_1f,'+sLineBreak - +' FIRST_VALUE(i) OVER (ORDER BY i ROWS BETWEEN 1 PRECEDING'+sLineBreak - +'AND 1 FOLLOWING) AS f_1p1f,'+sLineBreak - +' LAST_VALUE(i) OVER (ORDER BY i ROWS BETWEEN 1 PRECEDING AND'+sLineBreak - +'1 FOLLOWING) AS f_1p1f,'+sLineBreak - +' FIRST_VALUE(i) OVER (ORDER BY i ROWS BETWEEN 2 PRECEDING'+sLineBreak - +'AND 1 PRECEDING) AS f_2p1p,'+sLineBreak - +' LAST_VALUE(i) OVER (ORDER BY i ROWS BETWEEN 2 PRECEDING AND'+sLineBreak - +'1 PRECEDING) AS f_2p1p,'+sLineBreak - +' FIRST_VALUE(i) OVER (ORDER BY i ROWS BETWEEN 1 FOLLOWING'+sLineBreak - +'AND 2 FOLLOWING) AS f_1f2f,'+sLineBreak - +' LAST_VALUE(i) OVER (ORDER BY i ROWS BETWEEN 1 FOLLOWING AND'+sLineBreak - +'2 FOLLOWING) AS f_1f2f'+sLineBreak - +'FROM t1;'+sLineBreak - +' '+sLineBreak - +'+------+------+------+--------+--------+--------+--------+--------+--------+'+sLineBreak - +'| i | f_1f | l_1f | f_1p1f | f_1p1f | f_2p1p | f_2p1p |'+sLineBreak - +'f_1f2f | f_1f2f |'+sLineBreak - +'+------+------+------+--------+--------+--------+--------+--------+--------+'+sLineBreak - +'| 1 | 1 | 2 | 1 | 2 | NULL | NULL | 2 | 3 |'+sLineBreak - +'| 2 | 2 | 3 | 1 | 3 | 1 | 1 | 3 | 4 |'+sLineBreak - +'| 3 | 3 | 4 | 2 | 4 | 1 | 2 | 4 | 5 |'+sLineBreak - +'| 4 | 4 | 5 | 3 | 5 | 2 | 3 | 5 | 6 |'+sLineBreak - +'| 5 | 5 | 6 | 4 | 6 | 3 | 4 | 6 | 7 |'+sLineBreak - +'| 6 | 6 | 7 | 5 | 7 | 4 | 5 | 7 | 8 |'+sLineBreak - +'| 7 | 7 | 8 | 6 | 8 | 5 | 6 | 8 | 9 |'+sLineBreak - +'| 8 | 8 | 9 | 7 | 9 | 6 | 7 | 9 | 10 |'+sLineBreak - +'| 9 | 9 | 10 | 8 | 10 | 7 | 8 | 10 | 10 |'+sLineBreak - +'| 10 | 10 | 10 | 9 | 10 | 8 | 9 | NULL | NULL |'+sLineBreak - +'+------+------+------+--------+--------+--------+--------+--------+--------+' - ), - - ( - Name: 'FIRST_VALUE'; - Declaration: '( [ PARTITION BY partition_expression ] [ ORDER BY order_list ] )'; - Category: 'Window Functions'; - Version: SQL_VERSION_ANSI; - Description: 'FIRST_VALUE returns the first result from an ordered set, or'+sLineBreak - +'NULL if no such result exists.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'CREATE TABLE t1 ('+sLineBreak - +' pk int primary key,'+sLineBreak - +' a int,'+sLineBreak - +' b int,'+sLineBreak - +' c char(10),'+sLineBreak - +' d decimal(10, 3),'+sLineBreak - +' e real'+sLineBreak - +');'+sLineBreak - +' '+sLineBreak - +'INSERT INTO t1 VALUES'+sLineBreak - +'( 1, 0, 1, ''one'', 0.1, 0.001),'+sLineBreak - +'( 2, 0, 2, ''two'', 0.2, 0.002),'+sLineBreak - +'( 3, 0, 3, ''three'', 0.3, 0.003),'+sLineBreak - +'( 4, 1, 2, ''three'', 0.4, 0.004),'+sLineBreak - +'( 5, 1, 1, ''two'', 0.5, 0.005),'+sLineBreak - +'( 6, 1, 1, ''one'', 0.6, 0.006),'+sLineBreak - +'( 7, 2, NULL, ''n_one'', 0.5, 0.007),'+sLineBreak - +'( 8, 2, 1, ''n_two'', NULL, 0.008),'+sLineBreak - +'( 9, 2, 2, NULL, 0.7, 0.009),'+sLineBreak - +'(10, 2, 0, ''n_four'', 0.8, 0.010),'+sLineBreak - +'(11, 2, 10, NULL, 0.9, NULL);'+sLineBreak - +' '+sLineBreak - +'SELECT pk, FIRST_VALUE(pk) OVER (ORDER BY pk) AS first_asc,'+sLineBreak - +' LAST_VALUE(pk) OVER (ORDER BY pk) AS last_asc,'+sLineBreak - +' FIRST_VALUE(pk) OVER (ORDER BY pk DESC) AS first_desc,'+sLineBreak - +' LAST_VALUE(pk) OVER (ORDER BY pk DESC) AS last_desc'+sLineBreak - +'FROM t1'+sLineBreak - +'ORDER BY pk DESC;'+sLineBreak - +' '+sLineBreak - +'+----+-----------+----------+------------+-----------+'+sLineBreak - +'| pk | first_asc | last_asc | first_desc | last_desc |'+sLineBreak - +'+----+-----------+----------+------------+-----------+'+sLineBreak - +'| 11 | 1 | 11 | 11 | 11 |'+sLineBreak - +'| 10 | 1 | 10 | 11 | 10 |'+sLineBreak - +'| 9 | 1 | 9 | 11 | 9 |'+sLineBreak - +'| 8 | 1 | 8 | 11 | 8 |'+sLineBreak - +'| 7 | 1 | 7 | 11 | 7 |'+sLineBreak - +'| 6 | 1 | 6 | 11 | 6 |'+sLineBreak - +'| 5 | 1 | 5 | 11 | 5 |'+sLineBreak - +'| 4 | 1 | 4 | 11 | 4 |'+sLineBreak - +'| 3 | 1 | 3 | 11 | 3 |'+sLineBreak - +'| 2 | 1 | 2 | 11 | 2 |'+sLineBreak - +'| 1 | 1 | 1 | 11 | 1 |'+sLineBreak - +'+----+-----------+----------+------------+-----------+'+sLineBreak - +' '+sLineBreak - +'CREATE OR REPLACE TABLE t1 (i int);'+sLineBreak - +'INSERT INTO t1 VALUES'+sLineBreak - +'(1),(2),(3),(4),(5),(6),(7),(8),(9),(10);'+sLineBreak - +' '+sLineBreak - +'SELECT i,'+sLineBreak - +' FIRST_VALUE(i) OVER (ORDER BY i ROWS BETWEEN CURRENT ROW'+sLineBreak - +'and 1 FOLLOWING) AS f_1f,'+sLineBreak - +' LAST_VALUE(i) OVER (ORDER BY i ROWS BETWEEN CURRENT ROW and'+sLineBreak - +'1 FOLLOWING) AS l_1f,'+sLineBreak - +' FIRST_VALUE(i) OVER (ORDER BY i ROWS BETWEEN 1 PRECEDING'+sLineBreak - +'AND 1 FOLLOWING) AS f_1p1f,'+sLineBreak - +' LAST_VALUE(i) OVER (ORDER BY i ROWS BETWEEN 1 PRECEDING AND'+sLineBreak - +'1 FOLLOWING) AS f_1p1f,'+sLineBreak - +' FIRST_VALUE(i) OVER (ORDER BY i ROWS BETWEEN 2 PRECEDING'+sLineBreak - +'AND 1 PRECEDING) AS f_2p1p,'+sLineBreak - +' LAST_VALUE(i) OVER (ORDER BY i ROWS BETWEEN 2 PRECEDING AND'+sLineBreak - +'1 PRECEDING) AS f_2p1p,'+sLineBreak - +' FIRST_VALUE(i) OVER (ORDER BY i ROWS BETWEEN 1 FOLLOWING'+sLineBreak - +'AND 2 FOLLOWING) AS f_1f2f,'+sLineBreak - +' LAST_VALUE(i) OVER (ORDER BY i ROWS BETWEEN 1 FOLLOWING AND'+sLineBreak - +'2 FOLLOWING) AS f_1f2f'+sLineBreak - +'FROM t1;'+sLineBreak - +' '+sLineBreak - +'+------+------+------+--------+--------+--------+--------+--------+--------+'+sLineBreak - +'| i | f_1f | l_1f | f_1p1f | f_1p1f | f_2p1p | f_2p1p |'+sLineBreak - +'f_1f2f | f_1f2f |'+sLineBreak - +'+------+------+------+--------+--------+--------+--------+--------+--------+'+sLineBreak - +'| 1 | 1 | 2 | 1 | 2 | NULL | NULL | 2 | 3 |'+sLineBreak - +'| 2 | 2 | 3 | 1 | 3 | 1 | 1 | 3 | 4 |'+sLineBreak - +'| 3 | 3 | 4 | 2 | 4 | 1 | 2 | 4 | 5 |'+sLineBreak - +'| 4 | 4 | 5 | 3 | 5 | 2 | 3 | 5 | 6 |'+sLineBreak - +'| 5 | 5 | 6 | 4 | 6 | 3 | 4 | 6 | 7 |'+sLineBreak - +'| 6 | 6 | 7 | 5 | 7 | 4 | 5 | 7 | 8 |'+sLineBreak - +'| 7 | 7 | 8 | 6 | 8 | 5 | 6 | 8 | 9 |'+sLineBreak - +'| 8 | 8 | 9 | 7 | 9 | 6 | 7 | 9 | 10 |'+sLineBreak - +'| 9 | 9 | 10 | 8 | 10 | 7 | 8 | 10 | 10 |'+sLineBreak - +'| 10 | 10 | 10 | 9 | 10 | 8 | 9 | NULL | NULL |'+sLineBreak - +'+------+------+------+--------+--------+--------+--------+--------+--------+' - ), - - ( - Name: 'MEDIAN'; - Declaration: '(median expression)'; - Category: 'Window Functions'; - Version: SQL_VERSION_ANSI; - Description: 'MEDIAN() is a window function that returns the median value'+sLineBreak - +'of a range of values.'+sLineBreak - +' '+sLineBreak - +'It is a specific case of PERCENTILE_CONT, with an argument'+sLineBreak - +'of 0.5 and the ORDER BY column the one in MEDIAN''s'+sLineBreak - +'argument. '+sLineBreak - +' '+sLineBreak - +'MEDIAN() OVER ( [ PARTITION BY partition_expression] )'+sLineBreak - +' '+sLineBreak - +'Is equivalent to:'+sLineBreak - +' '+sLineBreak - +'PERCENTILE_CONT(0.5) WITHIN '+sLineBreak - +' GROUP (ORDER BY ) OVER ( [ PARTITION BY'+sLineBreak - +'partition_expression ])'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'CREATE TABLE book_rating (name CHAR(30), star_rating'+sLineBreak - +'TINYINT);'+sLineBreak - +' '+sLineBreak - +'INSERT INTO book_rating VALUES (''Lord of the Ladybirds'','+sLineBreak - +'5);'+sLineBreak - +'INSERT INTO book_rating VALUES (''Lord of the Ladybirds'','+sLineBreak - +'3);'+sLineBreak - +'INSERT INTO book_rating VALUES (''Lady of the Flies'', 1);'+sLineBreak - +'INSERT INTO book_rating VALUES (''Lady of the Flies'', 2);'+sLineBreak - +'INSERT INTO book_rating VALUES (''Lady of the Flies'', 5);'+sLineBreak - +' '+sLineBreak - +'SELECT name, median(star_rating) OVER (PARTITION BY name)'+sLineBreak - +'FROM book_rating;'+sLineBreak - +' '+sLineBreak - +'+-----------------------+----------------------------------------------+'+sLineBreak - +'| name | median(star_rating) OVER (PARTITION BY name) |'+sLineBreak - +'+-----------------------+----------------------------------------------+'+sLineBreak - +'| Lord of the Ladybirds | 4.0000000000 |'+sLineBreak - +'| Lord of the Ladybirds | 4.0000000000 |'+sLineBreak - +'| Lady of the Flies | 2.0000000000 |'+sLineBreak - +'| Lady of the Flies | 2.0000000000 |'+sLineBreak - +'| Lady of the Flies | 2.0000000000 |'+sLineBreak - +'+-----------------------+----------------------------------------------+' - ), - - ( - Name: 'MEDIAN'; - Declaration: '( [ PARTITION BY partition_expression ] )'; - Category: 'Window Functions'; - Version: SQL_VERSION_ANSI; - Description: 'MEDIAN() is a window function that returns the median value'+sLineBreak - +'of a range of values.'+sLineBreak - +' '+sLineBreak - +'It is a specific case of PERCENTILE_CONT, with an argument'+sLineBreak - +'of 0.5 and the ORDER BY column the one in MEDIAN''s'+sLineBreak - +'argument. '+sLineBreak - +' '+sLineBreak - +'MEDIAN() OVER ( [ PARTITION BY partition_expression] )'+sLineBreak - +' '+sLineBreak - +'Is equivalent to:'+sLineBreak - +' '+sLineBreak - +'PERCENTILE_CONT(0.5) WITHIN '+sLineBreak - +' GROUP (ORDER BY ) OVER ( [ PARTITION BY'+sLineBreak - +'partition_expression ])'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'CREATE TABLE book_rating (name CHAR(30), star_rating'+sLineBreak - +'TINYINT);'+sLineBreak - +' '+sLineBreak - +'INSERT INTO book_rating VALUES (''Lord of the Ladybirds'','+sLineBreak - +'5);'+sLineBreak - +'INSERT INTO book_rating VALUES (''Lord of the Ladybirds'','+sLineBreak - +'3);'+sLineBreak - +'INSERT INTO book_rating VALUES (''Lady of the Flies'', 1);'+sLineBreak - +'INSERT INTO book_rating VALUES (''Lady of the Flies'', 2);'+sLineBreak - +'INSERT INTO book_rating VALUES (''Lady of the Flies'', 5);'+sLineBreak - +' '+sLineBreak - +'SELECT name, median(star_rating) OVER (PARTITION BY name)'+sLineBreak - +'FROM book_rating;'+sLineBreak - +' '+sLineBreak - +'+-----------------------+----------------------------------------------+'+sLineBreak - +'| name | median(star_rating) OVER (PARTITION BY name) |'+sLineBreak - +'+-----------------------+----------------------------------------------+'+sLineBreak - +'| Lord of the Ladybirds | 4.0000000000 |'+sLineBreak - +'| Lord of the Ladybirds | 4.0000000000 |'+sLineBreak - +'| Lady of the Flies | 2.0000000000 |'+sLineBreak - +'| Lady of the Flies | 2.0000000000 |'+sLineBreak - +'| Lady of the Flies | 2.0000000000 |'+sLineBreak - +'+-----------------------+----------------------------------------------+' - ), - - ( - Name: 'PERCENT_RANK'; - Declaration: '()'; - Category: 'Window Functions'; - Version: SQL_VERSION_ANSI; - Description: 'PERCENT_RANK() is a window function that returns the'+sLineBreak - +'relative percent rank of a given row. The following formula'+sLineBreak - +'is used to calculate the percent rank:'+sLineBreak - +' '+sLineBreak - +'(rank - 1) / (number of rows in the window or partition - 1)'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'create table t1 ('+sLineBreak - +' pk int primary key,'+sLineBreak - +' a int,'+sLineBreak - +' b int'+sLineBreak - +');'+sLineBreak - +' '+sLineBreak - +'insert into t1 values'+sLineBreak - +'( 1 , 0, 10),'+sLineBreak - +'( 2 , 0, 10),'+sLineBreak - +'( 3 , 1, 10),'+sLineBreak - +'( 4 , 1, 10),'+sLineBreak - +'( 8 , 2, 10),'+sLineBreak - +'( 5 , 2, 20),'+sLineBreak - +'( 6 , 2, 20),'+sLineBreak - +'( 7 , 2, 20),'+sLineBreak - +'( 9 , 4, 20),'+sLineBreak - +'(10 , 4, 20);'+sLineBreak - +' '+sLineBreak - +'select pk, a, b,'+sLineBreak - +' rank() over (order by a) as rank,'+sLineBreak - +' percent_rank() over (order by a) as pct_rank,'+sLineBreak - +' cume_dist() over (order by a) as cume_dist'+sLineBreak - +'from t1;'+sLineBreak - +' '+sLineBreak - +'+----+------+------+------+--------------+--------------+'+sLineBreak - +'| pk | a | b | rank | pct_rank | cume_dist |'+sLineBreak - +'+----+------+------+------+--------------+--------------+'+sLineBreak - +'| 1 | 0 | 10 | 1 | 0.0000000000 | 0.2000000000 |'+sLineBreak - +'| 2 | 0 | 10 | 1 | 0.0000000000 | 0.2000000000 |'+sLineBreak - +'| 3 | 1 | 10 | 3 | 0.2222222222 | 0.4000000000 |'+sLineBreak - +'| 4 | 1 | 10 | 3 | 0.2222222222 | 0.4000000000 |'+sLineBreak - +'| 5 | 2 | 20 | 5 | 0.4444444444 | 0.8000000000 |'+sLineBreak - +'| 6 | 2 | 20 | 5 | 0.4444444444 | 0.8000000000 |'+sLineBreak - +'| 7 | 2 | 20 | 5 | 0.4444444444 | 0.8000000000 |'+sLineBreak - +'| 8 | 2 | 10 | 5 | 0.4444444444 | 0.8000000000 |'+sLineBreak - +'| 9 | 4 | 20 | 9 | 0.8888888889 | 1.0000000000 |'+sLineBreak - +'| 10 | 4 | 20 | 9 | 0.8888888889 | 1.0000000000 |'+sLineBreak - +'+----+------+------+------+--------------+--------------+'+sLineBreak - +' '+sLineBreak - +'select pk, a, b,'+sLineBreak - +' percent_rank() over (order by pk) as pct_rank,'+sLineBreak - +' cume_dist() over (order by pk) as cume_dist'+sLineBreak - +'from t1 order by pk;'+sLineBreak - +' '+sLineBreak - +'+----+------+------+--------------+--------------+'+sLineBreak - +'| pk | a | b | pct_rank | cume_dist |'+sLineBreak - +'+----+------+------+--------------+--------------+'+sLineBreak - +'| 1 | 0 | 10 | 0.0000000000 | 0.1000000000 |'+sLineBreak - +'| 2 | 0 | 10 | 0.1111111111 | 0.2000000000 |'+sLineBreak - +'| 3 | 1 | 10 | 0.2222222222 | 0.3000000000 |'+sLineBreak - +'| 4 | 1 | 10 | 0.3333333333 | 0.4000000000 |'+sLineBreak - +'| 5 | 2 | 20 | 0.4444444444 | 0.5000000000 |'+sLineBreak - +'| 6 | 2 | 20 | 0.5555555556 | 0.6000000000 |'+sLineBreak - +'| 7 | 2 | 20 | 0.6666666667 | 0.7000000000 |'+sLineBreak - +'| 8 | 2 | 10 | 0.7777777778 | 0.8000000000 |'+sLineBreak - +'| 9 | 4 | 20 | 0.8888888889 | 0.9000000000 |'+sLineBreak - +'| 10 | 4 | 20 | 1.0000000000 | 1.0000000000 |'+sLineBreak - +'+----+------+------+--------------+--------------+'+sLineBreak - +' '+sLineBreak - +'select pk, a, b,'+sLineBreak - +' percent_rank() over (partition by a order by a) as'+sLineBreak - +'pct_rank,'+sLineBreak - +' cume_dist() over (partition by a order by a) as cume_dist'+sLineBreak - +'from t1;'+sLineBreak - +' '+sLineBreak - +'+----+------+------+--------------+--------------+'+sLineBreak - +'| pk | a | b | pct_rank | cume_dist |'+sLineBreak - +'+----+------+------+--------------+--------------+'+sLineBreak - +'| 1 | 0 | 10 | 0.0000000000 | 1.0000000000 |'+sLineBreak - +'| 2 | 0 | 10 | 0.0000000000 | 1.0000000000 |'+sLineBreak - +'| 3 | 1 | 10 | 0.0000000000 | 1.0000000000 |'+sLineBreak - +'| 4 | 1 | 10 | 0.0000000000 | 1.0000000000 |'+sLineBreak - +'| 5 | 2 | 20 | 0.0000000000 | 1.0000000000 |'+sLineBreak - +'| 6 | 2 | 20 | 0.0000000000 | 1.0000000000 |'+sLineBreak - +'| 7 | 2 | 20 | 0.0000000000 | 1.0000000000 |'+sLineBreak - +'| 8 | 2 | 10 | 0.0000000000 | 1.0000000000 |'+sLineBreak - +'| 9 | 4 | 20 | 0.0000000000 | 1.0000000000 |'+sLineBreak - +'| 10 | 4 | 20 | 0.0000000000 | 1.0000000000 |'+sLineBreak - +'+----+------+------+--------------+--------------+' - ), - - ( - Name: 'PERCENT_RANK'; - Declaration: '( [ PARTITION BY partition_expression ] [ ORDER BY order_list ] )'; - Category: 'Window Functions'; - Version: SQL_VERSION_ANSI; - Description: 'PERCENT_RANK() is a window function that returns the'+sLineBreak - +'relative percent rank of a given row. The following formula'+sLineBreak - +'is used to calculate the percent rank:'+sLineBreak - +' '+sLineBreak - +'(rank - 1) / (number of rows in the window or partition - 1)'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'create table t1 ('+sLineBreak - +' pk int primary key,'+sLineBreak - +' a int,'+sLineBreak - +' b int'+sLineBreak - +');'+sLineBreak - +' '+sLineBreak - +'insert into t1 values'+sLineBreak - +'( 1 , 0, 10),'+sLineBreak - +'( 2 , 0, 10),'+sLineBreak - +'( 3 , 1, 10),'+sLineBreak - +'( 4 , 1, 10),'+sLineBreak - +'( 8 , 2, 10),'+sLineBreak - +'( 5 , 2, 20),'+sLineBreak - +'( 6 , 2, 20),'+sLineBreak - +'( 7 , 2, 20),'+sLineBreak - +'( 9 , 4, 20),'+sLineBreak - +'(10 , 4, 20);'+sLineBreak - +' '+sLineBreak - +'select pk, a, b,'+sLineBreak - +' rank() over (order by a) as rank,'+sLineBreak - +' percent_rank() over (order by a) as pct_rank,'+sLineBreak - +' cume_dist() over (order by a) as cume_dist'+sLineBreak - +'from t1;'+sLineBreak - +' '+sLineBreak - +'+----+------+------+------+--------------+--------------+'+sLineBreak - +'| pk | a | b | rank | pct_rank | cume_dist |'+sLineBreak - +'+----+------+------+------+--------------+--------------+'+sLineBreak - +'| 1 | 0 | 10 | 1 | 0.0000000000 | 0.2000000000 |'+sLineBreak - +'| 2 | 0 | 10 | 1 | 0.0000000000 | 0.2000000000 |'+sLineBreak - +'| 3 | 1 | 10 | 3 | 0.2222222222 | 0.4000000000 |'+sLineBreak - +'| 4 | 1 | 10 | 3 | 0.2222222222 | 0.4000000000 |'+sLineBreak - +'| 5 | 2 | 20 | 5 | 0.4444444444 | 0.8000000000 |'+sLineBreak - +'| 6 | 2 | 20 | 5 | 0.4444444444 | 0.8000000000 |'+sLineBreak - +'| 7 | 2 | 20 | 5 | 0.4444444444 | 0.8000000000 |'+sLineBreak - +'| 8 | 2 | 10 | 5 | 0.4444444444 | 0.8000000000 |'+sLineBreak - +'| 9 | 4 | 20 | 9 | 0.8888888889 | 1.0000000000 |'+sLineBreak - +'| 10 | 4 | 20 | 9 | 0.8888888889 | 1.0000000000 |'+sLineBreak - +'+----+------+------+------+--------------+--------------+'+sLineBreak - +' '+sLineBreak - +'select pk, a, b,'+sLineBreak - +' percent_rank() over (order by pk) as pct_rank,'+sLineBreak - +' cume_dist() over (order by pk) as cume_dist'+sLineBreak - +'from t1 order by pk;'+sLineBreak - +' '+sLineBreak - +'+----+------+------+--------------+--------------+'+sLineBreak - +'| pk | a | b | pct_rank | cume_dist |'+sLineBreak - +'+----+------+------+--------------+--------------+'+sLineBreak - +'| 1 | 0 | 10 | 0.0000000000 | 0.1000000000 |'+sLineBreak - +'| 2 | 0 | 10 | 0.1111111111 | 0.2000000000 |'+sLineBreak - +'| 3 | 1 | 10 | 0.2222222222 | 0.3000000000 |'+sLineBreak - +'| 4 | 1 | 10 | 0.3333333333 | 0.4000000000 |'+sLineBreak - +'| 5 | 2 | 20 | 0.4444444444 | 0.5000000000 |'+sLineBreak - +'| 6 | 2 | 20 | 0.5555555556 | 0.6000000000 |'+sLineBreak - +'| 7 | 2 | 20 | 0.6666666667 | 0.7000000000 |'+sLineBreak - +'| 8 | 2 | 10 | 0.7777777778 | 0.8000000000 |'+sLineBreak - +'| 9 | 4 | 20 | 0.8888888889 | 0.9000000000 |'+sLineBreak - +'| 10 | 4 | 20 | 1.0000000000 | 1.0000000000 |'+sLineBreak - +'+----+------+------+--------------+--------------+'+sLineBreak - +' '+sLineBreak - +'select pk, a, b,'+sLineBreak - +' percent_rank() over (partition by a order by a) as'+sLineBreak - +'pct_rank,'+sLineBreak - +' cume_dist() over (partition by a order by a) as cume_dist'+sLineBreak - +'from t1;'+sLineBreak - +' '+sLineBreak - +'+----+------+------+--------------+--------------+'+sLineBreak - +'| pk | a | b | pct_rank | cume_dist |'+sLineBreak - +'+----+------+------+--------------+--------------+'+sLineBreak - +'| 1 | 0 | 10 | 0.0000000000 | 1.0000000000 |'+sLineBreak - +'| 2 | 0 | 10 | 0.0000000000 | 1.0000000000 |'+sLineBreak - +'| 3 | 1 | 10 | 0.0000000000 | 1.0000000000 |'+sLineBreak - +'| 4 | 1 | 10 | 0.0000000000 | 1.0000000000 |'+sLineBreak - +'| 5 | 2 | 20 | 0.0000000000 | 1.0000000000 |'+sLineBreak - +'| 6 | 2 | 20 | 0.0000000000 | 1.0000000000 |'+sLineBreak - +'| 7 | 2 | 20 | 0.0000000000 | 1.0000000000 |'+sLineBreak - +'| 8 | 2 | 10 | 0.0000000000 | 1.0000000000 |'+sLineBreak - +'| 9 | 4 | 20 | 0.0000000000 | 1.0000000000 |'+sLineBreak - +'| 10 | 4 | 20 | 0.0000000000 | 1.0000000000 |'+sLineBreak - +'+----+------+------+--------------+--------------+' - ), - - ( - Name: 'RANK'; - Declaration: '()'; - Category: 'Window Functions'; - Version: SQL_VERSION_ANSI; - Description: 'RANK() is a window function that displays the number of a'+sLineBreak - +'given row, starting at one and following the ORDER BY'+sLineBreak - +'sequence of the window function, with identical values'+sLineBreak - +'receiving the same result. It is similar to the ROW_NUMBER()'+sLineBreak - +'function except that in that function, identical values will'+sLineBreak - +'receive a different row number for each result.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'The distinction between DENSE_RANK(), RANK() and'+sLineBreak - +'ROW_NUMBER():'+sLineBreak - +' '+sLineBreak - +'CREATE TABLE student(course VARCHAR(10), mark int, name'+sLineBreak - +'varchar(10));'+sLineBreak - +' '+sLineBreak - +'INSERT INTO student VALUES '+sLineBreak - +' (''Maths'', 60, ''Thulile''),'+sLineBreak - +' (''Maths'', 60, ''Pritha''),'+sLineBreak - +' (''Maths'', 70, ''Voitto''),'+sLineBreak - +' (''Maths'', 55, ''Chun''),'+sLineBreak - +' (''Biology'', 60, ''Bilal''),'+sLineBreak - +' (''Biology'', 70, ''Roger'');'+sLineBreak - +' '+sLineBreak - +'SELECT '+sLineBreak - +' RANK() OVER (PARTITION BY course ORDER BY mark DESC) AS'+sLineBreak - +'rank, '+sLineBreak - +' DENSE_RANK() OVER (PARTITION BY course ORDER BY mark DESC)'+sLineBreak - +'AS dense_rank, '+sLineBreak - +' ROW_NUMBER() OVER (PARTITION BY course ORDER BY mark DESC)'+sLineBreak - +'AS row_num, '+sLineBreak - +' course, mark, name '+sLineBreak - +'FROM student ORDER BY course, mark DESC;'+sLineBreak - +' '+sLineBreak - +'+------+------------+---------+---------+------+---------+'+sLineBreak - +'| rank | dense_rank | row_num | course | mark | name |'+sLineBreak - +'+------+------------+---------+---------+------+---------+'+sLineBreak - +'| 1 | 1 | 1 | Biology | 70 | Roger |'+sLineBreak - +'| 2 | 2 | 2 | Biology | 60 | Bilal |'+sLineBreak - +'| 1 | 1 | 1 | Maths | 70 | Voitto |'+sLineBreak - +'| 2 | 2 | 2 | Maths | 60 | Thulile |'+sLineBreak - +'| 2 | 2 | 3 | Maths | 60 | Pritha |'+sLineBreak - +'| 4 | 3 | 4 | Maths | 55 | Chun |'+sLineBreak - +'+------+------------+---------+---------+------+---------+' - ), - - ( - Name: 'RANK'; - Declaration: '( [ PARTITION BY partition_expression ] [ ORDER BY order_list ] )'; - Category: 'Window Functions'; - Version: SQL_VERSION_ANSI; - Description: 'RANK() is a window function that displays the number of a'+sLineBreak - +'given row, starting at one and following the ORDER BY'+sLineBreak - +'sequence of the window function, with identical values'+sLineBreak - +'receiving the same result. It is similar to the ROW_NUMBER()'+sLineBreak - +'function except that in that function, identical values will'+sLineBreak - +'receive a different row number for each result.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'The distinction between DENSE_RANK(), RANK() and'+sLineBreak - +'ROW_NUMBER():'+sLineBreak - +' '+sLineBreak - +'CREATE TABLE student(course VARCHAR(10), mark int, name'+sLineBreak - +'varchar(10));'+sLineBreak - +' '+sLineBreak - +'INSERT INTO student VALUES '+sLineBreak - +' (''Maths'', 60, ''Thulile''),'+sLineBreak - +' (''Maths'', 60, ''Pritha''),'+sLineBreak - +' (''Maths'', 70, ''Voitto''),'+sLineBreak - +' (''Maths'', 55, ''Chun''),'+sLineBreak - +' (''Biology'', 60, ''Bilal''),'+sLineBreak - +' (''Biology'', 70, ''Roger'');'+sLineBreak - +' '+sLineBreak - +'SELECT '+sLineBreak - +' RANK() OVER (PARTITION BY course ORDER BY mark DESC) AS'+sLineBreak - +'rank, '+sLineBreak - +' DENSE_RANK() OVER (PARTITION BY course ORDER BY mark DESC)'+sLineBreak - +'AS dense_rank, '+sLineBreak - +' ROW_NUMBER() OVER (PARTITION BY course ORDER BY mark DESC)'+sLineBreak - +'AS row_num, '+sLineBreak - +' course, mark, name '+sLineBreak - +'FROM student ORDER BY course, mark DESC;'+sLineBreak - +' '+sLineBreak - +'+------+------------+---------+---------+------+---------+'+sLineBreak - +'| rank | dense_rank | row_num | course | mark | name |'+sLineBreak - +'+------+------------+---------+---------+------+---------+'+sLineBreak - +'| 1 | 1 | 1 | Biology | 70 | Roger |'+sLineBreak - +'| 2 | 2 | 2 | Biology | 60 | Bilal |'+sLineBreak - +'| 1 | 1 | 1 | Maths | 70 | Voitto |'+sLineBreak - +'| 2 | 2 | 2 | Maths | 60 | Thulile |'+sLineBreak - +'| 2 | 2 | 3 | Maths | 60 | Pritha |'+sLineBreak - +'| 4 | 3 | 4 | Maths | 55 | Chun |'+sLineBreak - +'+------+------------+---------+---------+------+---------+' - ), - - ( - Name: 'ROW_NUMBER'; - Declaration: '()'; - Category: 'Window Functions'; - Version: SQL_VERSION_ANSI; - Description: 'ROW_NUMBER() is a window function that displays the number'+sLineBreak - +'of a given row, starting at one and following the ORDER BY'+sLineBreak - +'sequence of the window function, with identical values'+sLineBreak - +'receiving different row numbers. It is similar to the RANK()'+sLineBreak - +'and DENSE_RANK() functions except that in that function,'+sLineBreak - +'identical values will receive the same rank for each result.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'The distinction between DENSE_RANK(), RANK() and'+sLineBreak - +'ROW_NUMBER():'+sLineBreak - +' '+sLineBreak - +'CREATE TABLE student(course VARCHAR(10), mark int, name'+sLineBreak - +'varchar(10));'+sLineBreak - +' '+sLineBreak - +'INSERT INTO student VALUES '+sLineBreak - +' (''Maths'', 60, ''Thulile''),'+sLineBreak - +' (''Maths'', 60, ''Pritha''),'+sLineBreak - +' (''Maths'', 70, ''Voitto''),'+sLineBreak - +' (''Maths'', 55, ''Chun''),'+sLineBreak - +' (''Biology'', 60, ''Bilal''),'+sLineBreak - +' (''Biology'', 70, ''Roger'');'+sLineBreak - +' '+sLineBreak - +'SELECT '+sLineBreak - +' RANK() OVER (PARTITION BY course ORDER BY mark DESC) AS'+sLineBreak - +'rank, '+sLineBreak - +' DENSE_RANK() OVER (PARTITION BY course ORDER BY mark DESC)'+sLineBreak - +'AS dense_rank, '+sLineBreak - +' ROW_NUMBER() OVER (PARTITION BY course ORDER BY mark DESC)'+sLineBreak - +'AS row_num, '+sLineBreak - +' course, mark, name '+sLineBreak - +'FROM student ORDER BY course, mark DESC;'+sLineBreak - +' '+sLineBreak - +'+------+------------+---------+---------+------+---------+'+sLineBreak - +'| rank | dense_rank | row_num | course | mark | name |'+sLineBreak - +'+------+------------+---------+---------+------+---------+'+sLineBreak - +'| 1 | 1 | 1 | Biology | 70 | Roger |'+sLineBreak - +'| 2 | 2 | 2 | Biology | 60 | Bilal |'+sLineBreak - +'| 1 | 1 | 1 | Maths | 70 | Voitto |'+sLineBreak - +'| 2 | 2 | 2 | Maths | 60 | Thulile |'+sLineBreak - +'| 2 | 2 | 3 | Maths | 60 | Pritha |'+sLineBreak - +'| 4 | 3 | 4 | Maths | 55 | Chun |'+sLineBreak - +'+------+------------+---------+---------+------+---------+' - ), - - ( - Name: 'ROW_NUMBER'; - Declaration: '( [ PARTITION BY partition_expression ] [ ORDER BY order_list ] )'; - Category: 'Window Functions'; - Version: SQL_VERSION_ANSI; - Description: 'ROW_NUMBER() is a window function that displays the number'+sLineBreak - +'of a given row, starting at one and following the ORDER BY'+sLineBreak - +'sequence of the window function, with identical values'+sLineBreak - +'receiving different row numbers. It is similar to the RANK()'+sLineBreak - +'and DENSE_RANK() functions except that in that function,'+sLineBreak - +'identical values will receive the same rank for each result.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'The distinction between DENSE_RANK(), RANK() and'+sLineBreak - +'ROW_NUMBER():'+sLineBreak - +' '+sLineBreak - +'CREATE TABLE student(course VARCHAR(10), mark int, name'+sLineBreak - +'varchar(10));'+sLineBreak - +' '+sLineBreak - +'INSERT INTO student VALUES '+sLineBreak - +' (''Maths'', 60, ''Thulile''),'+sLineBreak - +' (''Maths'', 60, ''Pritha''),'+sLineBreak - +' (''Maths'', 70, ''Voitto''),'+sLineBreak - +' (''Maths'', 55, ''Chun''),'+sLineBreak - +' (''Biology'', 60, ''Bilal''),'+sLineBreak - +' (''Biology'', 70, ''Roger'');'+sLineBreak - +' '+sLineBreak - +'SELECT '+sLineBreak - +' RANK() OVER (PARTITION BY course ORDER BY mark DESC) AS'+sLineBreak - +'rank, '+sLineBreak - +' DENSE_RANK() OVER (PARTITION BY course ORDER BY mark DESC)'+sLineBreak - +'AS dense_rank, '+sLineBreak - +' ROW_NUMBER() OVER (PARTITION BY course ORDER BY mark DESC)'+sLineBreak - +'AS row_num, '+sLineBreak - +' course, mark, name '+sLineBreak - +'FROM student ORDER BY course, mark DESC;'+sLineBreak - +' '+sLineBreak - +'+------+------------+---------+---------+------+---------+'+sLineBreak - +'| rank | dense_rank | row_num | course | mark | name |'+sLineBreak - +'+------+------------+---------+---------+------+---------+'+sLineBreak - +'| 1 | 1 | 1 | Biology | 70 | Roger |'+sLineBreak - +'| 2 | 2 | 2 | Biology | 60 | Bilal |'+sLineBreak - +'| 1 | 1 | 1 | Maths | 70 | Voitto |'+sLineBreak - +'| 2 | 2 | 2 | Maths | 60 | Thulile |'+sLineBreak - +'| 2 | 2 | 3 | Maths | 60 | Pritha |'+sLineBreak - +'| 4 | 3 | 4 | Maths | 55 | Chun |'+sLineBreak - +'+------+------------+---------+---------+------+---------+' - ), - - ( - Name: 'MLineFromWKB'; - Declaration: '(wkb[,srid])'; - Category: 'WKB'; - Version: SQL_VERSION_ANSI; - Description: 'Constructs a MULTILINESTRING value using its WKB'+sLineBreak - +'representation and SRID.'+sLineBreak - +' '+sLineBreak - +'MLineFromWKB() and MultiLineStringFromWKB() are synonyms.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SET @g = ST_AsBinary(MLineFromText(''MULTILINESTRING((10'+sLineBreak - +'48,10 21,10 0),(16 0,16 23,16 48))''));'+sLineBreak - +' '+sLineBreak - +'SELECT ST_AsText(MLineFromWKB(@g));'+sLineBreak - +'+--------------------------------------------------------+'+sLineBreak - +'| ST_AsText(MLineFromWKB(@g)) |'+sLineBreak - +'+--------------------------------------------------------+'+sLineBreak - +'| MULTILINESTRING((10 48,10 21,10 0),(16 0,16 23,16 48)) |'+sLineBreak - +'+--------------------------------------------------------+' - ), - - ( - Name: 'MPointFromWKB'; - Declaration: '(wkb[,srid])'; - Category: 'WKB'; - Version: SQL_VERSION_ANSI; - Description: 'Constructs a MULTIPOINT value using its WKB representation'+sLineBreak - +'and SRID.'+sLineBreak - +' '+sLineBreak - +'MPointFromWKB() and MultiPointFromWKB() are synonyms.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SET @g = ST_AsBinary(MPointFromText(''MultiPoint( 1 1, 2 2,'+sLineBreak - +'5 3, 7 2, 9 3, 8 4, 6 6, 6 9, 4 9, 1 5 )''));'+sLineBreak - +' '+sLineBreak - +'SELECT ST_AsText(MPointFromWKB(@g));'+sLineBreak - +'+-----------------------------------------------------+'+sLineBreak - +'| ST_AsText(MPointFromWKB(@g)) |'+sLineBreak - +'+-----------------------------------------------------+'+sLineBreak - +'| MULTIPOINT(1 1,2 2,5 3,7 2,9 3,8 4,6 6,6 9,4 9,1 5) |'+sLineBreak - +'+-----------------------------------------------------+' - ), - - ( - Name: 'MPolyFromWKB'; - Declaration: '(wkb[,srid])'; - Category: 'WKB'; - Version: SQL_VERSION_ANSI; - Description: 'Constructs a MULTIPOLYGON value using its WKB representation'+sLineBreak - +'and SRID.'+sLineBreak - +' '+sLineBreak - +'MPolyFromWKB() and MultiPolygonFromWKB() are synonyms.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SET @g = ST_AsBinary(MPointFromText(''MULTIPOLYGON(((28'+sLineBreak - +'26,28 0,84 0,84 42,28 26),(52 18,66 23,73 9,48 6,52'+sLineBreak - +'18)),((59 18,67 18,67 13,59 13,59 18)))''));'+sLineBreak - +' '+sLineBreak - +'SELECT ST_AsText(MPolyFromWKB(@g));'+sLineBreak - +'+---------------------------------------------------------------------------------------------------------------+'+sLineBreak - +'| ST_AsText(MPolyFromWKB(@g)) |'+sLineBreak - +'+---------------------------------------------------------------------------------------------------------------+'+sLineBreak - +'| MULTIPOLYGON(((28 26,28 0,84 0,84 42,28 26),(52 18,66'+sLineBreak - +'23,73 9,48 6,52 18)),((59 18,67 18,67 13,59 13,59 18))) |'+sLineBreak - +'+---------------------------------------------------------------------------------------------------------------+' - ), - - ( - Name: 'ST_AsBinary'; - Declaration: '(g)'; - Category: 'WKB'; - Version: SQL_VERSION_ANSI; - Description: 'Converts a value in internal geometry format to its WKB'+sLineBreak - +'representation and returns the binary result.'+sLineBreak - +' '+sLineBreak - +'ST_AsBinary(), AsBinary(), ST_AsWKB() and AsWKB() are'+sLineBreak - +'synonyms,'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SET @poly = ST_GeomFromText(''POLYGON((0 0,0 1,1 1,1 0,0'+sLineBreak - +'0))'');'+sLineBreak - +'SELECT ST_AsBinary(@poly);'+sLineBreak - +' '+sLineBreak - +'SELECT ST_AsText(ST_GeomFromWKB(ST_AsWKB(@poly)));'+sLineBreak - +'+--------------------------------------------+'+sLineBreak - +'| ST_AsText(ST_GeomFromWKB(ST_AsWKB(@poly))) |'+sLineBreak - +'+--------------------------------------------+'+sLineBreak - +'| POLYGON((0 0,0 1,1 1,1 0,0 0)) |'+sLineBreak - +'+--------------------------------------------+' - ), - - ( - Name: 'ST_GeomCollFromWKB'; - Declaration: '(wkb[,srid])'; - Category: 'WKB'; - Version: SQL_VERSION_ANSI; - Description: 'Constructs a GEOMETRYCOLLECTION value using its WKB'+sLineBreak - +'representation and SRID.'+sLineBreak - +' '+sLineBreak - +'ST_GeomCollFromWKB(), ST_GeometryCollectionFromWKB(),'+sLineBreak - +'GeomCollFromWKB() and GeometryCollectionFromWKB() are'+sLineBreak - +'synonyms.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SET @g ='+sLineBreak - +'ST_AsBinary(ST_GeomFromText(''GEOMETRYCOLLECTION(POLYGON((5'+sLineBreak - +'5,10 5,10 10,5 5)),POINT(10 10))''));'+sLineBreak - +' '+sLineBreak - +'SELECT ST_AsText(ST_GeomCollFromWKB(@g));'+sLineBreak - +'+----------------------------------------------------------------+'+sLineBreak - +'| ST_AsText(ST_GeomCollFromWKB(@g)) |'+sLineBreak - +'+----------------------------------------------------------------+'+sLineBreak - +'| GEOMETRYCOLLECTION(POLYGON((5 5,10 5,10 10,5 5)),POINT(10'+sLineBreak - +'10)) |'+sLineBreak - +'+----------------------------------------------------------------+' - ), - - ( - Name: 'ST_GeomFromWKB'; - Declaration: '(wkb[,srid])'; - Category: 'WKB'; - Version: SQL_VERSION_ANSI; - Description: 'Constructs a geometry value of any type using its WKB'+sLineBreak - +'representation and SRID.'+sLineBreak - +' '+sLineBreak - +'ST_GeomFromWKB(), ST_GeometryFromWKB(), GeomFromWKB() and'+sLineBreak - +'GeometryFromWKB() are synonyms.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SET @g = ST_AsBinary(ST_LineFromText(''LINESTRING(0 4, 4'+sLineBreak - +'6)''));'+sLineBreak - +' '+sLineBreak - +'SELECT ST_AsText(ST_GeomFromWKB(@g));'+sLineBreak - +'+-------------------------------+'+sLineBreak - +'| ST_AsText(ST_GeomFromWKB(@g)) |'+sLineBreak - +'+-------------------------------+'+sLineBreak - +'| LINESTRING(0 4,4 6) |'+sLineBreak - +'+-------------------------------+' - ), - - ( - Name: 'ST_LineFromWKB'; - Declaration: '(wkb[,srid])'; - Category: 'WKB'; - Version: SQL_VERSION_ANSI; - Description: 'Constructs a LINESTRING value using its WKB representation'+sLineBreak - +'and SRID.'+sLineBreak - +' '+sLineBreak - +'ST_LineFromWKB(), LineFromWKB(), ST_LineStringFromWKB(), and'+sLineBreak - +'LineStringFromWKB() are synonyms.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SET @g = ST_AsBinary(ST_LineFromText(''LineString(0 4,4'+sLineBreak - +'6)''));'+sLineBreak - +' '+sLineBreak - +'SELECT ST_AsText(ST_LineFromWKB(@g)) AS l;'+sLineBreak - +' '+sLineBreak - +'+---------------------+'+sLineBreak - +'| l |'+sLineBreak - +'+---------------------+'+sLineBreak - +'| LINESTRING(0 4,4 6) |'+sLineBreak - +'+---------------------+' - ), - - ( - Name: 'ST_PointFromWKB'; - Declaration: '(wkb[,srid])'; - Category: 'WKB'; - Version: SQL_VERSION_ANSI; - Description: 'Constructs a POINT value using its WKB representation and'+sLineBreak - +'SRID.'+sLineBreak - +' '+sLineBreak - +'ST_PointFromWKB() and PointFromWKB() are synonyms.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SET @g = ST_AsBinary(ST_PointFromText(''POINT(0 4)''));'+sLineBreak - +' '+sLineBreak - +'SELECT ST_AsText(ST_PointFromWKB(@g)) AS p;'+sLineBreak - +' '+sLineBreak - +'+------------+'+sLineBreak - +'| p |'+sLineBreak - +'+------------+'+sLineBreak - +'| POINT(0 4) |'+sLineBreak - +'+------------+' - ), - - ( - Name: 'ST_PolyFromWKB'; - Declaration: '(wkb[,srid])'; - Category: 'WKB'; - Version: SQL_VERSION_ANSI; - Description: 'Constructs a POLYGON value using its WKB representation and'+sLineBreak - +'SRID.'+sLineBreak - +' '+sLineBreak - +'ST_PolyFromWKB(), ST_PolygonFromWKB(), PolyFromWKB() and'+sLineBreak - +'PolygonFromWKB() are synonyms.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SET @g = ST_AsBinary(ST_PolyFromText(''POLYGON((1 1,1 5,4'+sLineBreak - +'9,6 9,9 3,7 2,1 1))''));'+sLineBreak - +' '+sLineBreak - +'SELECT ST_AsText(ST_PolyFromWKB(@g)) AS p;'+sLineBreak - +' '+sLineBreak - +'+----------------------------------------+'+sLineBreak - +'| p |'+sLineBreak - +'+----------------------------------------+'+sLineBreak - +'| POLYGON((1 1,1 5,4 9,6 9,9 3,7 2,1 1)) |'+sLineBreak - +'+----------------------------------------+' - ), - - ( - Name: 'MLineFromText'; - Declaration: '(wkt[,srid])'; - Category: 'WKT'; - Version: SQL_VERSION_ANSI; - Description: 'Constructs a MULTILINESTRING value using its WKT'+sLineBreak - +'representation and SRID.'+sLineBreak - +' '+sLineBreak - +'MLineFromText() and MultiLineStringFromText() are synonyms.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'CREATE TABLE gis_multi_line (g MULTILINESTRING);'+sLineBreak - +'SHOW FIELDS FROM gis_multi_line;'+sLineBreak - +' '+sLineBreak - +'INSERT INTO gis_multi_line VALUES'+sLineBreak - +' (MultiLineStringFromText(''MULTILINESTRING((10 48,10 21,10'+sLineBreak - +'0),(16 0,16 23,16 48))'')),'+sLineBreak - +' (MLineFromText(''MULTILINESTRING((10 48,10 21,10 0))'')),'+sLineBreak - +' (MLineFromWKB(AsWKB(MultiLineString(LineString(Point(1, 2),'+sLineBreak - +'Point(3, 5)), LineString(Point(2, 5), Point(5, 8), Point(21,'+sLineBreak - +'7))))));' - ), - - ( - Name: 'MPointFromText'; - Declaration: '(wkt[,srid])'; - Category: 'WKT'; - Version: SQL_VERSION_ANSI; - Description: 'Constructs a MULTIPOINT value using its WKT representation'+sLineBreak - +'and SRID.'+sLineBreak - +' '+sLineBreak - +'MPointFromText() and MultiPointFromText() are synonyms.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'CREATE TABLE gis_multi_point (g MULTIPOINT);'+sLineBreak - +'SHOW FIELDS FROM gis_multi_point;'+sLineBreak - +' '+sLineBreak - +'INSERT INTO gis_multi_point VALUES'+sLineBreak - +' (MultiPointFromText(''MULTIPOINT(0 0,10 10,10 20,20'+sLineBreak - +'20)'')),'+sLineBreak - +' (MPointFromText(''MULTIPOINT(1 1,11 11,11 21,21 21)'')),'+sLineBreak - +' (MPointFromWKB(AsWKB(MultiPoint(Point(3, 6), Point(4,'+sLineBreak - +'10)))));' - ), - - ( - Name: 'MPolyFromText'; - Declaration: '(wkt[,srid])'; - Category: 'WKT'; - Version: SQL_VERSION_ANSI; - Description: 'Constructs a MULTIPOLYGON value using its WKT representation'+sLineBreak - +'and SRID.'+sLineBreak - +' '+sLineBreak - +'MPolyFromText() and MultiPolygonFromText() are synonyms.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'CREATE TABLE gis_multi_polygon (g MULTIPOLYGON);'+sLineBreak - +'SHOW FIELDS FROM gis_multi_polygon;'+sLineBreak - +' '+sLineBreak - +'INSERT INTO gis_multi_polygon VALUES'+sLineBreak - +' (MultiPolygonFromText(''MULTIPOLYGON(((28 26,28 0,84 0,84'+sLineBreak - +'42,28 26),(52 18,66 23,73 9,48 6,52 18)),((59 18,67 18,67'+sLineBreak - +'13,59 13,59 18)))'')),'+sLineBreak - +' (MPolyFromText(''MULTIPOLYGON(((28 26,28 0,84 0,84 42,28'+sLineBreak - +'26),(52 18,66 23,73 9,48 6,52 18)),((59 18,67 18,67 13,59'+sLineBreak - +'13,59 18)))'')),'+sLineBreak - +' (MPolyFromWKB(AsWKB(MultiPolygon(Polygon(LineString(Point(0,'+sLineBreak - +'3), Point(3, 3), Point(3, 0), Point(0, 3)))))));' - ), - - ( - Name: 'ST_AsText'; - Declaration: '(g)'; - Category: 'WKT'; - Version: SQL_VERSION_ANSI; - Description: 'Converts a value in internal geometry format to its WKT'+sLineBreak - +'representation and returns the string result.'+sLineBreak - +' '+sLineBreak - +'ST_AsText(), AsText(), ST_AsWKT() and AsWKT() are all'+sLineBreak - +'synonyms.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'SET @g = ''LineString(1 1,4 4,6 6)'';'+sLineBreak - +' '+sLineBreak - +'SELECT ST_AsText(ST_GeomFromText(@g));'+sLineBreak - +'+--------------------------------+'+sLineBreak - +'| ST_AsText(ST_GeomFromText(@g)) |'+sLineBreak - +'+--------------------------------+'+sLineBreak - +'| LINESTRING(1 1,4 4,6 6) |'+sLineBreak - +'+--------------------------------+' - ), - - ( - Name: 'ST_GeomCollFromText'; - Declaration: '(wkt[,srid])'; - Category: 'WKT'; - Version: SQL_VERSION_ANSI; - Description: 'Constructs a GEOMETRYCOLLECTION value using its WKT '+sLineBreak - +'representation and SRID.'+sLineBreak - +' '+sLineBreak - +'ST_GeomCollFromText(), ST_GeometryCollectionFromText(),'+sLineBreak - +'GeomCollFromText() and GeometryCollectionFromText() are all'+sLineBreak - +'synonyms.'+sLineBreak - +' '+sLineBreak - +'Example'+sLineBreak - +' '+sLineBreak - +'CREATE TABLE gis_geometrycollection (g GEOMETRYCOLLECTION);'+sLineBreak - +'SHOW FIELDS FROM gis_geometrycollection;'+sLineBreak - +' '+sLineBreak - +'INSERT INTO gis_geometrycollection VALUES'+sLineBreak - +' (GeomCollFromText(''GEOMETRYCOLLECTION(POINT(0 0),'+sLineBreak - +'LINESTRING(0 0,10 10))'')),'+sLineBreak - +' (GeometryFromWKB(AsWKB(GeometryCollection(Point(44, 6),'+sLineBreak - +'LineString(Point(3, 6), Point(7, 9)))))),'+sLineBreak - +' (GeomFromText(''GeometryCollection()'')),'+sLineBreak - +' (GeomFromText(''GeometryCollection EMPTY''));' - ), - - ( - Name: 'ST_GeomFromText'; - Declaration: '(wkt[,srid])'; - Category: 'WKT'; - Version: SQL_VERSION_ANSI; - Description: 'Constructs a geometry value of any type using its WKT'+sLineBreak - +'representation and SRID.'+sLineBreak - +' '+sLineBreak - +'GeomFromText(), GeometryFromText(), ST_GeomFromText() and'+sLineBreak - +'ST_GeometryFromText() are all synonyms.'+sLineBreak - +' '+sLineBreak - +'Example'+sLineBreak - +' '+sLineBreak - +'SET @g = ST_GEOMFROMTEXT(''POLYGON((1 1,1 5,4 9,6 9,9 3,7'+sLineBreak - +'2,1 1))'');' - ), - - ( - Name: 'ST_LineFromText'; - Declaration: '(wkt[,srid])'; - Category: 'WKT'; - Version: SQL_VERSION_ANSI; - Description: 'Constructs a LINESTRING value using its WKT representation'+sLineBreak - +'and SRID.'+sLineBreak - +' '+sLineBreak - +'ST_LineFromText(), ST_LineStringFromText(),'+sLineBreak - +'ST_LineFromText() and ST_LineStringFromText() are all'+sLineBreak - +'synonyms.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'CREATE TABLE gis_line (g LINESTRING);'+sLineBreak - +'SHOW FIELDS FROM gis_line;'+sLineBreak - +' '+sLineBreak - +'INSERT INTO gis_line VALUES'+sLineBreak - +' (LineFromText(''LINESTRING(0 0,0 10,10 0)'')),'+sLineBreak - +' (LineStringFromText(''LINESTRING(10 10,20 10,20 20,10 20,10'+sLineBreak - +'10)'')),'+sLineBreak - +' (LineStringFromWKB(AsWKB(LineString(Point(10, 10),'+sLineBreak - +'Point(40, 10)))));' - ), - - ( - Name: 'ST_PointFromText'; - Declaration: '(wkt[,srid])'; - Category: 'WKT'; - Version: SQL_VERSION_ANSI; - Description: 'Constructs a POINT value using its WKT representation and'+sLineBreak - +'SRID.'+sLineBreak - +' '+sLineBreak - +'ST_PointFromText() and PointFromText() are synonyms.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'CREATE TABLE gis_point (g POINT);'+sLineBreak - +'SHOW FIELDS FROM gis_point;'+sLineBreak - +' '+sLineBreak - +'INSERT INTO gis_point VALUES'+sLineBreak - +' (PointFromText(''POINT(10 10)'')),'+sLineBreak - +' (PointFromText(''POINT(20 10)'')),'+sLineBreak - +' (PointFromText(''POINT(20 20)'')),'+sLineBreak - +' (PointFromWKB(AsWKB(PointFromText(''POINT(10 20)''))));' - ), - - ( - Name: 'ST_PolyFromText'; - Declaration: '(wkt[,srid])'; - Category: 'WKT'; - Version: SQL_VERSION_ANSI; - Description: 'Constructs a POLYGON value using its WKT representation and'+sLineBreak - +'SRID.'+sLineBreak - +' '+sLineBreak - +'ST_PolyFromText(), ST_PolygonFromText(), PolyFromText() and'+sLineBreak - +'ST_PolygonFromText() are all synonyms.'+sLineBreak - +' '+sLineBreak - +''+sLineBreak - +'CREATE TABLE gis_polygon (g POLYGON);'+sLineBreak - +'INSERT INTO gis_polygon VALUES'+sLineBreak - +' (PolygonFromText(''POLYGON((10 10,20 10,20 20,10 20,10'+sLineBreak - +'10))'')),'+sLineBreak - +' (PolyFromText(''POLYGON((0 0,50 0,50 50,0 50,0 0), (10'+sLineBreak - +'10,20 10,20 20,10 20,10 10))''));' - ) - - ); - - - MySQLVariables: array [0..417] of TServerVariable = - ( - ( - Name: 'auto_increment_increment'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'auto_increment_offset'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'autocommit'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'automatic_sp_privileges'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'back_log'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'basedir'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'big_tables'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'binlog_cache_size'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'binlog_checksum'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'binlog_direct_non_transactional_updates'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'binlog_format'; - IsDynamic: True; - VarScope: vsBoth; - EnumValues: 'ROW,STATEMENT,MIXED'; - ), - ( - Name: 'binlog_row_image'; - IsDynamic: True; - VarScope: vsBoth; - EnumValues: 'FULL,MINIMAL,NOBLOB'; - ), - ( - Name: 'binlog_stmt_cache_size'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'bulk_insert_buffer_size'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'character_set_client'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'character_set_connection'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'character_set_database[a]'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'character_set_filesystem'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'character_set_results'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'character_set_server'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'character_set_system'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'character_sets_dir'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'collation_connection'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'collation_database[b]'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'collation_server'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'completion_type'; - IsDynamic: True; - VarScope: vsBoth; - EnumValues: 'NO_CHAIN,CHAIN,RELEASE,0,1,2'; - ), - ( - Name: 'concurrent_insert'; - IsDynamic: True; - VarScope: vsGlobal; - EnumValues: 'NEVER,AUTO,ALWAYS,0,1,2'; - ), - ( - Name: 'connect_timeout'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'datadir'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'date_format'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'datetime_format'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'debug'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'debug_sync'; - IsDynamic: True; - VarScope: vsSession; - ), - ( - Name: 'default_storage_engine'; - IsDynamic: True; - VarScope: vsBoth; - EnumValues: 'FEDERATED,MRG_MYISAM,MyISAM,BLACKHOLE,CSV,MEMORY,ARCHIVE,InnoDB'; - ), - ( - Name: 'default_tmp_storage_engine'; - IsDynamic: True; - VarScope: vsBoth; - EnumValues: 'FEDERATED,MRG_MYISAM,MyISAM,BLACKHOLE,CSV,MEMORY,ARCHIVE,InnoDB'; - ), - ( - Name: 'default_week_format'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'delay_key_write'; - IsDynamic: True; - VarScope: vsGlobal; - EnumValues: 'ON,OFF,ALL'; - ), - ( - Name: 'delayed_insert_limit'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'delayed_insert_timeout'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'delayed_queue_size'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'disable_gtid_unsafe_statements'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'div_precision_increment'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'end_markers_in_json'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'engine_condition_pushdown'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'eq_range_index_dive_limit'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'error_count'; - IsDynamic: False; - VarScope: vsSession; - ), - ( - Name: 'event_scheduler'; - IsDynamic: True; - VarScope: vsGlobal; - EnumValues: 'ON,OFF,DISABLED'; - ), - ( - Name: 'expire_logs_days'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'external_user'; - IsDynamic: False; - VarScope: vsSession; - ), - ( - Name: 'flush'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'flush_time'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'foreign_key_checks'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'ft_boolean_syntax'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'ft_max_word_len'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'ft_min_word_len'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'ft_query_expansion_limit'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'ft_stopword_file'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'general_log'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'general_log_file'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'group_concat_max_len'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'gtid_done'; - IsDynamic: False; - VarScope: vsBoth; - ), - ( - Name: 'gtid_lost'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'gtid_mode'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'gtid_mode'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'gtid_next'; - IsDynamic: True; - VarScope: vsSession; - EnumValues: 'AUTOMATIC,ANONYMOUS'; - ), - ( - Name: 'gtid_owned'; - IsDynamic: False; - VarScope: vsBoth; - ), - ( - Name: 'have_compress'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'have_crypt'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'have_csv'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'have_dynamic_loading'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'have_geometry'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'have_innodb'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'have_ndbcluster'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'have_openssl'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'have_partitioning'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'have_profiling'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'have_query_cache'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'have_rtree_keys'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'have_ssl'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'have_symlink'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'host_cache_size'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'hostname'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'identity'; - IsDynamic: True; - VarScope: vsSession; - ), - ( - Name: 'ignore_builtin_innodb'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'init_connect'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'init_file'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'init_slave'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_adaptive_flushing'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_adaptive_hash_index'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_adaptive_max_sleep_delay'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_additional_mem_pool_size'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_analyze_is_persistent'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_api_enable_binlog'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_api_enable_mdl'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_api_trx_level'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_autoextend_increment'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_autoinc_lock_mode'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_buffer_pool_dump_at_shutdown'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_buffer_pool_dump_now'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_buffer_pool_filename'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_buffer_pool_instances'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_buffer_pool_load_abort'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_buffer_pool_load_at_startup'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_buffer_pool_load_now'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_buffer_pool_size'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_change_buffer_max_size'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_change_buffering'; - IsDynamic: True; - VarScope: vsGlobal; - EnumValues: 'INSERTS,DELETES,PURGES,CHANGES,ALL,NONE'; - ), - ( - Name: 'innodb_checksum_algorithm'; - IsDynamic: True; - VarScope: vsGlobal; - EnumValues: 'INNODB,CRC32,NONE,STRICT_INNODB,STRICT_CRC32,STRICT_NONE'; - ), - ( - Name: 'innodb_checksums'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_commit_concurrency'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_concurrency_tickets'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_data_file_path'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_data_home_dir'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_doublewrite'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_fast_shutdown'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_file_format'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_file_format_check'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_file_format_max'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_file_per_table'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_flush_log_at_trx_commit'; - IsDynamic: True; - VarScope: vsGlobal; - EnumValues: '0,1,2'; - ), - ( - Name: 'innodb_flush_method'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_flush_neighbors'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_force_load_corrupted'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_force_recovery'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_ft_aux_table'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_ft_cache_size'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_ft_enable_stopword'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_ft_max_token_size'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_ft_min_token_size'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_ft_num_word_optimize'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_ft_server_stopword_table'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_ft_sort_pll_degree'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_ft_user_stopword_table'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_io_capacity'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_large_prefix'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_lock_wait_timeout'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'innodb_locks_unsafe_for_binlog'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_log_buffer_size'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_log_file_size'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_log_files_in_group'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_log_group_home_dir'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_lru_scan_depth'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_max_dirty_pages_pct'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_max_purge_lag'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_mirrored_log_groups'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_monitor_disable'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_monitor_enable'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_monitor_reset'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_monitor_reset_all'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_old_blocks_pct'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_old_blocks_time'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_open_files'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_optimize_fulltext_only'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_page_size'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_print_all_deadlocks'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_purge_batch_size'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_purge_threads'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_random_read_ahead'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_read_ahead_threshold'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_read_io_threads'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_replication_delay'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_rollback_on_timeout'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_rollback_segments'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_sort_buffer_size'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_spin_wait_delay'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_stats_method'; - IsDynamic: True; - VarScope: vsBoth; - EnumValues: 'NULLS_EQUAL,NULLS_UNEQUAL,NULLS_IGNORED'; - ), - ( - Name: 'innodb_stats_on_metadata'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_stats_persistent_sample_pages'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_stats_sample_pages'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_stats_transient_sample_pages'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_strict_mode'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'innodb_support_xa'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'innodb_sync_array_size'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_sync_spin_loops'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_table_locks'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'innodb_thread_concurrency'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_thread_sleep_delay'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_undo_directory'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_undo_logs'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_undo_tablespaces'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_use_native_aio'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_use_sys_malloc'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_version'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'innodb_write_io_threads'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'insert_id'; - IsDynamic: True; - VarScope: vsSession; - ), - ( - Name: 'interactive_timeout'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'join_buffer_size'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'keep_files_on_create'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'key_buffer_size'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'key_cache_age_threshold'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'key_cache_block_size'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'key_cache_division_limit'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'language'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'large_files_support'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'large_page_size'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'large_pages'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'last_insert_id'; - IsDynamic: True; - VarScope: vsSession; - ), - ( - Name: 'lc_messages'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'lc_messages_dir'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'lc_time_names'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'license'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'local_infile'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'lock_wait_timeout'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'locked_in_memory'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'log'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'log_bin'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'log_bin_basename'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'log_error'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'log_output'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'log_queries_not_using_indexes'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'log_slave_updates'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'log_slow_queries'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'log_throttle_queries_not_using_indexes'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'log_warnings'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'long_query_time'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'low_priority_updates'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'lower_case_file_system'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'lower_case_table_names'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'master_info_repository'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'master_verify_checksum'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'max_allowed_packet'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'max_binlog_cache_size'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'max_binlog_size'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'max_binlog_stmt_cache_size'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'max_connect_errors'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'max_connections'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'max_delayed_threads'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'max_error_count'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'max_heap_table_size'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'max_insert_delayed_threads'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'max_join_size'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'max_length_for_sort_data'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'max_prepared_stmt_count'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'max_relay_log_size'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'max_seeks_for_key'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'max_sort_length'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'max_sp_recursion_depth'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'max_tmp_tables'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'max_user_connections'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'max_write_lock_count'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'memlock'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'metadata_locks_cache_size'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'myisam_data_pointer_size'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'myisam_max_sort_file_size'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'myisam_mmap_size'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'myisam_recover_options'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'myisam_repair_threads'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'myisam_sort_buffer_size'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'myisam_stats_method'; - IsDynamic: True; - VarScope: vsBoth; - EnumValues: 'NULLS_EQUAL,NULLS_UNEQUAL,NULLS_IGNORED'; - ), - ( - Name: 'myisam_use_mmap'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'named_pipe'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'net_buffer_length'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'net_read_timeout'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'net_retry_count'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'net_write_timeout'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'new'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'old'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'old_alter_table'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'old_passwords'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'open_files_limit'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'optimizer_join_cache_level'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'optimizer_prune_level'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'optimizer_search_depth'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'optimizer_switch'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'optimizer_trace'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'optimizer_trace_features'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'optimizer_trace_limit'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'optimizer_trace_max_mem_size'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'optimizer_trace_offset'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'have_partitioning'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'performance_schema'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'performance_schema_accounts_size'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'performance_schema_digests_size'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'performance_schema_events_stages_history_long_size'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'performance_schema_events_stages_history_size'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'performance_schema_events_statements_history_long_size'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'performance_schema_events_statements_history_size'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'performance_schema_events_waits_history_long_size'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'performance_schema_events_waits_history_size'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'performance_schema_hosts_size'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'performance_schema_max_cond_classes'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'performance_schema_max_cond_instances'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'performance_schema_max_file_classes'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'performance_schema_max_file_handles'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'performance_schema_max_file_instances'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'performance_schema_max_mutex_classes'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'performance_schema_max_mutex_instances'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'performance_schema_max_rwlock_classes'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'performance_schema_max_rwlock_instances'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'performance_schema_max_socket_classes'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'performance_schema_max_socket_instances'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'performance_schema_max_stage_classes'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'performance_schema_max_statement_classes'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'performance_schema_max_table_handles'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'performance_schema_max_table_instances'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'performance_schema_max_thread_classes'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'performance_schema_max_thread_instances'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'performance_schema_setup_actors_size'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'performance_schema_setup_objects_size'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'performance_schema_users_size'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'pid_file'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'plugin_dir'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'port'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'preload_buffer_size'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'profiling'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'profiling_history_size'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'protocol_version'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'proxy_user'; - IsDynamic: False; - VarScope: vsSession; - ), - ( - Name: 'pseudo_thread_id'; - IsDynamic: True; - VarScope: vsSession; - ), - ( - Name: 'query_alloc_block_size'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'query_cache_limit'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'query_cache_min_res_unit'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'query_cache_size'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'query_cache_type'; - IsDynamic: True; - VarScope: vsBoth; - EnumValues: '0,1,2'; - ), - ( - Name: 'query_cache_wlock_invalidate'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'query_prealloc_size'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'rand_seed1'; - IsDynamic: True; - VarScope: vsSession; - ), - ( - Name: 'rand_seed2'; - IsDynamic: True; - VarScope: vsSession; - ), - ( - Name: 'range_alloc_block_size'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'read_buffer_size'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'read_only'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'read_rnd_buffer_size'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'relay_log_basename'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'relay_log_index'; - IsDynamic: False; - VarScope: vsBoth; - ), - ( - Name: 'relay_log_index'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'relay_log_info_file'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'relay_log_info_repository'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'relay_log_purge'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'relay_log_recovery'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'relay_log_space_limit'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'report_host'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'report_password'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'report_port'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'report_user'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'rpl_semi_sync_master_enabled'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'rpl_semi_sync_master_timeout'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'rpl_semi_sync_master_trace_level'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'rpl_semi_sync_master_wait_no_slave'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'rpl_semi_sync_slave_enabled'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'rpl_semi_sync_slave_trace_level'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'secure_auth'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'secure_file_priv'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'server_id'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'server_uuid'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'shared_memory'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'shared_memory_base_name'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'skip_external_locking'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'skip_name_resolve'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'skip_networking'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'skip_show_database'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'slave_compressed_protocol'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'slave_exec_mode'; - IsDynamic: True; - VarScope: vsGlobal; - EnumValues: 'IDEMPOTENT,STRICT'; - ), - ( - Name: 'slave_load_tmpdir'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'slave_net_timeout'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'slave_parallel_workers'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'slave_skip_errors'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'slave_sql_verify_checksum'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'slave_transaction_retries'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'slave_type_conversions'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'slow_launch_time'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'slow_query_log'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'slow_query_log_file'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'socket'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'sort_buffer_size'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'sql_auto_is_null'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'sql_big_selects'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'sql_big_tables'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'sql_buffer_result'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'sql_log_bin'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'sql_log_off'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'sql_low_priority_updates'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'sql_max_join_size'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'sql_mode'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'sql_notes'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'sql_quote_show_create'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'sql_safe_updates'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'sql_select_limit'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'sql_slave_skip_counter'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'sql_warnings'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'ssl_ca'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'ssl_capath'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'ssl_cert'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'ssl_cipher'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'ssl_crl'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'ssl_crlpath'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'ssl_key'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'storage_engine'; - IsDynamic: True; - VarScope: vsBoth; - EnumValues: 'FEDERATED,MRG_MYISAM,MyISAM,BLACKHOLE,CSV,MEMORY,ARCHIVE,InnoDB'; - ), - ( - Name: 'stored_program_cache'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'sync_binlog'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'sync_frm'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'sync_master_info'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'sync_relay_log'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'sync_relay_log_info'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'system_time_zone'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'table_definition_cache'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'table_open_cache'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'thread_cache_size'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'thread_concurrency'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'thread_handling'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'thread_stack'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'time_format'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'time_zone'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'timed_mutexes'; - IsDynamic: True; - VarScope: vsGlobal; - ), - ( - Name: 'timestamp'; - IsDynamic: True; - VarScope: vsSession; - ), - ( - Name: 'tmp_table_size'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'tmpdir'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'transaction_alloc_block_size'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'transaction_prealloc_size'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'tx_isolation'; - IsDynamic: True; - VarScope: vsBoth; - EnumValues: 'READ-UNCOMMITTED,READ-COMMITTED,REPEATABLE-READ,SERIALIZABLE'; - ), - ( - Name: 'tx_read_only'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'unique_checks'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'updatable_views_with_limit'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'version'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'version_comment'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'version_compile_machine'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'version_compile_os'; - IsDynamic: False; - VarScope: vsGlobal; - ), - ( - Name: 'wait_timeout'; - IsDynamic: True; - VarScope: vsBoth; - ), - ( - Name: 'warning_count'; - IsDynamic: False; - VarScope: vsSession; - ) +uses apphelpers; - ); +{ TSqlProvider } +constructor TSqlProvider.Create(ANetType: TNetType); +begin + FNetType := ANetType; + FServerVersion := 0; +end; - function GetFunctionCategories: TStringList; +function TSqlProvider.Has(AId: TQueryId): Boolean; +begin + Result := not GetSql(AId).IsEmpty; +end; -implementation +function TSqlProvider.GetSql(AId: TQueryId): string; +begin + // Basic default SQL snippets compatible to all or most servers + case AId of + qEmptyTable: Result := 'DELETE FROM %s'; + qForeignKeyEventAction: Result := 'RESTRICT,CASCADE,SET NULL,NO ACTION'; + qOrderAsc: Result := 'ASC'; + qOrderDesc: Result := 'DESC'; + qGetRowCountExact: Result := 'SELECT COUNT(*) FROM :QuotedDbAndTableName'; + qAutoInc: Result := 'AUTO_INCREMENT'; + else Result := ''; + end; +end; -uses apphelpers; +function TSqlProvider.GetSql(AId: TQueryId; const Args: array of const): string; +begin + Result := GetSql(AId); + if Result.IsEmpty then + Exit; + Result := Format(Result, Args); +end; -function GetFunctionCategories: TStringList; +function TSqlProvider.GetSql(AId: TQueryId; NamedParameters: TStringMap): string; var - i: Integer; + Key: String; begin - Result := TStringList.Create; - for i:=0 to Length(MySqlFunctions)-1 do - begin - if Result.IndexOf( MySqlFunctions[i].Category ) = -1 then - begin - Result.Add( MySqlFunctions[i].Category ); - end; + Result := GetSql(AId); + if Result.IsEmpty then + Exit; + for Key in NamedParameters.Keys do begin + Result := StringReplace(Result, ':'+Key, NamedParameters[Key], [rfReplaceAll]); end; - Result.Sort; end; { EDbError } -constructor EDbError.Create(const Msg: string; const ErrorCode: Cardinal=0); +constructor EDbError.Create(const Msg: string; const ErrorCode_: Cardinal=0; const Hint_: String=''); begin - Self.ErrorCode := ErrorCode; + FErrorCode := ErrorCode_; + FHint := Hint_; inherited Create(Msg); end; @@ -19764,19 +255,16 @@ constructor EDbError.Create(const Msg: string; const ErrorCode: Cardinal=0); { TDbLib } -constructor TDbLib.Create(DllFile: String); +constructor TDbLib.Create(UsedDllFile, HintDefaultDll: String); var - msg: String; + msg, ErrorHint: String; begin // Load DLL as is (with or without path) inherited Create; - FDllFile := DllFile; + FDllFile := UsedDllFile; + // On Windows, we have the full path to the dll file here, so even if the file portion is empty, FDllFile contains a path / non-empty string if not FileExists(FDllFile) then begin - msg := f_('File does not exist: %s', [FDllFile]) + - sLineBreak + sLineBreak + - f_('Please launch %s from the directory where you have installed it. Or just reinstall %s.', [APPNAME, APPNAME] - ); - Raise EdbError.Create(msg); + Raise EdbError.Create(_('No library selected. Please select one of the provided libraries in the drop-down.')); end; FHandle := LoadLibrary(PWideChar(FDllFile)); @@ -19784,9 +272,17 @@ constructor TDbLib.Create(DllFile: String); msg := f_('Library %s could not be loaded. Please select a different one.', [ExtractFileName(FDllFile)] ); - if Windows.GetLastError <> 0 then - msg := msg + sLineBreak + sLineBreak + f_('Internal error %d: %s', [Windows.GetLastError, SysErrorMessage(Windows.GetLastError)]); - Raise EDbError.Create(msg); + if GetLastError <> 0 then begin + msg := msg + sLineBreak + sLineBreak + f_('Internal error %d: %s', [GetLastError, SysErrorMessage(GetLastError)]); + end; + if (HintDefaultDll <> '') and (ExtractFileName(FDllFile) <> HintDefaultDll) then begin + ErrorHint := f_('You could try the default library %s in your session settings. (Current: %s)', + [HintDefaultDll, ExtractFileName(FDllFile)] + ); + end else begin + ErrorHint := ''; + end; + Raise EDbError.Create(msg, GetLastError, ErrorHint); end; // Dll was loaded, now initialize required procedures @@ -19815,220 +311,12 @@ procedure TDbLib.AssignProc(var Proc: FARPROC; Name: PAnsiChar; Mandantory: Bool msg := f_('Library error in %s: Could not find procedure address for "%s"', [ExtractFileName(FDllFile), Name] ); - if Windows.GetLastError <> 0 then - msg := msg + sLineBreak + sLineBreak + f_('Internal error %d: %s', [Windows.GetLastError, SysErrorMessage(Windows.GetLastError)]); + if GetLastError <> 0 then + msg := msg + sLineBreak + sLineBreak + f_('Internal error %d: %s', [GetLastError, SysErrorMessage(GetLastError)]); Raise EDbError.Create(msg, LIB_PROC_ERROR); end; end; end; -procedure TMySQLLib.AssignProcedures; -begin - AssignProc(@mysql_affected_rows, 'mysql_affected_rows'); - AssignProc(@mysql_character_set_name, 'mysql_character_set_name'); - AssignProc(@mysql_close, 'mysql_close'); - AssignProc(@mysql_data_seek, 'mysql_data_seek'); - AssignProc(@mysql_errno, 'mysql_errno'); - AssignProc(@mysql_error, 'mysql_error'); - AssignProc(@mysql_fetch_field_direct, 'mysql_fetch_field_direct'); - AssignProc(@mysql_fetch_field, 'mysql_fetch_field'); - AssignProc(@mysql_fetch_lengths, 'mysql_fetch_lengths'); - AssignProc(@mysql_fetch_row, 'mysql_fetch_row'); - AssignProc(@mysql_free_result, 'mysql_free_result'); - AssignProc(@mysql_get_client_info, 'mysql_get_client_info'); - AssignProc(@mysql_get_server_info, 'mysql_get_server_info'); - AssignProc(@mysql_init, 'mysql_init'); - AssignProc(@mysql_num_fields, 'mysql_num_fields'); - AssignProc(@mysql_num_rows, 'mysql_num_rows'); - AssignProc(@mysql_ping, 'mysql_ping'); - AssignProc(@mysql_options, 'mysql_options'); - AssignProc(@mysql_optionsv, 'mysql_optionsv', False); - AssignProc(@mysql_real_connect, 'mysql_real_connect'); - AssignProc(@mysql_real_query, 'mysql_real_query'); - AssignProc(@mysql_ssl_set, 'mysql_ssl_set'); - AssignProc(@mysql_stat, 'mysql_stat'); - AssignProc(@mysql_store_result, 'mysql_store_result'); - AssignProc(@mysql_thread_id, 'mysql_thread_id'); - AssignProc(@mysql_next_result, 'mysql_next_result'); - AssignProc(@mysql_set_character_set, 'mysql_set_character_set'); - AssignProc(@mysql_thread_init, 'mysql_thread_init'); - AssignProc(@mysql_thread_end, 'mysql_thread_end'); - AssignProc(@mysql_warning_count, 'mysql_warning_count'); -end; - - -procedure TPostgreSQLLib.AssignProcedures; -begin - AssignProc(@PQconnectdb, 'PQconnectdb'); - AssignProc(@PQerrorMessage, 'PQerrorMessage'); - AssignProc(@PQresultErrorMessage, 'PQresultErrorMessage'); - AssignProc(@PQresultErrorField, 'PQresultErrorField'); - AssignProc(@PQfinish, 'PQfinish'); - AssignProc(@PQstatus, 'PQstatus'); - AssignProc(@PQsendQuery, 'PQsendQuery'); - AssignProc(@PQgetResult, 'PQgetResult'); - AssignProc(@PQbackendPID, 'PQbackendPID'); - AssignProc(@PQcmdTuples, 'PQcmdTuples'); - AssignProc(@PQntuples, 'PQntuples'); - AssignProc(@PQclear, 'PQclear'); - AssignProc(@PQnfields, 'PQnfields'); - AssignProc(@PQfname, 'PQfname'); - AssignProc(@PQftype, 'PQftype'); - AssignProc(@PQftable, 'PQftable'); - AssignProc(@PQgetvalue, 'PQgetvalue'); - AssignProc(@PQgetlength, 'PQgetlength'); - AssignProc(@PQgetisnull, 'PQgetisnull'); - AssignProc(@PQlibVersion, 'PQlibVersion'); -end; - - -procedure TSQLiteLib.AssignProcedures; -begin - AssignProc(@sqlite3_open, 'sqlite3_open'); - AssignProc(@sqlite3_libversion, 'sqlite3_libversion'); - AssignProc(@sqlite3_close, 'sqlite3_close'); - AssignProc(@sqlite3_db_config, 'sqlite3_db_config'); - AssignProc(@sqlite3_errmsg, 'sqlite3_errmsg'); - AssignProc(@sqlite3_errcode, 'sqlite3_errcode'); - AssignProc(@sqlite3_prepare_v2, 'sqlite3_prepare_v2'); - AssignProc(@sqlite3_prepare_v3, 'sqlite3_prepare_v3'); - AssignProc(@sqlite3_exec, 'sqlite3_exec'); - AssignProc(@sqlite3_finalize, 'sqlite3_finalize'); - AssignProc(@sqlite3_step, 'sqlite3_step'); - AssignProc(@sqlite3_reset, 'sqlite3_reset'); - AssignProc(@sqlite3_total_changes, 'sqlite3_total_changes'); - AssignProc(@sqlite3_column_text, 'sqlite3_column_text'); - AssignProc(@sqlite3_column_count, 'sqlite3_column_count'); - AssignProc(@sqlite3_column_name, 'sqlite3_column_name'); - AssignProc(@sqlite3_column_decltype, 'sqlite3_column_decltype'); - AssignProc(@sqlite3_column_database_name, 'sqlite3_column_database_name'); - AssignProc(@sqlite3_column_table_name, 'sqlite3_column_table_name'); - AssignProc(@sqlite3_column_origin_name, 'sqlite3_column_origin_name'); - AssignProc(@sqlite3_column_type, 'sqlite3_column_type'); - AssignProc(@sqlite3_next_stmt, 'sqlite3_next_stmt'); - AssignProc(@sqlite3_table_column_metadata, 'sqlite3_table_column_metadata'); - AssignProc(@sqlite3_collation_needed, 'sqlite3_collation_needed'); - AssignProc(@sqlite3_create_collation, 'sqlite3_create_collation'); -end; - - - -initialization - -// Keywords copied from SynHighligherSQL -MySQLKeywords := TStringList.Create; -MySQLKeywords.CommaText := 'ACCESSIBLE,ACTION,ADD,AFTER,AGAINST,AGGREGATE,ALGORITHM,ALL,ALTER,ANALYZE,AND,ANY,AS,' + - 'ASC,ASENSITIVE,AT,AUTO_INCREMENT,AVG_ROW_LENGTH,BACKUP,BEFORE,BEGIN,BENCHMARK,BETWEEN,BINLOG,BIT,' + - 'BOOL,BOTH,BY,CACHE,CALL,CASCADE,CASCADED,CASE,CHANGE,CHARACTER,CHARSET,CHECK,' + - 'CHECKSUM,CLIENT,COLLATE,COLLATION,COLUMN,COLUMNS,COMMENT,COMMIT,' + - 'COMMITTED,COMPLETION,CONCURRENT,CONNECTION,CONSISTENT,CONSTRAINT,' + - 'CONVERT,CONTAINS,CONTENTS,CREATE,CROSS,DATA,DATABASE,DATABASES,DAY_HOUR,' + - 'DAY_MICROSECOND,DAY_MINUTE,DAY_SECOND,DEALLOCATE,DEC,DEFAULT,DEFINER,DELAYED,DELAY_KEY_WRITE,DELETE,DESC,' + - 'DETERMINISTIC,DIRECTORY,DISABLE,DISCARD,DESCRIBE,DISTINCT,DISTINCTROW,' + - 'DIV,DROP,DUAL,DUMPFILE,DUPLICATE,EACH,ELSE,ELSEIF,ENABLE,ENCLOSED,END,ENDS,' + - 'ENGINE,ENGINES,ESCAPE,ESCAPED,ERRORS,EVENT,EVENTS,EVERY,EXECUTE,EXISTS,' + - 'EXPANSION,EXPLAIN,FALSE,FIELDS,FILE,FIRST,FLOAT4,FLOAT8,FLUSH,FOR,FORCE,FOREIGN,FROM,' + - 'FULL,FULLTEXT,FUNCTION,FUNCTIONS,GLOBAL,GRANT,GRANTS,GROUP,HAVING,HELP,' + - 'HIGH_PRIORITY,HOSTS,HOUR_MICROSECOND,HOUR_MINUTE,HOUR_SECOND,IDENTIFIED,IGNORE,IGNORE_SERVER_IDS,INDEX,INFILE,INNER,INOUT,INSENSITIVE,INSERT,' + - 'INSERT_METHOD,INSTALL,INT1,INT2,INT3,INT4,INT8,INTEGER,INTO,IO_THREAD,IS,' + - 'ISOLATION,INVOKER,JOIN,KEY,KEYS,KILL,LAST,LEADING,LEAVES,LEVEL,LESS,' + - 'LIKE,LIMIT,LINEAR,LINES,LIST,LOAD,LOCAL,LOCK,LOGS,LONG,LOW_PRIORITY,' + - 'MASTER,MASTER_HOST,MASTER_HEARTBEAT_PERIOD,MASTER_LOG_FILE,MASTER_LOG_POS,MASTER_CONNECT_RETRY,' + - 'MASTER_PASSWORD,MASTER_PORT,MASTER_SSL,MASTER_SSL_CA,MASTER_SSL_CAPATH,' + - 'MASTER_SSL_CERT,MASTER_SSL_CIPHER,MASTER_SSL_KEY,MASTER_SSL_VERIFY_SERVER_CERT,MASTER_USER,MATCH,' + - 'MAX_ROWS,MAXVALUE,MIDDLEINT,MIN_ROWS,MINUTE_MICROSECOND,MINUTE_SECOND,MOD,MODE,MODIFY,MODIFIES,NAMES,' + - 'NATURAL,NEW,NO,NODEGROUP,NOT,NO_WRITE_TO_BINLOG,NULL,NUMERIC,OJ,OFFSET,OLD,ON,OPTIMIZE,OPTION,' + - 'OPTIONALLY,OPEN,OR,ORDER,OUT,OUTER,OUTFILE,PACK_KEYS,PARTIAL,PARTITION,' + - 'PARTITIONS,PERSISTENT,PLUGIN,PLUGINS,PRECISION,PREPARE,PRESERVE,PRIMARY,PRIVILEGES,PROCEDURE,' + - 'PROCESS,PROCESSLIST,PURGE,QUERY,RAID_CHUNKS,RAID_CHUNKSIZE,RAID_TYPE,RANGE,' + - 'READ,READS,READ_WRITE,REAL,REBUILD,REFERENCES,REGEXP,RELAY_LOG_FILE,RELAY_LOG_POS,RELEASE,RELOAD,' + - 'RENAME,REORGANIZE,REPAIR,REPEATABLE,REPLACE,REPLICATION,REQUIRE,RESIGNAL,RESTRICT,RESET,' + - 'RESTORE,RETURN,RETURNS,REVOKE,RLIKE,ROLLBACK,ROLLUP,ROUTINE,ROW,' + - 'ROW_FORMAT,ROWS,SAVEPOINT,SCHEDULE,SCHEMA,SCHEMAS,SECOND_MICROSECOND,SECURITY,SELECT,' + - 'SENSITIVE,SEPARATOR,SERIALIZABLE,SESSION,SET,SHARE,SHOW,SHUTDOWN,SIGNAL,SIMPLE,SLAVE,SNAPSHOT,SOME,' + - 'SONAME,SPECIFIC,SQL,SQLEXCEPTION,SQLSTATE,SQLWARNING,SQL_BIG_RESULT,SQL_BUFFER_RESULT,SQL_CACHE,' + - 'SQL_CALC_FOUND_ROWS,SQL_NO_CACHE,SQL_SMALL_RESULT,SPATIAL,SQL_THREAD,SSL,START,' + - 'STARTING,STARTS,STATUS,STOP,STORAGE,STRAIGHT_JOIN,SUBPARTITION,' + - 'SUBPARTITIONS,SUPER,TABLE,TABLES,TABLESPACE,TEMPORARY,TERMINATED,THAN,' + - 'THEN,TO,TRAILING,TRANSACTION,TRIGGER,TRIGGERS,TRUE,TYPE,UNCOMMITTED,UNDO,' + - 'UNINSTALL,UNIQUE,UNLOCK,UNSIGNED,UPDATE,UPGRADE,UNION,USAGE,USE,USING,VALUES,VARCHARACTER,' + - 'VARIABLES,VARYING,VIEW,VIRTUAL,WARNINGS,WHEN,WHERE,WITH,WORK,WRITE,XOR,YEAR_MONTH,ZEROFILL,' - // SQL Plus commands: - + 'CLOSE,CONDITION,CONTINUE,CURSOR,DECLARE,DO,EXIT,FETCH,FOUND,GOTO,' + - 'HANDLER,ITERATE,LANGUAGE,LEAVE,LOOP,UNTIL,WHILE'; - -// Error codes copied from perror.exe -MySQLErrorCodes := Explode(',', '0=No error,'+ - '1=Operation not permitted,'+ - '2=No such file or directory,'+ - '3=No such process,'+ - '4=Interrupted function call,'+ - '5=Input/output error,'+ - '6=No such device or address,'+ - '7=Arg list too long,'+ - '8=Exec format error,'+ - '9=Bad file descriptor,'+ - '10=No child processes,'+ - '11=Resource temporarily unavailable,'+ - '12=Not enough space,'+ - '13=Permission denied,'+ - '14=Bad address,'+ - '16=Resource device,'+ - '17=File exists,'+ - '18=Improper link,'+ - '19=No such device,'+ - '20=Not a directory,'+ - '21=Is a directory,'+ - '22=Invalid argument,'+ - '23=Too many open files in system,'+ - '24=Too many open files,'+ - '25=Inappropriate I/O control operation,'+ - '27=File too large,'+ - '28=No space left on device,'+ - '29=Invalid seek,'+ - '30=Read-only file system,'+ - '31=Too many links,'+ - '32=Broken pipe,'+ - '33=Domain error,'+ - '34=Result too large,'+ - '36=Resource deadlock avoided,'+ - '38=Filename too long,'+ - '39=No locks available,'+ - '40=Function not implemented,'+ - '41=Directory not empty,'+ - '42=Illegal byte sequence,'+ - '120=Didn''t find key on read or update,'+ - '121=Duplicate key on write or update,'+ - '123=Someone has changed the row since it was read (while the table was locked to prevent it),'+ - '124=Wrong index given to function,'+ - '126=Index file is crashed,'+ - '127=Record-file is crashed,'+ - '128=Out of memory,'+ - '130=Incorrect file format,'+ - '131=Command not supported by database,'+ - '132=Old database file,'+ - '133=No record read before update,'+ - '134=Record was already deleted (or record file crashed),'+ - '135=No more room in record file,'+ - '136=No more room in index file,'+ - '137=No more records (read after end of file),'+ - '138=Unsupported extension used for table,'+ - '139=Too big row,'+ - '140=Wrong create options,'+ - '141=Duplicate unique key or constraint on write or update,'+ - '142=Unknown character set used,'+ - '143=Conflicting table definitions in sub-tables of MERGE table,'+ - '144=Table is crashed and last repair failed,'+ - '145=Table was marked as crashed and should be repaired,'+ - '146=Lock timed out; Retry transaction,'+ - '147=Lock table is full; Restart program with a larger locktable,'+ - '148=Updates are not allowed under a read only transactions,'+ - '149=Lock deadlock; Retry transaction,'+ - '150=Foreign key constraint is incorrectly formed,'+ - '151=Cannot add a child row,'+ - '152=Cannot delete a parent row'); - - - end. diff --git a/source/dbstructures.postgresql.pas b/source/dbstructures.postgresql.pas new file mode 100644 index 000000000..9489241ba --- /dev/null +++ b/source/dbstructures.postgresql.pas @@ -0,0 +1,753 @@ +unit dbstructures.postgresql; + +interface + +uses + dbstructures, StrUtils; + +type + // PostgreSQL structures + TPQConnectStatus = (CONNECTION_OK, CONNECTION_BAD, CONNECTION_STARTED, CONNECTION_MADE, CONNECTION_AWAITING_RESPONSE, CONNECTION_AUTH_OK, CONNECTION_SETENV, CONNECTION_SSL_STARTUP, CONNECTION_NEEDED); + PPGconn = Pointer; + PPGresult = Pointer; + POid = Cardinal; // Object ID is a fundamental type in Postgres. + TPostgreSQLLib = class(TDbLib) + PQconnectdb: function(const ConnInfo: PAnsiChar): PPGconn cdecl; + PQerrorMessage: function(const Handle: PPGconn): PAnsiChar cdecl; + PQresultErrorMessage: function(const Result: PPGresult): PAnsiChar cdecl; + PQresultErrorField: function(const Result: PPGresult; fieldcode: Integer): PAnsiChar; + PQfinish: procedure(const Handle: PPGconn); + PQstatus: function(const Handle: PPGconn): TPQConnectStatus cdecl; + PQsendQuery: function(const Handle: PPGconn; command: PAnsiChar): Integer cdecl; + PQgetResult: function(const Handle: PPGconn): PPGresult cdecl; + PQbackendPID: function(const Handle: PPGconn): Integer cdecl; + PQcmdTuples: function(Result: PPGresult): PAnsiChar; cdecl; + PQntuples: function(Result: PPGresult): Integer; cdecl; + PQclear: procedure(Result: PPGresult); cdecl; + PQnfields: function(Result: PPGresult): Integer; cdecl; + PQfname: function(const Result: PPGresult; column_number: Integer): PAnsiChar; cdecl; + PQftype: function(const Result: PPGresult; column_number: Integer): POid; cdecl; + PQftable: function(const Result: PPGresult; column_number: Integer): POid; cdecl; + PQgetvalue: function(const Result: PPGresult; row_number: Integer; column_number: Integer): PAnsiChar; cdecl; + PQgetlength: function(const Result: PPGresult; row_number: Integer; column_number: Integer): Integer; cdecl; + PQgetisnull: function(const Result: PPGresult; row_number: Integer; column_number: Integer): Integer; cdecl; + PQlibVersion: function(): Integer; cdecl; + protected + procedure AssignProcedures; override; + end; + + TPostgreSQLProvider = class(TSqlProvider) + public + function GetSql(AId: TQueryId): string; override; + end; + +const InvalidOid: POid = 0; + +var + PostgreSQLDatatypes: Array[0..39] of TDBDatatype = + ( + ( + Index: dbdtUnknown; + NativeTypes: '99999'; + Name: 'UNKNOWN'; + Description: 'Unknown data type'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: False; + Category: dtcOther; + ), + ( + Index: dbdtSmallint; + NativeTypes: '21'; + Name: 'SMALLINT'; + Names: 'smallint|int2'; + Description: 'Small-range integer. Range: -32768 to +32767. Storage Size: 2 Bytes.'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: False; + ValueMustMatch: '^\d{1,5}$'; + Category: dtcInteger; + ), + ( + Index: dbdtInt; + // 26 = oid, 28 = xid + NativeTypes: '23|26|28'; + Name: 'INTEGER'; + Names: 'integer|int4|int|oid|xid'; + Description: 'Typical choice for integer. Range: -2147483648 to +2147483647. Storage Size: 4 Bytes.'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: False; + ValueMustMatch: '^\d{1,10}$'; + Category: dtcInteger; + ), + ( + Index: dbdtBigint; + NativeTypes: '20'; + Name: 'BIGINT'; + Names: 'bigint|int8'; + Description: 'Large-range integer. Range: -9223372036854775808 to 9223372036854775807. Storage Size: 8 Bytes.'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: False; + ValueMustMatch: '^\d{1,19}$'; + Category: dtcInteger; + ), + ( + Index: dbdtSerial; + Name: 'SERIAL'; + Names: 'serial|serial4'; + Description: 'Autoincrementing integer. Range: 1 to 2147483647. Storage Size: 4 Bytes.'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: False; + Category: dtcInteger; + ), + ( + Index: dbdtBigSerial; + Name: 'BIGSERIAL'; + Names: 'bigserial|serial8'; + Description: 'Large autoincrementing integer. Range: 1 to 9223372036854775807. Storage Size: 8 Bytes.'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: False; + Category: dtcInteger; + ), + ( + Index: dbdtVarBit; + NativeTypes: '1562'; + Name: 'BIT VARYING'; + Names: 'bit varying|varbit'; + Description: 'Variable-length bit string.'; + HasLength: True; + RequiresLength: False; + HasBinary: False; + HasDefault: True; + LoadPart: False; + Category: dtcInteger; + ), + ( + Index: dbdtBit; + NativeTypes: '1560'; + Name: 'BIT'; + Names: 'bit'; + Description: 'Fixed-length bit string.'; + HasLength: True; + RequiresLength: False; + HasBinary: False; + HasDefault: True; + LoadPart: False; + Category: dtcInteger; + ), + ( + Index: dbdtNumeric; + NativeTypes: '1700'; + Name: 'NUMERIC'; + Names: 'numeric|float8|decimal'; + Description: 'User-specified precision, exact. Range: no limit. Storage Size: variable.'; + HasLength: True; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: False; + Category: dtcReal; + ), + ( + Index: dbdtReal; + NativeTypes: '700'; + Name: 'REAL'; + Names: 'real|float4'; + Description: 'Variable-precision, inexact. Range: 6 decimal digits precision. Storage Size: 4 Bytes.'; + HasLength: True; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: False; + Category: dtcReal; + ), + ( + Index: dbdtDoublePrecision; + NativeTypes: '701|1700'; + Name: 'DOUBLE PRECISION'; + Names: 'double precision|float8'; + Description: 'Variable-precision, inexact. Range: 15 decimal digits precision. Storage Size: 8 Bytes.'; + HasLength: True; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: False; + Category: dtcReal; + ), + ( + Index: dbdtChar; + NativeTypes: '18|1042'; + Name: 'CHAR'; + Names: 'CHARACTER'; + Description: 'Fixed-length, blank padded.'; + HasLength: True; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: True; + Category: dtcText; + ), + ( + Index: dbdtVarchar; + NativeTypes: '18|19|24|1043|1043'; + Name: 'VARCHAR'; + Names: 'char|bpchar|varchar|name|enum|character varying'; + Description: 'Variable-length with limit.'; + HasLength: True; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: True; + Category: dtcText; + ), + ( + Index: dbdtText; + NativeTypes: '25|22|30|143|629|651|719|791|1000|1028|1040|1041|1115|1182|1183|1185|1187|1231|1263|1270|1561|1563|2201|2207|2211|2949|2951|3643|3644|3645|3735|3770'; + Name: 'TEXT'; + Names: 'text|int2vector|oidvector|bool'; + Description: 'Variable unlimited length.'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: True; + Category: dtcText; + ), + ( + Index: dbdtCiText; + NativeTypes: '?'; + Name: 'CITEXT'; + Names: 'citext'; + Description: 'A case-insensitive character string type. Essentially, it internally calls lower when comparing values. Otherwise, it behaves almost exactly like text.'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: True; + Category: dtcText; + ), + ( + Index: dbdtCidr; + NativeTypes: '650'; + Name: 'CIDR'; + Names: 'cidr'; + Description: 'IPv4 and IPv6 networks. Storage size: 7 or 19 bytes'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: False; + Category: dtcText; + ), + ( + Index: dbdtInet; + NativeTypes: '869'; + Name: 'INET'; + Names: 'inet'; + Description: 'IPv4 and IPv6 hosts and networks. Storage size: 7 or 19 bytes'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: False; + Category: dtcText; + ), + ( + Index: dbdtMacaddr; + NativeTypes: '829'; + Name: 'MACADDR'; + Names: 'macaddr'; + Description: 'MAC addresses. Storage size: 6 bytes'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: False; + Category: dtcText; + ), + ( + Index: dbdtMoney; + NativeTypes: '790'; + Name: 'MONEY'; + Description: 'Currency amount. Range: -92233720368547758.08 to +92233720368547758.07. Storage Size: 8 Bytes.'; + HasLength: True; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: False; + Category: dtcText; + ), + ( + Index: dbdtDate; + NativeTypes: '1082'; + Name: 'DATE'; + Description: 'Calendar date (year, month, day).'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: False; + Format: 'yyyy-mm-dd'; + Category: dtcTemporal; + ), + ( + Index: dbdtTime; + NativeTypes: '1083'; + Name: 'TIME'; + Description: 'Time of day.'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: False; + Format: 'hh:nn:ss'; + Category: dtcTemporal; + ), + ( + Index: dbdtDatetime; + NativeTypes: '1082|1114|702'; + Name: 'TIMESTAMP'; + Names: 'timestamp|datetime|abstime|timestamp without time zone'; + Description: 'Date and time without timezone, e.g. "2020-06-27 16:24:41".'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: False; + Format: 'yyyy-mm-dd hh:nn:ss'; + Category: dtcTemporal; + ), + ( + Index: dbdtDatetime2; + NativeTypes: '1184'; + Name: 'TIMESTAMPTZ'; + Names: 'timestamptz|timestamp with time zone'; + Description: 'Date and time with time zone, e.g. "2020-06-27 16:24:41+02".'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: False; + Format: 'yyyy-mm-dd hh:nn:ss'; + Category: dtcTemporal; + ), + ( + Index: dbdtDate; + NativeTypes: '1082'; + Name: 'DATE'; + Description: 'Calendar date (year, month, day).'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: False; + Format: 'yyyy-mm-dd'; + Category: dtcTemporal; + ), + ( + Index: dbdtInterval; + NativeTypes: '1186'; + Name: 'INTERVAL'; + Description: 'time interval from -178000000 years to 178000000 years'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: False; + Format: 'yyyy-mm-dd hh:nn:ss'; + Category: dtcTemporal; + ), + ( + Index: dbdtBlob; + NativeTypes: '17'; + Name: 'BYTEA'; + Description: 'Binary data ("byte array").'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: True; + Category: dtcBinary; + ), + ( + Index: dbdtPoint; + NativeTypes: '600'; + Name: 'POINT'; + Description: 'Point on a plane (x,y). Storage size: 16 bytes.'; + HasLength: True; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: False; + Category: dtcSpatial; + ), + ( + Index: dbdtLinestring; + NativeTypes: '628'; + Name: 'LINE'; + Description: 'Infinite line ((x1,y1),(x2,y2)). Storage size: 32 bytes.'; + HasLength: True; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: False; + Category: dtcSpatial; + ), + ( + Index: dbdtLineSegment; + NativeTypes: '601'; + Name: 'LSEG'; + Description: 'Finite line segment ((x1,y1),(x2,y2)). Storage size: 32 bytes.'; + HasLength: True; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: False; + Category: dtcSpatial; + ), + ( + Index: dbdtBox; + NativeTypes: '603'; + Name: 'BOX'; + Description: 'Rectangular box ((x1,y1),(x2,y2)). Storage size: 32 bytes.'; + HasLength: True; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: False; + Category: dtcSpatial; + ), + ( + Index: dbdtPath; + NativeTypes: '602'; + Name: 'PATH'; + Description: 'Closed path (similar to polygon) ((x1,y1),...). Storage size: 16+16n bytes.'; + HasLength: True; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: False; + Category: dtcSpatial; + ), + ( + Index: dbdtPolygon; + NativeTypes: '604'; + Name: 'POLYGON'; + Description: 'Closed path (similar to polygon) ((x1,y1),...). Storage size: 40+16n bytes.'; + HasLength: True; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: False; + Category: dtcSpatial; + ), + ( + Index: dbdtCircle; + NativeTypes: '718'; + Name: 'CIRCLE'; + Description: 'Circle <(x,y),r> (center point and radius). Storage size: 24 bytes.'; + HasLength: True; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: False; + Category: dtcSpatial; + ), + ( + Index: dbdtBool; + NativeTypes: '16'; + Name: 'BOOLEAN'; + Names: 'boolean|bool'; + Description: 'State of true or false. Storage size: 1 byte.'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: False; + ValueMustMatch: '^(true|false)$'; + Category: dtcOther; + ), + ( + Index: dbdtRegClass; + NativeTypes: '2205'; + Name: 'REGCLASS'; + Names: 'regclass'; + Description: 'Relation name'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: False; + Category: dtcOther; + ), + ( + Index: dbdtRegProc; + NativeTypes: '24'; + Name: 'REGPROC'; + Names: 'regproc|regprocedure'; + Description: 'Function name'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: False; + Category: dtcOther; + ), + ( + Index: dbdtEnum; + NativeTypes: 'e'; + Name: 'ENUM'; + Names: ''; + Description: 'A list of quoted labels, each of which must be less than NAMEDATALEN bytes long (64 bytes in a standard PostgreSQL build)'; + HasLength: True; // Enables the Length/set field in table editor + RequiresLength: True; + HasBinary: False; + HasDefault: True; + LoadPart: False; + Category: dtcOther; + ), + ( + Index: dbdtJson; + NativeTypes: '114'; + Name: 'JSON'; + Names: 'json'; + Description: 'JavaScript Object Notation data'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: False; + Category: dtcText; + ), + ( + Index: dbdtJsonB; + NativeTypes: '3802'; + Name: 'JSONB'; + Names: 'jsonb'; + Description: 'JavaScript Object Notation data in a binary form'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: False; + Category: dtcText; + ), + ( + Index: dbdtUniqueidentifier; + NativeTypes: '2950'; + Name: 'UUID'; + Names: 'uuid'; + Description: 'The data type uuid stores Universally Unique Identifiers (UUID) as defined by RFC 4122, ISO/IEC 9834-8:2005, and related standards.'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: False; + ValueMustMatch: '^\{?[a-f0-9]{8}-?[a-f0-9]{4}-?[a-f0-9]{4}-?[a-f0-9]{4}-?[a-f0-9]{12}\}?$'; + Category: dtcText; + ) + ); + +implementation + +procedure TPostgreSQLLib.AssignProcedures; +begin + AssignProc(@PQconnectdb, 'PQconnectdb'); + AssignProc(@PQerrorMessage, 'PQerrorMessage'); + AssignProc(@PQresultErrorMessage, 'PQresultErrorMessage'); + AssignProc(@PQresultErrorField, 'PQresultErrorField'); + AssignProc(@PQfinish, 'PQfinish'); + AssignProc(@PQstatus, 'PQstatus'); + AssignProc(@PQsendQuery, 'PQsendQuery'); + AssignProc(@PQgetResult, 'PQgetResult'); + AssignProc(@PQbackendPID, 'PQbackendPID'); + AssignProc(@PQcmdTuples, 'PQcmdTuples'); + AssignProc(@PQntuples, 'PQntuples'); + AssignProc(@PQclear, 'PQclear'); + AssignProc(@PQnfields, 'PQnfields'); + AssignProc(@PQfname, 'PQfname'); + AssignProc(@PQftype, 'PQftype'); + AssignProc(@PQftable, 'PQftable'); + AssignProc(@PQgetvalue, 'PQgetvalue'); + AssignProc(@PQgetlength, 'PQgetlength'); + AssignProc(@PQgetisnull, 'PQgetisnull'); + AssignProc(@PQlibVersion, 'PQlibVersion'); +end; + + +{ TPostgreSQLProvider } + +function TPostgreSQLProvider.GetSql(AId: TQueryId): string; +begin + case AId of + qDatabaseDrop: Result := 'DROP SCHEMA %s'; + qRenameTable: Result := 'ALTER TABLE %s RENAME TO %s'; + qRenameView: Result := 'ALTER VIEW %s RENAME TO %s'; + qCurrentUserHost: Result := 'SELECT CURRENT_USER'; + qLikeCompare: Result := '%s ILIKE %s'; + qAddColumn: Result := 'ADD %s'; + qChangeColumn: Result := 'ALTER COLUMN %s %s'; + qRenameColumn: Result := 'RENAME COLUMN %s TO %s'; + qForeignKeyEventAction: Result := 'RESTRICT,CASCADE,SET NULL,NO ACTION,SET DEFAULT'; + qSessionVariables: Result := 'SHOW ALL'; + qGlobalVariables: Result := 'SHOW ALL'; + qISSchemaCol: Result := '%s_schema'; + qUSEQuery: Result := 'SET search_path TO %s'; + qKillQuery: Result := 'SELECT pg_cancel_backend(%d)'; + qKillProcess: Result := 'SELECT pg_cancel_backend(%d)'; + qFuncLength: Result := 'LENGTH'; + qFuncCeil: Result := 'CEIL'; + qFuncLeft: Result := 'SUBSTRING(%s, 1, %d)'; + qFuncNow: Result := 'NOW()'; + qFuncLastAutoIncNumber: Result := 'LASTVAL()'; + qLockedTables: Result := ''; + qDisableForeignKeyChecks: Result := ''; + qEnableForeignKeyChecks: Result := ''; + qForeignKeyDrop: Result := 'DROP CONSTRAINT %s'; + + // This uses pg_attribute.attgenerated, which only exists starting in PostgreSQL 12 + qGetTableColumns: Result := IfThen( + FServerVersion >= 120000, + 'SELECT ' + + ' n.nspname AS table_schema, ' + + ' c.relname AS table_name, ' + + ' a.attname AS column_name, ' + + ' a.attnum AS ordinal_position, ' + + ' pg_catalog.format_type(a.atttypid, a.atttypmod) AS data_type, ' + + // YES/NO like information_schema.is_nullable + ' CASE ' + + ' WHEN a.attnotnull THEN ''NO'' ' + + ' ELSE ''YES'' ' + + ' END AS is_nullable, ' + + // Character maximum length (in characters) + ' CASE ' + + ' WHEN (bt.typcategory = ''S'' OR (bt.oid IS NULL AND t.typcategory = ''S'')) ' + + ' AND a.atttypmod <> -1 ' + + ' THEN a.atttypmod - 4 ' + + ' ELSE NULL ' + + ' END AS character_maximum_length, ' + + // Numeric precision / scale (NULL for non-numeric) + ' CASE ' + + ' WHEN (bt.typcategory IN (''N'',''F'')) OR (bt.oid IS NULL AND t.typcategory IN (''N'',''F'')) ' + + ' THEN ' + + ' CASE ' + + ' WHEN a.atttypmod = -1 THEN NULL ' + + ' ELSE ((a.atttypmod - 4) >> 16)::integer ' + + ' END ' + + ' END AS numeric_precision, ' + + ' CASE ' + + ' WHEN (bt.typcategory IN (''N'',''F'')) OR (bt.oid IS NULL AND t.typcategory IN (''N'',''F'')) ' + + ' THEN ' + + ' CASE ' + + ' WHEN a.atttypmod = -1 THEN NULL ' + + ' ELSE ((a.atttypmod - 4) & 65535)::integer ' + + ' END ' + + ' END AS numeric_scale, ' + + // Datetime precision (for time/timestamp/interval) + ' CASE ' + + ' WHEN (bt.typcategory = ''D'' OR (bt.oid IS NULL AND t.typcategory = ''D'')) ' + + ' AND a.atttypmod <> -1 ' + + ' THEN a.atttypmod ' + + ' ELSE NULL ' + + ' END AS datetime_precision, ' + + // Character set name: PostgreSQL has one per DB; mimic information_schema + ' CASE ' + + ' WHEN (bt.typcategory = ''S'' OR (bt.oid IS NULL AND t.typcategory = ''S'')) ' + + ' THEN current_database() ' + + ' ELSE NULL ' + + ' END AS character_set_name, ' + + // Collation name for collatable columns + ' CASE ' + + ' WHEN (bt.typcategory = ''S'' OR (bt.oid IS NULL AND t.typcategory = ''S'')) ' + + ' THEN ' + + ' CASE ' + + ' WHEN a.attcollation <> t.typcollation ' + + ' THEN coll.collname ' + + ' ELSE NULL ' + + ' END ' + + ' ELSE NULL ' + + ' END AS collation_name, ' + + // Default expression for non-generated columns + ' CASE ' + + ' WHEN a.attgenerated = '''' AND a.atthasdef ' + + ' THEN pg_get_expr(ad.adbin, ad.adrelid) ' + + ' ELSE NULL ' + + ' END AS column_default, ' + + // Generation expression for generated columns + ' CASE ' + + ' WHEN a.attgenerated <> '''' AND a.atthasdef ' + + ' THEN pg_get_expr(ad.adbin, ad.adrelid) ' + + ' ELSE NULL ' + + ' END AS generation_expression, ' + + ' d.description AS column_comment ' + + 'FROM pg_catalog.pg_class AS c ' + + 'JOIN pg_catalog.pg_namespace AS n ON n.oid = c.relnamespace ' + + 'JOIN pg_catalog.pg_attribute AS a ON a.attrelid = c.oid ' + + 'JOIN pg_catalog.pg_type AS t ON t.oid = a.atttypid ' + + 'LEFT JOIN pg_catalog.pg_type AS bt ON bt.oid = t.typbasetype ' + + 'LEFT JOIN pg_catalog.pg_attrdef AS ad ' + + ' ON ad.adrelid = a.attrelid ' + + ' AND ad.adnum = a.attnum ' + + 'LEFT JOIN pg_catalog.pg_description AS d ' + + ' ON d.objoid = a.attrelid ' + + ' AND d.objsubid = a.attnum ' + + 'LEFT JOIN pg_catalog.pg_collation AS coll ' + + ' ON coll.oid = a.attcollation ' + + 'WHERE n.nspname = %s ' + + ' AND a.attnum > 0 ' + + ' AND NOT a.attisdropped ' + + ' AND c.relname = %s ' + + 'ORDER BY ordinal_position', + '' // ServerVersion < 12 + ); + + qGetCharsets: Result := 'SELECT DISTINCT pg_encoding_to_char(enc) AS "Charset" FROM '+ + '(SELECT conforencoding AS enc FROM pg_catalog.pg_conversion '+ + ' UNION '+ + ' SELECT contoencoding AS enc FROM pg_catalog.pg_conversion) AS x'; + qGetRowCountApprox: Result := 'SELECT reltuples::bigint FROM pg_class'+ + ' LEFT JOIN pg_namespace ON pg_namespace.oid = pg_class.relnamespace'+ + ' WHERE pg_class.relkind=''r'''+ + ' AND pg_namespace.nspname=:EscapedDatabase'+ + ' AND pg_class.relname=:EscapedName'; + qExplain: Result := 'EXPLAIN %s'; + qGetEnumTypes: Result := IfThen( + FServerVersion >= 90000, + 'SELECT ' + + ' n.nspname AS enum_schema, ' + + ' t.typname AS enum_name, ' + + ' string_agg(e.enumlabel, ''|'' ORDER BY e.enumsortorder) AS enum_labels ' + + 'FROM pg_type AS t ' + + 'JOIN pg_enum AS e ' + + ' ON t.oid = e.enumtypid ' + + 'JOIN pg_namespace AS n ' + + ' ON n.oid = t.typnamespace ' + + 'WHERE t.typtype = ''e'' ' + + 'GROUP BY n.nspname, t.typname ' + + 'ORDER BY UPPER(t.typname)', + '' // ServerVersion < 9 + ); + qAutoInc: Result := 'SERIAL'; + qCastAsText: Result := '%s::text'; + else Result := inherited; + end; +end; + + +end. diff --git a/source/dbstructures.sqlite.pas b/source/dbstructures.sqlite.pas new file mode 100644 index 000000000..fb1cef0cc --- /dev/null +++ b/source/dbstructures.sqlite.pas @@ -0,0 +1,437 @@ +unit dbstructures.sqlite; + +interface + +uses + dbstructures; + + +const + { SQLite Result Codes + result code definitions + Many SQLite functions return an integer result code from the set shown + here in order to indicate success or failure. + New error codes may be added in future versions of SQLite. + See also: [extended result code definitions] + } + SQLITE_OK = 0; // Successful result + // beginning-of-error-codes + SQLITE_ERROR = 1; // Generic error + SQLITE_INTERNAL = 2; // Internal logic error in SQLite + SQLITE_PERM = 3; // Access permission denied + SQLITE_ABORT = 4; // Callback routine requested an abort + SQLITE_BUSY = 5; // The database file is locked + SQLITE_LOCKED = 6; // A table in the database is locked + SQLITE_NOMEM = 7; // A malloc() failed + SQLITE_READONLY = 8; // Attempt to write a readonly database + SQLITE_INTERRUPT = 9; // Operation terminated by sqlite3_interrupt()*/ + SQLITE_IOERR = 10; // Some kind of disk I/O error occurred + SQLITE_CORRUPT = 11; // The database disk image is malformed + SQLITE_NOTFOUND = 12; // Unknown opcode in sqlite3_file_control() + SQLITE_FULL = 13; // Insertion failed because database is full + SQLITE_CANTOPEN = 14; // Unable to open the database file + SQLITE_PROTOCOL = 15; // Database lock protocol error + SQLITE_EMPTY = 16; // Internal use only + SQLITE_SCHEMA = 17; // The database schema changed + SQLITE_TOOBIG = 18; // String or BLOB exceeds size limit + SQLITE_CONSTRAINT = 19; // Abort due to constraint violation + SQLITE_MISMATCH = 20; // Data type mismatch + SQLITE_MISUSE = 21; // Library used incorrectly + SQLITE_NOLFS = 22; // Uses OS features not supported on host + SQLITE_AUTH = 23; // Authorization denied + SQLITE_FORMAT = 24; // Not used + SQLITE_RANGE = 25; // 2nd parameter to sqlite3_bind out of range + SQLITE_NOTADB = 26; // File opened that is not a database file + SQLITE_NOTICE = 27; // Notifications from sqlite3_log() + SQLITE_WARNING = 28; // Warnings from sqlite3_log() + SQLITE_ROW = 100; // sqlite3_step() has another row ready + SQLITE_DONE = 101; // sqlite3_step() has finished executing + + { SQLite Flags + These constants define various flags that can be passed into + "prepFlags" parameter of the [sqlite3_prepare_v3()] and + [sqlite3_prepare16_v3()] interfaces. + New flags may be added in future releases of SQLite. + } + SQLITE_PREPARE_PERSISTENT = $01; // prepared statement will be retained for a long time and probably reused many times + SQLITE_PREPARE_NORMALIZE = $02; // no-op + SQLITE_PREPARE_NO_VTAB = $04; // return an error (error code SQLITE_ERROR) if the statement uses any virtual tables + + + + { SQLite Fundamental Datatypes + + Every value in SQLite has one of five fundamental datatypes: + 64-bit signed integer + 64-bit IEEE floating point number + string + BLOB + NULL + } + SQLITE_INTEGER = 1; + + SQLITE_FLOAT = 2; + SQLITE_BLOB = 4; + SQLITE_NULL = 5; + SQLITE_TEXT = 3; + SQLITE3_TEXT = 3; + { CAPI3REF: Database Connection Configuration Options + These constants are the available integer configuration options that + can be passed as the second argument to the [sqlite3_db_config()] interface. + } + SQLITE_DBCONFIG_MAINDBNAME = 1000; // const char* + SQLITE_DBCONFIG_LOOKASIDE = 1001; // void* int int + SQLITE_DBCONFIG_ENABLE_FKEY = 1002; // int int* + SQLITE_DBCONFIG_ENABLE_TRIGGER = 1003; // int int* + SQLITE_DBCONFIG_ENABLE_FTS3_TOKENIZER = 1004; // int int* + SQLITE_DBCONFIG_ENABLE_LOAD_EXTENSION = 1005; // int int* + SQLITE_DBCONFIG_NO_CKPT_ON_CLOSE = 1006; // int int* + SQLITE_DBCONFIG_ENABLE_QPSG = 1007; // int int* + SQLITE_DBCONFIG_TRIGGER_EQP = 1008; // int int* + SQLITE_DBCONFIG_RESET_DATABASE = 1009; // int int* + SQLITE_DBCONFIG_DEFENSIVE = 1010; // int int* + SQLITE_DBCONFIG_WRITABLE_SCHEMA = 1011; // int int* + SQLITE_DBCONFIG_LEGACY_ALTER_TABLE = 1012; // int int* + SQLITE_DBCONFIG_DQS_DML = 1013; // int int* + SQLITE_DBCONFIG_DQS_DDL = 1014; // int int* + SQLITE_DBCONFIG_ENABLE_VIEW = 1015; // int int* + SQLITE_DBCONFIG_MAX = 1015; // Largest DBCONFIG + + +type + + Psqlite3 = Pointer; + Psqlite3_stmt = Pointer; + + TSQLiteCollationNeededCallback = procedure(userData: Pointer; ppDb:Psqlite3; eTextRep: Integer; zName: PAnsiChar); cdecl; + TSQLiteCollation = function(userData: Pointer; lenA: Integer; strA: PAnsiChar; lenB: Integer; strB: PAnsiChar): Integer; cdecl; + + TSQLiteLib = class(TDbLib) + sqlite3_open: function(const filename: PAnsiChar; var ppDb: Psqlite3): Integer; cdecl; + sqlite3_libversion: function(): PAnsiChar; cdecl; + sqlite3_close: function(ppDb: Psqlite3): Integer; cdecl; + sqlite3_db_config: function (ppDb: Psqlite3; op: Integer): Integer; cdecl varargs; + sqlite3_enable_load_extension: function(ppDb: Psqlite3; onoff: Integer): Integer; cdecl; + sqlite3_errmsg: function(ppDb: Psqlite3): PAnsiChar; cdecl; + sqlite3_errcode: function(ppDb: Psqlite3): Integer; cdecl; + sqlite3_prepare_v2: function(ppDb: Psqlite3; zSql: PAnsiChar; nByte: Integer; var ppStmt: Psqlite3_stmt; var pzTail: PAnsiChar): Integer; cdecl; + sqlite3_prepare_v3: function(ppDb: Psqlite3; zSql: PAnsiChar; nByte: Integer; prepFlags: Cardinal; var ppStmt: Psqlite3_stmt; var pzTail: PAnsiChar): Integer; cdecl; + sqlite3_exec: function(ppDb: Psqlite3; sql: PAnsiChar; callback: Integer; callvack_arg: Pointer; errmsg: PAnsiChar): Integer; cdecl; + sqlite3_finalize: function(pStmt: Psqlite3_stmt): Integer; cdecl; + sqlite3_step: function(pStmt: Psqlite3_stmt): Integer; cdecl; + sqlite3_reset: function(pStmt: Psqlite3_stmt): Integer; cdecl; + sqlite3_total_changes: function(ppDb: Psqlite3): Integer; cdecl; + sqlite3_column_text: function(pStmt: Psqlite3_stmt; iCol: Integer): PAnsiChar; cdecl; + sqlite3_column_count: function(pStmt: Psqlite3_stmt): Integer; cdecl; + sqlite3_column_name: function(pStmt: Psqlite3_stmt; N: Integer): PAnsiChar; cdecl; + sqlite3_column_decltype: function(pStmt: Psqlite3_stmt; N: Integer): PAnsiChar; cdecl; + sqlite3_column_database_name: function(pStmt: Psqlite3_stmt; N: Integer): PAnsiChar; cdecl; + sqlite3_column_table_name: function(pStmt: Psqlite3_stmt; N: Integer): PAnsiChar; cdecl; + sqlite3_column_origin_name: function(pStmt: Psqlite3_stmt; N: Integer): PAnsiChar; cdecl; + sqlite3_column_type: function(pStmt: Psqlite3_stmt; iCol: Integer): Integer; cdecl; + sqlite3_next_stmt: function(ppDb: Psqlite3; pStmt: Psqlite3_stmt): Psqlite3_stmt; cdecl; + sqlite3_table_column_metadata: function(ppDb: Psqlite3; + zDbName, zTableName, zColumnName: PAnsiChar; + var pzDataType, pzCollSeq: PAnsiChar; var pNotNull, pPrimaryKey, pAutoinc: Integer + ): Integer; cdecl; + sqlite3_collation_needed: function(ppDb: Psqlite3; userData: Pointer; Func: TSQLiteCollationNeededCallback): Integer; cdecl; + sqlite3_create_collation: function(ppDb: Psqlite3; const zName: PAnsiChar; eTextRep: Integer; pArg: Pointer; xCompare: TSQLiteCollation): Integer; cdecl; + // Additionally, for use in Multiple Ciphers library: + sqlite3_key: function(ppDb: Psqlite3; const pKey: Pointer; nKey: Integer): Integer; cdecl; + sqlite3mc_cipher_count: function(): Integer; cdecl; + sqlite3mc_cipher_name: function(cipherIndex: Integer): PAnsiChar; cdecl; + sqlite3mc_cipher_index: function(const cipherName: PAnsiChar): Integer; cdecl; + sqlite3mc_config: function(ppDb: Psqlite3; const paramName: PAnsiChar; newValue: Integer): Integer; cdecl; + sqlite3mc_config_cipher: function(ppDb: Psqlite3; const cipherName: PAnsiChar; const paramName: PAnsiChar; newValue: Integer): Integer; cdecl; + private + FWithMultipleCipherFunctions: Boolean; + protected + procedure AssignProcedures; override; + public + constructor Create(DllFile, DefaultDll: String); override; + constructor CreateWithMultipleCipherFunctions(DllFile, DefaultDll: String); + end; + + TSQLiteProvider = class(TSqlProvider) + public + function GetSql(AId: TQueryId): string; override; + end; + +var + + SQLiteDatatypes: Array[0..15] of TDBDatatype = + ( + ( + Index: dbdtUnknown; + Name: 'UNKNOWN'; + Description: 'Unknown data type'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: False; + Category: dtcOther; + ), + ( + Index: dbdtTinyint; + Name: 'TINYINT'; + Names: 'INT2|BOOLEAN|BOOL'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: False; + Category: dtcInteger; + ), + ( + Index: dbdtInt; + Name: 'INTEGER'; + Names: 'INT|MEDIUMINT|INT8'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: True; + LoadPart: False; + Category: dtcInteger; + ), + ( + Index: dbdtUint; + Name: 'UINT'; + Names: 'UINT'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: True; + LoadPart: False; + Category: dtcInteger; + ), + ( + Index: dbdtBigint; + Name: 'BIGINT'; + Names: 'UNSIGNED BIG INT'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: True; + LoadPart: False; + Category: dtcInteger; + ), + ( + Index: dbdtChar; + Name: 'CHAR'; + Names: 'CHARACTER|CHAR|NCHAR|NATIVE CHARACTER'; + HasLength: True; + RequiresLength: True; + HasBinary: False; + HasDefault: True; + LoadPart: True; + DefLengthSet: '50'; + Category: dtcText; + ), + ( + Index: dbdtVarchar; + Name: 'VARCHAR'; + Names: 'VARCHAR|VARYING CHARACTER|NVARCHAR|CHARACTER|CHAR|NCHAR|NATIVE CHARACTER'; + HasLength: True; + RequiresLength: True; + HasBinary: False; + HasDefault: True; + LoadPart: True; + DefLengthSet: '50'; + Category: dtcText; + ), + ( + Index: dbdtText; + Name: 'TEXT'; + Names: 'CLOB'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: True; + LoadPart: True; + Category: dtcText; + ), + ( + Index: dbdtUniqueidentifier; + Name: 'UNIQUEIDENTIFIER'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: True; + LoadPart: False; + Category: dtcBinary; + ), + ( + Index: dbdtBlob; + Name: 'BLOB'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: False; + LoadPart: True; + Category: dtcBinary; + ), + ( + Index: dbdtReal; + Name: 'REAL'; + Names: 'REAL|NUMERIC|DOUBLE|DOUBLE PRECISION|FLOAT|DECIMAL'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: True; + LoadPart: False; + Category: dtcReal; + ), + ( + Index: dbdtDate; + Name: 'DATE'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: True; + LoadPart: False; + Category: dtcTemporal; + ), + ( + Index: dbdtTime; + Name: 'TIME'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: True; + LoadPart: False; + Category: dtcTemporal; + ), + ( + Index: dbdtDatetime; + Name: 'DATETIME'; + HasLength: False; + RequiresLength: False; + HasBinary: False; + HasDefault: True; + LoadPart: False; + Category: dtcTemporal; + ), + ( + Index: dbdtEnum; + Name: 'ENUM'; + HasLength: True; + RequiresLength: True; + HasBinary: False; + HasDefault: True; + LoadPart: False; + DefLengthSet: '''Y'',''N'''; + Category: dtcOther; + ), + ( + Index: dbdtSet; + Name: 'SET'; + HasLength: True; + RequiresLength: True; + HasBinary: False; + HasDefault: True; + LoadPart: False; + DefLengthSet: '''Value A'',''Value B'''; + Category: dtcOther; + ) + ); + + +implementation + + +constructor TSQLiteLib.Create(DllFile, DefaultDll: String); +begin + FWithMultipleCipherFunctions := False; + inherited; +end; + +constructor TSQLiteLib.CreateWithMultipleCipherFunctions(DllFile, DefaultDll: String); +begin + FWithMultipleCipherFunctions := True; + inherited Create(DllFile, DefaultDll); +end; + + +procedure TSQLiteLib.AssignProcedures; +begin + AssignProc(@sqlite3_open, 'sqlite3_open'); + AssignProc(@sqlite3_libversion, 'sqlite3_libversion'); + AssignProc(@sqlite3_close, 'sqlite3_close'); + AssignProc(@sqlite3_db_config, 'sqlite3_db_config'); + AssignProc(@sqlite3_enable_load_extension, 'sqlite3_enable_load_extension'); + AssignProc(@sqlite3_errmsg, 'sqlite3_errmsg'); + AssignProc(@sqlite3_errcode, 'sqlite3_errcode'); + AssignProc(@sqlite3_prepare_v2, 'sqlite3_prepare_v2'); + AssignProc(@sqlite3_prepare_v3, 'sqlite3_prepare_v3'); + AssignProc(@sqlite3_exec, 'sqlite3_exec'); + AssignProc(@sqlite3_finalize, 'sqlite3_finalize'); + AssignProc(@sqlite3_step, 'sqlite3_step'); + AssignProc(@sqlite3_reset, 'sqlite3_reset'); + AssignProc(@sqlite3_total_changes, 'sqlite3_total_changes'); + AssignProc(@sqlite3_column_text, 'sqlite3_column_text'); + AssignProc(@sqlite3_column_count, 'sqlite3_column_count'); + AssignProc(@sqlite3_column_name, 'sqlite3_column_name'); + AssignProc(@sqlite3_column_decltype, 'sqlite3_column_decltype'); + AssignProc(@sqlite3_column_database_name, 'sqlite3_column_database_name'); + AssignProc(@sqlite3_column_table_name, 'sqlite3_column_table_name'); + AssignProc(@sqlite3_column_origin_name, 'sqlite3_column_origin_name'); + AssignProc(@sqlite3_column_type, 'sqlite3_column_type'); + AssignProc(@sqlite3_next_stmt, 'sqlite3_next_stmt'); + AssignProc(@sqlite3_table_column_metadata, 'sqlite3_table_column_metadata'); + AssignProc(@sqlite3_collation_needed, 'sqlite3_collation_needed'); + AssignProc(@sqlite3_create_collation, 'sqlite3_create_collation'); + if FWithMultipleCipherFunctions then begin + // Additionally, for use in Multiple Ciphers library: + AssignProc(@sqlite3_key, 'sqlite3_key', False); + AssignProc(@sqlite3mc_cipher_count, 'sqlite3mc_cipher_count'); + AssignProc(@sqlite3mc_cipher_name, 'sqlite3mc_cipher_name'); + AssignProc(@sqlite3mc_cipher_index, 'sqlite3mc_cipher_index'); + AssignProc(@sqlite3mc_config, 'sqlite3mc_config'); + AssignProc(@sqlite3mc_config_cipher, 'sqlite3mc_config_cipher'); + end; +end; + + +{ TSQLiteProvider } + +function TSQLiteProvider.GetSql(AId: TQueryId): string; +begin + case AId of + qDatabaseDrop: Result := 'DROP DATABASE %s'; + qRenameTable: Result := 'ALTER TABLE %s RENAME TO %s'; + qRenameView: Result := 'ALTER TABLE %s RENAME TO %s'; + qCurrentUserHost: Result := ''; // unsupported + qLikeCompare: Result := '%s LIKE %s'; + qAddColumn: Result := 'ADD COLUMN %s'; + qChangeColumn: Result := ''; // SQLite only supports renaming + qRenameColumn: Result := 'RENAME COLUMN %s TO %s'; + qSessionVariables: Result := 'SELECT null, null'; // Todo: combine "PRAGMA pragma_list" + "PRAGMA a; PRAGMY b; ..."? + qGlobalVariables: Result := 'SHOW GLOBAL VARIABLES'; + qISSchemaCol: Result := '%s_SCHEMA'; + qUSEQuery: Result := ''; + qKillQuery: Result := 'KILL %d'; + qKillProcess: Result := 'KILL %d'; + qFuncLength: Result := 'LENGTH'; + qFuncCeil: Result := 'CEIL'; + qFuncLeft: Result := 'SUBSTR(%s, 1, %d)'; + qFuncNow: Result := 'DATETIME()'; + qFuncLastAutoIncNumber: Result := 'LAST_INSERT_ID()'; + qLockedTables: Result := ''; + qDisableForeignKeyChecks: Result := ''; + qEnableForeignKeyChecks: Result := ''; + qForeignKeyDrop: Result := 'DROP FOREIGN KEY %s'; + qGetTableColumns: Result := 'SELECT * FROM pragma_table_xinfo(%s, %s)'; + // See https://www.sqlite.org/datatype3.html#collation_sequence_examples + qGetCollations: Result := 'SELECT name AS "Collation", '''' AS "Charset", '''' AS "Id", '''' AS "Default", '''' AS "Compiled", ''1'' AS Sortlen from pragma_collation_list'; + qGetCharsets: Result := 'SELECT ''UTF-8'' AS "Charset", ''UTF-8'' AS "Description" '+ + 'UNION SELECT ''UTF-16le'', ''UTF-16 Little Endian'' '+ + 'UNION SELECT ''UTF-16be'', ''UTF-16 Big Endian'''; + qExplain: Result := 'EXPLAIN %s'; + qCastAsText: Result := 'CAST(%s AS CHAR)'; + else Result := inherited; + end; +end; + + +end. \ No newline at end of file diff --git a/source/detours/.gitignore b/source/detours/.gitignore index 38082db5c..ba6c54241 100644 --- a/source/detours/.gitignore +++ b/source/detours/.gitignore @@ -1,57 +1,57 @@ -# Uncomment these types if you want even more clean repository. But be careful. -# It can make harm to an existing project source. Read explanations below. -# -# Resource files are binaries containing manifest, project icon and version info. -# They can not be viewed as text or compared by diff-tools. Consider replacing them with .rc files. -*.res -# -# Type library file (binary). In old Delphi versions it should be stored. -# Since Delphi 2009 it is produced from .ridl file and can safely be ignored. -#*.tlb -# -# Diagram Portfolio file. Used by the diagram editor up to Delphi 7. -# Uncomment this if you are not using diagrams or use newer Delphi version. -#*.ddp -# -# Visual LiveBindings file. Added in Delphi XE2. -# Uncomment this if you are not using LiveBindings Designer. -#*.vlb -# -# Deployment Manager configuration file for your project. Added in Delphi XE2. -# Uncomment this if it is not mobile development and you do not use remote debug feature. -#*.deployproj -# - -# Delphi compiler-generated binaries (safe to delete) -#*.exe -*.dll -*.bpl -*.bpi -*.dcp -*.so -*.apk -*.drc -*.map -*.dres -*.rsm -*.tds -*.dcu -*.lib - -# Delphi autogenerated files (duplicated info) -*.cfg -*Resource.rc - -# Delphi local files (user-specific info) -*.local -*.identcache -*.projdata -*.tvsconfig -*.dsk - -# Delphi history and backups -__history/ -*.~* - -# Castalia statistics file -*.stat +# Uncomment these types if you want even more clean repository. But be careful. +# It can make harm to an existing project source. Read explanations below. +# +# Resource files are binaries containing manifest, project icon and version info. +# They can not be viewed as text or compared by diff-tools. Consider replacing them with .rc files. +*.res +# +# Type library file (binary). In old Delphi versions it should be stored. +# Since Delphi 2009 it is produced from .ridl file and can safely be ignored. +#*.tlb +# +# Diagram Portfolio file. Used by the diagram editor up to Delphi 7. +# Uncomment this if you are not using diagrams or use newer Delphi version. +#*.ddp +# +# Visual LiveBindings file. Added in Delphi XE2. +# Uncomment this if you are not using LiveBindings Designer. +#*.vlb +# +# Deployment Manager configuration file for your project. Added in Delphi XE2. +# Uncomment this if it is not mobile development and you do not use remote debug feature. +#*.deployproj +# + +# Delphi compiler-generated binaries (safe to delete) +#*.exe +*.dll +*.bpl +*.bpi +*.dcp +*.so +*.apk +*.drc +*.map +*.dres +*.rsm +*.tds +*.dcu +*.lib + +# Delphi autogenerated files (duplicated info) +*.cfg +*Resource.rc + +# Delphi local files (user-specific info) +*.local +*.identcache +*.projdata +*.tvsconfig +*.dsk + +# Delphi history and backups +__history/ +*.~* + +# Castalia statistics file +*.stat diff --git a/source/detours/CHANGELOG b/source/detours/CHANGELOG new file mode 100644 index 000000000..fc51fbc25 --- /dev/null +++ b/source/detours/CHANGELOG @@ -0,0 +1,41 @@ +version 2.2(Jun 9, 2020): + +Added support for older Delphi version: Now the minimal supported Delphi version is D7. + +Added support for FPC. + +Added recursive section feature: EnterRecursiveSection/ExitRecursiveSection. + +Added param/tag feature for all InterceptCreate functions. + +Added GetTrampolineParam function to get user param. + +Added GetCreatorThreadIdFromTrampoline function to get thread id that created the hook/trampoline. + +Added detection for non valid trampoline pointer. + +Added unittest. + +Replaced BeginHooks/BeginUnHooks by BeginTransaction. + +Replaced EndHooks/EndUnHooks by EndTransaction. + +Replaced GetNHook by GetHookCount. + +Replaced TDetours by TIntercept/TIntercept + +Fixed many bugs related to MultiBytesNop. + +Fixed wrong displacement value for some branch instructions on x64. + +Fixed wrong offset size on x86 for GetJmpType function. + +Removed v1 compatibility. + +Now the library does not rely on Object. + +Code refactoring. + +Jan 24,2015: + +Added support for vtable patching. + +Added GetNHook/IsHooked support for Interface. + +Jan 20,2015: + +Added support to hook Delphi Interface by name. + +Version2 , Mahdi Safsafi: + +Many bug fix. + +Added new hooking model architecture. + +Added multi hook support. + +Added COM hook support. + +Added instruction maping feature. + +Added hook detecting feature. + +Added BeginHooks/EndHooks. + +Added BeginUnHooks/EndUnHooks. + +Added IDetours interface. + +Added MultiNop instructions support. + +Generate better opcodes. + +Improved support for x64. + +Improved AllocMemAt function. diff --git a/source/detours/Clean.bat b/source/detours/Clean.bat index a3f0c053a..b591ee22c 100644 --- a/source/detours/Clean.bat +++ b/source/detours/Clean.bat @@ -1,35 +1,35 @@ -rem ***************************************** -rem * Delphi CleanUp Batch. * -rem * * -rem * Clean identcache,local,dcu,exe, * -rem * map,drc files. * -rem * Clean hidden __history folder. * -rem * * -rem * Author: Mahdi Safsafi * -rem ***************************************** - -@echo off -Setlocal EnableDelayedExpansion - -Del "*.identcache" /s/q -Del "*.local" /s/q -Del "*.dcu" /s/q -Del "*.exe" /s/q -Del "*.drc" /s/q -Del "*.map" /s/q - -set mustdel=false -For /r %%f in (.) do ( - set "mustdel=false" - if %%~nf==Win32 ( - if exist "%%~ff\Debug\" set "mustdel=true" - if exist "%%~ff\Release\" set "mustdel=true" -) else if %%~nf==Win64 ( - if exist "%%~ff\Debug\" set "mustdel=true" - if exist "%%~ff\Release\" set "mustdel=true" - ) -if %%~nf==__history set "mustdel=true" -if !mustdel!==true ( - if exist "%%~ff" rd /s/q "%%~ff" - ) +rem ***************************************** +rem * Delphi CleanUp Batch. * +rem * * +rem * Clean identcache,local,dcu,exe, * +rem * map,drc files. * +rem * Clean hidden __history folder. * +rem * * +rem * Author: Mahdi Safsafi * +rem ***************************************** + +@echo off +Setlocal EnableDelayedExpansion + +Del "*.identcache" /s/q +Del "*.local" /s/q +Del "*.dcu" /s/q +Del "*.exe" /s/q +Del "*.drc" /s/q +Del "*.map" /s/q + +set mustdel=false +For /r %%f in (.) do ( + set "mustdel=false" + if %%~nf==Win32 ( + if exist "%%~ff\Debug\" set "mustdel=true" + if exist "%%~ff\Release\" set "mustdel=true" +) else if %%~nf==Win64 ( + if exist "%%~ff\Debug\" set "mustdel=true" + if exist "%%~ff\Release\" set "mustdel=true" + ) +if %%~nf==__history set "mustdel=true" +if !mustdel!==true ( + if exist "%%~ff" rd /s/q "%%~ff" + ) ) \ No newline at end of file diff --git a/source/detours/Demo/Delphi/D7/D7.dpr b/source/detours/Demo/Delphi/D7/D7.dpr new file mode 100644 index 000000000..96f3020d7 --- /dev/null +++ b/source/detours/Demo/Delphi/D7/D7.dpr @@ -0,0 +1,13 @@ +program D7; + +uses + Forms, + uMain in 'uMain.pas' {Main}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TMain, Main); + Application.Run; +end. diff --git a/source/detours/Demo/Delphi/D7/D7_Icon.ico b/source/detours/Demo/Delphi/D7/D7_Icon.ico new file mode 100644 index 000000000..cfd8992a5 Binary files /dev/null and b/source/detours/Demo/Delphi/D7/D7_Icon.ico differ diff --git a/source/detours/Demo/DetoursDemo/win32api/Demo1/uMain.dfm b/source/detours/Demo/Delphi/D7/uMain.dfm similarity index 50% rename from source/detours/Demo/DetoursDemo/win32api/Demo1/uMain.dfm rename to source/detours/Demo/Delphi/D7/uMain.dfm index 87fb2f8b2..d4590f559 100644 --- a/source/detours/Demo/DetoursDemo/win32api/Demo1/uMain.dfm +++ b/source/detours/Demo/Delphi/D7/uMain.dfm @@ -1,10 +1,10 @@ object Main: TMain - Left = 0 - Top = 0 + Left = 192 + Top = 125 + Width = 238 + Height = 191 BorderStyle = bsSizeToolWin - Caption = 'Hooking MessageBox' - ClientHeight = 133 - ClientWidth = 188 + Caption = 'Main' Color = clBtnFace Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText @@ -12,33 +12,34 @@ object Main: TMain Font.Name = 'Tahoma' Font.Style = [] OldCreateOrder = False + OnCreate = FormCreate PixelsPerInch = 96 TextHeight = 13 object BtnHook: TButton - Left = 16 + Left = 46 Top = 24 - Width = 153 + Width = 131 Height = 25 - Caption = 'Hook MessageBox' + Caption = 'Hook' TabOrder = 0 OnClick = BtnHookClick end - object BtnUnHook: TButton - Left = 16 - Top = 88 - Width = 153 + object BtnMsgBox: TButton + Left = 46 + Top = 64 + Width = 131 Height = 25 - Caption = 'UnHook MessageBox' + Caption = 'MsgBox' TabOrder = 1 - OnClick = BtnUnHookClick + OnClick = BtnMsgBoxClick end - object BtnTestMsgBox: TButton - Left = 16 - Top = 57 - Width = 153 + object BtnUnhook: TButton + Left = 46 + Top = 104 + Width = 131 Height = 25 - Caption = 'Call MessageBox' + Caption = 'Unhook' TabOrder = 2 - OnClick = BtnTestMsgBoxClick + OnClick = BtnUnhookClick end end diff --git a/source/detours/Demo/Delphi/D7/uMain.pas b/source/detours/Demo/Delphi/D7/uMain.pas new file mode 100644 index 000000000..598b4e818 --- /dev/null +++ b/source/detours/Demo/Delphi/D7/uMain.pas @@ -0,0 +1,80 @@ +unit uMain; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, DDetours; + +type + TMain = class(TForm) + BtnHook: TButton; + BtnMsgBox: TButton; + BtnUnhook: TButton; + procedure BtnHookClick(Sender: TObject); + procedure BtnMsgBoxClick(Sender: TObject); + procedure BtnUnhookClick(Sender: TObject); + procedure FormCreate(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + Main: TMain; + +implementation + +{$R *.dfm} + +type TMessageBox = function (hWnd: HWND; lpText, lpCaption: PChar; uType: UINT): Integer; stdcall; +var TrampolineMessageBox : TMessageBox; + +function InterceptMessageBox(hWnd: HWND; lpText, lpCaption: PChar; uType: UINT): Integer; stdcall; +var + Self: TMain; +begin + Self := GetTrampolineParam(TrampolineMessageBox); + Self.Caption := 'MessageBox hooked !'; + Result := TrampolineMessageBox(hWnd, 'this text was hooked', 'this title was hooked', MB_ICONWARNING); +end; + + +procedure TMain.FormCreate(Sender: TObject); +begin + BtnUnHook.Enabled := False; +end; + +procedure TMain.BtnHookClick(Sender: TObject); +begin + TrampolineMessageBox := InterceptCreate(@MessageBox, @InterceptMessageBox, Self); + BtnUnHook.Enabled := True; + BtnHook.Enabled := False; +end; + +procedure TMain.BtnMsgBoxClick(Sender: TObject); +begin + MessageBox(0, 'text', 'caption', 0); +end; + +procedure TMain.BtnUnHookClick(Sender: TObject); +begin + if Assigned(TrampolineMessageBox) then + begin + InterceptRemove(@TrampolineMessageBox); + TrampolineMessageBox := nil; + BtnHook.Enabled := True; + BtnUnHook.Enabled := False; + end; +end; + +initialization + +finalization + +if Assigned(TrampolineMessageBox) then + InterceptRemove(@TrampolineMessageBox); + +end. + diff --git a/source/detours/Demo/DetoursDemo/MultiHook/Demo1/Demo1.dpr b/source/detours/Demo/Delphi/Demo1/Demo1.dpr similarity index 53% rename from source/detours/Demo/DetoursDemo/MultiHook/Demo1/Demo1.dpr rename to source/detours/Demo/Delphi/Demo1/Demo1.dpr index 7c8ff19dc..ff0595394 100644 --- a/source/detours/Demo/DetoursDemo/MultiHook/Demo1/Demo1.dpr +++ b/source/detours/Demo/Delphi/Demo1/Demo1.dpr @@ -3,9 +3,10 @@ program Demo1; uses Vcl.Forms, uMain in 'uMain.pas' {Main}, - CPUID in '..\..\..\..\Source\CPUID.pas', - DDetours in '..\..\..\..\Source\DDetours.pas', - InstDecode in '..\..\..\..\Source\InstDecode.pas'; + CPUID in '..\..\..\Source\CPUID.pas', + DDetours in '..\..\..\Source\DDetours.pas', + InstDecode in '..\..\..\Source\InstDecode.pas', + LegacyTypes in '..\..\..\Source\LegacyTypes.pas'; {$R *.res} diff --git a/source/detours/Demo/DetoursDemo/COM/Demo1/Demo1.dproj b/source/detours/Demo/Delphi/Demo1/Demo1.dproj similarity index 57% rename from source/detours/Demo/DetoursDemo/COM/Demo1/Demo1.dproj rename to source/detours/Demo/Delphi/Demo1/Demo1.dproj index e57be60d6..f3dd8f019 100644 --- a/source/detours/Demo/DetoursDemo/COM/Demo1/Demo1.dproj +++ b/source/detours/Demo/Delphi/Demo1/Demo1.dproj @@ -1,13 +1,13 @@  - {18E3F860-77E5-45A6-BF0A-445D77BE5AC5} - 18.1 + {F3F06688-F7C7-4A42-B09B-18B38AB06934} + 18.7 VCL Demo1.dpr True Debug - Win64 - 3 + Win32 + 1 Application @@ -39,10 +39,13 @@ Base true + + true + Cfg_2 + true + true + - System;Xml;Data;Datasnap;Web;Soap;Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;$(DCC_Namespace) - $(BDS)\bin\delphi_PROJECTICON.ico - Demo1 .\$(Platform)\$(Config) .\$(Platform)\$(Config) false @@ -50,24 +53,23 @@ false false false + System;Xml;Data;Datasnap;Web;Soap;Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;$(DCC_Namespace) + $(BDS)\bin\delphi_PROJECTICON.ico + $(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_44.png + $(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_150.png + Demo1 - true + DBXSqliteDriver;IndyIPCommon;RESTComponents;bindcompdbx;DBXInterBaseDriver;vcl;IndyIPServer;vclactnband;StyleControls_dxe103Rio;vclFireDAC;IndySystem;tethering;svnui;dsnapcon;FireDACADSDriver;FireDACMSAccDriver;fmxFireDAC;vclimg;TeeDB;FireDAC;vcltouch;vcldb;bindcompfmx;svn;FireDACSqliteDriver;FireDACPgDriver;ibmonitor;inetdb;FMXTee;MyIdePlugin;soaprtl;DbxCommonDriver;FmxTeeUI;ibxpress;fmx;FireDACIBDriver;fmxdae;xmlrtl;soapmidas;ibxbindings;fmxobj;vclwinx;vclib;rtl;Tee;DbxClientDriver;dclAbsDBd26;CustomIPTransport;vcldsnap;dbexpress;IndyCore;vclx;bindcomp;appanalytics;dsnap;FireDACCommon;IndyIPClient;bindcompvcl;RESTBackendComponents;TeeUI;VCLRESTComponents;soapserver;dbxcds;VclSmp;adortl;vclie;bindengine;DBXMySQLDriver;CloudService;dsnapxml;FireDACMySQLDriver;dbrtl;IndyProtocols;inetdbxpress;vclAbsDBd26;FireDACCommonODBC;FireDACCommonDriver;inet;fmxase;$(DCC_UsePackage) Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) - FireDACSqliteDriver;FireDACDSDriver;DBXSqliteDriver;FireDACPgDriver;fmx;IndySystem;TeeDB;tethering;vclib;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;DataSnapServer;DataSnapProviderClient;DBXSybaseASEDriver;DbxCommonDriver;vclimg;dbxcds;DatasnapConnectorsFreePascal;MetropolisUILiveTile;vcldb;vcldsnap;fmxFireDAC;DBXDb2Driver;DBXOracleDriver;CustomIPTransport;vclribbon;dsnap;IndyIPServer;fmxase;vcl;IndyCore;DBXMSSQLDriver;CloudService;IndyIPCommon;FmxTeeUI;FireDACIBDriver;DataSnapFireDAC;FireDACDBXDriver;soapserver;inetdbxpress;dsnapxml;FireDACInfxDriver;FireDACDb2Driver;adortl;FireDACASADriver;bindcompfmx;FireDACODBCDriver;RESTBackendComponents;emsclientfiredac;rtl;dbrtl;DbxClientDriver;FireDACCommon;bindcomp;inetdb;Tee;DBXOdbcDriver;vclFireDAC;xmlrtl;DataSnapNativeClient;ibxpress;svnui;IndyProtocols;DBXMySQLDriver;FireDACCommonDriver;bindcompdbx;bindengine;vclactnband;FMXTee;soaprtl;TeeUI;bindcompvcl;vclie;FireDACADSDriver;vcltouch;emsclient;VCLRESTComponents;FireDAC;DBXInformixDriver;FireDACMSSQLDriver;Intraweb;VclSmp;DataSnapConnectors;DataSnapServerMidas;DBXFirebirdDriver;dsnapcon;inet;fmxobj;FireDACMySQLDriver;soapmidas;vclx;svn;DBXSybaseASADriver;FireDACOracleDriver;fmxdae;RESTComponents;dbexpress;FireDACMSAccDriver;DataSnapIndy10ServerTransport;IndyIPClient;$(DCC_UsePackage) - 1033 + Debug true - CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProgramID=com.embarcadero.$(MSBuildProjectName);ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments= + 1033 $(BDS)\bin\default_app.manifest - true - Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;$(DCC_Namespace) - FireDACSqliteDriver;FireDACDSDriver;DBXSqliteDriver;FireDACPgDriver;fmx;IndySystem;TeeDB;tethering;vclib;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;DataSnapServer;DataSnapProviderClient;DBXSybaseASEDriver;DbxCommonDriver;vclimg;dbxcds;DatasnapConnectorsFreePascal;MetropolisUILiveTile;vcldb;vcldsnap;fmxFireDAC;DBXDb2Driver;DBXOracleDriver;CustomIPTransport;vclribbon;dsnap;IndyIPServer;fmxase;vcl;IndyCore;DBXMSSQLDriver;CloudService;IndyIPCommon;FmxTeeUI;FireDACIBDriver;DataSnapFireDAC;FireDACDBXDriver;soapserver;inetdbxpress;dsnapxml;FireDACInfxDriver;FireDACDb2Driver;adortl;FireDACASADriver;bindcompfmx;FireDACODBCDriver;RESTBackendComponents;emsclientfiredac;rtl;dbrtl;DbxClientDriver;FireDACCommon;bindcomp;inetdb;Tee;DBXOdbcDriver;vclFireDAC;xmlrtl;DataSnapNativeClient;ibxpress;IndyProtocols;DBXMySQLDriver;FireDACCommonDriver;bindcompdbx;bindengine;vclactnband;FMXTee;soaprtl;TeeUI;bindcompvcl;vclie;FireDACADSDriver;vcltouch;emsclient;VCLRESTComponents;FireDAC;DBXInformixDriver;FireDACMSSQLDriver;Intraweb;VclSmp;DataSnapConnectors;DataSnapServerMidas;DBXFirebirdDriver;dsnapcon;inet;fmxobj;FireDACMySQLDriver;soapmidas;vclx;DBXSybaseASADriver;FireDACOracleDriver;fmxdae;RESTComponents;dbexpress;FireDACMSAccDriver;DataSnapIndy10ServerTransport;IndyIPClient;$(DCC_UsePackage) - 1033 - true - CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= - $(BDS)\bin\default_app.manifest + DBXSqliteDriver;IndyIPCommon;RESTComponents;bindcompdbx;DBXInterBaseDriver;vcl;IndyIPServer;vclactnband;StyleControls_dxe103Rio;vclFireDAC;IndySystem;tethering;dsnapcon;FireDACADSDriver;FireDACMSAccDriver;fmxFireDAC;vclimg;TeeDB;FireDAC;vcltouch;vcldb;bindcompfmx;FireDACSqliteDriver;FireDACPgDriver;ibmonitor;inetdb;FMXTee;soaprtl;DbxCommonDriver;FmxTeeUI;ibxpress;fmx;FireDACIBDriver;fmxdae;xmlrtl;soapmidas;ibxbindings;fmxobj;vclwinx;vclib;rtl;Tee;DbxClientDriver;CustomIPTransport;vcldsnap;dbexpress;IndyCore;vclx;bindcomp;appanalytics;dsnap;FireDACCommon;IndyIPClient;bindcompvcl;RESTBackendComponents;TeeUI;VCLRESTComponents;soapserver;dbxcds;VclSmp;adortl;vclie;bindengine;DBXMySQLDriver;CloudService;dsnapxml;FireDACMySQLDriver;dbrtl;IndyProtocols;inetdbxpress;FireDACCommonODBC;FireDACCommonDriver;inet;fmxase;$(DCC_UsePackage) DEBUG;$(DCC_Define) @@ -79,6 +81,8 @@ false + true + PerMonitorV2 false @@ -86,6 +90,10 @@ 0 0 + + true + PerMonitorV2 + MainSource @@ -94,9 +102,10 @@
Main
dfm - - - + + + + Cfg_2 Base @@ -119,37 +128,23 @@ - - - Demo1.exe - true - - Demo1.exe true - - - Demo1.rsm - true - - - - - 1 - - + + 1 - - - Contents\Resources + Contents\MacOS 1 + + 0 + @@ -157,22 +152,21 @@ 1 - + - res\drawable-xxhdpi + res\xml 1 - - - Contents\MacOS - 0 - - + + + library\lib\armeabi-v7a 1 - - Contents\MacOS + + + + library\lib\armeabi 1 @@ -182,117 +176,133 @@ 1 - - - 1 - - - 1 - - + + + library\lib\armeabi-v7a 1 - - - 1 - - - 1 - - - 0 - - + + + res\drawable 1 - - Contents\MacOS + + + + res\values 1 + + - library\lib\armeabi-v7a + res\values-v21 1 - + + + + res\values 1 - - - 0 - - - Contents\MacOS + + + res\drawable 1 - .framework - - + + + res\drawable-xxhdpi 1 - + + + + res\drawable-ldpi 1 - + + + + res\drawable-mdpi 1 - - - - ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF + + + res\drawable-hdpi 1 - - ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF + + + + res\drawable-xhdpi 1 - - + + + res\drawable-mdpi 1 - + + + + res\drawable-hdpi 1 - + + + + res\drawable-xhdpi 1 - - + + + res\drawable-xxhdpi 1 - + + + + res\drawable-xxxhdpi 1 - + + + + res\drawable-small 1 - - + + + res\drawable-normal 1 - + + + + res\drawable-large 1 - + + + + res\drawable-xlarge 1 - + - library\lib\armeabi + res\values 1 - - 0 - 1 @@ -300,235 +310,531 @@ Contents\MacOS 1 - - - - 1 + + 0 - + + + + Contents\MacOS 1 + .framework - + + Contents\MacOS 1 + .framework - - - - res\drawable-normal - 1 + + 0 - - - res\drawable-xhdpi + + 1 + .dylib - - - - res\drawable-large + 1 + .dylib - - 1 + .dylib - + + Contents\MacOS 1 + .dylib - + + Contents\MacOS 1 + .dylib - - - - ..\ - 1 + + 0 + .dll;.bpl + + - ..\ 1 + .dylib - - - - library\lib\armeabi-v7a + 1 + .dylib - - - - res\drawable-hdpi + 1 + .dylib - - - Contents + Contents\MacOS 1 + .dylib - - - - ..\ + + Contents\MacOS 1 + .dylib - - - + + 0 + .bpl + + + + + 0 + + + 0 + + + 0 + + + 0 + + + Contents\Resources\StartUp\ + 0 + + + Contents\Resources\StartUp\ + 0 + + + 0 + + + + 1 1 + + 1 + + + 1 + + 1 + + + 1 + - - - res\values + + + 1 + + + 1 + + 1 - - - res\drawable-small + + + 1 + + + 1 + + 1 - - - res\drawable + + + 1 + + + 1 + + 1 - + + + 1 + + + 1 + 1 + + + + 1 + 1 + + 1 + + + 1 + + 1 + + + 1 + - - + + + 1 + + + 1 + + 1 - - - res\drawable + + + 1 + + + 1 + + 1 - - - 0 + + + 1 - 0 + 1 - - Contents\Resources\StartUp\ - 0 + + 1 + + - 0 + 1 - - 0 + + 1 - 0 + 1 - - - library\lib\armeabi-v7a + + + 1 + + + 1 + + 1 - - - 0 - .bpl + + + 1 1 - .dylib - - Contents\MacOS + 1 - .dylib + + 1 - .dylib + + + 1 1 - .dylib - - - res\drawable-mdpi + + + 1 + + + 1 + + 1 - - - res\drawable-xlarge + + + 1 + + + 1 + + 1 - + + + 1 + + + 1 + + + 1 + + + + + 1 + + + 1 + + + 1 + + + + + 1 + + + 1 + + + 1 + + + + + 1 + + + 1 + + + 1 + + + + + 1 + + + 1 + + + 1 + + + + + 1 + + + 1 + + + 1 + + + + + 1 + + + 1 + + + 1 + + + - res\drawable-ldpi 1 - - - 0 - .dll;.bpl + + + ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF + 1 + ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF 1 - .dylib + + + + 1 + + + 1 + + + + + ..\ + 1 + + + ..\ + 1 + + + + + 1 + + + 1 + + + 1 + + + + + 1 + + + 1 + + + 1 + + + + + ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF + 1 + + + - Contents\MacOS + ..\ + 1 + + + ..\ + 1 + + + + + Contents + 1 + + + Contents + 1 + + + + + Contents\Resources + 1 + + + Contents\Resources + 1 + + + + + library\lib\armeabi-v7a 1 - .dylib 1 - .dylib + + + 1 1 - .dylib + + + 1 + + + Contents\MacOS + 1 + + + Contents\MacOS + 1 + + + 0 + + + + + 1 + + + 1 + + + + + Assets + 1 + + + Assets + 1 + + + + + Assets + 1 + + + Assets + 1 - + - + + True - True + False 12 diff --git a/source/detours/Demo/DetoursDemo/Delphi/Interfaces/Demo1/uMain.dfm b/source/detours/Demo/Delphi/Demo1/uMain.dfm similarity index 55% rename from source/detours/Demo/DetoursDemo/Delphi/Interfaces/Demo1/uMain.dfm rename to source/detours/Demo/Delphi/Demo1/uMain.dfm index f7ca056ae..20ca59c87 100644 --- a/source/detours/Demo/DetoursDemo/Delphi/Interfaces/Demo1/uMain.dfm +++ b/source/detours/Demo/Delphi/Demo1/uMain.dfm @@ -1,10 +1,10 @@ object Main: TMain Left = 0 Top = 0 - BorderStyle = bsSizeToolWin - Caption = 'Hooking Method in interface' - ClientHeight = 133 - ClientWidth = 298 + BorderStyle = bsToolWindow + Caption = 'Main' + ClientHeight = 134 + ClientWidth = 257 Color = clBtnFace Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText @@ -12,32 +12,33 @@ object Main: TMain Font.Name = 'Tahoma' Font.Style = [] OldCreateOrder = False + OnCreate = FormCreate PixelsPerInch = 96 TextHeight = 13 - object BtnCallShowMsg: TButton - Left = 32 - Top = 24 - Width = 241 + object BtnHook: TButton + Left = 48 + Top = 16 + Width = 161 Height = 25 - Caption = 'Call ShowMsg' + Caption = 'Hook' TabOrder = 0 - OnClick = BtnCallShowMsgClick + OnClick = BtnHookClick end - object BtnHook: TButton - Left = 32 + object BtnMsgBox: TButton + Left = 48 Top = 55 - Width = 241 + Width = 161 Height = 25 - Caption = 'Hook ShowMsg' + Caption = 'MessageBox' TabOrder = 1 - OnClick = BtnHookClick + OnClick = BtnMsgBoxClick end object BtnUnHook: TButton - Left = 32 - Top = 86 - Width = 241 + Left = 48 + Top = 91 + Width = 161 Height = 25 - Caption = 'UnHook ShowMsg ' + Caption = 'Unhook' TabOrder = 2 OnClick = BtnUnHookClick end diff --git a/source/detours/Demo/Delphi/Demo1/uMain.pas b/source/detours/Demo/Delphi/Demo1/uMain.pas new file mode 100644 index 000000000..d6b5ce3e3 --- /dev/null +++ b/source/detours/Demo/Delphi/Demo1/uMain.pas @@ -0,0 +1,81 @@ +unit uMain; + +interface + +uses + Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics, + Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, DDetours; + +type + TMain = class(TForm) + BtnHook: TButton; + BtnMsgBox: TButton; + BtnUnHook: TButton; + procedure BtnHookClick(Sender: TObject); + procedure BtnUnHookClick(Sender: TObject); + procedure BtnMsgBoxClick(Sender: TObject); + procedure FormCreate(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + Main: TMain; + +implementation + +{$R *.dfm} + +type + TMessageBox = function(hWnd: hWnd; lpText, lpCaption: LPCWSTR; uType: UINT): Integer; stdcall; + +var + TrampolineMessageBox: TMessageBox = nil; + +function InterceptMessageBox(hWnd: hWnd; lpText, lpCaption: LPCWSTR; uType: UINT): Integer; stdcall; +var + Self: TMain; +begin + Self := GetTrampolineParam(TrampolineMessageBox); + Self.Caption := 'MessageBox hooked !'; + Result := TrampolineMessageBox(hWnd, 'this text was hooked', 'this title was hooked', MB_ICONWARNING); +end; + +procedure TMain.FormCreate(Sender: TObject); +begin + BtnUnHook.Enabled := False; +end; + +procedure TMain.BtnHookClick(Sender: TObject); +begin + TrampolineMessageBox := InterceptCreate(@MessageBox, @InterceptMessageBox, Self); + BtnUnHook.Enabled := True; + BtnHook.Enabled := False; +end; + +procedure TMain.BtnMsgBoxClick(Sender: TObject); +begin + MessageBox(0, 'text', 'caption', 0); +end; + +procedure TMain.BtnUnHookClick(Sender: TObject); +begin + if Assigned(TrampolineMessageBox) then + begin + InterceptRemove(@TrampolineMessageBox); + TrampolineMessageBox := nil; + BtnHook.Enabled := True; + BtnUnHook.Enabled := False; + end; +end; + +initialization + +finalization + +if Assigned(TrampolineMessageBox) then + InterceptRemove(@TrampolineMessageBox); + +end. diff --git a/source/detours/Demo/DetoursDemo/COM/Demo1/Demo1.dpr b/source/detours/Demo/DetoursDemo/COM/Demo1/Demo1.dpr deleted file mode 100644 index 7b1c4b71d..000000000 --- a/source/detours/Demo/DetoursDemo/COM/Demo1/Demo1.dpr +++ /dev/null @@ -1,18 +0,0 @@ -// JCL_DEBUG_EXPERT_GENERATEJDBG OFF -program Demo1; - -uses - Vcl.Forms, - uMain in 'uMain.pas' {Main}, - CPUID in '..\..\..\..\Source\CPUID.pas', - DDetours in '..\..\..\..\Source\DDetours.pas', - InstDecode in '..\..\..\..\Source\InstDecode.pas'; - -{$R *.res} - -begin - Application.Initialize; - Application.MainFormOnTaskbar := True; - Application.CreateForm(TMain, Main); - Application.Run; -end. diff --git a/source/detours/Demo/DetoursDemo/COM/Demo1/uMain.dfm b/source/detours/Demo/DetoursDemo/COM/Demo1/uMain.dfm deleted file mode 100644 index f69a80af9..000000000 --- a/source/detours/Demo/DetoursDemo/COM/Demo1/uMain.dfm +++ /dev/null @@ -1,54 +0,0 @@ -object Main: TMain - Left = 0 - Top = 0 - BorderStyle = bsSizeToolWin - Caption = 'Hooking IFileOpenDialog.Show Method' - ClientHeight = 196 - ClientWidth = 447 - Color = clBtnFace - Font.Charset = DEFAULT_CHARSET - Font.Color = clWindowText - Font.Height = -11 - Font.Name = 'Tahoma' - Font.Style = [] - OldCreateOrder = False - PixelsPerInch = 96 - TextHeight = 13 - object BtnOpenDialog: TButton - Left = 304 - Top = 97 - Width = 121 - Height = 25 - Caption = 'Open File Dialog' - TabOrder = 0 - OnClick = BtnOpenDialogClick - end - object MemLog: TMemo - Left = 0 - Top = 0 - Width = 447 - Height = 81 - Align = alTop - Lines.Strings = ( - 'MemLog') - TabOrder = 1 - end - object BtnEnableHook: TButton - Left = 304 - Top = 128 - Width = 121 - Height = 25 - Caption = 'Enable Hook' - TabOrder = 2 - OnClick = BtnEnableHookClick - end - object BtnDisableHook: TButton - Left = 304 - Top = 159 - Width = 121 - Height = 25 - Caption = 'Disable Hook' - TabOrder = 3 - OnClick = BtnDisableHookClick - end -end diff --git a/source/detours/Demo/DetoursDemo/COM/Demo1/uMain.pas b/source/detours/Demo/DetoursDemo/COM/Demo1/uMain.pas deleted file mode 100644 index e440045e7..000000000 --- a/source/detours/Demo/DetoursDemo/COM/Demo1/uMain.pas +++ /dev/null @@ -1,78 +0,0 @@ -unit uMain; - -interface - -uses - Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics, - Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, DDetours; - -type - TMain = class(TForm) - BtnOpenDialog: TButton; - MemLog: TMemo; - BtnEnableHook: TButton; - BtnDisableHook: TButton; - procedure BtnOpenDialogClick(Sender: TObject); - procedure BtnEnableHookClick(Sender: TObject); - procedure BtnDisableHookClick(Sender: TObject); - private - { Private declarations } - public - { Public declarations } - end; - -var - Main: TMain; - -implementation - -uses ShlObj, ComObj; -{$R *.dfm} - -var - Trampoline_FileOpenDialog_Show: function(const Self; hwndParent: HWND): HRESULT; stdcall; - Trampoline_FileOpenDialog_SetTitle: function(const Self; pszTitle: LPCWSTR): HRESULT; stdcall; - -function FileOpenDialog_SetTitle_Hook(const Self; pszTitle: LPCWSTR): HRESULT; stdcall; -begin - Result := Trampoline_FileOpenDialog_SetTitle(Self, 'Hooked'); -end; - -function FileOpenDialog_Show_Hook(const Self; hwndParent: HWND): HRESULT; stdcall; -begin - Main.MemLog.Lines.Add('Execution FileOpenDialog.Show ..'); - Result := Trampoline_FileOpenDialog_Show(Self, hwndParent); -end; - -var - FileOpenDialog: IFileOpenDialog; - -procedure TMain.BtnOpenDialogClick(Sender: TObject); -begin - MemLog.Clear; - FileOpenDialog.SetTitle('Open..'); - FileOpenDialog.Show(Handle); -end; - -procedure TMain.BtnEnableHookClick(Sender: TObject); -begin - if not Assigned(Trampoline_FileOpenDialog_Show) then - @Trampoline_FileOpenDialog_Show := InterceptCreate(FileOpenDialog, 3, @FileOpenDialog_Show_Hook); - Trampoline_FileOpenDialog_SetTitle := InterceptCreate(FileOpenDialog, 17, @FileOpenDialog_SetTitle_Hook); -end; - -procedure TMain.BtnDisableHookClick(Sender: TObject); -begin - if Assigned(Trampoline_FileOpenDialog_Show) then - begin - InterceptRemove(@Trampoline_FileOpenDialog_Show); - Trampoline_FileOpenDialog_Show := nil; - end; - InterceptRemove(@Trampoline_FileOpenDialog_SetTitle) -end; - -initialization - -FileOpenDialog := CreateComObject(CLSID_FileOpenDialog) as IFileOpenDialog; - -end. diff --git a/source/detours/Demo/DetoursDemo/Delphi/Hook_Overloaded_Method/Hook_Overloaded_Method.dpr b/source/detours/Demo/DetoursDemo/Delphi/Hook_Overloaded_Method/Hook_Overloaded_Method.dpr deleted file mode 100644 index c47f73672..000000000 --- a/source/detours/Demo/DetoursDemo/Delphi/Hook_Overloaded_Method/Hook_Overloaded_Method.dpr +++ /dev/null @@ -1,47 +0,0 @@ -program Hook_Overloaded_Method; - -{$APPTYPE CONSOLE} -{$R *.res} - -uses - System.SysUtils, - CPUID in '..\..\..\..\Source\CPUID.pas', - DDetours in '..\..\..\..\Source\DDetours.pas', - InstDecode in '..\..\..\..\Source\InstDecode.pas'; - -type - TShowMsg = procedure(Value: Integer); - -var - - TrampoShowMsg: TShowMsg; - { When hooking overloaded method , - Delphi does not reconize the desired method . - So we need to use this trick! - } - MyMethodPtr: TShowMsg; - -procedure ShowMsg(const S: String); overload; -begin - Writeln(S); -end; - -procedure ShowMsg(Value: Integer); overload; -begin - Writeln(Value); -end; - -procedure ShowMsgHooked(Value: Integer); -begin - Writeln('Method hooked successfully!'); - TrampoShowMsg(Value + 1); -end; - -begin - MyMethodPtr := ShowMsg; - @TrampoShowMsg := InterceptCreate(@MyMethodPtr, @ShowMsgHooked); - ShowMsg('Hi'); - ShowMsg(2015); - ReadLn; - -end. diff --git a/source/detours/Demo/DetoursDemo/Delphi/Interfaces/Demo1/Demo1.dpr b/source/detours/Demo/DetoursDemo/Delphi/Interfaces/Demo1/Demo1.dpr deleted file mode 100644 index 6044c216b..000000000 --- a/source/detours/Demo/DetoursDemo/Delphi/Interfaces/Demo1/Demo1.dpr +++ /dev/null @@ -1,18 +0,0 @@ -// JCL_DEBUG_EXPERT_GENERATEJDBG OFF -program Demo1; - -uses - Vcl.Forms, - uMain in 'uMain.pas' {Main}, - CPUID in '..\..\..\..\..\Source\CPUID.pas', - DDetours in '..\..\..\..\..\Source\DDetours.pas', - InstDecode in '..\..\..\..\..\Source\InstDecode.pas'; - -{$R *.res} - -begin - Application.Initialize; - Application.MainFormOnTaskbar := True; - Application.CreateForm(TMain, Main); - Application.Run; -end. diff --git a/source/detours/Demo/DetoursDemo/Delphi/Interfaces/Demo1/Demo1.dproj b/source/detours/Demo/DetoursDemo/Delphi/Interfaces/Demo1/Demo1.dproj deleted file mode 100644 index 5fc7f47ad..000000000 --- a/source/detours/Demo/DetoursDemo/Delphi/Interfaces/Demo1/Demo1.dproj +++ /dev/null @@ -1,521 +0,0 @@ - - - {A523E817-0A23-4476-91C8-42FA45FF0F64} - 18.1 - VCL - Demo1.dpr - True - Debug - Win32 - 1 - Application - - - true - - - true - Base - true - - - true - Base - true - - - true - Base - true - - - true - Cfg_1 - true - true - - - true - Base - true - - - System;Xml;Data;Datasnap;Web;Soap;Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;$(DCC_Namespace) - Demo1 - $(BDS)\bin\delphi_PROJECTICON.ico - .\$(Platform)\$(Config) - .\$(Platform)\$(Config) - false - false - false - false - false - - - true - FireDACSqliteDriver;FireDACDSDriver;DBXSqliteDriver;FireDACPgDriver;fmx;IndySystem;TeeDB;tethering;vclib;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;DataSnapServer;DataSnapProviderClient;DBXSybaseASEDriver;DbxCommonDriver;vclimg;dbxcds;DatasnapConnectorsFreePascal;MetropolisUILiveTile;vcldb;vcldsnap;fmxFireDAC;DBXDb2Driver;DBXOracleDriver;CustomIPTransport;vclribbon;dsnap;IndyIPServer;fmxase;vcl;IndyCore;DBXMSSQLDriver;CloudService;IndyIPCommon;FmxTeeUI;FireDACIBDriver;DataSnapFireDAC;FireDACDBXDriver;soapserver;inetdbxpress;dsnapxml;FireDACInfxDriver;FireDACDb2Driver;adortl;FireDACASADriver;bindcompfmx;FireDACODBCDriver;RESTBackendComponents;emsclientfiredac;rtl;dbrtl;DbxClientDriver;FireDACCommon;bindcomp;inetdb;Tee;DBXOdbcDriver;vclFireDAC;xmlrtl;DataSnapNativeClient;ibxpress;svnui;IndyProtocols;DBXMySQLDriver;FireDACCommonDriver;bindcompdbx;bindengine;vclactnband;FMXTee;soaprtl;TeeUI;bindcompvcl;vclie;FireDACADSDriver;vcltouch;emsclient;VCLRESTComponents;FireDAC;DBXInformixDriver;FireDACMSSQLDriver;Intraweb;VclSmp;DataSnapConnectors;DataSnapServerMidas;DBXFirebirdDriver;dsnapcon;inet;fmxobj;FireDACMySQLDriver;soapmidas;vclx;svn;DBXSybaseASADriver;FireDACOracleDriver;fmxdae;RESTComponents;dbexpress;FireDACMSAccDriver;DataSnapIndy10ServerTransport;IndyIPClient;$(DCC_UsePackage) - 1033 - true - CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= - $(BDS)\bin\default_app.manifest - Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) - - - FireDACSqliteDriver;FireDACDSDriver;DBXSqliteDriver;FireDACPgDriver;fmx;IndySystem;TeeDB;tethering;vclib;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;DataSnapServer;DataSnapProviderClient;DBXSybaseASEDriver;DbxCommonDriver;vclimg;dbxcds;DatasnapConnectorsFreePascal;MetropolisUILiveTile;vcldb;vcldsnap;fmxFireDAC;DBXDb2Driver;DBXOracleDriver;CustomIPTransport;vclribbon;dsnap;IndyIPServer;fmxase;vcl;IndyCore;DBXMSSQLDriver;CloudService;IndyIPCommon;FmxTeeUI;FireDACIBDriver;DataSnapFireDAC;FireDACDBXDriver;soapserver;inetdbxpress;dsnapxml;FireDACInfxDriver;FireDACDb2Driver;adortl;FireDACASADriver;bindcompfmx;FireDACODBCDriver;RESTBackendComponents;emsclientfiredac;rtl;dbrtl;DbxClientDriver;FireDACCommon;bindcomp;inetdb;Tee;DBXOdbcDriver;vclFireDAC;xmlrtl;DataSnapNativeClient;ibxpress;IndyProtocols;DBXMySQLDriver;FireDACCommonDriver;bindcompdbx;bindengine;vclactnband;FMXTee;soaprtl;TeeUI;bindcompvcl;vclie;FireDACADSDriver;vcltouch;emsclient;VCLRESTComponents;FireDAC;DBXInformixDriver;FireDACMSSQLDriver;Intraweb;VclSmp;DataSnapConnectors;DataSnapServerMidas;DBXFirebirdDriver;dsnapcon;inet;fmxobj;FireDACMySQLDriver;soapmidas;vclx;DBXSybaseASADriver;FireDACOracleDriver;fmxdae;RESTComponents;dbexpress;FireDACMSAccDriver;DataSnapIndy10ServerTransport;IndyIPClient;$(DCC_UsePackage) - - - DEBUG;$(DCC_Define) - true - false - true - true - true - - - false - - - false - RELEASE;$(DCC_Define) - 0 - 0 - - - - MainSource - - -
Main
- dfm - - - - - - Cfg_2 - Base - - - Base - - - Cfg_1 - Base - - - - Delphi.Personality.12 - Application - - - - Demo1.dpr - - - - - - Demo1.exe - true - - - - - 1 - - - 1 - - - - - Contents\Resources - 1 - - - - - classes - 1 - - - - - res\drawable-xxhdpi - 1 - - - - - Contents\MacOS - 0 - - - 1 - - - Contents\MacOS - 1 - - - - - library\lib\mips - 1 - - - - - 1 - - - 1 - - - 1 - - - - - 1 - - - 1 - - - 0 - - - 1 - - - Contents\MacOS - 1 - - - library\lib\armeabi-v7a - 1 - - - 1 - - - - - 0 - - - Contents\MacOS - 1 - .framework - - - - - 1 - - - 1 - - - 1 - - - - - - ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF - 1 - - - ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF - 1 - - - - - 1 - - - 1 - - - 1 - - - - - 1 - - - 1 - - - 1 - - - - - 1 - - - 1 - - - 1 - - - - - library\lib\armeabi - 1 - - - - - 0 - - - 1 - - - Contents\MacOS - 1 - - - - - 1 - - - 1 - - - 1 - - - - - res\drawable-normal - 1 - - - - - res\drawable-xhdpi - 1 - - - - - res\drawable-large - 1 - - - - - 1 - - - 1 - - - 1 - - - - - ..\ - 1 - - - ..\ - 1 - - - - - library\lib\armeabi-v7a - 1 - - - - - res\drawable-hdpi - 1 - - - - - Contents - 1 - - - - - ..\ - 1 - - - - - 1 - - - 1 - - - 1 - - - - - res\values - 1 - - - - - res\drawable-small - 1 - - - - - res\drawable - 1 - - - - - 1 - - - 1 - - - 1 - - - - - 1 - - - - - res\drawable - 1 - - - - - 0 - - - 0 - - - Contents\Resources\StartUp\ - 0 - - - 0 - - - 0 - - - 0 - - - - - library\lib\armeabi-v7a - 1 - - - - - 0 - .bpl - - - 1 - .dylib - - - Contents\MacOS - 1 - .dylib - - - 1 - .dylib - - - 1 - .dylib - - - - - res\drawable-mdpi - 1 - - - - - res\drawable-xlarge - 1 - - - - - res\drawable-ldpi - 1 - - - - - 0 - .dll;.bpl - - - 1 - .dylib - - - Contents\MacOS - 1 - .dylib - - - 1 - .dylib - - - 1 - .dylib - - - - - - - - - - - - - True - False - - - 12 - - - - - diff --git a/source/detours/Demo/DetoursDemo/Delphi/Interfaces/Demo1/uMain.pas b/source/detours/Demo/DetoursDemo/Delphi/Interfaces/Demo1/uMain.pas deleted file mode 100644 index a0b194a17..000000000 --- a/source/detours/Demo/DetoursDemo/Delphi/Interfaces/Demo1/uMain.pas +++ /dev/null @@ -1,81 +0,0 @@ -unit uMain; - -interface - -uses - Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics, - Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, DDetours; - -type - TMain = class(TForm) - BtnCallShowMsg: TButton; - BtnHook: TButton; - BtnUnHook: TButton; - procedure BtnCallShowMsgClick(Sender: TObject); - procedure BtnHookClick(Sender: TObject); - procedure BtnUnHookClick(Sender: TObject); - private - { Private declarations } - public - { Public declarations } - end; - -type - IMyInterface = Interface - procedure ShowMsg(const Msg: String); - End; - - TMyObject = class(TInterfacedObject, IMyInterface) - public - procedure ShowMsg(const Msg: String); - end; - -var - Main: TMain; - FMyInterface: IMyInterface; - -implementation - -{$R *.dfm} - -var - TrampolineShowMsg: procedure(const Self; const Msg: String) = nil; - -procedure TMain.BtnUnHookClick(Sender: TObject); -begin - if Assigned(TrampolineShowMsg) then - begin - InterceptRemove(@TrampolineShowMsg); - TrampolineShowMsg := nil; - end; -end; - -procedure TMain.BtnCallShowMsgClick(Sender: TObject); -begin - FMyInterface.ShowMsg('This is a test !'); -end; - -procedure InterceptShowMsg(const Self; const Msg: String); -begin - TrampolineShowMsg(Self, 'Hooked'); -end; -{ TMyObject } - -procedure TMyObject.ShowMsg(const Msg: String); -var - S: String; -begin - S := 'Your Message : ' + Msg; - ShowMessage(S); -end; - -procedure TMain.BtnHookClick(Sender: TObject); -begin - @TrampolineShowMsg := InterceptCreate(FMyInterface, 3, @InterceptShowMsg); -end; - -initialization - -FMyInterface := TMyObject.Create; - -end. diff --git a/source/detours/Demo/DetoursDemo/Delphi/Objects/Demo1/Demo1.dpr b/source/detours/Demo/DetoursDemo/Delphi/Objects/Demo1/Demo1.dpr deleted file mode 100644 index 6044c216b..000000000 --- a/source/detours/Demo/DetoursDemo/Delphi/Objects/Demo1/Demo1.dpr +++ /dev/null @@ -1,18 +0,0 @@ -// JCL_DEBUG_EXPERT_GENERATEJDBG OFF -program Demo1; - -uses - Vcl.Forms, - uMain in 'uMain.pas' {Main}, - CPUID in '..\..\..\..\..\Source\CPUID.pas', - DDetours in '..\..\..\..\..\Source\DDetours.pas', - InstDecode in '..\..\..\..\..\Source\InstDecode.pas'; - -{$R *.res} - -begin - Application.Initialize; - Application.MainFormOnTaskbar := True; - Application.CreateForm(TMain, Main); - Application.Run; -end. diff --git a/source/detours/Demo/DetoursDemo/Delphi/Objects/Demo1/Demo1.dproj b/source/detours/Demo/DetoursDemo/Delphi/Objects/Demo1/Demo1.dproj deleted file mode 100644 index 7918447cb..000000000 --- a/source/detours/Demo/DetoursDemo/Delphi/Objects/Demo1/Demo1.dproj +++ /dev/null @@ -1,521 +0,0 @@ - - - {F786E6F9-BE54-4103-ADFF-11BC6C8629F0} - 18.1 - VCL - Demo1.dpr - True - Debug - Win32 - 1 - Application - - - true - - - true - Base - true - - - true - Base - true - - - true - Base - true - - - true - Cfg_1 - true - true - - - true - Base - true - - - System;Xml;Data;Datasnap;Web;Soap;Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;$(DCC_Namespace) - Demo1 - $(BDS)\bin\delphi_PROJECTICON.ico - .\$(Platform)\$(Config) - .\$(Platform)\$(Config) - false - false - false - false - false - - - true - FireDACSqliteDriver;FireDACDSDriver;DBXSqliteDriver;FireDACPgDriver;fmx;IndySystem;TeeDB;tethering;vclib;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;DataSnapServer;DataSnapProviderClient;DBXSybaseASEDriver;DbxCommonDriver;vclimg;dbxcds;DatasnapConnectorsFreePascal;MetropolisUILiveTile;vcldb;vcldsnap;fmxFireDAC;DBXDb2Driver;DBXOracleDriver;CustomIPTransport;vclribbon;dsnap;IndyIPServer;fmxase;vcl;IndyCore;DBXMSSQLDriver;CloudService;IndyIPCommon;FmxTeeUI;FireDACIBDriver;DataSnapFireDAC;FireDACDBXDriver;soapserver;inetdbxpress;dsnapxml;FireDACInfxDriver;FireDACDb2Driver;adortl;FireDACASADriver;bindcompfmx;FireDACODBCDriver;RESTBackendComponents;emsclientfiredac;rtl;dbrtl;DbxClientDriver;FireDACCommon;bindcomp;inetdb;Tee;DBXOdbcDriver;vclFireDAC;xmlrtl;DataSnapNativeClient;ibxpress;svnui;IndyProtocols;DBXMySQLDriver;FireDACCommonDriver;bindcompdbx;bindengine;vclactnband;FMXTee;soaprtl;TeeUI;bindcompvcl;vclie;FireDACADSDriver;vcltouch;emsclient;VCLRESTComponents;FireDAC;DBXInformixDriver;FireDACMSSQLDriver;Intraweb;VclSmp;DataSnapConnectors;DataSnapServerMidas;DBXFirebirdDriver;dsnapcon;inet;fmxobj;FireDACMySQLDriver;soapmidas;vclx;svn;DBXSybaseASADriver;FireDACOracleDriver;fmxdae;RESTComponents;dbexpress;FireDACMSAccDriver;DataSnapIndy10ServerTransport;IndyIPClient;$(DCC_UsePackage) - 1033 - true - CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= - $(BDS)\bin\default_app.manifest - Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) - - - FireDACSqliteDriver;FireDACDSDriver;DBXSqliteDriver;FireDACPgDriver;fmx;IndySystem;TeeDB;tethering;vclib;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;DataSnapServer;DataSnapProviderClient;DBXSybaseASEDriver;DbxCommonDriver;vclimg;dbxcds;DatasnapConnectorsFreePascal;MetropolisUILiveTile;vcldb;vcldsnap;fmxFireDAC;DBXDb2Driver;DBXOracleDriver;CustomIPTransport;vclribbon;dsnap;IndyIPServer;fmxase;vcl;IndyCore;DBXMSSQLDriver;CloudService;IndyIPCommon;FmxTeeUI;FireDACIBDriver;DataSnapFireDAC;FireDACDBXDriver;soapserver;inetdbxpress;dsnapxml;FireDACInfxDriver;FireDACDb2Driver;adortl;FireDACASADriver;bindcompfmx;FireDACODBCDriver;RESTBackendComponents;emsclientfiredac;rtl;dbrtl;DbxClientDriver;FireDACCommon;bindcomp;inetdb;Tee;DBXOdbcDriver;vclFireDAC;xmlrtl;DataSnapNativeClient;ibxpress;IndyProtocols;DBXMySQLDriver;FireDACCommonDriver;bindcompdbx;bindengine;vclactnband;FMXTee;soaprtl;TeeUI;bindcompvcl;vclie;FireDACADSDriver;vcltouch;emsclient;VCLRESTComponents;FireDAC;DBXInformixDriver;FireDACMSSQLDriver;Intraweb;VclSmp;DataSnapConnectors;DataSnapServerMidas;DBXFirebirdDriver;dsnapcon;inet;fmxobj;FireDACMySQLDriver;soapmidas;vclx;DBXSybaseASADriver;FireDACOracleDriver;fmxdae;RESTComponents;dbexpress;FireDACMSAccDriver;DataSnapIndy10ServerTransport;IndyIPClient;$(DCC_UsePackage) - - - DEBUG;$(DCC_Define) - true - false - true - true - true - - - false - - - false - RELEASE;$(DCC_Define) - 0 - 0 - - - - MainSource - - -
Main
- dfm - - - - - - Cfg_2 - Base - - - Base - - - Cfg_1 - Base - - - - Delphi.Personality.12 - Application - - - - Demo1.dpr - - - - - - Demo1.exe - true - - - - - 1 - - - 1 - - - - - Contents\Resources - 1 - - - - - classes - 1 - - - - - res\drawable-xxhdpi - 1 - - - - - Contents\MacOS - 0 - - - 1 - - - Contents\MacOS - 1 - - - - - library\lib\mips - 1 - - - - - 1 - - - 1 - - - 1 - - - - - 1 - - - 1 - - - 0 - - - 1 - - - Contents\MacOS - 1 - - - library\lib\armeabi-v7a - 1 - - - 1 - - - - - 0 - - - Contents\MacOS - 1 - .framework - - - - - 1 - - - 1 - - - 1 - - - - - - ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF - 1 - - - ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF - 1 - - - - - 1 - - - 1 - - - 1 - - - - - 1 - - - 1 - - - 1 - - - - - 1 - - - 1 - - - 1 - - - - - library\lib\armeabi - 1 - - - - - 0 - - - 1 - - - Contents\MacOS - 1 - - - - - 1 - - - 1 - - - 1 - - - - - res\drawable-normal - 1 - - - - - res\drawable-xhdpi - 1 - - - - - res\drawable-large - 1 - - - - - 1 - - - 1 - - - 1 - - - - - ..\ - 1 - - - ..\ - 1 - - - - - library\lib\armeabi-v7a - 1 - - - - - res\drawable-hdpi - 1 - - - - - Contents - 1 - - - - - ..\ - 1 - - - - - 1 - - - 1 - - - 1 - - - - - res\values - 1 - - - - - res\drawable-small - 1 - - - - - res\drawable - 1 - - - - - 1 - - - 1 - - - 1 - - - - - 1 - - - - - res\drawable - 1 - - - - - 0 - - - 0 - - - Contents\Resources\StartUp\ - 0 - - - 0 - - - 0 - - - 0 - - - - - library\lib\armeabi-v7a - 1 - - - - - 0 - .bpl - - - 1 - .dylib - - - Contents\MacOS - 1 - .dylib - - - 1 - .dylib - - - 1 - .dylib - - - - - res\drawable-mdpi - 1 - - - - - res\drawable-xlarge - 1 - - - - - res\drawable-ldpi - 1 - - - - - 0 - .dll;.bpl - - - 1 - .dylib - - - Contents\MacOS - 1 - .dylib - - - 1 - .dylib - - - 1 - .dylib - - - - - - - - - - - - - True - False - - - 12 - - - - - diff --git a/source/detours/Demo/DetoursDemo/Delphi/Objects/Demo1/uMain.dfm b/source/detours/Demo/DetoursDemo/Delphi/Objects/Demo1/uMain.dfm deleted file mode 100644 index 9702c5260..000000000 --- a/source/detours/Demo/DetoursDemo/Delphi/Objects/Demo1/uMain.dfm +++ /dev/null @@ -1,52 +0,0 @@ -object Main: TMain - Left = 0 - Top = 0 - BorderStyle = bsSizeToolWin - Caption = 'Hooking TControl.SetTextBuf' - ClientHeight = 164 - ClientWidth = 178 - Color = clBtnFace - Font.Charset = DEFAULT_CHARSET - Font.Color = clWindowText - Font.Height = -11 - Font.Name = 'Tahoma' - Font.Style = [] - OldCreateOrder = False - PixelsPerInch = 96 - TextHeight = 13 - object BtnEnableHook: TButton - Left = 17 - Top = 90 - Width = 151 - Height = 25 - Caption = 'BtnEnableHook' - TabOrder = 0 - OnClick = BtnEnableHookClick - end - object BtnDisableHook: TButton - Left = 17 - Top = 116 - Width = 151 - Height = 25 - Caption = 'BtnDisableHook' - TabOrder = 1 - OnClick = BtnDisableHookClick - end - object Edit1: TEdit - Left = 17 - Top = 24 - Width = 151 - Height = 21 - TabOrder = 2 - Text = 'Hi' - end - object BtnClickMe: TButton - Left = 17 - Top = 51 - Width = 151 - Height = 25 - Caption = 'Click Me' - TabOrder = 3 - OnClick = BtnClickMeClick - end -end diff --git a/source/detours/Demo/DetoursDemo/Delphi/Objects/Demo1/uMain.pas b/source/detours/Demo/DetoursDemo/Delphi/Objects/Demo1/uMain.pas deleted file mode 100644 index 2de10be75..000000000 --- a/source/detours/Demo/DetoursDemo/Delphi/Objects/Demo1/uMain.pas +++ /dev/null @@ -1,62 +0,0 @@ -unit uMain; - -interface - -uses - Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics, - Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, DDetours; - -type - TMain = class(TForm) - BtnEnableHook: TButton; - BtnDisableHook: TButton; - Edit1: TEdit; - BtnClickMe: TButton; - procedure BtnEnableHookClick(Sender: TObject); - procedure BtnDisableHookClick(Sender: TObject); - procedure BtnClickMeClick(Sender: TObject); - private - { Private declarations } - public - { Public declarations } - end; - -var - Main: TMain; - -implementation - -{$R *.dfm} - -var - TrampolineSetTextBuf: procedure(const Self; Buffer: PChar) = nil; - -procedure SetTextBufHooked(const Self; Buffer: PChar); -var - S: String; -begin - S := 'Hooked _' + String(Buffer); - TrampolineSetTextBuf(Self, PChar(S)); // Call the original function . -end; - -procedure TMain.BtnDisableHookClick(Sender: TObject); -begin - if Assigned(TrampolineSetTextBuf) then - begin - InterceptRemove(@TrampolineSetTextBuf); - TrampolineSetTextBuf := nil; - end; -end; - -procedure TMain.BtnEnableHookClick(Sender: TObject); -begin - Edit1.Text := 'Enter new text ..'; - @TrampolineSetTextBuf := InterceptCreate(@TControl.SetTextBuf, @SetTextBufHooked); -end; - -procedure TMain.BtnClickMeClick(Sender: TObject); -begin - BtnClickMe.Caption := Edit1.Text; -end; - -end. diff --git a/source/detours/Demo/DetoursDemo/Delphi/RTL/Demo1/Demo1.dpr b/source/detours/Demo/DetoursDemo/Delphi/RTL/Demo1/Demo1.dpr deleted file mode 100644 index 6044c216b..000000000 --- a/source/detours/Demo/DetoursDemo/Delphi/RTL/Demo1/Demo1.dpr +++ /dev/null @@ -1,18 +0,0 @@ -// JCL_DEBUG_EXPERT_GENERATEJDBG OFF -program Demo1; - -uses - Vcl.Forms, - uMain in 'uMain.pas' {Main}, - CPUID in '..\..\..\..\..\Source\CPUID.pas', - DDetours in '..\..\..\..\..\Source\DDetours.pas', - InstDecode in '..\..\..\..\..\Source\InstDecode.pas'; - -{$R *.res} - -begin - Application.Initialize; - Application.MainFormOnTaskbar := True; - Application.CreateForm(TMain, Main); - Application.Run; -end. diff --git a/source/detours/Demo/DetoursDemo/Delphi/RTL/Demo1/Demo1.dproj b/source/detours/Demo/DetoursDemo/Delphi/RTL/Demo1/Demo1.dproj deleted file mode 100644 index cf66ecf87..000000000 --- a/source/detours/Demo/DetoursDemo/Delphi/RTL/Demo1/Demo1.dproj +++ /dev/null @@ -1,539 +0,0 @@ - - - {FF06FC93-1560-45CE-9FF3-14F0C95618F4} - 18.1 - VCL - Demo1.dpr - True - Debug - Win64 - 3 - Application - - - true - - - true - Base - true - - - true - Base - true - - - true - Base - true - - - true - Cfg_1 - true - true - - - true - Base - true - - - System;Xml;Data;Datasnap;Web;Soap;Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;$(DCC_Namespace) - $(BDS)\bin\delphi_PROJECTICON.ico - Demo1 - .\$(Platform)\$(Config) - .\$(Platform)\$(Config) - false - false - false - false - false - - - true - Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) - FireDACSqliteDriver;FireDACDSDriver;DBXSqliteDriver;FireDACPgDriver;fmx;IndySystem;TeeDB;tethering;vclib;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;DataSnapServer;DataSnapProviderClient;DBXSybaseASEDriver;DbxCommonDriver;vclimg;dbxcds;DatasnapConnectorsFreePascal;MetropolisUILiveTile;vcldb;vcldsnap;fmxFireDAC;DBXDb2Driver;DBXOracleDriver;CustomIPTransport;vclribbon;dsnap;IndyIPServer;fmxase;vcl;IndyCore;DBXMSSQLDriver;CloudService;IndyIPCommon;FmxTeeUI;FireDACIBDriver;DataSnapFireDAC;FireDACDBXDriver;soapserver;inetdbxpress;dsnapxml;FireDACInfxDriver;FireDACDb2Driver;adortl;FireDACASADriver;bindcompfmx;FireDACODBCDriver;RESTBackendComponents;emsclientfiredac;rtl;dbrtl;DbxClientDriver;FireDACCommon;bindcomp;inetdb;Tee;DBXOdbcDriver;vclFireDAC;xmlrtl;DataSnapNativeClient;ibxpress;svnui;IndyProtocols;DBXMySQLDriver;FireDACCommonDriver;bindcompdbx;bindengine;vclactnband;FMXTee;soaprtl;TeeUI;bindcompvcl;vclie;FireDACADSDriver;vcltouch;emsclient;VCLRESTComponents;FireDAC;DBXInformixDriver;FireDACMSSQLDriver;Intraweb;VclSmp;DataSnapConnectors;DataSnapServerMidas;DBXFirebirdDriver;dsnapcon;inet;fmxobj;FireDACMySQLDriver;soapmidas;vclx;svn;DBXSybaseASADriver;FireDACOracleDriver;fmxdae;RESTComponents;dbexpress;FireDACMSAccDriver;DataSnapIndy10ServerTransport;IndyIPClient;$(DCC_UsePackage) - 1033 - true - CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= - $(BDS)\bin\default_app.manifest - - - true - Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;$(DCC_Namespace) - FireDACSqliteDriver;FireDACDSDriver;DBXSqliteDriver;FireDACPgDriver;fmx;IndySystem;TeeDB;tethering;vclib;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;DataSnapServer;DataSnapProviderClient;DBXSybaseASEDriver;DbxCommonDriver;vclimg;dbxcds;DatasnapConnectorsFreePascal;MetropolisUILiveTile;vcldb;vcldsnap;fmxFireDAC;DBXDb2Driver;DBXOracleDriver;CustomIPTransport;vclribbon;dsnap;IndyIPServer;fmxase;vcl;IndyCore;DBXMSSQLDriver;CloudService;IndyIPCommon;FmxTeeUI;FireDACIBDriver;DataSnapFireDAC;FireDACDBXDriver;soapserver;inetdbxpress;dsnapxml;FireDACInfxDriver;FireDACDb2Driver;adortl;FireDACASADriver;bindcompfmx;FireDACODBCDriver;RESTBackendComponents;emsclientfiredac;rtl;dbrtl;DbxClientDriver;FireDACCommon;bindcomp;inetdb;Tee;DBXOdbcDriver;vclFireDAC;xmlrtl;DataSnapNativeClient;ibxpress;IndyProtocols;DBXMySQLDriver;FireDACCommonDriver;bindcompdbx;bindengine;vclactnband;FMXTee;soaprtl;TeeUI;bindcompvcl;vclie;FireDACADSDriver;vcltouch;emsclient;VCLRESTComponents;FireDAC;DBXInformixDriver;FireDACMSSQLDriver;Intraweb;VclSmp;DataSnapConnectors;DataSnapServerMidas;DBXFirebirdDriver;dsnapcon;inet;fmxobj;FireDACMySQLDriver;soapmidas;vclx;DBXSybaseASADriver;FireDACOracleDriver;fmxdae;RESTComponents;dbexpress;FireDACMSAccDriver;DataSnapIndy10ServerTransport;IndyIPClient;$(DCC_UsePackage) - 1033 - true - CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= - $(BDS)\bin\default_app.manifest - - - DEBUG;$(DCC_Define) - true - false - true - true - true - - - false - - - false - RELEASE;$(DCC_Define) - 0 - 0 - - - - MainSource - - -
Main
- dfm - - - - - - Cfg_2 - Base - - - Base - - - Cfg_1 - Base - - - - Delphi.Personality.12 - Application - - - - Demo1.dpr - - - - - - Demo1.exe - true - - - - - Demo1.exe - true - - - - - Demo1.rsm - true - - - - - 1 - - - 1 - - - - - Contents\Resources - 1 - - - - - classes - 1 - - - - - res\drawable-xxhdpi - 1 - - - - - Contents\MacOS - 0 - - - 1 - - - Contents\MacOS - 1 - - - - - library\lib\mips - 1 - - - - - 1 - - - 1 - - - 1 - - - - - 1 - - - 1 - - - 0 - - - 1 - - - Contents\MacOS - 1 - - - library\lib\armeabi-v7a - 1 - - - 1 - - - - - 0 - - - Contents\MacOS - 1 - .framework - - - - - 1 - - - 1 - - - 1 - - - - - - ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF - 1 - - - ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF - 1 - - - - - 1 - - - 1 - - - 1 - - - - - 1 - - - 1 - - - 1 - - - - - 1 - - - 1 - - - 1 - - - - - library\lib\armeabi - 1 - - - - - 0 - - - 1 - - - Contents\MacOS - 1 - - - - - 1 - - - 1 - - - 1 - - - - - res\drawable-normal - 1 - - - - - res\drawable-xhdpi - 1 - - - - - res\drawable-large - 1 - - - - - 1 - - - 1 - - - 1 - - - - - ..\ - 1 - - - ..\ - 1 - - - - - library\lib\armeabi-v7a - 1 - - - - - res\drawable-hdpi - 1 - - - - - Contents - 1 - - - - - ..\ - 1 - - - - - 1 - - - 1 - - - 1 - - - - - res\values - 1 - - - - - res\drawable-small - 1 - - - - - res\drawable - 1 - - - - - 1 - - - 1 - - - 1 - - - - - 1 - - - - - res\drawable - 1 - - - - - 0 - - - 0 - - - Contents\Resources\StartUp\ - 0 - - - 0 - - - 0 - - - 0 - - - - - library\lib\armeabi-v7a - 1 - - - - - 0 - .bpl - - - 1 - .dylib - - - Contents\MacOS - 1 - .dylib - - - 1 - .dylib - - - 1 - .dylib - - - - - res\drawable-mdpi - 1 - - - - - res\drawable-xlarge - 1 - - - - - res\drawable-ldpi - 1 - - - - - 0 - .dll;.bpl - - - 1 - .dylib - - - Contents\MacOS - 1 - .dylib - - - 1 - .dylib - - - 1 - .dylib - - - - - - - - - - - - - True - True - - - 12 - - - - - diff --git a/source/detours/Demo/DetoursDemo/Delphi/RTL/Demo1/uMain.dfm b/source/detours/Demo/DetoursDemo/Delphi/RTL/Demo1/uMain.dfm deleted file mode 100644 index eb63a5c50..000000000 --- a/source/detours/Demo/DetoursDemo/Delphi/RTL/Demo1/uMain.dfm +++ /dev/null @@ -1,38 +0,0 @@ -object Main: TMain - Left = 0 - Top = 0 - BorderStyle = bsSizeToolWin - Caption = 'Hooking GetMemory' - ClientHeight = 167 - ClientWidth = 447 - Color = clBtnFace - Font.Charset = DEFAULT_CHARSET - Font.Color = clWindowText - Font.Height = -11 - Font.Name = 'Tahoma' - Font.Style = [] - OldCreateOrder = False - OnCreate = FormCreate - PixelsPerInch = 96 - TextHeight = 13 - object MemLog: TMemo - Left = 0 - Top = 0 - Width = 447 - Height = 113 - Align = alTop - Lines.Strings = ( - 'MemLog') - ScrollBars = ssVertical - TabOrder = 0 - end - object BtnTest: TButton - Left = 302 - Top = 136 - Width = 137 - Height = 25 - Caption = 'Test' - TabOrder = 1 - OnClick = BtnTestClick - end -end diff --git a/source/detours/Demo/DetoursDemo/Delphi/RTL/Demo1/uMain.pas b/source/detours/Demo/DetoursDemo/Delphi/RTL/Demo1/uMain.pas deleted file mode 100644 index d64d766db..000000000 --- a/source/detours/Demo/DetoursDemo/Delphi/RTL/Demo1/uMain.pas +++ /dev/null @@ -1,93 +0,0 @@ -unit uMain; - -interface - -uses - Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics, - Vcl.Controls, Vcl.Forms, Vcl.Dialogs, DDetours, Vcl.StdCtrls; - -type - TMyForm = class(TForm) - private - class var FInit: Boolean; - class constructor Create; - end; - - TMain = class(TMyForm) - MemLog: TMemo; - BtnTest: TButton; - procedure FormCreate(Sender: TObject); - procedure BtnTestClick(Sender: TObject); - private - - { Private declarations } - public - { Public declarations } - end; - -var - Main: TMain; - -implementation - -{$R *.dfm} - -var - TrampolineGetMemory: function(Size: NativeInt): Pointer; -cdecl = nil; - -var - TrampolineFreeMemory: function(P: Pointer): Integer; -cdecl = nil; - -function GetMemory_Hooked(Size: NativeInt): Pointer; cdecl; -begin - Result := TrampolineGetMemory(Size); - if Main.FInit then - begin - Main.MemLog.Lines.Add(Format('Allocating %d bytes at %p.', [Size, Result])); - end; -end; - -function FreeMemory_Hooked(P: Pointer): Integer; cdecl; -begin - Result := TrampolineFreeMemory(P); - if Main.FInit then - begin - Main.MemLog.Lines.Add(Format('Freeing %p address.', [P])); - end; -end; - -procedure TMain.BtnTestClick(Sender: TObject); -var - P: PByte; -begin - P := GetMemory(16); - FreeMemory(P); - MemLog.Lines.Add('---------------------------------'); -end; - -procedure TMain.FormCreate(Sender: TObject); -begin - FInit := True; - MemLog.Clear; -end; - -{ TMyForm } - -class constructor TMyForm.Create; -begin - FInit := False; -end; - -initialization - -@TrampolineGetMemory := InterceptCreate(@GetMemory, @GetMemory_Hooked); -@TrampolineFreeMemory := InterceptCreate(@FreeMemory, @FreeMemory_Hooked); - -finalization - -InterceptRemove(@TrampolineGetMemory); -InterceptRemove(@TrampolineFreeMemory); - -end. diff --git a/source/detours/Demo/DetoursDemo/MultiHook/Demo1/Demo1.dproj b/source/detours/Demo/DetoursDemo/MultiHook/Demo1/Demo1.dproj deleted file mode 100644 index c1bd242b8..000000000 --- a/source/detours/Demo/DetoursDemo/MultiHook/Demo1/Demo1.dproj +++ /dev/null @@ -1,521 +0,0 @@ - - - {8D1CE223-B40B-479A-9234-47F5A8CD29FD} - 18.1 - VCL - Demo1.dpr - True - Debug - Win32 - 1 - Application - - - true - - - true - Base - true - - - true - Base - true - - - true - Base - true - - - true - Cfg_1 - true - true - - - true - Base - true - - - System;Xml;Data;Datasnap;Web;Soap;Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;$(DCC_Namespace) - $(BDS)\bin\delphi_PROJECTICON.ico - Demo1 - .\$(Platform)\$(Config) - .\$(Platform)\$(Config) - false - false - false - false - false - - - true - Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) - FireDACSqliteDriver;FireDACDSDriver;DBXSqliteDriver;FireDACPgDriver;fmx;IndySystem;TeeDB;tethering;vclib;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;DataSnapServer;DataSnapProviderClient;DBXSybaseASEDriver;DbxCommonDriver;vclimg;dbxcds;DatasnapConnectorsFreePascal;MetropolisUILiveTile;vcldb;vcldsnap;fmxFireDAC;DBXDb2Driver;DBXOracleDriver;CustomIPTransport;vclribbon;dsnap;IndyIPServer;fmxase;vcl;IndyCore;DBXMSSQLDriver;CloudService;IndyIPCommon;FmxTeeUI;FireDACIBDriver;DataSnapFireDAC;FireDACDBXDriver;soapserver;inetdbxpress;dsnapxml;FireDACInfxDriver;FireDACDb2Driver;adortl;FireDACASADriver;bindcompfmx;FireDACODBCDriver;RESTBackendComponents;emsclientfiredac;rtl;dbrtl;DbxClientDriver;FireDACCommon;bindcomp;inetdb;Tee;DBXOdbcDriver;vclFireDAC;xmlrtl;DataSnapNativeClient;ibxpress;svnui;IndyProtocols;DBXMySQLDriver;FireDACCommonDriver;bindcompdbx;bindengine;vclactnband;FMXTee;soaprtl;TeeUI;bindcompvcl;vclie;FireDACADSDriver;vcltouch;emsclient;VCLRESTComponents;FireDAC;DBXInformixDriver;FireDACMSSQLDriver;Intraweb;VclSmp;DataSnapConnectors;DataSnapServerMidas;DBXFirebirdDriver;dsnapcon;inet;fmxobj;FireDACMySQLDriver;soapmidas;vclx;svn;DBXSybaseASADriver;FireDACOracleDriver;fmxdae;RESTComponents;dbexpress;FireDACMSAccDriver;DataSnapIndy10ServerTransport;IndyIPClient;$(DCC_UsePackage) - 1033 - true - CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= - $(BDS)\bin\default_app.manifest - - - FireDACSqliteDriver;FireDACDSDriver;DBXSqliteDriver;FireDACPgDriver;fmx;IndySystem;TeeDB;tethering;vclib;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;DataSnapServer;DataSnapProviderClient;DBXSybaseASEDriver;DbxCommonDriver;vclimg;dbxcds;DatasnapConnectorsFreePascal;MetropolisUILiveTile;vcldb;vcldsnap;fmxFireDAC;DBXDb2Driver;DBXOracleDriver;CustomIPTransport;vclribbon;dsnap;IndyIPServer;fmxase;vcl;IndyCore;DBXMSSQLDriver;CloudService;IndyIPCommon;FmxTeeUI;FireDACIBDriver;DataSnapFireDAC;FireDACDBXDriver;soapserver;inetdbxpress;dsnapxml;FireDACInfxDriver;FireDACDb2Driver;adortl;FireDACASADriver;bindcompfmx;FireDACODBCDriver;RESTBackendComponents;emsclientfiredac;rtl;dbrtl;DbxClientDriver;FireDACCommon;bindcomp;inetdb;Tee;DBXOdbcDriver;vclFireDAC;xmlrtl;DataSnapNativeClient;ibxpress;IndyProtocols;DBXMySQLDriver;FireDACCommonDriver;bindcompdbx;bindengine;vclactnband;FMXTee;soaprtl;TeeUI;bindcompvcl;vclie;FireDACADSDriver;vcltouch;emsclient;VCLRESTComponents;FireDAC;DBXInformixDriver;FireDACMSSQLDriver;Intraweb;VclSmp;DataSnapConnectors;DataSnapServerMidas;DBXFirebirdDriver;dsnapcon;inet;fmxobj;FireDACMySQLDriver;soapmidas;vclx;DBXSybaseASADriver;FireDACOracleDriver;fmxdae;RESTComponents;dbexpress;FireDACMSAccDriver;DataSnapIndy10ServerTransport;IndyIPClient;$(DCC_UsePackage) - - - DEBUG;$(DCC_Define) - true - false - true - true - true - - - false - - - false - RELEASE;$(DCC_Define) - 0 - 0 - - - - MainSource - - -
Main
- dfm - - - - - - Cfg_2 - Base - - - Base - - - Cfg_1 - Base - - - - Delphi.Personality.12 - Application - - - - Demo1.dpr - - - - - - Demo1.exe - true - - - - - 1 - - - 1 - - - - - Contents\Resources - 1 - - - - - classes - 1 - - - - - res\drawable-xxhdpi - 1 - - - - - Contents\MacOS - 0 - - - 1 - - - Contents\MacOS - 1 - - - - - library\lib\mips - 1 - - - - - 1 - - - 1 - - - 1 - - - - - 1 - - - 1 - - - 0 - - - 1 - - - Contents\MacOS - 1 - - - library\lib\armeabi-v7a - 1 - - - 1 - - - - - 0 - - - Contents\MacOS - 1 - .framework - - - - - 1 - - - 1 - - - 1 - - - - - - ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF - 1 - - - ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF - 1 - - - - - 1 - - - 1 - - - 1 - - - - - 1 - - - 1 - - - 1 - - - - - 1 - - - 1 - - - 1 - - - - - library\lib\armeabi - 1 - - - - - 0 - - - 1 - - - Contents\MacOS - 1 - - - - - 1 - - - 1 - - - 1 - - - - - res\drawable-normal - 1 - - - - - res\drawable-xhdpi - 1 - - - - - res\drawable-large - 1 - - - - - 1 - - - 1 - - - 1 - - - - - ..\ - 1 - - - ..\ - 1 - - - - - library\lib\armeabi-v7a - 1 - - - - - res\drawable-hdpi - 1 - - - - - Contents - 1 - - - - - ..\ - 1 - - - - - 1 - - - 1 - - - 1 - - - - - res\values - 1 - - - - - res\drawable-small - 1 - - - - - res\drawable - 1 - - - - - 1 - - - 1 - - - 1 - - - - - 1 - - - - - res\drawable - 1 - - - - - 0 - - - 0 - - - Contents\Resources\StartUp\ - 0 - - - 0 - - - 0 - - - 0 - - - - - library\lib\armeabi-v7a - 1 - - - - - 0 - .bpl - - - 1 - .dylib - - - Contents\MacOS - 1 - .dylib - - - 1 - .dylib - - - 1 - .dylib - - - - - res\drawable-mdpi - 1 - - - - - res\drawable-xlarge - 1 - - - - - res\drawable-ldpi - 1 - - - - - 0 - .dll;.bpl - - - 1 - .dylib - - - Contents\MacOS - 1 - .dylib - - - 1 - .dylib - - - 1 - .dylib - - - - - - - - - - - - - True - False - - - 12 - - - - - diff --git a/source/detours/Demo/DetoursDemo/MultiHook/Demo1/uMain.dfm b/source/detours/Demo/DetoursDemo/MultiHook/Demo1/uMain.dfm deleted file mode 100644 index 06b7b7b80..000000000 --- a/source/detours/Demo/DetoursDemo/MultiHook/Demo1/uMain.dfm +++ /dev/null @@ -1,91 +0,0 @@ -object Main: TMain - Left = 0 - Top = 0 - Caption = 'Main' - ClientHeight = 264 - ClientWidth = 447 - Color = clBtnFace - Font.Charset = DEFAULT_CHARSET - Font.Color = clWindowText - Font.Height = -11 - Font.Name = 'Tahoma' - Font.Style = [] - OldCreateOrder = False - OnCreate = FormCreate - PixelsPerInch = 96 - TextHeight = 13 - object MemLog: TMemo - Left = 0 - Top = 0 - Width = 447 - Height = 89 - Align = alTop - Lines.Strings = ( - 'MemLog') - ScrollBars = ssVertical - TabOrder = 0 - end - object BtnEnableHook1: TButton - Left = 292 - Top = 120 - Width = 147 - Height = 25 - Caption = 'Enable Hook1' - TabOrder = 1 - OnClick = BtnEnableHook1Click - end - object BtnEnableHook2: TButton - Left = 292 - Top = 151 - Width = 147 - Height = 25 - Caption = 'Enable Hook2' - TabOrder = 2 - OnClick = BtnEnableHook2Click - end - object BtnEnableHook3: TButton - Left = 292 - Top = 182 - Width = 147 - Height = 25 - Caption = 'Enable Hook3' - TabOrder = 3 - OnClick = BtnEnableHook3Click - end - object BtnRemoveHook1: TButton - Left = 28 - Top = 120 - Width = 147 - Height = 25 - Caption = 'Remove Hook1' - TabOrder = 4 - OnClick = BtnRemoveHook1Click - end - object BtnRemoveHook2: TButton - Left = 28 - Top = 151 - Width = 147 - Height = 25 - Caption = 'Remove Hook2' - TabOrder = 5 - OnClick = BtnRemoveHook2Click - end - object BtnRemoveHook3: TButton - Left = 28 - Top = 182 - Width = 147 - Height = 25 - Caption = 'Remove Hook3' - TabOrder = 6 - OnClick = BtnRemoveHook3Click - end - object BtnTest: TButton - Left = 292 - Top = 231 - Width = 147 - Height = 25 - Caption = 'Test' - TabOrder = 7 - OnClick = BtnTestClick - end -end diff --git a/source/detours/Demo/DetoursDemo/MultiHook/Demo1/uMain.pas b/source/detours/Demo/DetoursDemo/MultiHook/Demo1/uMain.pas deleted file mode 100644 index b21a3c7d7..000000000 --- a/source/detours/Demo/DetoursDemo/MultiHook/Demo1/uMain.pas +++ /dev/null @@ -1,122 +0,0 @@ -unit uMain; - -interface - -uses - Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics, - Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, DDetours; - -type - TMain = class(TForm) - MemLog: TMemo; - BtnEnableHook1: TButton; - BtnEnableHook2: TButton; - BtnEnableHook3: TButton; - BtnRemoveHook1: TButton; - BtnRemoveHook2: TButton; - BtnRemoveHook3: TButton; - BtnTest: TButton; - procedure BtnEnableHook1Click(Sender: TObject); - procedure BtnEnableHook2Click(Sender: TObject); - procedure BtnEnableHook3Click(Sender: TObject); - procedure BtnRemoveHook1Click(Sender: TObject); - procedure BtnRemoveHook2Click(Sender: TObject); - procedure BtnRemoveHook3Click(Sender: TObject); - procedure BtnTestClick(Sender: TObject); - procedure FormCreate(Sender: TObject); - private - { Private declarations } - public - { Public declarations } - end; - -var - Main: TMain; - -implementation - -{$R *.dfm} - -type - TMsgBoxNextHookProc = function(hWnd: hWnd; lpText, lpCaption: LPCWSTR; uType: UINT): Integer; stdcall; - -var - NextHook1: TMsgBoxNextHookProc = nil; - NextHook2: TMsgBoxNextHookProc = nil; - NextHook3: TMsgBoxNextHookProc = nil; - -function MessageBox_Hook1(hWnd: hWnd; lpText, lpCaption: LPCWSTR; uType: UINT): Integer; stdcall; -begin - Main.MemLog.Lines.Add('Hook 1 executed successfully.'); - Result := NextHook1(hWnd, 'Hook1', lpCaption, uType); -end; - -function MessageBox_Hook2(hWnd: hWnd; lpText, lpCaption: LPCWSTR; uType: UINT): Integer; stdcall; -begin - Main.MemLog.Lines.Add('Hook 2 executed successfully.'); - Result := NextHook2(hWnd, lpText, 'Hook2', uType); -end; - -function MessageBox_Hook3(hWnd: hWnd; lpText, lpCaption: LPCWSTR; uType: UINT): Integer; stdcall; -begin - Main.MemLog.Lines.Add('Hook 3 executed successfully.'); - Result := NextHook3(hWnd, lpText, lpText, uType); -end; - -procedure TMain.BtnEnableHook1Click(Sender: TObject); -begin - if not Assigned(NextHook1) then - @NextHook1 := InterceptCreate(@MessageBox, @MessageBox_Hook1); -end; - -procedure TMain.BtnEnableHook2Click(Sender: TObject); -begin - if not Assigned(NextHook2) then - @NextHook2 := InterceptCreate(@MessageBox, @MessageBox_Hook2); -end; - -procedure TMain.BtnEnableHook3Click(Sender: TObject); -begin - if not Assigned(NextHook3) then - @NextHook3 := InterceptCreate(@MessageBox, @MessageBox_Hook3); -end; - -procedure TMain.BtnRemoveHook1Click(Sender: TObject); -begin - if Assigned(NextHook1) then - begin - InterceptRemove(@NextHook1); - NextHook1 := nil; - end; -end; - -procedure TMain.BtnRemoveHook2Click(Sender: TObject); -begin - if Assigned(NextHook2) then - begin - InterceptRemove(@NextHook2); - NextHook2 := nil; - end; -end; - -procedure TMain.BtnRemoveHook3Click(Sender: TObject); -begin - if Assigned(NextHook3) then - begin - InterceptRemove(@NextHook3); - NextHook3 := nil; - end; -end; - -procedure TMain.BtnTestClick(Sender: TObject); -begin - MemLog.Lines.Add('----------------------------'); - MessageBox(Handle, 'Msg Text', 'Msg Caption', MB_OK); -end; - -procedure TMain.FormCreate(Sender: TObject); -begin - MemLog.Clear; -end; - -end. diff --git a/source/detours/Demo/DetoursDemo/win32api/Demo1/Demo1.dpr b/source/detours/Demo/DetoursDemo/win32api/Demo1/Demo1.dpr deleted file mode 100644 index 7c8ff19dc..000000000 --- a/source/detours/Demo/DetoursDemo/win32api/Demo1/Demo1.dpr +++ /dev/null @@ -1,17 +0,0 @@ -program Demo1; - -uses - Vcl.Forms, - uMain in 'uMain.pas' {Main}, - CPUID in '..\..\..\..\Source\CPUID.pas', - DDetours in '..\..\..\..\Source\DDetours.pas', - InstDecode in '..\..\..\..\Source\InstDecode.pas'; - -{$R *.res} - -begin - Application.Initialize; - Application.MainFormOnTaskbar := True; - Application.CreateForm(TMain, Main); - Application.Run; -end. diff --git a/source/detours/Demo/DetoursDemo/win32api/Demo1/Demo1.dproj b/source/detours/Demo/DetoursDemo/win32api/Demo1/Demo1.dproj deleted file mode 100644 index 913d98cca..000000000 --- a/source/detours/Demo/DetoursDemo/win32api/Demo1/Demo1.dproj +++ /dev/null @@ -1,521 +0,0 @@ - - - {94A98E21-0A68-459A-87DB-F12416300062} - 18.1 - VCL - Demo1.dpr - True - Debug - Win32 - 1 - Application - - - true - - - true - Base - true - - - true - Base - true - - - true - Base - true - - - true - Cfg_1 - true - true - - - true - Base - true - - - System;Xml;Data;Datasnap;Web;Soap;Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;$(DCC_Namespace) - $(BDS)\bin\delphi_PROJECTICON.ico - Demo1 - .\$(Platform)\$(Config) - .\$(Platform)\$(Config) - false - false - false - false - false - - - true - Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) - FireDACSqliteDriver;FireDACDSDriver;DBXSqliteDriver;FireDACPgDriver;fmx;IndySystem;TeeDB;tethering;vclib;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;DataSnapServer;DataSnapProviderClient;DBXSybaseASEDriver;DbxCommonDriver;vclimg;dbxcds;DatasnapConnectorsFreePascal;MetropolisUILiveTile;vcldb;vcldsnap;fmxFireDAC;DBXDb2Driver;DBXOracleDriver;CustomIPTransport;vclribbon;dsnap;IndyIPServer;fmxase;vcl;IndyCore;DBXMSSQLDriver;CloudService;IndyIPCommon;FmxTeeUI;FireDACIBDriver;DataSnapFireDAC;FireDACDBXDriver;soapserver;inetdbxpress;dsnapxml;FireDACInfxDriver;FireDACDb2Driver;adortl;FireDACASADriver;bindcompfmx;FireDACODBCDriver;RESTBackendComponents;emsclientfiredac;rtl;dbrtl;DbxClientDriver;FireDACCommon;bindcomp;inetdb;Tee;DBXOdbcDriver;vclFireDAC;xmlrtl;DataSnapNativeClient;ibxpress;svnui;IndyProtocols;DBXMySQLDriver;FireDACCommonDriver;bindcompdbx;bindengine;vclactnband;FMXTee;soaprtl;TeeUI;bindcompvcl;vclie;FireDACADSDriver;vcltouch;emsclient;VCLRESTComponents;FireDAC;DBXInformixDriver;FireDACMSSQLDriver;Intraweb;VclSmp;DataSnapConnectors;DataSnapServerMidas;DBXFirebirdDriver;dsnapcon;inet;fmxobj;FireDACMySQLDriver;soapmidas;vclx;svn;DBXSybaseASADriver;FireDACOracleDriver;fmxdae;RESTComponents;dbexpress;FireDACMSAccDriver;DataSnapIndy10ServerTransport;IndyIPClient;$(DCC_UsePackage) - 1033 - true - CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= - $(BDS)\bin\default_app.manifest - - - FireDACSqliteDriver;FireDACDSDriver;DBXSqliteDriver;FireDACPgDriver;fmx;IndySystem;TeeDB;tethering;vclib;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;DataSnapServer;DataSnapProviderClient;DBXSybaseASEDriver;DbxCommonDriver;vclimg;dbxcds;DatasnapConnectorsFreePascal;MetropolisUILiveTile;vcldb;vcldsnap;fmxFireDAC;DBXDb2Driver;DBXOracleDriver;CustomIPTransport;vclribbon;dsnap;IndyIPServer;fmxase;vcl;IndyCore;DBXMSSQLDriver;CloudService;IndyIPCommon;FmxTeeUI;FireDACIBDriver;DataSnapFireDAC;FireDACDBXDriver;soapserver;inetdbxpress;dsnapxml;FireDACInfxDriver;FireDACDb2Driver;adortl;FireDACASADriver;bindcompfmx;FireDACODBCDriver;RESTBackendComponents;emsclientfiredac;rtl;dbrtl;DbxClientDriver;FireDACCommon;bindcomp;inetdb;Tee;DBXOdbcDriver;vclFireDAC;xmlrtl;DataSnapNativeClient;ibxpress;IndyProtocols;DBXMySQLDriver;FireDACCommonDriver;bindcompdbx;bindengine;vclactnband;FMXTee;soaprtl;TeeUI;bindcompvcl;vclie;FireDACADSDriver;vcltouch;emsclient;VCLRESTComponents;FireDAC;DBXInformixDriver;FireDACMSSQLDriver;Intraweb;VclSmp;DataSnapConnectors;DataSnapServerMidas;DBXFirebirdDriver;dsnapcon;inet;fmxobj;FireDACMySQLDriver;soapmidas;vclx;DBXSybaseASADriver;FireDACOracleDriver;fmxdae;RESTComponents;dbexpress;FireDACMSAccDriver;DataSnapIndy10ServerTransport;IndyIPClient;$(DCC_UsePackage) - - - DEBUG;$(DCC_Define) - true - false - true - true - true - - - false - - - false - RELEASE;$(DCC_Define) - 0 - 0 - - - - MainSource - - -
Main
- dfm - - - - - - Cfg_2 - Base - - - Base - - - Cfg_1 - Base - - - - Delphi.Personality.12 - Application - - - - Demo1.dpr - - - - - - Demo1.exe - true - - - - - 1 - - - 1 - - - - - Contents\Resources - 1 - - - - - classes - 1 - - - - - res\drawable-xxhdpi - 1 - - - - - Contents\MacOS - 0 - - - 1 - - - Contents\MacOS - 1 - - - - - library\lib\mips - 1 - - - - - 1 - - - 1 - - - 1 - - - - - 1 - - - 1 - - - 0 - - - 1 - - - Contents\MacOS - 1 - - - library\lib\armeabi-v7a - 1 - - - 1 - - - - - 0 - - - Contents\MacOS - 1 - .framework - - - - - 1 - - - 1 - - - 1 - - - - - - ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF - 1 - - - ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF - 1 - - - - - 1 - - - 1 - - - 1 - - - - - 1 - - - 1 - - - 1 - - - - - 1 - - - 1 - - - 1 - - - - - library\lib\armeabi - 1 - - - - - 0 - - - 1 - - - Contents\MacOS - 1 - - - - - 1 - - - 1 - - - 1 - - - - - res\drawable-normal - 1 - - - - - res\drawable-xhdpi - 1 - - - - - res\drawable-large - 1 - - - - - 1 - - - 1 - - - 1 - - - - - ..\ - 1 - - - ..\ - 1 - - - - - library\lib\armeabi-v7a - 1 - - - - - res\drawable-hdpi - 1 - - - - - Contents - 1 - - - - - ..\ - 1 - - - - - 1 - - - 1 - - - 1 - - - - - res\values - 1 - - - - - res\drawable-small - 1 - - - - - res\drawable - 1 - - - - - 1 - - - 1 - - - 1 - - - - - 1 - - - - - res\drawable - 1 - - - - - 0 - - - 0 - - - Contents\Resources\StartUp\ - 0 - - - 0 - - - 0 - - - 0 - - - - - library\lib\armeabi-v7a - 1 - - - - - 0 - .bpl - - - 1 - .dylib - - - Contents\MacOS - 1 - .dylib - - - 1 - .dylib - - - 1 - .dylib - - - - - res\drawable-mdpi - 1 - - - - - res\drawable-xlarge - 1 - - - - - res\drawable-ldpi - 1 - - - - - 0 - .dll;.bpl - - - 1 - .dylib - - - Contents\MacOS - 1 - .dylib - - - 1 - .dylib - - - 1 - .dylib - - - - - - - - - - - - - True - False - - - 12 - - - - - diff --git a/source/detours/Demo/DetoursDemo/win32api/Demo1/uMain.pas b/source/detours/Demo/DetoursDemo/win32api/Demo1/uMain.pas deleted file mode 100644 index afe843af5..000000000 --- a/source/detours/Demo/DetoursDemo/win32api/Demo1/uMain.pas +++ /dev/null @@ -1,61 +0,0 @@ -unit uMain; - -interface - -uses - Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics, - Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, DDetours; - -type - TMain = class(TForm) - BtnHook: TButton; - BtnUnHook: TButton; - BtnTestMsgBox: TButton; - procedure BtnHookClick(Sender: TObject); - procedure BtnUnHookClick(Sender: TObject); - procedure BtnTestMsgBoxClick(Sender: TObject); - private - { Private declarations } - public - { Public declarations } - end; - -var - Main: TMain; - -implementation - -{$R *.dfm} - -var - TrampolineMessageBoxW: function(hWnd: hWnd; lpText, lpCaption: LPCWSTR; uType: UINT): Integer; -stdcall = nil; - -function InterceptMessageBoxW(hWnd: hWnd; lpText, lpCaption: LPCWSTR; uType: UINT): Integer; stdcall; -begin - Result := TrampolineMessageBoxW(hWnd, 'Hooked', 'Hooked', MB_OK or MB_ICONEXCLAMATION); -end; - -procedure TMain.BtnHookClick(Sender: TObject); -begin - if not Assigned(TrampolineMessageBoxW) then - begin - @TrampolineMessageBoxW := InterceptCreate(@MessageBoxW, @InterceptMessageBoxW); - end; -end; - -procedure TMain.BtnTestMsgBoxClick(Sender: TObject); -begin - MessageBoxW(Handle, 'Text', 'Caption', MB_OK); -end; - -procedure TMain.BtnUnHookClick(Sender: TObject); -begin - if Assigned(TrampolineMessageBoxW) then - begin - InterceptRemove(@TrampolineMessageBoxW); - TrampolineMessageBoxW := nil; - end; -end; - -end. diff --git a/source/detours/Demo/DetoursDemo/win32api/Demo2/Demo2.dpr b/source/detours/Demo/DetoursDemo/win32api/Demo2/Demo2.dpr deleted file mode 100644 index 057f914c5..000000000 --- a/source/detours/Demo/DetoursDemo/win32api/Demo2/Demo2.dpr +++ /dev/null @@ -1,18 +0,0 @@ -// JCL_DEBUG_EXPERT_GENERATEJDBG OFF -program Demo2; - -uses - Vcl.Forms, - uMain in 'uMain.pas' {Main}, - CPUID in '..\..\..\..\Source\CPUID.pas', - DDetours in '..\..\..\..\Source\DDetours.pas', - InstDecode in '..\..\..\..\Source\InstDecode.pas'; - -{$R *.res} - -begin - Application.Initialize; - Application.MainFormOnTaskbar := True; - Application.CreateForm(TMain, Main); - Application.Run; -end. diff --git a/source/detours/Demo/DetoursDemo/win32api/Demo2/Demo2.dproj b/source/detours/Demo/DetoursDemo/win32api/Demo2/Demo2.dproj deleted file mode 100644 index ada8d1026..000000000 --- a/source/detours/Demo/DetoursDemo/win32api/Demo2/Demo2.dproj +++ /dev/null @@ -1,521 +0,0 @@ - - - {D20E30CF-BD39-428A-9E72-F6745BF708E6} - 18.1 - VCL - Demo2.dpr - True - Debug - Win32 - 1 - Application - - - true - - - true - Base - true - - - true - Base - true - - - true - Base - true - - - true - Cfg_1 - true - true - - - true - Base - true - - - System;Xml;Data;Datasnap;Web;Soap;Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;$(DCC_Namespace) - Demo2 - $(BDS)\bin\delphi_PROJECTICON.ico - .\$(Platform)\$(Config) - .\$(Platform)\$(Config) - false - false - false - false - false - - - true - FireDACSqliteDriver;FireDACDSDriver;DBXSqliteDriver;FireDACPgDriver;fmx;IndySystem;TeeDB;tethering;vclib;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;DataSnapServer;DataSnapProviderClient;DBXSybaseASEDriver;DbxCommonDriver;vclimg;dbxcds;DatasnapConnectorsFreePascal;MetropolisUILiveTile;vcldb;vcldsnap;fmxFireDAC;DBXDb2Driver;DBXOracleDriver;CustomIPTransport;vclribbon;dsnap;IndyIPServer;fmxase;vcl;IndyCore;DBXMSSQLDriver;CloudService;IndyIPCommon;FmxTeeUI;FireDACIBDriver;DataSnapFireDAC;FireDACDBXDriver;soapserver;inetdbxpress;dsnapxml;FireDACInfxDriver;FireDACDb2Driver;adortl;FireDACASADriver;bindcompfmx;FireDACODBCDriver;RESTBackendComponents;emsclientfiredac;rtl;dbrtl;DbxClientDriver;FireDACCommon;bindcomp;inetdb;Tee;DBXOdbcDriver;vclFireDAC;xmlrtl;DataSnapNativeClient;ibxpress;svnui;IndyProtocols;DBXMySQLDriver;FireDACCommonDriver;bindcompdbx;bindengine;vclactnband;FMXTee;soaprtl;TeeUI;bindcompvcl;vclie;FireDACADSDriver;vcltouch;emsclient;VCLRESTComponents;FireDAC;DBXInformixDriver;FireDACMSSQLDriver;Intraweb;VclSmp;DataSnapConnectors;DataSnapServerMidas;DBXFirebirdDriver;dsnapcon;inet;fmxobj;FireDACMySQLDriver;soapmidas;vclx;svn;DBXSybaseASADriver;FireDACOracleDriver;fmxdae;RESTComponents;dbexpress;FireDACMSAccDriver;DataSnapIndy10ServerTransport;IndyIPClient;$(DCC_UsePackage) - 1033 - true - CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= - $(BDS)\bin\default_app.manifest - Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) - - - FireDACSqliteDriver;FireDACDSDriver;DBXSqliteDriver;FireDACPgDriver;fmx;IndySystem;TeeDB;tethering;vclib;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;DataSnapServer;DataSnapProviderClient;DBXSybaseASEDriver;DbxCommonDriver;vclimg;dbxcds;DatasnapConnectorsFreePascal;MetropolisUILiveTile;vcldb;vcldsnap;fmxFireDAC;DBXDb2Driver;DBXOracleDriver;CustomIPTransport;vclribbon;dsnap;IndyIPServer;fmxase;vcl;IndyCore;DBXMSSQLDriver;CloudService;IndyIPCommon;FmxTeeUI;FireDACIBDriver;DataSnapFireDAC;FireDACDBXDriver;soapserver;inetdbxpress;dsnapxml;FireDACInfxDriver;FireDACDb2Driver;adortl;FireDACASADriver;bindcompfmx;FireDACODBCDriver;RESTBackendComponents;emsclientfiredac;rtl;dbrtl;DbxClientDriver;FireDACCommon;bindcomp;inetdb;Tee;DBXOdbcDriver;vclFireDAC;xmlrtl;DataSnapNativeClient;ibxpress;IndyProtocols;DBXMySQLDriver;FireDACCommonDriver;bindcompdbx;bindengine;vclactnband;FMXTee;soaprtl;TeeUI;bindcompvcl;vclie;FireDACADSDriver;vcltouch;emsclient;VCLRESTComponents;FireDAC;DBXInformixDriver;FireDACMSSQLDriver;Intraweb;VclSmp;DataSnapConnectors;DataSnapServerMidas;DBXFirebirdDriver;dsnapcon;inet;fmxobj;FireDACMySQLDriver;soapmidas;vclx;DBXSybaseASADriver;FireDACOracleDriver;fmxdae;RESTComponents;dbexpress;FireDACMSAccDriver;DataSnapIndy10ServerTransport;IndyIPClient;$(DCC_UsePackage) - - - DEBUG;$(DCC_Define) - true - false - true - true - true - - - false - - - false - RELEASE;$(DCC_Define) - 0 - 0 - - - - MainSource - - -
Main
- dfm - - - - - - Cfg_2 - Base - - - Base - - - Cfg_1 - Base - - - - Delphi.Personality.12 - Application - - - - Demo2.dpr - - - - - - Demo2.exe - true - - - - - 1 - - - 1 - - - - - Contents\Resources - 1 - - - - - classes - 1 - - - - - res\drawable-xxhdpi - 1 - - - - - Contents\MacOS - 0 - - - 1 - - - Contents\MacOS - 1 - - - - - library\lib\mips - 1 - - - - - 1 - - - 1 - - - 1 - - - - - 1 - - - 1 - - - 0 - - - 1 - - - Contents\MacOS - 1 - - - library\lib\armeabi-v7a - 1 - - - 1 - - - - - 0 - - - Contents\MacOS - 1 - .framework - - - - - 1 - - - 1 - - - 1 - - - - - - ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF - 1 - - - ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF - 1 - - - - - 1 - - - 1 - - - 1 - - - - - 1 - - - 1 - - - 1 - - - - - 1 - - - 1 - - - 1 - - - - - library\lib\armeabi - 1 - - - - - 0 - - - 1 - - - Contents\MacOS - 1 - - - - - 1 - - - 1 - - - 1 - - - - - res\drawable-normal - 1 - - - - - res\drawable-xhdpi - 1 - - - - - res\drawable-large - 1 - - - - - 1 - - - 1 - - - 1 - - - - - ..\ - 1 - - - ..\ - 1 - - - - - library\lib\armeabi-v7a - 1 - - - - - res\drawable-hdpi - 1 - - - - - Contents - 1 - - - - - ..\ - 1 - - - - - 1 - - - 1 - - - 1 - - - - - res\values - 1 - - - - - res\drawable-small - 1 - - - - - res\drawable - 1 - - - - - 1 - - - 1 - - - 1 - - - - - 1 - - - - - res\drawable - 1 - - - - - 0 - - - 0 - - - Contents\Resources\StartUp\ - 0 - - - 0 - - - 0 - - - 0 - - - - - library\lib\armeabi-v7a - 1 - - - - - 0 - .bpl - - - 1 - .dylib - - - Contents\MacOS - 1 - .dylib - - - 1 - .dylib - - - 1 - .dylib - - - - - res\drawable-mdpi - 1 - - - - - res\drawable-xlarge - 1 - - - - - res\drawable-ldpi - 1 - - - - - 0 - .dll;.bpl - - - 1 - .dylib - - - Contents\MacOS - 1 - .dylib - - - 1 - .dylib - - - 1 - .dylib - - - - - - - - - - - - - True - False - - - 12 - - - - - diff --git a/source/detours/Demo/DetoursDemo/win32api/Demo2/uMain.dfm b/source/detours/Demo/DetoursDemo/win32api/Demo2/uMain.dfm deleted file mode 100644 index 17a0c0b5e..000000000 --- a/source/detours/Demo/DetoursDemo/win32api/Demo2/uMain.dfm +++ /dev/null @@ -1,61 +0,0 @@ -object Main: TMain - Left = 0 - Top = 0 - BorderStyle = bsSizeToolWin - Caption = 'Hooking GetSysColor function' - ClientHeight = 234 - ClientWidth = 219 - Color = clBtnFace - Font.Charset = DEFAULT_CHARSET - Font.Color = clWindowText - Font.Height = -11 - Font.Name = 'Tahoma' - Font.Style = [] - OldCreateOrder = False - OnCreate = FormCreate - PixelsPerInch = 96 - TextHeight = 13 - object Label1: TLabel - Left = 16 - Top = 141 - Width = 31 - Height = 13 - Caption = 'Label1' - end - object Memo1: TMemo - Left = 16 - Top = 40 - Width = 185 - Height = 89 - Lines.Strings = ( - 'Select me before hooking , and ' - 'reselect me after hooking !') - TabOrder = 0 - end - object Edit1: TEdit - Left = 16 - Top = 13 - Width = 185 - Height = 21 - TabOrder = 1 - Text = 'Select Me..' - end - object BtnEnableHook: TButton - Left = 16 - Top = 169 - Width = 185 - Height = 25 - Caption = 'Enable Hook' - TabOrder = 2 - OnClick = BtnEnableHookClick - end - object BtnDisableHook: TButton - Left = 16 - Top = 200 - Width = 185 - Height = 25 - Caption = 'Disable Hook' - TabOrder = 3 - OnClick = BtnDisableHookClick - end -end diff --git a/source/detours/Demo/DetoursDemo/win32api/Demo2/uMain.pas b/source/detours/Demo/DetoursDemo/win32api/Demo2/uMain.pas deleted file mode 100644 index 085779130..000000000 --- a/source/detours/Demo/DetoursDemo/win32api/Demo2/uMain.pas +++ /dev/null @@ -1,65 +0,0 @@ -unit uMain; - -interface - -uses - Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics, - Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, DDetours; - -type - TMain = class(TForm) - Memo1: TMemo; - Edit1: TEdit; - BtnEnableHook: TButton; - BtnDisableHook: TButton; - Label1: TLabel; - procedure BtnEnableHookClick(Sender: TObject); - procedure BtnDisableHookClick(Sender: TObject); - procedure FormCreate(Sender: TObject); - private - { Private declarations } - public - { Public declarations } - end; - -var - Main: TMain; - -implementation - -{$R *.dfm} - -var - TrampolineGetSysColor: function(nIndex: Integer): DWORD; -stdcall = nil; - -function InterceptGetSysColor(nIndex: Integer): DWORD; stdcall; -begin - if nIndex = COLOR_HIGHLIGHT then - Result := clWebOrange - else - Result := TrampolineGetSysColor(nIndex); -end; - -procedure TMain.BtnEnableHookClick(Sender: TObject); -begin - @TrampolineGetSysColor := InterceptCreate(@GetSysColor, @InterceptGetSysColor); - Label1.Caption := 'GetSysColor is hooked.'; -end; - -procedure TMain.FormCreate(Sender: TObject); -begin - Label1.Caption := 'GetSysColor not hooked.'; -end; - -procedure TMain.BtnDisableHookClick(Sender: TObject); -begin - if Assigned(TrampolineGetSysColor) then - begin - InterceptRemove(@TrampolineGetSysColor); - TrampolineGetSysColor := nil; - Label1.Caption := 'GetSysColor not hooked.'; - end; -end; - -end. diff --git a/source/detours/Demo/InstDecodeDemo/Demo1/Demo1.dpr b/source/detours/Demo/InstDecodeDemo/Demo1/Demo1.dpr deleted file mode 100644 index f6a418d9c..000000000 --- a/source/detours/Demo/InstDecodeDemo/Demo1/Demo1.dpr +++ /dev/null @@ -1,57 +0,0 @@ -// JCL_DEBUG_EXPERT_GENERATEJDBG OFF -program Demo1; - -{$APPTYPE CONSOLE} -{$R *.res} - -uses - System.SysUtils, - InstDecode in '..\..\..\Source\InstDecode.pas'; - -procedure Foo; -asm - {$IFDEF CPUX64} - PUSH RAX - XOR EAX,EAX - MOV EAX,5 - ADD EAX,EDX - POP RAX - NOP - NOP - NOP - MOV RAX,1 - {$ELSE !CPUX64} - PUSH EAX - XOR EAX,EAX - MOV EAX,5 - ADD EAX,EDX - POP EAX - NOP - NOP - NOP - MOV EAX,1 - {$ENDIF CPUX64} -end; - -var - Inst: TInstruction; - nInst: Integer; - -begin - // Foo; - Inst := Default (TInstruction); - Inst.Archi := CPUX; - Inst.NextInst := @Foo; - nInst := 0; - while (Inst.OpType <> otRET) do - begin - inc(nInst); - Inst.Addr := Inst.NextInst; - DecodeInst(@Inst); - Writeln(Format('OpCode : 0x%.2x | Length : %d', [Inst.OpCode, Inst.InstSize])); - end; - Writeln('-------------------------------'); - Writeln(Format('Total instructions : %d', [nInst])); - ReadLn; - -end. diff --git a/source/detours/Demo/InstDecodeDemo/Demo1/Demo1.dproj b/source/detours/Demo/InstDecodeDemo/Demo1/Demo1.dproj deleted file mode 100644 index df00068df..000000000 --- a/source/detours/Demo/InstDecodeDemo/Demo1/Demo1.dproj +++ /dev/null @@ -1,623 +0,0 @@ - - - {6D1CA670-4437-4814-9FD1-01AC3CE12603} - 18.1 - None - Demo1.dpr - True - Debug - Win32 - 1 - Console - - - true - - - true - Base - true - - - true - Base - true - - - true - Base - true - - - true - Base - true - - - true - Base - true - - - true - Base - true - - - true - Base - true - - - true - Cfg_1 - true - true - - - true - Base - true - - - $(BDS)\bin\delphi_PROJECTICON.ico - $(BDS)\bin\delphi_PROJECTICNS.icns - Demo1 - System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace) - .\$(Platform)\$(Config) - .\$(Platform)\$(Config) - false - false - false - false - false - - - $(BDS)\bin\Artwork\Android\FM_LauncherIcon_144x144.png - true - true - $(BDS)\bin\Artwork\Android\FM_SplashImage_470x320.png - true - true - $(BDS)\bin\Artwork\Android\FM_SplashImage_960x720.png - true - $(BDS)\bin\Artwork\Android\FM_LauncherIcon_96x96.png - true - true - $(BDS)\bin\Artwork\Android\FM_SplashImage_640x480.png - $(BDS)\bin\Artwork\Android\FM_LauncherIcon_72x72.png - $(BDS)\bin\Artwork\Android\FM_LauncherIcon_48x48.png - $(BDS)\bin\Artwork\Android\FM_LauncherIcon_36x36.png - true - true - true - $(BDS)\bin\Artwork\Android\FM_SplashImage_426x320.png - - - $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_80x80.png - $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_60x60.png - $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_76x76.png - $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_40x40.png - $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_80x80.png - $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_120x120.png - $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_768x1024.png - $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_1024x768.png - $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_152x152.png - $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_2048x1536.png - $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_1536x2048.png - $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_40x40.png - - - $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_80x80.png - $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_60x60.png - $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_76x76.png - $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_40x40.png - $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_80x80.png - $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_120x120.png - $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_768x1024.png - $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_1024x768.png - $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_152x152.png - $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_2048x1536.png - $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_1536x2048.png - $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_40x40.png - - - $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_80x80.png - $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_60x60.png - $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_76x76.png - $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_40x40.png - $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_80x80.png - $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_120x120.png - $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_768x1024.png - $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_1024x768.png - $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_152x152.png - $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_2048x1536.png - $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_1536x2048.png - $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_40x40.png - - - Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) - FireDACSqliteDriver;FireDACDSDriver;DBXSqliteDriver;FireDACPgDriver;fmx;IndySystem;TeeDB;tethering;vclib;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;DataSnapServer;DataSnapProviderClient;DBXSybaseASEDriver;DbxCommonDriver;vclimg;dbxcds;DatasnapConnectorsFreePascal;MetropolisUILiveTile;vcldb;vcldsnap;fmxFireDAC;DBXDb2Driver;DBXOracleDriver;CustomIPTransport;vclribbon;dsnap;IndyIPServer;fmxase;vcl;IndyCore;DBXMSSQLDriver;CloudService;IndyIPCommon;FmxTeeUI;FireDACIBDriver;DataSnapFireDAC;FireDACDBXDriver;soapserver;inetdbxpress;dsnapxml;FireDACInfxDriver;FireDACDb2Driver;adortl;FireDACASADriver;bindcompfmx;FireDACODBCDriver;RESTBackendComponents;emsclientfiredac;rtl;dbrtl;DbxClientDriver;FireDACCommon;bindcomp;inetdb;Tee;DBXOdbcDriver;vclFireDAC;xmlrtl;DataSnapNativeClient;ibxpress;svnui;IndyProtocols;DBXMySQLDriver;FireDACCommonDriver;bindcompdbx;bindengine;vclactnband;FMXTee;soaprtl;TeeUI;bindcompvcl;vclie;FireDACADSDriver;vcltouch;emsclient;VCLRESTComponents;FireDAC;DBXInformixDriver;FireDACMSSQLDriver;Intraweb;VclSmp;DataSnapConnectors;DataSnapServerMidas;DBXFirebirdDriver;dsnapcon;inet;fmxobj;FireDACMySQLDriver;soapmidas;vclx;svn;DBXSybaseASADriver;FireDACOracleDriver;fmxdae;RESTComponents;dbexpress;FireDACMSAccDriver;DataSnapIndy10ServerTransport;IndyIPClient;$(DCC_UsePackage) - CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= - true - 1033 - - - FireDACSqliteDriver;FireDACDSDriver;DBXSqliteDriver;FireDACPgDriver;fmx;IndySystem;TeeDB;tethering;vclib;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;DataSnapServer;DataSnapProviderClient;DBXSybaseASEDriver;DbxCommonDriver;vclimg;dbxcds;DatasnapConnectorsFreePascal;MetropolisUILiveTile;vcldb;vcldsnap;fmxFireDAC;DBXDb2Driver;DBXOracleDriver;CustomIPTransport;vclribbon;dsnap;IndyIPServer;fmxase;vcl;IndyCore;DBXMSSQLDriver;CloudService;IndyIPCommon;FmxTeeUI;FireDACIBDriver;DataSnapFireDAC;FireDACDBXDriver;soapserver;inetdbxpress;dsnapxml;FireDACInfxDriver;FireDACDb2Driver;adortl;FireDACASADriver;bindcompfmx;FireDACODBCDriver;RESTBackendComponents;emsclientfiredac;rtl;dbrtl;DbxClientDriver;FireDACCommon;bindcomp;inetdb;Tee;DBXOdbcDriver;vclFireDAC;xmlrtl;DataSnapNativeClient;ibxpress;IndyProtocols;DBXMySQLDriver;FireDACCommonDriver;bindcompdbx;bindengine;vclactnband;FMXTee;soaprtl;TeeUI;bindcompvcl;vclie;FireDACADSDriver;vcltouch;emsclient;VCLRESTComponents;FireDAC;DBXInformixDriver;FireDACMSSQLDriver;Intraweb;VclSmp;DataSnapConnectors;DataSnapServerMidas;DBXFirebirdDriver;dsnapcon;inet;fmxobj;FireDACMySQLDriver;soapmidas;vclx;DBXSybaseASADriver;FireDACOracleDriver;fmxdae;RESTComponents;dbexpress;FireDACMSAccDriver;DataSnapIndy10ServerTransport;IndyIPClient;$(DCC_UsePackage) - true - - - DEBUG;$(DCC_Define) - true - false - true - true - true - - - false - - - false - RELEASE;$(DCC_Define) - 0 - 0 - - - - MainSource - - - - Cfg_2 - Base - - - Base - - - Cfg_1 - Base - - - - Delphi.Personality.12 - Application - - - - Demo1.dpr - - - - - - Demo1.exe - true - - - - - true - - - - - true - - - - - true - - - - - true - - - - - 1 - - - 1 - - - - - Contents\Resources - 1 - - - - - classes - 1 - - - - - res\drawable-xxhdpi - 1 - - - - - Contents\MacOS - 0 - - - 1 - - - Contents\MacOS - 1 - - - - - library\lib\mips - 1 - - - - - 1 - - - 1 - - - 1 - - - - - 1 - - - 1 - - - 0 - - - 1 - - - Contents\MacOS - 1 - - - library\lib\armeabi-v7a - 1 - - - 1 - - - - - 0 - - - Contents\MacOS - 1 - .framework - - - - - 1 - - - 1 - - - 1 - - - - - - ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF - 1 - - - ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF - 1 - - - - - 1 - - - 1 - - - 1 - - - - - 1 - - - 1 - - - 1 - - - - - 1 - - - 1 - - - 1 - - - - - library\lib\armeabi - 1 - - - - - 0 - - - 1 - - - Contents\MacOS - 1 - - - - - 1 - - - 1 - - - 1 - - - - - res\drawable-normal - 1 - - - - - res\drawable-xhdpi - 1 - - - - - res\drawable-large - 1 - - - - - 1 - - - 1 - - - 1 - - - - - ..\ - 1 - - - ..\ - 1 - - - - - library\lib\armeabi-v7a - 1 - - - - - res\drawable-hdpi - 1 - - - - - Contents - 1 - - - - - ..\ - 1 - - - - - 1 - - - 1 - - - 1 - - - - - res\values - 1 - - - - - res\drawable-small - 1 - - - - - res\drawable - 1 - - - - - 1 - - - 1 - - - 1 - - - - - 1 - - - - - res\drawable - 1 - - - - - 0 - - - 0 - - - Contents\Resources\StartUp\ - 0 - - - 0 - - - 0 - - - 0 - - - - - library\lib\armeabi-v7a - 1 - - - - - 0 - .bpl - - - 1 - .dylib - - - Contents\MacOS - 1 - .dylib - - - 1 - .dylib - - - 1 - .dylib - - - - - res\drawable-mdpi - 1 - - - - - res\drawable-xlarge - 1 - - - - - res\drawable-ldpi - 1 - - - - - 0 - .dll;.bpl - - - 1 - .dylib - - - Contents\MacOS - 1 - .dylib - - - 1 - .dylib - - - 1 - .dylib - - - - - - - - - - - - - False - False - False - False - False - True - False - - - 12 - - - - - diff --git a/source/detours/Demo/Lazarus/Demo1/Demo1.ico b/source/detours/Demo/Lazarus/Demo1/Demo1.ico new file mode 100644 index 000000000..0341321b5 Binary files /dev/null and b/source/detours/Demo/Lazarus/Demo1/Demo1.ico differ diff --git a/source/detours/Demo/Lazarus/Demo1/Demo1.lpi b/source/detours/Demo/Lazarus/Demo1/Demo1.lpi new file mode 100644 index 000000000..5ceee037a --- /dev/null +++ b/source/detours/Demo/Lazarus/Demo1/Demo1.lpi @@ -0,0 +1,81 @@ + + + + + + + + + + <Scaled Value="True"/> + <ResourceType Value="res"/> + <UseXPManifest Value="True"/> + <XPManifest> + <DpiAware Value="True"/> + </XPManifest> + <Icon Value="0"/> + </General> + <BuildModes Count="1"> + <Item1 Name="Default" Default="True"/> + </BuildModes> + <PublishOptions> + <Version Value="2"/> + <UseFileFilters Value="True"/> + </PublishOptions> + <RunParams> + <FormatVersion Value="2"/> + <Modes Count="0"/> + </RunParams> + <RequiredPackages Count="1"> + <Item1> + <PackageName Value="LCL"/> + </Item1> + </RequiredPackages> + <Units Count="2"> + <Unit0> + <Filename Value="Demo1.lpr"/> + <IsPartOfProject Value="True"/> + </Unit0> + <Unit1> + <Filename Value="umain.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="Main"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + <UnitName Value="uMain"/> + </Unit1> + </Units> + </ProjectOptions> + <CompilerOptions> + <Version Value="11"/> + <PathDelim Value="\"/> + <Target> + <Filename Value="Demo1"/> + </Target> + <SearchPaths> + <IncludeFiles Value="$(ProjOutDir)"/> + <OtherUnitFiles Value="..\..\..\Source"/> + <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> + </SearchPaths> + <Linking> + <Options> + <Win32> + <GraphicApplication Value="True"/> + </Win32> + </Options> + </Linking> + </CompilerOptions> + <Debugging> + <Exceptions Count="3"> + <Item1> + <Name Value="EAbort"/> + </Item1> + <Item2> + <Name Value="ECodetoolError"/> + </Item2> + <Item3> + <Name Value="EFOpenError"/> + </Item3> + </Exceptions> + </Debugging> +</CONFIG> diff --git a/source/detours/Demo/Lazarus/Demo1/Demo1.lpr b/source/detours/Demo/Lazarus/Demo1/Demo1.lpr new file mode 100644 index 000000000..1badac4d6 --- /dev/null +++ b/source/detours/Demo/Lazarus/Demo1/Demo1.lpr @@ -0,0 +1,22 @@ +program Demo1; + +{$mode objfpc}{$H+} + +uses + {$IFDEF UNIX}{$IFDEF UseCThreads} + cthreads, + {$ENDIF}{$ENDIF} + Interfaces, // this includes the LCL widgetset + Forms, uMain + { you can add units after this }; + +{$R *.res} + +begin + RequireDerivedFormResource:=True; + Application.Scaled:=True; + Application.Initialize; + Application.CreateForm(TMain, Main); + Application.Run; +end. + diff --git a/source/detours/Demo/Lazarus/Demo1/Demo1.lps b/source/detours/Demo/Lazarus/Demo1/Demo1.lps new file mode 100644 index 000000000..6a541c62a --- /dev/null +++ b/source/detours/Demo/Lazarus/Demo1/Demo1.lps @@ -0,0 +1,138 @@ +<?xml version="1.0" encoding="UTF-8"?> +<CONFIG> + <ProjectSession> + <PathDelim Value="\"/> + <Version Value="11"/> + <BuildModes Active="Default"/> + <Units Count="4"> + <Unit0> + <Filename Value="Demo1.lpr"/> + <IsPartOfProject Value="True"/> + <EditorIndex Value="-1"/> + <WindowIndex Value="-1"/> + <TopLine Value="-1"/> + <CursorPos X="-1" Y="-1"/> + <UsageCount Value="20"/> + </Unit0> + <Unit1> + <Filename Value="umain.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="Main"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + <UnitName Value="uMain"/> + <IsVisibleTab Value="True"/> + <TopLine Value="40"/> + <CursorPos X="38" Y="50"/> + <UsageCount Value="20"/> + <Loaded Value="True"/> + <LoadedDesigner Value="True"/> + </Unit1> + <Unit2> + <Filename Value="C:\lazarus\fpc\3.0.4\source\rtl\win\wininc\ascdef.inc"/> + <EditorIndex Value="2"/> + <TopLine Value="248"/> + <CursorPos Y="257"/> + <UsageCount Value="10"/> + <Loaded Value="True"/> + </Unit2> + <Unit3> + <Filename Value="..\..\..\Source\DDetours.pas"/> + <EditorIndex Value="1"/> + <TopLine Value="2291"/> + <CursorPos Y="2299"/> + <UsageCount Value="10"/> + <Loaded Value="True"/> + </Unit3> + </Units> + <JumpHistory Count="21" HistoryIndex="20"> + <Position1> + <Filename Value="umain.pas"/> + </Position1> + <Position2> + <Filename Value="umain.pas"/> + <Caret Line="37" Column="21" TopLine="25"/> + </Position2> + <Position3> + <Filename Value="umain.pas"/> + <Caret Line="34" Column="28" TopLine="24"/> + </Position3> + <Position4> + <Filename Value="umain.pas"/> + <Caret Line="50" Column="6" TopLine="37"/> + </Position4> + <Position5> + <Filename Value="umain.pas"/> + <Caret Line="9" Column="20"/> + </Position5> + <Position6> + <Filename Value="umain.pas"/> + <Caret Line="49" TopLine="39"/> + </Position6> + <Position7> + <Filename Value="umain.pas"/> + <Caret Line="68" Column="42" TopLine="53"/> + </Position7> + <Position8> + <Filename Value="umain.pas"/> + <Caret Line="53" Column="5" TopLine="44"/> + </Position8> + <Position9> + <Filename Value="umain.pas"/> + <Caret Line="61" Column="9" TopLine="45"/> + </Position9> + <Position10> + <Filename Value="umain.pas"/> + <Caret Line="53" Column="5" TopLine="45"/> + </Position10> + <Position11> + <Filename Value="umain.pas"/> + <Caret Line="56" Column="51" TopLine="45"/> + </Position11> + <Position12> + <Filename Value="umain.pas"/> + <Caret Line="53" Column="54" TopLine="45"/> + </Position12> + <Position13> + <Filename Value="umain.pas"/> + <Caret Line="4" Column="2"/> + </Position13> + <Position14> + <Filename Value="umain.pas"/> + <Caret Line="69" Column="20" TopLine="54"/> + </Position14> + <Position15> + <Filename Value="umain.pas"/> + <Caret Line="70" Column="35" TopLine="54"/> + </Position15> + <Position16> + <Filename Value="umain.pas"/> + <Caret Line="75" Column="21" TopLine="59"/> + </Position16> + <Position17> + <Filename Value="umain.pas"/> + <Caret Line="74" TopLine="60"/> + </Position17> + <Position18> + <Filename Value="umain.pas"/> + <Caret Line="75" TopLine="60"/> + </Position18> + <Position19> + <Filename Value="umain.pas"/> + <Caret Line="74" TopLine="60"/> + </Position19> + <Position20> + <Filename Value="umain.pas"/> + <Caret Line="80" TopLine="64"/> + </Position20> + <Position21> + <Filename Value="umain.pas"/> + <Caret Line="48" Column="25" TopLine="35"/> + </Position21> + </JumpHistory> + <RunParams> + <FormatVersion Value="2"/> + <Modes Count="0" ActiveMode=""/> + </RunParams> + </ProjectSession> +</CONFIG> diff --git a/source/detours/Demo/Lazarus/Demo1/umain.lfm b/source/detours/Demo/Lazarus/Demo1/umain.lfm new file mode 100644 index 000000000..2db95e453 --- /dev/null +++ b/source/detours/Demo/Lazarus/Demo1/umain.lfm @@ -0,0 +1,39 @@ +object Main: TMain + Left = 256 + Height = 137 + Top = 145 + Width = 242 + BorderStyle = bsToolWindow + Caption = 'Main' + ClientHeight = 137 + ClientWidth = 242 + OnCreate = FormCreate + LCLVersion = '2.0.8.0' + object BtnHook: TButton + Left = 49 + Height = 27 + Top = 23 + Width = 141 + Caption = 'Hook' + OnClick = BtnHookClick + TabOrder = 0 + end + object BtnMsgBox: TButton + Left = 48 + Height = 25 + Top = 56 + Width = 141 + Caption = 'MessageBox' + OnClick = BtnMsgBoxClick + TabOrder = 1 + end + object BtnUnhook: TButton + Left = 49 + Height = 26 + Top = 88 + Width = 141 + Caption = 'Unhook' + OnClick = BtnUnhookClick + TabOrder = 2 + end +end diff --git a/source/detours/Demo/Lazarus/Demo1/umain.pas b/source/detours/Demo/Lazarus/Demo1/umain.pas new file mode 100644 index 000000000..08a4f57f7 --- /dev/null +++ b/source/detours/Demo/Lazarus/Demo1/umain.pas @@ -0,0 +1,90 @@ +unit uMain; + +{$mode Delphi}{$H+} + + +interface + +uses + Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls, + Windows, DDetours; + +type + + { TMain } + + TMain = class(TForm) + BtnHook: TButton; + BtnMsgBox: TButton; + BtnUnhook: TButton; + procedure BtnHookClick(Sender: TObject); + procedure BtnMsgBoxClick(Sender: TObject); + procedure BtnUnhookClick(Sender: TObject); + procedure FormCreate(Sender: TObject); + private + + public + + end; + +var + Main: TMain; + +implementation + +{$R *.lfm} + +type + TMessageBox = function(hWnd: HWND; lpText: LPCSTR; lpCaption: LPCSTR; + uType: UINT): longint; stdcall; + +var + TrampolineMessageBox: TMessageBox = nil; + +function InterceptMessageBox(hWnd: HWND; lpText: LPCSTR; lpCaption: LPCSTR; + uType: UINT): longint; stdcall; +var + Form: TMain; +begin + Form := GetTrampolineParam(TrampolineMessageBox); + Form.Caption := 'MessageBox Hooked!'; + Result := TrampolineMessageBox(hWnd, 'this text was hooked.', + 'this caption was hooked.', MB_ICONEXCLAMATION); +end; + +{ TMain } + +procedure TMain.BtnHookClick(Sender: TObject); +begin + BtnUnhook.Enabled := True; + BtnHook.Enabled := False; + @TrampolineMessageBox := InterceptCreate(@MessageBox, @InterceptMessageBox, Self); +end; + +procedure TMain.BtnMsgBoxClick(Sender: TObject); +begin + MessageBox(0, 'text', 'caption', 0); +end; + +procedure TMain.BtnUnhookClick(Sender: TObject); +begin + BtnHook.Enabled := True; + BtnUnHook.Enabled := False; + if Assigned(TrampolineMessageBox) then + begin + InterceptRemove(@TrampolineMessageBox); + TrampolineMessageBox := nil; + end; +end; + +procedure TMain.FormCreate(Sender: TObject); +begin + BtnUnhook.Enabled := False; +end; + +initialization + +finalization + if Assigned(TrampolineMessageBox) then + InterceptRemove(@TrampolineMessageBox); +end. diff --git a/source/detours/LICENSE b/source/detours/LICENSE new file mode 100644 index 000000000..a612ad981 --- /dev/null +++ b/source/detours/LICENSE @@ -0,0 +1,373 @@ +Mozilla Public License Version 2.0 +================================== + +1. Definitions +-------------- + +1.1. "Contributor" + means each individual or legal entity that creates, contributes to + the creation of, or owns Covered Software. + +1.2. "Contributor Version" + means the combination of the Contributions of others (if any) used + by a Contributor and that particular Contributor's Contribution. + +1.3. "Contribution" + means Covered Software of a particular Contributor. + +1.4. "Covered Software" + means Source Code Form to which the initial Contributor has attached + the notice in Exhibit A, the Executable Form of such Source Code + Form, and Modifications of such Source Code Form, in each case + including portions thereof. + +1.5. "Incompatible With Secondary Licenses" + means + + (a) that the initial Contributor has attached the notice described + in Exhibit B to the Covered Software; or + + (b) that the Covered Software was made available under the terms of + version 1.1 or earlier of the License, but not also under the + terms of a Secondary License. + +1.6. "Executable Form" + means any form of the work other than Source Code Form. + +1.7. "Larger Work" + means a work that combines Covered Software with other material, in + a separate file or files, that is not Covered Software. + +1.8. "License" + means this document. + +1.9. "Licensable" + means having the right to grant, to the maximum extent possible, + whether at the time of the initial grant or subsequently, any and + all of the rights conveyed by this License. + +1.10. "Modifications" + means any of the following: + + (a) any file in Source Code Form that results from an addition to, + deletion from, or modification of the contents of Covered + Software; or + + (b) any new file in Source Code Form that contains any Covered + Software. + +1.11. "Patent Claims" of a Contributor + means any patent claim(s), including without limitation, method, + process, and apparatus claims, in any patent Licensable by such + Contributor that would be infringed, but for the grant of the + License, by the making, using, selling, offering for sale, having + made, import, or transfer of either its Contributions or its + Contributor Version. + +1.12. "Secondary License" + means either the GNU General Public License, Version 2.0, the GNU + Lesser General Public License, Version 2.1, the GNU Affero General + Public License, Version 3.0, or any later versions of those + licenses. + +1.13. "Source Code Form" + means the form of the work preferred for making modifications. + +1.14. "You" (or "Your") + means an individual or a legal entity exercising rights under this + License. For legal entities, "You" includes any entity that + controls, is controlled by, or is under common control with You. For + purposes of this definition, "control" means (a) the power, direct + or indirect, to cause the direction or management of such entity, + whether by contract or otherwise, or (b) ownership of more than + fifty percent (50%) of the outstanding shares or beneficial + ownership of such entity. + +2. License Grants and Conditions +-------------------------------- + +2.1. Grants + +Each Contributor hereby grants You a world-wide, royalty-free, +non-exclusive license: + +(a) under intellectual property rights (other than patent or trademark) + Licensable by such Contributor to use, reproduce, make available, + modify, display, perform, distribute, and otherwise exploit its + Contributions, either on an unmodified basis, with Modifications, or + as part of a Larger Work; and + +(b) under Patent Claims of such Contributor to make, use, sell, offer + for sale, have made, import, and otherwise transfer either its + Contributions or its Contributor Version. + +2.2. Effective Date + +The licenses granted in Section 2.1 with respect to any Contribution +become effective for each Contribution on the date the Contributor first +distributes such Contribution. + +2.3. Limitations on Grant Scope + +The licenses granted in this Section 2 are the only rights granted under +this License. No additional rights or licenses will be implied from the +distribution or licensing of Covered Software under this License. +Notwithstanding Section 2.1(b) above, no patent license is granted by a +Contributor: + +(a) for any code that a Contributor has removed from Covered Software; + or + +(b) for infringements caused by: (i) Your and any other third party's + modifications of Covered Software, or (ii) the combination of its + Contributions with other software (except as part of its Contributor + Version); or + +(c) under Patent Claims infringed by Covered Software in the absence of + its Contributions. + +This License does not grant any rights in the trademarks, service marks, +or logos of any Contributor (except as may be necessary to comply with +the notice requirements in Section 3.4). + +2.4. Subsequent Licenses + +No Contributor makes additional grants as a result of Your choice to +distribute the Covered Software under a subsequent version of this +License (see Section 10.2) or under the terms of a Secondary License (if +permitted under the terms of Section 3.3). + +2.5. Representation + +Each Contributor represents that the Contributor believes its +Contributions are its original creation(s) or it has sufficient rights +to grant the rights to its Contributions conveyed by this License. + +2.6. Fair Use + +This License is not intended to limit any rights You have under +applicable copyright doctrines of fair use, fair dealing, or other +equivalents. + +2.7. Conditions + +Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted +in Section 2.1. + +3. Responsibilities +------------------- + +3.1. Distribution of Source Form + +All distribution of Covered Software in Source Code Form, including any +Modifications that You create or to which You contribute, must be under +the terms of this License. You must inform recipients that the Source +Code Form of the Covered Software is governed by the terms of this +License, and how they can obtain a copy of this License. You may not +attempt to alter or restrict the recipients' rights in the Source Code +Form. + +3.2. Distribution of Executable Form + +If You distribute Covered Software in Executable Form then: + +(a) such Covered Software must also be made available in Source Code + Form, as described in Section 3.1, and You must inform recipients of + the Executable Form how they can obtain a copy of such Source Code + Form by reasonable means in a timely manner, at a charge no more + than the cost of distribution to the recipient; and + +(b) You may distribute such Executable Form under the terms of this + License, or sublicense it under different terms, provided that the + license for the Executable Form does not attempt to limit or alter + the recipients' rights in the Source Code Form under this License. + +3.3. Distribution of a Larger Work + +You may create and distribute a Larger Work under terms of Your choice, +provided that You also comply with the requirements of this License for +the Covered Software. If the Larger Work is a combination of Covered +Software with a work governed by one or more Secondary Licenses, and the +Covered Software is not Incompatible With Secondary Licenses, this +License permits You to additionally distribute such Covered Software +under the terms of such Secondary License(s), so that the recipient of +the Larger Work may, at their option, further distribute the Covered +Software under the terms of either this License or such Secondary +License(s). + +3.4. Notices + +You may not remove or alter the substance of any license notices +(including copyright notices, patent notices, disclaimers of warranty, +or limitations of liability) contained within the Source Code Form of +the Covered Software, except that You may alter any license notices to +the extent required to remedy known factual inaccuracies. + +3.5. Application of Additional Terms + +You may choose to offer, and to charge a fee for, warranty, support, +indemnity or liability obligations to one or more recipients of Covered +Software. However, You may do so only on Your own behalf, and not on +behalf of any Contributor. You must make it absolutely clear that any +such warranty, support, indemnity, or liability obligation is offered by +You alone, and You hereby agree to indemnify every Contributor for any +liability incurred by such Contributor as a result of warranty, support, +indemnity or liability terms You offer. You may include additional +disclaimers of warranty and limitations of liability specific to any +jurisdiction. + +4. Inability to Comply Due to Statute or Regulation +--------------------------------------------------- + +If it is impossible for You to comply with any of the terms of this +License with respect to some or all of the Covered Software due to +statute, judicial order, or regulation then You must: (a) comply with +the terms of this License to the maximum extent possible; and (b) +describe the limitations and the code they affect. Such description must +be placed in a text file included with all distributions of the Covered +Software under this License. Except to the extent prohibited by statute +or regulation, such description must be sufficiently detailed for a +recipient of ordinary skill to be able to understand it. + +5. Termination +-------------- + +5.1. The rights granted under this License will terminate automatically +if You fail to comply with any of its terms. However, if You become +compliant, then the rights granted under this License from a particular +Contributor are reinstated (a) provisionally, unless and until such +Contributor explicitly and finally terminates Your grants, and (b) on an +ongoing basis, if such Contributor fails to notify You of the +non-compliance by some reasonable means prior to 60 days after You have +come back into compliance. Moreover, Your grants from a particular +Contributor are reinstated on an ongoing basis if such Contributor +notifies You of the non-compliance by some reasonable means, this is the +first time You have received notice of non-compliance with this License +from such Contributor, and You become compliant prior to 30 days after +Your receipt of the notice. + +5.2. If You initiate litigation against any entity by asserting a patent +infringement claim (excluding declaratory judgment actions, +counter-claims, and cross-claims) alleging that a Contributor Version +directly or indirectly infringes any patent, then the rights granted to +You by any and all Contributors for the Covered Software under Section +2.1 of this License shall terminate. + +5.3. In the event of termination under Sections 5.1 or 5.2 above, all +end user license agreements (excluding distributors and resellers) which +have been validly granted by You or Your distributors under this License +prior to termination shall survive termination. + +************************************************************************ +* * +* 6. Disclaimer of Warranty * +* ------------------------- * +* * +* Covered Software is provided under this License on an "as is" * +* basis, without warranty of any kind, either expressed, implied, or * +* statutory, including, without limitation, warranties that the * +* Covered Software is free of defects, merchantable, fit for a * +* particular purpose or non-infringing. The entire risk as to the * +* quality and performance of the Covered Software is with You. * +* Should any Covered Software prove defective in any respect, You * +* (not any Contributor) assume the cost of any necessary servicing, * +* repair, or correction. This disclaimer of warranty constitutes an * +* essential part of this License. No use of any Covered Software is * +* authorized under this License except under this disclaimer. * +* * +************************************************************************ + +************************************************************************ +* * +* 7. Limitation of Liability * +* -------------------------- * +* * +* Under no circumstances and under no legal theory, whether tort * +* (including negligence), contract, or otherwise, shall any * +* Contributor, or anyone who distributes Covered Software as * +* permitted above, be liable to You for any direct, indirect, * +* special, incidental, or consequential damages of any character * +* including, without limitation, damages for lost profits, loss of * +* goodwill, work stoppage, computer failure or malfunction, or any * +* and all other commercial damages or losses, even if such party * +* shall have been informed of the possibility of such damages. This * +* limitation of liability shall not apply to liability for death or * +* personal injury resulting from such party's negligence to the * +* extent applicable law prohibits such limitation. Some * +* jurisdictions do not allow the exclusion or limitation of * +* incidental or consequential damages, so this exclusion and * +* limitation may not apply to You. * +* * +************************************************************************ + +8. Litigation +------------- + +Any litigation relating to this License may be brought only in the +courts of a jurisdiction where the defendant maintains its principal +place of business and such litigation shall be governed by laws of that +jurisdiction, without reference to its conflict-of-law provisions. +Nothing in this Section shall prevent a party's ability to bring +cross-claims or counter-claims. + +9. Miscellaneous +---------------- + +This License represents the complete agreement concerning the subject +matter hereof. If any provision of this License is held to be +unenforceable, such provision shall be reformed only to the extent +necessary to make it enforceable. Any law or regulation which provides +that the language of a contract shall be construed against the drafter +shall not be used to construe this License against a Contributor. + +10. Versions of the License +--------------------------- + +10.1. New Versions + +Mozilla Foundation is the license steward. Except as provided in Section +10.3, no one other than the license steward has the right to modify or +publish new versions of this License. Each version will be given a +distinguishing version number. + +10.2. Effect of New Versions + +You may distribute the Covered Software under the terms of the version +of the License under which You originally received the Covered Software, +or under the terms of any subsequent version published by the license +steward. + +10.3. Modified Versions + +If you create software not governed by this License, and you want to +create a new license for such software, you may create and use a +modified version of this License if you rename the license and remove +any references to the name of the license steward (except to note that +such modified license differs from this License). + +10.4. Distributing Source Code Form that is Incompatible With Secondary +Licenses + +If You choose to distribute Source Code Form that is Incompatible With +Secondary Licenses under the terms of this version of the License, the +notice described in Exhibit B of this License must be attached. + +Exhibit A - Source Code Form License Notice +------------------------------------------- + + This Source Code Form is subject to the terms of the Mozilla Public + License, v. 2.0. If a copy of the MPL was not distributed with this + file, You can obtain one at http://mozilla.org/MPL/2.0/. + +If it is not possible or desirable to put the notice in a particular +file, then You may include the notice in a location (such as a LICENSE +file in a relevant directory) where a recipient would be likely to look +for such a notice. + +You may add additional accurate notices of copyright ownership. + +Exhibit B - "Incompatible With Secondary Licenses" Notice +--------------------------------------------------------- + + This Source Code Form is "Incompatible With Secondary Licenses", as + defined by the Mozilla Public License, v. 2.0. diff --git a/source/detours/README.md b/source/detours/README.md index dca7a7019..38c8000e6 100644 --- a/source/detours/README.md +++ b/source/detours/README.md @@ -1,30 +1,39 @@ -The **Delphi Detours Library** is a library allowing you to hook Delphi and Windows API functions. It provides an easy way to insert and remove hook. +![Version](https://img.shields.io/badge/version-v2.2-yellow.svg) +![License](https://img.shields.io/github/license/MahdiSafsafi/DDetours) +![Lang](https://img.shields.io/github/languages/top/MahdiSafsafi/DDetours.svg) + +The **DDetours** is a library allowing you to hook Delphi and Windows API functions. It provides an easy way to insert and remove hook. + +## What's new in Version 2.2 ? ## +* Support for FPC and older Delphi version notably D7. +* Support for recursive section. +* Support for custom parameter/tag for each trampoline function. +* See CHANGELOG for complete changes. -## What's new in Version 2: ## -Please check [Version2](https://github.com/MahdiSafsafi/delphi-detours-library/blob/wiki/Version2.md) wiki page ## Features : ## - * Support **x86** and **x64** architecture. - * Allow calling the original function via <u><b>Trampoline</b></u> function. - * Support for <u><b>Multi Hook</b></u>. - * **COM**/**Interfaces**/**win32api** support. - * Support hooking interfaces methods by **MethodName** or **MethodIndex**. - * Support COM **vtable** patching. - * Fully <u><b>thread-safe</b></u> code hooking and unhooking. - * Support hooking Object Method. - * Support Delphi 7/2005-2010/XE-XE8. - * Support Lazarus/FPC. - * 64 bit address is supported. - * The library does not use any external library. - * The library can insert and remove the hook at any time. - * The library contains InstDecode library, that allow to you to decode CPU instructions (x86 & x64). - -This project contains two sub projects : **The Detours Library** and **the InstDecode library**. - -The InstDecode Library is a library that can decode both (x86-x64) instructions. You can consider it as a small disassembler routine. -It can decode instruction and getting information about the instruction (size of instruction,displacement,immediate data, jump address,..) without displaying mnemonics making it very faster and small in compiled size. +* Supports **x86** and **x64** architecture. +* Supports <u><b>multiple hook</b></u> for a single function. +* Supports Delphi 7/2005-2010/XE-Rio(Delphi 10.3). +* Supports Lazarus/FPC. +* Supports recursive function inside the hook function. +* Supports hooking interfaces methods by **MethodName** or **MethodIndex**. +* Supports COM **vtable** patching. +* Supports hooking object methods. +* Allows calling the original function via <u><b>Trampoline/NextHook</b></u> function. +* **COM**/**Interfaces**/**win32api** support. +* Thread-safe for hooking and unhooking. +* 64 bit address is supported. +* The library does not use any external library. +* The library can insert and remove the hook at any time. +* The library contains InstDecode library, that allows you to decode CPU instructions (x86/x64). + +This project contains two sub project : **DDetours** and **InstDecode*** library. + +The InstDecode Library is a library that can decode both (x86/x64) instructions. You can consider it as a small disassembler routine. +It can decode instruction and getting information about the instruction (size of instruction, displacement, immediate data, jump address,..) without displaying mnemonics making it very faster and very small in size. These two libraries were coded in pure Pascal language with Delphi XE7. -See the [Wiki](https://github.com/MahdiSafsafi/delphi-detours-library/tree/wiki) page for more information about how to use the library. +See the [Wiki](https://github.com/MahdiSafsafi/DDetours/wiki) page for more information about how to use the library. Please, if you find any bug, feel free to report it. diff --git a/source/detours/Source/CPUID.pas b/source/detours/Source/CPUID.pas index e1ccaff2c..cb79a28c3 100644 --- a/source/detours/Source/CPUID.pas +++ b/source/detours/Source/CPUID.pas @@ -1,48 +1,44 @@ // ************************************************************************************************** // CPUID for Delphi. // Unit CPUID -// https://github.com/MahdiSafsafi/delphi-detours-library - -// 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. -// -// The Original Code is CPUID.pas. -// -// The Initial Developer of the Original Code is Mahdi Safsafi [SMP3]. -// Portions created by Mahdi Safsafi . are Copyright (C) 2013-2017 Mahdi Safsafi . -// All Rights Reserved. +// https://github.com/MahdiSafsafi/DDetours // +// This Source Code Form is subject to the terms of the Mozilla +// Public License, v. 2.0. If a copy of the MPL was not distributed +// with this file, You can obtain one at +// https://mozilla.org/MPL/2.0/. // ************************************************************************************************** unit CPUID; {$IFDEF FPC} {$MODE DELPHI} +{$WARN 4055 OFF} +{$WARN 4082 OFF} +{$WARN 5057 OFF} {$ENDIF FPC} interface -{$I Defs.inc} +{$I DDetoursDefs.inc} -uses SysUtils; +uses + SysUtils +{$IFNDEF FPC}, LegacyTypes{$ENDIF FPC} + ; type { Do not change registers order ! } TCPUIDStruct = packed record - rEAX: UInt32; { EAX Register } - rEBX: UInt32; { EBX Register } - rEDX: UInt32; { EDX Register } - rECX: UInt32; { ECX Register } + rEAX: Cardinal; { EAX Register } + rEBX: Cardinal; { EBX Register } + rEDX: Cardinal; { EDX Register } + rECX: Cardinal; { ECX Register } end; PCPUIDStruct = ^TCPUIDStruct; -procedure CallCPUID(const ID: NativeUInt; var CPUIDStruct: TCPUIDStruct); -function IsCPUIDSupported: Boolean; +procedure CallCPUID(ID: NativeUInt; var CPUIDStruct: TCPUIDStruct); +function IsCPUIDSupported(): Boolean; type TCPUVendor = (vUnknown, vIntel, vAMD, vNextGen); @@ -61,7 +57,25 @@ implementation function ___IsCPUIDSupported: Boolean; asm - {$IFDEF CPUX86} + {$IFDEF CPUX64} + PUSH RCX + MOV RCX,RCX + PUSHFQ + POP RAX + MOV RCX, RAX + XOR RAX, $200000 + PUSH RAX + POPFQ + PUSHFQ + POP RAX + XOR RAX, RCX + SHR RAX, 21 + AND RAX, 1 + PUSH RCX + POPFQ + POP RCX + {$ELSE !CPUX64} + PUSH ECX PUSHFD POP EAX { EAX = EFLAGS } @@ -86,24 +100,7 @@ function ___IsCPUIDSupported: Boolean; PUSH ECX POPFD { Restore original EFLAGS value . } POP ECX - {$ELSE !CPUX86} - PUSH RCX - MOV RCX,RCX - PUSHFQ - POP RAX - MOV RCX, RAX - XOR RAX, $200000 - PUSH RAX - POPFQ - PUSHFQ - POP RAX - XOR RAX, RCX - SHR RAX, 21 - AND RAX, 1 - PUSH RCX - POPFQ - POP RCX - {$ENDIF CPUX86} + {$ENDIF CPUX64} end; procedure ___CallCPUID(const ID: NativeInt; var CPUIDStruct); @@ -112,7 +109,29 @@ procedure ___CallCPUID(const ID: NativeInt; var CPUIDStruct); ALL REGISTERS (rDX,rCX,rBX) MUST BE SAVED BEFORE EXECUTING CPUID INSTRUCTION ! } - {$IFDEF CPUX86} + {$IFDEF CPUX64} + PUSH R9 + PUSH RBX + PUSH RDX + MOV RAX,RCX + MOV R9,RDX + CPUID + {$IFNDEF FPC} + MOV R9.TCPUIDStruct.rEAX,EAX + MOV R9.TCPUIDStruct.rEBX,EBX + MOV R9.TCPUIDStruct.rECX,ECX + MOV R9.TCPUIDStruct.rEDX,EDX + {$ELSE FPC} + MOV [R9].TCPUIDStruct.rEAX,EAX + MOV [R9].TCPUIDStruct.rEBX,EBX + MOV [R9].TCPUIDStruct.rECX,ECX + MOV [R9].TCPUIDStruct.rEDX,EDX + {$ENDIF !FPC} + POP RDX + POP RBX + POP R9 + {$ELSE !CPUX64} + PUSH EDI PUSH ECX PUSH EBX @@ -132,21 +151,7 @@ procedure ___CallCPUID(const ID: NativeInt; var CPUIDStruct); POP EBX POP ECX POP EDI - {$ELSE !CPUX86} - PUSH R9 - PUSH RBX - PUSH RDX - MOV RAX,RCX - MOV R9,RDX - CPUID - MOV R9.TCPUIDStruct.rEAX,EAX - MOV R9.TCPUIDStruct.rEBX,EBX - MOV R9.TCPUIDStruct.rECX,ECX - MOV R9.TCPUIDStruct.rEDX,EDX - POP RDX - POP RBX - POP R9 - {$ENDIF CPUX86} + {$ENDIF CPUX64} end; function ___IsAVXSupported: Boolean; @@ -160,7 +165,7 @@ function ___IsAVXSupported: Boolean; 2) Detect CPUID.1:ECX.AVX[bit 28] = 1 => AVX instructions supported. - 3) Issue XGETBV and verify that XCR0[2:1] = 11b + 3) Issue XGETBV and verify that XCR0[2:1] = ‘11b’ => XMM state and YMM state are enabled by OS. } @@ -207,7 +212,7 @@ function ___IsAVXSupported: Boolean; {$ENDIF CPUX64} end; -procedure CallCPUID(const ID: NativeUInt; var CPUIDStruct: TCPUIDStruct); +procedure CallCPUID(ID: NativeUInt; var CPUIDStruct: TCPUIDStruct); begin FillChar(CPUIDStruct, SizeOf(TCPUIDStruct), #0); if not CPUIDSupported then @@ -224,7 +229,7 @@ function IsCPUIDSupported: Boolean; type TVendorName = array [0 .. 12] of AnsiChar; -function GetVendorName: TVendorName; +function GetVendorName(): TVendorName; var Info: PCPUIDStruct; P: PByte; @@ -234,7 +239,7 @@ function GetVendorName: TVendorName; Exit; Info := GetMemory(SizeOf(TCPUIDStruct)); CallCPUID(0, Info^); - P := PByte(Info) + 4; // Skip EAX ! + P := PByte(NativeInt(Info) + 4); // Skip EAX ! Move(P^, PByte(@Result[0])^, 12); FreeMemory(Info); end; @@ -243,7 +248,7 @@ procedure __Init__; var vn: TVendorName; Info: TCPUIDStruct; - r: UInt32; + r: Cardinal; begin CPUVendor := vUnknown; {$IFDEF CPUX64} @@ -264,7 +269,8 @@ procedure __Init__; CallCPUID(1, Info); r := Info.rEAX and $F00; case r of - $F00, $600: Include(CPUInsts, iMultiNop); + $F00, $600: + Include(CPUInsts, iMultiNop); end; if ___IsAVXSupported then Include(CPUEncoding, VEX); diff --git a/source/detours/Source/DDetours.pas b/source/detours/Source/DDetours.pas index b69c799d4..79135fdb7 100644 --- a/source/detours/Source/DDetours.pas +++ b/source/detours/Source/DDetours.pas @@ -1,238 +1,215 @@ // ************************************************************************************************** // Delphi Detours Library. // Unit DDetours -// https://github.com/MahdiSafsafi/delphi-detours-library - -// 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. -// -// The Original Code is DDetours.pas. +// https://github.com/MahdiSafsafi/DDetours // -// Contributor(s): -// David Millington -// RRUZ -// -// The Initial Developer of the Original Code is Mahdi Safsafi [SMP3]. -// Portions created by Mahdi Safsafi . are Copyright (C) 2013-2017 Mahdi Safsafi . -// All Rights Reserved. +// This Source Code Form is subject to the terms of the Mozilla +// Public License, v. 2.0. If a copy of the MPL was not distributed +// with this file, You can obtain one at +// https://mozilla.org/MPL/2.0/. +// ************************************************************************************************** // +// Contributors: +// - David Millington : Added TDetours<T> class. // ************************************************************************************************** -{ ===============================> CHANGE LOG <====================================================== - - Jan 24,2015: - +Added support for vtable patching. - +Added GetNHook/IsHooked support for Interface. - - Jan 20,2015: - +Added support to hook Delphi Interface by name. - - Version2 , Mahdi Safsafi: - +Many bug fix. - +Added new hooking model architecture. - +Added multi hook support. - +Added COM hook support. - +Added instruction maping feature. - +Added hook detecting feature. - +Added BeginHooks/EndHooks. - +Added BeginUnHooks/EndUnHooks. - +Added IDetours interface. - +Added MultiNop instructions support. - +Generate better opcodes. - +Improved support for x64. - +Improved AllocMemAt function. - ====================================================================================================== } - unit DDetours; +{define FIX_MADEXCEPT if you are using crash on buffer overrun/underrun feature from MadExcept } +{.$DEFINE FIX_MADEXCEPT} +{.$define DEVMODE} + {$IFDEF FPC} {$MODE DELPHI} +{$HINTS OFF} +{$WARN 4045 OFF} +{$WARN 4055 OFF} +{$WARN 4056 OFF} +{$WARN 4082 OFF} +{$WARN 5024 OFF} +{$WARN 5028 OFF} +{$WARN 5057 OFF} +{$WARN 5058 OFF} {$ENDIF FPC} interface -{$I Defs.inc} +{$I DDetoursDefs.inc} uses - InstDecode, - CPUID, - SysUtils, -{$IFDEF DXE2UP} + +{$IFDEF RENAMED_NAMESPACE} + System.SysUtils, + System.Classes, WinApi.Windows, -{$ELSE !DXE2UP} + WinApi.TLHelp32, +{$IFNDEF SUPPORTS_MONITOR} + System.SyncObjs, +{$ENDIF SUPPORTS_MONITOR} +{$ELSE !RENAMED_NAMESPACE} + SysUtils, Windows, -{$ENDIF DXE2UP} - Classes -{$IFDEF MustUseGenerics} - , Generics.Collections // - , Typinfo, RTTI -{$ENDIF MustUseGenerics} - ; + Classes, +{$IFNDEF SUPPORTS_MONITOR} + SyncObjs, +{$ENDIF SUPPORTS_MONITOR} +{$IFNDEF FPC} + TLHelp32, +{$ENDIF FPC} +{$ENDIF RENAMED_NAMESPACE} +{$IFDEF SUPPORTS_RTTI} + System.Generics.Collections, + System.Typinfo, System.RTTI, +{$ENDIF SUPPORTS_RTTI} + LegacyTypes, + CPUID, + InstDecode; type InterceptException = Exception; -{$IFNDEF DXE2UP} - SIZE_T = NativeUInt; -{$ENDIF !DXE2UP} + TTransactionOption = (toSuspendThread); + TTransactionOptions = set of TTransactionOption; + + TInterceptOption = (ioForceLoad, ioRecursive); + TInterceptOptions = set of TInterceptOption; const { Maximum allowed number of hooks. } MAX_HOOKS = 7; - { Options } - Root = 1; // Future use. - ST = 2; // Suspend Threads. + DefaultInterceptOptions = []; + SErrorInvalidTType = '<T> must be a method'; -{$IFDEF BuildThreadSafe} - { - Make the new version compatible with the old one ! - =================================================== - I don't guarantee that i will continue - supporting old release . - ==> You sould update your code - when you have some time ! - } - v1compatibility = ST; -{$ELSE !BuildThreadSafe} - v1compatibility = 0; -{$ENDIF BuildThreadSafe} - { ======================================================================================================================================================= } -function InterceptCreate(const TargetProc, InterceptProc: Pointer; Options: Byte = v1compatibility): Pointer; overload; -function InterceptCreate(const TargetInterface; MethodIndex: Integer; const InterceptProc: Pointer; Options: Byte = v1compatibility): Pointer; overload; -function InterceptCreate(const Module, MethodName: String; const InterceptProc: Pointer; ForceLoadModule: Boolean = True; Options: Byte = v1compatibility) + { ========================================= DDetours Interface ========================================= } +function InterceptCreate(const TargetProc, InterceptProc: Pointer; const Param: Pointer = nil; const Options: TInterceptOptions = DefaultInterceptOptions) : Pointer; overload; -procedure InterceptCreate(const TargetProc, InterceptProc: Pointer; var TrampoLine: Pointer; Options: Byte = v1compatibility); overload; -function InterceptRemove(const Trampo: Pointer; Options: Byte = v1compatibility): Integer; -function GetNHook(const TargetProc: Pointer): ShortInt; overload; -function GetNHook(const TargetInterface; MethodIndex: Integer): ShortInt; overload; +function InterceptCreate(const TargetInterface; MethodIndex: Integer; const InterceptProc: Pointer; const Param: Pointer = nil; + const Options: TInterceptOptions = DefaultInterceptOptions): Pointer; overload; +function InterceptCreate(const Module, MethodName: String; const InterceptProc: Pointer; const Param: Pointer = nil; + const Options: TInterceptOptions = DefaultInterceptOptions): Pointer; overload; +procedure InterceptCreate(const TargetProc, InterceptProc: Pointer; var TrampoLine: Pointer; const Param: Pointer = nil; + const Options: TInterceptOptions = DefaultInterceptOptions); overload; + +{$IFDEF SUPPORTS_RTTI} +function InterceptCreate(const TargetInterface; const MethodName: String; const InterceptProc: Pointer; const Param: Pointer = nil; + const Options: TInterceptOptions = DefaultInterceptOptions): Pointer; overload; +{$ENDIF SUPPORTS_RTTI} +function InterceptRemove(const TrampoLine: Pointer): Integer; overload; + +function GetHookCount(const TargetProc: Pointer): Integer; overload; +function GetHookCount(const TargetInterface; MethodIndex: Integer): Integer; overload; +{$IFDEF SUPPORTS_RTTI} +function GetHookCount(const TargetInterface; const MethodName: String): Integer; overload; +{$ENDIF SUPPORTS_RTTI} function IsHooked(const TargetProc: Pointer): Boolean; overload; function IsHooked(const TargetInterface; MethodIndex: Integer): Boolean; overload; +{$IFDEF SUPPORTS_RTTI} +function IsHooked(const TargetInterface; const MethodName: String): Boolean; overload; +{$ENDIF SUPPORTS_RTTI} function PatchVt(const TargetInterface; MethodIndex: Integer; InterceptProc: Pointer): Pointer; -function UnPatchVt(const Trampo: Pointer): Boolean; +function UnPatchVt(const TrampoLine: Pointer): Boolean; -{$IFDEF MustUseGenerics } -function InterceptCreate(const TargetInterface; const MethodName: String; const InterceptProc: Pointer; Options: Byte = v1compatibility): Pointer; overload; -function GetNHook(const TargetInterface; const MethodName: String): ShortInt; overload; -function IsHooked(const TargetInterface; const MethodName: String): Boolean; overload; -function BeginHooks(): Boolean; -function EndHooks(): Boolean; -function BeginUnHooks(): Boolean; -function EndUnHooks(): Boolean; +function BeginTransaction(Options: TTransactionOptions = [toSuspendThread]): THandle; +function EndTransaction(Handle: THandle): Boolean; -type - DetourException = Exception; +function EnterRecursiveSection(var TrampoLine; MaxRecursionLevel: NativeInt = 0): Boolean; +function ExitRecursiveSection(var TrampoLine): Boolean; - IGenericCast<T> = interface(IInterface) - ['{B19D793C-3225-439C-A2F3-04A72D41879E}'] - function TToPointer(const _T: T): Pointer; - function PointerToT(const _P: Pointer): T; - end; +function GetCreatorThreadIdFromTrampoline(var TrampoLine): TThreadId; +function GetTrampolineParam(var TrampoLine): Pointer; + +{$IFDEF SUPPORTS_GENERICS} - IDetours<T> = interface(IInterface) - ['{04552E96-C716-4378-BE9A-CD383D20AB91}'] - function NextHook: T; - function GetInstalled: Boolean; - function GetHookCount: ShortInt; - procedure SetHook(const TargetProc, InterceptProc: T); - procedure Enable; - procedure Disable; - property TrampoLine: T read NextHook; // Call the original +type + IIntercept<T, U> = interface(IInterface) + ['{EECBF3C2-3938-4923-835A-B0A6AD27744D}'] + function GetTrampoline(): T; + function GetParam(): U; + function GetCreatorThreadId(): TThreadId; + function GetInterceptOptions(): TInterceptOptions; + function EnterRecursive(MaxRecursionLevel: NativeInt = 0): Boolean; + function ExitRecursive(): Boolean; + + property NextHook: T read GetTrampoline; + property TrampoLine: T read GetTrampoline; // alias to NextHook + property Param: U read GetParam; + property CreatorThreadId: TThreadId read GetCreatorThreadId; + property InterceptOptions: TInterceptOptions read GetInterceptOptions; end; - TDetours<T> = class(TInterfacedObject, IGenericCast<T>, IDetours<T>) + { + Based on David Millington's original implementation TDetours<T>. + } + TIntercept<T, U> = class(TInterfacedObject, IIntercept<T, U>) private - FTargetProc: PByte; - FInterceptProc: PByte; FNextHook: T; - function __TToPointer(const _T): Pointer; - function __PointerToT(const _P): T; - function TToPointer(const _T: T): Pointer; - function PointerToT(const _P: Pointer): T; - function NextHook: T; - function GetInstalled: Boolean; - function GetHookCount: ShortInt; - protected - function CheckTType: Boolean; - procedure SetHook(const TargetProc, InterceptProc: T); + FTrampolinePtr: Pointer; + FParam: U; + FCreatorThreadId: TThreadId; + FInterceptOptions: TInterceptOptions; + function TToPointer(const A): Pointer; + function PointerToT(const P): T; + function EnsureTIsMethod(): Boolean; public - constructor Create(const TargetProc, InterceptProc: T); - destructor Destroy; override; - procedure Enable; - procedure Disable; - property TrampoLine: T read NextHook; // Call the original - property Installed: Boolean read GetInstalled; - property nHook: ShortInt read GetHookCount; + function GetTrampoline(): T; + function GetParam(): U; + function GetCreatorThreadId(): TThreadId; + function GetInterceptOptions(): TInterceptOptions; + function EnterRecursive(MaxRecursionLevel: NativeInt = 0): Boolean; + function ExitRecursive(): Boolean; + constructor Create(const TargetProc, InterceptProc: T; const AParam: U; const AInterceptOptions: TInterceptOptions = DefaultInterceptOptions); virtual; + destructor Destroy(); override; + property Param: U read FParam; + property NextHook: T read FNextHook; + property TrampoLine: T read FNextHook; // alias to NextHook + property CreatorThreadId: TThreadId read FCreatorThreadId; + property InterceptOptions: TInterceptOptions read FInterceptOptions; end; -const - SInvalidTType = '%s must be procedure.'; - SDetoursNotInstalled = 'Detour is not installed; trampoline pointer is nil'; -{$ENDIF MustUseGenerics } -{$IFDEF FPC} - -var - Critical: TRTLCriticalSection; -{$ENDIF FPC} - -implementation - -{$OVERFLOWCHECKS OFF} -{$IFNDEF FPC} - -{ Delphi } -uses -{$IFDEF DXE2UP} - WinApi.TLHelp32; -{$ELSE !DXE2UP} - TLHelp32; -{$ENDIF DXE2UP} -{$ELSE FPC} - -type - tagTHREADENTRY32 = record - dwSize: DWORD; - cntUsage: DWORD; - th32ThreadID: DWORD; // this thread - th32OwnerProcessID: DWORD; // Process this thread is associated with - tpBasePri: Longint; - tpDeltaPri: Longint; - dwFlags: DWORD; + TIntercept<T> = class(TIntercept<T, Pointer>) + public + constructor Create(const TargetProc, InterceptProc: T; const AParam: Pointer = nil; + const AInterceptOptions: TInterceptOptions = DefaultInterceptOptions); override; end; +{$ENDIF SUPPORTS_GENERICS} - THREADENTRY32 = tagTHREADENTRY32; - PTHREADENTRY32 = ^tagTHREADENTRY32; - LPTHREADENTRY32 = ^tagTHREADENTRY32; - TThreadEntry32 = tagTHREADENTRY32; - - TCreateToolhelp32Snapshot = function(dwFlags, th32ProcessID: DWORD): THandle stdcall; - TThread32First = function(hSnapshot: THandle; var lpte: TThreadEntry32): BOOL stdcall; - TThread32Next = function(hSnapshot: THandle; var lpte: TThreadEntry32): BOOL stdcall; +type + DetourException = Exception; -var - CreateToolhelp32Snapshot: TCreateToolhelp32Snapshot; - Thread32First: TThread32First; - Thread32Next: TThread32Next; +implementation const - TH32CS_SNAPTHREAD = $00000004; -{$ENDIF !FPC} - -type - TOpenThread = function(dwDesiredAccess: DWORD; bInheritHandle: BOOL; dwThreadId: DWORD): THandle; stdcall; + { Nops } + Nop9: array [0 .. 8] of Byte = ($66, $0F, $1F, $84, $00, $00, $00, $00, $00); + Nop8: array [0 .. 7] of Byte = ($0F, $1F, $84, $00, $00, $00, $00, $00); + Nop7: array [0 .. 6] of Byte = ($0F, $1F, $80, $00, $00, $00, $00); + Nop6: array [0 .. 5] of Byte = ($66, $0F, $1F, $44, $00, $00); + Nop5: array [0 .. 4] of Byte = ($0F, $1F, $44, $00, $00); + Nop4: array [0 .. 3] of Byte = ($0F, $1F, $40, $00); + Nop3: array [0 .. 2] of Byte = ($0F, $1F, $00); + Nop2: array [0 .. 1] of Byte = ($66, $90); + Nop1: array [0 .. 0] of Byte = ($90); + MultiNops: array [0 .. 8] of PByte = ( // + @Nop1, { Standard Nop } + @Nop2, { 2 Bytes Nop } + @Nop3, { 3 Bytes Nop } + @Nop4, { 4 Bytes Nop } + @Nop5, { 5 Bytes Nop } + @Nop6, { 6 Bytes Nop } + @Nop7, { 7 Bytes Nop } + @Nop8, { 8 Bytes Nop } + @Nop9 { 9 Bytes Nop } + ); -var - OpenThread: TOpenThread; - hKernel: THandle; - OpenThreadExist: Boolean = False; - FreeKernel: Boolean = False; - SizeOfAlloc: DWORD = 0; // See initialization ! + { Arithmetic operands } + arNone = $00; + arPlus = $08; + arMin = $10; + arAdd = arPlus or $01; + arSub = arMin or $01; + arInc = arPlus or $02; + arDec = arMin or $02; -const { Instructions OpCodes } opJmpRelz = $E9; opJmpRelb = $EB; @@ -242,14 +219,92 @@ tagTHREADENTRY32 = record opPrfAddrSize = $67; opNop = $90; - fDscrHasTmp = $01; + { thread constants } + THREAD_SUSPEND_RESUME = $0002; + + { Error messages } + SErrorSmallFunctionSize = 'Size of function is too small, risk to override others adjacent functions.'; + SErrorInvalidJmp = 'Invalid JMP Type.'; + SErrorInvalidJmp64 = 'Invalid JMP Type for x64.'; + SErrorInvalidJmp32 = 'Invalid JMP Type for x32.'; + SErrorInvalidDstSave = 'Invalid DstSave Address pointer.'; + SErrorUnsupportedMultiNop = 'Multi Bytes Nop Instructions not supported by your CPU.'; + SErrorRipDisp = 'Failed to correcr RIP Displacement.'; + SErrorBigTrampoSize = 'Exceed maximum TrampoSize.'; + SErrorMaxHook = 'Exceed maximum allowed of hooks.'; + SErrorInvalidTargetProc = 'Invalid TargetProc Pointer.'; + SErrorInvalidInterceptProc = 'Invalid InterceptProc Pointer.'; + SErrorInvalidDescriptor = 'Invalid Descriptor.'; + SErrorInvalidTrampoline = 'Invalid TrampoLine Pointer.'; + SErrorBeginUnHook = 'BeginUnHooks must be called outside BeginHooks/EndHooks.'; + SErrorRecursiveSectionUnsupported = 'Trampoline was not marked to use recursive section.'; + SErrorTlsOutOfIndexes = 'Tls out of indexes.'; + { JMP Type } + JT_NONE = 0; + JT_REL8 = 1; + JT_REL16 = 2; + JT_REL32 = 3; + JT_MEM16 = 4; + JT_MEM32 = 5; + JT_MEM64 = 6; + JT_RIPZ = 7; + +{$IFDEF CPUX64} + JT_MEMN = JT_MEM64; +{$ELSE !CPUX64} + JT_MEMN = JT_MEM32; +{$ENDIF CPUX64} + { Jmp Type To Size } + JmpTypeToSize: array [0 .. 7] of Byte = ( // + 0, { None } + 2, { JT_REL8 = $EB + Rel8 } + 4, { JT_REL16 = OpSizePrf + $E9 + Rel16 } + 5, { JT_REL32 = $E9 + Rel32 } + 7, { JT_MEM16 = OpSizePrf + $FF /4 + Disp32 } + 6, { JT_MEM32 = $FF /4 + Disp32 } + 6, { JT_MEM64 = $FF /4 + Disp32 } + 14 { JT_RIPZ = $FF /4 + Disp32 + DQ } + ); + + SizeToJmpType: array [0 .. 4] of Byte = ( // +{$IFDEF CPUX86} + JT_REL8, { db } + JT_REL16, { dw } + JT_REL32, { dd } + JT_MEM32, { dd } + JT_MEM32 { dd } +{$ELSE !CPUX86} + JT_REL8, { db } + JT_REL32, { dw } + JT_REL32, { dd } + JT_MEM64, { dq } + JT_MEM64 { dq } +{$ENDIF CPUX86} + ); + DscrSigSize = $08; - TrampoSize = 64; TmpSize = 32; + TrampolineSignature = $544C544C; + type + TArrayOfThreadId = array [0 .. HIGH(SmallInt) - 1] of DWORD; + PArrayOfThreadId = ^TArrayOfThreadId; + + TTransactionStruct = record + Options: TTransactionOptions; + TID: DWORD; + PID: DWORD; + ThreadPriority: Integer; + SuspendedThreadCount: Integer; + SuspendedThreads: PArrayOfThreadId; + end; + + PTransactionStruct = ^TTransactionStruct; + + TOpenThread = function(dwDesiredAccess: DWORD; bInheritHandle: BOOL; dwThreadId: DWORD): THandle; stdcall; + TDscrSig = array [0 .. DscrSigSize - 1] of Byte; - TTrampoData = array [0 .. TrampoSize - 1] of Byte; TVirtualProtect = function(lpAddress: Pointer; dwSize: SIZE_T; flNewProtect: DWORD; var OldProtect: DWORD): BOOL; stdcall; TVirtualAlloc = function(lpvAddress: Pointer; dwSize: SIZE_T; flAllocationType, flProtect: DWORD): Pointer; stdcall; @@ -258,6 +313,9 @@ tagTHREADENTRY32 = record TGetCurrentProcess = function: THandle; stdcall; TVirtualFree = function(lpAddress: Pointer; dwSize: SIZE_T; dwFreeType: DWORD): BOOL; stdcall; + { TEnumThreadCallBack for EnumProcessThreads } + TEnumThreadCallBack = function(ID: DWORD; Param: Pointer): Boolean; + TInternalFuncs = record VirtualAlloc: TVirtualAlloc; VirtualFree: TVirtualFree; @@ -267,36 +325,6 @@ TInternalFuncs = record GetCurrentProcess: TGetCurrentProcess; end; -var - InternalFuncs: TInternalFuncs; - -const - { Descriptor Signature } -{$IFDEF CPUX64} - DscrSig: TDscrSig = ( // - $90, { NOP } - $40, { REX } - $40, { REX } - $40, { REX } - $0F, { ESCAPE TWO BYTE } - $1F, { HINT_NOP } - $F3, { PRF } - $F3 { PRF } - ); -{$ELSE !CPUX64} - DscrSig: TDscrSig = ( // - $90, { NOP } - $40, { INC EAX } - $48, { DEC EAX } - $90, { NOP } - $0F, { ESCAPE TWO BYTE } - $1F, { HINT_NOP } - $F3, { PRF } - $F3 { PRF } - ); -{$ENDIF CPUX64} - -type TTrampoInfo = record Addr: PByte; // Pointer to first trampoline instruction . Size: Byte; // Stolen bytes size . @@ -336,139 +364,121 @@ TTrampoInfo = record TNextHook = packed record ID: Byte; { Hook ID . } PDscr: PDescriptor; + Signature: Cardinal; + threadid: TThreadId; + Param: Pointer; + TlsRecursionLevelIndex: DWORD; + InterceptOptions: TInterceptOptions; end; PNextHook = ^TNextHook; - TThreadsIDList = class(TList); - - TInterceptMonitor = class(TObject) - class procedure InternalCreate; - class procedure InternalDestroy; - class var FLock: TObject; - class procedure Enter; - class procedure Leave; + TTrampoDataVt = record + vAddr: Pointer; + Addr: Pointer; end; - TIntercept = class(TObject) - private - FOptions: Byte; - FList: TThreadsIDList; - class function GetRoot(P: PByte): PByte; - public - constructor Create(Options: Byte); virtual; - destructor Destroy; override; - - protected - function GetDescriptor(P: PByte): PDescriptor; - function IsValidDescriptor(P: PByte): Boolean; - function CreateNewDescriptor: PDescriptor; - procedure InsertDescriptor(PAt: PByte; PDscr: PDescriptor); - procedure RemoveDescriptor(PDscr: PDescriptor); - function InstallHook(TargetProc, InterceptProc: PByte; const Options: Byte = $00): PByte; - function AddHook(PDscr: PDescriptor; InterceptProc: PByte; const Options: Byte = $00): PByte; - function RemoveHook(Trampo: PByte): Integer; - end; + PTrampoDataVt = ^TTrampoDataVt; const - { Error Str } - ErrFuncSize = 'Size of function is too small, risk to override others adjacent functions.'; - ErrJmpInvalid = 'Invalid JMP Type.'; - ErrJmpInvalid64 = 'Invalid JMP Type for x64.'; - ErrJmpInvalid32 = 'Invalid JMP Type for x32.'; - ErrJmpInvalidDstSave = 'Invalid DstSave Address pointer.'; - ErrMultiNopNotSup = 'Multi Bytes Nop Instructions not supported by your CPU.'; - ErrRipDisp = 'Failed to correcr RIP Displacement.'; - ErrTrampoSize = 'Exceed maximum TrampoSize.'; - ErrMaxHook = 'Exceed maximum allowed of hooks.'; - ErrTargetProc = 'Invalid TargetProc Pointer.'; - ErrInterceptProc = 'Invalid InterceptProc Pointer.'; - ErrInvalidDscr = 'Invalid Descriptor.'; - ErrInvalidTrampo = 'Invalid TrampoLine Pointer.'; - ErrBgnUnHooks = 'BeginUnHooks must be called outside BeginHooks/EndHooks.'; - - { JMP Type } - tJmpNone = 0; - tJmpRel8 = 1; - tJmpRel16 = 2; - tJmpRel32 = 3; - tJmpMem16 = 4; - tJmpMem32 = 5; - tJmpMem64 = 6; - tJmpRipZ = 7; + TrampoSize = SizeOf(TNextHook) + 64; + { Descriptor Signature } {$IFDEF CPUX64} - tJmpMemN = tJmpMem64; + DscrSig: TDscrSig = ( // + $90, { NOP } + $40, { REX } + $40, { REX } + $40, { REX } + $0F, { ESCAPE TWO BYTE } + $1F, { HINT_NOP } + $F3, { PRF } + $F3 { PRF } + ); {$ELSE !CPUX64} - tJmpMemN = tJmpMem32; -{$ENDIF CPUX64} - { Jmp Type To Size } - JmpTypeToSize: array [0 .. 7] of Byte = ( // - 0, { None } - 2, { tJmpRel8 = $EB + Rel8 } - 4, { tJmpRel16 = OpSizePrf + $E9 + Rel16 } - 5, { tJmpRel32 = $E9 + Rel32 } - 7, { tJmpMem16 = OpSizePrf + $FF /4 + Disp32 } - 6, { tJmpMem32 = $FF /4 + Disp32 } - 6, { tJmpMem64 = $FF /4 + Disp32 } - 14 { tJmpRipZ = $FF /4 + Disp32 + DQ } + DscrSig: TDscrSig = ( // + $90, { NOP } + $40, { INC EAX } + $48, { DEC EAX } + $90, { NOP } + $0F, { ESCAPE TWO BYTE } + $1F, { HINT_NOP } + $F3, { PRF } + $F3 { PRF } ); +{$ENDIF CPUX64} +{$IFDEF FPC} +{$I 'TlHelp32.inc'} +{$ENDIF FPC} - SizeToJmpType: array [0 .. 4] of Byte = ( // -{$IFDEF CPUX86} - tJmpRel8, { db } - tJmpRel16, { dw } - tJmpRel32, { dd } - tJmpMem32, { dd } - tJmpMem32 { dd } -{$ELSE !CPUX86} - tJmpRel8, { db } - tJmpRel32, { dw } - tJmpRel32, { dd } - tJmpMem64, { dq } - tJmpMem64 { dq } -{$ENDIF CPUX86} - ); +var + OpenThread: TOpenThread = nil; +{$IFDEF FPC} + CreateToolhelp32Snapshot: TCreateToolhelp32Snapshot = nil; + Thread32First: TThread32First = nil; + Thread32Next: TThread32Next = nil; +{$ENDIF FPC} + hKernel: THandle; + OpenThreadExist: Boolean = False; + FreeKernel: Boolean = False; + SizeOfAlloc: DWORD = 0; // See initialization ! + SysInfo: TSystemInfo; + InternalFuncs: TInternalFuncs; +{$IFDEF SUPPORTS_MONITOR} + FLock: TObject = nil; +{$ELSE !SUPPORTS_MONITOR} + FLock: TCriticalSection = nil; +{$ENDIF SUPPORTS_MONITOR } + { ================================== Utils ================================== } - { - // Useful function when debugging ! - procedure DbgPrint(const msg: string; Value: Int64); overload; - var - s: string; - begin - s := msg; - if s <> EmptyStr then - s := s + ' = ' + IntToStr(Value) - else - s := IntToStr(Value); - OutputDebugStringW(PChar(s)); - end; +function GetUInt64Size(const Value: UInt64): Integer; {$IFDEF SUPPORTS_INLINE}inline; {$ENDIF SUPPORTS_INLINE} +begin + if UInt8(Value) = Value then + Result := 1 + else if UInt16(Value) = Value then + Result := 2 + else if UInt32(Value) = Value then + Result := 4 + else + Result := 8; +end; - procedure DbgPrint(const msg: string); overload; - begin - OutputDebugStringW(PChar(msg)); - end; +function GetInt64Size(const Value: Int64): Integer; {$IFDEF SUPPORTS_INLINE}inline; {$ENDIF SUPPORTS_INLINE} +begin + if Int8(Value) = Value then + Result := 1 + else if Int16(Value) = Value then + Result := 2 + else if Int32(Value) = Value then + Result := 4 + else + Result := 8; +end; - procedure ShowMsg(const msg: string); - begin - MessageBoxW(0, PChar(msg), nil, MB_OK); - end; - } -const - THREAD_SUSPEND_RESUME = $0002; +procedure EnterLook(LockedObject: TObject); {$IFDEF SUPPORTS_INLINE}inline; {$ENDIF SUPPORTS_INLINE} +begin +{$IFDEF SUPPORTS_MONITOR} + TMonitor.Enter(LockedObject); +{$ELSE !SUPPORTS_MONITOR} + TCriticalSection(LockedObject).Enter(); +{$ENDIF SUPPORTS_MONITOR} +end; + +procedure LeaveLook(LockedObject: TObject); {$IFDEF SUPPORTS_INLINE}inline; {$ENDIF SUPPORTS_INLINE} +begin +{$IFDEF SUPPORTS_MONITOR} + TMonitor.Exit(LockedObject); +{$ELSE !SUPPORTS_MONITOR} + TCriticalSection(LockedObject).Leave(); +{$ENDIF SUPPORTS_MONITOR} +end; -function SuspendAllThreads(RTID: TThreadsIDList): Boolean; +function EnumProcessThreads(PID: DWORD; CallBack: TEnumThreadCallBack; Param: Pointer): BOOL; var hSnap: THandle; - PID: DWORD; te: TThreadEntry32; - nCount: DWORD; - hThread: THandle; Next: Boolean; - CurrentThreadId: Cardinal; begin - PID := GetCurrentProcessId; - CurrentThreadId := GetCurrentThreadId; hSnap := CreateToolhelp32Snapshot(TH32CS_SNAPTHREAD, PID); Result := hSnap <> INVALID_HANDLE_VALUE; if Result then @@ -477,51 +487,21 @@ function SuspendAllThreads(RTID: TThreadsIDList): Boolean; Next := Thread32First(hSnap, te); while Next do begin - if (te.th32OwnerProcessID = PID) and (te.th32ThreadID <> CurrentThreadId) then + if (te.th32OwnerProcessID = PID) then begin - { Allow the caller thread to access the Detours . - => Suspend all threads, except the current thread . } - hThread := OpenThread(THREAD_SUSPEND_RESUME, False, te.th32ThreadID); - if hThread <> INVALID_HANDLE_VALUE then - begin - nCount := SuspendThread(hThread); - if nCount <> DWORD(-1) then // thread's previously was running . - { Only add threads that was running before suspending them ! } - RTID.Add(Pointer(NativeUInt(te.th32ThreadID))); - CloseHandle(hThread); + try + if not CallBack(te.th32ThreadID, Param) then + break; + except end; end; Next := Thread32Next(hSnap, te); end; - CloseHandle(hSnap); + Result := CloseHandle(hSnap); end; end; -function ResumeSuspendedThreads(RTID: TThreadsIDList): Boolean; -var - i: Integer; - TID: DWORD; - hThread: THandle; -begin - Result := False; - if Assigned(RTID) then - for i := 0 to RTID.Count - 1 do - begin - TID := DWORD(RTID.Items[i]); - if TID <> DWORD(-1) then - begin - Result := True; - hThread := OpenThread(THREAD_SUSPEND_RESUME, False, TID); - if hThread <> INVALID_HANDLE_VALUE then - begin - ResumeThread(hThread); - CloseHandle(hThread); - end; - end; - end; -end; - -function SetMemPermission(const P: Pointer; const Size: NativeUInt; const NewProtect: DWORD): DWORD; +function SetMemPermission(const P: Pointer; const Size: SIZE_T; const NewProtect: DWORD): DWORD; const PAGE_EXECUTE_FLAGS = PAGE_EXECUTE or PAGE_EXECUTE_READ or PAGE_EXECUTE_READWRITE or PAGE_EXECUTE_WRITECOPY; begin @@ -538,7 +518,7 @@ function SetMemPermission(const P: Pointer; const Size: NativeUInt; const NewPro end; end; -function GetDispDataSize(PInst: PInstruction): ShortInt; +function GetDispDataSize(PInst: PInstruction): Integer; begin Result := 0; if PInst^.Disp.Flags and dfUsed <> 0 then @@ -546,10 +526,13 @@ function GetDispDataSize(PInst: PInstruction): ShortInt; if PInst^.Archi = CPUX32 then begin if PInst^.Prefixes and Prf_OpSize <> 0 then - Exit(ops16bits) + Result := ops16bits else - Exit(ops32bits); - end else begin + Result := ops32bits; + Exit; + end + else + begin case PInst^.OperandFlags of opdD64: begin @@ -558,14 +541,15 @@ function GetDispDataSize(PInst: PInstruction): ShortInt; PrfOpSize results in O16. } if PInst^.Prefixes and Prf_OpSize <> 0 then - Exit(ops16bits) + Result := ops16bits else - Exit(ops64bits); + Result := ops64bits; end; opdF64, opdDv64: begin { The operand size is forced to a 64-bit operand size in PM64 ! } - Exit(ops64bits); + Result := (ops64bits); + Exit; end; opdDf64: begin @@ -575,25 +559,27 @@ function GetDispDataSize(PInst: PInstruction): ShortInt; PrfOpSize is ignored in EM64T. } if (CPUVendor = vAMD) and (PInst^.Prefixes and Prf_OpSize <> 0) then - Exit(ops16bits) + Result := (ops16bits) else - Exit(ops64bits); + Result := (ops64bits); + Exit; end; else begin if PInst^.Rex.W then - Exit(ops64bits) + Result := (ops64bits) else if (PInst^.Prefixes and Prf_OpSize <> 0) then - Exit(ops16bits) + Result := (ops16bits) else - Exit(ops32bits); + Result := (ops32bits); + Exit; end; end; end; end; end; -function fDecodeInst(PInst: PInstruction): ShortInt; +function fDecodeInst(PInst: PInstruction): Integer; var IsNxtInstData: Boolean; begin @@ -606,7 +592,7 @@ function fDecodeInst(PInst: PInstruction): ShortInt; {$IFDEF CPUX64} IsNxtInstData := ((PInst^.Disp.Flags and (dfUsed or dfRip) = (dfUsed or dfRip)) and (PInst^.Disp.Value = 0)); {$ELSE !CPUX64} - IsNxtInstData := (PInst^.Disp.Value = UInt64(PInst^.NextInst)); + IsNxtInstData := (PInst^.Disp.Value = Int64(PInst^.NextInst)); {$ENDIF CPUX64} if IsNxtInstData then begin @@ -621,11 +607,14 @@ function fDecodeInst(PInst: PInstruction): ShortInt; end; end; -function RoundMultipleOf(const Value, n: NativeUInt): NativeUInt; {$IFDEF MustInline}inline; {$ENDIF} +function RoundMultipleOf(const Value, MultipleOf: NativeInt): NativeInt; {$IFDEF SUPPORTS_INLINE}inline; {$ENDIF SUPPORTS_INLINE} begin if Value = 0 then - Exit(n); - Result := ((Value + (n - 1)) and not(n - 1)); + begin + Result := (MultipleOf); + Exit; + end; + Result := ((Value + (MultipleOf - 1)) and not(MultipleOf - 1)); end; function AllocMemAt(const Addr: Pointer; const MemSize, flProtect: DWORD): Pointer; @@ -653,21 +642,21 @@ function AllocMemAt(const Addr: Pointer; const MemSize, flProtect: DWORD): Point pMax := SysInfo.lpMaximumApplicationAddress; dwAllocGran := SysInfo.dwAllocationGranularity; - if (P < pMin) or (P > pMax) then + if (NativeUInt(P) < NativeUInt(pMin)) or (NativeUInt(P) > NativeUInt(pMax)) then Exit; if InternalFuncs.VirtualQuery(P, mbi, SizeOf(mbi)) = 0 then Exit; pBase := mbi.BaseAddress; Q := pBase; - while Q < pMax do + while NativeUInt(Q) < NativeUInt(pMax) do begin if InternalFuncs.VirtualQuery(Q, mbi, SizeOf(mbi)) = 0 then Exit; if (mbi.State = MEM_FREE) and (mbi.RegionSize >= dwAllocGran) and (mbi.RegionSize >= MemSize) then begin { The address (P) must be multiple of the allocation granularity (dwAllocationGranularity) . } - P := PByte(RoundMultipleOf(NativeUInt(Q), dwAllocGran)); + P := PByte(RoundMultipleOf(NativeInt(Q), dwAllocGran)); Result := InternalFuncs.VirtualAlloc(P, MemSize, MEM_RESERVE or MEM_COMMIT, flProtect); if Assigned(Result) then Exit; @@ -679,13 +668,13 @@ function AllocMemAt(const Addr: Pointer; const MemSize, flProtect: DWORD): Point try to allocate at the range [pMin - Addr] } Q := pBase; - while Q > pMin do + while NativeUInt(Q) > NativeUInt(pMin) do begin if InternalFuncs.VirtualQuery(Q, mbi, SizeOf(mbi)) = 0 then Exit; if (mbi.State = MEM_FREE) and (mbi.RegionSize >= dwAllocGran) and (mbi.RegionSize >= MemSize) then begin - P := PByte(RoundMultipleOf(NativeUInt(Q), dwAllocGran)); + P := PByte(RoundMultipleOf(NativeInt(Q), dwAllocGran)); Result := InternalFuncs.VirtualAlloc(P, MemSize, MEM_RESERVE or MEM_COMMIT, flProtect); if Assigned(Result) then Exit; @@ -711,58 +700,57 @@ function TryAllocMemAt(const Addr: Pointer; const MemSize, flProtect: DWORD): Po end; end; -function InsertJmp(Src, Dst: PByte; JmpType: Byte; const DstSave: PByte = nil): ShortInt; +function InsertJmp(Src, Dst: PByte; JmpType: Integer; const DstSave: PByte = nil): Integer; var - Offset32: Int32; - Offset64: Int64; - JmpSize: Byte; + Offset: NativeInt; + JmpSize: Integer; begin Result := 1; JmpSize := JmpTypeToSize[JmpType]; - Offset32 := Int32(UInt64(Dst) - UInt64(Src)) - JmpSize; + Offset := NativeInt(NativeInt(Dst) - NativeInt(Src)) - JmpSize; case JmpType of - tJmpNone: + JT_NONE: begin - raise InterceptException.Create(ErrJmpInvalid); + raise InterceptException.Create(SErrorInvalidJmp); end; - tJmpRel8: + JT_REL8: begin PByte(Src)^ := opJmpRelb; Inc(Src); - PInt8(Src)^ := Int8(Offset32); + PInt8(Src)^ := Int8(Offset); end; - tJmpRel16: + JT_REL16: begin {$IFDEF CPUX64} { JMP Rel16 ==> Not supported on x64! } - raise InterceptException.Create(ErrJmpInvalid64); + raise InterceptException.Create(SErrorInvalidJmp64); {$ENDIF CPUX64} PByte(Src)^ := opPrfOpSize; Inc(Src); PByte(Src)^ := opJmpRelz; Inc(Src); - PInt16(Src)^ := Int16(Offset32); + PInt16(Src)^ := Int16(Offset); end; - tJmpRel32: + JT_REL32: begin PByte(Src)^ := opJmpRelz; Inc(Src); - PInt32(Src)^ := Offset32; + PInt32(Src)^ := Offset; end; - tJmpMem16: + JT_MEM16: begin {$IFDEF CPUX64} { JMP WORD [012345] ==> Not supported on x64! } - raise InterceptException.Create(ErrJmpInvalid64); + raise InterceptException.Create(SErrorInvalidJmp64); {$ENDIF CPUX64} if not Assigned(DstSave) then - raise InterceptException.Create(ErrJmpInvalidDstSave); + raise InterceptException.Create(SErrorInvalidDstSave); PByte(Src)^ := opPrfOpSize; Inc(Src); PWord(Src)^ := opJmpMem; @@ -770,50 +758,45 @@ function InsertJmp(Src, Dst: PByte; JmpType: Byte; const DstSave: PByte = nil): PUInt32(Src)^ := UInt32(DstSave); PUInt16(DstSave)^ := UInt16(Dst); end; - tJmpMem32: + JT_MEM32: begin {$IFDEF CPUX64} { JMP DWORD [012345] ==> Not supported on x64! } - raise InterceptException.Create(ErrJmpInvalid64); + raise InterceptException.Create(SErrorInvalidJmp64); {$ENDIF CPUX64} if not Assigned(DstSave) then - raise InterceptException.Create(ErrJmpInvalidDstSave); + raise InterceptException.Create(SErrorInvalidDstSave); PWord(Src)^ := opJmpMem; Inc(Src, 2); PUInt32(Src)^ := UInt32(DstSave); PUInt32(DstSave)^ := UInt32(Dst); end; - tJmpMem64: + JT_MEM64: begin {$IFDEF CPUX86} { JMP QWORD [0123456789] ==> Not supported on x32! } - raise InterceptException.Create(ErrJmpInvalid32); + raise InterceptException.Create(SErrorInvalidJmp32); {$ENDIF CPUX86} if not Assigned(DstSave) then - raise InterceptException.Create(ErrJmpInvalidDstSave); + raise InterceptException.Create(SErrorInvalidDstSave); { RIP Disp ! } PUInt64(DstSave)^ := UInt64(Dst); - Offset64 := Int64(UInt64(DstSave) - UInt64(Src)) - JmpSize; - Offset32 := Integer(Offset64); - { If the distance between DispAddr and Src exceed 32-bits then - the only way to insert a jump - is to use tJmpRipZ method ! } - if Offset32 <> Offset64 then - Exit(-1); + Offset := NativeInt(NativeInt(DstSave) - NativeInt(Src)) - JmpSize; + PWord(Src)^ := opJmpMem; Inc(Src, 2); - PInt32(Src)^ := Offset32; + PInt32(Src)^ := Offset; end; - tJmpRipZ: + JT_RIPZ: begin {$IFDEF CPUX86} - raise InterceptException.Create(ErrJmpInvalid32); + raise InterceptException.Create(SErrorInvalidJmp32); {$ENDIF CPUX86} { This is the most harder way to insert a jump ! @@ -841,160 +824,113 @@ function InsertJmp(Src, Dst: PByte; JmpType: Byte; const DstSave: PByte = nil): end; end; -function GetUInt64Size(const Value: UInt64): Byte; -begin - if UInt8(Value) = Value then - Exit(1) - else if UInt16(Value) = Value then - Exit(2) - else if UInt32(Value) = Value then - Exit(4) - else - Exit(8); -end; - -function GetInt64Size(const Value: Int64): Byte; -begin - if Int8(Value) = Value then - Exit(1) - else if Int16(Value) = Value then - Exit(2) - else if Int32(Value) = Value then - Exit(4) - else - Exit(8); -end; - -function GetJmpType(Src, Dst, DstSave: PByte): Byte; +function GetJmpType(Src, Dst, DstSave: PByte): Integer; var - Offset: Int64; - OffsetSize: Byte; + Offset: NativeInt; + OffsetSize: Integer; begin - Offset := Int64(UInt64(Src) - UInt64(Dst)); + Offset := NativeInt(NativeInt(Src) - NativeInt(Dst)); OffsetSize := GetInt64Size(Offset); Result := SizeToJmpType[OffsetSize shr 1]; {$IFDEF CPUX64} - if Result = tJmpMem64 then + if Result = JT_MEM64 then begin if not Assigned(DstSave) then - raise InterceptException.Create(ErrJmpInvalidDstSave); - Offset := Int64(UInt64(DstSave) - UInt64(Src)) - 7; - if Int32(Offset) <> Offset then - Exit(tJmpRipZ); + raise InterceptException.Create(SErrorInvalidDstSave); + Offset := NativeInt(NativeInt(DstSave) - NativeInt(Src)) - 7; + if Integer(Offset) <> Offset then + begin + Result := (JT_RIPZ); + Exit; + end; end; {$ENDIF CPUX64} end; -{$IFDEF UseMultiBytesNop} - -const - Nop9: array [0 .. 8] of Byte = ($66, $0F, $1F, $84, $00, $00, $00, $00, $00); - Nop8: array [0 .. 7] of Byte = ($0F, $1F, $84, $00, $00, $00, $00, $00); - Nop7: array [0 .. 6] of Byte = ($0F, $1F, $80, $00, $00, $00, $00); - Nop6: array [0 .. 5] of Byte = ($66, $0F, $1F, $44, $00, $00); - Nop5: array [0 .. 4] of Byte = ($0F, $1F, $44, $00, $00); - Nop4: array [0 .. 3] of Byte = ($0F, $1F, $40, $00); - Nop3: array [0 .. 2] of Byte = ($0F, $1F, $00); - Nop2: array [0 .. 1] of Byte = ($66, $90); - Nop1: array [0 .. 0] of Byte = ($90); - MultiNops: array [0 .. 8] of PByte = ( // - @Nop1, { Standard Nop } - @Nop2, { 2 Bytes Nop } - @Nop3, { 3 Bytes Nop } - @Nop4, { 4 Bytes Nop } - @Nop5, { 5 Bytes Nop } - @Nop6, { 6 Bytes Nop } - @Nop7, { 7 Bytes Nop } - @Nop8, { 8 Bytes Nop } - @Nop9 { 9 Bytes Nop } - - ); - -function IsMultiBytesNop(const P: PByte; Len: ShortInt = 0): Boolean; +function IsMultiBytesNop(P: Pointer; Size: Integer): Boolean; var i: Integer; - nL: Integer; begin - for i := Length(MultiNops) downto 1 do + Result := False; + if Size > 0 then begin - nL := i; - Result := CompareMem(MultiNops[i - 1], P, nL); - if Result then + while (Size > 0) do begin - if Len < 0 then - Exit; - Result := (nL = Len); - if Result then + for i := Length(MultiNops) downto 1 do + begin + if Size >= i then + begin + Result := CompareMem(MultiNops[i - 1], P, i); + if Result then + begin + Inc(PByte(P), i); + Dec(Size, i); + break; + end; + end; + end; + if not Result then Exit; end; + Result := True; end; end; -procedure FillMultiNop(var Buff; Size: Integer); +procedure FillMultiNop(var Buffer; Size: Integer); var i: Integer; - nL: Byte; P: PByte; begin - { Multi Bytes Nop Instructions seems to be - faster to execute rather than - the traditional (NOP x n) instructions. + { Multi Bytes Nop Instruction is fast to execute compared to + the traditional NOP instruction. However it's not supported by all CPU ! - ==> Use FillNop(P,Size,True)! + ==> Use FillNop(P,Size,True). - ==> CPUID implement a routine to detect - if the CPU support Multi Bytes Nop . + ==> CPUID implements a routine to detect + if the CPU supports Multi Bytes Nop . } if not(iMultiNop in CPUInsts) then - raise InterceptException.Create(ErrMultiNopNotSup); + raise InterceptException.Create(SErrorUnsupportedMultiNop); - P := PByte(@Buff); + P := PByte(@Buffer); for i := Length(MultiNops) downto 1 do begin - nL := i; - if Size = 0 then - Break; - while Size >= nL do + while Size >= i do begin - Move(MultiNops[i - 1]^, P^, nL); - Dec(Size, nL); - Inc(P, nL); + Move(MultiNops[i - 1]^, P^, i); + Dec(Size, i); + Inc(P, i); end; + if Size = 0 then + Exit; end; end; -{$ENDIF UseMultiBytesNop} -function IsNop(const P: PByte; Len: ShortInt; MultiBytesNop: Boolean = False): Boolean; +function IsNop(P: PByte; Size: Integer): Boolean; var i: Integer; - Q: PByte; begin - { Return True if the first instructions are nop/multi nop ! } + { Return True if the first instructions are nop/multi nop. } Result := False; - Q := P; -{$IFDEF UseMultiBytesNop} - if (MultiBytesNop and (iMultiNop in CPUInsts)) then - Result := IsMultiBytesNop(P, Len) + if iMultiNop in CPUInsts then + Result := IsMultiBytesNop(P, Size) else -{$ENDIF UseMultiBytesNop} - for i := 0 to Len - 1 do + for i := 0 to Size - 1 do begin - Result := (Q^ = opNop); + Result := (P^ = opNop); if not Result then Exit; - Inc(Q); // Next Byte. + Inc(P); // Next Byte. end; end; -procedure FillNop(var P; const Size: Integer; const MultiBytesNop: Boolean = False); {$IFDEF MustInline}inline; {$ENDIF} +procedure FillNop(var P; Size: Integer; MultipleNop: Boolean); begin -{$IFDEF UseMultiBytesNop} - if (MultiBytesNop and (iMultiNop in CPUInsts)) then + if MultipleNop and (iMultiNop in CPUInsts) then FillMultiNop(P, Size) else -{$ENDIF UseMultiBytesNop} - FillChar(PByte(@P)^, Size, opNop); + FillChar(P, Size, opNop); end; function GetPrefixesCount(Prefixes: WORD): Byte; @@ -1040,7 +976,8 @@ function GetInstOpCodes(PInst: PInstruction; P: PByte): ShortInt; if PInst^.Prefixes and Prf_VEX3 = 0 then Inc(Result, 2); // 0F + 38|3A ! end; - tbFPU: Inc(Result, 2); // [$D8..$D9] + ModRm ! + tbFPU: + Inc(Result, 2); // [$D8..$D9] + ModRm ! end; if PInst^.Prefixes and Prf_Vex2 <> 0 then Inc(Result); // VEX.P0 @@ -1054,6 +991,33 @@ function GetInstOpCodes(PInst: PInstruction; P: PByte): ShortInt; Move(PInst^.Addr^, P^, Result); end; +function GetJccOpCode(PInst: PInstruction; RelSize: Integer): DWORD; +var + OpCode: Byte; + Opcodes: array [0 .. 3] of Byte; +begin + FillChar(PByte(@Opcodes[0])^, 4, #00); + OpCode := PInst^.OpCode and $F; + case RelSize of + ops8bits: + begin + Opcodes[0] := $70 or OpCode; + end; + ops16bits: + begin + Opcodes[0] := opPrfOpSize; + Opcodes[1] := $0F; + Opcodes[2] := $80 or OpCode; + end; + ops32bits: + begin + Opcodes[0] := $0F; + Opcodes[1] := $80 or OpCode; + end; + end; + Result := PDWORD(@Opcodes[0])^; +end; + function CorrectJ(PInst: PInstruction; NewAddr: PByte): Integer; const { Convert LOOP instruction to relative word jcc ! } @@ -1063,46 +1027,18 @@ function CorrectJ(PInst: PInstruction; NewAddr: PByte): Integer; var Offset: Int64; POpc: PByte; - // Opcsz: Integer; NOpc: DWORD; PQ: PByte; - Relsz: Byte; - JmpType: Byte; - JmpSize: Byte; - function GetJccOpCode(RelSize: Byte): DWORD; - var - LOp: Byte; - Opc: array [0 .. 3] of Byte; - begin - FillChar(PByte(@Opc[0])^, 4, #0); - LOp := PInst^.OpCode and $F; - case RelSize of - ops8bits: - begin - Opc[0] := $70 or LOp; - end; - ops16bits: - begin - Opc[0] := opPrfOpSize; - Opc[1] := $0F; - Opc[2] := $80 or LOp; - end; - ops32bits: - begin - Opc[0] := $0F; - Opc[1] := $80 or LOp; - end; - end; - Result := PDWORD(@Opc[0])^; - end; - + Relsz: Integer; + JmpType: Integer; + JmpSize: Integer; begin PQ := NewAddr; JmpSize := 0; GetMem(POpc, MAX_INST_LENGTH_N + 1); try // Opcsz := GetInstOpCodes(PInst, POpc); - Offset := Int64(UInt64(PInst^.Branch.Target) - UInt64(PQ) - 6); + Offset := Int64(Int64(PInst^.Branch.Target) - Int64(PQ) - 6); Relsz := GetInt64Size(Offset); {$IFDEF CPUX64} if Relsz = ops16bits then @@ -1175,7 +1111,7 @@ function CorrectJ(PInst: PInstruction; NewAddr: PByte): Integer; case Relsz of ops16bits: begin - Offset := Int64(UInt64(PInst^.Branch.Target) - UInt64(PQ) - 5); + Offset := Int64(Int64(PInst^.Branch.Target) - Int64(PQ) - 5); PQ^ := opPrfOpSize; Inc(PQ); PWord(PQ)^ := LOOP_To_JccZ[PInst^.OpCode and 3]; @@ -1185,7 +1121,7 @@ function CorrectJ(PInst: PInstruction; NewAddr: PByte): Integer; end; ops32bits: begin - Offset := Int64(UInt64(PInst^.Branch.Target) - UInt64(PQ) - 6); + Offset := Int64(Int64(PInst^.Branch.Target) - Int64(PQ) - 6); PWord(PQ)^ := LOOP_To_JccZ[PInst^.OpCode and 3]; Inc(PQ, 2); PInt32(PQ)^ := Int32(Offset); @@ -1211,7 +1147,7 @@ function CorrectJ(PInst: PInstruction; NewAddr: PByte): Integer; PQ^ := 14; Inc(PQ); { Insert Jmp @LoopDst } - InsertJmp(PQ, PInst.Branch.Target, tJmpRipZ); + InsertJmp(PQ, PInst.Branch.Target, JT_RIPZ); Inc(PQ, 14); end; end; @@ -1269,7 +1205,7 @@ function CorrectJ(PInst: PInstruction; NewAddr: PByte): Integer; TEST CX,CX JZ @Dst } - Offset := Int64(UInt64(PInst^.Branch.Target) - UInt64(PQ) - 5); + Offset := Int64(Int64(PInst^.Branch.Target) - Int64(PQ) - 5); PQ^ := opPrfOpSize; Inc(PQ); PQ^ := $0F; @@ -1285,7 +1221,7 @@ function CorrectJ(PInst: PInstruction; NewAddr: PByte): Integer; TEST ECX,ECX JZ @Dst } - Offset := Int64(UInt64(PInst^.Branch.Target) - UInt64(PQ) - 6); + Offset := Int64(Int64(PInst^.Branch.Target) - Int64(PQ) - 6); PQ^ := $0F; Inc(PQ); PQ^ := $84; // JZ ! @@ -1313,18 +1249,20 @@ function CorrectJ(PInst: PInstruction; NewAddr: PByte): Integer; PQ^ := 14; Inc(PQ); { Insert Jmp @Dst } - InsertJmp(PQ, PInst.Branch.Target, tJmpRipZ); + InsertJmp(PQ, PInst.Branch.Target, JT_RIPZ); Inc(PQ, 14); end; end; end; - end else begin + end + else + begin { Jcc ! } - NOpc := GetJccOpCode(Relsz); + NOpc := GetJccOpCode(PInst, Relsz); case Relsz of ops8bits: begin - Offset := Int64(UInt64(PInst^.Branch.Target) - UInt64(PQ) - 2); + Offset := Int64(Int64(PInst^.Branch.Target) - Int64(PQ) - 2); PInt8(PQ)^ := UInt8(NOpc); Inc(PQ); PInt8(PQ)^ := Int8(Offset); @@ -1332,7 +1270,7 @@ function CorrectJ(PInst: PInstruction; NewAddr: PByte): Integer; end; ops16bits: begin - Offset := Int64(UInt64(PInst^.Branch.Target) - UInt64(PQ) - 5); + Offset := Int64(Int64(PInst^.Branch.Target) - Int64(PQ) - 5); PUInt32(PQ)^ := UInt32(NOpc); Inc(PQ, 3); PInt16(PQ)^ := Int16(Offset); @@ -1340,7 +1278,7 @@ function CorrectJ(PInst: PInstruction; NewAddr: PByte): Integer; end; ops32bits: begin - Offset := Int64(UInt64(PInst^.Branch.Target) - UInt64(PQ) - 6); + Offset := Int64(Int64(PInst^.Branch.Target) - Int64(PQ) - 6); PUInt16(PQ)^ := UInt16(NOpc); Inc(PQ, 2); PInt32(PQ)^ := Int32(Offset); @@ -1371,9 +1309,9 @@ function CorrectJ(PInst: PInstruction; NewAddr: PByte): Integer; Inc(PQ); PQ^ := 2; Inc(PQ); - JmpType := GetJmpType(NewAddr + 4, PInst^.Branch.Target, NewAddr + 4 + 6); + JmpType := GetJmpType(PByte(NativeInt(NewAddr) + 4), PInst^.Branch.Target, PByte(NativeInt(NewAddr) + 4 + 6)); JmpSize := JmpTypeToSize[JmpSize]; - if JmpType > tJmpRel32 then + if JmpType > JT_REL32 then Inc(JmpSize, SizeOf(Pointer)); { Jmp To Next Valid Instruction ! } @@ -1381,8 +1319,7 @@ function CorrectJ(PInst: PInstruction; NewAddr: PByte): Integer; Inc(PQ); PQ^ := JmpSize; Inc(PQ); - - InsertJmp(NewAddr + 4, PInst^.Branch.Target, JmpType, NewAddr + 4 + 6); + InsertJmp(PByte(NativeInt(NewAddr) + 4), PInst^.Branch.Target, JmpType, PByte(NativeInt(NewAddr) + 4 + 6)); Inc(PQ, JmpSize); end; end; @@ -1390,7 +1327,7 @@ function CorrectJ(PInst: PInstruction; NewAddr: PByte): Integer; finally FreeMem(POpc); end; - Result := PQ - NewAddr; + Result := Integer(NativeInt(PQ) - NativeInt(NewAddr)); if Result = 00 then begin Move(PInst^.Addr^, NewAddr^, PInst^.InstSize); @@ -1404,8 +1341,6 @@ function MakeModRm(iMod, Reg, Rm: Byte): Byte; {$IFDEF MustInline}inline; {$ENDI end; function CorrectRipDisp(PInst: PInstruction; NewAddr: PByte): Integer; -type - PNativeUInt = ^NativeUInt; var Offset: Int64; P: PByte; @@ -1427,9 +1362,9 @@ function CorrectRipDisp(PInst: PInstruction; NewAddr: PByte): Integer; if PInst^.AddrMode = am32 then P := PByte(UInt64(P) and $FFFFFFFF); - P := P + Int64(PInst^.Disp.Value); + P := PByte(Int64(P) + Int64(PInst^.Disp.Value)); - Offset := Int64(UInt64(P) - UInt64(NewAddr) - PInst^.InstSize); + Offset := Int64(Int64(P) - Int64(NewAddr) - PInst^.InstSize); if Int32(Offset) <> Offset then begin rReg := rEAX; @@ -1447,17 +1382,17 @@ function CorrectRipDisp(PInst: PInstruction; NewAddr: PByte): Integer; PByte(NewAddr)^ := $48; // REX.W! Inc(NewAddr); {$ENDIF CPUX64} - { MOV REG,Imm(NativeUInt) } + { MOV REG,Imm(NativeInt) } PByte(NewAddr)^ := $B8 + (rReg and $7); Inc(NewAddr); - PNativeUInt(NewAddr)^ := NativeUInt(P); - Inc(NewAddr, SizeOf(NativeUInt)); + PNativeInt(NewAddr)^ := NativeInt(P); + Inc(NewAddr, SizeOf(NativeInt)); { Set the original instruction opcodes } POpc := GetMemory(MAX_INST_LENGTH_N); L := GetInstOpCodes(PInst, POpc); - Move(PByte(@POpc[0])^, NewAddr^, L); + Move(POpc^, NewAddr^, L); Inc(NewAddr, L); pMR := NewAddr; if (PInst^.OpKind and kGrp <> 0) or (PInst^.OpTable = tbFPU) then @@ -1472,14 +1407,15 @@ function CorrectRipDisp(PInst: PInstruction; NewAddr: PByte): Integer; Inc(NewAddr); FreeMemory(POpc); - Exit(NewAddr - pFrst); + Result := (NativeInt(NewAddr) - NativeInt(pFrst)); + Exit; end else - raise InterceptException.Create(ErrRipDisp); + raise InterceptException.Create(SErrorRipDisp); end; Move(PInst^.Addr^, NewAddr^, PInst^.InstSize); Inc(NewAddr, PInst^.InstSize); - PInt32(NewAddr - SizeOf(Int32))^ := Int32(Offset); + PInt32(NativeInt(NewAddr) - SizeOf(Int32))^ := Int32(Offset); Result := PInst^.InstSize; end; @@ -1488,8 +1424,8 @@ function CorrectJmpRel(PInst: PInstruction; NewAddr: PByte): Integer; var JmpType: Byte; begin - JmpType := GetJmpType(NewAddr, PInst^.Branch.Target, NewAddr + 6); - InsertJmp(NewAddr, PInst^.Branch.Target, JmpType, NewAddr + 6); + JmpType := GetJmpType(NewAddr, PInst^.Branch.Target, PByte(NativeInt(NewAddr) + 6)); + InsertJmp(NewAddr, PInst^.Branch.Target, JmpType, PByte(NativeInt(NewAddr) + 6)); Result := JmpTypeToSize[JmpType]; end; @@ -1500,7 +1436,7 @@ function CorrectCallRel(PInst: PInstruction; NewAddr: PByte): Integer; P: PByte; begin P := NewAddr; - Offset := Int64(UInt64(PInst^.Branch.Target) - UInt64(P) - 6); + Offset := Int64(Int64(PInst^.Branch.Target) - Int64(P) - 6); Relsz := GetInt64Size(Offset); {$IFDEF CPUX64} { Only 32-bits relative offset is supported on x64! } @@ -1514,7 +1450,7 @@ function CorrectCallRel(PInst: PInstruction; NewAddr: PByte): Integer; case Relsz of ops16bits: begin - Offset := Int64(UInt64(PInst^.Branch.Target) - UInt64(P) - 4); + Offset := Int64(Int64(PInst^.Branch.Target) - Int64(P) - 4); P^ := opPrfOpSize; Inc(P); P^ := $E8; @@ -1524,7 +1460,7 @@ function CorrectCallRel(PInst: PInstruction; NewAddr: PByte): Integer; end; ops32bits: begin - Offset := Int64(UInt64(PInst^.Branch.Target) - UInt64(P) - 5); + Offset := Int64(Int64(PInst^.Branch.Target) - Int64(P) - 5); P^ := $E8; Inc(P); PInt32(P)^ := Int32(Offset); @@ -1565,7 +1501,7 @@ function CorrectCallRel(PInst: PInstruction; NewAddr: PByte): Integer; Inc(P, SizeOf(UInt64)); end; end; - Result := P - NewAddr; + Result := NativeInt(P) - NativeInt(NewAddr); if Result = 0 then begin Move(PInst^.Addr^, P^, PInst^.InstSize); @@ -1618,30 +1554,29 @@ function MapInsts(Addr, NewAddr: PByte; Size: Integer): Integer; FreeMemory(PInst); end; -const - arNone = $00; - arPlus = $08; - arMin = $10; - arAdd = arPlus or $01; - arSub = arMin or $01; - arInc = arPlus or $02; - arDec = arMin or $02; - +{$IFNDEF FPC} {$WARN COMPARISON_TRUE OFF} +{$ENDIF FPC} -function GetInstArithmeticType(PInst: PInstruction): Byte; +function GetInstArithmeticType(PInst: PInstruction): Integer; function IsInstAdd(PInst: PInstruction): Boolean; begin Result := False; if PInst^.OpTable = tbOneByte then begin if (PInst^.OpCode >= $00) and (PInst^.OpCode < $06) then - Exit(True); + begin + Result := (True); + Exit; + end; end; if (PInst^.OpKind = kGrp) and (PInst^.ModRm.Reg = $00) then begin if (PInst^.OpCode > $7F) and (PInst^.OpCode < $84) then - Exit(True); + begin + Result := (True); + Exit; + end; end; end; function IsInstSub(PInst: PInstruction): Boolean; @@ -1650,12 +1585,18 @@ function GetInstArithmeticType(PInst: PInstruction): Byte; if PInst^.OpTable = tbOneByte then begin if (PInst^.OpCode > $27) and (PInst^.OpCode < $2E) then - Exit(True); + begin + Result := (True); + Exit; + end; end; if (PInst^.OpKind = kGrp) and (PInst^.ModRm.Reg = $05) then begin if (PInst^.OpCode > $7F) and (PInst^.OpCode < $84) then - Exit(True); + begin + Result := (True); + Exit; + end; end; end; function IsInstInc(PInst: PInstruction): Boolean; @@ -1664,12 +1605,18 @@ function GetInstArithmeticType(PInst: PInstruction): Byte; if (PInst^.Archi = CPUX32) and (PInst^.OpTable = tbOneByte) then begin if (PInst^.OpCode >= $40) and (PInst^.OpCode <= $47) then - Exit(True); + begin + Result := (True); + Exit; + end; end; if (PInst^.OpKind = kGrp) and (PInst^.ModRm.Reg = $00) then begin if (PInst^.OpCode = $FE) or (PInst^.OpCode = $FF) then - Exit(True); + begin + Result := (True); + Exit; + end; end; end; function IsInstDec(PInst: PInstruction): Boolean; @@ -1678,37 +1625,45 @@ function GetInstArithmeticType(PInst: PInstruction): Byte; if (PInst^.Archi = CPUX32) and (PInst^.OpTable = tbOneByte) then begin if (PInst^.OpCode >= $48) and (PInst^.OpCode <= $4F) then - Exit(True); + begin + Result := (True); + Exit; + end; end; if (PInst^.OpKind = kGrp) and (PInst^.ModRm.Reg = $01) then begin if (PInst^.OpCode = $FE) or (PInst^.OpCode = $FF) then - Exit(True); + begin + Result := (True); + Exit; + end; end; end; begin { Return Instruction Arithmetic (+ or - or ..) } Result := arNone; - if IsInstAdd(PInst) then - Exit(arAdd); - if IsInstInc(PInst) then - Exit(arAdd); - if IsInstSub(PInst) then - Exit(arSub); - if IsInstDec(PInst) then - Exit(arSub); + if IsInstAdd(PInst) or IsInstInc(PInst) then + Result := (arAdd) + else if IsInstSub(PInst) or IsInstDec(PInst) then + Result := (arSub); end; +{$IFNDEF FPC} {$WARN COMPARISON_TRUE ON} +{$ENDIF FPC} -function EvalArithU(Arith: Byte; Value: NativeUInt; Offset: NativeInt): NativeUInt; +function EvalArith(Arith: Integer; Value: NativeInt; Offset: NativeInt): NativeInt; begin Result := Value; case Arith of - arAdd: Inc(Result, Offset); - arInc: Inc(Result); - arSub: Dec(Result, Offset); - arDec: Dec(Result); + arAdd: + Inc(Result, Offset); + arInc: + Inc(Result); + arSub: + Dec(Result, Offset); + arDec: + Dec(Result); end; end; @@ -1732,22 +1687,23 @@ function InterfaceToObj(const AIntf): TObject; Inst: TInstruction; PObj: PByte; imm: Int64; - Arith: Byte; + Arith: Integer; Skip: Boolean; sReg: ShortInt; begin if not Assigned(@AIntf) then - Exit(nil); + begin + Result := nil; + Exit; + end; sReg := -1; PObj := PByte(AIntf); -{$IFNDEF FPC} - Inst := default (TInstruction); -{$ENDIF !FPC} + FillChar(Inst, SizeOf(TInstruction), #00); Inst.Archi := CPUX; Pvt := PPointer(AIntf)^; // vTable ! - PCode := PPointer(Pvt + Offset)^; // Code Entry ! + PCode := PPointer(NativeInt(Pvt) + Offset)^; // Code Entry ! Inst.NextInst := PCode; { At the top of code entry delphi will generate : @@ -1763,7 +1719,7 @@ function InterfaceToObj(const AIntf): TObject; fDecodeInst(@Inst); { Keep looping until JMP/RET ! } if (Inst.Branch.Falgs and bfUsed <> 0) or (Inst.OpType = otRET) then - Break; + break; Arith := GetInstArithmeticType(@Inst); Skip := (Arith = arNone); @@ -1800,7 +1756,7 @@ function InterfaceToObj(const AIntf): TObject; if not Skip then begin imm := Inst.imm.Value; - PObj := PByte(EvalArithU(Arith, NativeUInt(PObj), imm)); + PObj := PByte(EvalArith(Arith, NativeInt(PObj), imm)); end; end; @@ -1822,13 +1778,10 @@ function GetInterfaceMethodPtrByIndex(const PInterface; MethodIndex: Integer): P => Return first instruction that was implemented on Interface object ! } -{$IFNDEF FPC} - Inst := default (TInstruction); -{$ENDIF !FPC} + FillChar(Inst, SizeOf(TInstruction), #00); Inst.Archi := CPUX; Pvt := PPointer(PInterface)^; // Virtual Table ! P := Pvt; - // Inc(PByte(P), MethodIndex * SizeOf(NativeUInt)); Inc(P, MethodIndex); P := PPointer(P)^; PDst := PByte(P); @@ -1840,13 +1793,13 @@ function GetInterfaceMethodPtrByIndex(const PInterface; MethodIndex: Integer): P if Assigned(Inst.Branch.Target) then begin PDst := Inst.Branch.Target; - Break; + break; end; end; Result := PDst; end; -{$IFDEF MustUseGenerics} +{$IFDEF SUPPORTS_RTTI} function GetMethodPtrFromObjByName(Obj: TObject; const MethodName: String): Pointer; var @@ -1865,7 +1818,10 @@ function GetMethodPtrFromObjByName(Obj: TObject; const MethodName: String): Poin for LMethod in LMethods do begin if SameText(LMethod.Name, MethodName) then - Exit(LMethod.CodeAddress); + begin + Result := LMethod.CodeAddress; + Exit; + end; end; end; @@ -1883,68 +1839,42 @@ function GetInterfaceMethodPtrByName(const PInterface; const MethodName: String) end; end; -var - GlobalThreadList: TDictionary<THandle, TThreadsIDList>; - -{$ENDIF MustUseGenerics} - { TIntercept } +{$ENDIF SUPPORTS_RTTI} -constructor TIntercept.Create(Options: Byte); +function GetRoot(P: PByte): PByte; +var + Inst: TInstruction; begin - FOptions := Options; - FList := nil; - - if (FOptions and ST = ST) -{$IFDEF MustUseGenerics} - and (not GlobalThreadList.ContainsKey(GetCurrentThread)) -{$ENDIF MustUseGenerics} - then - begin - { Suspend All threads ! } - if OpenThreadExist then - begin - FList := TThreadsIDList.Create; - SuspendAllThreads(FList); - end; - end; - - if not Assigned(FList) then - begin - TInterceptMonitor.Enter(); - end; + Result := P; + FillChar(Inst, SizeOf(TInstruction), #00); + Inst.Addr := P; + Inst.Archi := CPUX; + Inst.VirtualAddr := nil; + { + While the opcode is jmp and the jmp destination + address is known get the next jmp . + } + fDecodeInst(@Inst); + if (Inst.OpType = otJMP) and (Assigned(Inst.Branch.Target)) then + Result := GetRoot(Inst.Branch.Target); end; -destructor TIntercept.Destroy; +function IsValidDescriptor(P: PByte): Boolean; begin - if Assigned(FList) then - begin - ResumeSuspendedThreads(FList); - FreeAndNil(FList); - end else begin - TInterceptMonitor.Leave(); - end; - inherited; + Result := CompareMem(P, PByte(@DscrSig[0]), SizeOf(DscrSig)); end; -function TIntercept.GetDescriptor(P: PByte): PDescriptor; +function GetDescriptor(P: PByte): PDescriptor; var Inst: TInstruction; function IsDscrpInst(PInst: PInstruction): Boolean; begin - Result := -{$IFDEF UseMultiBytesNop} - (IsNop(PInst.Addr, 6, True)) or -{$ELSE !UseMultiBytesNop} - (IsNop(PInst.Addr, 6)) or -{$ENDIF UseMultiBytesNop} - (Assigned(PInst.Branch.Target)); + Result := Assigned(PInst.Branch.Target) or IsNop(PInst.Addr, 6); end; begin Result := nil; -{$IFNDEF FPC} - Inst := default (TInstruction); -{$ENDIF !FPC} + FillChar(Inst, SizeOf(TInstruction), #00); Inst.Archi := CPUX; Inst.VirtualAddr := nil; { Find last JMP ! } @@ -1969,39 +1899,11 @@ function TIntercept.GetDescriptor(P: PByte): PDescriptor; end; end; -class function TIntercept.GetRoot(P: PByte): PByte; -var - Inst: TInstruction; -begin - Result := P; -{$IFNDEF FPC} - Inst := default (TInstruction); -{$ENDIF !FPC} - Inst.Addr := P; - Inst.Archi := CPUX; - Inst.VirtualAddr := nil; - { - While the opcode is jmp and the jmp destination - address is known get the next jmp . - } - fDecodeInst(@Inst); - if (Inst.OpType = otJMP) and (Assigned(Inst.Branch.Target)) then - Result := GetRoot(Inst.Branch.Target); -end; - -function TIntercept.CreateNewDescriptor: PDescriptor; +function CreateNewDescriptor(): PDescriptor; begin { Create a new descriptor tables ! } Result := AllocMem(SizeOf(TDescriptor)); - { - Hahaha .. this stupid code (between commenet) - had take me 2h to figure why my libray does not works ! - I didn't know what i was thinking in when i wrote this code ! - :) - } - // SetMemPermission(Result, SizeOf(TDescriptor), PAGE_READWRITE); - // SetMemPermission(@Result^.JmpMems, SizeOf(TJmpMem) * (MAX_HOOKS + 1), PAGE_EXECUTE_READWRITE); - FillNop(Result^, SizeOf(TDescriptor)); + FillNop(Result^, SizeOf(TDescriptor), False); FillNop(Result^.JmpMems[0], SizeOf(TJmpMem) * (MAX_HOOKS + 1), True); { A valid descriptor have a valid signature . } @@ -2011,7 +1913,7 @@ function TIntercept.CreateNewDescriptor: PDescriptor; Result^.ExMem := nil; end; -procedure TIntercept.InsertDescriptor(PAt: PByte; PDscr: PDescriptor); +procedure InsertDescriptor(PAt: PByte; PDscr: PDescriptor); const { JMP from Target to Code Entry } kJmpCE = 1; @@ -2038,7 +1940,6 @@ procedure TIntercept.InsertDescriptor(PAt: PByte; PDscr: PDescriptor); PExMem: PByte; LPExMem: PByte; begin - JmpKind := kJmpCE; Sb := 0; P := PAt; PDscr^.OrgPtr := P; @@ -2046,12 +1947,8 @@ procedure TIntercept.InsertDescriptor(PAt: PByte; PDscr: PDescriptor); {$IFDEF CPUX64} Tmp := nil; PExMem := TryAllocMemAt(P, SizeOfAlloc, PAGE_EXECUTE_READWRITE); -{$ELSE !CPUX64} - PExMem := TryAllocMemAt(nil, SizeOfAlloc, PAGE_EXECUTE_READWRITE); -{$ENDIF CPUX64} LPExMem := PExMem; -{$IFDEF CPUX64} - sJmpType := tJmpNone; + sJmpType := JT_NONE; JmpKind := kJmpRipZCE; { Try to find the perfect jump instruction ! } { @@ -2074,13 +1971,17 @@ procedure TIntercept.InsertDescriptor(PAt: PByte; PDscr: PDescriptor); JmpKind := kJmpTmpJmpCE; end; end; - end else begin + end + else + begin JmpKind := kJmpCE; end; +{$ELSE !CPUX64} + PExMem := TryAllocMemAt(nil, SizeOfAlloc, PAGE_EXECUTE_READWRITE); + JmpKind := kJmpCE; + LPExMem := PExMem; {$ENDIF CPUX64} -{$IFNDEF FPC} - Inst := default (TInstruction); -{$ENDIF !FPC} + FillChar(Inst, SizeOf(TInstruction), #00); Inst.Archi := CPUX; Inst.NextInst := P; Inst.VirtualAddr := nil; @@ -2090,21 +1991,21 @@ procedure TIntercept.InsertDescriptor(PAt: PByte; PDscr: PDescriptor); while Sb < JmpSize do begin if Inst.OpType = otRET then - raise InterceptException.Create(ErrFuncSize); + raise InterceptException.Create(SErrorSmallFunctionSize); Inst.Addr := Inst.NextInst; Inc(Sb, fDecodeInst(@Inst)); end; if Sb > TrampoSize then - raise InterceptException.Create(ErrTrampoSize); + raise InterceptException.Create(SErrorBigTrampoSize); { Trampoline momory } T := PExMem; - FillNop(T^, TrampoSize); + FillNop(T^, TrampoSize, False); PDscr^.Trampo := AllocMem(SizeOf(TTrampoInfo)); PDscr^.Trampo^.PData := AllocMem(Sb + 6); - FillNop(PDscr^.Trampo^.PData^, Sb + 6); + FillNop(PDscr^.Trampo^.PData^, Sb + 6, False); { Save original target routine instruction . } Move(P^, PDscr^.Trampo^.PData^, Sb); PDscr^.Trampo^.Addr := T; // Pointer to the first trampoline instruction. @@ -2113,7 +2014,7 @@ procedure TIntercept.InsertDescriptor(PAt: PByte; PDscr: PDescriptor); Tsz := MapInsts(P, T, Sb); OrgAccess := SetMemPermission(P, Sb, PAGE_EXECUTE_READWRITE); try - FillNop(P^, Sb); + FillNop(P^, Sb, False); case JmpKind of kJmpCE: begin @@ -2144,10 +2045,10 @@ procedure TIntercept.InsertDescriptor(PAt: PByte; PDscr: PDescriptor); JMP @Tmp ==> Tmp is allocated nearly from TargetProc ! Tmp: - JMP @PDscr^.CodeEntry ==> tJmpRipZ + JMP @PDscr^.CodeEntry ==> JT_RIPZ } InsertJmp(P, Tmp, fJmpType, Tmp + 6); - InsertJmp(Tmp, @PDscr^.CodeEntry, tJmpRipZ, nil); + InsertJmp(Tmp, @PDscr^.CodeEntry, JT_RIPZ, nil); end; kJmpRipZCE: begin @@ -2155,9 +2056,9 @@ procedure TIntercept.InsertDescriptor(PAt: PByte; PDscr: PDescriptor); Not a good jump ! TargetProc : - JMP @PDscr^.CodeEntry ==> tJmpRipZ + JMP @PDscr^.CodeEntry ==> JT_RIPZ } - InsertJmp(P, @PDscr^.CodeEntry, tJmpRipZ, nil); + InsertJmp(P, @PDscr^.CodeEntry, JT_RIPZ, nil); end; {$ENDIF CPUX64} end; @@ -2169,10 +2070,9 @@ procedure TIntercept.InsertDescriptor(PAt: PByte; PDscr: PDescriptor); executing originals instructions. } {$IFDEF CPUX64} - // InsertJmp(T + Tsz, P + JmpTypeToSize[fJmpType], tJmpRipZ); - InsertJmp(T + Tsz, P + Sb, tJmpRipZ); + InsertJmp(T + Tsz, P + Sb, JT_RIPZ); {$ELSE !CPUX64} - InsertJmp(T + Tsz, P + Sb, tJmpMem32, T + Tsz + 6); + InsertJmp(PByte(NativeInt(T) + Tsz), PByte(NativeInt(P) + Sb), JT_MEM32, PByte(NativeInt(T) + Tsz + 6)); {$ENDIF CPUX64} { Save LPExMem ==> we need it when deleting descriptor } PDscr^.ExMem := LPExMem; @@ -2184,15 +2084,39 @@ procedure TIntercept.InsertDescriptor(PAt: PByte; PDscr: PDescriptor); end; end; -function TIntercept.IsValidDescriptor(P: PByte): Boolean; +procedure MadExceptFreeMem(P: Pointer); +var + Page: Pointer; + mbi: TMemoryBasicInformation; + Permission: DWORD; +begin + if InternalFuncs.VirtualQuery(P, mbi, SizeOf(mbi)) <> 0 then + begin + Page := mbi.BaseAddress; + Permission := SetMemPermission(Page, SysInfo.dwPageSize, PAGE_READWRITE); + FreeMem(P); + SetMemPermission(Page, SysInfo.dwPageSize, Permission); + end + else + FreeMem(P); +end; + +function GetNextHookPtrFromTrampoline(TrampoLine: Pointer): PNextHook; begin - Result := CompareMem(P, PByte(@DscrSig[0]), SizeOf(DscrSig)); + if Assigned(TrampoLine) then + begin + Result := PNextHook(NativeInt(TrampoLine) - SizeOf(TNextHook)); + if Result^.Signature = TrampolineSignature then + Exit; + end; + raise DetourException.Create(SErrorInvalidTrampoline); end; -function TIntercept.AddHook(PDscr: PDescriptor; InterceptProc: PByte; const Options: Byte): PByte; +function AddHook(PDscr: PDescriptor; InterceptProc: PByte; Param: Pointer; Options: TInterceptOptions): PByte; var n: ShortInt; NxHook: PByte; + LTlsRecursionLevelIndex: DWORD; begin { Return a pointer to a function that can @@ -2200,45 +2124,57 @@ function TIntercept.AddHook(PDscr: PDescriptor; InterceptProc: PByte; const Opti } n := PDscr^.nHook; if n + 1 > MAX_HOOKS then - raise InterceptException.Create(ErrMaxHook); + raise InterceptException.Create(SErrorMaxHook); { Alloc memory for the NextHook ! } NxHook := AllocMem(TrampoSize); Result := NxHook; - FillNop(Result^, TrampoSize); + FillNop(Result^, TrampoSize, False); PNextHook(Result)^.PDscr := PDscr; PNextHook(Result)^.ID := n + 1; + PNextHook(Result)^.threadid := GetCurrentThreadId(); + PNextHook(Result)^.Param := Param; + PNextHook(Result)^.Signature := TrampolineSignature; + PNextHook(Result)^.InterceptOptions := Options; + if ioRecursive in Options then + begin + LTlsRecursionLevelIndex := TlsAlloc(); + if LTlsRecursionLevelIndex <> TLS_OUT_OF_INDEXES then + PNextHook(Result)^.TlsRecursionLevelIndex := LTlsRecursionLevelIndex + else + raise DetourException.Create(SErrorTlsOutOfIndexes); + end; Inc(Result, SizeOf(TNextHook)); { Redirect code to InterceptProc ! } - InsertJmp(@PDscr^.JmpMems[n], InterceptProc, tJmpMemN, @PDscr^.JmpAddrs[n]); + InsertJmp(@PDscr^.JmpMems[n], InterceptProc, JT_MEMN, @PDscr^.JmpAddrs[n]); { Redirect code to TrampoLine ! } - InsertJmp(@PDscr^.JmpMems[n + 1], PDscr^.Trampo^.Addr, tJmpMemN, @PDscr^.JmpAddrs[n + 1]); + InsertJmp(@PDscr^.JmpMems[n + 1], PDscr^.Trampo^.Addr, JT_MEMN, @PDscr^.JmpAddrs[n + 1]); { Redirect code to next hook ! } - InsertJmp(Result, @PDscr^.JmpMems[n + 1], tJmpMemN, Result + 6); + InsertJmp(Result, @PDscr^.JmpMems[n + 1], JT_MEMN, PByte(NativeInt(Result) + 6)); Inc(PDscr^.nHook); - SetMemPermission(Result, JmpTypeToSize[tJmpRipZ], PAGE_EXECUTE_READWRITE); + SetMemPermission(Result, JmpTypeToSize[JT_RIPZ], PAGE_EXECUTE_READWRITE); end; -function TIntercept.InstallHook(TargetProc, InterceptProc: PByte; const Options: Byte = $00): PByte; +function InstallHook(TargetProc, InterceptProc: PByte; Param: Pointer; Options: TInterceptOptions): PByte; var P: PByte; PDscr: PDescriptor; begin if not Assigned(TargetProc) then - raise InterceptException.Create(ErrTargetProc); + raise InterceptException.Create(SErrorInvalidTargetProc); if not Assigned(InterceptProc) then - raise InterceptException.Create(ErrInterceptProc); + raise InterceptException.Create(SErrorInvalidInterceptProc); PDscr := GetDescriptor(TargetProc); if not Assigned(PDscr) then begin P := GetRoot(TargetProc); - PDscr := CreateNewDescriptor; + PDscr := CreateNewDescriptor(); try InsertDescriptor(P, PDscr); except @@ -2246,10 +2182,10 @@ function TIntercept.InstallHook(TargetProc, InterceptProc: PByte; const Options: raise; end; end; - Result := AddHook(PDscr, InterceptProc); + Result := AddHook(PDscr, InterceptProc, Param, Options); end; -procedure TIntercept.RemoveDescriptor(PDscr: PDescriptor); +procedure RemoveDescriptor(PDscr: PDescriptor); var OrgAccess: DWORD; P: PByte; @@ -2266,7 +2202,7 @@ procedure TIntercept.RemoveDescriptor(PDscr: PDescriptor); { Restore the old stolen instructions ! } Move(PDscr^.Trampo^.PData^, PDscr^.OrgPtr^, PDscr^.Trampo^.Size); - FillNop(PDscr^.ExMem^, SizeOfAlloc); + FillNop(PDscr^.ExMem^, SizeOfAlloc, False); FreeMem(PDscr^.Trampo^.PData); FreeMem(PDscr^.Trampo); @@ -2277,29 +2213,33 @@ procedure TIntercept.RemoveDescriptor(PDscr: PDescriptor); RaiseLastOSError; end; - FillNop(PDscr^, SizeOf(TDescriptor)); + FillNop(PDscr^, SizeOf(TDescriptor), False); +{$IFDEF FIX_MADEXCEPT} + MadExceptFreeMem(PDscr); +{$ELSE !FIX_MADEXCEPT} FreeMem(PDscr); +{$ENDIF FIX_MADEXCEPT} finally SetMemPermission(P, sz, OrgAccess); end; end; -function TIntercept.RemoveHook(Trampo: PByte): Integer; +function RemoveHook(TrampoLine: PByte): Integer; var PNxtHook: PNextHook; PDscr: PDescriptor; n: Byte; begin - if not Assigned(Trampo) then - raise InterceptException.Create(ErrInvalidTrampo); + if not Assigned(TrampoLine) then + raise InterceptException.Create(SErrorInvalidTrampoline); - PNxtHook := PNextHook(Trampo - SizeOf(TNextHook)); + PNxtHook := GetNextHookPtrFromTrampoline(TrampoLine); if not Assigned(PNxtHook) then - raise InterceptException.Create(ErrInvalidTrampo); + raise InterceptException.Create(SErrorInvalidTrampoline); PDscr := PNxtHook^.PDscr; if not IsValidDescriptor(PByte(PDscr)) then - raise InterceptException.Create(ErrInvalidDscr); + raise InterceptException.Create(SErrorInvalidDescriptor); n := PNxtHook^.ID; Dec(PDscr^.nHook); @@ -2317,24 +2257,27 @@ function TIntercept.RemoveHook(Trampo: PByte): Integer; if Result = 0 then RemoveDescriptor(PDscr); - FreeMem(PNxtHook); + if ioRecursive in PNxtHook^.InterceptOptions then + TlsFree(PNxtHook^.TlsRecursionLevelIndex); + +{$IFDEF FIX_MADEXCEPT} + MadExceptFreeMem(PNxtHook); +{$ELSE !FIX_MADEXCEPT} + FreeMem(PNxtHook); +{$ENDIF FIX_MADEXCEPT} + end; -function InterceptCreate(const TargetProc, InterceptProc: Pointer; Options: Byte = v1compatibility): Pointer; -var - Intercept: TIntercept; +{ ======================================= InterceptCreate ======================================= } + +function InterceptCreate(const TargetProc, InterceptProc: Pointer; const Param: Pointer = nil; + const Options: TInterceptOptions = DefaultInterceptOptions): Pointer; begin - Intercept := TIntercept.Create(Options); - try - Result := Intercept.InstallHook(TargetProc, InterceptProc, Options); - finally - Intercept.Free; - end; + Result := InstallHook(TargetProc, InterceptProc, Param, Options); end; -{ =====> Support for Interface <===== } - -function InterceptCreate(const TargetInterface; MethodIndex: Integer; const InterceptProc: Pointer; Options: Byte = v1compatibility): Pointer; +function InterceptCreate(const TargetInterface; MethodIndex: Integer; const InterceptProc: Pointer; const Param: Pointer = nil; + const Options: TInterceptOptions = DefaultInterceptOptions): Pointer; var P: PByte; begin @@ -2344,28 +2287,12 @@ function InterceptCreate(const TargetInterface; MethodIndex: Integer; const Inte P := GetInterfaceMethodPtrByIndex(TargetInterface, MethodIndex); if Assigned(P) then begin - Result := InterceptCreate(P, InterceptProc, Options); + Result := InterceptCreate(P, InterceptProc, Param, Options); end; end; -{$IFDEF MustUseGenerics} - -function InterceptCreate(const TargetInterface; const MethodName: String; const InterceptProc: Pointer; Options: Byte = v1compatibility): Pointer; overload; -var - P: PByte; -begin - Result := nil; - if (not Assigned(@TargetInterface)) or (MethodName = EmptyStr) then - Exit; - - P := GetInterfaceMethodPtrByName(TargetInterface, MethodName); - if Assigned(P) then - Result := InterceptCreate(P, InterceptProc, Options); -end; -{$ENDIF MustUseGenerics} - -function InterceptCreate(const Module, MethodName: string; const InterceptProc: Pointer; ForceLoadModule: Boolean = True; - Options: Byte = v1compatibility): Pointer; +function InterceptCreate(const Module, MethodName: string; const InterceptProc: Pointer; const Param: Pointer = nil; + const Options: TInterceptOptions = DefaultInterceptOptions): Pointer; var pOrgPointer: Pointer; LModule: THandle; @@ -2373,88 +2300,95 @@ function InterceptCreate(const Module, MethodName: string; const InterceptProc: { RRUZ's idea ==> Looks great ! } Result := nil; LModule := GetModuleHandle(PChar(Module)); - if (LModule = 0) and ForceLoadModule then + if (LModule = 0) and (ioForceLoad in Options) then LModule := LoadLibrary(PChar(Module)); if LModule <> 0 then begin pOrgPointer := GetProcAddress(LModule, PChar(MethodName)); if Assigned(pOrgPointer) then - Result := InterceptCreate(pOrgPointer, InterceptProc, Options); + Result := InterceptCreate(pOrgPointer, InterceptProc, Param, Options); end; end; -procedure InterceptCreate(const TargetProc, InterceptProc: Pointer; var TrampoLine: Pointer; Options: Byte = v1compatibility); -var - Intercept: TIntercept; +procedure InterceptCreate(const TargetProc, InterceptProc: Pointer; var TrampoLine: Pointer; const Param: Pointer = nil; + const Options: TInterceptOptions = DefaultInterceptOptions); begin - Intercept := TIntercept.Create(Options); - try - TrampoLine := Intercept.InstallHook(TargetProc, InterceptProc, Options); - finally - Intercept.Free; - end; + TrampoLine := InstallHook(TargetProc, InterceptProc, Param, Options); end; -function InterceptRemove(const Trampo: Pointer; Options: Byte = v1compatibility): Integer; +{$IFDEF SUPPORTS_RTTI} + +function InterceptCreate(const TargetInterface; const MethodName: String; const InterceptProc: Pointer; const Param: Pointer = nil; + const Options: TInterceptOptions = DefaultInterceptOptions): Pointer; overload; var - Intercept: TIntercept; + P: PByte; begin - if not Assigned(Trampo) then - Exit(-1); - Intercept := TIntercept.Create(Options); - try - Result := Intercept.RemoveHook(Trampo); - finally - Intercept.Free; - end; + { Interface support } + Result := nil; + if (not Assigned(@TargetInterface)) or (MethodName = EmptyStr) then + Exit; + + P := GetInterfaceMethodPtrByName(TargetInterface, MethodName); + if Assigned(P) then + Result := InterceptCreate(P, InterceptProc); end; -function GetNHook(const TargetProc: Pointer): ShortInt; +{$ENDIF SUPPORTS_RTTI} +{ ======================================= InterceptRemove ======================================= } + +function InterceptRemove(const TrampoLine: Pointer): Integer; +begin + if Assigned(TrampoLine) then + Result := RemoveHook(TrampoLine) + else + Result := -1; +end; + +{ ======================================= GetHookCount ======================================= } + +function GetHookCount(const TargetProc: Pointer): Integer; var - Intercept: TIntercept; PDscr: PDescriptor; begin - { - Return the number of installed hooks ! - Return -1 if no hooks installed ! - } - Result := -1; - if not Assigned(TargetProc) then - raise InterceptException.Create(ErrTargetProc); - - Intercept := TIntercept.Create(0); - try - PDscr := Intercept.GetDescriptor(TargetProc); + { Return the number of installed hooks. } + if Assigned(TargetProc) then + begin + PDscr := GetDescriptor(TargetProc); if Assigned(PDscr) then + begin Result := PDscr^.nHook; - finally - Intercept.Free; - end; + Exit; + end; + end + else + raise InterceptException.Create(SErrorInvalidTargetProc); + Result := 0; end; -function GetNHook(const TargetInterface; MethodIndex: Integer): ShortInt; overload; +function GetHookCount(const TargetInterface; MethodIndex: Integer): Integer; overload; var P: PByte; begin P := GetInterfaceMethodPtrByIndex(TargetInterface, MethodIndex); - Result := GetNHook(P); + Result := GetHookCount(P); end; +{$IFDEF SUPPORTS_RTTI} -{$IFDEF MustUseGenerics } - -function GetNHook(const TargetInterface; const MethodName: String): ShortInt; overload; +function GetHookCount(const TargetInterface; const MethodName: String): Integer; overload; var P: PByte; begin + { Interface support } P := GetInterfaceMethodPtrByName(TargetInterface, MethodName); - Result := GetNHook(P); + Result := GetHookCount(P); end; -{$ENDIF MustUseGenerics } +{$ENDIF SUPPORTS_RTTI} +{ ======================================= IsHooked ======================================= } function IsHooked(const TargetProc: Pointer): Boolean; begin - Result := GetNHook(TargetProc) > 0; + Result := GetHookCount(TargetProc) > 0; end; function IsHooked(const TargetInterface; MethodIndex: Integer): Boolean; overload; @@ -2465,24 +2399,18 @@ function IsHooked(const TargetInterface; MethodIndex: Integer): Boolean; overloa Result := IsHooked(P); end; -{$IFDEF MustUseGenerics } +{$IFDEF SUPPORTS_RTTI} function IsHooked(const TargetInterface; const MethodName: String): Boolean; overload; var P: PByte; begin + { Interface support } P := GetInterfaceMethodPtrByName(TargetInterface, MethodName); Result := IsHooked(P); end; -{$ENDIF MustUseGenerics } - -type - TTrampoDataVt = record - vAddr: Pointer; - Addr: Pointer; - end; - - PTrampoDataVt = ^TTrampoDataVt; +{$ENDIF SUPPORTS_RTTI} +{ ======================================= Patch ======================================= } function PatchVt(const TargetInterface; MethodIndex: Integer; InterceptProc: Pointer): Pointer; var @@ -2502,7 +2430,6 @@ function PatchVt(const TargetInterface; MethodIndex: Integer; InterceptProc: Poi if not Assigned(InterceptProc) then Exit; - TInterceptMonitor.Enter; try vt := PPointer(TargetInterface)^; P := vt; @@ -2530,216 +2457,288 @@ function PatchVt(const TargetInterface; MethodIndex: Integer; InterceptProc: Poi Inc(Q, 2); PInt32(Q)^ := $00; Inc(Q, 4); - PNativeUInt(Q)^ := NativeUInt(DstAddr); + PNativeInt(Q)^ := NativeInt(DstAddr); {$ELSE !CPUX64} PWord(Q)^ := opJmpMem; Inc(Q, 2); - PUInt32(Q)^ := UInt32(Q + 4); - PUInt32(Q + 4)^ := UInt32(DstAddr); + PUInt32(Q)^ := UInt32(NativeInt(Q) + 4); + PUInt32(NativeInt(Q) + 4)^ := UInt32(DstAddr); {$ENDIF CPUX64} finally - TInterceptMonitor.Leave; end; end; -function UnPatchVt(const Trampo: Pointer): Boolean; +function UnPatchVt(const TrampoLine: Pointer): Boolean; var OrgAccess: DWORD; PInfo: PTrampoDataVt; begin - if not Assigned(Trampo) then - Exit(False); + if not Assigned(TrampoLine) then + begin + Result := False; + Exit; + end; - TInterceptMonitor.Enter; try - PInfo := PTrampoDataVt(PByte(Trampo) - SizeOf(TTrampoDataVt)); + PInfo := PTrampoDataVt(NativeInt(TrampoLine) - SizeOf(TTrampoDataVt)); OrgAccess := SetMemPermission(PInfo^.vAddr, 32, PAGE_EXECUTE_READWRITE); try PPointer(PInfo^.vAddr)^ := PInfo^.Addr; finally SetMemPermission(PInfo^.vAddr, 32, OrgAccess); end; - Result := InternalFuncs.VirtualFree(Trampo, 0, MEM_RELEASE); + Result := InternalFuncs.VirtualFree(TrampoLine, 0, MEM_RELEASE); finally - TInterceptMonitor.Leave; end; end; -{ TInterceptMonitor } +{ ======================================= Trampoline misc =================================== } -class procedure TInterceptMonitor.InternalCreate; +function GetCreatorThreadIdFromTrampoline(var TrampoLine): TThreadId; +var + PNxtHook: PNextHook; begin - FLock := TObject.Create; + PNxtHook := GetNextHookPtrFromTrampoline(PPointer(@TrampoLine)^); + Result := PNxtHook^.threadid; end; -class procedure TInterceptMonitor.InternalDestroy; +function GetTrampolineParam(var TrampoLine): Pointer; +var + PNxtHook: PNextHook; begin - FreeAndNil(FLock); + PNxtHook := GetNextHookPtrFromTrampoline(PPointer(@TrampoLine)^); + Result := PNxtHook^.Param; end; -class procedure TInterceptMonitor.Enter; +{ ======================================= Recursive Section ======================================= } + +function EnterRecursiveSection(var TrampoLine; MaxRecursionLevel: NativeInt = 0): Boolean; +var + PNxtHook: PNextHook; + RecursionLevel: NativeInt; begin - { - If the current thread is working with DDL (Insert/Remove hook).. - others threads must wait before accessing - detours (Insert/Remove/...). - } -{$IFNDEF FPC} - TMonitor.Enter(FLock); -{$ELSE FPC} - EnterCriticalSection(Critical); -{$ENDIF !FPC} + PNxtHook := GetNextHookPtrFromTrampoline(PPointer(@TrampoLine)^); + if ioRecursive in PNxtHook^.InterceptOptions then + begin + RecursionLevel := NativeInt(TlsGetValue(PNxtHook^.TlsRecursionLevelIndex)); + Result := RecursionLevel <= MaxRecursionLevel; + if Result then + begin + Inc(RecursionLevel); + TlsSetValue(PNxtHook^.TlsRecursionLevelIndex, Pointer(RecursionLevel)); + end; + end + else + raise DetourException.Create(SErrorRecursiveSectionUnsupported); end; -class procedure TInterceptMonitor.Leave; +function ExitRecursiveSection(var TrampoLine): Boolean; +var + PNxtHook: PNextHook; + RecursionLevel: NativeInt; begin - { - After the current thread finish it's - job with TIntercept .. others thread - can now access TIntercept . - } -{$IFNDEF FPC} - TMonitor.Exit(FLock); -{$ELSE} - LeaveCriticalSection(Critical); -{$ENDIF} + PNxtHook := GetNextHookPtrFromTrampoline(PPointer(@TrampoLine)^); + if ioRecursive in PNxtHook^.InterceptOptions then + begin + RecursionLevel := NativeInt(TlsGetValue(PNxtHook^.TlsRecursionLevelIndex)); + Result := RecursionLevel >= 0; + if Result then + begin + Dec(RecursionLevel); + TlsSetValue(PNxtHook^.TlsRecursionLevelIndex, Pointer(RecursionLevel)); + end; + end + else + raise DetourException.Create(SErrorRecursiveSectionUnsupported); end; -{$IFDEF MustUseGenerics } -{ ***** BEGIN LICENSE BLOCK ***** - * - * The initial developer of the original TDetour - * class is David Millington . - * - * ***** END LICENSE BLOCK ***** } - -{ TDetours<T> } - -function TDetours<T>.CheckTType: Boolean; -var - LPInfo: PTypeInfo; +{ ======================================= Transaction ======================================= } +function CountThreadCallBack(ID: DWORD; Param: Pointer): BOOL; begin - LPInfo := TypeInfo(T); - Result := SizeOf(T) = SizeOf(Pointer); - if Result then - Result := LPInfo.Kind = tkProcedure; - if not Result then - raise DetourException.CreateFmt(SInvalidTType, [LPInfo.Name]); + Assert(Assigned(Param)); + Inc(PInteger(Param)^); + Result := True; end; -constructor TDetours<T>.Create(const TargetProc, InterceptProc: T); +function SuspendOrResumeThread(threadid: DWORD; Suspend: Boolean): DWORD; +var + hThread: THandle; begin - inherited Create(); - CheckTType; - SetHook(TargetProc, InterceptProc); + hThread := OpenThread(THREAD_SUSPEND_RESUME, False, threadid); + if hThread <> THandle(0) then + begin + if Suspend then + Result := SuspendThread(hThread) + else + Result := ResumeThread(hThread); + CloseHandle(hThread); + end + else + Result := DWORD(-1); end; -destructor TDetours<T>.Destroy; +function SuspendThreadCallBack(ID: DWORD; Param: Pointer): BOOL; +var + PStruct: PTransactionStruct; + SuspendCount: DWORD; begin - Disable; - inherited; + Assert(Assigned(Param)); + PStruct := PTransactionStruct(Param); + if ID <> PStruct^.TID then + begin + SuspendCount := SuspendOrResumeThread(ID, True); + if SuspendCount <> DWORD(-1) then + // thread's previously was running . + begin + { Only add threads that was running before suspending them ! } + PStruct^.SuspendedThreads^[PStruct^.SuspendedThreadCount] := ID; + Inc(PStruct^.SuspendedThreadCount); + end; + end; + Result := True; end; -procedure TDetours<T>.SetHook(const TargetProc, InterceptProc: T); +function BeginTransaction(Options: TTransactionOptions = [toSuspendThread]): THandle; +var + PStruct: PTransactionStruct; + ThreadCount: Integer; + P: Pointer; + ThreadHandle: THandle; begin - FTargetProc := TToPointer(TargetProc); - FInterceptProc := TToPointer(InterceptProc); - FNextHook := T(nil); - Assert(Assigned(FTargetProc) and Assigned(FInterceptProc), 'Target or replacement methods are not assigned'); + EnterLook(FLock); + try + ThreadHandle := GetCurrentThread(); + PStruct := GetMemory(SizeOf(TTransactionStruct)); + FillChar(PStruct^, SizeOf(TTransactionStruct), #00); + PStruct^.Options := Options; + PStruct^.PID := GetCurrentProcessId(); + PStruct^.TID := GetCurrentThreadId(); + PStruct^.ThreadPriority := GetThreadPriority(ThreadHandle); + SetThreadPriority(ThreadHandle, THREAD_PRIORITY_TIME_CRITICAL); + Result := THandle(PStruct); + if toSuspendThread in Options then + begin + ThreadCount := 0; + EnumProcessThreads(PStruct^.PID, @CountThreadCallBack, @ThreadCount); + if ThreadCount > 1 then + begin + P := GetMemory(ThreadCount * 2 * SizeOf(DWORD)); + PStruct^.SuspendedThreads := P; + EnumProcessThreads(PStruct^.PID, @SuspendThreadCallBack, PStruct); + end; + end; + finally + LeaveLook(FLock); + end; end; -procedure TDetours<T>.Disable; +function EndTransaction(Handle: THandle): Boolean; var - PTrampoline: Pointer; + PStruct: PTransactionStruct; + i: Integer; begin - if Installed then - begin - PTrampoline := TToPointer(FNextHook); - DDetours.InterceptRemove(PTrampoline); - FNextHook := T(nil); + EnterLook(FLock); + Result := True; + PStruct := PTransactionStruct(Handle); + try + if PStruct^.SuspendedThreadCount > 0 then + begin + for i := 0 to PStruct^.SuspendedThreadCount - 1 do + begin + SuspendOrResumeThread(PStruct^.SuspendedThreads^[i], False); + end; + FreeMemory(PStruct^.SuspendedThreads); + end; + SetThreadPriority(GetCurrentThread(), PStruct^.ThreadPriority); + FreeMemory(PTransactionStruct(Handle)); + finally + LeaveLook(FLock); end; end; -procedure TDetours<T>.Enable; +{$IFDEF SUPPORTS_GENERICS} +{ TIntercept<T,U> } + +function TIntercept<T, U>.TToPointer(const A): Pointer; begin - if not Installed then - FNextHook := PointerToT(InterceptCreate(FTargetProc, FInterceptProc)); + Result := Pointer(A); end; -function TDetours<T>.GetHookCount: ShortInt; +function TIntercept<T, U>.PointerToT(const P): T; begin - Result := GetNHook(FTargetProc); + Result := T(P); end; -function TDetours<T>.GetInstalled: Boolean; +function TIntercept<T, U>.EnsureTIsMethod(): Boolean; +var + LPInfo: PTypeInfo; begin - Result := Assigned(TToPointer(FNextHook)); + Result := SizeOf(T) = SizeOf(Pointer); + if Result then + begin + LPInfo := TypeInfo(T); + if LPInfo.Kind = tkProcedure then + Exit + else + raise DetourException.Create(SErrorInvalidTType); + end; end; -function TDetours<T>.NextHook: T; +constructor TIntercept<T, U>.Create(const TargetProc, InterceptProc: T; const AParam: U; const AInterceptOptions: TInterceptOptions = DefaultInterceptOptions); begin - Assert(Installed, SDetoursNotInstalled); - Result := FNextHook; + EnsureTIsMethod(); + FCreatorThreadId := GetCurrentThreadId(); + FInterceptOptions := AInterceptOptions; + FParam := AParam; + FTrampolinePtr := InterceptCreate(TToPointer(TargetProc), TToPointer(InterceptProc), @FParam, AInterceptOptions); + FNextHook := PointerToT(FTrampolinePtr); end; -function TDetours<T>.PointerToT(const _P: Pointer): T; +function TIntercept<T, U>.GetTrampoline(): T; begin - Result := __PointerToT(_P); + Result := FNextHook; end; -function TDetours<T>.TToPointer(const _T: T): Pointer; +function TIntercept<T, U>.GetParam(): U; begin - Result := __TToPointer(_T); + Result := FParam; end; -function TDetours<T>.__PointerToT(const _P): T; +function TIntercept<T, U>.GetCreatorThreadId(): TThreadId; begin - Result := T(_P); + Result := FCreatorThreadId; end; -function TDetours<T>.__TToPointer(const _T): Pointer; +function TIntercept<T, U>.GetInterceptOptions(): TInterceptOptions; begin - Result := Pointer(_T); + Result := FInterceptOptions; end; -{ --------------------------------------------------------------------------- } -function BeginHooks(): Boolean; -var - List: TThreadsIDList; +function TIntercept<T, U>.EnterRecursive(MaxRecursionLevel: NativeInt = 0): Boolean; begin - List := TThreadsIDList.Create; - GlobalThreadList.Add(GetCurrentThread, List); - Result := SuspendAllThreads(List); + Result := EnterRecursiveSection(FTrampolinePtr, MaxRecursionLevel); end; -function EndHooks(): Boolean; -var - List: TThreadsIDList; - currThread: THandle; +function TIntercept<T, U>.ExitRecursive(): Boolean; begin - currThread := GetCurrentThread; - List := GlobalThreadList[currThread]; - Assert(Assigned(List)); - Result := ResumeSuspendedThreads(List); - GlobalThreadList.Remove(currThread); - FreeAndNil(List); + Result := ExitRecursiveSection(FTrampolinePtr); end; -function BeginUnHooks(): Boolean; +destructor TIntercept<T, U>.Destroy(); begin - if GlobalThreadList.ContainsKey(GetCurrentThread) then - raise InterceptException.Create(ErrBgnUnHooks); - Result := BeginHooks; + InterceptRemove(TToPointer(FNextHook)); + inherited; end; -function EndUnHooks(): Boolean; +{ TIntercept<T> } +constructor TIntercept<T>.Create(const TargetProc, InterceptProc: T; const AParam: Pointer = nil; + const AInterceptOptions: TInterceptOptions = DefaultInterceptOptions); begin - Result := EndHooks; + inherited Create(TargetProc, InterceptProc, AParam, InterceptOptions); end; -{$ENDIF MustUseGenerics} -var - SysInfo: TSystemInfo; +{$ENDIF SUPPORTS_GENERICS} +{ ======================================= Initialization ======================================= } procedure InitInternalFuncs(); @@ -2750,13 +2749,11 @@ procedure InitInternalFuncs(); Inst: TInstruction; begin Sb := 0; - Func := TIntercept.GetRoot(Func); + Func := GetRoot(Func); Result := VirtualAlloc(nil, 64, MEM_RESERVE or MEM_COMMIT, PAGE_EXECUTE_READWRITE); P := Result; - mb := JmpTypeToSize[tJmpRipZ]; -{$IFNDEF FPC} - Inst := default (TInstruction); -{$ENDIF !FPC} + mb := JmpTypeToSize[JT_RIPZ]; + FillChar(Inst, SizeOf(TInstruction), #00); Inst.Archi := CPUX; Inst.NextInst := Func; while Sb <= mb do @@ -2768,33 +2765,33 @@ procedure InitInternalFuncs(); fn := MapInsts(Func, P, Sb); Inc(P, fn); {$IFDEF CPUX64} - InsertJmp(P, Func + Sb, tJmpRipZ); + InsertJmp(P, PByte(NativeInt(Func) + Sb), JT_RIPZ); {$ELSE !CPUX64} - InsertJmp(P, Func + Sb, tJmpRel32); + InsertJmp(P, PByte(NativeInt(Func) + Sb), JT_REL32); {$ENDIF CPUX64} end; begin -{$IFDEF HookInternalFuncs} +{$IFDEF HOOK_INTERNAL_FUNCTIONS} @InternalFuncs.VirtualAlloc := CloneFunc(@VirtualAlloc); @InternalFuncs.VirtualFree := CloneFunc(@VirtualFree); @InternalFuncs.VirtualProtect := CloneFunc(@VirtualProtect); @InternalFuncs.VirtualQuery := CloneFunc(@VirtualQuery); @InternalFuncs.FlushInstructionCache := CloneFunc(@FlushInstructionCache); @InternalFuncs.GetCurrentProcess := CloneFunc(@GetCurrentProcess); -{$ELSE !HookInternalFuncs} +{$ELSE !HOOK_INTERNAL_FUNCTIONS} @InternalFuncs.VirtualAlloc := @VirtualAlloc; @InternalFuncs.VirtualFree := @VirtualFree; @InternalFuncs.VirtualProtect := @VirtualProtect; @InternalFuncs.VirtualQuery := @VirtualQuery; @InternalFuncs.FlushInstructionCache := @FlushInstructionCache; @InternalFuncs.GetCurrentProcess := @GetCurrentProcess; -{$ENDIF HookInternalFuncs} +{$ENDIF HOOK_INTERNAL_FUNCTIONS} end; procedure FreeInternalFuncs; begin -{$IFDEF HookInternalFuncs} +{$IFDEF HOOK_INTERNAL_FUNCTIONS} InternalFuncs.VirtualFree(@InternalFuncs.VirtualAlloc, 0, MEM_RELEASE); InternalFuncs.VirtualFree(@InternalFuncs.VirtualProtect, 0, MEM_RELEASE); InternalFuncs.VirtualFree(@InternalFuncs.VirtualQuery, 0, MEM_RELEASE); @@ -2802,22 +2799,22 @@ procedure FreeInternalFuncs; InternalFuncs.VirtualFree(@InternalFuncs.GetCurrentProcess, 0, MEM_RELEASE); // VirtualFree must be the last one ! InternalFuncs.VirtualFree(@InternalFuncs.VirtualFree, 0, MEM_RELEASE); -{$ENDIF HookInternalFuncs} +{$ENDIF HOOK_INTERNAL_FUNCTIONS} end; initialization -TInterceptMonitor.InternalCreate; -{$IFDEF MustUseGenerics} -GlobalThreadList := TDictionary<THandle, TThreadsIDList>.Create; -{$ENDIF MustUseGenerics} +{$IFDEF SUPPORTS_MONITOR} + FLock := TObject.Create(); +{$ELSE SUPPORTS_MONITOR} + FLock := TCriticalSection.Create(); +{$ENDIF SUPPORTS_MONITOR} GetSystemInfo(SysInfo); SizeOfAlloc := SysInfo.dwPageSize; if SizeOfAlloc < (TmpSize + TrampoSize + 64) then SizeOfAlloc := (TmpSize + TrampoSize + 64); {$IFDEF FPC} OpenThread := nil; -InitializeCriticalSection(Critical); {$ELSE !FPC} @OpenThread := nil; {$ENDIF !FPC} @@ -2843,19 +2840,14 @@ initialization end; { The OpenThread function does not exist on OS version < Win XP } OpenThreadExist := (@OpenThread <> nil); -InitInternalFuncs; +InitInternalFuncs(); finalization -{$IFDEF MustUseGenerics} - GlobalThreadList.Free; -{$ENDIF MustUseGenerics} if (FreeKernel) and (hKernel > 0) then FreeLibrary(hKernel); -FreeInternalFuncs; -{$IFDEF FPC} -DeleteCriticalSection(Critical); -{$ENDIF FPC} -TInterceptMonitor.InternalDestroy; +FreeInternalFuncs(); +if Assigned(FLock) then + FreeAndNil(FLock); end. diff --git a/source/detours/Source/DDetoursDefs.inc b/source/detours/Source/DDetoursDefs.inc new file mode 100644 index 000000000..ba41e2db4 --- /dev/null +++ b/source/detours/Source/DDetoursDefs.inc @@ -0,0 +1,48 @@ +{.$DEFINE HOOK_INTERNAL_FUNCTIONS} // hook internal functions. + +{$IFDEF FPC} + {$ASMMODE INTEL} +{$ELSE !FPC} + +{$T-} + +{$IF CompilerVersion >= 17.0} + {$DEFINE DELPHI_2005_UP} +{$IFEND} + +{$IF CompilerVersion >= 18.5} + {$DEFINE DELPHI_2007_UP} +{$IFEND} + +{$IF CompilerVersion >= 20} + {$DEFINE DELPHI_2009_UP} +{$IFEND} + +{$IF CompilerVersion >= 21} + {$DEFINE DELPHI_2010_UP} +{$IFEND} + +{$IF CompilerVersion >= 22} + {$DEFINE DELPHI_XE_UP} +{$IFEND} + +{$IF CompilerVersion >= 23} + {$DEFINE DELPHI_XE2_UP} +{$IFEND} + +{$IF CompilerVersion >= 33} + {$DEFINE DELPHI_RIO_UP} +{$IFEND} + +{$IFDEF DELPHI_2005_UP} + {$DEFINE SUPPORTS_INLINE} +{$ENDIF} + +{$IFDEF DELPHI_XE2_UP} + {$DEFINE SUPPORTS_RTTI} + {$DEFINE SUPPORTS_GENERICS} + {$DEFINE RENAMED_NAMESPACE} +{$ENDIF} + +{$ENDIF FPC} + diff --git a/source/detours/Source/Defs.inc b/source/detours/Source/Defs.inc deleted file mode 100644 index 6ed587d51..000000000 --- a/source/detours/Source/Defs.inc +++ /dev/null @@ -1,48 +0,0 @@ -{$DEFINE UseInline} -{$DEFINE BuildThreadSafe} -{$DEFINE UseGenerics} -{$DEFINE UseMultiBytesNop} -//Define HookInternalFuncs if you want to hook internal functions used by DDL core! -{.$DEFINE HookInternalFuncs} -//---------------------------------------------- -{$IFDEF FPC} - {$IFDEF CPU64} - {$IFNDEF CPUX64} - {$DEFINE CPUX64} - {$ENDIF !CPUX64} - {$ENDIF CPU64} - {$ASMMODE INTEL} -{$ENDIF FPC} - -{$IFNDEF CPUX64} - {$IFNDEF CPUX86} - {$DEFINE CPUX86} - {$ENDIF !CPUX86} -{$ENDIF !CPUX64} - -{$IFDEF DEBUG} -{$R+} // Range check On -{$ENDIF} - -{$IFNDEF FPC} - {$IF CompilerVersion >17} - {$DEFINE CanInline} - {$IFEND} - {$IF CompilerVersion >=21} - {$DEFINE GenericsExist } - {$IFEND} - {$IF CompilerVersion >=23} - {$DEFINE DXE2UP } - {$IFEND} - {$IF CompilerVersion >=24} - {$DEFINE DXE3UP } - {$IFEND} -{$ENDIF !FPC} - -{$IF DEFINED(UseInline) and DEFINED(CanInline)} - {$DEFINE MustInline} -{$IFEND} - -{$IF DEFINED(GenericsExist) and DEFINED(UseGenerics)} - {$DEFINE MustUseGenerics} -{$IFEND} diff --git a/source/detours/Source/InstDecode.pas b/source/detours/Source/InstDecode.pas index 58efb5abf..1058a6a76 100644 --- a/source/detours/Source/InstDecode.pas +++ b/source/detours/Source/InstDecode.pas @@ -1,25 +1,20 @@ // ************************************************************************************************** -// Delphi Instruction Decode Library +// x86 Instruction Decode Library // Unit InstDecode -// https://github.com/MahdiSafsafi/delphi-detours-library - -// 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. -// -// The Original Code is InstDecode.pas. -// -// The Initial Developer of the Original Code is Mahdi Safsafi [SMP3]. -// Portions created by Mahdi Safsafi . are Copyright (C) 2013-2017 Mahdi Safsafi . -// All Rights Reserved. +// https://github.com/MahdiSafsafi/DDetours // +// This Source Code Form is subject to the terms of the Mozilla +// Public License, v. 2.0. If a copy of the MPL was not distributed +// with this file, You can obtain one at +// https://mozilla.org/MPL/2.0/. // ************************************************************************************************** { ===============================> CHANGE LOG <====================================================== + ==> Jun, 7, 2020: + +Added support for older Delphi version (D7+). + +Added support for FPC. + +Fixed some bug related to displacement. + ==> Dec 27,2014 , Mahdi Safsafi : +BugFix : IN/INS/OUT/OUTS instructions decoding. +BugFix : MOV with offset instructions decoding. @@ -50,24 +45,18 @@ {$IFDEF FPC} {$MODE DELPHI} +{$HINTS OFF} +{$WARN 4056 OFF} +{$WARN 4082 OFF} {$ENDIF FPC} interface -{$I Defs.inc} - -uses SysUtils; +{$I DDetoursDefs.inc} -type - PInt8 = ^Int8; - PInt16 = ^Int16; - PInt32 = ^Int32; - PInt64 = ^Int64; - - PUInt8 = ^UInt8; - PUInt16 = ^UInt16; - PUInt32 = ^UInt32; - PUInt64 = ^UInt64; +uses + SysUtils, + LegacyTypes; const { CPUX } @@ -345,16 +334,16 @@ TInstruction = record Vex: TVex; LID: TInternalData; { Internal Data } Errors: Byte; - InstSize: Byte; + InstSize: Integer; Options: Byte; - UserTag: UInt64; + UserTag: NativeInt; end; PInstruction = ^TInstruction; TDecoderProc = procedure(PInst: PInstruction); -function DecodeInst(PInst: PInstruction): ShortInt; +function DecodeInst(PInst: PInstruction): Integer; { Useful ModRm Routines } function GetModRm_Mod(const Value: Byte): Byte; {$IFDEF MustInline}inline; {$ENDIF} @@ -651,7 +640,7 @@ procedure Decode_JMP_Mp(PInst: PInstruction); forward; { 81 } Decode_SP_T38_F0_F7, { 82 } Decode_66_ModRm_Ib, { 83 } Decode_F2_ModRm_Ib); -{$REGION 'COMMON'} + { .$REGION 'COMMON' } { ========================== COMMON =============================== } procedure SetInstError(PInst: PInstruction; Error: Byte); @@ -757,16 +746,19 @@ procedure DecodeDisp(PInst: PInstruction); DispOnly := (PInst^.ModRm.iMod = $00) and (PInst^.ModRm.Rm = $05); case Size of - ops8bits: Disp := (PUInt8(PInst^.NextInst)^); // and $FF; - ops16bits: Disp := (PUInt16(PInst^.NextInst)^); // and $FFFF; + ops8bits: + Disp := (PInt8(PInst^.NextInst)^); // and $FF; + ops16bits: + Disp := (PInt16(PInst^.NextInst)^); // and $FFFF; ops32bits: begin - Disp := (PUInt32(PInst^.NextInst)^); // and $FFFFFFFF; + Disp := (PInt32(PInst^.NextInst)^); // and $FFFFFFFF; if (PInst^.Archi = CPUX64) and DispOnly then { RIP disp ! } PInst^.Disp.Flags := PInst^.Disp.Flags or dfRip; end; - else SetInstError(PInst, ERROR_DISP_SIZE); + else + SetInstError(PInst, ERROR_DISP_SIZE); end; if DispOnly then @@ -823,11 +815,16 @@ procedure Decode_Imm(PInst: PInstruction; immSize: Byte); begin Imm := $00; case immSize of - ops8bits: Imm := (PInt8(PInst^.NextInst)^); - ops16bits: Imm := (PInt16(PInst^.NextInst)^); - ops32bits: Imm := (PInt32(PInst^.NextInst)^); - ops64bits: Imm := (PInt64(PInst^.NextInst)^); - else SetInstError(PInst, ERROR_IMM_SIZE); + ops8bits: + Imm := (PInt8(PInst^.NextInst)^); + ops16bits: + Imm := (PInt16(PInst^.NextInst)^); + ops32bits: + Imm := (PInt32(PInst^.NextInst)^); + ops64bits: + Imm := (PInt64(PInst^.NextInst)^); + else + SetInstError(PInst, ERROR_IMM_SIZE); end; { @@ -851,10 +848,14 @@ procedure Decode_J(PInst: PInstruction; Size: Byte); begin Value := $00; case Size of - ops8bits: Value := (PInt8(PInst^.NextInst)^); - ops16bits: Value := (PInt16(PInst^.NextInst)^); - ops32bits: Value := (PInt32(PInst^.NextInst)^); - ops64bits: Value := (PInt64(PInst^.NextInst)^); + ops8bits: + Value := (PInt8(PInst^.NextInst)^); + ops16bits: + Value := (PInt16(PInst^.NextInst)^); + ops32bits: + Value := (PInt32(PInst^.NextInst)^); + ops64bits: + Value := (PInt64(PInst^.NextInst)^); end; Inc(PInst^.NextInst, Size); if PInst^.OpType = otNone then @@ -862,13 +863,13 @@ procedure Decode_J(PInst: PInstruction; Size: Byte); if PInst^.OpCode in [$70 .. $8F] then PInst^.OpType := otJ or otJcc; if Assigned(PInst^.VirtualAddr) then - VA := PInst^.VirtualAddr + (PInst^.NextInst - PInst^.Addr) + VA := PByte(NativeInt(PInst^.VirtualAddr) + NativeInt(NativeInt(PInst^.NextInst) - NativeInt(PInst^.Addr))) else VA := PInst^.NextInst; PInst^.Branch.Size := Size; PInst^.Branch.Falgs := bfUsed or bfRel; PInst^.Branch.Value := Value; - PInst^.Branch.Target := VA + Value; + PInst^.Branch.Target := PByte(NativeInt(VA) + Value); end; procedure Decode_Branch_ModRm(PInst: PInstruction); @@ -882,7 +883,7 @@ procedure Decode_Branch_ModRm(PInst: PInstruction); PInst^.Branch.Size := PInst^.Disp.Size; PInst^.Branch.Falgs := bfUsed or bfIndirect or bfAbs; if Assigned(PInst^.VirtualAddr) then - VA := PInst^.VirtualAddr + (PInst^.NextInst - PInst^.Addr) + VA := PByte(NativeInt(PInst^.VirtualAddr) + (NativeInt(PInst^.NextInst) - NativeInt(PInst^.Addr))) else VA := PInst^.NextInst; if (PInst^.ModRm.iMod = $00) and (PInst^.ModRm.Rm = $05) then @@ -895,7 +896,7 @@ procedure Decode_Branch_ModRm(PInst: PInstruction); VA := PByte(UInt64(VA) and $FFFFFFFF); { Displacement = RIP + Offset } PInst^.Branch.Falgs := PInst^.Branch.Falgs or bfRip; - P := VA + Int32(PInst^.Disp.Value); + P := PByte(NativeInt(VA) + NativeInt(PInst^.Disp.Value)); { Memory 64-bits } PInst^.Branch.Target := PByte(PUInt64(P)^); end @@ -960,8 +961,8 @@ procedure Decode_Invalid_FPU(PInst: PInstruction); {$IFDEF MustInline}inline; Inc(PInst^.NextInst); end; -{$ENDREGION} -{$REGION 'PREFIXES'} +{ .$ENDREGION } +{ .$REGION 'PREFIXES' } { ========================== PREFIXES =============================== } procedure Decode_ES_Prefix(PInst: PInstruction); @@ -1170,8 +1171,8 @@ procedure Decode_REPE_Prefix(PInst: PInstruction); Inc(PInst^.NextInst); DecoderProcTable[OneByteTable[PInst^.NextInst^]](PInst); end; -{$ENDREGION} -{$REGION 'ESCAPE'} +{ .$ENDREGION } +{ .$REGION 'ESCAPE' } { ========================== ESCAPE =============================== } procedure JumpError(PInst: PInstruction); @@ -1223,8 +1224,8 @@ procedure Decode_Escape_3_Byte(PInst: PInstruction); DecoderProcTable[ThreeByteTable3A[PInst^.NextInst^]](PInst); end; -{$ENDREGION} -{$REGION 'FPU'} +{ .$ENDREGION } +{ .$REGION 'FPU' } { ========================== FPU =============================== } procedure Decode_Escape_FPU_D8(PInst: PInstruction); @@ -1404,8 +1405,8 @@ procedure Decode_Escape_FPU_DF(PInst: PInstruction); Decode_NA_ModRm(PInst); end; -{$ENDREGION} -{$REGION 'GROUPS'} +{ .$ENDREGION } +{ .$REGION 'GROUPS' } { ========================== GROUPS =============================== } procedure Decode_Group_1(PInst: PInstruction); @@ -1781,8 +1782,8 @@ procedure Decode_Group_17(PInst: PInstruction); Decode_Invalid_Group(PInst); end; -{$ENDREGION} -{$REGION 'DECODERS'} +{ .$ENDREGION } +{ .$REGION 'DECODERS' } { ========================== DECODERS PROC =============================== } procedure Decode_NA_CALL_Ap_I64(PInst: PInstruction); @@ -2327,9 +2328,9 @@ procedure Decode_NA_Iv(PInst: PInstruction); SetOpCode(PInst); Decode_Imm(PInst, PInst^.LID.vOpSize); end; -{$ENDREGION} +{ .$ENDREGION } -function DecodeInst(PInst: PInstruction): ShortInt; +function DecodeInst(PInst: PInstruction): Integer; var P: PByte; LArchi: Byte; @@ -2373,7 +2374,7 @@ function DecodeInst(PInst: PInstruction): ShortInt; PInst^.OpTable := tbOneByte; DecoderProcTable[OneByteTable[P^]](PInst); - Result := PInst^.NextInst - P; + Result := Integer(NativeInt(PInst^.NextInst) - NativeInt(P)); PInst^.InstSize := Result; if Result > CPUX_TO_INST_LENGTH[PInst^.Archi] then diff --git a/source/detours/Source/LegacyTypes.pas b/source/detours/Source/LegacyTypes.pas new file mode 100644 index 000000000..f9bab62b1 --- /dev/null +++ b/source/detours/Source/LegacyTypes.pas @@ -0,0 +1,48 @@ +// ************************************************************************************************** +// +// https://github.com/MahdiSafsafi/DDetours +// +// ************************************************************************************************** + +unit LegacyTypes; + +interface + +{$I DDetoursDefs.inc} + +type + +{$IFNDEF FPC} +{$IFNDEF DELPHI_XE_UP} + NativeInt = Integer; + NativeUInt = Cardinal; + PNativeInt = ^NativeInt; + PNativeUInt = ^NativeUInt; +{$IFDEF MSWINDOWS} + TThreadID = LongWord; +{$ENDIF MSWINDOWS} +{$ENDIF DELPHI_XE_UP} +{$ENDIF FPC} + Int8 = Shortint; + Int16 = Smallint; + Int32 = Integer; + + UInt8 = Byte; + UInt16 = Word; + UInt32 = Cardinal; + + PInt8 = ^Int8; + PInt16 = ^Int16; + PInt32 = ^Int32; + PInt64 = ^Int64; + + PUInt8 = ^UInt8; + PUInt16 = ^UInt16; + PUInt32 = ^UInt32; + PUInt64 = ^UInt64; + + SIZE_T = NativeUInt; + +implementation + +end. diff --git a/source/detours/Source/ModRmFlagsTables.inc b/source/detours/Source/ModRmFlagsTables.inc index f51efb577..c58c2632b 100644 --- a/source/detours/Source/ModRmFlagsTables.inc +++ b/source/detours/Source/ModRmFlagsTables.inc @@ -1,22 +1,12 @@ // ************************************************************************************************** -// Part of Delphi Instruction Decode Library [InstDecode] +// Part of x86 Instruction Decode Library [InstDecode] // -// https://github.com/MahdiSafsafi/delphi-detours-library - -// 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. -// -// The Original Code is ModRmFlagsTables.inc. -// -// The Initial Developer of the Original Code is Mahdi Safsafi [SMP3]. -// Portions created by Mahdi Safsafi . are Copyright (C) 2013-2016 Mahdi Safsafi . -// All Rights Reserved. +// https://github.com/MahdiSafsafi/DDetours // +// This Source Code Form is subject to the terms of the Mozilla +// Public License, v. 2.0. If a copy of the MPL was not distributed +// with this file, You can obtain one at +// https://mozilla.org/MPL/2.0/. // ************************************************************************************************** diff --git a/source/detours/Source/OpCodesTables.inc b/source/detours/Source/OpCodesTables.inc index 2a46dc941..57f6c4f9a 100644 --- a/source/detours/Source/OpCodesTables.inc +++ b/source/detours/Source/OpCodesTables.inc @@ -1,22 +1,12 @@ // ************************************************************************************************** -// Part of Delphi Instruction Decode Library [InstDecode] +// Part of x86 Instruction Decode Library [InstDecode] // -// https://github.com/MahdiSafsafi/delphi-detours-library - -// 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. -// -// The Original Code is OpCodesTables.inc. -// -// The Initial Developer of the Original Code is Mahdi Safsafi [SMP3]. -// Portions created by Mahdi Safsafi . are Copyright (C) 2013-2016 Mahdi Safsafi . -// All Rights Reserved. +// https://github.com/MahdiSafsafi/DDetours // +// This Source Code Form is subject to the terms of the Mozilla +// Public License, v. 2.0. If a copy of the MPL was not distributed +// with this file, You can obtain one at +// https://mozilla.org/MPL/2.0/. // ************************************************************************************************** { Reference : diff --git a/source/detours/Source/TlHelp32.inc b/source/detours/Source/TlHelp32.inc new file mode 100644 index 000000000..5690f94c4 --- /dev/null +++ b/source/detours/Source/TlHelp32.inc @@ -0,0 +1,31 @@ +{ TlHelp32 types for fpc } + +const + TH32CS_SNAPHEAPLIST = $00000001; + TH32CS_SNAPPROCESS = $00000002; + TH32CS_SNAPTHREAD = $00000004; + TH32CS_SNAPMODULE = $00000008; + TH32CS_SNAPALL = TH32CS_SNAPHEAPLIST or TH32CS_SNAPPROCESS or + TH32CS_SNAPTHREAD or TH32CS_SNAPMODULE; + TH32CS_INHERIT = $80000000; + + TLS_OUT_OF_INDEXES = DWORD($FFFFFFFF); // FPC does not declare TLS_OUT_OF_INDEXES. + +type + tagTHREADENTRY32 = record + dwSize: DWORD; + cntUsage: DWORD; + th32ThreadID: DWORD; + th32OwnerProcessID: DWORD; + tpBasePri: Longint; + tpDeltaPri: Longint; + dwFlags: DWORD; + end; + THREADENTRY32 = tagTHREADENTRY32; + PTHREADENTRY32 = ^tagTHREADENTRY32; + LPTHREADENTRY32 = ^tagTHREADENTRY32; + TThreadEntry32 = tagTHREADENTRY32; + + TThread32First = function (hSnapshot: THandle; var lpte: TThreadEntry32): BOOL stdcall; + TThread32Next = function (hSnapshot: THandle; var lpte: TThreadENtry32): BOOL stdcall; + TCreateToolhelp32Snapshot = function (dwFlags, th32ProcessID: DWORD): THandle; stdcall; diff --git a/source/detours/Test/Test.dpr b/source/detours/Test/Test.dpr new file mode 100644 index 000000000..d895686ee --- /dev/null +++ b/source/detours/Test/Test.dpr @@ -0,0 +1,59 @@ +program Test; + +{$IFNDEF TESTINSIGHT} +{$APPTYPE CONSOLE} +{$ENDIF}{$STRONGLINKTYPES ON} +uses + System.SysUtils, + {$IFDEF TESTINSIGHT} + TestInsight.DUnitX, + {$ENDIF } + DUnitX.Loggers.Console, + DUnitX.Loggers.Xml.NUnit, + DUnitX.TestFramework, + uTest in 'uTest.pas'; + +var + runner : ITestRunner; + results : IRunResults; + logger : ITestLogger; + nunitLogger : ITestLogger; +begin +{$IFDEF TESTINSIGHT} + TestInsight.DUnitX.RunRegisteredTests; + exit; +{$ENDIF} + try + //Check command line options, will exit if invalid + TDUnitX.CheckCommandLine; + //Create the test runner + runner := TDUnitX.CreateRunner; + //Tell the runner to use RTTI to find Fixtures + runner.UseRTTI := True; + //tell the runner how we will log things + //Log to the console window + logger := TDUnitXConsoleLogger.Create(true); + runner.AddLogger(logger); + //Generate an NUnit compatible XML File + nunitLogger := TDUnitXXMLNUnitFileLogger.Create(TDUnitX.Options.XMLOutputFile); + runner.AddLogger(nunitLogger); + runner.FailsOnNoAsserts := False; //When true, Assertions must be made during tests; + + //Run tests + results := runner.Execute; + if not results.AllPassed then + System.ExitCode := EXIT_ERRORS; + + {$IFNDEF CI} + //We don't want this happening when running under CI. + if TDUnitX.Options.ExitBehavior = TDUnitXExitBehavior.Pause then + begin + System.Write('Done.. press <Enter> key to quit.'); + System.Readln; + end; + {$ENDIF} + except + on E: Exception do + System.Writeln(E.ClassName, ': ', E.Message); + end; +end. diff --git a/source/detours/Demo/DetoursDemo/Delphi/Hook_Overloaded_Method/Hook_Overloaded_Method.dproj b/source/detours/Test/Test.dproj similarity index 56% rename from source/detours/Demo/DetoursDemo/Delphi/Hook_Overloaded_Method/Hook_Overloaded_Method.dproj rename to source/detours/Test/Test.dproj index 553aa9bd8..6ef2a9104 100644 --- a/source/detours/Demo/DetoursDemo/Delphi/Hook_Overloaded_Method/Hook_Overloaded_Method.dproj +++ b/source/detours/Test/Test.dproj @@ -1,13 +1,13 @@ <Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> <PropertyGroup> - <ProjectGuid>{E9A76233-969C-4733-B759-3191ED9B483B}</ProjectGuid> - <ProjectVersion>18.1</ProjectVersion> + <ProjectGuid>{AE7FD8B6-27D8-45EA-B53E-B9F470DA9BA0}</ProjectGuid> + <ProjectVersion>18.7</ProjectVersion> <FrameworkType>None</FrameworkType> - <MainSource>Hook_Overloaded_Method.dpr</MainSource> + <MainSource>Test.dpr</MainSource> <Base>True</Base> <Config Condition="'$(Config)'==''">Debug</Config> <Platform Condition="'$(Platform)'==''">Win32</Platform> - <TargetedPlatforms>1</TargetedPlatforms> + <TargetedPlatforms>3</TargetedPlatforms> <AppType>Console</AppType> </PropertyGroup> <PropertyGroup Condition="'$(Config)'=='Base' or '$(Base)'!=''"> @@ -18,21 +18,6 @@ <CfgParent>Base</CfgParent> <Base>true</Base> </PropertyGroup> - <PropertyGroup Condition="('$(Platform)'=='iOSDevice32' and '$(Base)'=='true') or '$(Base_iOSDevice32)'!=''"> - <Base_iOSDevice32>true</Base_iOSDevice32> - <CfgParent>Base</CfgParent> - <Base>true</Base> - </PropertyGroup> - <PropertyGroup Condition="('$(Platform)'=='iOSDevice64' and '$(Base)'=='true') or '$(Base_iOSDevice64)'!=''"> - <Base_iOSDevice64>true</Base_iOSDevice64> - <CfgParent>Base</CfgParent> - <Base>true</Base> - </PropertyGroup> - <PropertyGroup Condition="('$(Platform)'=='iOSSimulator' and '$(Base)'=='true') or '$(Base_iOSSimulator)'!=''"> - <Base_iOSSimulator>true</Base_iOSSimulator> - <CfgParent>Base</CfgParent> - <Base>true</Base> - </PropertyGroup> <PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Base)'=='true') or '$(Base_Win32)'!=''"> <Base_Win32>true</Base_Win32> <CfgParent>Base</CfgParent> @@ -60,10 +45,6 @@ <Base>true</Base> </PropertyGroup> <PropertyGroup Condition="'$(Base)'!=''"> - <Icon_MainIcon>$(BDS)\bin\delphi_PROJECTICON.ico</Icon_MainIcon> - <Icns_MainIcns>$(BDS)\bin\delphi_PROJECTICNS.icns</Icns_MainIcns> - <SanitizedProjectName>Hook_Overloaded_Method</SanitizedProjectName> - <DCC_Namespace>System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace)</DCC_Namespace> <DCC_DcuOutput>.\$(Platform)\$(Config)</DCC_DcuOutput> <DCC_ExeOutput>.\$(Platform)\$(Config)</DCC_ExeOutput> <DCC_E>false</DCC_E> @@ -71,80 +52,31 @@ <DCC_S>false</DCC_S> <DCC_F>false</DCC_F> <DCC_K>false</DCC_K> + <DCC_Namespace>System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace)</DCC_Namespace> + <Icon_MainIcon>$(BDS)\bin\delphi_PROJECTICON.ico</Icon_MainIcon> + <Icns_MainIcns>$(BDS)\bin\delphi_PROJECTICNS.icns</Icns_MainIcns> + <DCC_UnitSearchPath>$(DUnitX);$(DCC_UnitSearchPath)</DCC_UnitSearchPath> + <SanitizedProjectName>Test</SanitizedProjectName> </PropertyGroup> <PropertyGroup Condition="'$(Base_Android)'!=''"> - <Android_LauncherIcon144>$(BDS)\bin\Artwork\Android\FM_LauncherIcon_144x144.png</Android_LauncherIcon144> - <AUP_ACCESS_COARSE_LOCATION>true</AUP_ACCESS_COARSE_LOCATION> - <AUP_ACCESS_FINE_LOCATION>true</AUP_ACCESS_FINE_LOCATION> - <Android_SplashImage470>$(BDS)\bin\Artwork\Android\FM_SplashImage_470x320.png</Android_SplashImage470> - <AUP_READ_EXTERNAL_STORAGE>true</AUP_READ_EXTERNAL_STORAGE> - <AUP_CAMERA>true</AUP_CAMERA> - <Android_SplashImage960>$(BDS)\bin\Artwork\Android\FM_SplashImage_960x720.png</Android_SplashImage960> - <AUP_CALL_PHONE>true</AUP_CALL_PHONE> - <Android_LauncherIcon96>$(BDS)\bin\Artwork\Android\FM_LauncherIcon_96x96.png</Android_LauncherIcon96> - <AUP_READ_PHONE_STATE>true</AUP_READ_PHONE_STATE> - <AUP_WRITE_CALENDAR>true</AUP_WRITE_CALENDAR> - <Android_SplashImage640>$(BDS)\bin\Artwork\Android\FM_SplashImage_640x480.png</Android_SplashImage640> - <Android_LauncherIcon72>$(BDS)\bin\Artwork\Android\FM_LauncherIcon_72x72.png</Android_LauncherIcon72> - <Android_LauncherIcon48>$(BDS)\bin\Artwork\Android\FM_LauncherIcon_48x48.png</Android_LauncherIcon48> - <Android_LauncherIcon36>$(BDS)\bin\Artwork\Android\FM_LauncherIcon_36x36.png</Android_LauncherIcon36> - <AUP_WRITE_EXTERNAL_STORAGE>true</AUP_WRITE_EXTERNAL_STORAGE> - <AUP_INTERNET>true</AUP_INTERNET> - <AUP_READ_CALENDAR>true</AUP_READ_CALENDAR> - <Android_SplashImage426>$(BDS)\bin\Artwork\Android\FM_SplashImage_426x320.png</Android_SplashImage426> - </PropertyGroup> - <PropertyGroup Condition="'$(Base_iOSDevice32)'!=''"> - <iPhone_Spotlight80>$(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_80x80.png</iPhone_Spotlight80> - <iPhone_AppIcon60>$(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_60x60.png</iPhone_AppIcon60> - <iPad_AppIcon76>$(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_76x76.png</iPad_AppIcon76> - <iPad_SpotLight40>$(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_40x40.png</iPad_SpotLight40> - <iPad_SpotLight80>$(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_80x80.png</iPad_SpotLight80> - <iPhone_AppIcon120>$(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_120x120.png</iPhone_AppIcon120> - <iPad_Launch768x1024>$(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_768x1024.png</iPad_Launch768x1024> - <iPad_Launch1024x768>$(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_1024x768.png</iPad_Launch1024x768> - <iPad_AppIcon152>$(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_152x152.png</iPad_AppIcon152> - <iPad_Launch2048x1536>$(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_2048x1536.png</iPad_Launch2048x1536> - <iPad_Launch1536x2048>$(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_1536x2048.png</iPad_Launch1536x2048> - <iPhone_Spotlight40>$(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_40x40.png</iPhone_Spotlight40> - </PropertyGroup> - <PropertyGroup Condition="'$(Base_iOSDevice64)'!=''"> - <iPhone_Spotlight80>$(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_80x80.png</iPhone_Spotlight80> - <iPhone_AppIcon60>$(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_60x60.png</iPhone_AppIcon60> - <iPad_AppIcon76>$(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_76x76.png</iPad_AppIcon76> - <iPad_SpotLight40>$(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_40x40.png</iPad_SpotLight40> - <iPad_SpotLight80>$(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_80x80.png</iPad_SpotLight80> - <iPhone_AppIcon120>$(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_120x120.png</iPhone_AppIcon120> - <iPad_Launch768x1024>$(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_768x1024.png</iPad_Launch768x1024> - <iPad_Launch1024x768>$(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_1024x768.png</iPad_Launch1024x768> - <iPad_AppIcon152>$(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_152x152.png</iPad_AppIcon152> - <iPad_Launch2048x1536>$(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_2048x1536.png</iPad_Launch2048x1536> - <iPad_Launch1536x2048>$(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_1536x2048.png</iPad_Launch1536x2048> - <iPhone_Spotlight40>$(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_40x40.png</iPhone_Spotlight40> - </PropertyGroup> - <PropertyGroup Condition="'$(Base_iOSSimulator)'!=''"> - <iPhone_Spotlight80>$(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_80x80.png</iPhone_Spotlight80> - <iPhone_AppIcon60>$(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_60x60.png</iPhone_AppIcon60> - <iPad_AppIcon76>$(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_76x76.png</iPad_AppIcon76> - <iPad_SpotLight40>$(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_40x40.png</iPad_SpotLight40> - <iPad_SpotLight80>$(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_80x80.png</iPad_SpotLight80> - <iPhone_AppIcon120>$(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_120x120.png</iPhone_AppIcon120> - <iPad_Launch768x1024>$(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_768x1024.png</iPad_Launch768x1024> - <iPad_Launch1024x768>$(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_1024x768.png</iPad_Launch1024x768> - <iPad_AppIcon152>$(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_152x152.png</iPad_AppIcon152> - <iPad_Launch2048x1536>$(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_2048x1536.png</iPad_Launch2048x1536> - <iPad_Launch1536x2048>$(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_1536x2048.png</iPad_Launch1536x2048> - <iPhone_Spotlight40>$(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_40x40.png</iPhone_Spotlight40> + <DCC_UsePackage>DBXSqliteDriver;IndyIPCommon;RESTComponents;bindcompdbx;DBXInterBaseDriver;IndyIPServer;IndySystem;tethering;fmxFireDAC;FireDAC;bindcompfmx;FireDACSqliteDriver;ibmonitor;FMXTee;soaprtl;DbxCommonDriver;FmxTeeUI;ibxpress;fmx;FireDACIBDriver;xmlrtl;soapmidas;ibxbindings;rtl;DbxClientDriver;CustomIPTransport;dbexpress;IndyCore;bindcomp;dsnap;FireDACCommon;IndyIPClient;RESTBackendComponents;soapserver;dbxcds;bindengine;CloudService;dsnapxml;dbrtl;IndyProtocols;FireDACCommonDriver;inet;$(DCC_UsePackage)</DCC_UsePackage> + <EnabledSysJars>android-support-v4.dex.jar;cloud-messaging.dex.jar;com-google-android-gms.play-services-ads-base.17.2.0.dex.jar;com-google-android-gms.play-services-ads-identifier.16.0.0.dex.jar;com-google-android-gms.play-services-ads-lite.17.2.0.dex.jar;com-google-android-gms.play-services-ads.17.2.0.dex.jar;com-google-android-gms.play-services-analytics-impl.16.0.8.dex.jar;com-google-android-gms.play-services-analytics.16.0.8.dex.jar;com-google-android-gms.play-services-base.16.0.1.dex.jar;com-google-android-gms.play-services-basement.16.2.0.dex.jar;com-google-android-gms.play-services-gass.17.2.0.dex.jar;com-google-android-gms.play-services-identity.16.0.0.dex.jar;com-google-android-gms.play-services-maps.16.1.0.dex.jar;com-google-android-gms.play-services-measurement-base.16.4.0.dex.jar;com-google-android-gms.play-services-measurement-sdk-api.16.4.0.dex.jar;com-google-android-gms.play-services-stats.16.0.1.dex.jar;com-google-android-gms.play-services-tagmanager-v4-impl.16.0.8.dex.jar;com-google-android-gms.play-services-tasks.16.0.1.dex.jar;com-google-android-gms.play-services-wallet.16.0.1.dex.jar;com-google-firebase.firebase-analytics.16.4.0.dex.jar;com-google-firebase.firebase-common.16.1.0.dex.jar;com-google-firebase.firebase-iid-interop.16.0.1.dex.jar;com-google-firebase.firebase-iid.17.1.1.dex.jar;com-google-firebase.firebase-measurement-connector.17.0.1.dex.jar;com-google-firebase.firebase-messaging.17.5.0.dex.jar;fmx.dex.jar;google-play-billing.dex.jar;google-play-licensing.dex.jar</EnabledSysJars> + <VerInfo_Keys>package=com.embarcadero.$(MSBuildProjectName);label=$(MSBuildProjectName);versionCode=1;versionName=1.0.0;persistent=False;restoreAnyVersion=False;installLocation=auto;largeHeap=False;theme=TitleBar;hardwareAccelerated=true;apiKey=</VerInfo_Keys> + <BT_BuildType>Debug</BT_BuildType> </PropertyGroup> <PropertyGroup Condition="'$(Base_Win32)'!=''"> - <DCC_UsePackage>FireDACSqliteDriver;FireDACDSDriver;DBXSqliteDriver;FireDACPgDriver;fmx;IndySystem;TeeDB;tethering;vclib;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;DataSnapServer;DataSnapProviderClient;DBXSybaseASEDriver;DbxCommonDriver;vclimg;dbxcds;DatasnapConnectorsFreePascal;MetropolisUILiveTile;vcldb;vcldsnap;fmxFireDAC;DBXDb2Driver;DBXOracleDriver;CustomIPTransport;vclribbon;dsnap;IndyIPServer;fmxase;vcl;IndyCore;DBXMSSQLDriver;CloudService;IndyIPCommon;FmxTeeUI;FireDACIBDriver;DataSnapFireDAC;FireDACDBXDriver;soapserver;inetdbxpress;dsnapxml;FireDACInfxDriver;FireDACDb2Driver;adortl;FireDACASADriver;bindcompfmx;FireDACODBCDriver;RESTBackendComponents;emsclientfiredac;rtl;dbrtl;DbxClientDriver;FireDACCommon;bindcomp;inetdb;Tee;DBXOdbcDriver;vclFireDAC;xmlrtl;DataSnapNativeClient;ibxpress;svnui;IndyProtocols;DBXMySQLDriver;FireDACCommonDriver;bindcompdbx;bindengine;vclactnband;FMXTee;soaprtl;TeeUI;bindcompvcl;vclie;FireDACADSDriver;vcltouch;emsclient;VCLRESTComponents;FireDAC;DBXInformixDriver;FireDACMSSQLDriver;Intraweb;VclSmp;DataSnapConnectors;DataSnapServerMidas;DBXFirebirdDriver;dsnapcon;inet;fmxobj;FireDACMySQLDriver;soapmidas;vclx;svn;DBXSybaseASADriver;FireDACOracleDriver;fmxdae;RESTComponents;dbexpress;FireDACMSAccDriver;DataSnapIndy10ServerTransport;IndyIPClient;$(DCC_UsePackage)</DCC_UsePackage> - <DCC_ConsoleTarget>true</DCC_ConsoleTarget> - <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> - <VerInfo_Locale>1033</VerInfo_Locale> + <DCC_UsePackage>DBXSqliteDriver;IndyIPCommon;RESTComponents;bindcompdbx;DBXInterBaseDriver;vcl;IndyIPServer;vclactnband;StyleControls_dxe103Rio;vclFireDAC;IndySystem;tethering;svnui;dsnapcon;FireDACADSDriver;FireDACMSAccDriver;fmxFireDAC;vclimg;TeeDB;FireDAC;vcltouch;vcldb;bindcompfmx;svn;FireDACSqliteDriver;FireDACPgDriver;ibmonitor;inetdb;FMXTee;MyIdePlugin;soaprtl;DbxCommonDriver;FmxTeeUI;ibxpress;fmx;FireDACIBDriver;fmxdae;xmlrtl;soapmidas;ibxbindings;fmxobj;vclwinx;vclib;rtl;Tee;DbxClientDriver;dclAbsDBd26;CustomIPTransport;vcldsnap;dbexpress;IndyCore;vclx;bindcomp;appanalytics;dsnap;FireDACCommon;IndyIPClient;bindcompvcl;RESTBackendComponents;TeeUI;VCLRESTComponents;soapserver;dbxcds;VclSmp;adortl;vclie;bindengine;DBXMySQLDriver;CloudService;dsnapxml;FireDACMySQLDriver;dbrtl;IndyProtocols;inetdbxpress;vclAbsDBd26;FireDACCommonODBC;FireDACCommonDriver;inet;fmxase;$(DCC_UsePackage)</DCC_UsePackage> <DCC_Namespace>Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace)</DCC_Namespace> + <BT_BuildType>Debug</BT_BuildType> + <VerInfo_Keys>CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProgramID=com.embarcadero.$(MSBuildProjectName);ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> + <VerInfo_Locale>1033</VerInfo_Locale> </PropertyGroup> <PropertyGroup Condition="'$(Base_Win64)'!=''"> - <DCC_ConsoleTarget>true</DCC_ConsoleTarget> - <DCC_UsePackage>FireDACSqliteDriver;FireDACDSDriver;DBXSqliteDriver;FireDACPgDriver;fmx;IndySystem;TeeDB;tethering;vclib;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;DataSnapServer;DataSnapProviderClient;DBXSybaseASEDriver;DbxCommonDriver;vclimg;dbxcds;DatasnapConnectorsFreePascal;MetropolisUILiveTile;vcldb;vcldsnap;fmxFireDAC;DBXDb2Driver;DBXOracleDriver;CustomIPTransport;vclribbon;dsnap;IndyIPServer;fmxase;vcl;IndyCore;DBXMSSQLDriver;CloudService;IndyIPCommon;FmxTeeUI;FireDACIBDriver;DataSnapFireDAC;FireDACDBXDriver;soapserver;inetdbxpress;dsnapxml;FireDACInfxDriver;FireDACDb2Driver;adortl;FireDACASADriver;bindcompfmx;FireDACODBCDriver;RESTBackendComponents;emsclientfiredac;rtl;dbrtl;DbxClientDriver;FireDACCommon;bindcomp;inetdb;Tee;DBXOdbcDriver;vclFireDAC;xmlrtl;DataSnapNativeClient;ibxpress;IndyProtocols;DBXMySQLDriver;FireDACCommonDriver;bindcompdbx;bindengine;vclactnband;FMXTee;soaprtl;TeeUI;bindcompvcl;vclie;FireDACADSDriver;vcltouch;emsclient;VCLRESTComponents;FireDAC;DBXInformixDriver;FireDACMSSQLDriver;Intraweb;VclSmp;DataSnapConnectors;DataSnapServerMidas;DBXFirebirdDriver;dsnapcon;inet;fmxobj;FireDACMySQLDriver;soapmidas;vclx;DBXSybaseASADriver;FireDACOracleDriver;fmxdae;RESTComponents;dbexpress;FireDACMSAccDriver;DataSnapIndy10ServerTransport;IndyIPClient;$(DCC_UsePackage)</DCC_UsePackage> + <DCC_UsePackage>DBXSqliteDriver;IndyIPCommon;RESTComponents;bindcompdbx;DBXInterBaseDriver;vcl;IndyIPServer;vclactnband;StyleControls_dxe103Rio;vclFireDAC;IndySystem;tethering;dsnapcon;FireDACADSDriver;FireDACMSAccDriver;fmxFireDAC;vclimg;TeeDB;FireDAC;vcltouch;vcldb;bindcompfmx;FireDACSqliteDriver;FireDACPgDriver;ibmonitor;inetdb;FMXTee;soaprtl;DbxCommonDriver;FmxTeeUI;ibxpress;fmx;FireDACIBDriver;fmxdae;xmlrtl;soapmidas;ibxbindings;fmxobj;vclwinx;vclib;rtl;Tee;DbxClientDriver;CustomIPTransport;vcldsnap;dbexpress;IndyCore;vclx;bindcomp;appanalytics;dsnap;FireDACCommon;IndyIPClient;bindcompvcl;RESTBackendComponents;TeeUI;VCLRESTComponents;soapserver;dbxcds;VclSmp;adortl;vclie;bindengine;DBXMySQLDriver;CloudService;dsnapxml;FireDACMySQLDriver;dbrtl;IndyProtocols;inetdbxpress;FireDACCommonODBC;FireDACCommonDriver;inet;fmxase;$(DCC_UsePackage)</DCC_UsePackage> + <DCC_Namespace>Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;$(DCC_Namespace)</DCC_Namespace> + <BT_BuildType>Debug</BT_BuildType> + <VerInfo_Keys>CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProgramID=com.embarcadero.$(MSBuildProjectName);ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> + <VerInfo_Locale>1033</VerInfo_Locale> </PropertyGroup> <PropertyGroup Condition="'$(Cfg_1)'!=''"> <DCC_Define>DEBUG;$(DCC_Define)</DCC_Define> @@ -167,9 +99,7 @@ <DelphiCompile Include="$(MainSource)"> <MainSource>MainSource</MainSource> </DelphiCompile> - <DCCReference Include="..\..\..\..\Source\CPUID.pas"/> - <DCCReference Include="..\..\..\..\Source\DDetours.pas"/> - <DCCReference Include="..\..\..\..\Source\InstDecode.pas"/> + <DCCReference Include="uTest.pas"/> <BuildConfiguration Include="Release"> <Key>Cfg_2</Key> <CfgParent>Base</CfgParent> @@ -184,20 +114,14 @@ </ItemGroup> <ProjectExtensions> <Borland.Personality>Delphi.Personality.12</Borland.Personality> - <Borland.ProjectType>Application</Borland.ProjectType> + <Borland.ProjectType>Console</Borland.ProjectType> <BorlandProject> <Delphi.Personality> <Source> - <Source Name="MainSource">Hook_Overloaded_Method.dpr</Source> + <Source Name="MainSource">Test.dpr</Source> </Source> </Delphi.Personality> <Deployment Version="3"> - <DeployFile LocalName="Win32\Debug\Hook_Overloaded_Method.exe" Configuration="Debug" Class="ProjectOutput"> - <Platform Name="Win32"> - <RemoteName>Hook_Overloaded_Method.exe</RemoteName> - <Overwrite>true</Overwrite> - </Platform> - </DeployFile> <DeployFile LocalName="$(BDS)\Redist\osx32\libcgunwind.1.0.dylib" Class="DependencyModule"> <Platform Name="OSX32"> <Overwrite>true</Overwrite> @@ -208,33 +132,88 @@ <Overwrite>true</Overwrite> </Platform> </DeployFile> - <DeployFile LocalName="$(BDS)\Redist\iossimulator\libPCRE.dylib" Class="DependencyModule"> + <DeployFile LocalName="$(BDS)\Redist\iossimulator\libpcre.dylib" Class="DependencyModule"> <Platform Name="iOSSimulator"> <Overwrite>true</Overwrite> </Platform> </DeployFile> - <DeployFile LocalName="$(BDS)\Redist\osx32\libcgsqlite3.dylib" Class="DependencyModule"> - <Platform Name="OSX32"> + <DeployFile LocalName="Win32\Debug\Test.exe" Configuration="Debug" Class="ProjectOutput"> + <Platform Name="Win32"> + <RemoteName>Test.exe</RemoteName> <Overwrite>true</Overwrite> </Platform> </DeployFile> - <DeployClass Name="ProjectiOSDeviceResourceRules"> - <Platform Name="iOSDevice64"> + <DeployClass Name="AdditionalDebugSymbols"> + <Platform Name="OSX32"> <Operation>1</Operation> </Platform> - <Platform Name="iOSDevice32"> + <Platform Name="Win32"> + <Operation>0</Operation> + </Platform> + </DeployClass> + <DeployClass Name="AndroidClassesDexFile"> + <Platform Name="Android"> + <RemoteDir>classes</RemoteDir> <Operation>1</Operation> </Platform> </DeployClass> - <DeployClass Name="ProjectOSXResource"> - <Platform Name="OSX32"> - <RemoteDir>Contents\Resources</RemoteDir> + <DeployClass Name="AndroidFileProvider"> + <Platform Name="Android"> + <RemoteDir>res\xml</RemoteDir> <Operation>1</Operation> </Platform> </DeployClass> - <DeployClass Name="AndroidClassesDexFile"> + <DeployClass Name="AndroidGDBServer"> <Platform Name="Android"> - <RemoteDir>classes</RemoteDir> + <RemoteDir>library\lib\armeabi-v7a</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="AndroidLibnativeArmeabiFile"> + <Platform Name="Android"> + <RemoteDir>library\lib\armeabi</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="AndroidLibnativeMipsFile"> + <Platform Name="Android"> + <RemoteDir>library\lib\mips</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="AndroidServiceOutput"> + <Platform Name="Android"> + <RemoteDir>library\lib\armeabi-v7a</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="AndroidSplashImageDef"> + <Platform Name="Android"> + <RemoteDir>res\drawable</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="AndroidSplashStyles"> + <Platform Name="Android"> + <RemoteDir>res\values</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="AndroidSplashStylesV21"> + <Platform Name="Android"> + <RemoteDir>res\values-v21</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_Colors"> + <Platform Name="Android"> + <RemoteDir>res\values</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_DefaultAppIcon"> + <Platform Name="Android"> + <RemoteDir>res\drawable</RemoteDir> <Operation>1</Operation> </Platform> </DeployClass> @@ -244,377 +223,552 @@ <Operation>1</Operation> </Platform> </DeployClass> - <DeployClass Name="AdditionalDebugSymbols"> - <Platform Name="Win32"> - <RemoteDir>Contents\MacOS</RemoteDir> - <Operation>0</Operation> + <DeployClass Name="Android_LauncherIcon36"> + <Platform Name="Android"> + <RemoteDir>res\drawable-ldpi</RemoteDir> + <Operation>1</Operation> </Platform> - <Platform Name="iOSSimulator"> + </DeployClass> + <DeployClass Name="Android_LauncherIcon48"> + <Platform Name="Android"> + <RemoteDir>res\drawable-mdpi</RemoteDir> <Operation>1</Operation> </Platform> - <Platform Name="OSX32"> - <RemoteDir>Contents\MacOS</RemoteDir> + </DeployClass> + <DeployClass Name="Android_LauncherIcon72"> + <Platform Name="Android"> + <RemoteDir>res\drawable-hdpi</RemoteDir> <Operation>1</Operation> </Platform> </DeployClass> - <DeployClass Name="AndroidLibnativeMipsFile"> + <DeployClass Name="Android_LauncherIcon96"> <Platform Name="Android"> - <RemoteDir>library\lib\mips</RemoteDir> + <RemoteDir>res\drawable-xhdpi</RemoteDir> <Operation>1</Operation> </Platform> </DeployClass> - <DeployClass Name="iPad_Launch768"> - <Platform Name="iOSSimulator"> + <DeployClass Name="Android_NotificationIcon24"> + <Platform Name="Android"> + <RemoteDir>res\drawable-mdpi</RemoteDir> <Operation>1</Operation> </Platform> - <Platform Name="iOSDevice64"> + </DeployClass> + <DeployClass Name="Android_NotificationIcon36"> + <Platform Name="Android"> + <RemoteDir>res\drawable-hdpi</RemoteDir> <Operation>1</Operation> </Platform> - <Platform Name="iOSDevice32"> + </DeployClass> + <DeployClass Name="Android_NotificationIcon48"> + <Platform Name="Android"> + <RemoteDir>res\drawable-xhdpi</RemoteDir> <Operation>1</Operation> </Platform> </DeployClass> - <DeployClass Required="true" Name="ProjectOutput"> - <Platform Name="iOSDevice64"> + <DeployClass Name="Android_NotificationIcon72"> + <Platform Name="Android"> + <RemoteDir>res\drawable-xxhdpi</RemoteDir> <Operation>1</Operation> </Platform> - <Platform Name="iOSDevice32"> + </DeployClass> + <DeployClass Name="Android_NotificationIcon96"> + <Platform Name="Android"> + <RemoteDir>res\drawable-xxxhdpi</RemoteDir> <Operation>1</Operation> </Platform> - <Platform Name="Win32"> - <Operation>0</Operation> + </DeployClass> + <DeployClass Name="Android_SplashImage426"> + <Platform Name="Android"> + <RemoteDir>res\drawable-small</RemoteDir> + <Operation>1</Operation> </Platform> - <Platform Name="Linux64"> + </DeployClass> + <DeployClass Name="Android_SplashImage470"> + <Platform Name="Android"> + <RemoteDir>res\drawable-normal</RemoteDir> <Operation>1</Operation> </Platform> - <Platform Name="OSX32"> - <RemoteDir>Contents\MacOS</RemoteDir> + </DeployClass> + <DeployClass Name="Android_SplashImage640"> + <Platform Name="Android"> + <RemoteDir>res\drawable-large</RemoteDir> <Operation>1</Operation> </Platform> + </DeployClass> + <DeployClass Name="Android_SplashImage960"> <Platform Name="Android"> - <RemoteDir>library\lib\armeabi-v7a</RemoteDir> + <RemoteDir>res\drawable-xlarge</RemoteDir> <Operation>1</Operation> </Platform> - <Platform Name="iOSSimulator"> + </DeployClass> + <DeployClass Name="Android_Strings"> + <Platform Name="Android"> + <RemoteDir>res\values</RemoteDir> <Operation>1</Operation> </Platform> </DeployClass> - <DeployClass Name="DependencyFramework"> + <DeployClass Name="DebugSymbols"> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + </Platform> + <Platform Name="OSX32"> + <Operation>1</Operation> + </Platform> <Platform Name="Win32"> <Operation>0</Operation> </Platform> + </DeployClass> + <DeployClass Name="DependencyFramework"> <Platform Name="OSX32"> - <RemoteDir>Contents\MacOS</RemoteDir> <Operation>1</Operation> <Extensions>.framework</Extensions> </Platform> + <Platform Name="OSX64"> + <Operation>1</Operation> + <Extensions>.framework</Extensions> + </Platform> + <Platform Name="Win32"> + <Operation>0</Operation> + </Platform> </DeployClass> - <DeployClass Name="iPhone_Launch640"> - <Platform Name="iOSSimulator"> + <DeployClass Name="DependencyModule"> + <Platform Name="OSX32"> <Operation>1</Operation> + <Extensions>.dylib</Extensions> </Platform> - <Platform Name="iOSDevice64"> + <Platform Name="OSX64"> <Operation>1</Operation> + <Extensions>.dylib</Extensions> </Platform> + <Platform Name="Win32"> + <Operation>0</Operation> + <Extensions>.dll;.bpl</Extensions> + </Platform> + </DeployClass> + <DeployClass Required="true" Name="DependencyPackage"> <Platform Name="iOSDevice32"> <Operation>1</Operation> + <Extensions>.dylib</Extensions> </Platform> - </DeployClass> - <DeployClass Name="AndroidLibnativeX86File"/> - <DeployClass Name="ProjectiOSDeviceDebug"> <Platform Name="iOSDevice64"> - <RemoteDir>..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF</RemoteDir> <Operation>1</Operation> + <Extensions>.dylib</Extensions> </Platform> - <Platform Name="iOSDevice32"> - <RemoteDir>..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF</RemoteDir> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + <Extensions>.dylib</Extensions> + </Platform> + <Platform Name="OSX32"> + <Operation>1</Operation> + <Extensions>.dylib</Extensions> + </Platform> + <Platform Name="OSX64"> <Operation>1</Operation> + <Extensions>.dylib</Extensions> + </Platform> + <Platform Name="Win32"> + <Operation>0</Operation> + <Extensions>.bpl</Extensions> </Platform> </DeployClass> - <DeployClass Name="iPad_Launch1024"> + <DeployClass Name="File"> + <Platform Name="Android"> + <Operation>0</Operation> + </Platform> + <Platform Name="iOSDevice32"> + <Operation>0</Operation> + </Platform> + <Platform Name="iOSDevice64"> + <Operation>0</Operation> + </Platform> <Platform Name="iOSSimulator"> + <Operation>0</Operation> + </Platform> + <Platform Name="OSX32"> + <Operation>0</Operation> + </Platform> + <Platform Name="OSX64"> + <Operation>0</Operation> + </Platform> + <Platform Name="Win32"> + <Operation>0</Operation> + </Platform> + </DeployClass> + <DeployClass Name="iPad_Launch1024x768"> + <Platform Name="iOSDevice32"> <Operation>1</Operation> </Platform> <Platform Name="iOSDevice64"> <Operation>1</Operation> </Platform> - <Platform Name="iOSDevice32"> + <Platform Name="iOSSimulator"> <Operation>1</Operation> </Platform> </DeployClass> - <DeployClass Name="iPhone_Launch320"> - <Platform Name="iOSSimulator"> + <DeployClass Name="iPad_Launch1536x2048"> + <Platform Name="iOSDevice32"> <Operation>1</Operation> </Platform> <Platform Name="iOSDevice64"> <Operation>1</Operation> </Platform> - <Platform Name="iOSDevice32"> + <Platform Name="iOSSimulator"> <Operation>1</Operation> </Platform> </DeployClass> - <DeployClass Name="ProjectiOSInfoPList"> - <Platform Name="iOSSimulator"> + <DeployClass Name="iPad_Launch1668"> + <Platform Name="iOSDevice32"> <Operation>1</Operation> </Platform> <Platform Name="iOSDevice64"> <Operation>1</Operation> </Platform> - <Platform Name="iOSDevice32"> + <Platform Name="iOSSimulator"> <Operation>1</Operation> </Platform> </DeployClass> - <DeployClass Name="AndroidLibnativeArmeabiFile"> - <Platform Name="Android"> - <RemoteDir>library\lib\armeabi</RemoteDir> + <DeployClass Name="iPad_Launch1668x2388"> + <Platform Name="iOSDevice32"> <Operation>1</Operation> </Platform> - </DeployClass> - <DeployClass Name="DebugSymbols"> - <Platform Name="Win32"> - <Operation>0</Operation> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> </Platform> <Platform Name="iOSSimulator"> <Operation>1</Operation> </Platform> - <Platform Name="OSX32"> - <RemoteDir>Contents\MacOS</RemoteDir> + </DeployClass> + <DeployClass Name="iPad_Launch2048x1536"> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice64"> <Operation>1</Operation> </Platform> - </DeployClass> - <DeployClass Name="iPad_Launch1536"> <Platform Name="iOSSimulator"> <Operation>1</Operation> </Platform> + </DeployClass> + <DeployClass Name="iPad_Launch2048x2732"> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + </Platform> <Platform Name="iOSDevice64"> <Operation>1</Operation> </Platform> - <Platform Name="iOSDevice32"> + <Platform Name="iOSSimulator"> <Operation>1</Operation> </Platform> </DeployClass> - <DeployClass Name="Android_SplashImage470"> - <Platform Name="Android"> - <RemoteDir>res\drawable-normal</RemoteDir> + <DeployClass Name="iPad_Launch2224"> + <Platform Name="iOSDevice32"> <Operation>1</Operation> </Platform> - </DeployClass> - <DeployClass Name="Android_LauncherIcon96"> - <Platform Name="Android"> - <RemoteDir>res\drawable-xhdpi</RemoteDir> + <Platform Name="iOSDevice64"> <Operation>1</Operation> </Platform> - </DeployClass> - <DeployClass Name="Android_SplashImage640"> - <Platform Name="Android"> - <RemoteDir>res\drawable-large</RemoteDir> + <Platform Name="iOSSimulator"> <Operation>1</Operation> </Platform> </DeployClass> - <DeployClass Name="iPhone_Launch640x1136"> - <Platform Name="iOSSimulator"> + <DeployClass Name="iPad_Launch2388x1668"> + <Platform Name="iOSDevice32"> <Operation>1</Operation> </Platform> <Platform Name="iOSDevice64"> <Operation>1</Operation> </Platform> - <Platform Name="iOSDevice32"> + <Platform Name="iOSSimulator"> <Operation>1</Operation> </Platform> </DeployClass> - <DeployClass Name="ProjectiOSEntitlements"> + <DeployClass Name="iPad_Launch2732x2048"> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + </Platform> <Platform Name="iOSDevice64"> - <RemoteDir>..\</RemoteDir> <Operation>1</Operation> </Platform> - <Platform Name="iOSDevice32"> - <RemoteDir>..\</RemoteDir> + <Platform Name="iOSSimulator"> <Operation>1</Operation> </Platform> </DeployClass> - <DeployClass Name="AndroidGDBServer"> - <Platform Name="Android"> - <RemoteDir>library\lib\armeabi-v7a</RemoteDir> + <DeployClass Name="iPad_Launch768x1024"> + <Platform Name="iOSDevice32"> <Operation>1</Operation> </Platform> - </DeployClass> - <DeployClass Name="Android_LauncherIcon72"> - <Platform Name="Android"> - <RemoteDir>res\drawable-hdpi</RemoteDir> + <Platform Name="iOSDevice64"> <Operation>1</Operation> </Platform> - </DeployClass> - <DeployClass Name="ProjectOSXInfoPList"> - <Platform Name="OSX32"> - <RemoteDir>Contents</RemoteDir> + <Platform Name="iOSSimulator"> <Operation>1</Operation> </Platform> </DeployClass> - <DeployClass Name="ProjectOSXEntitlements"> - <Platform Name="OSX32"> - <RemoteDir>..\</RemoteDir> + <DeployClass Name="iPhone_Launch1125"> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice64"> <Operation>1</Operation> </Platform> - </DeployClass> - <DeployClass Name="iPad_Launch2048"> <Platform Name="iOSSimulator"> <Operation>1</Operation> </Platform> + </DeployClass> + <DeployClass Name="iPhone_Launch1136x640"> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + </Platform> <Platform Name="iOSDevice64"> <Operation>1</Operation> </Platform> - <Platform Name="iOSDevice32"> + <Platform Name="iOSSimulator"> <Operation>1</Operation> </Platform> </DeployClass> - <DeployClass Name="AndroidSplashStyles"> - <Platform Name="Android"> - <RemoteDir>res\values</RemoteDir> + <DeployClass Name="iPhone_Launch1242"> + <Platform Name="iOSDevice32"> <Operation>1</Operation> </Platform> - </DeployClass> - <DeployClass Name="Android_SplashImage426"> - <Platform Name="Android"> - <RemoteDir>res\drawable-small</RemoteDir> + <Platform Name="iOSDevice64"> <Operation>1</Operation> </Platform> - </DeployClass> - <DeployClass Name="AndroidSplashImageDef"> - <Platform Name="Android"> - <RemoteDir>res\drawable</RemoteDir> + <Platform Name="iOSSimulator"> <Operation>1</Operation> </Platform> </DeployClass> - <DeployClass Name="ProjectiOSResource"> + <DeployClass Name="iPhone_Launch1242x2688"> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> + </Platform> <Platform Name="iOSSimulator"> <Operation>1</Operation> </Platform> + </DeployClass> + <DeployClass Name="iPhone_Launch1334"> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + </Platform> <Platform Name="iOSDevice64"> <Operation>1</Operation> </Platform> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="iPhone_Launch1792"> <Platform Name="iOSDevice32"> <Operation>1</Operation> </Platform> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + </Platform> </DeployClass> - <DeployClass Name="ProjectAndroidManifest"> - <Platform Name="Android"> + <DeployClass Name="iPhone_Launch2208"> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSSimulator"> <Operation>1</Operation> </Platform> </DeployClass> - <DeployClass Name="Android_DefaultAppIcon"> - <Platform Name="Android"> - <RemoteDir>res\drawable</RemoteDir> + <DeployClass Name="iPhone_Launch2436"> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSSimulator"> <Operation>1</Operation> </Platform> </DeployClass> - <DeployClass Name="File"> - <Platform Name="Win32"> - <Operation>0</Operation> + <DeployClass Name="iPhone_Launch2688x1242"> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> </Platform> <Platform Name="iOSDevice64"> - <Operation>0</Operation> + <Operation>1</Operation> </Platform> - <Platform Name="OSX32"> - <RemoteDir>Contents\Resources\StartUp\</RemoteDir> - <Operation>0</Operation> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> </Platform> + </DeployClass> + <DeployClass Name="iPhone_Launch320"> <Platform Name="iOSDevice32"> - <Operation>0</Operation> + <Operation>1</Operation> </Platform> - <Platform Name="Android"> - <Operation>0</Operation> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> </Platform> <Platform Name="iOSSimulator"> - <Operation>0</Operation> + <Operation>1</Operation> </Platform> </DeployClass> - <DeployClass Name="AndroidServiceOutput"> - <Platform Name="Android"> - <RemoteDir>library\lib\armeabi-v7a</RemoteDir> + <DeployClass Name="iPhone_Launch640"> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSSimulator"> <Operation>1</Operation> </Platform> </DeployClass> - <DeployClass Required="true" Name="DependencyPackage"> - <Platform Name="Win32"> - <Operation>0</Operation> - <Extensions>.bpl</Extensions> + <DeployClass Name="iPhone_Launch640x1136"> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> </Platform> <Platform Name="iOSDevice64"> <Operation>1</Operation> - <Extensions>.dylib</Extensions> </Platform> - <Platform Name="OSX32"> - <RemoteDir>Contents\MacOS</RemoteDir> + <Platform Name="iOSSimulator"> <Operation>1</Operation> - <Extensions>.dylib</Extensions> </Platform> + </DeployClass> + <DeployClass Name="iPhone_Launch750"> <Platform Name="iOSDevice32"> <Operation>1</Operation> - <Extensions>.dylib</Extensions> + </Platform> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> </Platform> <Platform Name="iOSSimulator"> <Operation>1</Operation> - <Extensions>.dylib</Extensions> </Platform> </DeployClass> - <DeployClass Name="Android_LauncherIcon48"> - <Platform Name="Android"> - <RemoteDir>res\drawable-mdpi</RemoteDir> + <DeployClass Name="iPhone_Launch828"> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSSimulator"> <Operation>1</Operation> </Platform> </DeployClass> - <DeployClass Name="Android_SplashImage960"> + <DeployClass Name="ProjectAndroidManifest"> <Platform Name="Android"> - <RemoteDir>res\drawable-xlarge</RemoteDir> <Operation>1</Operation> </Platform> </DeployClass> - <DeployClass Name="Android_LauncherIcon36"> - <Platform Name="Android"> - <RemoteDir>res\drawable-ldpi</RemoteDir> + <DeployClass Name="ProjectiOSDeviceDebug"> + <Platform Name="iOSDevice32"> + <RemoteDir>..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice64"> + <RemoteDir>..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF</RemoteDir> <Operation>1</Operation> </Platform> </DeployClass> - <DeployClass Name="DependencyModule"> - <Platform Name="Win32"> - <Operation>0</Operation> - <Extensions>.dll;.bpl</Extensions> + <DeployClass Name="ProjectiOSDeviceResourceRules"/> + <DeployClass Name="ProjectiOSEntitlements"/> + <DeployClass Name="ProjectiOSInfoPList"/> + <DeployClass Name="ProjectiOSResource"> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> </Platform> <Platform Name="iOSDevice64"> <Operation>1</Operation> - <Extensions>.dylib</Extensions> </Platform> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="ProjectOSXDebug"/> + <DeployClass Name="ProjectOSXEntitlements"/> + <DeployClass Name="ProjectOSXInfoPList"/> + <DeployClass Name="ProjectOSXResource"> <Platform Name="OSX32"> - <RemoteDir>Contents\MacOS</RemoteDir> + <RemoteDir>Contents\Resources</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="OSX64"> + <RemoteDir>Contents\Resources</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Required="true" Name="ProjectOutput"> + <Platform Name="Android"> + <RemoteDir>library\lib\armeabi-v7a</RemoteDir> <Operation>1</Operation> - <Extensions>.dylib</Extensions> </Platform> <Platform Name="iOSDevice32"> <Operation>1</Operation> - <Extensions>.dylib</Extensions> + </Platform> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> </Platform> <Platform Name="iOSSimulator"> <Operation>1</Operation> - <Extensions>.dylib</Extensions> + </Platform> + <Platform Name="Linux64"> + <Operation>1</Operation> + </Platform> + <Platform Name="OSX32"> + <Operation>1</Operation> + </Platform> + <Platform Name="OSX64"> + <Operation>1</Operation> + </Platform> + <Platform Name="Win32"> + <Operation>0</Operation> + </Platform> + </DeployClass> + <DeployClass Name="ProjectUWPManifest"> + <Platform Name="Win32"> + <Operation>1</Operation> + </Platform> + <Platform Name="Win64"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="UWP_DelphiLogo150"> + <Platform Name="Win32"> + <RemoteDir>Assets</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="Win64"> + <RemoteDir>Assets</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="UWP_DelphiLogo44"> + <Platform Name="Win32"> + <RemoteDir>Assets</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="Win64"> + <RemoteDir>Assets</RemoteDir> + <Operation>1</Operation> </Platform> </DeployClass> - <ProjectRoot Platform="Win64" Name="$(PROJECTNAME)"/> <ProjectRoot Platform="iOSDevice64" Name="$(PROJECTNAME).app"/> + <ProjectRoot Platform="Win64" Name="$(PROJECTNAME)"/> <ProjectRoot Platform="iOSDevice32" Name="$(PROJECTNAME).app"/> - <ProjectRoot Platform="Win32" Name="$(PROJECTNAME)"/> <ProjectRoot Platform="Linux64" Name="$(PROJECTNAME)"/> - <ProjectRoot Platform="OSX32" Name="$(PROJECTNAME).app"/> + <ProjectRoot Platform="Win32" Name="$(PROJECTNAME)"/> + <ProjectRoot Platform="OSX32" Name="$(PROJECTNAME)"/> <ProjectRoot Platform="Android" Name="$(PROJECTNAME)"/> + <ProjectRoot Platform="OSX64" Name="$(PROJECTNAME)"/> <ProjectRoot Platform="iOSSimulator" Name="$(PROJECTNAME).app"/> </Deployment> <Platforms> <Platform value="Android">False</Platform> - <Platform value="iOSDevice32">False</Platform> - <Platform value="iOSDevice64">False</Platform> - <Platform value="iOSSimulator">False</Platform> - <Platform value="OSX32">False</Platform> <Platform value="Win32">True</Platform> - <Platform value="Win64">False</Platform> + <Platform value="Win64">True</Platform> </Platforms> </BorlandProject> <ProjectFileVersion>12</ProjectFileVersion> diff --git a/source/detours/Test/uTest.pas b/source/detours/Test/uTest.pas new file mode 100644 index 000000000..324e7fe98 --- /dev/null +++ b/source/detours/Test/uTest.pas @@ -0,0 +1,149 @@ +unit uTest; + +interface + +uses + DUnitX.TestFramework, DDetours; + +type + + [TestFixture] + TDDetours = class(TObject) + public + [Setup] + procedure Setup; + [TearDown] + procedure TearDown; + // Sample Methods + // Simple single Test + [Test] + procedure Test1; + [Test] + procedure Test2; + [Test] + procedure Test3; + [Test] + procedure Test4; + end; + +implementation + +const + Pi = 3.14; + +const + NewPi = 3.14159265359; + +type + TAdd = function(a, b: Integer): Integer; + TSub = function(a, b: Integer): Integer; + TGetPi = function(): Extended; + +var + TrampolineAdd: TAdd = nil; + TrampolineSub: TSub = nil; + TrampolineGetPi: TGetPi = nil; + + FInterceptSub: TIntercept<TSub, Integer>; + +function Add(a, b: Integer): Integer; +begin + Result := a + b; +end; + +function Sub(a, b: Integer): Integer; +begin + Result := a - b; +end; + +function GetPi(): Extended; +begin + Result := Pi; +end; + +function InterceptAdd(a, b: Integer): Integer; +begin + Result := TrampolineAdd(a, b); +end; + +function InterceptSub(a, b: Integer): Integer; +var + Param: Integer; +begin + Param := Integer(GetTrampolineParam(TrampolineSub)); + Result := TrampolineSub(a, Param); +end; + +function InterceptSub2(a, b: Integer): Integer; +begin + Result := FInterceptSub.TrampoLine(a, FInterceptSub.Param); +end; + +function InterceptGetPi(): Extended; +begin + Result := NewPi; +end; + +procedure TDDetours.Setup; +begin + +end; + +procedure TDDetours.TearDown; +begin +end; + +procedure TDDetours.Test1; +var + a, b, c: Integer; +begin + a := 3; + b := 2; + c := a + b; + TrampolineAdd := InterceptCreate(@Add, @InterceptAdd); + Assert.AreEqual(Add(a, b), c); + InterceptRemove(@TrampolineAdd); + Assert.AreEqual(Add(a, b), c); +end; + +procedure TDDetours.Test2; +var + a, b, c: Integer; + Param: Pointer; +begin + a := 3; + b := 2; + c := a - b; + Param := Pointer(0); + TrampolineSub := InterceptCreate(@Sub, @InterceptSub, Param, DefaultInterceptOptions); + Assert.AreEqual(Sub(a, b), a); + InterceptRemove(@TrampolineSub); + Assert.AreEqual(Sub(a, b), c); +end; + +procedure TDDetours.Test3; +begin + TrampolineAdd := InterceptCreate(@GetPi, @InterceptGetPi); + Assert.AreEqual(GetPi(), NewPi); + InterceptRemove(@TrampolineAdd); + Assert.AreEqual(GetPi(), Pi); +end; + +procedure TDDetours.Test4; +var + a, b, c: Integer; +begin + a := 3; + b := 2; + c := a - b; + FInterceptSub := TIntercept<TSub, Integer>.Create(Sub, InterceptSub2, 0); + Assert.AreEqual(Sub(a, b), a); + FInterceptSub.Free(); + Assert.AreEqual(Sub(a, b), c); +end; + +initialization + +TDUnitX.RegisterTestFixture(TDDetours); + +end. diff --git a/source/editvar.dfm b/source/editvar.dfm index 8bae8e422..023d2daab 100644 --- a/source/editvar.dfm +++ b/source/editvar.dfm @@ -9,10 +9,9 @@ object frmEditVariable: TfrmEditVariable Constraints.MinWidth = 200 Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText - Font.Height = -11 + Font.Height = -12 Font.Name = 'Tahoma' Font.Style = [] - OldCreateOrder = False Position = poMainFormCenter OnCreate = FormCreate OnDestroy = FormDestroy @@ -20,8 +19,7 @@ object frmEditVariable: TfrmEditVariable DesignSize = ( 291 222) - PixelsPerInch = 96 - TextHeight = 13 + TextHeight = 14 object btnOK: TButton Left = 127 Top = 189 diff --git a/source/editvar.pas b/source/editvar.pas index 3c0211f33..9d1a7b2ee 100644 --- a/source/editvar.pas +++ b/source/editvar.pas @@ -3,8 +3,8 @@ interface uses - Windows, SysUtils, Classes, Controls, Forms, Dialogs, StdCtrls, ExtCtrls, - dbconnection, dbstructures, ComCtrls, gnugettext, SynRegExpr, extra_controls; + Winapi.Windows, System.SysUtils, System.Classes, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ExtCtrls, + dbconnection, dbstructures, dbstructures.mysql, Vcl.ComCtrls, gnugettext, SynRegExpr, extra_controls; type TVarType = (vtString, vtNumeric, vtBoolean, vtEnum); @@ -56,15 +56,13 @@ implementation procedure TfrmEditVariable.FormCreate(Sender: TObject); begin HasSizeGrip := True; - Width := AppSettings.ReadInt(asEditVarWindowWidth); - Height := AppSettings.ReadInt(asEditVarWindowHeight); end; procedure TfrmEditVariable.FormDestroy(Sender: TObject); begin - AppSettings.WriteInt(asEditVarWindowWidth, Width); - AppSettings.WriteInt(asEditVarWindowHeight, Height); + AppSettings.WriteIntDpiAware(asEditVarWindowWidth, Self, Width); + AppSettings.WriteIntDpiAware(asEditVarWindowHeight, Self, Height); end; @@ -80,7 +78,7 @@ procedure TfrmEditVariable.SetVarName(Value: String); FVar := MySQLVariables[i]; Found := True; if not FVar.IsDynamic then - raise EVariableError.CreateFmt(_('"%s" is a read only variable, not editable.'), [Value]); + raise EVariableError.CreateFmt(_('"%s" is a read only variable, not editable'), [Value]); break; end; end; @@ -93,6 +91,8 @@ procedure TfrmEditVariable.FormShow(Sender: TObject); var val: String; begin + Width := AppSettings.ReadIntDpiAware(asEditVarWindowWidth, Self); + Height := AppSettings.ReadIntDpiAware(asEditVarWindowHeight, Self); // Verify variable type by value FVarType := vtString; if IsInt(FVarValue) then @@ -158,6 +158,7 @@ procedure TfrmEditVariable.FormShow(Sender: TObject); procedure TfrmEditVariable.btnOKClick(Sender: TObject); var sql, val: String; + Conn: TDBConnection; begin // Syntax taken from http://dev.mysql.com/doc/refman/4.1/en/using-system-variables.html sql := 'SET @@'; @@ -167,6 +168,8 @@ procedure TfrmEditVariable.btnOKClick(Sender: TObject); sql := sql + 'global'; sql := sql + '.' + FVar.Name + ' = '; + Conn := MainForm.ActiveConnection; + case FVarType of vtNumeric: val := IntToStr(UpDownNumber.Position); vtString: begin @@ -176,16 +179,17 @@ procedure TfrmEditVariable.btnOKClick(Sender: TObject); if ExecRegExpr('^\d+(\.\d*)?$', FVarValue) then val := editString.Text else - val := MainForm.ActiveConnection.EscapeString(editString.Text); + val := Conn.EscapeString(editString.Text); end; vtBoolean: val := IntToStr(Integer(radioBooleanOn.Checked)); - vtEnum: val := MainForm.ActiveConnection.EscapeString(comboEnum.Text); + vtEnum: val := Conn.EscapeString(comboEnum.Text); end; sql := sql + val; // Set the value and keep the form open in any error case try - MainForm.ActiveConnection.Query(sql); + Conn.Query(sql); + Conn.ShowWarnings; except on E:EDbError do begin ModalResult := mrNone; diff --git a/source/event_editor.dfm b/source/event_editor.dfm index d42365d84..1f8cf935e 100644 --- a/source/event_editor.dfm +++ b/source/event_editor.dfm @@ -32,6 +32,14 @@ object frmEventEditor: TfrmEventEditor Font.Name = 'Courier New' Font.Style = [] TabOrder = 1 + CodeFolding.GutterShapeSize = 11 + CodeFolding.CollapsedLineColor = clGrayText + CodeFolding.FolderBarLinesColor = clGrayText + CodeFolding.IndentGuidesColor = clGray + CodeFolding.IndentGuides = True + CodeFolding.ShowCollapsedLine = False + CodeFolding.ShowHintMark = True + UseCodeFolding = False Gutter.AutoSize = True Gutter.DigitCount = 2 Gutter.Font.Charset = DEFAULT_CHARSET @@ -163,6 +171,7 @@ object frmEventEditor: TfrmEventEditor Top = 3 Width = 194 Height = 21 + AutoDropDownWidth = True Anchors = [akLeft, akTop, akRight] TabOrder = 4 Text = 'comboDefiner' @@ -198,8 +207,8 @@ object frmEventEditor: TfrmEventEditor Top = 11 Width = 133 Height = 21 - Date = 40273.547337048610000000 - Time = 40273.547337048610000000 + Date = 40273.000000000000000000 + Time = 0.547337048607005300 TabOrder = 1 OnChange = Modification end @@ -208,8 +217,8 @@ object frmEventEditor: TfrmEventEditor Top = 11 Width = 133 Height = 21 - Date = 40273.548026377310000000 - Time = 40273.548026377310000000 + Date = 40273.000000000000000000 + Time = 0.548026377313362900 Kind = dtkTime TabOrder = 2 OnChange = Modification @@ -239,6 +248,7 @@ object frmEventEditor: TfrmEventEditor Top = 48 Width = 133 Height = 21 + AutoDropDownWidth = True Style = csDropDownList TabOrder = 6 OnChange = comboEveryIntervalChange @@ -266,8 +276,8 @@ object frmEventEditor: TfrmEventEditor Top = 75 Width = 133 Height = 21 - Date = 40273.548478379630000000 - Time = 40273.548478379630000000 + Date = 40273.000000000000000000 + Time = 0.548478379627340500 TabOrder = 8 OnChange = Modification end @@ -276,8 +286,8 @@ object frmEventEditor: TfrmEventEditor Top = 75 Width = 133 Height = 21 - Date = 40273.549206851850000000 - Time = 40273.549206851850000000 + Date = 40273.000000000000000000 + Time = 0.549206851850613000 Kind = dtkTime TabOrder = 9 OnChange = Modification @@ -287,8 +297,8 @@ object frmEventEditor: TfrmEventEditor Top = 102 Width = 133 Height = 21 - Date = 40273.549548981480000000 - Time = 40273.549548981480000000 + Date = 40273.000000000000000000 + Time = 0.549548981478437800 Kind = dtkTime TabOrder = 12 OnChange = Modification @@ -298,8 +308,8 @@ object frmEventEditor: TfrmEventEditor Top = 102 Width = 133 Height = 21 - Date = 40273.549452245370000000 - Time = 40273.549452245370000000 + Date = 40273.000000000000000000 + Time = 0.549452245366410400 TabOrder = 11 OnChange = Modification end @@ -320,6 +330,14 @@ object frmEventEditor: TfrmEventEditor Font.Name = 'Courier New' Font.Style = [] TabOrder = 0 + CodeFolding.GutterShapeSize = 11 + CodeFolding.CollapsedLineColor = clGrayText + CodeFolding.FolderBarLinesColor = clGrayText + CodeFolding.IndentGuidesColor = clGray + CodeFolding.IndentGuides = True + CodeFolding.ShowCollapsedLine = False + CodeFolding.ShowHintMark = True + UseCodeFolding = False Gutter.AutoSize = True Gutter.DigitCount = 2 Gutter.Font.Charset = DEFAULT_CHARSET @@ -354,6 +372,14 @@ object frmEventEditor: TfrmEventEditor Font.Name = 'Courier New' Font.Style = [] TabOrder = 0 + CodeFolding.GutterShapeSize = 11 + CodeFolding.CollapsedLineColor = clGrayText + CodeFolding.FolderBarLinesColor = clGrayText + CodeFolding.IndentGuidesColor = clGray + CodeFolding.IndentGuides = True + CodeFolding.ShowCollapsedLine = False + CodeFolding.ShowHintMark = True + UseCodeFolding = False Gutter.AutoSize = True Gutter.DigitCount = 2 Gutter.Font.Charset = DEFAULT_CHARSET diff --git a/source/event_editor.pas b/source/event_editor.pas index fdec2c854..9fc4d2ef0 100644 --- a/source/event_editor.pas +++ b/source/event_editor.pas @@ -3,9 +3,9 @@ interface uses - Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, - Dialogs, StdCtrls, SynEdit, SynMemo, SynRegExpr, ComCtrls, ExtCtrls, WideStrUtils, - apphelpers, dbconnection, dbstructures, gnugettext; + Winapi.Windows, Winapi.Messages, System.SysUtils, System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, + Vcl.Dialogs, Vcl.StdCtrls, Vcl.Menus, SynEdit, SynMemo, SynRegExpr, Vcl.ComCtrls, Vcl.ExtCtrls, System.WideStrUtils, + apphelpers, dbconnection, dbstructures, gnugettext, extra_controls; type TFrame = TDBObjectEditor; @@ -62,7 +62,6 @@ TfrmEventEditor = class(TFrame) public { Public declarations } constructor Create(AOwner: TComponent); override; - destructor Destroy; override; procedure Init(Obj: TDBObject); override; function ApplyModifications: TModalResult; override; end; @@ -81,13 +80,8 @@ constructor TfrmEventEditor.Create(AOwner: TComponent); comboEveryInterval.Items := Explode('|', 'YEAR|QUARTER|MONTH|DAY|HOUR|MINUTE|WEEK|SECOND|YEAR_MONTH|'+ 'DAY_HOUR|DAY_MINUTE|DAY_SECOND|HOUR_MINUTE|HOUR_SECOND|MINUTE_SECOND'); grpState.Items := Explode('|', 'Enable|Disable|Disable on slave'); -end; - - -destructor TfrmEventEditor.Destroy; -begin - // Store GUI setup? Nothing yet. - inherited; + FMainSynMemo := SynMemoBody; + btnSave.Hint := ShortCutToText(MainForm.actSaveSQL.ShortCut); end; @@ -117,7 +111,7 @@ procedure TfrmEventEditor.Init(Obj: TDBObject); udEveryQuantity.Position := 1; comboEveryInterval.ItemIndex := comboEveryInterval.Items.IndexOf('DAY'); tabALTERcode.TabVisible := False; - if DBObject.Name <> '' then begin + if ObjectExists then begin // Edit mode tabALTERcode.TabVisible := True; editName.Text := DBObject.Name; @@ -195,6 +189,7 @@ procedure TfrmEventEditor.Init(Obj: TDBObject); SynMemoBody.Text := rx.Match[1]; rx.Free; + SynMemoBody.TopLine := FMainSynMemoPreviousTopLine; end; radioScheduleClick(Self); @@ -202,6 +197,7 @@ procedure TfrmEventEditor.Init(Obj: TDBObject); btnSave.Enabled := Modified; btnDiscard.Enabled := Modified; Mainform.ShowStatusMsg; + TExtForm.PageControlTabHighlight(PageControlMain); Screen.Cursor := crDefault; end; @@ -229,15 +225,16 @@ function TfrmEventEditor.ApplyModifications: TModalResult; begin // Create or alter table Result := mrOk; - if DBObject.Name = '' then + if not ObjectExists then sql := ComposeCreateStatement else sql := ComposeAlterStatement; try MainForm.ActiveConnection.Query(sql); + MainForm.ActiveConnection.ShowWarnings; DBObject.Name := editName.Text; DBObject.UnloadDetails; - tabALTERcode.TabVisible := DBObject.Name <> ''; + tabALTERcode.TabVisible := ObjectExists; Mainform.UpdateEditorTab; Mainform.RefreshTree(DBObject); Modified := False; @@ -276,7 +273,7 @@ function TfrmEventEditor.ComposeStatement(CreateOrAlter, ObjName: String): Strin Result := CreateOrAlter + ' '; if comboDefiner.Text <> '' then Result := Result + 'DEFINER='+DBObject.Connection.QuoteIdent(comboDefiner.Text, True, '@')+' '; - Result := Result + 'EVENT ' + DBObject.Connection.QuoteIdent(ObjName) + CRLF + #9 + 'ON SCHEDULE' + CRLF + #9#9; + Result := Result + 'EVENT ' + DBObject.Connection.QuoteIdent(ObjName) + sLineBreak + CodeIndent + 'ON SCHEDULE' + sLineBreak + CodeIndent(2); if radioOnce.Checked then begin d := dateOnce.DateTime; ReplaceTime(d, timeOnce.DateTime); @@ -301,20 +298,21 @@ function TfrmEventEditor.ComposeStatement(CreateOrAlter, ObjName: String): Strin end; if chkDropAfterExpiration.Checked then - Result := Result + #9 + 'ON COMPLETION NOT PRESERVE' + Result := Result + CodeIndent + 'ON COMPLETION NOT PRESERVE' else - Result := Result + #9 + 'ON COMPLETION PRESERVE'; - if (DBObject.Name <> '') and (DBObject.Name <> editName.Text) then - Result := Result + CRLF + #9 + 'RENAME TO ' + DBObject.Connection.QuoteIdent(editName.Text); - Result := Result + CRLF + #9 + UpperCase(grpState.Items[grpState.ItemIndex]); - Result := Result + CRLF + #9 + 'COMMENT ' + DBObject.Connection.EscapeString(editComment.Text); - Result := Result + CRLF + #9 + 'DO ' + SynMemoBody.Text; + Result := Result + CodeIndent + 'ON COMPLETION PRESERVE'; + if ObjectExists and (DBObject.Name <> editName.Text) then + Result := Result + sLineBreak + CodeIndent + 'RENAME TO ' + DBObject.Connection.QuoteIdent(editName.Text); + Result := Result + sLineBreak + CodeIndent + UpperCase(grpState.Items[grpState.ItemIndex]); + Result := Result + sLineBreak + CodeIndent + 'COMMENT ' + DBObject.Connection.EscapeString(editComment.Text); + Result := Result + sLineBreak + CodeIndent + 'DO ' + SynMemoBody.Text; end; procedure TfrmEventEditor.PageControlMainChange(Sender: TObject); begin UpdateSQLcode; + TExtForm.PageControlTabHighlight(PageControlMain); end; diff --git a/source/exportgrid.dfm b/source/exportgrid.dfm index a48fb6e6a..efbaf7bcf 100644 --- a/source/exportgrid.dfm +++ b/source/exportgrid.dfm @@ -3,107 +3,82 @@ object frmExportGrid: TfrmExportGrid Top = 0 BorderIcons = [biSystemMenu] Caption = 'Export grid rows' - ClientHeight = 445 - ClientWidth = 373 + ClientHeight = 412 + ClientWidth = 574 Color = clBtnFace - Constraints.MinHeight = 480 - Constraints.MinWidth = 350 + Constraints.MinHeight = 450 + Constraints.MinWidth = 530 Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText - Font.Height = -11 + Font.Height = -12 Font.Name = 'Tahoma' Font.Style = [] - OldCreateOrder = False Position = poMainFormCenter OnClose = FormClose OnCreate = FormCreate - OnDestroy = FormDestroy - OnResize = FormResize OnShow = FormShow DesignSize = ( - 373 - 445) - PixelsPerInch = 96 - TextHeight = 13 + 574 + 412) + TextHeight = 14 object btnOK: TButton - Left = 209 - Top = 412 + Left = 410 + Top = 379 Width = 75 Height = 25 Anchors = [akRight, akBottom] Caption = 'OK' Default = True ModalResult = 1 - TabOrder = 0 + TabOrder = 5 OnClick = btnOKClick end object btnCancel: TButton - Left = 290 - Top = 412 + Left = 491 + Top = 379 Width = 75 Height = 25 Anchors = [akRight, akBottom] Cancel = True Caption = 'Cancel' ModalResult = 2 - TabOrder = 1 - end - object grpFormat: TRadioGroup - Left = 8 - Top = 112 - Width = 137 - Height = 294 - Anchors = [akLeft, akTop, akBottom] - Caption = 'Output format' - ItemIndex = 0 - Items.Strings = ( - 'Excel compatible' - 'Delimited text' - 'HTML table' - 'XML' - 'SQL INSERTs' - 'SQL REPLACEs' - 'LaTeX' - 'Wiki markup' - 'PHP Array') - TabOrder = 2 - OnClick = grpFormatClick + TabOrder = 6 end object grpSelection: TRadioGroup - Left = 151 - Top = 112 - Width = 214 + Left = 8 + Top = 168 + Width = 558 Height = 66 - Anchors = [akTop, akRight] + Anchors = [akLeft, akTop, akRight] Caption = 'Row selection' ItemIndex = 1 Items.Strings = ( 'Selected rows' 'All loaded rows') - TabOrder = 3 + TabOrder = 2 end object grpOutput: TGroupBox Left = 8 Top = 8 - Width = 357 + Width = 558 Height = 98 Anchors = [akLeft, akTop, akRight] Caption = 'Output target' - TabOrder = 4 + TabOrder = 0 DesignSize = ( - 357 + 558 98) object lblEncoding: TLabel Left = 8 Top = 72 - Width = 47 - Height = 13 + Width = 54 + Height = 14 Caption = 'Encoding:' end object radioOutputCopyToClipboard: TRadioButton Left = 8 Top = 18 - Width = 335 + Width = 540 Height = 17 Anchors = [akLeft, akTop, akRight] Caption = 'Copy to clipboard' @@ -124,8 +99,8 @@ object frmExportGrid: TfrmExportGrid object editFilename: TButtonedEdit Left = 79 Top = 42 - Width = 264 - Height = 21 + Width = 469 + Height = 22 Anchors = [akLeft, akTop, akRight] Images = MainForm.VirtualImageListMain LeftButton.DropDownMenu = popupRecentFiles @@ -142,152 +117,164 @@ object frmExportGrid: TfrmExportGrid object comboEncoding: TComboBox Left = 79 Top = 69 - Width = 264 - Height = 21 + Width = 469 + Height = 22 Style = csDropDownList Anchors = [akLeft, akTop, akRight] TabOrder = 3 end end object grpOptions: TGroupBox - Left = 151 - Top = 184 - Width = 214 - Height = 222 - Anchors = [akTop, akRight, akBottom] + Left = 8 + Top = 240 + Width = 558 + Height = 133 + Anchors = [akLeft, akTop, akRight, akBottom] Caption = 'Options' - TabOrder = 5 + TabOrder = 3 DesignSize = ( - 214 - 222) + 558 + 133) object lblSeparator: TLabel - Left = 6 - Top = 116 - Width = 76 - Height = 13 + Left = 279 + Top = 18 + Width = 83 + Height = 14 Caption = 'Field separator:' end object lblEncloser: TLabel - Left = 6 - Top = 141 - Width = 44 - Height = 13 + Left = 279 + Top = 44 + Width = 49 + Height = 14 Caption = 'Encloser:' end object lblTerminator: TLabel - Left = 6 - Top = 167 - Width = 76 - Height = 13 + Left = 279 + Top = 71 + Width = 87 + Height = 14 Caption = 'Line terminator:' end object lblNull: TLabel - Left = 6 - Top = 194 - Width = 57 - Height = 13 + Left = 279 + Top = 97 + Width = 64 + Height = 14 Caption = 'NULL value:' end object chkIncludeColumnNames: TCheckBox - Left = 6 + Left = 8 Top = 18 - Width = 191 + Width = 257 Height = 17 - Anchors = [akLeft, akTop, akRight] Caption = 'Include column names' Checked = True State = cbChecked TabOrder = 0 end object editSeparator: TButtonedEdit - Left = 106 - Top = 112 - Width = 93 - Height = 21 + Left = 400 + Top = 15 + Width = 148 + Height = 22 Anchors = [akLeft, akTop, akRight] Images = MainForm.VirtualImageListMain RightButton.DisabledImageIndex = 107 RightButton.ImageIndex = 108 RightButton.Visible = True - TabOrder = 3 + TabOrder = 6 Text = ';' OnChange = editCSVChange OnRightButtonClick = editCSVRightButtonClick end object editEncloser: TButtonedEdit - Left = 106 - Top = 138 - Width = 93 - Height = 21 + Left = 400 + Top = 41 + Width = 148 + Height = 22 Anchors = [akLeft, akTop, akRight] Images = MainForm.VirtualImageListMain RightButton.DisabledImageIndex = 107 RightButton.ImageIndex = 108 RightButton.Visible = True - TabOrder = 4 + TabOrder = 7 OnChange = editCSVChange OnRightButtonClick = editCSVRightButtonClick end object editTerminator: TButtonedEdit - Left = 106 - Top = 164 - Width = 93 - Height = 21 + Left = 400 + Top = 68 + Width = 148 + Height = 22 Anchors = [akLeft, akTop, akRight] Images = MainForm.VirtualImageListMain RightButton.DisabledImageIndex = 107 RightButton.ImageIndex = 108 RightButton.Visible = True - TabOrder = 5 + TabOrder = 8 Text = '\r\n' OnChange = editCSVChange OnRightButtonClick = editCSVRightButtonClick end object chkIncludeAutoIncrement: TCheckBox - Left = 6 + Left = 8 Top = 41 - Width = 191 + Width = 257 Height = 17 - Anchors = [akLeft, akTop, akRight] Caption = 'Include auto increment column' TabOrder = 1 end object chkIncludeQuery: TCheckBox - Left = 6 - Top = 64 - Width = 191 + Left = 8 + Top = 87 + Width = 257 Height = 17 - Anchors = [akLeft, akTop, akRight] Caption = 'Include SQL query' - TabOrder = 2 + TabOrder = 3 end object editNull: TButtonedEdit - Left = 106 - Top = 191 - Width = 93 - Height = 21 + Left = 400 + Top = 94 + Width = 148 + Height = 22 Anchors = [akLeft, akTop, akRight] Images = MainForm.VirtualImageListMain RightButton.DisabledImageIndex = 107 RightButton.ImageIndex = 108 RightButton.Visible = True - TabOrder = 6 + TabOrder = 9 OnChange = editCSVChange OnRightButtonClick = editCSVRightButtonClick end object chkRemoveLinebreaks: TCheckBox - Left = 6 - Top = 87 - Width = 191 + Left = 8 + Top = 110 + Width = 257 Height = 17 - Anchors = [akLeft, akTop, akRight] Caption = 'Remove linebreaks from contents' - TabOrder = 7 + TabOrder = 4 + end + object chkOpenFile: TCheckBox + Left = 8 + Top = 133 + Width = 257 + Height = 17 + Caption = 'Open file after creation' + TabOrder = 5 + end + object chkFocusedColumnOnly: TCheckBox + Left = 8 + Top = 64 + Width = 265 + Height = 17 + Caption = 'Only focused column (%s)' + TabOrder = 2 end end object btnSetClipboardDefaults: TButton Left = 8 - Top = 412 + Top = 379 Width = 153 Height = 25 Anchors = [akLeft, akBottom] @@ -295,12 +282,50 @@ object frmExportGrid: TfrmExportGrid ImageIndex = 4 ImageName = 'icons8-paste-100' Images = MainForm.VirtualImageListMain - TabOrder = 6 + TabOrder = 4 OnClick = btnSetClipboardDefaultsClick end + object grpFormat: TGroupBox + Left = 8 + Top = 112 + Width = 558 + Height = 50 + Anchors = [akLeft, akTop, akRight] + Caption = 'Output format' + TabOrder = 1 + DesignSize = ( + 558 + 50) + object comboFormat: TComboBoxEx + Left = 8 + Top = 18 + Width = 540 + Height = 23 + ItemsEx = < + item + Caption = 'Excel CSV' + ImageIndex = 49 + SelectedImageIndex = 49 + end + item + Caption = 'CSV' + ImageIndex = 50 + SelectedImageIndex = 50 + end + item + Caption = '...' + end> + Style = csExDropDownList + Anchors = [akLeft, akTop, akRight] + TabOrder = 0 + OnSelect = comboFormatSelect + Images = MainForm.VirtualImageListMain + DropDownCount = 20 + end + end object popupCSVchar: TPopupMenu AutoHotkeys = maManual - Left = 224 + Left = 160 Top = 6 object menuCSVtab: TMenuItem Caption = 'Tab' @@ -370,7 +395,7 @@ object frmExportGrid: TfrmExportGrid object popupRecentFiles: TPopupMenu AutoHotkeys = maManual OnPopup = popupRecentFilesPopup - Left = 312 + Left = 248 Top = 6 end end diff --git a/source/exportgrid.pas b/source/exportgrid.pas index c219eb9ef..7fed89244 100644 --- a/source/exportgrid.pas +++ b/source/exportgrid.pas @@ -3,17 +3,34 @@ interface uses - Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, - Dialogs, StdCtrls, ExtCtrls, Menus, ComCtrls, VirtualTrees, SynExportHTML, gnugettext, ActnList, - extra_controls, dbstructures, SynRegExpr; + Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, + Vcl.Dialogs, Vcl.StdCtrls, Vcl.ExtCtrls, Vcl.Menus, Vcl.ComCtrls, VirtualTrees, SynExportHTML, gnugettext, Vcl.ActnList, + extra_controls, dbstructures, SynRegExpr, System.StrUtils, System.IOUtils, VirtualTrees.BaseTree, VirtualTrees.Types; type - TGridExportFormat = (efExcel, efCSV, efHTML, efXML, efSQLInsert, efSQLReplace, efSQLDeleteInsert, efLaTeX, efWiki, efPHPArray, efMarkDown, efJSON); + TGridExportFormat = ( + efExcel, + efCSV, + efHTML, + efXML, + efSQLInsert, + efSQLInsertIgnore, + efSQLReplace, + efSQLDeleteInsert, + efSQLUpdate, + efLaTeX, + efTextile, + efJiraTextile, + efPHPArray, + efMarkDown, + efJSON, + efJSONLines + ); TfrmExportGrid = class(TExtForm) btnOK: TButton; btnCancel: TButton; - grpFormat: TRadioGroup; + chkFocusedColumnOnly: TCheckBox; grpSelection: TRadioGroup; grpOutput: TGroupBox; radioOutputCopyToClipboard: TRadioButton; @@ -51,8 +68,10 @@ TfrmExportGrid = class(TExtForm) editNull: TButtonedEdit; btnSetClipboardDefaults: TButton; chkRemoveLinebreaks: TCheckBox; + grpFormat: TGroupBox; + comboFormat: TComboBoxEx; + chkOpenFile: TCheckBox; procedure FormCreate(Sender: TObject); - procedure FormDestroy(Sender: TObject); procedure CalcSize(Sender: TObject); procedure FormClose(Sender: TObject; var Action: TCloseAction); procedure editFilenameRightButtonClick(Sender: TObject); @@ -64,9 +83,8 @@ TfrmExportGrid = class(TExtForm) procedure ValidateControls(Sender: TObject); procedure btnOKClick(Sender: TObject); procedure FormShow(Sender: TObject); - procedure grpFormatClick(Sender: TObject); + procedure comboFormatSelect(Sender: TObject); procedure btnSetClipboardDefaultsClick(Sender: TObject); - procedure FormResize(Sender: TObject); private { Private declarations } FCSVEditor: TButtonedEdit; @@ -74,21 +92,76 @@ TfrmExportGrid = class(TExtForm) FGrid: TVirtualStringTree; FRecentFiles: TStringList; FHiddenCopyMode: Boolean; - const FFormatToFileExtension: Array[TGridExportFormat] of String = - (('csv'), ('csv'), ('html'), ('xml'), ('sql'), ('sql'), ('sql'), ('LaTeX'), ('wiki'), ('php'), ('md'), ('json')); - const FFormatToDescription: Array[TGridExportFormat] of String = - (('Excel CSV'), ('Delimited text'), ('HTML table'), ('XML'), ('SQL INSERTs'), ('SQL REPLACEs'), ('SQL DELETEs/INSERTs'), ('LaTeX'), ('Wiki markup'), ('PHP Array'), ('Markdown Here'), ('JSON')); procedure SaveDialogTypeChange(Sender: TObject); function GetExportFormat: TGridExportFormat; procedure SetExportFormat(Value: TGridExportFormat); procedure SetExportFormatByFilename; procedure SelectRecentFile(Sender: TObject); procedure PutFilenamePlaceholder(Sender: TObject); - function FormatExcelCsv(Text, Encloser: String; DataType: TDBDatatype): String; + function FormatCsv(Text, Encloser: String; DataType: TDBDatatype; SubFormat: TGridExportFormat): String; + function FormatJson(Text: String): String; function FormatPhp(Text: String): String; function FormatLatex(Text: String): String; public { Public declarations } + const FormatToFileExtension: Array[TGridExportFormat] of String = + ( + ('csv'), + ('csv'), + ('html'), + ('xml'), + ('sql'), + ('sql'), + ('sql'), + ('sql'), + ('sql'), + ('LaTeX'), + ('textile'), + ('jira-textile'), + ('php'), + ('md'), + ('json'), + ('jsonl') + ); + const FormatToDescription: Array[TGridExportFormat] of String = + ( + ('Excel CSV'), + ('Delimited text'), + ('HTML table'), + ('XML'), + ('SQL INSERTs'), + ('SQL INSERT IGNOREs'), + ('SQL REPLACEs'), + ('SQL DELETEs/INSERTs'), + ('SQL UPDATEs'), + ('LaTeX'), + ('Textile'), + ('Jira Textile'), + ('PHP Array'), + ('Markdown Here'), + ('JSON'), + ('JSON Lines') + ); + const FormatToImageIndex: Array[TGridExportFormat] of Integer = + ( + 49, // Excel + 50, // CSV + 32, // HTML + 48, // XML + 201, // SQL + 201, // SQL + 201, // SQL + 201, // SQL + 201, // SQL + 153, // Latex + 154, // Textile + 154, // Jira + 202, // PHP + 199, // Markdown + 200, // JSON + 200 // JSON Lines + ); + const CopyAsActionPrefix = 'actCopyAs'; property Grid: TVirtualStringTree read FGrid write FGrid; property ExportFormat: TGridExportFormat read GetExportFormat write SetExportFormat; end; @@ -104,29 +177,35 @@ implementation procedure TfrmExportGrid.FormCreate(Sender: TObject); var - FormatDesc: String; + ef: TGridExportFormat; + SenderName: String; + comboItem: TComboExItem; begin HasSizeGrip := True; - Width := AppSettings.ReadInt(asGridExportWindowWidth); - Height := AppSettings.ReadInt(asGridExportWindowHeight); editFilename.Text := AppSettings.ReadString(asGridExportFilename); FRecentFiles := Explode(DELIM, AppSettings.ReadString(asGridExportRecentFiles)); comboEncoding.Items.Assign(MainForm.FileEncodings); comboEncoding.Items.Delete(0); // Remove "Auto detect" comboEncoding.ItemIndex := AppSettings.ReadInt(asGridExportEncoding); - grpFormat.Items.Clear; - for FormatDesc in FFormatToDescription do - grpFormat.Items.Add(FormatDesc); - FHiddenCopyMode := Owner = MainForm.actCopyRows; + comboFormat.Items.Clear; + for ef:=Low(TGridExportFormat) to High(TGridExportFormat) do begin + comboItem := TComboExItem.Create(comboFormat.ItemsEx); + comboItem.Caption := FormatToDescription[ef]; + comboItem.ImageIndex := FormatToImageIndex[ef]; + end; + SenderName := Owner.Name; + FHiddenCopyMode := SenderName.StartsWith(CopyAsActionPrefix); if FHiddenCopyMode then begin radioOutputCopyToClipboard.Checked := True; - grpFormat.ItemIndex := AppSettings.ReadInt(asGridExportClpFormat); + comboFormat.ItemIndex := Owner.Tag; grpSelection.ItemIndex := 0; // Always use selected cells in copy mode chkIncludeColumnNames.Checked := AppSettings.ReadBool(asGridExportClpColumnNames); chkIncludeAutoIncrement.Checked := AppSettings.ReadBool(asGridExportClpIncludeAutoInc); + chkFocusedColumnOnly.Checked := False; chkIncludeQuery.Checked := False; // Always off in copy mode chkRemoveLinebreaks.Checked := AppSettings.ReadBool(asGridExportClpRemoveLinebreaks); + chkOpenFile.Checked := False; // Always off in copy mode FCSVSeparator := AppSettings.ReadString(asGridExportClpSeparator); FCSVEncloser := AppSettings.ReadString(asGridExportClpEncloser); FCSVTerminator := AppSettings.ReadString(asGridExportClpTerminator); @@ -134,12 +213,14 @@ procedure TfrmExportGrid.FormCreate(Sender: TObject); end else begin radioOutputCopyToClipboard.Checked := AppSettings.ReadBool(asGridExportOutputCopy); radioOutputFile.Checked := AppSettings.ReadBool(asGridExportOutputFile); - grpFormat.ItemIndex := AppSettings.ReadInt(asGridExportFormat); + comboFormat.ItemIndex := AppSettings.ReadInt(asGridExportFormat); grpSelection.ItemIndex := AppSettings.ReadInt(asGridExportSelection); chkIncludeColumnNames.Checked := AppSettings.ReadBool(asGridExportColumnNames); chkIncludeAutoIncrement.Checked := AppSettings.ReadBool(asGridExportIncludeAutoInc); + chkFocusedColumnOnly.Checked := AppSettings.ReadBool(asGridExportFocusedColumnOnly); chkIncludeQuery.Checked := AppSettings.ReadBool(asGridExportIncludeQuery); chkRemoveLinebreaks.Checked := AppSettings.ReadBool(asGridExportRemoveLinebreaks); + chkOpenFile.Checked := AppSettings.ReadBool(asGridExportOpenFile); FCSVSeparator := AppSettings.ReadString(asGridExportSeparator); FCSVEncloser := AppSettings.ReadString(asGridExportEncloser); FCSVTerminator := AppSettings.ReadString(asGridExportTerminator); @@ -149,54 +230,50 @@ procedure TfrmExportGrid.FormCreate(Sender: TObject); end; -procedure TfrmExportGrid.FormDestroy(Sender: TObject); -begin - // Store settings - if not FHiddenCopyMode then begin - AppSettings.WriteInt(asGridExportWindowWidth, Width); - AppSettings.WriteInt(asGridExportWindowHeight, Height); - if ModalResult = mrOK then begin - AppSettings.WriteBool(asGridExportOutputCopy, radioOutputCopyToClipboard.Checked); - AppSettings.WriteBool(asGridExportOutputFile, radioOutputFile.Checked); - AppSettings.WriteString(asGridExportFilename, editFilename.Text); - AppSettings.WriteString(asGridExportRecentFiles, ImplodeStr(DELIM, FRecentFiles)); - AppSettings.WriteInt(asGridExportEncoding, comboEncoding.ItemIndex); - AppSettings.WriteInt(asGridExportFormat, grpFormat.ItemIndex); - AppSettings.WriteInt(asGridExportSelection, grpSelection.ItemIndex); - AppSettings.WriteBool(asGridExportColumnNames, chkIncludeColumnNames.Checked); - AppSettings.WriteBool(asGridExportIncludeAutoInc, chkIncludeAutoIncrement.Checked); - AppSettings.WriteBool(asGridExportIncludeQuery, chkIncludeQuery.Checked); - AppSettings.WriteBool(asGridExportRemoveLinebreaks, chkRemoveLinebreaks.Checked); - AppSettings.WriteString(asGridExportSeparator, FCSVSeparator); - AppSettings.WriteString(asGridExportEncloser, FCSVEncloser); - AppSettings.WriteString(asGridExportTerminator, FCSVTerminator); - AppSettings.WriteString(asGridExportNull, FCSVNull); - end; - end; -end; - - -procedure TfrmExportGrid.FormResize(Sender: TObject); -begin - grpFormat.Width := Width div 3; - grpSelection.Left := grpFormat.Left + grpFormat.Width + 8; - grpSelection.Width := Width - grpSelection.Left - 24; - grpOptions.Left := grpSelection.Left; - grpOptions.Width := grpSelection.Width; -end; - procedure TfrmExportGrid.FormShow(Sender: TObject); +var + FocusedCol: String; begin // Show dialog. Expect "Grid" property to be set now by the caller. + Width := AppSettings.ReadIntDpiAware(asGridExportWindowWidth, Self); + Height := AppSettings.ReadIntDpiAware(asGridExportWindowHeight, Self); chkIncludeAutoIncrement.OnClick := CalcSize; + chkFocusedColumnOnly.OnClick := CalcSize; CalcSize(Sender); + // Show name of focused column + if Grid.FocusedColumn > -1 then + FocusedCol := Grid.Header.Columns[Grid.FocusedColumn].Text + else + FocusedCol := ''; + chkFocusedColumnOnly.Caption := f_('Only focused column (%s)', [FocusedCol]); + chkFocusedColumnOnly.Enabled := not FocusedCol.IsEmpty; end; procedure TfrmExportGrid.FormClose(Sender: TObject; var Action: TCloseAction); begin - // Destroy dialog - not cached - Action := caFree; + // Store settings + AppSettings.WriteIntDpiAware(asGridExportWindowWidth, Self, Width); + AppSettings.WriteIntDpiAware(asGridExportWindowHeight, Self, Height); + if ModalResult = mrOK then begin + AppSettings.WriteBool(asGridExportOutputCopy, radioOutputCopyToClipboard.Checked); + AppSettings.WriteBool(asGridExportOutputFile, radioOutputFile.Checked); + AppSettings.WriteString(asGridExportFilename, editFilename.Text); + AppSettings.WriteString(asGridExportRecentFiles, Implode(DELIM, FRecentFiles)); + AppSettings.WriteInt(asGridExportEncoding, comboEncoding.ItemIndex); + AppSettings.WriteInt(asGridExportFormat, comboFormat.ItemIndex); + AppSettings.WriteInt(asGridExportSelection, grpSelection.ItemIndex); + AppSettings.WriteBool(asGridExportColumnNames, chkIncludeColumnNames.Checked); + AppSettings.WriteBool(asGridExportIncludeAutoInc, chkIncludeAutoIncrement.Checked); + AppSettings.WriteBool(asGridExportFocusedColumnOnly, chkFocusedColumnOnly.Checked); + AppSettings.WriteBool(asGridExportIncludeQuery, chkIncludeQuery.Checked); + AppSettings.WriteBool(asGridExportRemoveLinebreaks, chkRemoveLinebreaks.Checked); + AppSettings.WriteBool(asGridExportOpenFile, chkOpenFile.Checked); + AppSettings.WriteString(asGridExportSeparator, FCSVSeparator); + AppSettings.WriteString(asGridExportEncloser, FCSVEncloser); + AppSettings.WriteString(asGridExportTerminator, FCSVTerminator); + AppSettings.WriteString(asGridExportNull, FCSVNull); + end; end; @@ -236,6 +313,7 @@ procedure TfrmExportGrid.ValidateControls(Sender: TObject); end; chkIncludeQuery.Enabled := ExportFormat in [efHTML, efXML, efMarkDown, efJSON]; + chkOpenFile.Enabled := radioOutputFile.Checked; Enable := ExportFormat = efCSV; lblSeparator.Enabled := Enable; editSeparator.Enabled := Enable; @@ -261,17 +339,19 @@ procedure TfrmExportGrid.ValidateControls(Sender: TObject); function TfrmExportGrid.GetExportFormat: TGridExportFormat; begin - Result := TGridExportFormat(grpFormat.ItemIndex); + // This is slow, don't use in large loops + Result := TGridExportFormat(comboFormat.ItemIndex); end; procedure TfrmExportGrid.SetExportFormat(Value: TGridExportFormat); begin - grpFormat.ItemIndex := Integer(Value); + comboFormat.ItemIndex := Integer(Value); + ValidateControls(Self); end; -procedure TfrmExportGrid.grpFormatClick(Sender: TObject); +procedure TfrmExportGrid.comboFormatSelect(Sender: TObject); var Filename: String; begin @@ -279,8 +359,8 @@ procedure TfrmExportGrid.grpFormatClick(Sender: TObject); // Be careful about triggering editFilename.OnChange event, as we may have come here from that event! if radioOutputFile.Checked then begin Filename := ExtractFilePath(editFilename.Text) + - ExtractBaseFileName(editFilename.Text) + - '.' + FFormatToFileExtension[ExportFormat]; + TPath.GetFileNameWithoutExtension(editFilename.Text) + + '.' + FormatToFileExtension[ExportFormat]; if CompareText(Filename, editFilename.Text) <> 0 then editFilename.Text := Filename; end; @@ -296,9 +376,9 @@ procedure TfrmExportGrid.SetExportFormatByFilename; // Set format by file extension ext := LowerCase(Copy(ExtractFileExt(editFilename.Text), 2, 10)); for efrm :=Low(TGridExportFormat) to High(TGridExportFormat) do begin - if ext = FFormatToFileExtension[ExportFormat] then + if ext = FormatToFileExtension[ExportFormat] then break; - if ext = FFormatToFileExtension[efrm] then begin + if ext = FormatToFileExtension[efrm] then begin ExportFormat := efrm; break; end; @@ -322,13 +402,13 @@ procedure TfrmExportGrid.editFilenameRightButtonClick(Sender: TObject); Dialog := TSaveDialog.Create(Self); Filename := GetOutputFilename(editFilename.Text, MainForm.ActiveDbObj); Dialog.InitialDir := ExtractFilePath(Filename); - Dialog.FileName := ExtractBaseFileName(Filename); + Dialog.FileName := TPath.GetFileNameWithoutExtension(Filename); Dialog.Filter := ''; for ef:=Low(TGridExportFormat) to High(TGridExportFormat) do - Dialog.Filter := Dialog.Filter + FFormatToDescription[ef] + ' (*.'+FFormatToFileExtension[ef]+')|*.'+FFormatToFileExtension[ef]+'|'; + Dialog.Filter := Dialog.Filter + FormatToDescription[ef] + ' (*.'+FormatToFileExtension[ef]+')|*.'+FormatToFileExtension[ef]+'|'; Dialog.Filter := Dialog.Filter + _('All files')+' (*.*)|*.*'; Dialog.OnTypeChange := SaveDialogTypeChange; - Dialog.FilterIndex := grpFormat.ItemIndex+1; + Dialog.FilterIndex := comboFormat.ItemIndex+1; Dialog.OnTypeChange(Dialog); if Dialog.Execute then begin editFilename.Text := Dialog.FileName; @@ -395,7 +475,6 @@ procedure TfrmExportGrid.btnSetClipboardDefaultsClick(Sender: TObject); begin // Store copy-to-clipboard settings AppSettings.ResetPath; - AppSettings.WriteInt(asGridExportClpFormat, grpFormat.ItemIndex); AppSettings.WriteBool(asGridExportClpColumnNames, chkIncludeColumnNames.Checked); AppSettings.WriteBool(asGridExportClpIncludeAutoInc, chkIncludeAutoIncrement.Checked); AppSettings.WriteBool(asGridExportRemoveLinebreaks, chkRemoveLinebreaks.Checked); @@ -411,43 +490,63 @@ procedure TfrmExportGrid.CalcSize(Sender: TObject); var GridData: TDBQuery; Node: PVirtualNode; - Col, ExcludeCol: TColumnIndex; + Col, ExcludeAutoIncCol, IncludeFocusedCol: TColumnIndex; + ResultCol: Integer; RowNum: PInt64; - SelectionSize, AllSize, RowsCalculated: Int64; + SelectedSize, AllSize: Int64; + CalculatedCount, SelectedCount, AllCount: Int64; + DoIncludeCol: Boolean; begin GridData := Mainform.GridResult(Grid); + if not Assigned(GridData) then begin + MainForm.LogSQL('Failed to get current results'); + Exit; + end; AllSize := 0; - SelectionSize := 0; - chkIncludeAutoIncrement.Enabled := GridData.AutoIncrementColumn > -1; - ExcludeCol := -1; + SelectedSize := 0; + chkIncludeAutoIncrement.Enabled := (GridData.AutoIncrementColumn > -1) and (not chkFocusedColumnOnly.Checked); + ExcludeAutoIncCol := -1; if chkIncludeAutoIncrement.Enabled and (not chkIncludeAutoIncrement.Checked) then - ExcludeCol := GridData.AutoIncrementColumn; + ExcludeAutoIncCol := GridData.AutoIncrementColumn; + IncludeFocusedCol := -1; + if chkFocusedColumnOnly.Enabled and chkFocusedColumnOnly.Checked then + IncludeFocusedCol := Grid.FocusedColumn; Node := GetNextNode(Grid, nil, False); - RowsCalculated := 0; + CalculatedCount := 0; + AllCount := 0; + SelectedCount := 0; while Assigned(Node) do begin - RowNum := Grid.GetNodeData(Node); - GridData.RecNo := RowNum^; - Col := Grid.Header.Columns.GetFirstVisibleColumn; - while Col > NoColumn do begin - if Col <> ExcludeCol then begin - Inc(AllSize, GridData.ColumnLengths(Col)); - if vsSelected in Node.States then - Inc(SelectionSize, GridData.ColumnLengths(Col)); + Inc(AllCount); + if vsSelected in Node.States then + Inc(SelectedCount); + + if CalculatedCount < 1000 then begin + // Performance: use first rows only, and interpolate the rest, see issue #804 + RowNum := Grid.GetNodeData(Node); + GridData.RecNo := RowNum^; + Col := Grid.Header.Columns.GetFirstVisibleColumn(True); + while Col > NoColumn do begin + ResultCol := Col - 1; + DoIncludeCol := (Col <> ExcludeAutoIncCol) and + ((IncludeFocusedCol < 0) or (Col = IncludeFocusedCol)); + if DoIncludeCol then begin + Inc(AllSize, GridData.ColumnLengths(ResultCol)); + if vsSelected in Node.States then + Inc(SelectedSize, GridData.ColumnLengths(ResultCol)); + end; + Col := Grid.Header.Columns.GetNextVisibleColumn(Col); end; - Col := Grid.Header.Columns.GetNextVisibleColumn(Col); + Inc(CalculatedCount); end; - // Performance: use first rows only, and interpolate the rest, see issue #804 - Inc(RowsCalculated); - if RowsCalculated >= 1000 then - Break; + Node := GetNextNode(Grid, Node, False); end; - if GridData.RecordCount > RowsCalculated then begin - AllSize := Round(AllSize / RowsCalculated * GridData.RecordCount); + if AllCount > CalculatedCount then begin + AllSize := Round(AllSize / CalculatedCount * AllCount); end; - grpSelection.Items[0] := f_('Selection (%s rows, %s)', [FormatNumber(Grid.SelectedCount), FormatByteNumber(SelectionSize)]); - grpSelection.Items[1] := f_('Complete (%s rows, %s)', [FormatNumber(Grid.RootNodeCount), FormatByteNumber(AllSize)]); + grpSelection.Items[0] := f_('Selection (%s rows, %s)', [FormatNumber(SelectedCount), FormatByteNumber(SelectedSize)]); + grpSelection.Items[1] := f_('Complete (%s rows, %s)', [FormatNumber(AllCount), FormatByteNumber(AllSize)]); end; @@ -480,7 +579,7 @@ procedure TfrmExportGrid.SaveDialogTypeChange(Sender: TObject); Dialog := Sender as TSaveDialog; for ef:=Low(TGridExportFormat) to High(TGridExportFormat) do begin if Dialog.FilterIndex = Integer(ef)+1 then - Dialog.DefaultExt := FFormatToFileExtension[ef]; + Dialog.DefaultExt := FormatToFileExtension[ef]; end; end; @@ -507,19 +606,20 @@ procedure TfrmExportGrid.menuCSVClick(Sender: TObject); end; -function TfrmExportGrid.FormatExcelCsv(Text, Encloser: String; DataType: TDBDatatype): String; +function TfrmExportGrid.FormatCsv(Text, Encloser: String; DataType: TDBDatatype; SubFormat: TGridExportFormat): String; begin Result := Text; // Escape encloser characters inside data per de-facto CSV. if not Encloser.IsEmpty then Result := StringReplace(Result, Encloser, Encloser+Encloser, [rfReplaceAll]); - if DataType.Category = dtcTemporal then begin - Result := ReplaceRegExpr('\.(\d+)$', Result, FormatSettings.DecimalSeparator + '$1', True); + // Remove milliseconds from date/time values, unsupported by Excel. See issue #922 + if (SubFormat = efExcel) and (DataType.Category = dtcTemporal) then begin + Result := ReplaceRegExpr('\.(\d+)$', Result, ''); end; end; -function TfrmExportGrid.FormatPhp(Text: String): String; +function TfrmExportGrid.FormatJson(Text: String): String; begin // String escaping for PHP output. Incompatible to TDBConnection.EscapeString. Result := StringReplace(Text, '\', '\\', [rfReplaceAll]); @@ -530,6 +630,28 @@ function TfrmExportGrid.FormatPhp(Text: String): String; Result := '"' + Result + '"'; end; +function TfrmExportGrid.FormatPhp(Text: String): String; +begin + if Text.IndexOfAny([#10, #13, #9, #11, #27, #12]) > -1 then begin + // https://www.php.net/manual/it/language.types.string.php#language.types.string.syntax.double + Result := StringReplace(Text, '\', '\\', [rfReplaceAll]); + Result := StringReplace(Result, #10, '\n', [rfReplaceAll]); + Result := StringReplace(Result, #13, '\r', [rfReplaceAll]); + Result := StringReplace(Result, #9, '\t', [rfReplaceAll]); + Result := StringReplace(Result, #11, '\v', [rfReplaceAll]); + Result := StringReplace(Result, #27, '\e', [rfReplaceAll]); + Result := StringReplace(Result, #12, '\f', [rfReplaceAll]); + Result := StringReplace(Result, '$', '\$', [rfReplaceAll]); + Result := StringReplace(Result, '"', '\"', [rfReplaceAll]); + Result := '"' + Result + '"'; + end else begin + // https://www.php.net/manual/it/language.types.string.php#language.types.string.syntax.single + Result := StringReplace(Text, '\', '\\', [rfReplaceAll]); + Result := StringReplace(Text, '''', '\''', [rfReplaceAll]); + Result := '''' + Result + ''''; + end; +end; + function TfrmExportGrid.FormatLatex(Text: String): String; var @@ -549,11 +671,12 @@ function TfrmExportGrid.FormatLatex(Text: String): String; procedure TfrmExportGrid.btnOKClick(Sender: TObject); var - Col, ExcludeCol: TColumnIndex; + Col, ExcludeAutoIncCol, IncludeFocusedCol: TColumnIndex; + ResultCol: Integer; Header, Data, tmp, Encloser, Separator, Terminator, TableName, Filename: String; Node: PVirtualNode; GridData: TDBQuery; - SelectionOnly: Boolean; + SelectionOnly, HasNulls: Boolean; i: Integer; NodeCount: Cardinal; RowNum: PInt64; @@ -562,6 +685,13 @@ procedure TfrmExportGrid.btnOKClick(Sender: TObject); Exporter: TSynExporterHTML; Encoding: TEncoding; Bom: TBytes; + CurrentExportFormat: TGridExportFormat; + + function DoIncludeCol: Boolean; + begin + Result := (Col <> ExcludeAutoIncCol) and + ((IncludeFocusedCol < 0) or (Col = IncludeFocusedCol)) + end; begin Filename := GetOutputFilename(editFilename.Text, MainForm.ActiveDbObj); @@ -590,9 +720,14 @@ procedure TfrmExportGrid.btnOKClick(Sender: TObject); except TableName := _('UnknownTable'); end; - ExcludeCol := NoColumn; - if (not chkIncludeAutoIncrement.Checked) or (not chkIncludeAutoIncrement.Enabled) then - ExcludeCol := GridData.AutoIncrementColumn; + ExcludeAutoIncCol := NoColumn; + if chkIncludeAutoIncrement.Enabled and (not chkIncludeAutoIncrement.Checked) then + ExcludeAutoIncCol := GridData.AutoIncrementColumn + 1; + IncludeFocusedCol := NoColumn; + if chkFocusedColumnOnly.Checked then + IncludeFocusedCol := Grid.FocusedColumn; + // Calling (Get)ExportFormat is slow, so we store it in a local variable + CurrentExportFormat := ExportFormat; if radioOutputCopyToClipboard.Checked then Encoding := TEncoding.UTF8 @@ -611,61 +746,57 @@ procedure TfrmExportGrid.btnOKClick(Sender: TObject); // Note that TStringStream + TEncoding.UTF8 do not write a BOM (which is nice), // although it should do so according to TUTF8Encoding.GetPreamble. // Now, only newer Excel versions need that BOM, so we add it explicitly here - S := TStringStream.Create(Header, Encoding); - if (ExportFormat = efExcel) and (Encoding = TEncoding.UTF8) then begin + // P.S.: Note the boolean/False parameter for OwnsEncoding, so our global encodings are not destroyed after usage + S := TStringStream.Create(Header, Encoding, False); + if (CurrentExportFormat = efExcel) and (Encoding = TEncoding.UTF8) and radioOutputFile.Checked then begin Bom := TBytes.Create($EF, $BB, $BF); S.Write(Bom, 3); end; Header := ''; - case ExportFormat of + case CurrentExportFormat of efHTML: begin Header := - '<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" ' + CRLF + - ' "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">' + CRLF + CRLF + - '<html>' + CRLF + - ' <head>' + CRLF + - ' <title>' + TableName + '' + CRLF + - ' ' + CRLF + - ' ' + CRLF + - ' ' + CRLF + - ' ' + CRLF + CRLF + - ' ' + CRLF + CRLF; + CodeIndent(2) + '' + sLineBreak + + CodeIndent + '' + sLineBreak + sLineBreak + + CodeIndent + '' + sLineBreak + sLineBreak; if chkIncludeQuery.Checked then - Header := Header + '

' + GridData.SQL + '

' + CRLF + CRLF; - Header := Header + ' ' + CRLF; + Header := Header + '

' + GridData.SQL + '

' + CRLF + CRLF; + Header := Header + CodeIndent(2) + '
' + sLineBreak; if chkIncludeColumnNames.Checked then begin Header := Header + - ' ' + CRLF + - ' ' + CRLF; - Col := Grid.Header.Columns.GetFirstVisibleColumn; + CodeIndent(3) + '' + sLineBreak + + CodeIndent(4) + '' + sLineBreak; + Col := Grid.Header.Columns.GetFirstVisibleColumn(True); while Col > NoColumn do begin - if Col <> ExcludeCol then - Header := Header + ' ' + CRLF; + if DoIncludeCol then + Header := Header + CodeIndent(5) + '' + sLineBreak; Col := Grid.Header.Columns.GetNextVisibleColumn(Col); end; Header := Header + - ' ' + CRLF + - ' ' + CRLF; + CodeIndent(4) + '' + sLineBreak + + CodeIndent(3) + '' + sLineBreak; end; - Header := Header + - ' ' + CRLF; + Header := Header + CodeIndent(3) + '' + sLineBreak; end; efExcel, efCSV: begin @@ -673,12 +804,13 @@ procedure TfrmExportGrid.btnOKClick(Sender: TObject); Encloser := GridData.Connection.UnescapeString(editEncloser.Text); Terminator := GridData.Connection.UnescapeString(editTerminator.Text); if chkIncludeColumnNames.Checked then begin - Col := Grid.Header.Columns.GetFirstVisibleColumn; + Col := Grid.Header.Columns.GetFirstVisibleColumn(True); while Col > NoColumn do begin // Alter column name in header if data is not raw. - if Col <> ExcludeCol then begin + ResultCol := Col - 1; + if DoIncludeCol then begin Data := Grid.Header.Columns[Col].Text; - if (GridData.DataType(Col).Category in [dtcBinary, dtcSpatial]) and (not Mainform.actBlobAsText.Checked) then + if (GridData.DataType(ResultCol).Category in [dtcBinary, dtcSpatial]) and (not Mainform.actBlobAsText.Checked) then Data := 'HEX(' + Data + ')'; // Add header item. if Header <> '' then @@ -706,17 +838,17 @@ procedure TfrmExportGrid.btnOKClick(Sender: TObject); Encloser := ''; Terminator := '\\ '+CRLF; Header := Header + '{'; - Col := Grid.Header.Columns.GetFirstVisibleColumn; + Col := Grid.Header.Columns.GetFirstVisibleColumn(True); while Col > NoColumn do begin - if Col <> ExcludeCol then + if DoIncludeCol then Header := Header + ' c '; Col := Grid.Header.Columns.GetNextVisibleColumn(Col); end; Header := Header + '}' + CRLF; if chkIncludeColumnNames.Checked then begin - Col := Grid.Header.Columns.GetFirstVisibleColumn; + Col := Grid.Header.Columns.GetFirstVisibleColumn(True); while Col > NoColumn do begin - if Col <> ExcludeCol then + if DoIncludeCol then Header := Header + FormatLatex(Grid.Header.Columns[Col].Text) + Separator; Col := Grid.Header.Columns.GetNextVisibleColumn(Col); end; @@ -725,28 +857,30 @@ procedure TfrmExportGrid.btnOKClick(Sender: TObject); end; end; - efWiki: begin - Separator := ' || '; + efTextile, efJiraTextile: begin + Separator := IfThen(CurrentExportFormat=efTextile, ' |_. ', ' || '); Encloser := ''; - Terminator := ' ||'+CRLF; + Terminator := IfThen(CurrentExportFormat=efTextile, ' |', ' ||') + CRLF; if chkIncludeColumnNames.Checked then begin - Header := '|| '; - Col := Grid.Header.Columns.GetFirstVisibleColumn; + Header := TrimLeft(Separator); + Col := Grid.Header.Columns.GetFirstVisibleColumn(True); while Col > NoColumn do begin - if Col <> ExcludeCol then - Header := Header + '*' + Grid.Header.Columns[Col].Text + '*' + Separator; + if DoIncludeCol then + Header := Header + Grid.Header.Columns[Col].Text + Separator; Col := Grid.Header.Columns.GetNextVisibleColumn(Col); end; Delete(Header, Length(Header)-Length(Separator)+1, Length(Separator)); Header := Header + Terminator; end; + Separator := ' | '; + Terminator := ' |' + CRLF; end; efPHPArray: begin if radioOutputFile.Checked then - Header := ' NoColumn do begin - if Col <> ExcludeCol then begin + if DoIncludeCol then begin if chkIncludeColumnNames.Checked then Header := Header + Grid.Header.Columns[Col].Text + Separator else @@ -770,11 +904,12 @@ procedure TfrmExportGrid.btnOKClick(Sender: TObject); Header := Header + Terminator; // Write an extra line with dashes below the heading, otherwise the table won't parse Header := Header + TrimLeft(Separator); - Col := Grid.Header.Columns.GetFirstVisibleColumn; + Col := Grid.Header.Columns.GetFirstVisibleColumn(True); while Col > NoColumn do begin - if Col <> ExcludeCol then begin + ResultCol := Col - 1; + if DoIncludeCol then begin Header := Header + '---'; - if GridData.DataType(Col).Category in [dtcInteger, dtcReal] then + if GridData.DataType(ResultCol).Category in [dtcInteger, dtcReal] then Header := Header + ':'; Header := Header + Separator; end; @@ -785,12 +920,12 @@ procedure TfrmExportGrid.btnOKClick(Sender: TObject); efJSON: begin // JavaScript Object Notation - Header := '{' + CRLF; + Header := '{' + sLineBreak; if chkIncludeQuery.Checked then - Header := Header + #9 + '"query": '+FormatPhp(GridData.SQL)+',' + CRLF + Header := Header + #9 + '"query": '+FormatJson(GridData.SQL)+',' + sLineBreak else - Header := Header + #9 + '"table": '+FormatPhp(TableName)+',' + CRLF ; - Header := Header + #9 + '"rows":' + CRLF + #9 + '['; + Header := Header + #9 + '"table": '+FormatJson(TableName)+',' + sLineBreak; + Header := Header + #9 + '"rows":' + sLineBreak + #9 + '['; end; end; @@ -812,27 +947,35 @@ procedure TfrmExportGrid.btnOKClick(Sender: TObject); GridData.RecNo := RowNum^; // Row preamble - case ExportFormat of - efHTML: tmp := ' ' + CRLF; + case CurrentExportFormat of + efHTML: tmp := CodeIndent(4) + '' + sLineBreak; - efXML: tmp := #9'' + CRLF; + efXML: tmp := CodeIndent + '' + sLineBreak; - efSQLInsert, efSQLReplace, efSQLDeleteInsert: begin + efSQLUpdate: begin tmp := ''; - if ExportFormat = efSQLDeleteInsert then begin + tmp := tmp + 'UPDATE ' + GridData.Connection.QuoteIdent(Tablename) + ' SET '; + end; + + efSQLInsert, efSQLInsertIgnore, efSQLReplace, efSQLDeleteInsert: begin + tmp := ''; + if CurrentExportFormat = efSQLDeleteInsert then begin tmp := tmp + 'DELETE FROM ' + GridData.Connection.QuoteIdent(Tablename) + ' WHERE' + GridData.GetWhereClause + ';' + CRLF; end; - if ExportFormat in [efSQLInsert, efSQLDeleteInsert] then + if CurrentExportFormat in [efSQLInsert, efSQLDeleteInsert] then tmp := tmp + 'INSERT' + else if CurrentExportFormat = efSQLInsertIgnore then + tmp := tmp + 'INSERT IGNORE' else tmp := tmp + 'REPLACE'; tmp := tmp + ' INTO '+GridData.Connection.QuoteIdent(Tablename); if chkIncludeColumnNames.Checked then begin tmp := tmp + ' ('; - Col := Grid.Header.Columns.GetFirstVisibleColumn; + Col := Grid.Header.Columns.GetFirstVisibleColumn(True); while Col > NoColumn do begin - if (Col <> ExcludeCol) and (not GridData.ColIsVirtual(Col)) then + ResultCol := Col - 1; + if DoIncludeCol and (not GridData.ColIsVirtual(ResultCol)) then tmp := tmp + GridData.Connection.QuoteIdent(Grid.Header.Columns[Col].Text)+', '; Col := Grid.Header.Columns.GetNextVisibleColumn(Col); end; @@ -842,58 +985,66 @@ procedure TfrmExportGrid.btnOKClick(Sender: TObject); tmp := tmp + ' VALUES ('; end; - efWiki: tmp := TrimLeft(Separator); + efTextile, efJiraTextile: tmp := TrimLeft(Separator); - efPHPArray: tmp := #9 + 'array('+CRLF; + efPHPArray: tmp := CodeIndent + '[' + sLineBreak; efMarkDown: tmp := '| '; efJSON: begin if chkIncludeColumnNames.Checked then - tmp := CRLF + #9#9 + '{' + CRLF + tmp := sLineBreak + CodeIndent(2) + '{' + sLineBreak else - tmp := CRLF + #9#9 + '[' + CRLF + tmp := sLineBreak + CodeIndent(2) + '[' + sLineBreak + end; + + efJSONLines: begin + if chkIncludeColumnNames.Checked then + tmp := '{' + else + tmp := '['; end else tmp := ''; end; // Row contents - Col := Grid.Header.Columns.GetFirstVisibleColumn; + Col := Grid.Header.Columns.GetFirstVisibleColumn(True); while Col > NoColumn do begin - if Col <> ExcludeCol then begin - if (GridData.DataType(Col).Category in [dtcBinary, dtcSpatial]) + ResultCol := Col - 1; + if DoIncludeCol then begin + if (GridData.DataType(ResultCol).Category in [dtcBinary, dtcSpatial]) and (not Mainform.actBlobAsText.Checked) then begin - Data := GridData.HexValue(Col); + Data := GridData.HexValue(ResultCol); end else begin - Data := GridData.Col(Col); + Data := GridData.Col(ResultCol); + RemoveNullChars(Data, HasNulls); end; // Keep formatted numeric values - if (GridData.DataType(Col).Category in [dtcInteger, dtcReal]) - and (ExportFormat in [efExcel, efHTML, efMarkDown]) then begin + if (GridData.DataType(ResultCol).Category in [dtcInteger, dtcReal]) + and (CurrentExportFormat in [efExcel, efHTML, efMarkDown]) + then begin Data := FormatNumber(Data, False); end; // Remove linebreaks, see #474 if chkRemoveLinebreaks.Checked then begin - Data := StringReplace(Data, #13#10, ' ', [rfReplaceAll]); - Data := StringReplace(Data, #13, ' ', [rfReplaceAll]); - Data := StringReplace(Data, #10, ' ', [rfReplaceAll]); + StripNewLines(Data); end; - case ExportFormat of + case CurrentExportFormat of efHTML: begin // Escape HTML control characters in data. Data := HTMLSpecialChars(Data); - tmp := tmp + ' ' + CRLF; + tmp := tmp + CodeIndent(5) + '' + sLineBreak; end; efExcel, efCSV: begin - if GridData.IsNull(Col) then + if GridData.IsNull(ResultCol) then Data := editNull.Text else begin - Data := FormatExcelCsv(Data, Encloser, GridData.DataType(Col)); + Data := FormatCsv(Data, Encloser, GridData.DataType(ResultCol), CurrentExportFormat); Data := Encloser + Data + Encloser; end; tmp := tmp + Data + Separator; @@ -901,57 +1052,60 @@ procedure TfrmExportGrid.btnOKClick(Sender: TObject); efLaTeX: begin Data := FormatLatex(Data); - if (not GridData.IsNull(Col)) and (GridData.DataType(Col).Category in [dtcInteger, dtcReal]) then + if (not GridData.IsNull(ResultCol)) and (GridData.DataType(ResultCol).Category in [dtcInteger, dtcReal]) then // Special encloser for numeric values, see https://www.heidisql.com/forum.php?t=36530 Data := '$' + Data + '$'; tmp := tmp + Data + Separator; end; - efWiki: begin + efTextile, efJiraTextile: begin tmp := tmp + Data + Separator; end; efMarkDown: begin - if GridData.IsNull(Col) then + if GridData.IsNull(ResultCol) then Data := editNull.Text; tmp := tmp + Data + Separator; end; efXML: begin // Print cell start tag. - tmp := tmp + #9#9'' + CRLF else begin - if (GridData.DataType(Col).Category in [dtcBinary, dtcSpatial]) and (not Mainform.actBlobAsText.Checked) then + if (GridData.DataType(ResultCol).Category in [dtcBinary, dtcSpatial]) and (not Mainform.actBlobAsText.Checked) then tmp := tmp + ' format="hex"'; tmp := tmp + '>' + HTMLSpecialChars(Data) + '' + CRLF; end; end; - efSQLInsert, efSQLReplace, efSQLDeleteInsert: begin - if GridData.ColIsVirtual(Col) then + efSQLInsert, efSQLInsertIgnore, efSQLReplace, efSQLDeleteInsert, efSQLUpdate: begin + if GridData.ColIsVirtual(ResultCol) then Data := '' - else if GridData.IsNull(Col) then + else if GridData.IsNull(ResultCol) then Data := 'NULL' - else if (GridData.DataType(Col).Index = dtBit) and GridData.Connection.Parameters.IsAnyMySQL then - Data := 'b' + GridData.Connection.EscapeString(Data) - else if (GridData.DataType(Col).Category in [dtcText, dtcTemporal, dtcOther]) - or ((GridData.DataType(Col).Category in [dtcBinary, dtcSpatial]) and Mainform.actBlobAsText.Checked) + else if (GridData.DataType(ResultCol).Index = dbdtBit) and GridData.Connection.Parameters.IsAnyMySQL then + Data := GridData.Connection.EscapeString(Data, GridData.DataType(ResultCol)) + else if (GridData.DataType(ResultCol).Category in [dtcText, dtcTemporal, dtcOther]) + or ((GridData.DataType(ResultCol).Category in [dtcBinary, dtcSpatial]) and Mainform.actBlobAsText.Checked) then Data := GridData.Connection.EscapeString(Data) else if Data = '' then Data := GridData.Connection.EscapeString(Data); - if not Data.IsEmpty then + if not Data.IsEmpty then begin + if CurrentExportFormat = efSQLUpdate then + tmp := tmp + GridData.Connection.QuoteIdent(Grid.Header.Columns[Col].Text) + '='; tmp := tmp + Data + ', '; + end; end; efPHPArray: begin - if GridData.IsNull(Col) then - Data := 'NULL' - else case GridData.DataType(Col).Category of + if GridData.IsNull(ResultCol) then + Data := 'null' + else case GridData.DataType(ResultCol).Category of dtcInteger, dtcReal: begin // Remove zeropadding to avoid octal => integer conversion in PHP Data := FormatNumber(Data); @@ -962,28 +1116,44 @@ procedure TfrmExportGrid.btnOKClick(Sender: TObject); end; if chkIncludeColumnNames.Checked then - tmp := tmp + #9#9 + FormatPhp(Grid.Header.Columns[Col].Text) + ' => ' + Data + ','+CRLF + tmp := tmp + CodeIndent(2) + FormatPhp(Grid.Header.Columns[Col].Text) + ' => ' + Data + ',' + sLineBreak else - tmp := tmp + #9#9 + Data + ','+CRLF; + tmp := tmp + CodeIndent(2) + Data + ',' + sLineBreak; end; efJSON: begin - tmp := tmp + #9#9#9; + tmp := tmp + CodeIndent(3); if chkIncludeColumnNames.Checked then - tmp := tmp + FormatPhp(Grid.Header.Columns[Col].Text) + ': '; - if GridData.IsNull(Col) then + tmp := tmp + FormatJson(Grid.Header.Columns[Col].Text) + ': '; + if GridData.IsNull(ResultCol) then tmp := tmp + 'null,' +CRLF else begin - case GridData.DataType(Col).Category of + case GridData.DataType(ResultCol).Category of dtcInteger, dtcReal: tmp := tmp + Data; else - tmp := tmp + FormatPhp(Data) + tmp := tmp + FormatJson(Data) end; tmp := tmp + ',' + CRLF; end; end; + efJSONLines: begin + if chkIncludeColumnNames.Checked then + tmp := tmp + FormatJson(Grid.Header.Columns[Col].Text) + ': '; + if GridData.IsNull(ResultCol) then + tmp := tmp + 'null, ' + else begin + case GridData.DataType(ResultCol).Category of + dtcInteger, dtcReal: + tmp := tmp + Data; + else + tmp := tmp + FormatJson(Data) + end; + tmp := tmp + ', '; + end; + end; + end; end; @@ -991,29 +1161,40 @@ procedure TfrmExportGrid.btnOKClick(Sender: TObject); end; // Row epilogue - case ExportFormat of + case CurrentExportFormat of efHTML: - tmp := tmp + ' ' + CRLF; - efExcel, efCSV, efLaTeX, efWiki: begin + tmp := tmp + CodeIndent(4) + '' + sLineBreak; + efExcel, efCSV, efLaTeX, efTextile, efJiraTextile: begin Delete(tmp, Length(tmp)-Length(Separator)+1, Length(Separator)); tmp := tmp + Terminator; end; efXML: - tmp := tmp + #9'' + CRLF; - efSQLInsert, efSQLReplace, efSQLDeleteInsert: begin + tmp := tmp + CodeIndent + '' + sLineBreak; + efSQLInsert, efSQLInsertIgnore, efSQLReplace, efSQLDeleteInsert: begin Delete(tmp, Length(tmp)-1, 2); tmp := tmp + ');' + CRLF; end; + efSQLUpdate : begin + Delete(tmp, length(tmp)-1,2); + tmp := tmp + ' WHERE' + GridData.GetWhereClause + ';' + sLineBreak; + end; efPHPArray: - tmp := tmp + #9 + '),' + CRLF; + tmp := tmp + CodeIndent + '],' + sLineBreak; efMarkDown: tmp := tmp + Terminator; efJSON: begin Delete(tmp, length(tmp)-2,2); if chkIncludeColumnNames.Checked then - tmp := tmp + #9#9 + '},' + tmp := tmp + CodeIndent(2) + '},' else - tmp := tmp + #9#9 + '],'; + tmp := tmp + CodeIndent(2) + '],'; + end; + efJSONLines: begin + Delete(tmp, length(tmp)-1,2); + if chkIncludeColumnNames.Checked then + tmp := tmp + '}' + #10 + else + tmp := tmp + ']' + #10; end; end; S.WriteString(tmp); @@ -1022,17 +1203,17 @@ procedure TfrmExportGrid.btnOKClick(Sender: TObject); end; // Footer - case ExportFormat of + case CurrentExportFormat of efHTML: begin tmp := - ' ' + CRLF + - '
' + Grid.Header.Columns[Col].Text + '' + Grid.Header.Columns[Col].Text + '
' + Data + '' + Data + '
' + CRLF + CRLF + - '

' + CRLF + - ' generated ' + DateToStr(now) + ' ' + TimeToStr(now) + - ' by ' + APPNAME + ' ' + Mainform.AppVersion + '' + CRLF + - '

' + CRLF + CRLF + - ' ' + CRLF + - '' + CRLF; + CodeIndent(3) + '' + sLineBreak + + CodeIndent(2) + '' + sLineBreak + sLineBreak + + CodeIndent(2) + '

' + sLineBreak + + CodeIndent(3) + 'generated ' + DateToStr(now) + ' ' + TimeToStr(now) + + CodeIndent(3) + 'by ' + APPNAME + ' ' + Mainform.AppVersion + '' + sLineBreak + + CodeIndent(2) + '

' + sLineBreak + sLineBreak + + CodeIndent + '' + sLineBreak + + '' + sLineBreak; end; efXML: begin if chkIncludeQuery.Checked then @@ -1043,13 +1224,11 @@ procedure TfrmExportGrid.btnOKClick(Sender: TObject); efLaTeX: tmp := '\end{tabular}' + CRLF; efPHPArray: begin - tmp := ');' + CRLF; - if radioOutputFile.Checked then - tmp := tmp + '?>'; + tmp := '];' + CRLF; end; efJSON: begin S.Size := S.Size - 1; - tmp := CRLF + #9 + ']' + CRLF + '}'; + tmp := sLineBreak + CodeIndent + ']' + sLineBreak + '}'; end; else tmp := ''; @@ -1060,8 +1239,8 @@ procedure TfrmExportGrid.btnOKClick(Sender: TObject); HTML := nil; // SynEdit's exporter is slow on large strings, see issue #2903 if S.Size < 100*SIZE_KB then begin - case ExportFormat of - efSQLInsert, efSQLReplace, efSQLDeleteInsert: begin + case CurrentExportFormat of + efSQLInsert, efSQLInsertIgnore, efSQLReplace, efSQLDeleteInsert: begin Exporter := TSynExporterHTML.Create(Self); Exporter.Highlighter := MainForm.SynSQLSynUsed; Exporter.ExportAll(Explode(CRLF, S.DataString)); @@ -1072,10 +1251,12 @@ procedure TfrmExportGrid.btnOKClick(Sender: TObject); efHTML: HTML := S; end; end; - StreamToClipboard(S, HTML, (ExportFormat=efHTML) and (HTML <> nil)); + StreamToClipboard(S, HTML); end else begin try S.SaveToFile(Filename); + if chkOpenFile.Checked then + ShellExec(editFilename.Text); except on E:EFCreateError do begin // Keep form open if file cannot be created diff --git a/source/extra_controls.pas b/source/extra_controls.pas index b90b1d070..3ec77abc7 100644 --- a/source/extra_controls.pas +++ b/source/extra_controls.pas @@ -3,31 +3,106 @@ interface uses - Classes, SysUtils, Forms, Windows, Messages, System.Types, StdCtrls, Clipbrd, - SizeGrip, apphelpers, Vcl.Graphics, Vcl.Dialogs, gnugettext, Vcl.ImgList, Vcl.ComCtrls, - ShLwApi, Vcl.ExtCtrls, VirtualTrees, SynRegExpr; + System.Classes, System.SysUtils, Vcl.Forms, Winapi.Windows, Winapi.Messages, System.Types, Vcl.StdCtrls, Vcl.Clipbrd, + SizeGrip, apphelpers, Vcl.Graphics, Vcl.Dialogs, gnugettext, Vcl.ImgList, Vcl.VirtualImageList, Vcl.ComCtrls, + Winapi.ShLwApi, Vcl.ExtCtrls, VirtualTrees, VirtualTrees.Types, SynRegExpr, Vcl.Controls, Winapi.ShlObj, + SynEditMiscClasses, SynUnicode, Vcl.Themes, Vcl.GraphUtil, Math; type // Form with a sizegrip in the lower right corner, without the need for a statusbar TExtForm = class(TForm) private FSizeGrip: TSizeGripXP; + FPixelsPerInchDesigned: Integer; function GetHasSizeGrip: Boolean; procedure SetHasSizeGrip(Value: Boolean); protected procedure DoShow; override; + procedure DoBeforeMonitorDpiChanged(OldDPI, NewDPI: Integer); override; + procedure DoAfterMonitorDpiChanged(OldDPI, NewDPI: Integer); override; procedure FilterNodesByEdit(Edit: TButtonedEdit; Tree: TVirtualStringTree); public constructor Create(AOwner: TComponent); override; - procedure InheritFont(AFont: TFont); + class procedure InheritFont(AFont: TFont); property HasSizeGrip: Boolean read GetHasSizeGrip write SetHasSizeGrip default False; class procedure FixControls(ParentComp: TComponent); + class procedure SaveListSetup(List: TVirtualStringTree); + class procedure RestoreListSetup(List: TVirtualStringTree); + function ScaleSize(x: Extended): Integer; overload; + class function ScaleSize(x: Extended; Control: TControl): Integer; overload; + class procedure PageControlTabHighlight(PageControl: TPageControl); + property PixelsPerInchDesigned: Integer read FPixelsPerInchDesigned; end; - // Memo replacement which accepts any line break format - TLineNormalizingMemo = class(TMemo) + + // Modern file-open-dialog with high DPI support and encoding selector + TExtFileOpenDialog = class(TFileOpenDialog) private - procedure WMSetText(var msg: TWMSettext); message WM_SETTEXT; - procedure WMPaste(var msg: TWMPaste); message WM_PASTE; + FEncodings: TStringList; + FEncodingIndex: Cardinal; + const idEncodingCombo = 1; + procedure FileOkClickNoOp(Sender: TObject; var CanClose: Boolean); + protected + procedure DoOnExecute; override; + function DoOnFileOkClick: Boolean; override; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure AddFileType(FileMask, DisplayName: String); + property Encodings: TStringList read FEncodings write FEncodings; + property EncodingIndex: Cardinal read FEncodingIndex write FEncodingIndex; + end; + + TExtFileSaveDialog = class(TFileSaveDialog) + private + FLineBreaks: TStringList; + FLineBreakIndex: TLineBreaks; + const idLineBreakCombo = 1; + procedure FileOkClickNoOp(Sender: TObject; var CanClose: Boolean); + protected + procedure DoOnExecute; override; + function DoOnFileOkClick: Boolean; override; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure AddFileType(FileMask, DisplayName: String); + property LineBreaks: TStringList read FLineBreaks; + property LineBreakIndex: TLineBreaks read FLineBreakIndex write FLineBreakIndex; + end; + + TExtSynHotKey = class(TSynHotKey) + private + FOnChange: TNotifyEvent; + FOnEnter: TNotifyEvent; + FOnExit: TNotifyEvent; + procedure WMKillFocus(var Msg: TWMKillFocus); message WM_KILLFOCUS; + procedure WMSetFocus(var Msg: TWMSetFocus); message WM_SETFOCUS; + protected + procedure KeyDown(var Key: Word; Shift: TShiftState); override; + procedure Paint; override; + published + property OnChange: TNotifyEvent read FOnChange write FOnChange; + property OnEnter: TNotifyEvent read FOnEnter write FOnEnter; + property OnExit: TNotifyEvent read FOnExit write FOnExit; + end; + + TExtComboBox = class(TComboBox) + private + FcbHintIndex: Integer; + FHintWindow: THintWindow; + protected + procedure Change; override; + procedure DropDown; override; + procedure CloseUp; override; + procedure InitiateAction; override; + end; + + TExtHintWindow = class(THintWindow) + private + const Padding: Integer = 8; + protected + procedure Paint; override; + public + function CalcHintRect(MaxWidth: Integer; const AHint: string; AData: TCustomData): TRect; override; end; @@ -42,6 +117,7 @@ constructor TExtForm.Create(AOwner: TComponent); begin inherited; + FPixelsPerInchDesigned := 96; InheritFont(Font); HasSizeGrip := False; @@ -73,6 +149,21 @@ procedure TExtForm.DoShow; end; +procedure TExtForm.DoBeforeMonitorDpiChanged(OldDPI, NewDPI: Integer); +begin + // Reduce flicker + inherited; + LockWindowUpdate(Handle); +end; + +procedure TExtForm.DoAfterMonitorDpiChanged(OldDPI, NewDPI: Integer); +begin + // Release window updates + LockWindowUpdate(0); + inherited; +end; + + class procedure TExtForm.FixControls(ParentComp: TComponent); var i: Integer; @@ -119,7 +210,7 @@ procedure TExtForm.SetHasSizeGrip(Value: Boolean); end; -procedure TExtForm.InheritFont(AFont: TFont); +class procedure TExtForm.InheritFont(AFont: TFont); var LogFont: TLogFont; GUIFontName: String; @@ -138,7 +229,8 @@ procedure TExtForm.InheritFont(AFont: TFont); // Apply system font. See issue #3204. // Code taken from http://www.gerixsoft.com/blog/delphi/system-font if SystemParametersInfo(SPI_GETICONTITLELOGFONT, SizeOf(TLogFont), @LogFont, 0) then begin - AFont.Height := LogFont.lfHeight; + // Leave font size at default, as the system's font size is probably scaled up + //AFont.Height := LogFont.lfHeight; AFont.Orientation := LogFont.lfOrientation; AFont.Charset := TFontCharset(LogFont.lfCharSet); AFont.Name := PChar(@LogFont.lfFaceName); @@ -154,11 +246,143 @@ procedure TExtForm.InheritFont(AFont: TFont); end; +{** + Save setup of a VirtualStringTree to registry +} +class procedure TExtForm.SaveListSetup( List: TVirtualStringTree ); +var + i: Integer; + ColWidth: Int64; + ColWidths, ColsVisible, ColPos, Regname: String; + OwnerForm: TWinControl; +begin + // Prevent sporadic crash on startup + if List = nil then + Exit; + OwnerForm := GetParentFormOrFrame(List); + // On a windows shutdown, GetParentForm() seems sporadically unable to find the owner form + // In that case we would cause an exception when accessing it. Emergency break in that case. + // See issue #1462 + // TODO: Test this, probably fixed by implementing GetParentFormOrFrame, and then again, probably not. + if not Assigned(OwnerForm) then + Exit; + + ColWidths := ''; + ColsVisible := ''; + ColPos := ''; + + for i := 0 to List.Header.Columns.Count - 1 do + begin + // Column widths + if ColWidths <> '' then + ColWidths := ColWidths + ','; + ColWidth := RoundCommercial(List.Header.Columns[i].Width / OwnerForm.ScaleFactor); + ColWidths := ColWidths + IntToStr(ColWidth); + + // Column visibility + if coVisible in List.Header.Columns[i].Options then + begin + if ColsVisible <> '' then + ColsVisible := ColsVisible + ','; + ColsVisible := ColsVisible + IntToStr(i); + end; + + // Column position + if ColPos <> '' then + ColPos := ColPos + ','; + ColPos := ColPos + IntToStr(List.Header.Columns[i].Position); + + end; + + // Lists can have the same name over different forms or frames. Find parent form or frame, + // so we can prepend its name into the registry value name. + Regname := OwnerForm.Name + '.' + List.Name; + AppSettings.ResetPath; + AppSettings.WriteString(asListColWidths, ColWidths, Regname); + AppSettings.WriteString(asListColsVisible, ColsVisible, Regname); + AppSettings.WriteString(asListColPositions, ColPos, Regname); + AppSettings.WriteString(asListColSort, IntToStr(List.Header.SortColumn) + ',' + IntToStr(Integer(List.Header.SortDirection)), RegName); +end; + + +{** + Restore setup of VirtualStringTree from registry +} +class procedure TExtForm.RestoreListSetup( List: TVirtualStringTree ); +var + i : Byte; + colpos : Integer; + ColWidth: Int64; + Value : String; + ValueList : TStringList; + Regname: String; + OwnerForm: TWinControl; +begin + ValueList := TStringList.Create; + + // Column widths + OwnerForm := GetParentFormOrFrame(List); + Regname := OwnerForm.Name + '.' + List.Name; + Value := AppSettings.ReadString(asListColWidths, Regname); + if Value <> '' then begin + ValueList := Explode( ',', Value ); + for i := 0 to ValueList.Count - 1 do + begin + ColWidth := MakeInt(ValueList[i]); + ColWidth := RoundCommercial(ColWidth * OwnerForm.ScaleFactor); + // Check if column number exists and width is at least 1 pixel + if (List.Header.Columns.Count > i) and (ColWidth > 0) and (ColWidth < 1000) then + List.Header.Columns[i].Width := ColWidth; + end; + end; + + // Column visibility + Value := AppSettings.ReadString(asListColsVisible, Regname); + if Value <> '' then begin + ValueList := Explode( ',', Value ); + for i:=0 to List.Header.Columns.Count-1 do begin + if ValueList.IndexOf( IntToStr(i) ) > -1 then + List.Header.Columns[i].Options := List.Header.Columns[i].Options + [coVisible] + else + List.Header.Columns[i].Options := List.Header.Columns[i].Options - [coVisible]; + end; + end; + + // Column position + Value := AppSettings.ReadString(asListColPositions, Regname); + if Value <> '' then begin + ValueList := Explode( ',', Value ); + for i := 0 to ValueList.Count - 1 do + begin + colpos := MakeInt(ValueList[i]); + // Check if column number exists + if List.Header.Columns.Count > i then + List.Header.Columns[i].Position := colpos; + end; + end; + + // Sort column and direction + Value := AppSettings.ReadString(asListColSort, Regname); + if Value <> '' then begin + ValueList := Explode(',', Value); + if ValueList.Count = 2 then begin + List.Header.SortColumn := MakeInt(ValueList[0]); + if MakeInt(ValueList[1]) = 0 then + List.Header.SortDirection := sdAscending + else + List.Header.SortDirection := sdDescending; + end; + end; + + ValueList.Free; +end; + + procedure TExtForm.FilterNodesByEdit(Edit: TButtonedEdit; Tree: TVirtualStringTree); var rx: TRegExpr; Node: PVirtualNode; - i: Integer; + i, ColumnCount: Integer; match: Boolean; CellText: String; begin @@ -183,14 +407,18 @@ procedure TExtForm.FilterNodesByEdit(Edit: TButtonedEdit; Tree: TVirtualStringTr if not Tree.HasChildren[Node] then begin // Don't filter anything if the filter text is empty match := rx.Expression = ''; + // Suport trees with 0 defined columns, like the shortcut tree in preferences + ColumnCount := Max(Tree.Header.Columns.Count, 1); // Search for given text in node's captions - if not match then for i := 0 to Tree.Header.Columns.Count - 1 do begin + if not match then for i:=0 to ColumnCount - 1 do begin CellText := Tree.Text[Node, i]; match := rx.Exec(CellText); if match then break; end; Tree.IsVisible[Node] := match; + if match and IsNotEmpty(Edit.Text) then + Tree.VisiblePath[Node] := True; end; Node := Tree.GetNext(Node); end; @@ -202,31 +430,373 @@ procedure TExtForm.FilterNodesByEdit(Edit: TButtonedEdit; Tree: TVirtualStringTr end; +function TExtForm.ScaleSize(x: Extended): Integer; +begin + // Shorthand for dpi scaling hardcoded width/height values of controls + Result := ScaleSize(x, Self); +end; + +class function TExtForm.ScaleSize(x: Extended; Control: TControl): Integer; +begin + // Same as above for callers without a form + Result := Round(x * Control.ScaleFactor); +end; + + +class procedure TExtForm.PageControlTabHighlight(PageControl: TPageControl); +var + i, CurrentImage, CountOriginals: Integer; + Images: TVirtualImageList; + GrayscaleMode: Integer; + IsQueryTab, DoGrayscale: Boolean; +begin + // Set grayscale icon on inactive tabs + if not (PageControl.Images is TVirtualImageList) then + Exit; + GrayscaleMode := AppSettings.ReadInt(asTabIconsGrayscaleMode); + + Images := PageControl.Images as TVirtualImageList; + CountOriginals := Images.ImageCollection.Count; + + for i:=0 to PageControl.PageCount-1 do begin + CurrentImage := PageControl.Pages[i].ImageIndex; + if PageControl.ActivePageIndex = i then begin + if CurrentImage >= CountOriginals then begin + // Grayscaled => Color + PageControl.Pages[i].ImageIndex := CurrentImage - CountOriginals; + end; + end + else begin + if CurrentImage < CountOriginals then begin + // Color => Grayscaled + IsQueryTab := (PageControl.Owner.Name = 'MainForm') and ExecRegExpr('^tabQuery\d*$', PageControl.Pages[i].Name); + if ((GrayscaleMode = 1) and IsQueryTab) or (GrayscaleMode = 2) then + PageControl.Pages[i].ImageIndex := CurrentImage + CountOriginals; + end; + end; + end; +end; + + + +{ TExtFileOpenDialog } + +constructor TExtFileOpenDialog.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + FEncodings := TStringList.Create; + FEncodingIndex := 0; +end; + + +destructor TExtFileOpenDialog.Destroy; +begin + FEncodings.Free; + inherited; +end; + + +procedure TExtFileOpenDialog.AddFileType(FileMask, DisplayName: String); +var + FileType: TFileTypeItem; +begin + // Shorthand for callers + FileType := FileTypes.Add; + FileType.DisplayName := DisplayName; + FileType.FileMask := FileMask; +end; + + +procedure TExtFileOpenDialog.DoOnExecute; +var + iCustomize: IFileDialogCustomize; + i: Integer; +begin + // Add encodings selector + if Dialog.QueryInterface(IFileDialogCustomize, iCustomize) = S_OK then + begin + iCustomize.StartVisualGroup(0, PChar(_('Encoding:'))); + try + // note other controls available: AddCheckButton, AddEditBox, AddPushButton, AddRadioButtonList... + iCustomize.AddComboBox(idEncodingCombo); + for i:=0 to FEncodings.Count - 1 do begin + iCustomize.AddControlItem(idEncodingCombo, i, PChar(FEncodings[i])); + end; + iCustomize.SetSelectedControlItem(idEncodingCombo, FEncodingIndex); + if not Assigned(OnFileOkClick) then + OnFileOkClick := FileOkClickNoOp; + finally + iCustomize.EndVisualGroup; + end; + end; +end; + + +procedure TExtFileOpenDialog.FileOkClickNoOp(Sender: TObject; var CanClose: Boolean); +begin + // Dummy procedure, just makes sure parent class calls DoOnFileOkClick +end; + + +function TExtFileOpenDialog.DoOnFileOkClick: Boolean; +var + iCustomize: IFileDialogCustomize; +begin + Result := inherited; + if Dialog.QueryInterface(IFileDialogCustomize, iCustomize) = S_OK then + begin + iCustomize.GetSelectedControlItem(idEncodingCombo, FEncodingIndex); + end; +end; + + + +{ TExtFileSaveDialog } + +constructor TExtFileSaveDialog.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + FLineBreaks := TStringList.Create; + FLineBreaks.Add(_('Windows linebreaks')); + FLineBreaks.Add(_('UNIX linebreaks')); + FLineBreaks.Add(_('Mac OS linebreaks')); + FLineBreakIndex := lbsWindows; +end; + + +destructor TExtFileSaveDialog.Destroy; +begin + FLineBreaks.Free; + inherited; +end; + + +procedure TExtFileSaveDialog.AddFileType(FileMask, DisplayName: String); +var + FileType: TFileTypeItem; +begin + // Shorthand for callers + FileType := FileTypes.Add; + FileType.DisplayName := DisplayName; + FileType.FileMask := FileMask; +end; +procedure TExtFileSaveDialog.DoOnExecute; +var + iCustomize: IFileDialogCustomize; + i, ComboIndex: Integer; +begin + // Add line break selector + if Dialog.QueryInterface(IFileDialogCustomize, iCustomize) = S_OK then + begin + iCustomize.StartVisualGroup(0, PChar(_('Linebreaks')+':')); + try + iCustomize.AddComboBox(idLineBreakCombo); + case FLineBreakIndex of + lbsUnix: ComboIndex := 1; + lbsMac: ComboIndex := 2; + else ComboIndex := 0; + end; + for i:=0 to FLineBreaks.Count - 1 do begin + iCustomize.AddControlItem(idLineBreakCombo, i, PChar(FLineBreaks[i])); + end; + iCustomize.SetSelectedControlItem(idLineBreakCombo, ComboIndex); + if not Assigned(OnFileOkClick) then + OnFileOkClick := FileOkClickNoOp; + finally + iCustomize.EndVisualGroup; + end; + end; +end; -{ TLineNormalizingMemo } -procedure TLineNormalizingMemo.WMSetText(var msg: TWMSettext); +procedure TExtFileSaveDialog.FileOkClickNoOp(Sender: TObject; var CanClose: Boolean); +begin + // Dummy procedure, just makes sure parent class calls DoOnFileOkClick +end; + + +function TExtFileSaveDialog.DoOnFileOkClick: Boolean; var - s: string; + iCustomize: IFileDialogCustomize; + ComboIndex: Cardinal; +begin + Result := inherited; + if Dialog.QueryInterface(IFileDialogCustomize, iCustomize) = S_OK then + begin + iCustomize.GetSelectedControlItem(idLineBreakCombo, ComboIndex); + case ComboIndex of + 0: FLineBreakIndex := lbsWindows; + 1: FLineBreakIndex := lbsUnix; + 2: FLineBreakIndex := lbsMac; + end; + end; +end; + + +{ TExtSynHotKey } + +procedure TExtSynHotKey.WMKillFocus(var Msg: TWMKillFocus); begin - s := msg.Text; - s := AdjustLineBreaks(s); - msg.Text := PChar(s); inherited; + if Assigned(FOnExit) then + FOnExit(Self); end; +procedure TExtSynHotKey.WMSetFocus(var Msg: TWMSetFocus); +begin + inherited; + if Assigned(FOnEnter) then + FOnEnter(Self); +end; + +procedure TExtSynHotKey.KeyDown(var Key: Word; Shift: TShiftState); +begin + inherited; + if Assigned(FOnChange) then + FOnChange(Self); +end; -procedure TLineNormalizingMemo.WMPaste(var msg: TWMPaste); +procedure TExtSynHotKey.Paint; var - s: string; + r: TRect; begin - if Clipboard.HasFormat(cf_Text) then begin - s := Clipboard.AsText; - s := AdjustLineBreaks(s); - SelText := s; + r := ClientRect; + Canvas.Brush.Style := bsSolid; + Canvas.Brush.Color := Color; + InflateRect(r, -BorderWidth, -BorderWidth); + Canvas.FillRect(r); + if Enabled then + Canvas.Font.Color := clWindowText + else + Canvas.Font.Color := clGrayText; + SynUnicode.TextRect(Canvas, r, BorderWidth + 1, BorderWidth + 1, Text); +end; + + + +{ TExtComboBox } + +procedure TExtComboBox.Change; +var + P: TPoint; + HintRect: TRect; + HintText: String; + HintWidth, Padding: Integer; +begin + inherited; + if (ItemIndex > -1) and DroppedDown and GetCursorPos(P) then begin + HintText := Items[ItemIndex]; + HintWidth := Canvas.TextWidth(HintText); + if HintWidth > Width then begin + Padding := TExtForm.ScaleSize(10, Self); + HintRect := Rect( + P.X + Padding, + P.Y + Padding * 2, + P.X + HintWidth + Padding * 3, + P.Y + Padding * 4 + ); + FHintWindow.ActivateHint(HintRect, HintText); + end; end; end; +procedure TExtComboBox.CloseUp; +begin + inherited; + FHintWindow.Hide; + ControlStyle := ControlStyle - [csActionClient]; +end; + +procedure TExtComboBox.DropDown; +begin + inherited; + if not Assigned(FHintWindow) then + FHintWindow := THintWindow.Create(Self); + FcbHintIndex := -1; + ControlStyle := ControlStyle + [csActionClient]; +end; + +procedure TExtComboBox.InitiateAction; +var + Idx: Integer; +begin + inherited; + Idx := ItemIndex; + if Idx <> FcbHintIndex then + begin + FcbHintIndex := ItemIndex; + Change; + end; +end; + + + +{ TExtHintWindow } + + +function TExtHintWindow.CalcHintRect(MaxWidth: Integer; const AHint: string; AData: TCustomData): TRect; +begin + Result := inherited; + // Customized: enlarge surrounding rect to make space for padding + if AHint.Contains(SLineBreak) then begin + Result.Right := Result.Right + 2 * ScaleValue(Padding); + Result.Bottom := Result.Bottom + 2 * ScaleValue(Padding); + end; +end; + + +procedure TExtHintWindow.Paint; +var + R, ClipRect: TRect; + LColor: TColor; + LStyle: TCustomStyleServices; + LDetails: TThemedElementDetails; + LGradientStart, LGradientEnd, LTextColor: TColor; +begin + R := ClientRect; + LStyle := StyleServices(Screen.ActiveForm); + LTextColor := Screen.HintFont.Color; + if LStyle.Enabled then + begin + ClipRect := R; + InflateRect(R, 4, 4); + if TOSVersion.Check(6) and LStyle.IsSystemStyle then + begin + // Paint Windows gradient background + LStyle.DrawElement(Canvas.Handle, LStyle.GetElementDetails(tttStandardNormal), R, ClipRect); + end + else + begin + LDetails := LStyle.GetElementDetails(thHintNormal); + if LStyle.GetElementColor(LDetails, ecGradientColor1, LColor) and (LColor <> clNone) then + LGradientStart := LColor + else + LGradientStart := clInfoBk; + if LStyle.GetElementColor(LDetails, ecGradientColor2, LColor) and (LColor <> clNone) then + LGradientEnd := LColor + else + LGradientEnd := clInfoBk; + if LStyle.GetElementColor(LDetails, ecTextColor, LColor) and (LColor <> clNone) then + LTextColor := LColor + else + LTextColor := Screen.HintFont.Color; + GradientFillCanvas(Canvas, LGradientStart, LGradientEnd, R, gdVertical); + end; + R := ClipRect; + end; + Inc(R.Left, 2); + Inc(R.Top, 2); + // Customized: move inner rect right+down to add padding to outer edge + if String(Caption).Contains(SLineBreak) then begin + Inc(R.Left, ScaleValue(Padding)); + Inc(R.Top, ScaleValue(Padding)); + end; + Canvas.Font.Color := LTextColor; + DrawText(Canvas.Handle, Caption, -1, R, DT_LEFT or DT_NOPREFIX or + DT_WORDBREAK or DrawTextBiDiModeFlagsReadingOnly); +end; + + end. diff --git a/source/generic_types.pas b/source/generic_types.pas new file mode 100644 index 000000000..a6222d8ad --- /dev/null +++ b/source/generic_types.pas @@ -0,0 +1,11 @@ +unit generic_types; + +interface + +type + TThreeStateBoolean = (nbUnset, nbFalse, nbTrue); + + +implementation + +end. diff --git a/source/gnugettext.pas b/source/gnugettext.pas index b26d7a4cb..06d95c10c 100644 --- a/source/gnugettext.pas +++ b/source/gnugettext.pas @@ -208,7 +208,7 @@ interface uses {$ifdef MSWINDOWS} - Windows, + Winapi.Windows, {$else} Libc, {$ifdef FPC} @@ -219,9 +219,9 @@ interface System.AnsiStrings, {$ENDIF dx_midstr_in_AnsiStrings} {$IFDEF dx_has_WideStrings} - WideStrings, + System.WideStrings, {$ENDIF dx_has_WideStrings} - Types, Classes, StrUtils, SysUtils, TypInfo; + System.Types, System.Classes, System.StrUtils, System.SysUtils, System.TypInfo; (*****************************************************************************) (* *) @@ -587,7 +587,9 @@ procedure HookIntoResourceStrings (enabled:boolean=true; SupportPackages:boolean const LOCALE_SISO639LANGNAME = $59; // Used by Lazarus software development tool + {$EXTERNALSYM LOCALE_SISO639LANGNAME} LOCALE_SISO3166CTRYNAME = $5A; // Used by Lazarus software development tool + {$EXTERNALSYM LOCALE_SISO3166CTRYNAME} GETTEXT_CONTEXT_GLUE = #4; var @@ -805,10 +807,10 @@ function GGGetEnvironmentVariable(const Name:widestring):widestring; begin Result := ''; SetLength(W,1); - Len := Windows.GetEnvironmentVariableW(PWideChar(Name), PWideChar(W), 1); + Len := Winapi.Windows.GetEnvironmentVariableW(PWideChar(Name), PWideChar(W), 1); if Len > 0 then begin SetLength(Result, Len - 1); - Windows.GetEnvironmentVariableW(PWideChar(Name), PWideChar(Result), Len); + Winapi.Windows.GetEnvironmentVariableW(PWideChar(Name), PWideChar(Result), Len); end; end; @@ -1368,7 +1370,7 @@ function GetLastWinError:widestring; begin SetLength (Result,2000); errcode:=GetLastError(); - Windows.FormatMessageW(FORMAT_MESSAGE_FROM_SYSTEM,nil,errcode,0,PWideChar(Result),2000,nil); + Winapi.Windows.FormatMessageW(FORMAT_MESSAGE_FROM_SYSTEM,nil,errcode,0,PWideChar(Result),2000,nil); Result:=PWideChar(Result); end; {$endif} @@ -3288,7 +3290,7 @@ function TFileLocator.FindSignaturePos(const signature: RawByteString; SetLength (a, bufsize); SetLength (b, bufsize); - str.Read(a[1],bufsize); + str.ReadBuffer(a[1],bufsize); while true do begin rd:=str.Read(b[1],bufsize); @@ -3305,7 +3307,10 @@ function TFileLocator.FindSignaturePos(const signature: RawByteString; a:=b; offset:=offset+bufsize; end; +{$IF CompilerVersion<34} + // this causes a hint in Delphi 10.4 and newer Result:=0; +{$IFEND} end; procedure TFileLocator.Analyze; @@ -3394,7 +3399,7 @@ procedure TFileLocator.Analyze; SetLength (filename8bit, offset-fs.position); fs.ReadBuffer (filename8bit[1], offset-fs.position); filename:=trim(utf8decode(filename8bit)); - if PreferExternal and sysutils.fileexists(basedirectory+filename) then begin + if PreferExternal and System.sysutils.fileexists(basedirectory+filename) then begin // Disregard the internal version and use the external version instead FreeAndNil (fi); end else @@ -4247,38 +4252,38 @@ function VclMenusShortCutToText(ShortCut: TShortCut): string; // Replace German shortcut names {$IFDEF dx_has_dotted_unitnames} sbShortCut. - Replace(Vcl.Consts.SmkcBkSp {'Rck'}, 'BkSp'). - Replace(Vcl.Consts.SmkcEnter {'Eingabe'}, 'Enter'). - Replace(Vcl.Consts.SmkcSpace {'Leer'}, 'Space'). - Replace(Vcl.Consts.SmkcPgUp {'BildAuf'}, 'PgUp'). - Replace(Vcl.Consts.SmkcPgDn {'BildAb'}, 'PgDn'). - Replace(Vcl.Consts.SmkcEnd {'Ende'}, 'End'). - Replace(Vcl.Consts.SmkcHome {'Pos1'}, 'Home'). - Replace(Vcl.Consts.SmkcLeft {'Links'}, 'Left'). - Replace(Vcl.Consts.SmkcUp {'Auf'}, 'Up'). - Replace(Vcl.Consts.SmkcRight {'Rechts'}, 'Right'). - Replace(Vcl.Consts.SmkcDown {'Ab'}, 'Down'). - Replace(Vcl.Consts.SmkcIns {'Einfg'}, 'Ins'). - Replace(Vcl.Consts.SmkcDel {'Entf'}, 'Del'). - Replace(Vcl.Consts.SmkcShift {'Umsch+'}, 'Shift+'). - Replace(Vcl.Consts.SmkcCtrl {'Strg+'}, 'Ctrl+'); + Replace(Vcl.Consts.SmkcBkSp, 'BkSp'). // 'Rueck' + Replace(Vcl.Consts.SmkcEnter, 'Enter'). // 'Eingabe' + Replace(Vcl.Consts.SmkcSpace, 'Space'). // 'Leer' + Replace(Vcl.Consts.SmkcPgUp, 'PgUp'). // 'BildAuf' + Replace(Vcl.Consts.SmkcPgDn, 'PgDn'). // 'BildAb' + Replace(Vcl.Consts.SmkcEnd, 'End'). // 'Ende' + Replace(Vcl.Consts.SmkcHome, 'Home'). // 'Pos1' + Replace(Vcl.Consts.SmkcLeft, 'Left'). // 'Links' + Replace(Vcl.Consts.SmkcUp, 'Up'). // 'Auf' + Replace(Vcl.Consts.SmkcRight, 'Right'). // 'Rechts' + Replace(Vcl.Consts.SmkcDown, 'Down'). // 'Ab' + Replace(Vcl.Consts.SmkcIns, 'Ins'). // 'Einfg' + Replace(Vcl.Consts.SmkcDel, 'Del'). // 'Entf' + Replace(Vcl.Consts.SmkcShift, 'Shift+'). // 'Umsch+' + Replace(Vcl.Consts.SmkcCtrl, 'Ctrl+'); // 'Strg+' {$ELSE ~dx_has_dotted_unitnames} sbShortCut. - Replace(Consts.SmkcBkSp {'Rck'}, 'BkSp'). - Replace(Consts.SmkcEnter {'Eingabe'}, 'Enter'). - Replace(Consts.SmkcSpace {'Leer'}, 'Space'). - Replace(Consts.SmkcPgUp {'BildAuf'}, 'PgUp'). - Replace(Consts.SmkcPgDn {'BildAb'}, 'PgDn'). - Replace(Consts.SmkcEnd {'Ende'}, 'End'). - Replace(Consts.SmkcHome {'Pos1'}, 'Home'). - Replace(Consts.SmkcLeft {'Links'}, 'Left'). - Replace(Consts.SmkcUp {'Auf'}, 'Up'). - Replace(Consts.SmkcRight {'Rechts'}, 'Right'). - Replace(Consts.SmkcDown {'Ab'}, 'Down'). - Replace(Consts.SmkcIns {'Einfg'}, 'Ins'). - Replace(Consts.SmkcDel {'Entf'}, 'Del'). - Replace(Consts.SmkcShift {'Umsch+'}, 'Shift+'). - Replace(Consts.SmkcCtrl {'Strg+'}, 'Ctrl+'); + Replace(Consts.SmkcBkSp, 'BkSp'). // 'Rueck' + Replace(Consts.SmkcEnter, 'Enter'). // 'Eingabe' + Replace(Consts.SmkcSpace, 'Space'). // 'Leer' + Replace(Consts.SmkcPgUp, 'PgUp'). // 'BildAuf' + Replace(Consts.SmkcPgDn, 'PgDn'). // 'BildAb' + Replace(Consts.SmkcEnd, 'End'). // 'Ende' + Replace(Consts.SmkcHome, 'Home'). // 'Pos1' + Replace(Consts.SmkcLeft, 'Left'). // 'Links' + Replace(Consts.SmkcUp, 'Up'). // 'Auf' + Replace(Consts.SmkcRight, 'Right'). // 'Rechts' + Replace(Consts.SmkcDown, 'Down'). // 'Ab' + Replace(Consts.SmkcIns, 'Ins'). // 'Einfg' + Replace(Consts.SmkcDel, 'Del'). // 'Entf' + Replace(Consts.SmkcShift, 'Shift+'). // 'Umsch+' + Replace(Consts.SmkcCtrl, 'Ctrl+'); // 'Strg+' {$ENDIF dx_has_dotted_unitnames} Result := sbShortCut.ToString; finally @@ -4300,21 +4305,21 @@ function VclMenusShortCutToText(ShortCut: TShortCut): string; // if currently used language is not German: replace the German names by English names if not SameText(GetCurrentLanguageCode, 'de') then begin - Result := StringReplace(Result, Consts.SmkcBkSp {'Rck'}, 'BkSp', []); - Result := StringReplace(Result, Consts.SmkcEnter {'Eingabe'}, 'Enter', []); - Result := StringReplace(Result, Consts.SmkcSpace {'Leer'}, 'Space', []); - Result := StringReplace(Result, Consts.SmkcPgUp {'BildAuf'}, 'PgUp', []); - Result := StringReplace(Result, Consts.SmkcPgDn {'BildAb'}, 'PgDn', []); - Result := StringReplace(Result, Consts.SmkcEnd {'Ende'}, 'End', []); - Result := StringReplace(Result, Consts.SmkcHome {'Pos1'}, 'Home', []); - Result := StringReplace(Result, Consts.SmkcLeft {'Links'}, 'Left', []); - Result := StringReplace(Result, Consts.SmkcUp {'Auf'}, 'Up', []); - Result := StringReplace(Result, Consts.SmkcRight {'Rechts'}, 'Right', []); - Result := StringReplace(Result, Consts.SmkcDown {'Ab'}, 'Down', []); - Result := StringReplace(Result, Consts.SmkcIns {'Einfg'}, 'Ins', []); - Result := StringReplace(Result, Consts.SmkcDel {'Entf'}, 'Del', []); - Result := StringReplace(Result, Consts.SmkcShift {'Umsch+'}, 'Shift+', []); - Result := StringReplace(Result, Consts.SmkcCtrl {'Strg+'}, 'Ctrl+', []); + Result := StringReplace(Result, Consts.SmkcBkSp, 'BkSp', []); // 'Rueck' + Result := StringReplace(Result, Consts.SmkcEnter, 'Enter', []); // 'Eingabe' + Result := StringReplace(Result, Consts.SmkcSpace, 'Space', []); // 'Leer' + Result := StringReplace(Result, Consts.SmkcPgUp, 'PgUp', []); // 'BildAuf' + Result := StringReplace(Result, Consts.SmkcPgDn, 'PgDn', []); // 'BildAb' + Result := StringReplace(Result, Consts.SmkcEnd, 'End', []); // 'Ende' + Result := StringReplace(Result, Consts.SmkcHome, 'Home', []); // 'Pos1' + Result := StringReplace(Result, Consts.SmkcLeft, 'Left', []); // 'Links' + Result := StringReplace(Result, Consts.SmkcUp, 'Up', []); // 'Auf' + Result := StringReplace(Result, Consts.SmkcRight, 'Right', []); // 'Rechts' + Result := StringReplace(Result, Consts.SmkcDown, 'Down', []); // 'Ab' + Result := StringReplace(Result, Consts.SmkcIns, 'Ins', []); // 'Einfg' + Result := StringReplace(Result, Consts.SmkcDel, 'Del', []); // 'Entf' + Result := StringReplace(Result, Consts.SmkcShift, 'Shift+', []); // 'Umsch+' + Result := StringReplace(Result, Consts.SmkcCtrl, 'Ctrl+', []); // 'Strg+' end; finally HookShortCutToText.Enable; @@ -4385,8 +4390,8 @@ initialization {$else} HookLoadResString:=THook.Create (@system.LoadResString, @LoadResStringA); {$endif} - HookLoadStr:=THook.Create (@sysutils.LoadStr, @SysUtilsLoadStr); - HookFmtLoadStr:=THook.Create (@sysutils.FmtLoadStr, @SysUtilsFmtLoadStr); + HookLoadStr:=THook.Create (@System.sysutils.LoadStr, @SysUtilsLoadStr); + HookFmtLoadStr:=THook.Create (@System.sysutils.FmtLoadStr, @SysUtilsFmtLoadStr); {$ifdef dx_German_Delphi_fix} // Create hook for Vcl.Menus.ShortCutToText to translate shortcut strings. {$IFDEF dx_has_dotted_unitnames} diff --git a/source/grideditlinks.pas b/source/grideditlinks.pas index 4d9888c50..309302352 100644 --- a/source/grideditlinks.pas +++ b/source/grideditlinks.pas @@ -5,10 +5,10 @@ interface uses - Windows, Forms, Graphics, Messages, VirtualTrees, ComCtrls, SysUtils, Classes, - StdCtrls, ExtCtrls, CheckLst, Controls, Types, Dialogs, Menus, Mask, DateUtils, Math, + Winapi.Windows, Vcl.Forms, Vcl.Graphics, Winapi.Messages, VirtualTrees, VirtualTrees.BaseTree, VirtualTrees.Types, Vcl.ComCtrls, System.SysUtils, System.Classes, + Vcl.StdCtrls, Vcl.ExtCtrls, Vcl.CheckLst, Vcl.Controls, System.Types, Vcl.Dialogs, Vcl.Menus, Vcl.Mask, System.DateUtils, System.Math, dbconnection, dbstructures, apphelpers, texteditor, bineditor, gnugettext, - StrUtils, System.UITypes, SynRegExpr, Vcl.Themes, extra_controls; + System.StrUtils, System.UITypes, SynRegExpr, Vcl.Themes, extra_controls; type // Radio buttons and checkboxes which do not pass key to their parent control @@ -47,11 +47,11 @@ TBaseGridEditorLink = class(TInterfacedObject, IVTEditLink) function GetCellRect(InnerTextBounds: Boolean): TRect; public // The table column of the cell being edited. Mostly used in data grids. - property TableColumn: TTableColumn read FTableColumn write FTableColumn; + property TableColumn: TTableColumn read FTableColumn; // The original constructor, not used any more, throws an exception if you do constructor Create; overload; // The right constructor, we need the Tree reference - constructor Create(Tree: TVirtualStringTree; AllowEdit: Boolean); overload; virtual; + constructor Create(Tree: TVirtualStringTree; AllowEdit: Boolean; Col: TTableColumn); overload; virtual; destructor Destroy; override; property Tree: TVirtualStringTree read FTree; function PrepareEdit(Tree: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex): Boolean; virtual; stdcall; @@ -70,7 +70,7 @@ THexEditorLink = class(TBaseGridEditorLink) public MaxLength: Integer; TitleText: String; - constructor Create(Tree: TVirtualStringTree; AllowEdit: Boolean); override; + constructor Create(Tree: TVirtualStringTree; AllowEdit: Boolean; Col: TTableColumn); override; destructor Destroy; override; function BeginEdit: Boolean; override; function CancelEdit: Boolean; override; @@ -97,7 +97,7 @@ TDateTimeEditorLink = class(TBaseGridEditorLink) procedure TextChange(Sender: TObject); function MicroSecondsPrecision: Integer; public - constructor Create(Tree: TVirtualStringTree; AllowEdit: Boolean); override; + constructor Create(Tree: TVirtualStringTree; AllowEdit: Boolean; Col: TTableColumn); override; destructor Destroy; override; function BeginEdit: Boolean; override; function EndEdit: Boolean; override; @@ -107,13 +107,14 @@ TDateTimeEditorLink = class(TBaseGridEditorLink) TEnumEditorLink = class(TBaseGridEditorLink) private - FCombo: TComboBox; + FCombo: TExtComboBox; procedure DoKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); procedure DoSelect(Sender: TObject); public ValueList, DisplayList: TStringList; AllowCustomText: Boolean; - constructor Create(Tree: TVirtualStringTree; AllowEdit: Boolean); override; + ItemMustExist: Boolean; + constructor Create(Tree: TVirtualStringTree; AllowEdit: Boolean; Col: TTableColumn); override; destructor Destroy; override; function BeginEdit: Boolean; override; function EndEdit: Boolean; override; @@ -131,7 +132,7 @@ TSetEditorLink = class(TBaseGridEditorLink) procedure BtnCancelClick(Sender: TObject); public ValueList: TStringList; - constructor Create(Tree: TVirtualStringTree; AllowEdit: Boolean); override; + constructor Create(Tree: TVirtualStringTree; AllowEdit: Boolean; Col: TTableColumn); override; destructor Destroy; override; function BeginEdit: Boolean; override; function EndEdit: Boolean; override; @@ -145,17 +146,15 @@ TInplaceEditorLink = class(TBaseGridEditorLink) FPanel: TPanel; FEdit: TEdit; FButton: TButton; - FTextEditor: TfrmTextEditor; FMaxLength: Integer; procedure DoKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); procedure ButtonClick(Sender: TObject); public ButtonVisible: Boolean; TitleText: String; - constructor Create(Tree: TVirtualStringTree; AllowEdit: Boolean); override; + constructor Create(Tree: TVirtualStringTree; AllowEdit: Boolean; Col: TTableColumn); override; destructor Destroy; override; function BeginEdit: Boolean; override; - function CancelEdit: Boolean; override; function EndEdit: Boolean; override; function PrepareEdit(Tree: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex): Boolean; override; procedure SetBounds(R: TRect); override; @@ -181,7 +180,7 @@ TColumnDefaultEditorLink = class(TBaseGridEditorLink) public DefaultType, OnUpdateType: TColumnDefaultType; DefaultText, OnUpdateText: String; - constructor Create(Tree: TVirtualStringTree; AllowEdit: Boolean); override; + constructor Create(Tree: TVirtualStringTree; AllowEdit: Boolean; Col: TTableColumn); override; destructor Destroy; override; function BeginEdit: Boolean; override; function EndEdit: Boolean; override; @@ -207,7 +206,7 @@ TDataTypeEditorLink = class(TBaseGridEditorLink) PVirtualNode; OldColumn, NewColumn: TColumnIndex; var Allowed: Boolean); procedure DoTreeSelectFocusChanged(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex); public - constructor Create(Tree: TVirtualStringTree; AllowEdit: Boolean); override; + constructor Create(Tree: TVirtualStringTree; AllowEdit: Boolean; Col: TTableColumn); override; destructor Destroy; override; function BeginEdit: Boolean; override; function EndEdit: Boolean; override; @@ -240,7 +239,7 @@ procedure TAllKeysCheckBox.WMGetDlgCode(var Msg: TMessage); procedure TBaseGridEditorLink.Log(Msg: String); begin - MainForm.LogSQL('#'+FInstanceId.ToString+': '+Msg); + MainForm.LogSQL('#'+FInstanceId.ToString+': '+Msg, lcDebug); end; @@ -250,7 +249,7 @@ constructor TBaseGridEditorLink.Create; [Self.ClassName, 'Create', Self.ClassName, 'Create(VirtualStringTree)']); end; -constructor TBaseGridEditorLink.Create(Tree: TVirtualStringTree; AllowEdit: Boolean); +constructor TBaseGridEditorLink.Create(Tree: TVirtualStringTree; AllowEdit: Boolean; Col: TTableColumn); begin inherited Create; FInstanceId := Random(100); @@ -260,10 +259,11 @@ constructor TBaseGridEditorLink.Create(Tree: TVirtualStringTree; AllowEdit: Bool FParentForm := GetParentForm(FTree); // Avoid flicker FParentForm.Repaint; - SendMessage(FParentForm.Handle, WM_SETREDRAW, 0, 0); + FMainControl := nil; FModified := False; FAllowEdit := AllowEdit; ActiveGridEditor := Self; + FTableColumn := Col; end; destructor TBaseGridEditorLink.Destroy; @@ -273,8 +273,10 @@ destructor TBaseGridEditorLink.Destroy; DoPrev: Boolean; begin ActiveGridEditor := nil; - FMainControl.WindowProc := FOldWindowProc; - FMainControl := nil; + if Assigned(FMainControl) then begin + FMainControl.WindowProc := FOldWindowProc; + FMainControl := nil; + end; if FLastKeyDown = VK_TAB then begin DoPrev := ssShift in FLastShiftState; // Advance to next/previous visible column/node. @@ -313,6 +315,7 @@ destructor TBaseGridEditorLink.Destroy; function TBaseGridEditorLink.PrepareEdit(Tree: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex): Boolean; var FCellTextBounds: TRect; + HasNulls: Boolean; begin Result := not FStopping; if not Result then @@ -321,6 +324,11 @@ function TBaseGridEditorLink.PrepareEdit(Tree: TBaseVirtualTree; Node: PVirtualN FColumn := Column; FCellFont := TFont.Create; FTree.GetTextInfo(FNode, FColumn, FCellFont, FCellTextBounds, FCellText); + apphelpers.RemoveNullChars(FCellText, HasNulls); + if HasNulls and FAllowEdit then begin + FAllowEdit := False; + end; + // Not all editors have a connection assigned, e.g. session manager tree if Assigned(FTableColumn) then begin FCellFont.Color := DatatypeCategories[FTableColumn.DataType.Category].Color; @@ -333,7 +341,8 @@ function TBaseGridEditorLink.PrepareEdit(Tree: TBaseVirtualTree; Node: PVirtualN end; // Adjust editor position and allow repainting mainform SetBounds(FCellTextBounds); - SendMessage(FParentForm.Handle, WM_SETREDRAW, 1, 0); + if not IsWine then + SendMessage(FParentForm.Handle, WM_SETREDRAW, 1, 0); end; function TBaseGridEditorLink.BeginEdit: Boolean; @@ -468,7 +477,7 @@ procedure TBaseGridEditorLink.DoCancelEdit(Sender: TObject); -constructor THexEditorLink.Create(Tree: TVirtualStringTree; AllowEdit: Boolean); +constructor THexEditorLink.Create(Tree: TVirtualStringTree; AllowEdit: Boolean; Col: TTableColumn); begin inherited; end; @@ -530,7 +539,7 @@ procedure THexEditorLink.SetBounds(R: TRect); stdcall; { DateTime editor } -constructor TDateTimeEditorLink.Create(Tree: TVirtualStringTree; AllowEdit: Boolean); +constructor TDateTimeEditorLink.Create(Tree: TVirtualStringTree; AllowEdit: Boolean; Col: TTableColumn); begin inherited; @@ -548,7 +557,6 @@ constructor TDateTimeEditorLink.Create(Tree: TVirtualStringTree; AllowEdit: Bool FMaskEdit.OnKeyDown := DoKeyDown; FMaskEdit.OnKeyUp := DoKeyUp; FMaskEdit.OnChange := TextChange; - FMaskEdit.ReadOnly := not FAllowEdit; FMainControl := FMaskEdit; FUpDown := TUpDown.Create(FPanel); @@ -601,16 +609,24 @@ function TDateTimeEditorLink.PrepareEdit(Tree: TBaseVirtualTree; Node: PVirtualN Result := inherited PrepareEdit(Tree, Node, Column); if not Result then Exit; + FMaskEdit.ReadOnly := not FAllowEdit; + case FTableColumn.DataType.Index of - dtDate: + dbdtDate: FMaskEdit.EditMask := '0000-00-00;1; '; - dtDatetime, dtDatetime2, dtTimestamp, dtInt, dtBigint: begin + + dbdtDatetime, dbdtDatetime2, dbdtTimestamp, + dbdtInt, dbdtBigint, + dbdtFloat, dbdtDouble, dbdtDecimal, dbdtNumeric, dbdtReal, dbdtDoublePrecision: begin + if FCellText.IsEmpty then + FCellText := DateTimeToStr(Now); if MicroSecondsPrecision > 0 then FMaskEdit.EditMask := '0000-00-00 00\:00\:00.'+StringOfChar('0', MicroSecondsPrecision)+';1; ' else FMaskEdit.EditMask := '0000-00-00 00\:00\:00;1; '; end; - dtTime: begin + + dbdtTime: begin ForceTextLen := 10; if MicroSecondsPrecision > 0 then begin FMaskEdit.EditMask := '#900\:00\:00.'+StringOfChar('0', MicroSecondsPrecision)+';1; '; @@ -620,7 +636,8 @@ function TDateTimeEditorLink.PrepareEdit(Tree: TBaseVirtualTree; Node: PVirtualN while Length(FCellText) < ForceTextLen do FCellText := ' ' + FCellText; end; - dtYear: + + dbdtYear: FMaskEdit.EditMask := '0000;1; '; end; FMaskEdit.Text := FCellText; @@ -721,7 +738,8 @@ procedure TDateTimeEditorLink.ModifyDate(Offset: Integer); i, MaxSeconds, MinSeconds: Int64; text: String; OldSelStart, OldSelLength, - ms, DotPos: Integer; + ms: Integer; + msStr, StrWithoutMs: String; function TimeToSeconds(Str: String): Int64; var @@ -757,19 +775,20 @@ procedure TDateTimeEditorLink.ModifyDate(Offset: Integer); try // Detect microseconds part of value if any if MicroSecondsPrecision > 0 then begin - DotPos := Length(FMaskEdit.Text) - Pos('.', ReverseString(FMaskEdit.Text)) + 2; - ms := MakeInt(Copy(FMaskEdit.Text, DotPos, Length(FMaskEdit.Text))); - end else + msStr := RegExprGetMatch('\.(\d+)$', FMaskEdit.Text, 1); + ms := MakeInt(msStr); + end else begin ms := 0; + end; case FTableColumn.DataType.Index of - dtYear: begin + dbdtYear: begin i := MakeInt(FMaskEdit.Text); i := i + Offset; text := IntToStr(i); end; - dtDate: begin + dbdtDate: begin d := StrToDate(FMaskEdit.Text); // De- or increase focused date segment case FMaskEdit.SelStart of @@ -780,8 +799,11 @@ procedure TDateTimeEditorLink.ModifyDate(Offset: Integer); text := DateToStr(d); end; - dtDateTime, dtDateTime2, dtTimestamp, dtInt, dtBigint: begin - dt := StrToDateTime(FMaskEdit.Text); + dbdtDateTime, dbdtDateTime2, dbdtTimestamp, + dbdtInt, dbdtBigint, + dbdtFloat, dbdtDouble, dbdtDecimal, dbdtNumeric, dbdtReal, dbdtDoublePrecision: begin + StrWithoutMs := ReplaceRegExpr('\.\d+$', FMaskEdit.Text, ''); + dt := StrToDateTime(StrWithoutMs); case FMaskEdit.SelStart of 0..3: dt := IncYear(dt, Offset); 5,6: dt := IncMonth(dt, Offset); @@ -798,7 +820,7 @@ procedure TDateTimeEditorLink.ModifyDate(Offset: Integer); text := text + '.' + Format('%.'+IntToStr(MicroSecondsPrecision)+'d', [ms]); end; - dtTime: begin + dbdtTime: begin i := TimeToSeconds(FMaskEdit.Text); case FMaskEdit.SelStart of 0..3: Inc(i, Offset*60*60); @@ -829,11 +851,9 @@ procedure TDateTimeEditorLink.ModifyDate(Offset: Integer); FMaskEdit.SelLength := OldSelLength; end; except - on E:EConvertError do begin - // Ignore any DateToStr exception. Should only appear in cases where the users - // enters invalid dates - end else - raise; + on E:Exception do begin + MainForm.LogSQL(E.Message); + end; end; end; @@ -847,34 +867,51 @@ procedure TDateTimeEditorLink.TextChange; function TDateTimeEditorLink.MicroSecondsPrecision: Integer; var rx: TRegExpr; -begin - if not FTableColumn.LengthSet.IsEmpty then - Result := MakeInt(FTableColumn.LengthSet) - else begin - // Find default length of supported microseconds in datatype definition - // See dbstructures - rx := TRegExpr.Create; - rx.Expression := '\.([^\.]+)$'; - if rx.Exec(FTableColumn.DataType.Format) then - Result := rx.MatchLen[1] - else + msStr: String; +begin + case FTableColumn.DataType.Category of + dtcTemporal: begin + if not FTableColumn.LengthSet.IsEmpty then + // Read microseconds precision from MySQL length/set + Result := MakeInt(FTableColumn.LengthSet) + else begin + // Find default length of supported microseconds in datatype definition + // See dbstructures + rx := TRegExpr.Create; + rx.Expression := '\.([^\.]+)$'; + if rx.Exec(FTableColumn.DataType.Format) then + Result := rx.MatchLen[1] + else + Result := 0; + rx.Free; + end; + end; + + dtcInteger: begin + // UNIX timestamps from integers Result := 0; - rx.Free; + end; + + dtcReal: begin + // UNIX timestamps from floats + // Detect number of decimals from original cell string + msStr := RegExprGetMatch('\.(\d+)$', FCellText, 1); + Result := Length(msStr); + end; + end; - // No microseconds for UNIX timestamp columns - if FTableColumn.DataType.Index in [dtInt, dtBigint] then - Result := 0; end; { Enum editor } -constructor TEnumEditorLink.Create(Tree: TVirtualStringTree; AllowEdit: Boolean); +constructor TEnumEditorLink.Create(Tree: TVirtualStringTree; AllowEdit: Boolean; Col: TTableColumn); begin inherited; AllowCustomText := False; - FCombo := TComboBox.Create(FParentForm); + ItemMustExist := False; + FCombo := TExtComboBox.Create(FParentForm); FCombo.Hide; FCombo.Parent := FParentForm; FCombo.OnKeyDown := DoKeyDown; @@ -909,8 +946,12 @@ function TEnumEditorLink.EndEdit: Boolean; stdcall; var NewText: String; begin - if AllowCustomText and FAllowEdit then - NewText := FCombo.Text + if AllowCustomText and FAllowEdit then begin + if (not ItemMustExist) or ValueList.Contains(FCombo.Text) then + NewText := FCombo.Text + else + NewText := ''; + end else if (ValueList.Count > 0) and (FCombo.ItemIndex > -1) then NewText := ValueList[FCombo.ItemIndex] else @@ -921,25 +962,21 @@ function TEnumEditorLink.EndEdit: Boolean; stdcall; function TEnumEditorLink.PrepareEdit(Tree: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex): Boolean; stdcall; -var - i: Integer; - Items: TStringList; begin Result := inherited PrepareEdit(Tree, Node, Column); if Result then begin if DisplayList.Count = ValueList.Count then - Items := DisplayList + FCombo.Items.AddStrings(DisplayList) else - Items := ValueList; - for i:=0 to Items.Count - 1 do - FCombo.Items.Add(Items[i]); + FCombo.Items.AddStrings(ValueList); + FCombo.AutoDropDownWidth := True; + FCombo.ItemIndex := ValueList.IndexOf(FCellText); if AllowCustomText and FAllowEdit then begin FCombo.Style := csDropDown; FCombo.Text := FCellText; end else begin // Set style to OwnerDraw, otherwise we wouldn't be able to adjust the combo's height FCombo.Style := csOwnerDrawFixed; - FCombo.ItemIndex := ValueList.IndexOf(FCellText); end; end; end; @@ -973,7 +1010,7 @@ procedure TEnumEditorLink.DoSelect(Sender: TObject); { SET editor } -constructor TSetEditorLink.Create(Tree: TVirtualStringTree; AllowEdit: Boolean); +constructor TSetEditorLink.Create(Tree: TVirtualStringTree; AllowEdit: Boolean; Col: TTableColumn); begin inherited; ValueList := TStringList.Create; @@ -982,7 +1019,7 @@ constructor TSetEditorLink.Create(Tree: TVirtualStringTree; AllowEdit: Boolean); FPanel.Hide; FPanel.Parent := FParentForm; FPanel.ParentBackground := False; - FPanel.Height := 150; + FPanel.Height := TExtForm.ScaleSize(150, FParentForm); FPanel.OnExit := DoEndEdit; FCheckList := TCheckListBox.Create(FPanel); @@ -1073,7 +1110,7 @@ procedure TSetEditorLink.SetBounds(R: TRect); stdcall; FBtnOk.Width := (FPanel.Width - 3*margin) div 2; FBtnOk.Left := margin; - FBtnOk.Height := 24; + FBtnOk.Height := TExtForm.ScaleSize(24, FParentForm); FBtnOk.Top := FPanel.Height - 2*margin - FBtnOk.Height; FBtnOk.Enabled := FAllowEdit; @@ -1109,11 +1146,10 @@ procedure TSetEditorLink.BtnCancelClick(Sender: TObject); { TInplaceEditorLink } -constructor TInplaceEditorLink.Create(Tree: TVirtualStringTree; AllowEdit: Boolean); +constructor TInplaceEditorLink.Create(Tree: TVirtualStringTree; AllowEdit: Boolean; Col: TTableColumn); begin inherited; ButtonVisible := false; - FTextEditor := nil; FPanel := TPanel.Create(FParentForm); FPanel.Parent := FParentForm; @@ -1127,7 +1163,6 @@ constructor TInplaceEditorLink.Create(Tree: TVirtualStringTree; AllowEdit: Boole FEdit.ParentColor := True; FEdit.BorderStyle := bsNone; FEdit.OnKeyDown := DoKeyDown; - FEdit.ReadOnly := not FAllowEdit; FMainControl := FEdit; FButton := TButton.Create(FPanel); @@ -1141,10 +1176,11 @@ constructor TInplaceEditorLink.Create(Tree: TVirtualStringTree; AllowEdit: Boole destructor TInplaceEditorLink.Destroy; begin - if Assigned(FTextEditor) then - FTextEditor.Release; - if not ((csDestroying in FPanel.ComponentState) or (csCreating in FPanel.ControlState)) then + if not ((csDestroying in FPanel.ComponentState) or (csCreating in FPanel.ControlState)) then begin + FEdit.Free; + FButton.Free; FPanel.Free; + end; inherited; end; @@ -1154,7 +1190,7 @@ function TInplaceEditorLink.BeginEdit: Boolean; if Result then begin FButton.Visible := ButtonVisible; SetBounds(Rect(0, 0, 0, 0)); - if (Length(FEdit.Text) > SIZE_KB*100) or (ScanLineBreaks(FEdit.Text) <> lbsNone) then + if (Length(FEdit.Text) >= GRIDMAXDATA) or (ScanLineBreaks(FEdit.Text) <> lbsNone) then ButtonClick(FTree) else begin FPanel.Show; @@ -1163,14 +1199,6 @@ function TInplaceEditorLink.BeginEdit: Boolean; end; end; -function TInplaceEditorLink.CancelEdit: Boolean; -begin - Result := inherited CancelEdit; - if Result then begin - if Assigned(FTextEditor) then - FTextEditor.Close; - end; -end; function TInplaceEditorLink.EndEdit: Boolean; var @@ -1178,14 +1206,8 @@ function TInplaceEditorLink.EndEdit: Boolean; begin Result := not FStopping; if FStopping then Exit; - if Assigned(FTextEditor) then begin - NewText := FTextEditor.GetText; - FModified := FTextEditor.Modified; - FTextEditor.Close; - end else begin - NewText := FEdit.Text; - FModified := FEdit.Modified; - end; + NewText := FEdit.Text; + FModified := NewText <> FCellText; Result := EndEditHelper(NewText); end; @@ -1198,16 +1220,30 @@ procedure TInplaceEditorLink.DoKeyDown(Sender: TObject; var Key: Word; end; procedure TInplaceEditorLink.ButtonClick(Sender: TObject); +var + Editor: TfrmTextEditor; begin if not FButton.Visible then Exit; // Button was invisible, but hotkey was pressed - FTextEditor := TfrmTextEditor.Create(FTree); - FTextEditor.SetFont(FEdit.Font); - FTextEditor.SetText(FEdit.Text); - FTextEditor.SetTitleText(TitleText); - FTextEditor.Modified := FEdit.Modified; - FTextEditor.SetMaxLength(Self.FMaxLength); - FTextEditor.memoText.ReadOnly := not FAllowEdit; - FTextEditor.ShowModal; + Editor := TfrmTextEditor.Create(FTree); + Editor.SetFont(MainForm.SynMemoQuery.Font); + Editor.SetText(FEdit.Text); + if FEdit.HandleAllocated then begin + Editor.MemoText.SelStart := FEdit.SelStart; + Editor.MemoText.SelLength := FEdit.SelLength; + end; + Editor.SetTitleText(TitleText); + Editor.Modified := FEdit.Modified; + Editor.SetMaxLength(FMaxLength); + Editor.TableColumn := FTableColumn; + Editor.MemoText.ReadOnly := not FAllowEdit; + if Editor.ShowModal = mrYes then begin + FEdit.Text := Editor.GetText; + DoEndEdit(Sender); + end + else begin + DoCancelEdit(Sender); + end; + Editor.Free; end; function TInplaceEditorLink.PrepareEdit(Tree: TBaseVirtualTree; @@ -1217,6 +1253,7 @@ function TInplaceEditorLink.PrepareEdit(Tree: TBaseVirtualTree; if not Result then Exit; + FEdit.ReadOnly := not FAllowEdit; FEdit.Font.Assign(FCellFont); FEdit.Font.Color := GetThemeColor(clWindowText); FPanel.Color := FCellBackground; @@ -1231,7 +1268,7 @@ procedure TInplaceEditorLink.SetBounds(R: TRect); FPanel.BoundsRect := GetCellRect(False); R := GetCellRect(True); if FButton.Visible then - Dec(R.Right, 20); + Dec(R.Right, TExtForm.ScaleSize(20, FPanel)); FEdit.BoundsRect := R; FButton.BoundsRect := Rect(FEdit.BoundsRect.Right, 0, FPanel.Width, FPanel.Height); @@ -1242,14 +1279,16 @@ procedure TInplaceEditorLink.SetBounds(R: TRect); { Column default editor } -constructor TColumnDefaultEditorLink.Create(Tree: TVirtualStringTree; AllowEdit: Boolean); -const - m = 5; +constructor TColumnDefaultEditorLink.Create(Tree: TVirtualStringTree; AllowEdit: Boolean; Col: TTableColumn); var - i: Integer; + SQLFunc: TSQLFunction; + m: Integer; begin inherited; + // Margin between controls and to edge of panel + m := TExtForm.ScaleSize(5, FParentForm); + FPanel := TPanel.Create(FParentForm); FPanel.Hide; FPanel.Parent := FParentForm; @@ -1316,9 +1355,7 @@ constructor TColumnDefaultEditorLink.Create(Tree: TVirtualStringTree; AllowEdit: FExpressionEdit.Width := FExpressionEdit.Parent.Width - 2*FExpressionEdit.Left; FExpressionEdit.OnChange := EditChange; FExpressionEdit.DropDownCount := 20; - for i:=Low(MySQLFunctions) to High(MySQLFunctions) do begin - FExpressionEdit.Items.Add(MySQLFunctions[i].Name + MySQLFunctions[i].Declaration); - end; + FTableColumn.Connection.GetColumnDefaultExpressions(FExpressionEdit.Items); FlblOnUpdate := TLabel.Create(FPanel); FlblOnUpdate.Parent := FPanel; @@ -1334,9 +1371,7 @@ constructor TColumnDefaultEditorLink.Create(Tree: TVirtualStringTree; AllowEdit: FOnUpdateEdit.Width := FOnUpdateEdit.Parent.Width - 2*FOnUpdateEdit.Left; FOnUpdateEdit.OnChange := EditChange; FOnUpdateEdit.DropDownCount := 20; - for i:=Low(MySQLFunctions) to High(MySQLFunctions) do begin - FOnUpdateEdit.Items.Add(MySQLFunctions[i].Name + MySQLFunctions[i].Declaration); - end; + FTableColumn.Connection.GetColumnDefaultExpressions(FOnUpdateEdit.Items); FRadioAutoInc := TAllKeysRadioButton.Create(FPanel); FRadioAutoInc.Parent := FPanel; @@ -1345,11 +1380,11 @@ constructor TColumnDefaultEditorLink.Create(Tree: TVirtualStringTree; AllowEdit: FRadioAutoInc.Width := FRadioAutoInc.Parent.Width - 2 * FRadioAutoInc.Left; FRadioAutoInc.OnClick := RadioClick; FRadioAutoInc.OnKeyDown := DoKeyDown; - FRadioAutoInc.Caption := 'AUTO_INCREMENT'; + FRadioAutoInc.Caption := FTableColumn.Connection.SqlProvider.GetSql(qAutoInc); FBtnOk := TButton.Create(FPanel); FBtnOk.Parent := FPanel; - FBtnOk.Width := 60; + FBtnOk.Width := TExtForm.ScaleSize(60, FParentForm); FBtnOk.Top := FRadioAutoInc.Top + FRadioAutoInc.Height + m; FBtnOk.Left := FPanel.Width - 3*m - 2*FBtnOk.Width - 2*FPanel.BorderWidth; FBtnOk.OnClick := BtnOkClick; @@ -1423,7 +1458,7 @@ function TColumnDefaultEditorLink.PrepareEdit(Tree: TBaseVirtualTree; Node: PVir FRadioAutoInc.Enabled := FRadioAutoInc.Checked or (FTableColumn.DataType.Category = dtcInteger); // Provide items with a check mark for ENUM and SET columns - if FTableColumn.DataType.Index in [dtEnum, dtSet] then begin + if FTableColumn.DataType.Index in [dbdtEnum, dbdtSet] then begin FTextEdit.RightButton.Visible := True; ValueList := FTableColumn.ValueList; SelectedValues := Explode(',', FTextEdit.Text); @@ -1431,7 +1466,7 @@ function TColumnDefaultEditorLink.PrepareEdit(Tree: TBaseVirtualTree; Node: PVir for i:=0 to ValueList.Count-1 do begin Item := TMenuItem.Create(FTextDropDown); Item.Caption := ValueList[i]; - Item.RadioItem := FTableColumn.DataType.Index = dtEnum; + Item.RadioItem := FTableColumn.DataType.Index = dbdtEnum; Item.Checked := SelectedValues.IndexOf(Item.Caption) > -1; Item.OnClick := EditDropDownClick; FTextDropDown.Items.Add(Item); @@ -1509,7 +1544,7 @@ function TColumnDefaultEditorLink.EndEdit: Boolean; stdcall; cdtText: Col.DefaultText := FTextEdit.Text; cdtNull: Col.DefaultText := 'NULL'; cdtExpression: Col.DefaultText := FExpressionEdit.Text; - cdtAutoInc: Col.DefaultText := 'AUTO_INCREMENT'; + cdtAutoInc: Col.DefaultText := Col.Connection.SqlProvider.GetSql(qAutoInc); end; if FOnUpdateEdit.Text <> '' then @@ -1592,7 +1627,7 @@ procedure TColumnDefaultEditorLink.BtnCancelClick(Sender: TObject); { Datatype selector } -constructor TDataTypeEditorLink.Create(Tree: TVirtualStringTree; AllowEdit: Boolean); +constructor TDataTypeEditorLink.Create(Tree: TVirtualStringTree; AllowEdit: Boolean; Col: TTableColumn); begin inherited; diff --git a/source/insertfiles.dfm b/source/insertfiles.dfm index cf8cfe85e..d66aa8009 100644 --- a/source/insertfiles.dfm +++ b/source/insertfiles.dfm @@ -10,20 +10,17 @@ object frmInsertFiles: TfrmInsertFiles Constraints.MinWidth = 475 Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText - Font.Height = -11 + Font.Height = -12 Font.Name = 'Tahoma' Font.Style = [] - OldCreateOrder = False Position = poOwnerFormCenter - OnClose = FormClose OnCreate = FormCreate OnDestroy = FormDestroy OnShow = FormShow DesignSize = ( 511 491) - PixelsPerInch = 96 - TextHeight = 13 + TextHeight = 14 object btnInsert: TButton Left = 272 Top = 458 @@ -89,6 +86,7 @@ object frmInsertFiles: TfrmInsertFiles Top = 23 Width = 159 Height = 21 + AutoDropDownWidth = True Style = csDropDownList Anchors = [akLeft, akTop, akRight] TabOrder = 1 @@ -116,6 +114,8 @@ object frmInsertFiles: TfrmInsertFiles OnPaintText = ListColumnsPaintText OnGetNodeDataSize = ListColumnsGetNodeDataSize OnNewText = ListColumnsNewText + Touch.InteractiveGestures = [igPan, igPressAndTap] + Touch.InteractiveGestureOptions = [igoPanSingleFingerHorizontal, igoPanSingleFingerVertical, igoPanInertia, igoPanGutter, igoParentPassthrough] Columns = < item Options = [coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus] @@ -197,6 +197,8 @@ object frmInsertFiles: TfrmInsertFiles OnKeyPress = GridKeyPress OnKeyUp = ListFilesKeyUp OnStructureChange = ListFilesStructureChange + Touch.InteractiveGestures = [igPan, igPressAndTap] + Touch.InteractiveGestureOptions = [igoPanSingleFingerHorizontal, igoPanSingleFingerVertical, igoPanInertia, igoPanGutter, igoParentPassthrough] Columns = < item Position = 0 diff --git a/source/insertfiles.pas b/source/insertfiles.pas index d844e944e..38e7bd892 100644 --- a/source/insertfiles.pas +++ b/source/insertfiles.pas @@ -3,9 +3,10 @@ interface uses - Windows, Messages, SysUtils, Classes, Controls, Forms, Dialogs, StdCtrls, - ShellApi, Math, Graphics, ComCtrls, ToolWin, extra_controls, - dbconnection, dbstructures, VirtualTrees, grideditlinks, SynRegExpr, gnugettext, apphelpers; + Winapi.Windows, Winapi.Messages, System.SysUtils, System.Classes, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, + Winapi.ShellApi, System.Math, Vcl.Graphics, Vcl.ComCtrls, Vcl.ToolWin, extra_controls, + dbconnection, dbstructures, VirtualTrees, grideditlinks, SynRegExpr, gnugettext, apphelpers, VirtualTrees.BaseTree, VirtualTrees.Types, + VirtualTrees.BaseAncestorVCL, VirtualTrees.AncestorVCL; type TColInfo = class @@ -52,7 +53,6 @@ TfrmInsertFiles = class(TExtForm) procedure FormCreate(Sender: TObject); procedure btnInsertClick(Sender: TObject); procedure AddFile(Filename: String); - procedure FormClose(Sender: TObject; var Action: TCloseAction); procedure ListFilesGetNodeDataSize(Sender: TBaseVirtualTree; var NodeDataSize: Integer); procedure ListFilesGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; var CellText: string); @@ -119,8 +119,6 @@ procedure TfrmInsertFiles.FormCreate(Sender: TObject); HasSizeGrip := True; ListFiles.Images := GetSystemImageList; DragAcceptFiles(Handle, True); - MainForm.RestoreListSetup(ListColumns); - MainForm.RestoreListSetup(ListFiles); FixVT(ListFiles); FixVT(ListColumns); end; @@ -128,17 +126,19 @@ procedure TfrmInsertFiles.FormCreate(Sender: TObject); procedure TfrmInsertFiles.FormDestroy(Sender: TObject); begin - AppSettings.WriteInt(asFileImportWindowWidth, Width); - AppSettings.WriteInt(asFileImportWindowHeight, Height); - MainForm.SaveListSetup(ListColumns); - MainForm.SaveListSetup(listFiles); + AppSettings.WriteIntDpiAware(asFileImportWindowWidth, Self, Width); + AppSettings.WriteIntDpiAware(asFileImportWindowHeight, Self, Height); + SaveListSetup(ListColumns); + SaveListSetup(listFiles); end; procedure TfrmInsertFiles.FormShow(Sender: TObject); begin - Width := AppSettings.ReadInt(asFileImportWindowWidth); - Height := AppSettings.ReadInt(asFileImportWindowHeight); + Width := AppSettings.ReadIntDpiAware(asFileImportWindowWidth, Self); + Height := AppSettings.ReadIntDpiAware(asFileImportWindowHeight, Self); + RestoreListSetup(ListColumns); + RestoreListSetup(ListFiles); FConnection := Mainform.ActiveConnection; Caption := FConnection.Parameters.SessionName + ' - ' + MainForm.actInsertFiles.Caption; comboDBs.Items.Clear; @@ -151,12 +151,6 @@ procedure TfrmInsertFiles.FormShow(Sender: TObject); end; -procedure TfrmInsertFiles.FormClose(Sender: TObject; var Action: TCloseAction); -begin - Action := caFree; -end; - - procedure TfrmInsertFiles.ListColumnsFreeNode(Sender: TBaseVirtualTree; Node: PVirtualNode); var ColInfo: PColInfo; @@ -272,7 +266,7 @@ procedure TfrmInsertFiles.ListColumnsCreateEditor(Sender: TBaseVirtualTree; Node // Start cell editor Grid := Sender as TVirtualStringTree; if Column = ColValue then begin - EnumEditor := TEnumEditorLink.Create(Grid, True); + EnumEditor := TEnumEditorLink.Create(Grid, True, nil); EnumEditor.AllowCustomText := True; EnumEditor.ValueList := TStringList.Create; EnumEditor.ValueList.Text := 'NULL'+CRLF+ @@ -559,18 +553,20 @@ procedure TfrmInsertFiles.ListFilesHeaderClick(Sender: TVTHeader; HitInfo: TVTHe Node: PVirtualNode; FileInfo: PFileInfo; CheckState: TCheckState; + Tree: TBaseVirtualTree; begin // Header column click / check MainForm.AnyGridHeaderClick(Sender, HitInfo); CheckState := Sender.Columns[HitInfo.Column].CheckState; if (HitInfo.Column = ColBinary) and (not (CheckState in [csMixedNormal, csMixedPressed])) then begin - Node := Sender.Treeview.GetFirst; + Tree := TBaseVirtualTree(Sender.Treeview); + Node := Tree.GetFirst; while Assigned(Node) do begin - FileInfo := Sender.Treeview.GetNodeData(Node); + FileInfo := Tree.GetNodeData(Node); FileInfo.IsBinary := CheckState in CheckedStates; - Node := Sender.Treeview.GetNextSibling(Node); + Node := Tree.GetNextSibling(Node); end; - Sender.Treeview.InvalidateChildren(nil, false); + Tree.InvalidateChildren(nil, false); end; end; @@ -604,6 +600,11 @@ procedure TfrmInsertFiles.btnInsertClick(Sender: TObject); while Assigned(Node) do begin ListFiles.FocusedNode := Node; FileInfo := ListFiles.GetNodeData(Node); + if not FileExists(FileInfo.Filename) then begin + ErrorDialog('File does not exist: '+FileInfo.Filename); + Node := ListFiles.GetNextSibling(Node); + Continue; + end; FileSize := _GetFileSize(FileInfo.Filename); FileReadDone := False; sql := 'INSERT INTO '+FConnection.QuotedDbAndTableName(comboDBs.Text, comboTables.Text) + ' ('; @@ -658,6 +659,7 @@ procedure TfrmInsertFiles.btnInsertClick(Sender: TObject); sql := sql + ')'; try FConnection.Query(sql); + FConnection.ShowWarnings; Mainform.ProgressStep; except on E:EDbError do begin diff --git a/source/loaddata.dfm b/source/loaddata.dfm index 919adeba9..e49ed410a 100644 --- a/source/loaddata.dfm +++ b/source/loaddata.dfm @@ -2,31 +2,28 @@ object loaddataform: Tloaddataform Left = 212 Top = 111 Caption = 'Import text file' - ClientHeight = 494 - ClientWidth = 509 + ClientHeight = 548 + ClientWidth = 513 Color = clBtnFace - Constraints.MinHeight = 530 + Constraints.MinHeight = 550 Constraints.MinWidth = 525 Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText - Font.Height = -11 + Font.Height = -12 Font.Name = 'Tahoma' Font.Style = [] - OldCreateOrder = False Position = poMainFormCenter OnClose = FormClose OnCreate = FormCreate - OnDestroy = FormDestroy OnResize = FormResize OnShow = FormShow DesignSize = ( - 509 - 494) - PixelsPerInch = 96 - TextHeight = 13 + 513 + 548) + TextHeight = 14 object btnImport: TButton Left = 345 - Top = 461 + Top = 515 Width = 75 Height = 25 Anchors = [akRight, akBottom] @@ -39,7 +36,7 @@ object loaddataform: Tloaddataform end object btnCancel: TButton Left = 426 - Top = 461 + Top = 515 Width = 75 Height = 25 Anchors = [akRight, akBottom] @@ -62,23 +59,23 @@ object loaddataform: Tloaddataform object lblFilename: TLabel Left = 10 Top = 27 - Width = 46 - Height = 13 + Width = 51 + Height = 14 Caption = 'Filename:' FocusControl = editFilename end object lblEncoding: TLabel Left = 10 Top = 54 - Width = 47 - Height = 13 + Width = 54 + Height = 14 Caption = 'Encoding:' end object editFilename: TButtonedEdit Left = 88 Top = 24 Width = 395 - Height = 21 + Height = 22 Anchors = [akLeft, akTop, akRight] Images = MainForm.VirtualImageListMain RightButton.ImageIndex = 51 @@ -93,7 +90,7 @@ object loaddataform: Tloaddataform Left = 88 Top = 51 Width = 395 - Height = 21 + Height = 22 Style = csDropDownList Anchors = [akLeft, akTop, akRight] DropDownCount = 16 @@ -115,36 +112,36 @@ object loaddataform: Tloaddataform object lblFieldTerminater: TLabel Left = 10 Top = 26 - Width = 97 - Height = 13 + Width = 110 + Height = 14 Caption = 'Fields terminated by' end object lblFieldEncloser: TLabel Left = 10 Top = 51 - Width = 87 - Height = 13 + Width = 98 + Height = 14 Caption = 'Fields enclosed by' end object lblFieldEscaper: TLabel Left = 10 Top = 75 - Width = 85 - Height = 13 + Width = 95 + Height = 14 Caption = 'Fields escaped by' end object lblLineTerminator: TLabel Left = 10 Top = 100 - Width = 94 - Height = 13 + Width = 108 + Height = 14 Caption = 'Lines terminated by' end object editFieldEscaper: TEdit Left = 145 Top = 72 Width = 49 - Height = 21 + Height = 22 TabOrder = 3 Text = '"' end @@ -152,7 +149,7 @@ object loaddataform: Tloaddataform Left = 145 Top = 48 Width = 49 - Height = 21 + Height = 22 TabOrder = 1 Text = '"' end @@ -160,7 +157,7 @@ object loaddataform: Tloaddataform Left = 145 Top = 23 Width = 49 - Height = 21 + Height = 22 TabOrder = 0 Text = ';' end @@ -179,7 +176,7 @@ object loaddataform: Tloaddataform Left = 145 Top = 97 Width = 49 - Height = 21 + Height = 22 TabOrder = 4 Text = '\r\n' end @@ -188,32 +185,32 @@ object loaddataform: Tloaddataform Left = 8 Top = 98 Width = 209 - Height = 135 + Height = 175 Anchors = [akLeft, akTop, akRight] Caption = 'Options' TabOrder = 1 DesignSize = ( 209 - 135) + 175) object lblIgnoreLinesCount: TLabel Left = 143 Top = 26 - Width = 21 - Height = 13 + Width = 23 + Height = 14 Caption = 'lines' end object lblIgnoreLines: TLabel Left = 10 Top = 26 - Width = 54 - Height = 13 + Width = 60 + Height = 14 Caption = 'Ignore first' end object updownIgnoreLines: TUpDown Left = 121 Top = 23 Width = 16 - Height = 21 + Height = 22 Associate = editIgnoreLines Max = 32767 Position = 1 @@ -223,7 +220,7 @@ object loaddataform: Tloaddataform Left = 88 Top = 23 Width = 33 - Height = 21 + Height = 22 TabOrder = 0 Text = '1' end @@ -260,10 +257,19 @@ object loaddataform: Tloaddataform Caption = 'Truncate destination table before import' TabOrder = 4 end + object chkKeepDialogOpen: TCheckBox + Left = 10 + Top = 138 + Width = 196 + Height = 17 + Anchors = [akLeft, akTop, akRight] + Caption = 'Keep dialog open after import' + TabOrder = 5 + end end object grpDuplicates: TRadioGroup Left = 8 - Top = 239 + Top = 279 Width = 209 Height = 123 Anchors = [akLeft, akTop, akRight] @@ -277,9 +283,9 @@ object loaddataform: Tloaddataform end object grpParseMethod: TRadioGroup Left = 8 - Top = 368 + Top = 408 Width = 209 - Height = 87 + Height = 101 Anchors = [akLeft, akTop, akRight, akBottom] Caption = 'Method' ItemIndex = 0 @@ -294,39 +300,39 @@ object loaddataform: Tloaddataform Left = 223 Top = 239 Width = 278 - Height = 216 + Height = 270 Anchors = [akTop, akRight, akBottom] Caption = 'Destination' TabOrder = 5 DesignSize = ( 278 - 216) + 270) object lblDatabase: TLabel Left = 10 Top = 24 - Width = 50 - Height = 13 + Width = 54 + Height = 14 Caption = 'Database:' end object lblTable: TLabel Left = 10 Top = 48 - Width = 30 - Height = 13 + Width = 34 + Height = 14 Caption = 'Table:' end object lblColumns: TLabel Left = 10 Top = 72 - Width = 44 - Height = 13 + Width = 49 + Height = 14 Caption = 'Columns:' end object comboDatabase: TComboBox Left = 112 Top = 21 Width = 156 - Height = 21 + Height = 22 Style = csDropDownList Anchors = [akLeft, akTop, akRight] TabOrder = 0 @@ -336,7 +342,7 @@ object loaddataform: Tloaddataform Left = 112 Top = 45 Width = 156 - Height = 21 + Height = 22 Style = csDropDownList Anchors = [akLeft, akTop, akRight] TabOrder = 1 @@ -346,20 +352,19 @@ object loaddataform: Tloaddataform Left = 112 Top = 72 Width = 153 - Height = 129 + Height = 183 Anchors = [akLeft, akTop, akRight, akBottom] - ItemHeight = 13 + ItemHeight = 14 TabOrder = 2 OnClick = chklistColumnsClick end object ToolBarColMove: TToolBar Left = 10 Top = 91 - Width = 58 + Width = 87 Height = 66 Align = alNone - AutoSize = True - ButtonWidth = 58 + ButtonWidth = 59 Caption = 'ToolBarColMove' Images = MainForm.VirtualImageListMain List = True diff --git a/source/loaddata.pas b/source/loaddata.pas index 285776e7b..ce2e1762f 100644 --- a/source/loaddata.pas +++ b/source/loaddata.pas @@ -9,8 +9,8 @@ interface uses - Windows, SysUtils, Classes, Controls, Forms, Dialogs, StdCtrls, ComCtrls, CheckLst, - SynRegExpr, Buttons, ExtCtrls, ToolWin, ExtDlgs, Math, extra_controls, + Winapi.Windows, System.SysUtils, System.Classes, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ComCtrls, Vcl.CheckLst, + SynRegExpr, Vcl.Buttons, Vcl.ExtCtrls, Vcl.ToolWin, Vcl.ExtDlgs, System.Math, System.IOUtils, extra_controls, dbconnection, dbstructures, gnugettext; type @@ -53,11 +53,13 @@ Tloaddataform = class(TExtForm) chkLocalNumbers: TCheckBox; chkTruncateTable: TCheckBox; btnCheckAll: TToolButton; + chkKeepDialogOpen: TCheckBox; + const ProgressBarSteps=100; procedure FormCreate(Sender: TObject); - procedure FormDestroy(Sender: TObject); procedure editFilenameChange(Sender: TObject); procedure FormShow(Sender: TObject); procedure comboDatabaseChange(Sender: TObject); + procedure comboTablePopulate(SelectTableName: String; RefreshDbObjects: Boolean); procedure comboTableChange(Sender: TObject); procedure btnImportClick(Sender: TObject); procedure ServerParse(Sender: TObject); @@ -72,31 +74,28 @@ Tloaddataform = class(TExtForm) private { Private declarations } FFileEncoding: TEncoding; - Term, Encl, Escp, LineTerm: String; - RowCount, ColumnCount: Integer; - Columns: TTableColumnList; + FTerm, FEncl, FEscp, FLineTerm: String; + FRowCount, FColumnCount: Integer; + FColumns: TTableColumnList; FConnection: TDBConnection; public { Public declarations } + property FileEncoding: TEncoding read FFileEncoding; end; implementation -uses Main, apphelpers; +uses Main, apphelpers, csv_detector; {$R *.DFM} -const - ProgressBarSteps=100; procedure Tloaddataform.FormCreate(Sender: TObject); begin HasSizeGrip := True; // Restore settings - Width := AppSettings.ReadInt(asCSVImportWindowWidth); - Height := AppSettings.ReadInt(asCSVImportWindowHeight); editFilename.Text := AppSettings.ReadString(asCSVImportFilename); editFieldTerminator.Text := AppSettings.ReadString(asCSVImportSeparator); editFieldEncloser.Text := AppSettings.ReadString(asCSVImportEncloser); @@ -106,6 +105,7 @@ procedure Tloaddataform.FormCreate(Sender: TObject); updownIgnoreLines.Position := AppSettings.ReadInt(asCSVImportIgnoreLines); chkLowPriority.Checked := AppSettings.ReadBool(asCSVImportLowPriority); chkLocalNumbers.Checked := AppSettings.ReadBool(asCSVImportLocalNumbers); + chkKeepDialogOpen.Checked := AppSettings.ReadBool(asCSVKeepDialogOpen); // Uncheck critical "Truncate table" checkbox, to avoid accidental data removal chkTruncateTable.Checked := False; grpDuplicates.ItemIndex := AppSettings.ReadInt(asCSVImportDuplicateHandling); @@ -113,25 +113,6 @@ procedure Tloaddataform.FormCreate(Sender: TObject); end; -procedure Tloaddataform.FormDestroy(Sender: TObject); -begin - // Save settings - AppSettings.WriteInt(asCSVImportWindowWidth, Width); - AppSettings.WriteInt(asCSVImportWindowHeight, Height); - AppSettings.WriteString(asCSVImportFilename, editFilename.Text); - AppSettings.WriteString(asCSVImportSeparator, editFieldTerminator.Text); - AppSettings.WriteString(asCSVImportEncloser, editFieldEncloser.Text); - AppSettings.WriteString(asCSVImportTerminator, editLineTerminator.Text); - AppSettings.WriteBool(asCSVImportFieldsEnclosedOptionally, chkFieldsEnclosedOptionally.Checked); - AppSettings.WriteString(asCSVImportFieldEscaper, editFieldEscaper.Text); - AppSettings.WriteInt(asCSVImportIgnoreLines, updownIgnoreLines.Position); - AppSettings.WriteBool(asCSVImportLowPriority, chkLowPriority.Checked); - AppSettings.WriteBool(asCSVImportLocalNumbers, chkLocalNumbers.Checked); - AppSettings.WriteInt(asCSVImportDuplicateHandling, grpDuplicates.ItemIndex); - AppSettings.WriteInt(asCSVImportParseMethod, grpParseMethod.ItemIndex); -end; - - procedure Tloaddataform.FormResize(Sender: TObject); var HalfWidth, RightBoxX: Integer; @@ -152,6 +133,9 @@ procedure Tloaddataform.FormResize(Sender: TObject); procedure Tloaddataform.FormShow(Sender: TObject); begin + Width := AppSettings.ReadIntDpiAware(asCSVImportWindowWidth, Self); + Height := AppSettings.ReadIntDpiAware(asCSVImportWindowHeight, Self); + FConnection := MainForm.ActiveConnection; // Disable features supported in MySQL only, if active connection is not MySQL @@ -178,7 +162,21 @@ procedure Tloaddataform.FormShow(Sender: TObject); procedure Tloaddataform.FormClose(Sender: TObject; var Action: TCloseAction); begin - Action := caFree; + // Save settings + AppSettings.WriteIntDpiAware(asCSVImportWindowWidth, Self, Width); + AppSettings.WriteIntDpiAware(asCSVImportWindowHeight, Self, Height); + AppSettings.WriteString(asCSVImportFilename, editFilename.Text); + AppSettings.WriteString(asCSVImportSeparator, editFieldTerminator.Text); + AppSettings.WriteString(asCSVImportEncloser, editFieldEncloser.Text); + AppSettings.WriteString(asCSVImportTerminator, editLineTerminator.Text); + AppSettings.WriteBool(asCSVImportFieldsEnclosedOptionally, chkFieldsEnclosedOptionally.Checked); + AppSettings.WriteString(asCSVImportFieldEscaper, editFieldEscaper.Text); + AppSettings.WriteInt(asCSVImportIgnoreLines, updownIgnoreLines.Position); + AppSettings.WriteBool(asCSVImportLowPriority, chkLowPriority.Checked); + AppSettings.WriteBool(asCSVImportLocalNumbers, chkLocalNumbers.Checked); + AppSettings.WriteBool(asCSVKeepDialogOpen, chkKeepDialogOpen.Checked); + AppSettings.WriteInt(asCSVImportDuplicateHandling, grpDuplicates.ItemIndex); + AppSettings.WriteInt(asCSVImportParseMethod, grpParseMethod.ItemIndex); end; @@ -222,28 +220,37 @@ procedure Tloaddataform.grpParseMethodClick(Sender: TObject); procedure Tloaddataform.comboDatabaseChange(Sender: TObject); +begin + comboTablePopulate('', False); + grpParseMethod.OnClick(Sender); + comboTableChange(Sender); +end; + + +procedure Tloaddataform.comboTablePopulate(SelectTableName: String; RefreshDbObjects: Boolean); var - count, i: Integer; + i: Integer; DBObjects: TDBObjectList; - seldb, seltable: String; + FocusedTable: String; begin // read tables from db comboTable.Items.Clear; - seldb := Mainform.ActiveDatabase; - seltable := Mainform.ActiveDbObj.Name; - DBObjects := FConnection.GetDBObjects(comboDatabase.Text); + FocusedTable := Mainform.ActiveDbObj.Name; + DBObjects := FConnection.GetDBObjects(comboDatabase.Text, RefreshDbObjects); for i:=0 to DBObjects.Count-1 do begin if DBObjects[i].NodeType in [lntTable, lntView] then comboTable.Items.Add(DBObjects[i].Name); - count := comboTable.Items.Count-1; - if (comboDatabase.Text = seldb) and (comboTable.Items[count] = seltable) then - comboTable.ItemIndex := count; end; - if comboTable.ItemIndex = -1 then - comboTable.ItemIndex := 0; - grpParseMethod.OnClick(Sender); - comboTableChange(Sender); + if comboDatabase.Text = Mainform.ActiveDatabase then begin + if not SelectTableName.IsEmpty then + comboTable.ItemIndex := comboTable.Items.IndexOf(SelectTableName) + else if not FocusedTable.IsEmpty then + comboTable.ItemIndex := comboTable.Items.IndexOf(FocusedTable); + end; + if (comboTable.ItemIndex = -1) and (comboTable.Items.Count >= 1) then + comboTable.ItemIndex := 0; // First real table + comboTable.Items.Add('<'+_('New table')+'>'); end; @@ -253,20 +260,34 @@ procedure Tloaddataform.comboTableChange(Sender: TObject); DBObjects: TDBObjectList; Obj: TDBObject; begin - // fill columns: + // fill columns, or show csv detector: chklistColumns.Items.Clear; + if comboTable.ItemIndex = comboTable.Items.Count-1 then begin + frmCsvDetector := TfrmCsvDetector.Create(Self); + case frmCsvDetector.ShowModal of + mrOk: begin + // table got created and combo is refreshed + end; + else begin + comboTable.ItemIndex := 0; + end; + end; + frmCsvDetector.Free; + frmCsvDetector := nil; // check for Assigned() must be false in SetupSynEditors + end; + if (comboDatabase.Text <> '') and (comboTable.Text <> '') then begin - if not Assigned(Columns) then - Columns := TTableColumnList.Create; + if not Assigned(FColumns) then + FColumns := TTableColumnList.Create; DBObjects := FConnection.GetDBObjects(comboDatabase.Text); for Obj in DBObjects do begin if (Obj.Database=comboDatabase.Text) and (Obj.Name=comboTable.Text) then begin case Obj.NodeType of - lntTable, lntView: Columns := Obj.TableColumns; + lntTable, lntView: FColumns := Obj.TableColumns; end; end; end; - for Col in Columns do + for Col in FColumns do chklistColumns.Items.Add(Col.Name); end; @@ -283,7 +304,6 @@ procedure Tloaddataform.btnImportClick(Sender: TObject); var StartTickCount: Cardinal; i: Integer; - Warnings: TDBQuery; begin Screen.Cursor := crHourglass; StartTickCount := GetTickCount; @@ -292,46 +312,39 @@ procedure Tloaddataform.btnImportClick(Sender: TObject); // Truncate table before importing if chkTruncateTable.Checked then try FConnection.Query('TRUNCATE TABLE ' + FConnection.QuotedDbAndTableName(comboDatabase.Text, comboTable.Text)); + FConnection.ShowWarnings; except try FConnection.Query('DELETE FROM ' + FConnection.QuotedDbAndTableName(comboDatabase.Text, comboTable.Text)); + FConnection.ShowWarnings; except on E:EDbError do ErrorDialog(_('Cannot truncate table'), E.Message); end; end; - ColumnCount := 0; + FColumnCount := 0; for i:=0 to chkListColumns.Items.Count-1 do begin if chkListColumns.Checked[i] then - Inc(ColumnCount); + Inc(FColumnCount); end; - Term := FConnection.UnescapeString(editFieldTerminator.Text); - Encl := FConnection.UnescapeString(editFieldEncloser.Text); - LineTerm := FConnection.UnescapeString(editLineTerminator.Text); - Escp := FConnection.UnescapeString(editFieldEscaper.Text); + FTerm := FConnection.UnescapeString(editFieldTerminator.Text); + FEncl := FConnection.UnescapeString(editFieldEncloser.Text); + FLineTerm := FConnection.UnescapeString(editLineTerminator.Text); + FEscp := FConnection.UnescapeString(editFieldEscaper.Text); + + if chkKeepDialogOpen.Checked then + ModalResult := mrNone; try case grpParseMethod.ItemIndex of 0: ServerParse(Sender); 1: ClientParse(Sender); end; - MainForm.LogSQL(FormatNumber(RowCount)+' rows imported in '+FormatNumber((GetTickcount-StartTickCount)/1000, 3)+' seconds.'); - // SHOW WARNINGS is implemented as of MySQL 4.1.0 - if FConnection.Parameters.IsAnyMySQL and (FConnection.ServerVersionInt >= 40100) then begin - Warnings := FConnection.GetResults('SHOW WARNINGS'); - while not Warnings.Eof do begin - MainForm.LogSQL(Warnings.Col(0)+' ('+Warnings.Col(1)+'): '+Warnings.Col(2), lcError); - Warnings.Next; - end; - if Warnings.RecordCount > 0 then begin - ErrorDialog(f_('Your file was imported but the server returned %s warnings and/or notes. See the log panel for details.', [FormatNumber(Warnings.RecordCount)])); - ModalResult := mrNone; - end; - end; + MainForm.LogSQL(FormatNumber(FRowCount)+' rows imported in '+FormatNumber((GetTickcount-StartTickCount)/1000, 3)+' seconds.'); // Hint user if zero rows were detected in file - if (ModalResult <> mrNone) and (RowCount = 0) then begin + if FRowCount = 0 then begin ErrorDialog(_('No rows were imported'), _('This can have several causes:')+CRLF+ _(' - File is empty')+CRLF+ @@ -343,13 +356,22 @@ procedure Tloaddataform.btnImportClick(Sender: TObject); except on E:EDbError do begin - Screen.Cursor := crDefault; ModalResult := mrNone; MainForm.SetProgressState(pbsError); ErrorDialog(E.Message); end; + on E:EStreamError do begin + // all file stream errors, eg. EFOpenError and EReadError + // http://docwiki.embarcadero.com/Libraries/Sydney/en/System.Classes.EStreamError + ModalResult := mrNone; + MainForm.SetProgressState(pbsError); + ErrorDialog(E.Message + sLineBreak + sLineBreak + editFilename.Text); + end; end; + if ModalResult = mrNone then + btnCancel.Caption := _('Close'); + Mainform.ShowStatusMsg; MainForm.DisableProgress; Screen.Cursor := crDefault; @@ -360,11 +382,21 @@ procedure Tloaddataform.ServerParse(Sender: TObject); var SQL, SetColVars, SelectedCharset: String; i: Integer; + Filename: String; begin SQL := 'LOAD DATA '; if chkLowPriority.Checked and chkLowPriority.Enabled then SQL := SQL + 'LOW_PRIORITY '; - SQL := SQL + 'LOCAL INFILE ' + FConnection.EscapeString(editFilename.Text) + ' '; + + // Issue #1387: Use 8.3 filename, to prevent "file not found" error from MySQL library + // Todo: test on Wine + Filename := ExtractShortPathName(editFilename.Text); + if not Filename.IsEmpty then + MainForm.LogSQL('Converting filename to 8.3 format: '+editFilename.Text+' => '+Filename, lcInfo) + else + Filename := editFilename.Text; + SQL := SQL + 'LOCAL INFILE ' + FConnection.EscapeString(Filename) + ' '; + case grpDuplicates.ItemIndex of 1: SQL := SQL + 'IGNORE '; 2: SQL := SQL + 'REPLACE '; @@ -377,21 +409,21 @@ procedure Tloaddataform.ServerParse(Sender: TObject); end; // Fields: - if (Term <> '') or (Encl <> '') or (Escp <> '') then + if (FTerm <> '') or (FEncl <> '') or (FEscp <> '') then SQL := SQL + 'FIELDS '; if editFieldTerminator.Text <> '' then - SQL := SQL + 'TERMINATED BY ' + FConnection.EscapeString(Term) + ' '; - if Encl <> '' then begin + SQL := SQL + 'TERMINATED BY ' + FConnection.EscapeString(FTerm) + ' '; + if FEncl <> '' then begin if chkFieldsEnclosedOptionally.Checked then SQL := SQL + 'OPTIONALLY '; - SQL := SQL + 'ENCLOSED BY ' + FConnection.EscapeString(Encl) + ' '; + SQL := SQL + 'ENCLOSED BY ' + FConnection.EscapeString(FEncl) + ' '; end; - if Escp <> '' then - SQL := SQL + 'ESCAPED BY ' + FConnection.EscapeString(Escp) + ' '; + if FEscp <> '' then + SQL := SQL + 'ESCAPED BY ' + FConnection.EscapeString(FEscp) + ' '; // Lines: - if LineTerm <> '' then - SQL := SQL + 'LINES TERMINATED BY ' + FConnection.EscapeString(LineTerm) + ' '; + if FLineTerm <> '' then + SQL := SQL + 'LINES TERMINATED BY ' + FConnection.EscapeString(FLineTerm) + ' '; if updownIgnoreLines.Position > 0 then SQL := SQL + 'IGNORE ' + inttostr(updownIgnoreLines.Position) + ' LINES '; @@ -400,7 +432,7 @@ procedure Tloaddataform.ServerParse(Sender: TObject); SetColVars := ''; for i:=0 to chklistColumns.Items.Count-1 do begin if chklistColumns.Checked[i] then begin - if chkLocalNumbers.Checked and (Columns[i].DataType.Category in [dtcInteger, dtcReal]) then begin + if chkLocalNumbers.Checked and (FColumns[i].DataType.Category in [dtcInteger, dtcReal]) then begin SQL := SQL + '@ColVar' + IntToStr(i) + ', '; SetColVars := SetColVars + FConnection.QuoteIdent(chklistColumns.Items[i]) + ' = REPLACE(REPLACE(@ColVar' + IntToStr(i) + ', '+FConnection.EscapeString(FormatSettings.ThousandSeparator)+', ''''), '+FConnection.EscapeString(FormatSettings.DecimalSeparator)+', ''.''), '; @@ -417,7 +449,8 @@ procedure Tloaddataform.ServerParse(Sender: TObject); FConnection.Query(SQL); - RowCount := Max(FConnection.RowsAffected, 0); + FRowCount := Max(FConnection.RowsAffected, 0); + FConnection.ShowWarnings; end; @@ -425,6 +458,7 @@ procedure Tloaddataform.ClientParse(Sender: TObject); var P, ContentLen, ProgressCharsPerStep, ProgressChars: Integer; IgnoreLines, ValueCount, PacketSize: Integer; + LineNum: Int64; RowCountInChunk: Int64; EnclLen, TermLen, LineTermLen: Integer; Contents: String; @@ -433,8 +467,6 @@ procedure Tloaddataform.ClientParse(Sender: TObject); IsEncl, IsTerm, IsLineTerm, IsEof: Boolean; InEncl: Boolean; OutStream: TMemoryStream; -const - MaxRowCountPerChunk = 1000; procedure NextChar; begin @@ -442,7 +474,7 @@ procedure Tloaddataform.ClientParse(Sender: TObject); Inc(ProgressChars); if ProgressChars >= ProgressCharsPerStep then begin Mainform.ProgressStep; - Mainform.ShowStatusMsg(f_('Importing textfile, row %s, %d%%', [FormatNumber(RowCount-IgnoreLines), Mainform.ProgressBarStatus.Position])); + Mainform.ShowStatusMsg(f_('Importing textfile, row %s, %d%%', [FormatNumber(FRowCount-IgnoreLines), Mainform.ProgressBarStatus.Position])); ProgressChars := 0; end; end; @@ -467,8 +499,8 @@ procedure Tloaddataform.ClientParse(Sender: TObject); ValuesCounted: Integer; begin Inc(ValueCount); - if ValueCount <= ColumnCount then begin - if Copy(Value, 1, EnclLen) = Encl then begin + if ValueCount <= FColumnCount then begin + if Copy(Value, 1, EnclLen) = FEncl then begin Delete(Value, 1, EnclLen); Delete(Value, Length(Value)-EnclLen+1, EnclLen); end; @@ -495,17 +527,17 @@ procedure Tloaddataform.ClientParse(Sender: TObject); for i:=0 to chkListColumns.Items.Count-1 do begin if chkListColumns.Checked[i] then // column was already counted - Inc(ValuesCounted); // increase number of counted columns + Inc(ValuesCounted); // increase number of counted columns if ValuesCounted = ValueCount then // did we count all included columns up to the current column? - Break; + Break; Inc(ColumnIndex); // if all columns (until the current column) are checked, ColumnIndex is ValueCount-1, like before this patch end; if Value <> 'NULL' then begin - if chkLocalNumbers.Checked and (Columns[ColumnIndex].DataType.Category in [dtcInteger, dtcReal]) then + if chkLocalNumbers.Checked and (FColumns[ColumnIndex].DataType.Category in [dtcInteger, dtcReal]) then Value := UnformatNumber(Value) else - Value := FConnection.EscapeString(Value); + Value := FConnection.EscapeString(Value, FColumns[ColumnIndex].DataType); end; SQL := SQL + Value + ', '; end; @@ -520,18 +552,18 @@ procedure Tloaddataform.ClientParse(Sender: TObject); begin if SQL = '' then Exit; - Inc(RowCount); - for i:=ValueCount to ColumnCount do begin + Inc(LineNum); + for i:=ValueCount to FColumnCount do begin Value := 'NULL'; AddValue; end; ValueCount := 0; - if RowCount > IgnoreLines then begin + if LineNum > IgnoreLines then begin Delete(SQL, Length(SQL)-1, 2); StreamWrite(OutStream, SQL + ')'); SQL := ''; Inc(RowCountInChunk); - if (OutStream.Size < PacketSize) and (P < ContentLen) and (RowCountInChunk < MaxRowCountPerChunk) then begin + if (OutStream.Size < PacketSize) and (P < ContentLen) and (RowCountInChunk < FConnection.MaxRowsPerInsert) then begin SQL := SQL + ', ('; end else begin OutStream.Position := 0; @@ -540,6 +572,8 @@ procedure Tloaddataform.ClientParse(Sender: TObject); OutStream.Read(PAnsiChar(SA)^, ChunkSize); OutStream.Size := 0; FConnection.Query(UTF8ToString(SA), False, lcScript); + Inc(FRowCount, Max(FConnection.RowsAffected, 0)); + FConnection.ShowWarnings; SQL := ''; RowCountInChunk := 0; end; @@ -548,9 +582,9 @@ procedure Tloaddataform.ClientParse(Sender: TObject); end; begin - TermLen := Length(Term); - EnclLen := Length(Encl); - LineTermLen := Length(LineTerm); + TermLen := Length(FTerm); + EnclLen := Length(FEncl); + LineTermLen := Length(FLineTerm); SetLength(TermTest, TermLen); SetLength(EnclTest, EnclLen); @@ -562,6 +596,11 @@ procedure Tloaddataform.ClientParse(Sender: TObject); Value := ''; OutStream := TMemoryStream.Create; + // Turns SQL errors into warnings, e.g. when providing an empty string for an integer column + if FConnection.Parameters.IsAnyMySQL then begin + FConnection.Query('/*!40101 SET @OLD_SQL_MODE=@@SQL_MODE, SQL_MODE='''' */'); + end; + MainForm.ShowStatusMsg(f_('Reading textfile (%s) ...', [FormatByteNumber(_GetFileSize(editFilename.Text))])); Contents := ReadTextfile(editFilename.Text, FFileEncoding); ContentLen := Length(Contents); @@ -570,7 +609,8 @@ procedure Tloaddataform.ClientParse(Sender: TObject); P := 0; ProgressCharsPerStep := ContentLen div ProgressBarSteps; ProgressChars := 0; - RowCount := 0; + FRowCount := 0; + LineNum := 0; RowCountInChunk := 0; IgnoreLines := UpDownIgnoreLines.Position; ValueCount := 0; @@ -580,9 +620,9 @@ procedure Tloaddataform.ClientParse(Sender: TObject); // TODO: read chunks! while P <= ContentLen do begin // Check characters left-side from current position - IsEncl := TestLeftChars(EnclTest, Encl, EnclLen); - IsTerm := TestLeftChars(TermTest, Term, TermLen); - IsLineTerm := TestLeftChars(LineTermTest, LineTerm, LineTermLen) and (ValueCount >= ColumnCount-1); + IsEncl := TestLeftChars(EnclTest, FEncl, EnclLen); + IsTerm := TestLeftChars(TermTest, FTerm, TermLen); + IsLineTerm := TestLeftChars(LineTermTest, FLineTerm, LineTermLen) and (ValueCount >= FColumnCount-1); IsEof := P = ContentLen; Value := Value + Contents[P]; @@ -612,25 +652,36 @@ procedure Tloaddataform.ClientParse(Sender: TObject); Contents := ''; FreeAndNil(OutStream); - RowCount := Max(RowCount-IgnoreLines, 0); + + if FConnection.Parameters.IsAnyMySQL then begin + FConnection.Query('/*!40101 SET SQL_MODE=IFNULL(@OLD_SQL_MODE, '''') */'); + end; end; procedure Tloaddataform.btnOpenFileClick(Sender: TObject); var - Dialog: TOpenTextFileDialog; + Dialog: TExtFileOpenDialog; TestStream: TFileStream; begin AppSettings.ResetPath; - Dialog := TOpenTextFileDialog.Create(Self); - Dialog.Filter := _('CSV files')+' (*.csv)|*.csv|'+_('Text files')+' (*.txt)|*.txt|'+_('All files')+' (*.*)|*.*'; - Dialog.DefaultExt := 'csv'; + Dialog := TExtFileOpenDialog.Create(Self); + Dialog.DefaultFolder := ExtractFilePath(editFilename.Text); + Dialog.FileName := ExtractFileName(editFilename.Text); + Dialog.AddFileType('*.csv', _('CSV files')); + Dialog.AddFileType('*.txt', _('Text files')); + Dialog.AddFileType('*.*', _('All files')); + Dialog.DefaultExtension := 'csv'; Dialog.Encodings.Assign(Mainform.FileEncodings); Dialog.EncodingIndex := AppSettings.ReadInt(asFileDialogEncoding, Self.Name); if Dialog.Execute then begin editfilename.Text := Dialog.FileName; FFileEncoding := Mainform.GetEncodingByName(Dialog.Encodings[Dialog.EncodingIndex]); if FFileEncoding = nil then begin + MessageDialog(_('Auto detecting the encoding of a file is highly discouraged. You may experience data loss if the detection fails.') + + SLineBreak + SLineBreak + + _('To avoid this message select the correct encoding before pressing Open.'), + mtWarning, [mbOK]); TestStream := TFileStream.Create(Dialog.Filename, fmOpenRead or fmShareDenyNone); FFileEncoding := DetectEncoding(TestStream); TestStream.Free; diff --git a/source/loginform.dfm b/source/loginform.dfm index 69c69238b..dd8fd1241 100644 --- a/source/loginform.dfm +++ b/source/loginform.dfm @@ -8,18 +8,16 @@ object frmLogin: TfrmLogin Color = clBtnFace Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText - Font.Height = -11 + Font.Height = -12 Font.Name = 'Tahoma' Font.Style = [] - OldCreateOrder = False Position = poScreenCenter OnCreate = FormCreate OnShow = FormShow DesignSize = ( 270 176) - PixelsPerInch = 96 - TextHeight = 13 + TextHeight = 14 object btnOK: TButton Left = 164 Top = 143 diff --git a/source/loginform.pas b/source/loginform.pas index 079a22f27..76e795493 100644 --- a/source/loginform.pas +++ b/source/loginform.pas @@ -3,8 +3,8 @@ interface uses - Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, - Dialogs, StdCtrls, ExtCtrls, gnugettext, System.UITypes, extra_controls; + Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, + Vcl.Dialogs, Vcl.StdCtrls, Vcl.ExtCtrls, gnugettext, System.UITypes, extra_controls; type TfrmLogin = class(TExtForm) diff --git a/source/main.dfm b/source/main.dfm index 5777d7b23..9950b7fa4 100644 --- a/source/main.dfm +++ b/source/main.dfm @@ -1,29 +1,29 @@ object MainForm: TMainForm Left = 0 Top = 463 - ClientHeight = 466 - ClientWidth = 977 + ClientHeight = 408 + ClientWidth = 865 Color = clBtnFace Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText - Font.Height = -11 + Font.Height = -12 Font.Name = 'Tahoma' Font.Style = [] Menu = MainMenu1 - OldCreateOrder = True Position = poDesigned ShowHint = True + OnAfterMonitorDpiChanged = FormAfterMonitorDpiChanged + OnBeforeMonitorDpiChanged = FormBeforeMonitorDpiChanged OnCloseQuery = FormCloseQuery OnCreate = FormCreate OnDestroy = FormDestroy OnMouseWheel = FormMouseWheel OnShow = FormShow - PixelsPerInch = 96 - TextHeight = 13 + TextHeight = 14 object spltTopBottom: TSplitter Left = 0 - Top = 363 - Width = 977 + Top = 305 + Width = 865 Height = 4 Cursor = crSizeNS Align = alBottom @@ -32,8 +32,8 @@ object MainForm: TMainForm end object SynMemoSQLLog: TSynMemo Left = 0 - Top = 367 - Width = 977 + Top = 309 + Width = 865 Height = 80 SingleLineMode = True Align = alBottom @@ -65,12 +65,13 @@ object MainForm: TMainForm ReadOnly = True RightEdge = 0 ScrollBars = ssVertical + OnSpecialLineColors = SynMemoSQLLogSpecialLineColors FontSmoothing = fsmNone end object StatusBar: TStatusBar Left = 0 - Top = 447 - Width = 977 + Top = 389 + Width = 865 Height = 19 AutoHint = True Panels = < @@ -109,8 +110,8 @@ object MainForm: TMainForm object panelTop: TPanel Left = 0 Top = 26 - Width = 977 - Height = 337 + Width = 865 + Height = 279 Align = alClient AutoSize = True BevelOuter = bvNone @@ -120,7 +121,7 @@ object MainForm: TMainForm Left = 169 Top = 0 Width = 4 - Height = 337 + Height = 279 Cursor = crSizeWE ResizeStyle = rsUpdate end @@ -128,14 +129,14 @@ object MainForm: TMainForm Left = 0 Top = 0 Width = 169 - Height = 337 + Height = 279 Align = alLeft BevelOuter = bvNone TabOrder = 0 OnResize = pnlLeftResize object spltPreview: TSplitter Left = 0 - Top = 233 + Top = 175 Width = 169 Height = 4 Cursor = crSizeNS @@ -148,7 +149,7 @@ object MainForm: TMainForm Left = 0 Top = 22 Width = 169 - Height = 211 + Height = 153 Align = alClient Constraints.MinWidth = 40 DragMode = dmAutomatic @@ -183,6 +184,8 @@ object MainForm: TMainForm OnInitChildren = DBtreeInitChildren OnInitNode = DBtreeInitNode OnMouseUp = DBtreeMouseUp + Touch.InteractiveGestures = [igPan, igPressAndTap] + Touch.InteractiveGestureOptions = [igoPanSingleFingerHorizontal, igoPanSingleFingerVertical, igoPanInertia, igoPanGutter, igoParentPassthrough] Columns = < item Position = 0 @@ -201,7 +204,7 @@ object MainForm: TMainForm end object pnlPreview: TPanel Left = 0 - Top = 237 + Top = 179 Width = 169 Height = 100 Align = alBottom @@ -331,15 +334,15 @@ object MainForm: TMainForm object pnlRight: TPanel Left = 173 Top = 0 - Width = 804 - Height = 337 + Width = 692 + Height = 279 Align = alClient BevelOuter = bvNone TabOrder = 1 object pnlFilterVT: TPanel Left = 0 - Top = 311 - Width = 804 + Top = 253 + Width = 692 Height = 26 Align = alBottom BevelOuter = bvNone @@ -348,15 +351,15 @@ object MainForm: TMainForm object lblFilterVT: TLabel Left = 36 Top = 6 - Width = 28 - Height = 13 + Width = 30 + Height = 14 Caption = 'Filter:' end object lblFilterVTInfo: TLabel Left = 239 Top = 6 - Width = 66 - Height = 13 + Width = 75 + Height = 14 Caption = 'lblFilterVTInfo' end object btnCloseFilterPanel: TSpeedButton @@ -372,22 +375,27 @@ object MainForm: TMainForm Left = 70 Top = 3 Width = 154 - Height = 21 + Height = 22 Images = VirtualImageListMain + LeftButton.ImageIndex = 192 + LeftButton.Visible = True RightButton.Hint = 'Clear filter' RightButton.ImageIndex = 193 RightButton.Visible = True TabOrder = 0 TextHint = 'Regular expression' OnChange = editFilterVTChange - OnRightButtonClick = editFilterVTRightButtonClick + OnExit = editDatabaseTableFilterExit + OnKeyPress = editDatabaseTableFilterKeyPress + OnLeftButtonClick = editDatabaseTableFilterLeftButtonClick + OnRightButtonClick = buttonedEditClear end end object PageControlMain: TPageControl Left = 0 Top = 0 - Width = 804 - Height = 311 + Width = 692 + Height = 253 ActivePage = tabHost Align = alClient HotTrack = True @@ -405,8 +413,8 @@ object MainForm: TMainForm object PageControlHost: TPageControl Left = 0 Top = 0 - Width = 796 - Height = 282 + Width = 684 + Height = 224 ActivePage = tabDatabases Align = alClient HotTrack = True @@ -419,8 +427,8 @@ object MainForm: TMainForm object ListDatabases: TVirtualStringTree Left = 0 Top = 0 - Width = 788 - Height = 253 + Width = 676 + Height = 195 Align = alClient Header.AutoSizeIndex = 0 Header.Options = [hoColumnResize, hoDblClickResize, hoDrag, hoHotTrack, hoShowSortGlyphs, hoVisible, hoDisableAnimatedResize, hoAutoResizeInclCaption] @@ -432,7 +440,7 @@ object MainForm: TMainForm TreeOptions.PaintOptions = [toHotTrack, toShowButtons, toShowDropmark, toShowHorzGridLines, toShowVertGridLines, toThemeAware, toUseBlendedImages, toGhostedIfUnfocused, toUseExplorerTheme, toHideTreeLinesIfThemed] TreeOptions.SelectionOptions = [toExtendedFocus, toFullRowSelect, toMultiSelect, toRightClickSelect] OnAfterPaint = AnyGridAfterPaint - OnBeforeCellPaint = ListDatabasesBeforeCellPaint + OnBeforeCellPaint = HostListBeforeCellPaint OnBeforePaint = ListDatabasesBeforePaint OnCompareNodes = AnyGridCompareNodes OnDblClick = ListDatabasesDblClick @@ -443,6 +451,8 @@ object MainForm: TMainForm OnHeaderClick = AnyGridHeaderClick OnHeaderDraggedOut = AnyGridHeaderDraggedOut OnInitNode = ListDatabasesInitNode + Touch.InteractiveGestures = [igPan, igPressAndTap] + Touch.InteractiveGestureOptions = [igoPanSingleFingerHorizontal, igoPanSingleFingerVertical, igoPanInertia, igoPanGutter, igoParentPassthrough] Columns = < item Position = 0 @@ -499,8 +509,8 @@ object MainForm: TMainForm object ListVariables: TVirtualStringTree Left = 0 Top = 0 - Width = 788 - Height = 253 + Width = 676 + Height = 195 Align = alClient DragOperations = [] Header.AutoSizeIndex = 2 @@ -515,11 +525,11 @@ object MainForm: TMainForm PopupMenu = popupHost ShowHint = True TabOrder = 0 - TreeOptions.MiscOptions = [toToggleOnDblClick] + TreeOptions.MiscOptions = [toGridExtensions, toToggleOnDblClick] TreeOptions.PaintOptions = [toHotTrack, toShowDropmark, toShowHorzGridLines, toShowVertGridLines, toThemeAware, toUseBlendedImages, toUseExplorerTheme] TreeOptions.SelectionOptions = [toExtendedFocus, toFullRowSelect, toRightClickSelect] OnAfterPaint = AnyGridAfterPaint - OnBeforeCellPaint = ListVariablesBeforeCellPaint + OnBeforeCellPaint = HostListBeforeCellPaint OnBeforePaint = HostListBeforePaint OnCompareNodes = AnyGridCompareNodes OnDblClick = ListVariablesDblClick @@ -531,6 +541,8 @@ object MainForm: TMainForm OnHeaderClick = AnyGridHeaderClick OnHeaderDraggedOut = AnyGridHeaderDraggedOut OnInitNode = AnyGridInitNode + Touch.InteractiveGestures = [igPan, igPressAndTap] + Touch.InteractiveGestureOptions = [igoPanSingleFingerHorizontal, igoPanSingleFingerVertical, igoPanInertia, igoPanGutter, igoParentPassthrough] Columns = < item Position = 0 @@ -545,7 +557,7 @@ object MainForm: TMainForm item Position = 2 Text = 'Global' - Width = 424 + Width = 312 end> end end @@ -555,8 +567,8 @@ object MainForm: TMainForm object ListStatus: TVirtualStringTree Left = 0 Top = 0 - Width = 788 - Height = 253 + Width = 676 + Height = 195 Align = alClient DragOperations = [] Header.AutoSizeIndex = 1 @@ -575,6 +587,7 @@ object MainForm: TMainForm TreeOptions.PaintOptions = [toHotTrack, toShowDropmark, toShowHorzGridLines, toShowVertGridLines, toThemeAware, toUseBlendedImages, toUseExplorerTheme] TreeOptions.SelectionOptions = [toExtendedFocus, toFullRowSelect, toRightClickSelect] OnAfterPaint = AnyGridAfterPaint + OnBeforeCellPaint = HostListBeforeCellPaint OnBeforePaint = HostListBeforePaint OnCompareNodes = AnyGridCompareNodes OnGetText = HostListGetText @@ -584,6 +597,8 @@ object MainForm: TMainForm OnHeaderClick = AnyGridHeaderClick OnHeaderDraggedOut = AnyGridHeaderDraggedOut OnInitNode = AnyGridInitNode + Touch.InteractiveGestures = [igPan, igPressAndTap] + Touch.InteractiveGestureOptions = [igoPanSingleFingerHorizontal, igoPanSingleFingerVertical, igoPanInertia, igoPanGutter, igoParentPassthrough] Columns = < item Position = 0 @@ -594,7 +609,7 @@ object MainForm: TMainForm Alignment = taRightJustify Position = 1 Text = 'Value' - Width = 424 + Width = 312 end item Alignment = taRightJustify @@ -615,8 +630,8 @@ object MainForm: TMainForm ImageIndex = 57 object spltProcessList: TSplitter Left = 0 - Top = 180 - Width = 788 + Top = 122 + Width = 676 Height = 4 Cursor = crSizeNS Align = alBottom @@ -625,8 +640,8 @@ object MainForm: TMainForm object ListProcesses: TVirtualStringTree Left = 0 Top = 0 - Width = 788 - Height = 180 + Width = 676 + Height = 122 Align = alClient Header.AutoSizeIndex = 7 Header.Height = 20 @@ -656,6 +671,8 @@ object MainForm: TMainForm OnHeaderClick = AnyGridHeaderClick OnHeaderDraggedOut = AnyGridHeaderDraggedOut OnInitNode = AnyGridInitNode + Touch.InteractiveGestures = [igPan, igPressAndTap] + Touch.InteractiveGestureOptions = [igoPanSingleFingerHorizontal, igoPanSingleFingerVertical, igoPanInertia, igoPanGutter, igoParentPassthrough] Columns = < item Alignment = taRightJustify @@ -694,13 +711,13 @@ object MainForm: TMainForm item Position = 7 Text = 'Info' - Width = 294 + Width = 182 end> end object pnlProcessViewBox: TPanel Left = 0 - Top = 184 - Width = 788 + Top = 126 + Width = 676 Height = 69 Align = alBottom BevelOuter = bvNone @@ -708,7 +725,7 @@ object MainForm: TMainForm object pnlProcessView: TPanel Left = 0 Top = 0 - Width = 788 + Width = 676 Height = 18 Align = alTop Alignment = taLeftJustify @@ -718,30 +735,19 @@ object MainForm: TMainForm object lblExplainProcess: TLabel Left = 95 Top = 2 - Width = 41 - Height = 13 + Width = 47 + Height = 14 Cursor = crHandPoint Hint = 'Analyze this query' Caption = 'EXPLAIN' Enabled = False OnClick = lblExplainProcessClick end - object lblExplainProcessAnalyzer: TLabel - Left = 170 - Top = 2 - Width = 162 - Height = 13 - Cursor = crHandPoint - Hint = 'Analyze this query on MariaDB.org' - Caption = 'EXPLAIN analyzer on MariaDB.org' - Enabled = False - OnClick = lblExplainProcessAnalyzerClick - end end object SynMemoProcessView: TSynMemo Left = 0 Top = 18 - Width = 788 + Width = 676 Height = 51 SingleLineMode = False Align = alClient @@ -783,8 +789,8 @@ object MainForm: TMainForm object ListCommandStats: TVirtualStringTree Left = 0 Top = 0 - Width = 788 - Height = 253 + Width = 676 + Height = 195 Align = alClient Header.AutoSizeIndex = 4 Header.Height = 20 @@ -813,6 +819,8 @@ object MainForm: TMainForm OnHeaderClick = AnyGridHeaderClick OnHeaderDraggedOut = AnyGridHeaderDraggedOut OnInitNode = AnyGridInitNode + Touch.InteractiveGestures = [igPan, igPressAndTap] + Touch.InteractiveGestureOptions = [igoPanSingleFingerHorizontal, igoPanSingleFingerVertical, igoPanInertia, igoPanGutter, igoParentPassthrough] Columns = < item Position = 0 @@ -840,7 +848,7 @@ object MainForm: TMainForm item Position = 4 Text = 'Percentage' - Width = 364 + Width = 252 end> end end @@ -852,8 +860,8 @@ object MainForm: TMainForm object ListTables: TVirtualStringTree Left = 0 Top = 0 - Width = 796 - Height = 282 + Width = 684 + Height = 224 Align = alClient EditDelay = 500 Header.AutoSizeIndex = -1 @@ -888,6 +896,8 @@ object MainForm: TMainForm OnInitNode = ListTablesInitNode OnKeyPress = ListTablesKeyPress OnNewText = ListTablesNewText + Touch.InteractiveGestures = [igPan, igPressAndTap] + Touch.InteractiveGestureOptions = [igoPanSingleFingerHorizontal, igoPanSingleFingerVertical, igoPanInertia, igoPanGutter, igoParentPassthrough] Columns = < item Position = 0 @@ -1010,8 +1020,8 @@ object MainForm: TMainForm object lblSorryNoData: TLabel Left = 0 Top = 91 - Width = 796 - Height = 191 + Width = 684 + Height = 133 Align = alClient Alignment = taCenter Caption = 'No data available for this item.' @@ -1021,7 +1031,7 @@ object MainForm: TMainForm object pnlDataTop: TPanel Left = 0 Top = 0 - Width = 796 + Width = 684 Height = 25 Align = alTop Alignment = taLeftJustify @@ -1031,23 +1041,23 @@ object MainForm: TMainForm object lblDataTop: TLabel Left = 1 Top = 1 - Width = 514 + Width = 574 Height = 23 Align = alLeft Anchors = [akLeft, akTop, akRight, akBottom] AutoSize = False Caption = 'Data' + PopupMenu = popupDataTop Layout = tlCenter - WordWrap = True end object tlbDataButtons: TToolBar - Left = 452 + Left = 315 Top = 1 - Width = 343 + Width = 368 Height = 23 Align = alRight AutoSize = True - ButtonWidth = 67 + ButtonWidth = 72 Caption = 'tlbDataButtons' Images = VirtualImageListMain List = True @@ -1062,12 +1072,12 @@ object MainForm: TMainForm Action = actDataShowNext end object tbtnDataShowAll: TToolButton - Left = 67 + Left = 72 Top = 0 Action = actDataShowAll end object ToolButton2: TToolButton - Left = 134 + Left = 144 Top = 0 Width = 8 Caption = 'ToolButton2' @@ -1076,7 +1086,7 @@ object MainForm: TMainForm Style = tbsSeparator end object tbtnDataSorting: TToolButton - Left = 142 + Left = 152 Top = 0 AllowAllUp = True Caption = 'Sorting' @@ -1086,7 +1096,7 @@ object MainForm: TMainForm OnClick = btnDataClick end object tbtnDataColumns: TToolButton - Left = 209 + Left = 224 Top = 0 AllowAllUp = True Caption = 'Columns' @@ -1096,7 +1106,7 @@ object MainForm: TMainForm OnClick = btnDataClick end object tbtnDataFilter: TToolButton - Left = 276 + Left = 296 Top = 0 AllowAllUp = True Caption = 'Filter' @@ -1109,52 +1119,54 @@ object MainForm: TMainForm object pnlFilter: TPanel Left = 0 Top = 25 - Width = 796 + Width = 684 Height = 66 Align = alTop BevelOuter = bvNone TabOrder = 1 Visible = False DesignSize = ( - 796 + 684 66) object lblTableFilter: TLabel - Left = 633 + Left = 497 Top = 0 - Width = 123 - Height = 13 + Width = 141 + Height = 14 Anchors = [akTop, akRight] Caption = 'Create multi column filter:' end object lblRecentFilters: TLabel Left = 1 Top = 3 - Width = 68 - Height = 13 + Width = 76 + Height = 14 Caption = 'Recent filters:' end object btnFilterApply: TButton - Left = 633 + Left = 497 Top = 41 - Width = 76 + Width = 89 Height = 22 Action = actApplyFilter Anchors = [akTop, akRight] - TabOrder = 2 + DropDownMenu = popupApplyFilter + Style = bsSplitButton + TabOrder = 3 end object btnFilterClear: TButton - Left = 713 + Left = 592 Top = 41 - Width = 76 + Width = 89 Height = 22 Action = actClearFilterEditor Anchors = [akTop, akRight] - TabOrder = 3 + TabOrder = 4 end object SynMemoFilter: TSynMemo Left = 0 Top = 21 - Width = 630 + Width = 494 Height = 42 SingleLineMode = False Anchors = [akLeft, akTop, akRight, akBottom] @@ -1164,7 +1176,7 @@ object MainForm: TMainForm Font.Name = 'Courier New' Font.Style = [] PopupMenu = popupFilter - TabOrder = 0 + TabOrder = 1 CodeFolding.GutterShapeSize = 11 CodeFolding.CollapsedLineColor = clGrayText CodeFolding.FolderBarLinesColor = clGrayText @@ -1193,12 +1205,12 @@ object MainForm: TMainForm FontSmoothing = fsmNone end object editFilterSearch: TEdit - Left = 633 + Left = 497 Top = 15 - Width = 156 - Height = 21 + Width = 184 + Height = 22 Anchors = [akTop, akRight] - TabOrder = 1 + TabOrder = 2 OnChange = editFilterSearchChange OnEnter = editFilterSearchEnter OnExit = editFilterSearchExit @@ -1206,22 +1218,22 @@ object MainForm: TMainForm object comboRecentFilters: TComboBox Left = 77 Top = 0 - Width = 553 - Height = 21 + Width = 417 + Height = 22 AutoDropDown = True AutoCloseUp = True Style = csDropDownList Anchors = [akLeft, akTop, akRight] DropDownCount = 20 - TabOrder = 4 + TabOrder = 0 OnSelect = LoadRecentFilter end end object DataGrid: TVirtualStringTree Left = 0 Top = 91 - Width = 796 - Height = 191 + Width = 684 + Height = 133 Align = alClient AutoScrollDelay = 50 EditDelay = 0 @@ -1231,11 +1243,10 @@ object MainForm: TMainForm Header.MainColumn = -1 Header.Options = [hoColumnResize, hoDblClickResize, hoDrag, hoHotTrack, hoOwnerDraw, hoShowHint, hoShowImages, hoVisible, hoDisableAnimatedResize, hoAutoResizeInclCaption] IncrementalSearch = isInitializedOnly - LineStyle = lsSolid PopupMenu = popupDataGrid TabOrder = 2 TreeOptions.AutoOptions = [toAutoDropExpand, toAutoScroll, toAutoScrollOnExpand, toAutoTristateTracking, toAutoDeleteMovedNodes, toAutoChangeScale] - TreeOptions.MiscOptions = [toAcceptOLEDrop, toEditable, toFullRepaintOnResize, toGridExtensions, toInitOnSave, toWheelPanning, toVariableNodeHeight, toEditOnClick, toEditOnDblClick] + TreeOptions.MiscOptions = [toAcceptOLEDrop, toEditable, toFullRepaintOnResize, toGridExtensions, toInitOnSave, toWheelPanning, toEditOnClick, toEditOnDblClick] TreeOptions.PaintOptions = [toShowButtons, toShowDropmark, toShowHorzGridLines, toShowVertGridLines, toThemeAware, toUseBlendedImages, toAlwaysHideSelection] TreeOptions.SelectionOptions = [toExtendedFocus, toFullRowSelect, toMultiSelect, toRightClickSelect] WantTabs = True @@ -1263,6 +1274,8 @@ object MainForm: TMainForm OnMouseUp = AnyGridMouseUp OnMouseWheel = AnyGridMouseWheel OnNewText = AnyGridNewText + Touch.InteractiveGestures = [igPan, igPressAndTap] + Touch.InteractiveGestureOptions = [igoPanSingleFingerHorizontal, igoPanSingleFingerVertical, igoPanInertia, igoPanGutter, igoParentPassthrough] Columns = <> end end @@ -1272,7 +1285,7 @@ object MainForm: TMainForm object spltQuery: TSplitter Left = 0 Top = 96 - Width = 796 + Width = 684 Height = 4 Cursor = crSizeNS Align = alTop @@ -1282,14 +1295,14 @@ object MainForm: TMainForm object pnlQueryMemo: TPanel Left = 0 Top = 0 - Width = 796 + Width = 684 Height = 96 Align = alTop BevelOuter = bvNone Constraints.MinHeight = 40 TabOrder = 0 object spltQueryHelpers: TSplitter - Left = 607 + Left = 495 Top = 0 Width = 4 Height = 96 @@ -1300,7 +1313,7 @@ object MainForm: TMainForm object SynMemoQuery: TSynMemo Left = 0 Top = 0 - Width = 607 + Width = 495 Height = 96 SingleLineMode = False Align = alClient @@ -1316,7 +1329,7 @@ object MainForm: TMainForm OnDragDrop = SynMemoQueryDragDrop OnDragOver = SynMemoQueryDragOver OnKeyPress = SynMemoQueryKeyPress - OnMouseWheel = SynMemoQueryMouseWheel + OnMouseWheel = AnySynMemoMouseWheel CodeFolding.GutterShapeSize = 11 CodeFolding.CollapsedLineColor = clGrayText CodeFolding.FolderBarLinesColor = clGrayText @@ -1335,20 +1348,35 @@ object MainForm: TMainForm Gutter.RightOffset = 0 Gutter.ShowLineNumbers = True Highlighter = SynSQLSynUsed + HintMode = shmToken Options = [eoAutoIndent, eoAutoSizeMaxScrollWidth, eoDropFiles, eoGroupUndo, eoHideShowScrollbars, eoKeepCaretX, eoShowScrollHint, eoTabIndent] RightEdge = 0 TabWidth = 3 WantTabs = True OnDropFiles = SynMemoQueryDropFiles OnReplaceText = SynMemoQueryReplaceText + OnSpecialLineColors = SynMemoQuerySpecialLineColors OnStatusChange = SynMemoQueryStatusChange + OnTokenHint = SynMemoQueryTokenHint OnPaintTransient = SynMemoQueryPaintTransient OnScanForFoldRanges = SynMemoQueryScanForFoldRanges FontSmoothing = fsmNone RemovedKeystrokes = < + item + Command = ecRedo + ShortCut = 40968 + end item Command = ecDeleteWord ShortCut = 16468 + end + item + Command = ecDeleteLine + ShortCut = 16473 + end + item + Command = ecRedo + ShortCut = 24666 end> AddedKeystrokes = < item @@ -1365,7 +1393,7 @@ object MainForm: TMainForm end> end object pnlQueryHelpers: TPanel - Left = 611 + Left = 499 Top = 0 Width = 185 Height = 96 @@ -1376,9 +1404,9 @@ object MainForm: TMainForm TabOrder = 1 object treeQueryHelpers: TVirtualStringTree Left = 0 - Top = 21 + Top = 22 Width = 185 - Height = 75 + Height = 74 Align = alClient Constraints.MinWidth = 10 DragMode = dmAutomatic @@ -1410,6 +1438,8 @@ object MainForm: TMainForm OnNewText = treeQueryHelpersNewText OnNodeClick = treeQueryHelpersNodeClick OnResize = treeQueryHelpersResize + Touch.InteractiveGestures = [igPan, igPressAndTap] + Touch.InteractiveGestureOptions = [igoPanSingleFingerHorizontal, igoPanSingleFingerVertical, igoPanInertia, igoPanGutter, igoParentPassthrough] Columns = < item Position = 0 @@ -1426,7 +1456,7 @@ object MainForm: TMainForm Left = 0 Top = 0 Width = 185 - Height = 21 + Height = 22 Align = alTop Images = VirtualImageListMain LeftButton.ImageIndex = 30 @@ -1442,8 +1472,8 @@ object MainForm: TMainForm object QueryGrid: TVirtualStringTree Left = 0 Top = 124 - Width = 796 - Height = 158 + Width = 684 + Height = 100 Align = alClient AutoScrollDelay = 50 EditDelay = 0 @@ -1454,11 +1484,10 @@ object MainForm: TMainForm Header.Options = [hoColumnResize, hoDblClickResize, hoDrag, hoHotTrack, hoOwnerDraw, hoShowHint, hoShowImages, hoDisableAnimatedResize, hoAutoResizeInclCaption] Header.PopupMenu = popupListHeader IncrementalSearch = isAll - LineStyle = lsSolid PopupMenu = popupDataGrid TabOrder = 1 TreeOptions.AutoOptions = [toAutoDropExpand, toAutoScroll, toAutoScrollOnExpand, toAutoTristateTracking, toAutoDeleteMovedNodes, toAutoChangeScale] - TreeOptions.MiscOptions = [toAcceptOLEDrop, toEditable, toFullRepaintOnResize, toGridExtensions, toInitOnSave, toWheelPanning, toVariableNodeHeight, toEditOnClick, toEditOnDblClick] + TreeOptions.MiscOptions = [toAcceptOLEDrop, toEditable, toFullRepaintOnResize, toGridExtensions, toInitOnSave, toWheelPanning, toEditOnClick, toEditOnDblClick] TreeOptions.PaintOptions = [toShowButtons, toShowDropmark, toShowHorzGridLines, toShowVertGridLines, toThemeAware, toUseBlendedImages, toAlwaysHideSelection] TreeOptions.SelectionOptions = [toExtendedFocus, toMultiSelect, toRightClickSelect] Visible = False @@ -1489,12 +1518,14 @@ object MainForm: TMainForm OnMouseWheel = AnyGridMouseWheel OnNewText = AnyGridNewText OnStartOperation = AnyGridStartOperation + Touch.InteractiveGestures = [igPan, igPressAndTap] + Touch.InteractiveGestureOptions = [igoPanSingleFingerHorizontal, igoPanSingleFingerVertical, igoPanInertia, igoPanGutter, igoParentPassthrough] Columns = <> end object tabsetQuery: TTabSet Left = 0 Top = 100 - Width = 796 + Width = 684 Height = 24 Align = alTop DitherBackground = False @@ -1529,7 +1560,7 @@ object MainForm: TMainForm object ControlBarMain: TControlBar Left = 0 Top = 0 - Width = 977 + Width = 865 Height = 26 Align = alTop AutoSize = True @@ -1537,275 +1568,10 @@ object MainForm: TMainForm BevelOuter = bvNone BevelKind = bkNone TabOrder = 4 - object imgDonate: TImage - Left = 810 - Top = 2 - Width = 129 - Height = 22 - Cursor = crHandPoint - Picture.Data = { - 07544269746D6170D61F0000424DD61F00000000000036000000280000007A00 - 0000160000000100180000000000A01F0000C40E0000C40E0000000000000000 - 00009FAFA50C1D12030D06030D06030D06030D06030D06030D06030D06030D06 - 030D06030D06030D06030D06030D06030D06030D06030D06030D06030D06030D - 06030D06030D06030D06030D06030D06030D06030D06030D06030D06030D0603 - 0D06030D06030D06030D06030D06030D06030D06030D06030D06030D06030D06 - 030D06030D06030D06030D06030D06030D06030D06030D06030D06030D06030D - 06030D06030D06030D06030D06030D06030D06030D06030D06030D06030D0603 - 0D06030D06030D06030D06030D06030D06030D06030D06030D06030D06030D06 - 030D06030D06030D06030D06030D06030D06030D06030D06030D06030D06030D - 06030D06030D06030D06030D06030D06030D06030D06030D06030D06030D0603 - 0D06030D06030D06030D06030D06030D06030D06030D06030D06030D06030D06 - 030D06030D06030D06030D06030D06030D06030D06030D06030D06030D06030D - 06030D06030D06030D060F2015AEBBB3D5FF07140B0000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000000000000000000000000000000000000000000F2116 - 43FF000000000100003916005B24005B24005B24005B24005B24005B24005B24 - 005B24005B24005B24005B24005B24005B24005B24005B24005B24005B24005B - 24005B24005B24005B24005B24005B24005B24005B24005B24005B24005B2400 - 5B24005B24005B24005B24005B24005B24005B24005B24005B24005B24005B24 - 005B24005B24005B24005B24005B24005B24005B24005B24005B24005B24005B - 24005B24005B24005B24005B24005B24005B24005B24005B24005B24005B2400 - 5B24005B24005B24005B24005B24005B24005B24005B24005B24005B24005B24 - 005B24005B24005B24005B24005B24005B24005B24005B24005B24005B24005B - 24005B24005B24005B24005B24005B24005B24005B24005B24005B24005B2400 - 5B24005B24005B24005B24005B24005B24005B24005B24005B24005B24005B24 - 005B24005B24005B24005B24005B24005B24005B24005B24005B24005B24005B - 24005B24005B24003214000000030D0643FF00000000010000662900A44200A4 - 4200A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200 - A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200A442 - 00A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200A4 - 4200A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200 - A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200A442 - 00A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200A4 - 4200A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200 - A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200A442 - 00A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200A4 - 4200A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200 - A44200A44200A44200A44200A44200A44200A44200A442005A24000000030D06 - F9FF00000000010000672900A64200A64200A64200A64200A64200A64200A642 - 00A64200A64200A64200A64200A64200A64200A64200A64200A64200A64200A6 - 4200A64200A64200A64200A64200A64200A64200A64200A64200A6420FAB4D1C - AF571CAF571CAF571CAF5718AE540FAB4D03A74400A64200A64200A64200A642 - 00A64200A64200A6420AA94A19AE541CAF5718AE530BA94A01A64200A64200A6 - 4200A6420FAB4D1CAF5715AD5101A64300A64200A64209A9491CAF5719AE5502 - A64300A64200A64207A84817AE531CAF5714AD5104A74513AC501CAF5709A948 - 00A64200A64200A64209A9491AAE551CAF5710AB4E00A64200A64200A64205A7 - 4513AC501CAF561CAF5716AD520DAA4C01A64300A64200A64200A64200A64200 - A64200A64200A64200A64200A64200A64200A64200A64200A64200A64200A642 - 00A64200A64200A64200A64200A64200A64200A64200A64200A64200A64200A6 - 4200A64200A642005B24000000030D0669FF00000000010000682900A64300A6 - 4300A64300A64300A64300A64300A64300A64300A64300A64300A64300A64300 - A64300A64300A64300A64300A64300A64300A64300A64300A64300A64300A643 - 00A64300A64300A64300A643AAE1C0FFFFFFFFFFFFFFFFFFFFFFFFF2FAF5D2EF - DD9EDDB736B96A02A74400A64300A64300A64306A8475BC686C2EAD2F2FAF5FF - FFFFEFF9F3C1E9D158C48305A84600A64300A643A0DEB9FEFFFED4F0DF0FAB4D - 00A64300A6436CCC93FFFFFFEFF9F316AD5300A6431FB15AABE2C1EDF9F2FEFF - FEE2F5EA8AD6A8C7EBD5FDFEFE61C88A00A64300A64320B15AB6E5C9F5FBF8FF - FFFFD4F0DF0EAB4D00A6432AB461A3DFBBDFF4E7FDFEFDFEFFFEEAF7EFCBEDD9 - 5DC68700A64300A64300A64300A64300A64300A64300A64300A64300A64300A6 - 4300A64300A64300A64300A64300A64300A64300A64300A64300A64300A64300 - A64300A64300A64300A64300A64300A64300A64300A643005C24000000030D06 - 56FF00000000010000682900A74300A74300A74300A74300A74300A74300A743 - 00A74300A74300A74300A74300A74300A74300A74300A74300A74300A74300A7 - 4300A74300A74300A74300A74300A74300A74300A74300A74300A743BEE9CFFF - FFFFF9FDFADBF3E4D7F1E2E0F4E8F7FCF9FFFFFFF4FBF764C98C02A84500A743 - 01A84468CB8FFDFEFDFEFFFEEBF8F0D9F2E3E6F7EDFEFFFEF6FCF86ACB9102A8 - 4400A743B2E4C6FFFFFFE3F5EA12AD5000A74300A7437CD29FFFFFFFF6FCF81A - B05606A948A9E1BFFFFFFFF9FDFBDBF3E4DFF4E8F8FDFAFEFEFEFFFFFF6DCC93 - 00A74300A74396DAB1FFFFFFFEFFFEDEF4E7E2F5E91BB0561BB057E1F4E8FFFF - FFF8FDFADDF3E6D7F1E2DEF4E7EEF9F29EDEB700A74300A74300A74300A74300 - A74300A74300A74300A74300A74300A74300A74300A74300A74300A74300A743 - 00A74300A74300A74300A74300A74300A74300A74300A74300A74300A74300A7 - 4300A74300A743005C25000000030D0644FF00000000010000692A00A94400A9 - 4400A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400 - A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A944 - 00A94400A94400A94400A944BEE9CFFFFFFFD5F1E016B05300A94413AF5152C4 - 80DDF3E6FFFFFFF7FCF940BE7200A9440EAD4EE4F6EBFFFFFFD8F2E22DB86503 - AA4622B45CBDE8CEFFFFFFE2F5E922B45C00A944B2E5C6FFFFFFE3F5EA12AF51 - 00A94400A9447CD39FFFFFFFF6FCF81AB15711AE50DFF4E7FFFFFFA2DFBA08AB - 4911AF507ED3A0FFFFFFFFFFFF6DCD9300A94400A944CFEEDBFFFFFFD1EFDD12 - AF5116B05401A94481D4A2FFFFFFF8FDFA69CC910CAD4D00A9440FAE4F31B967 - 30B96700A94400A94400A94400A94400A94400A94400A94400A94400A94400A9 - 4400A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400 - A94400A94400A94400A94400A94400A94400A94400A944005D25000000030D06 - 45FF00000000010000692A00A94400A94400A94400A94400A94400A94400A944 - 00A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A9 - 4400A94400A94400A94400A94400A94400A94400A94400A94400A944BEE9CFFF - FFFFD5F1E016B05400A94400A94400A94443BF75F8FDFAFFFFFFB6E6C900A944 - 31B967FFFFFFFFFFFF7AD29D00A94400A94400A9444AC27AFEFFFEFFFFFF57C6 - 8400A944B2E5C6FFFFFFE3F6EA12AF5100A94400A9447CD39FFFFFFFF6FCF81A - B2570CAD4DCEEEDBFFFFFFD3F0DF56C68333BA6964CB8DFFFFFFFFFFFF6DCD93 - 01A94402AA45DFF4E7FFFFFFACE3C209AC4A06AB4808AC4AC0E9D0FFFFFFD8F2 - E20BAD4C07AB4906AB4906AB4805AB4804AB4704AA4703AA4601AA4500A94400 - A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A944 - 00A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A9 - 4400A94400A944005D25000000030D0676FF000000000100006A2A00AA4400AA - 4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400 - AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA44 - 00AA4400AA4400AA4400AA44BEE9CFFFFFFFD5F1E016B15400AA4400AA4400AA - 4402AB46CBEED9FFFFFFF6FCF80BAE4C48C278FFFFFFFFFFFF62CB8C00AA4400 - AA4400AA442DB965F0FAF4FFFFFF71CF9600AA44B2E5C6FFFFFFE3F6EA12B051 - 00AA4400AA447CD49FFFFFFFF6FCF81DB45A07AD4960CA8AF0FAF4FFFFFFFFFF - FFFFFFFFFFFFFFFFFFFFFFFFFF86D7A62FB96631BA68E5F6ECFFFFFFBCE9CE3A - BD6E38BD6D3ABD6EE3F5EAFFFFFFF1FAF4BFEAD0BFE9D0BFE9D0BEE9CFBDE9CE - A6E1BD42C07433BB6931BA672EB9652BB86328B76123B55D1EB45A19B25614B0 - 520FAF4E0BAE4C08AD4A06AC4802AB4600AA4400AA4400AA4400AA4400AA4400 - AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA44005E25000000030D06 - 75FF000000000100006A2B00AB4500AB4500AB4500AB4500AB4500AB4500AB45 - 00AB4500AB4500AB4500AB4500AB4500AB4500AB4500AB4500AB4500AB4500AB - 4500AB4500AB4500AB4500AB4500AB4500AB4500AB4500AB4500AB45BEEACFFF - FFFFD5F1E116B25500AB4500AB4500AB4500AB4597DDB3FFFFFFFEFFFE2AB963 - 3DBF71FFFFFFFFFFFF68CD9000AB4500AB4500AB4535BD6BF8FDFAFFFFFF6FCF - 9600AB45B2E5C6FFFFFFE4F6EB1BB4580FB04F17B2558CD9ABFFFFFFF7FCFA49 - C37A38BD6D3EBF7166CC8F9DDFB8C2EBD3D1F0DDDCF3E5FFFFFFFFFFFF92DBAF - 42C07542C075E7F7EDFFFFFFC0EAD144C17742C07544C176D6F1E1FFFFFFFFFF - FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF1FAF563CB8D42C07542C07542C07542 - C07542C07542C07542C07542C07542C07541C0743EBF723ABE6F37BD6D33BB6A - 2DB96525B75F1DB45A14B1530DAF4E08AE4B04AC4700AB4500AB4500AB4500AB - 4500AB4500AB45005E26000000030D0646FF000000000100006B2B00AC4500AC - 4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500 - AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC45 - 00AC4500AC4500AC4500AC45BEEACFFFFFFFD5F1E116B35500AC4500AC4500AC - 4500AC4590DBADFFFFFFFEFFFE39BE6E14B353F3FBF6FFFFFFA4E1BD05AE4800 - AC4501AD466ED095FFFFFFFEFFFE5CCA881CB559BCE9CEFFFFFFF4FBF765CC8E - 40C17442C175B5E7C9FFFFFFF7FDFA50C67F42C17550C67F5FCB8A43C27642C1 - 7542C17573D198FFFFFFFFFFFF82D6A442C17542C175E7F7EDFFFFFFC0EAD144 - C27742C17543C175B3E6C8FFFFFFE7F7ED74D29970D09770D097ADE4C3FFFFFF - E7F7EE58C88542C17542C17542C17542C17542C17542C17542C17542C17542C1 - 7542C17542C17542C17542C17542C17542C17542C17542C17542C1753FC0733A - BF6F35BD6C2EBB6623B75E18B4560FB15008AF4B01AD46005F26000000030D06 - 46FF000000000100006C2B00AD4600AD4600AD4600AD4600AD4600AD4600AD46 - 00AD4600AD4600AD4600AD4600AD4600AD4600AD4600AD4600AD4600AD4600AD - 4600AD4600AD4600AD4600AD4600AD4600AD4600AD4600AD4600AD46BEEAD0FF - FFFFD5F1E116B45500AD4600AD4600AD4600AD4696DDB2FFFFFFFEFFFE33BD6A - 03AE4896DDB3FFFFFFF6FCF88EDAAC4FC67F7BD49FE8F7EEFFFFFFDFF5E854C8 - 8242C275C5ECD5FFFFFFFFFFFFE5F6EC8BDAAB90DBAEF4FBF7FFFFFFDEF4E742 - C27542C27590DBAEECF9F1B2E6C77FD6A27ED5A1C7EDD6FFFFFFFBFEFC6DD094 - 4FC67F76D39BEEF9F2FFFFFFD2F1DE7AD49E77D39B44C3776ACF92FAFDFBFBFE - FCAFE5C47DD5A08AD9AAE0F5E8FFFFFFC3EBD345C37742C27542C27542C27542 - C27542C27542C27542C27542C27542C27542C27542C27542C27542C27542C275 - 42C27542C27542C27542C27542C27542C27542C27542C27542C27542C2753FC1 - 733ABF6F34BD6B186737000000030E0776FF000000000100006C2C00AE4600AE - 4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600 - AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE46 - 00AE4600AE4600AE4600AE46BEEAD0FFFFFFD5F2E116B55600AE4600AE4600AE - 4603AF48C9EED7FFFFFFFBFEFC14B4540BB14E2BBB65BFEAD0FDFEFEFFFFFFFF - FFFFFFFFFFFFFFFFE9F8EF7AD49E43C27542C275C5ECD5FFFFFFC4ECD4E3F6EA - FFFFFFFFFFFFFFFFFFF7FDF986D8A742C27542C2756DD095E6F7EDFFFFFFFFFF - FFFFFFFFFFFFFFFEFFFEBEEAD04BC57B7ED5A1FDFEFEFFFFFFFFFFFFFFFFFFFF - FFFFFEFFFE56C88443C27695DDB2F5FCF7FFFFFFFFFFFFFFFFFFFFFFFFDBF3E5 - 63CD8D42C27542C27542C27542C27542C27542C27542C27542C27542C27542C2 - 7542C27542C27542C27542C27542C27542C27542C27542C27542C27542C27542 - C27542C27542C27542C27542C27542C27542C27542C275246B41000000060E09 - 76FF000000000100006D2C00AF4600AF4600AF4600AF4600AF4600AF4600AF46 - 00AF4600AF4600AF4600AF4600AF4600AF4600AF4600AF4600AF4600AF4600AF - 4600AF4600AF4600AF4600AF4600AF4600AF4600AF4600AF4600AF46BEEBD0FF - FFFFD5F2E116B65600AF4600AF4600AF4646C578F7FCF9FFFFFFCDEFDB35BF6C - 3DC27141C3754AC67B79D59DA9E4C0C0EBD1B8E9CB92DDAF5CCC8843C37642C3 - 7542C37589DAA9BFEBD077D49C58CA8593DDB0BFEBD0B3E7C872D29845C47742 - C37542C37543C37657CA8488D9A8B5E8C9C0EBD1AFE6C483D8A44EC77E42C375 - 64CE8EBCEACEF7FCF9FFFFFFEAF8F0C1ECD2BDEACF4AC67B42C37544C47768CF - 91A2E2BBC0EBD1B9E9CC8EDBAC57CA8542C37542C37542C37542C37542C37542 - C37542C37542C37542C37542C37542C37542C37542C37542C37542C37542C375 - 42C37542C37542C37542C37542C37542C37542C37542C37542C37542C37542C3 - 7542C37542C375246B41000000060F0947FF000000000100006E2C00B04700B0 - 4700B04700B04700B04700B04700B04700B04700B04700B04700B04700B04700 - B04700B04700B04700B04700B04700B04700B04700B04700B04700B04700B047 - 00B04700B04700B04700B047BEEBD0FFFFFFD5F2E116B75601B0471CB95B60CE - 8CE2F6EAFFFFFFFDFEFD76D49C42C47642C47642C47642C47642C47642C47642 - C47642C47642C47642C47642C47642C47642C47642C47642C47642C47642C476 - 42C47642C47642C47642C47642C47642C47642C47642C47642C47642C47642C4 - 7642C47642C47642C47642C47642C47642C47642C476E7F7EDFFFFFFC0EBD244 - C57842C47642C47642C47642C47642C47642C47642C47642C47642C47642C476 - 42C47642C47642C47642C47642C47642C47642C47642C47642C47642C47642C4 - 7642C47642C47642C47642C47642C47642C47642C47642C47642C47642C47642 - C47642C47642C47642C47642C47642C47642C47642C476246C41000000060F09 - E9FF000000000100006E2C00B14700B14700B14700B14700B14700B14700B147 - 00B14700B14700B14700B14700B14700B14700B14700B14700B14700B14700B1 - 4700B14700B14700B14700B14700B14700B14700B14700B14700B147BEEBD0FF - FFFFF9FDFBE0F5E9DDF5E7E7F8EEF9FDFBFFFFFFF8FDFA97DFB344C57742C576 - 42C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642C5 - 7642C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642 - C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642C576 - 42C57642C576DBF4E5FFFFFFB8E9CC44C67742C57642C57642C57642C57642C5 - 7642C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642 - C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642C576 - 42C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642C5 - 7642C57642C576246C41000000060F0976FF000000000100006F2C00B24700B2 - 4700B24700B24700B24700B24700B24700B24700B24700B24700B24700B24700 - B24700B24700B24700B24700B24700B24700B24700B24700B24700B24700B247 - 00B24700B24700B24706B44BB2E8C7FFFFFFFFFFFFFFFFFFFFFFFFF9FDFBE3F6 - EAB8E9CC6AD29344C67842C57642C57642C57642C57642C57642C57642C57642 - C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642C576 - 42C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642C5 - 7642C57642C57642C57642C57642C57642C57642C57651CA8157CC864EC97F42 - C57742C57642C57642C57642C57642C57642C57642C57642C57642C57642C576 - 42C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642C5 - 7642C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642 - C57642C57642C57642C57642C57642C57642C57642C576246D41000000060F09 - 77FF000000000100006F2D00B34800B34800B34800B34800B34800B34800B348 - 00B34800B34800B34800B34800B34800B34800B34800B34800B34800B34800B3 - 4800B34800B34800B34800B34800B34801B3490FB75227BE643CC4724AC97D53 - CB8353CB8353CB8353CB8351CB824CC97F44C77942C67742C67742C67742C677 - 42C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742C6 - 7742C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742 - C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742C677 - 42C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742C6 - 7742C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742 - C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742C677 - 42C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742C6 - 7742C67742C677246D42000000060F0A00FF00000000010000461C00702D0070 - 2D00702D00702D00702D00702D00702D00702D00702D00702D00702D00702D00 - 702D00702D00702D00702D00702D00702D00702D00702D00702D00712D057231 - 19783F277C49297C4A297C4B297C4B297C4B297C4B297C4B297C4B297C4B297C - 4B297C4B297C4B297C4B297C4B297C4B297C4B297C4B297C4B297C4B297C4B29 - 7C4B297C4B297C4B297C4B297C4B297C4B297C4B297C4B297C4B297C4B297C4B - 297C4B297C4B297C4B297C4B297C4B297C4B297C4B297C4B297C4B297C4B297C - 4B297C4B297C4B297C4B297C4B297C4B297C4B297C4B297C4B297C4B297C4B29 - 7C4B297C4B297C4B297C4B297C4B297C4B297C4B297C4B297C4B297C4B297C4B - 297C4B297C4B297C4B297C4B297C4B297C4B297C4B297C4B297C4B297C4B297C - 4B297C4B297C4B297C4B297C4B297C4B297C4B297C4B297C4B297C4B297C4B29 - 7C4B297C4B297C4B297C4B297C4B297C4B297C4B297C4B164529000000060F0A - 4BFF051209000000000100000100000100000100000100000100000100000100 - 0001000001000001000001000001000001000001000001000001000001000001 - 0000010000010000010000010100010100010100010100010100010100010100 - 0101000101000101000101000101000101000101000101000101000101000101 - 0001010001010001010001010001010001010001010001010001010001010001 - 0100010100010100010100010100010100010100010100010100010100010100 - 0101000101000101000101000101000101000101000101000101000101000101 - 0001010001010001010001010001010001010001010001010001010001010001 - 0100010100010100010100010100010100010100010100010100010100010100 - 0101000101000101000101000101000101000101000101000101000101000101 - 0001010001010001010001010001010001010001010001010001010001010001 - 0100010100010100010000000013221901FF95A79C06130A0000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000000000000000000000000000000000000D1912A8B4AE - 00FF} - OnClick = DonateClick - end object ToolBarMainButtons: TToolBar Left = 11 Top = 2 - Width = 786 + Width = 896 Height = 22 Align = alNone AutoSize = True @@ -2009,6 +1775,33 @@ object MainForm: TMainForm Action = actCancelOperation end end + object ToolBarDonate: TToolBar + Left = 863 + Top = 2 + Width = 67 + Height = 22 + Align = alNone + AutoSize = True + ButtonWidth = 67 + Caption = 'Donate' + EdgeInner = esNone + EdgeOuter = esNone + Images = VirtualImageListMain + List = True + ShowCaptions = True + TabOrder = 1 + Wrapable = False + object btnDonate: TToolButton + Left = 0 + Top = 0 + Hint = + 'Send an arbitrary amount as donation to the author - per PayPal ' + + '(also supports credit cards)' + Caption = 'Donate' + ImageIndex = 185 + OnClick = DonateClick + end + end end object MainMenu1: TMainMenu AutoHotkeys = maManual @@ -2034,6 +1827,9 @@ object MainForm: TMainForm object Closetab1: TMenuItem Action = actCloseQueryTab end + object Closeallquerytabs1: TMenuItem + Action = actCloseAllQueryTabs + end object N2: TMenuItem Caption = '-' end @@ -2069,15 +1865,36 @@ object MainForm: TMainForm object MainMenuEdit: TMenuItem Caption = 'Edit' Hint = 'Edit commands' + object Undo1: TMenuItem + Action = actUndo + end object CopyItem: TMenuItem Action = actCopy end + object Copyformattedtext1: TMenuItem + Action = actCopyFormatted + end + object Copywithtabstospaces1: TMenuItem + Action = actCopyTabsToSpaces + end + object Copycolumnnames1: TMenuItem + Action = actCopyColumnNames + end + object actCopyGridNodes1: TMenuItem + Action = actCopyGridNodes + end object PasteItem: TMenuItem Action = actPaste end object Cut1: TMenuItem Action = actCut end + object Movelinedown1: TMenuItem + Action = actSynMoveDown + end + object Movelineup1: TMenuItem + Action = actSynMoveUp + end object N13: TMenuItem Caption = '-' end @@ -2087,10 +1904,39 @@ object MainForm: TMainForm object Inverseselection1: TMenuItem Action = actSelectInverse end - object actFindInVT1: TMenuItem + end + object MainMenuDisplay: TMenuItem + Caption = 'Display' + object menuDisplaysizeofobjects1: TMenuItem + Action = actDisplayObjectSize + AutoCheck = True + end + object menuShowonlyfavorites1: TMenuItem + Action = actFavoriteObjectsOnly + AutoCheck = True + end + object menuFilterpanel1: TMenuItem Action = actFilterPanel AutoCheck = True end + object menuDisplayLogPanel1: TMenuItem + Action = actDisplayLogPanel + AutoCheck = True + end + object menuTreefilters1: TMenuItem + Action = actDisplayTreeFilters + AutoCheck = True + end + object menuTreeShowColumns1: TMenuItem + Action = actTreeShowColumns + AutoCheck = True + end + object N27: TMenuItem + Caption = '-' + end + object menuResetpaneldimensions1: TMenuItem + Action = actResetPanelDimensions + end end object MainMenuSearch: TMenuItem Caption = 'Search' @@ -2115,6 +1961,9 @@ object MainForm: TMainForm object Closequerytab1: TMenuItem Action = actCloseQueryTab end + object Renametab1: TMenuItem + Action = actRenameQueryTab + end object Clear1: TMenuItem Action = actClearQueryEditor end @@ -2163,6 +2012,9 @@ object MainForm: TMainForm object Uncomment2: TMenuItem Action = actToggleComment end + object menuEditorCommands: TMenuItem + Caption = 'Editor commands' + end object Folding1: TMenuItem Caption = 'Code folding' object Codefolding1: TMenuItem @@ -2185,24 +2037,9 @@ object MainForm: TMainForm object Explaincurrentquery2: TMenuItem Action = actExplainCurrentQuery end - object Explainanalyzerforcurrentquery2: TMenuItem - Action = actExplainAnalyzeCurrentQuery - end end object MainMenuTools: TMenuItem Caption = 'Tools' - object Previoustab1: TMenuItem - Action = actPreviousTab - end - object Nexttab1: TMenuItem - Action = actNextTab - end - object Previousresulttab1: TMenuItem - Action = actPreviousResult - end - object Nextresulttab1: TMenuItem - Action = actNextResult - end object Flush1: TMenuItem Caption = 'Flush' object MenuFlushHosts: TMenuItem @@ -2236,9 +2073,15 @@ object MainForm: TMainForm object Bulktableeditor1: TMenuItem Action = actBulkTableEdit end + object Generatedata1: TMenuItem + Action = actGenerateData + end object Launchcommandline1: TMenuItem Action = actLaunchCommandline end + object SequalSuggest1: TMenuItem + Action = actSequalSuggest + end object N7: TMenuItem Caption = '-' end @@ -2266,6 +2109,21 @@ object MainForm: TMainForm end object MainMenuGoto: TMenuItem Caption = 'Go to' + object Previoustab1: TMenuItem + Action = actPreviousTab + end + object Nexttab1: TMenuItem + Action = actNextTab + end + object Previousresulttab1: TMenuItem + Action = actPreviousResult + end + object Nextresulttab1: TMenuItem + Action = actNextResult + end + object N16: TMenuItem + Caption = '-' + end object actGotoFilter1: TMenuItem Action = actGotoFilter end @@ -2352,6 +2210,14 @@ object MainForm: TMainForm ImageName = 'icons8-close-button' OnExecute = actExitApplicationExecute end + object actFollowForeignKey: TAction + Category = 'Various' + Caption = 'Follow Foreign Key' + Enabled = False + Hint = 'Follow foreign key to the linked table' + ImageIndex = 136 + OnExecute = actFollowForeignKeyExecute + end object actCopy: TAction Category = 'Various' Caption = '&Copy' @@ -2360,6 +2226,7 @@ object MainForm: TMainForm ImageName = 'icons8-copy-100' ShortCut = 16451 OnExecute = actCopyOrCutExecute + OnUpdate = actCopyUpdate end object actPaste: TAction Category = 'Various' @@ -2391,10 +2258,18 @@ object MainForm: TMainForm Category = 'Various' Caption = '&Undo' Enabled = False + Hint = 'Undo|Revert last modification' ImageIndex = 40 ImageName = 'icons8-undo' ShortCut = 32776 end + object actCopyTabsToSpaces: TAction + Category = 'Various' + Caption = 'Copy with tabs to spaces' + ImageIndex = 3 + ShortCut = 24643 + OnExecute = actCopyTabsToSpacesExecute + end object actAboutBox: TAction Category = 'Various' Caption = 'About...' @@ -2483,12 +2358,6 @@ object MainForm: TMainForm Hint = 'Run EXPLAIN and show results' OnExecute = actExecuteQueryExecute end - object actExplainAnalyzeCurrentQuery: TAction - Category = 'SQL' - Caption = 'Explain analyzer for current query' - Hint = 'Run EXPLAIN and send results to MariaDB.org' - OnExecute = actExplainAnalyzeCurrentQueryExecute - end object actDataPreview: TAction Category = 'Data' Caption = 'Image preview' @@ -2962,10 +2831,10 @@ object MainForm: TMainForm OnExecute = actSelectAllExecute OnUpdate = ValidateControls end - object actCreateRoutine: TAction + object actCreateProcedure: TAction Category = 'Database' - Caption = 'Stored routine' - Hint = 'Create stored routine|Create stored procedure or function' + Caption = 'Stored procedure' + Hint = 'Create stored procedure' ImageIndex = 119 ImageName = 'icons8-source-code-other' OnExecute = actCreateDBObjectExecute @@ -2979,6 +2848,11 @@ object MainForm: TMainForm ShortCut = 16468 OnExecute = actNewQueryTabExecute end + object actNewQueryTabNofocus: TAction + Category = 'File' + Caption = 'New query tab in background' + OnExecute = actNewQueryTabExecute + end object actCloseQueryTab: TAction Category = 'File' Caption = 'Close query tab' @@ -3001,7 +2875,6 @@ object MainForm: TMainForm AutoCheck = True Caption = 'Filter panel' Hint = 'Activates the filter panel' - ImageIndex = 30 ImageName = 'icons8-find' ShortCut = 49222 OnExecute = actFilterPanelExecute @@ -3013,6 +2886,13 @@ object MainForm: TMainForm ImageName = 'icons8-sheets-100' OnExecute = actTableToolsExecute end + object actCreateFunction: TAction + Category = 'Database' + Caption = 'Stored function' + Hint = 'Create stored function' + ImageIndex = 35 + OnExecute = actCreateDBObjectExecute + end object actCreateTrigger: TAction Category = 'Database' Caption = 'Trigger' @@ -3153,12 +3033,11 @@ object MainForm: TMainForm ImageName = 'icons8-comments' OnExecute = actToggleCommentExecute end - object actSynchronizeDatabase: TAction - Category = 'Export/Import' - Caption = 'Synchronize database' - ImageIndex = 27 - ImageName = 'icons8-data-backup' - OnExecute = actSynchronizeDatabaseExecute + object actGenerateData: TAction + Category = 'Tools' + Caption = 'Generate data' + ImageIndex = 130 + OnExecute = actTableToolsExecute end object actLaunchCommandline: TAction Category = 'Tools' @@ -3200,7 +3079,7 @@ object MainForm: TMainForm AutoCheck = True Caption = 'Show only favorites' Hint = 'Show only favorite tree items' - ImageIndex = 112 + ImageIndex = 113 ImageName = 'icons8-star-filled' OnExecute = actFavoriteObjectsOnlyExecute end @@ -3284,15 +3163,6 @@ object MainForm: TMainForm ShortCut = 118 OnExecute = actGoToDataMultiFilterExecute end - object actCopyRows: TAction - Category = 'Various' - Caption = 'Copy selected rows' - Hint = 'Copy selected rows in custom format' - ImageIndex = 155 - ImageName = 'icons8-copy-rows' - ShortCut = 24643 - OnExecute = actCopyOrCutExecute - end object actDataOpenUrl: TAction Category = 'Data' Caption = 'Open URL' @@ -3345,35 +3215,35 @@ object MainForm: TMainForm end object actQuickFilterFocused3: TAction Category = 'Data' - Caption = 'Quick filter: Column > Focused' + Caption = 'Quick filter: Column LIKE Focused%' ImageIndex = 61 ImageName = 'icons8-sort-right' OnExecute = QuickFilterClick end object actQuickFilterFocused4: TAction Category = 'Data' - Caption = 'Quick filter: Column < Focused' + Caption = 'Quick filter: Column LIKE %Focused' ImageIndex = 61 ImageName = 'icons8-sort-right' OnExecute = QuickFilterClick end object actQuickFilterFocused5: TAction Category = 'Data' - Caption = 'Quick filter: Column LIKE Focused%' + Caption = 'Quick filter: Column LIKE %Focused%' ImageIndex = 61 ImageName = 'icons8-sort-right' OnExecute = QuickFilterClick end object actQuickFilterFocused6: TAction Category = 'Data' - Caption = 'Quick filter: Column LIKE %Focused' + Caption = 'Quick filter: Column > Focused' ImageIndex = 61 ImageName = 'icons8-sort-right' OnExecute = QuickFilterClick end object actQuickFilterFocused7: TAction Category = 'Data' - Caption = 'Quick filter: Column LIKE %Focused%' + Caption = 'Quick filter: Column < Focused' ImageIndex = 61 ImageName = 'icons8-sort-right' OnExecute = QuickFilterClick @@ -3499,6 +3369,111 @@ object MainForm: TMainForm ImageIndex = 122 OnExecute = actCodeFoldingFoldSelectionExecute end + object actConnectionProperties: TAction + Category = 'Tools' + Caption = 'Connection properties' + ImageIndex = 135 + OnExecute = actConnectionPropertiesExecute + end + object actRenameQueryTab: TAction + Category = 'File' + Caption = 'Rename query tab' + ImageIndex = 58 + OnExecute = actRenameQueryTabExecute + end + object actCloseAllQueryTabs: TAction + Category = 'File' + Caption = 'Close all query tabs' + Enabled = False + ImageIndex = 133 + OnExecute = actCloseAllQueryTabsExecute + end + object actSynMoveDown: TAction + Category = 'SQL' + Caption = 'Move line down' + ImageIndex = 75 + ShortCut = 32808 + OnExecute = actSynMoveDownExecute + end + object actSynMoveUp: TAction + Category = 'SQL' + Caption = 'Move line up' + ImageIndex = 74 + ShortCut = 32806 + OnExecute = actSynMoveUpExecute + end + object actSequalSuggest: TAction + Category = 'Tools' + Caption = 'Sequal Suggest' + ImageIndex = 206 + Visible = False + OnExecute = actSequalSuggestExecute + end + object actResetPanelDimensions: TAction + Category = 'Tools' + Caption = 'Reset panel dimensions' + Hint = 'Reset and fix overlapping panels in main window' + ImageIndex = 71 + OnExecute = actResetPanelDimensionsExecute + end + object actCopyGridNodes: TAction + Category = 'Various' + Caption = 'Copy all lines from listing or tree in CSV format' + ImageIndex = 3 + OnExecute = actCopyGridNodesExecute + end + object actQueryTable: TAction + Category = 'Database' + Caption = 'Select top 1000 rows' + Hint = 'Selects the first 1000 rows in a new query tab' + ImageIndex = 57 + OnExecute = actQueryTableExecute + end + object actDisplayObjectSize: TAction + Category = 'Various' + AutoCheck = True + Caption = 'Display size of objects' + OnExecute = actDisplayObjectSizeExecute + end + object actDisplayLogPanel: TAction + Category = 'Various' + AutoCheck = True + Caption = 'Log panel' + OnExecute = actDisplayLogPanelExecute + end + object actDisplayTreeFilters: TAction + Category = 'Various' + AutoCheck = True + Caption = 'Tree filters' + OnExecute = actDisplayTreeFiltersExecute + end + object actCopyColumnNames: TAction + Category = 'Various' + Caption = 'Copy column names' + ImageIndex = 3 + OnExecute = menuCopyColumnNamesClick + end + object actCopyFormatted: TAction + Category = 'Various' + Caption = 'Copy formatted text' + Hint = + 'Copies selected text with formatting from current editor to clip' + + 'board' + ImageIndex = 3 + OnExecute = actCopyFormattedExecute + end + object actDataEditWithoutLookup: TAction + Category = 'Data' + Caption = 'Edit value without foreign key lookup' + ImageIndex = 58 + OnExecute = actDataEditWithoutLookupExecute + end + object actTreeShowColumns: TAction + Category = 'Various' + AutoCheck = True + Caption = 'Columns below tables in tree' + OnExecute = actTreeShowColumnsExecute + end end object menuConnections: TPopupMenu AutoHotkeys = maManual @@ -3536,6 +3511,9 @@ object MainForm: TMainForm object menuEmptyTables: TMenuItem Action = actEmptyTables end + object Selecttop1000rows1: TMenuItem + Action = actQueryTable + end object Runroutines1: TMenuItem Action = actRunRoutines end @@ -3555,7 +3533,10 @@ object MainForm: TMainForm Action = actCreateView end object menuCreateRoutine: TMenuItem - Action = actCreateRoutine + Action = actCreateProcedure + end + object Storedfunction1: TMenuItem + Action = actCreateFunction end object menuCreateTrigger: TMenuItem Action = actCreateTrigger @@ -3565,7 +3546,7 @@ object MainForm: TMainForm end end object menuClearDataTabFilter: TMenuItem - Caption = 'Clear data tab filter' + Caption = 'Clear data tab filter and sort order' OnClick = menuClearDataTabFilterClick end object N17: TMenuItem @@ -3583,6 +3564,9 @@ object MainForm: TMainForm object menuBulkTableEdit: TMenuItem Action = actBulkTableEdit end + object Generatedata2: TMenuItem + Action = actGenerateData + end object N5a: TMenuItem Caption = '-' end @@ -3603,8 +3587,8 @@ object MainForm: TMainForm AutoCheck = True end object menuShowSizeColumn: TMenuItem - Caption = 'Display size of objects' - OnClick = menuShowSizeColumnClick + Action = actDisplayObjectSize + AutoCheck = True end object menuAutoExpand: TMenuItem Caption = 'Auto expand on click' @@ -3618,6 +3602,10 @@ object MainForm: TMainForm Action = actFavoriteObjectsOnly AutoCheck = True end + object menuTreeShowColumns2: TMenuItem + Action = actTreeShowColumns + AutoCheck = True + end end object menuPrint: TMenuItem Action = actPrintList @@ -3625,6 +3613,9 @@ object MainForm: TMainForm object menuRefreshDB: TMenuItem Action = actRefresh end + object Connectionproperties1: TMenuItem + Action = actConnectionProperties + end object Disconnect1: TMenuItem Action = actDisconnect end @@ -3665,13 +3656,6 @@ object MainForm: TMainForm ImageIndex = 39 OnClick = lblExplainProcessClick end - object menuExplainAnalyzer: TMenuItem - Caption = 'EXPLAIN analyzer on MariaDB.org' - Enabled = False - Hint = 'Pass EXPLAIN output to MariaDB'#39's analyzer webpage' - ImageIndex = 39 - OnClick = lblExplainProcessAnalyzerClick - end object N1a: TMenuItem Caption = '-' end @@ -3703,6 +3687,7 @@ object MainForm: TMainForm Top = 152 end object TimerHostUptime: TTimer + Interval = 20000 OnTimer = TimerHostUptimeTimer Left = 687 Top = 101 @@ -3716,8 +3701,9 @@ object MainForm: TMainForm object Copy3: TMenuItem Action = actCopy end - object Copyselectedrows1: TMenuItem - Action = actCopyRows + object menuCopyAs: TMenuItem + Caption = 'Copy as' + ImageIndex = 155 end object Paste2: TMenuItem Action = actPaste @@ -3737,6 +3723,9 @@ object MainForm: TMainForm ImageIndex = 28 OnClick = InsertValue end + object menuDataEditWithoutLookup: TMenuItem + Action = actDataEditWithoutLookup + end object N11: TMenuItem Caption = '-' end @@ -3806,6 +3795,16 @@ object MainForm: TMainForm ImageIndex = 112 OnClick = InsertValue end + object DataGUIDlowercase: TMenuItem + Caption = 'GUID lowercase' + ImageIndex = 112 + OnClick = InsertValue + end + object DataGUIDlowercaseWobraces: TMenuItem + Caption = 'GUID lowercase without braces' + ImageIndex = 112 + OnClick = InsertValue + end end object InsertfilesintoBLOBfields3: TMenuItem Action = actInsertFiles @@ -3833,6 +3832,9 @@ object MainForm: TMainForm object OpenURL1: TMenuItem Action = actDataOpenUrl end + object FollowForeignKey: TMenuItem + Action = actFollowForeignKey + end object N4a: TMenuItem Caption = '-' end @@ -4008,12 +4010,13 @@ object MainForm: TMainForm object TimerRefresh: TTimer Enabled = False Interval = 5000 - OnTimer = actRefreshExecute + OnTimer = TimerRefreshTimer Left = 688 Top = 197 end object popupListHeader: TVTHeaderPopupMenu Images = VirtualImageListMain + OnPopup = popupListHeaderPopup Left = 424 Top = 208 end @@ -4023,6 +4026,7 @@ object MainForm: TMainForm Width = 350 EndOfTokenChr = ',()[]. ='#9 TriggerChars = '.' + Title = ' ' Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText Font.Height = -11 @@ -4043,6 +4047,7 @@ object MainForm: TMainForm ItemHeight = 18 Images = VirtualImageListMain Margin = 1 + OnChange = SynCompletionProposalChange OnExecute = SynCompletionProposalExecute ShortCut = 0 Editor = SynMemoQuery @@ -4067,14 +4072,7 @@ object MainForm: TMainForm Action = actExecuteCurrentQuery end object menuQueryExplain: TMenuItem - Caption = 'Explain' - OnClick = menuQueryExplainClick - object Explaincurrentquery1: TMenuItem - Action = actExplainCurrentQuery - end - object Explainanalyzerforcurrentquery1: TMenuItem - Action = actExplainAnalyzeCurrentQuery - end + Action = actExplainCurrentQuery end object MenuItem1: TMenuItem Caption = '-' @@ -4139,6 +4137,9 @@ object MainForm: TMainForm object menuSQLhelp2: TMenuItem Action = actSQLhelp end + object SequalSuggest2: TMenuItem + Action = actSequalSuggest + end object menuQueryInsertFunction: TMenuItem Caption = 'Insert function' ImageIndex = 13 @@ -4148,12 +4149,11 @@ object MainForm: TMainForm Images = VirtualImageListMain Left = 344 Top = 152 - object menuInsertSnippetAtCursor: TMenuItem + object menuInsertAtCursor: TMenuItem Caption = 'Insert at cursor' Default = True - Enabled = False ImageIndex = 52 - OnClick = menuInsertSnippetAtCursorClick + OnClick = menuInsertAtCursorClick end object menuLoadSnippet: TMenuItem Caption = 'Load' @@ -4161,6 +4161,12 @@ object MainForm: TMainForm ImageIndex = 52 OnClick = menuLoadSnippetClick end + object menuRenameSnippet: TMenuItem + Caption = 'Rename' + Enabled = False + ImageIndex = 58 + OnClick = menuRenameSnippetClick + end object menuDeleteSnippet: TMenuItem Caption = 'Delete ...' Enabled = False @@ -4180,6 +4186,7 @@ object MainForm: TMainForm object menuClearQueryHistory: TMenuItem Caption = 'Clear query history ...' Enabled = False + ImageIndex = 26 OnClick = menuClearQueryHistoryClick end object menuQueryHelpersGenerateSelect: TMenuItem @@ -4209,6 +4216,7 @@ object MainForm: TMainForm end object popupFilter: TPopupMenu Images = VirtualImageListMain + OnPopup = popupFilterPopup Left = 344 Top = 248 object menuFilterCopy: TMenuItem @@ -4265,10 +4273,41 @@ object MainForm: TMainForm object menuNewQueryTab: TMenuItem Action = actNewQueryTab end - object menuCloseTab: TMenuItem + object menuCloseQueryTab: TMenuItem Caption = 'Close query tab' ImageIndex = 133 - OnClick = menuCloseQueryTab + OnClick = menuCloseQueryTabClick + end + object menuCloseRightQueryTabs: TMenuItem + Caption = 'Close query tabs to the right' + ImageIndex = 133 + OnClick = menuCloseRightQueryTabsClick + end + object actCloseAllQueryTabs1: TMenuItem + Action = actCloseAllQueryTabs + end + object N25: TMenuItem + Caption = '-' + end + object menuRenameQueryTab: TMenuItem + Caption = 'Rename tab' + ImageIndex = 58 + OnClick = menuRenameQueryTabClick + end + object menuCloseTabOnDblClick: TMenuItem + AutoCheck = True + Caption = 'Close tab on doubleclick' + OnClick = menuCloseTabOnDblClickClick + end + object menuCloseTabOnMiddleClick: TMenuItem + AutoCheck = True + Caption = 'Close tab on middleclick' + OnClick = menuCloseTabOnMiddleClickClick + end + object menuTabsInMultipleLines: TMenuItem + AutoCheck = True + Caption = 'Tabs in multiple lines' + OnClick = menuTabsInMultipleLinesClick end end object TimerFilterVT: TTimer @@ -6447,23 +6486,24 @@ object MainForm: TMainForm SourceImages = < item Image.Data = { - 89504E470D0A1A0A0000000D494844520000005E0000005E040300000058FCBE - 5D00000015504C5445FFFFFF00000000ADC500ACC000ABC1009FBF00ACC122A0 - AABA0000000674524E53000016D5B70835C94844000000097048597300000EC4 - 00000EC401952B0E1B0000018B49444154588595985D4E84401006D113EC6CE2 - BBBA37D0C413A8EF267A020DF73F82C0C04C77CF3740F1682A55BB2B3FDD0C03 - 3CEE923C9EF59F2F1DFEFAFA84F8DBF842F8EBDBF82B031DFE368E3AA0F9493F - EA80E667BD0E487ED1EB80E4B35E0614BFEA6540F19B5E05045FF42A20F8AC7F - D78196CFFABF9F4F1968F9ACFF48DF32D0F0ABFE2B3DC840C36FFAA403912FFA - A40391AF7A1D08BCD1EB40E0AD5E063CEFF432E079AF5701C707BD0A383EEA45 - C0F28D5E042CDFEADB80E185BE0D185EE99B40E5A5BE09545EEB63A0F01D7D0C - 14BEA70F818DEFEA4360E3FB7A1F58F91DBD0FACFC9EDE0532BFAB7781CCEFEB - 6D60E10FF436B0F0477A1398F943BD09CCFCB1BE0626FE84BE0626FE8CBE042E - C3FD197D093C629E7E1EFC7DE9EF89FF5FF47CC0E71B3D9FF1F542AF477CBDD3 - FB09BE5FD1FB21BEDFD2FB397E5ED0E7117EDED1E7297E5ED37900CF1B749EC1 - F3129DC7F0BC47E7493CAFD27918CFDB749EC7FB02DD47F0BE43F729BCAFD17D - 10EF9B749FC5FB32DDC7F1BE4FDF27E0F715FDF721F0F807B76B509911661559 - 0000000049454E44AE426082} + 89504E470D0A1A0A0000000D4948445200000060000000600806000000E29877 + 38000000097048597300000B1300000B1301009A9C18000001E749444154789C + ED9D416E134114057B13CE42E0901C00E279811547010E0033CA0E73101216DD + 4A24A3B6B288085656498DA6ABA45EB754D5FEF6CABF14111111111111117941 + 76737B9BB94D59EA3E73FD93A51D9EF51CEFA8FB696EBBCB1FF54D199577FBC3 + AB696E9FA6A5DE3DBBF413E7FEEECBCF5787B3329AFCCCED1B25FE5188B97D1D + 2A427FF9B4F43C8E9032CACC27C74E4E9E7A3B7DAFE765EBF497C6CB6EA7CE45 + D93AD3D27EAD40F4E1FF63A8FE2C5B679AEB0D2D3AA7C7D075D93A4F49281BBF + 1F87161003180085161003180085161003180085161003180085161003180085 + 1610031800851610031800851610031800851610031800851610031800851610 + 0318008516100318008516100318008516100318008516100318008516100318 + 0085161003180085161003180085161003180085161003180085161003180085 + 1610031800851610031800851610031800851610031800851610031800851610 + 03180085161003180085161003180085161003D4EBA724043AD3527F97AD735C + D6B3D600F3107F5FDF76EB0DD0DE97ADD35747AD7585C9C7ABFABA8C405F1DB5 + C2D7BF2BA3D05746F5D551598BFCA57D196A8DD58308E91F7D72ECF4973F9CFC + 7FBF13B2B48BFE0BE425F6CBF43B8E772DEDC3106BAB44444444444444CA9AF8 + 0B3F293F102E7F2D520000000049454E44AE426082} end> end item @@ -8559,54 +8599,43 @@ object MainForm: TMainForm SourceImages = < item Image.Data = { - 89504E470D0A1A0A0000000D494844520000005E0000005E0806000000AAD2A3 - 6E000000017352474200AECE1CE90000000467414D410000B18F0BFC61050000 - 00097048597300000EC300000EC301C76FA8640000001874455874536F667477 - 617265007061696E742E6E657420342E312E35644758520000055A4944415478 - 5EEDDBBFAB1C6514C6F1082982A455AE60A190BFC056095A69A17005C146B030 - 608A1469FC038414824510C12682815B88DCBD1BAD2C630A0D7ACB44025AC444 - C132DE545710C6F3CC7DCF6477E7CCEFF3CE7BCECE7CE191607667673EC4BD9B - DDF5549665F312ECE41F1E3BF8F1D97C0EF30B0FF0C50FBFE67388EF13BE40BF - 959DCC1FBE3FF812BA4F7C5FF095E83C3FF87EE01BD1793EF07DC0B746E7D9C7 - B70FDF199D671BDF367C6F749E5D7CBBF083D17936F16DC2ABA1F3ECE1DB8357 - 47E7D9C2B705DF157DFFD6F7F9A4DF136707DF0E7C1FF4AF6E9EC9E710DF067C - 5F74CE217E7AF8A1E89C33FCB4F05AE89C23FC74F0DAE89C13FC34F0B1D03907 - F8E3C3C746E78CE38F0B3F163A67187F3CF8B1D139A3F8E3C0A742E70CE2C787 - 4F8DCE19C38F0B6F059D33841F0FDE1A3A67043F0EBC5574CE00BE3EBC75742E - 31BE2EBC17742E21BE1EBC37742E11BE0EBC57742E01FE7078EFE8DCC8F8C3E0 - B7059D1B11BF3FFCB6A17323E1F783DF56746E04FCEEF0DB8ECE45C6EF063F15 - 742E227E7BF8A9A17391F0DBC14F159D8B80DF0C3F75744E19BF1E7E465F4F11 - BF1A7E469753C297E167F4FA14F0CBF0337ABB06E2AFC3CFE8DD1A80FF047E46 - EF574FFC197E6883E1D18CDFAD9EE8B8EB3A3C9AF1DB35001D95E1D18C5FDF40 - 7424C3A3195F4E011D55C3A3197F3D2574540F8F66FC9314D151333C9A3ABE32 - 3A6A078F2680FFE68DDD73B44BB47DDA1DDA235A86BDBE7C373BBFFC207B69F9 - 51F6C2C167D9D38BEFE4EB6E818EDAC3A32DC427D4D3B47768B719B9ED5E5E5E - CC9E5B5CCB9E5ADC0CD7DC0E1D7583475B844F78AFD2F0275B846D3BFC97F0CC - E2FA1F6DD1517778E41C9FB0CED0AEAEE2290DC76C759DFDE091537C82D9A175 - 7E5AE9301C7B273C5C65FDE191337C80D0EE05A098C363D4E20F83474EF00902 - 4F2F31FFA46F0E8F55799DC3E191037C42E8F49CFEF0F1C3ECE8DFA3D2FE393E - 126F5FB1CFC3C397D2814786F10900AF5E2498CAFDF9F82F622977FCDFB178FB - 9ABD114E632D3A94123C32884F178ED7E99D5F322AC2E3F9FE74389D223A9422 - 3C32864F178DBF1C4920B55384C7DE0BA753448752864786F0E9A27BFD405586 - BF1D4EA7880E15011E19C0A70BC67B2F1244E394E1B173E1B4F2E85091E05162 - 7CBA58BCE12521342E02FCA5705A7974A888F028213E5D2CDE659410F2BD75E3 - EDCAD5C14BB75F9DF458B4FD705A7974A8C8F028113E5D6CE5AB99AFEF7D9343 - 6AF7CBDF87E2E3D1EE84D3CAA39B8E008F12E0D3C516EFA76F2E01FCA3705A79 - 74D391E0D1C8F8C2C5174B00BF864C371D111E8D854FF7912E9E373D78141B1F - B7A5FBE0E33A09009BD653CD6AB1F0033AEE834F8604807CD3F9E12AA58DBF82 - 8EE183690120DF273F7F9A2D7FFBB672752F27A5DBF3AEDFDD131F8F96E0E564 - 5D5AF81BE8D88B07572580568BF017A8CBE14CF3E85089E1D1507C011DC35730 - 048056F3FD964197FAE257A0F35E597E2821344E19FE305C65111DCA083CEA83 - 5F838E3D7FF08504D13865F80BE10A8BE85086E05157FC86E1CB46AF2DDF9730 - 6AA708FF3BADF433890E650C1E29E3EF2CBE7CB081D13845F8DD70556BD1A10C - C223357C3A061D8B00AE6D80D44E097E2F5C4D293A9451783418FF041D872284 - B3B4D69FBD7EFCD395CA49B71786CF5ACFE6D721641B1EF5C67F82CE1104BED0 - 84E75C094A73F76991BFD034469DF1CBE81C406831BF4DD6F82D32E4031EB5C6 - AF46E708064F3B7B014A733866E5D3CB6A7EE051237E33FA6A84B44BD378EAC1 - 31C4572F55F9824795F8DDD03902C3FBF61768873409B56EB80FEEDBFCAEE946 - FEE05109BF1FFA660488AF835CA695FE579CF06BFC3BFC1E6EB3F6DE4BD77CC2 - A3025F077DECFCC223803B444705FCBCB1979DFA1FF0491B3AB771EE65000000 - 0049454E44AE426082} + 89504E470D0A1A0A0000000D4948445200000060000000600806000000E29877 + 38000000097048597300000B1300000B1301009A9C180000044D49444154789C + ED9DBF6B1C4714C71F4AE4C265922EC6BDE552C4C4D5C1CE79E64057A4F09118 + BB514C48913AC8A8D92E1206E94638413A0C9939146370FC4BC44E2115214514 + AD4863F9FC0758B15DF857E11FB06B1B363C490862E924DF9D76DF78E77D6040 + 7082D37D3FBB6F67679F6E001886611886611886611886C991C92839ACA3A4AE + 97E3968EE2177A3949331D6BEF11B7EA513239B5140F80AF84AD745F3D4ACED5 + 97E3379987DE666CBCF754E39FB41F7C0B5F47C90255F05B4444C9BC5712F0C8 + A70E5D6F95A0C1979A4F597674DB11BFAEFF1D1F82A283471A7DD849BB310145 + A7BE9CDC7120E874FB3214DF86A2538FE2E7D441EBF665E819149DDD428082BF + 3F39D4016816C00248A10E40B30016400A75009A05B00052A803D02C80059042 + 1D8066012C8014EA00340B6001A45007A059000B20853A00CD02580029D40168 + 16C00248A10E40B30016400A75009A05B00052A803D02C800590421D8066012C + 8014EA00340B6001A45007A059000B20853A00CD02580029D4016816C00248A1 + 0E40B30016400A75009A05B82FA076A9F68168AAA38155A38195578495778491 + 4F8555AFD606FE6C640B5FC3DF299BCAE76118F6C1FB80CB02C6FFBA9F0AA3C6 + 8591F784556947C3C87F03ABC64AB39503E0322E0A38BBF830FD7AAE9E969B43 + 9D85BECD088C4C8495D3A50BD54FC0455C13F0FDC27C5A993DDE73F05B45A8C7 + 8139F615B8862B0226A397E9F0F5893D0F7E9BD23433D81874E7BB885C1030B1 + F42C3D717934FBF03787BC596D54F7830B500B988C5EE61CFEE6B561A176A9B6 + 0F7C17309C47D9697F264C83CF028491273B0D6D373A96D0945F828F0244537C + 2C8C7C442D20B0EA09E914954A406055A39BB2B1E767C0FAF5E027F0494069B6 + 7260FD06C9190149B9593E08BE0810B8BCD0E585330B011BA5680C7C10108661 + 1FAED3B82600D79B70D10F8A2E4034D5D1AE43CA52C0DA59208F40D10504568D + BA2AA06CE41928FC1960E4D55E02EE959DCB90FA153C10D072554060E50A7850 + 829EB82A006F0CA1F002CCCEF37F4A01819531E40D0B509E09B05C82FE077E41 + F66E12F41E8E2F2E7E93BA2A80E8221CB7F21470EA4AE8AC00926928EE5E94A7 + 80EF7EFFA5A79BA59E02DE6504568EE42E00B78ECA730B93F0CF156705889F2B + 9F0105B875546E674114A743174E3A272030EA2E59371D6E19855B47E99C247C + 7BE3BC8302E40F24E1BF2541E3EE45590B185B7CD075D75B160270FE1FD8A14F + C105A696E201DCBD0837D0C9727F99D373DA1901C2A873E01BF2BCFCC88987F2 + 463D76B66F346BB057935E40A5063E238C9CE9F6C2D9FB903F82EFD4F09F2FAC + BA9677F88195374A7F943EA4FEFC4E506D54F763C36C6EE11BF59B33CDB9AE30 + D818ECC75ECD3CCA0E1FF93B80BD9ADDCC8EDEA1E43CF4FE82DB49DF28B60BE2 + 0DD21E041FE33C1FA7BDEFFC0730EBE0DD2976AC0556AD761EBC5AC5E50567EE + 70DF67C230ECC3A629ECDBC1357B7C70824FD6F0F1E6DAC0A76C46DEDA786D04 + 5735BB5D58FB0F47048A8EB21074F10000000049454E44AE426082} end> end item @@ -8614,61 +8643,47 @@ object MainForm: TMainForm SourceImages = < item Image.Data = { - 89504E470D0A1A0A0000000D494844520000005E0000005E0806000000AAD2A3 - 6E000000017352474200AECE1CE90000000467414D410000B18F0BFC61050000 - 00097048597300000EC300000EC301C76FA8640000001874455874536F667477 - 617265007061696E742E6E657420342E312E3564475852000006454944415478 - 5EEDDB4F681C551C07F01E7A10CCD9530F3D1651F0505A94A8875653B1070F22 - 01EBADE2A5A0E2CDAB07855682B4504BC5852A064D6B625BDB189424B41E052F - 11156DE39F6A0441D4959AD96CC6DF77F6FDC6F9F3DEBEF9F366E6BDDDF9C2B7 - 4D67DFCCECFB106667DF6E77F8BEDFB6810EFE7031173EBF2BA88371171EE0E7 - 57D6823A88EF267C88BEEA0FEA1EBE7BF0297437F1DD8257A273DDC177075E8B - CE7503DF0DF8CCE85CFBF1ED87CF8DCEB51BDF6EF8C2E85C7BF1ED852F8DCEB5 - 13DF4E7863E85CFBF0ED83378ECEB50BDF2EF8BCE873AB5783CA1E93D61E7C7B - E08BA07796EF08EA20BE1DF045D1390EE2370F5F169DE3187EB3F0A6D0390EE1 - 37076F1A9DE3087E33F055A1731CC0AF1FBE6A748EE5F8F5C2D785CEB118BF3E - F8BAD13996E2D703DF143AC742FCEAE19B46E758865F2DBC2DE81C8BF0AB83B7 - 0D9D63097E35F0B6A2732CC0370F6F3B3AA7617CB3F0AEA0731AC43707EF1A3A - A7217C33F0AEA2731AC02F0FEF3A3AA766FC72F0A382CEA911BF38FCA8A1736A - C22F063FAAE89C1AF0F3C38F3A3AA762FC7CF0E382CEA9103F3BFCB8A1732AC2 - CF063FAEE89C0AF0F5F0E38ECE318C3F1CBE458FC720BE1ABE4597C710BE1CBE - 451F1E03F869F8163D5B4AE2C7E15BF47C2981FF3F7C8B5E2C05F15BF8B2290D - 8FB4F8F952101DBBC6E191163F5B4AA0236978A4C51F9E92E8881C1E69F1E531 - 808EA8E191163F1E43E8C87078A4C51FC4203AA28747C60CBF7B60DF04F53075 - 86BAFCD7817DEBF4B7CF5D7B62CABFF2CCB4FFDA8B2FF9874E9CF6EF9C5D4A18 - 0C4747B2C12363804FA8F750CF52FF66E42CDD989AF44F1D3BE6DF7DE67D9ABB - 1E1DC90E8F8C283EE1EDA276A83DC62CD23F0FEEDFDE3834394B3FEF12875626 - 1F3C3262F8847484FA07E3192A8E77449C429AFCF0C888E013CEF10856153D2E - 4E954A3178C4717C42C1B55C8665BAEF8853C6521C1E71149F30AAFE4D4F7646 - 9C3A4C3978C4317C42C0355D861374F3DC5BD2EDBA6EBEFBB6747BA4B16B7E79 - 78C4117C9A3CEE5E942FA44047FADF7F2B7D5C55EF93CBC17EBD954FA58F8BE2 - 1675B7782A86E01107F069E2B86594A184E89CFE8DEFFCEEC1FDD2B1D17A8B97 - C41E83F43E5B948E139D154FC5203C62313E4D1A6F8EA4F7E949744E7FFD86DF - 7DE4FED478AE7765418C8CC75BFA583A5EF43E3C1F1A66101EB1149F262CBD8B - F9F7D4EB01962AFD1FD7FDEED403A9FDBCCBF362843CDE47E753FB889EC5F3A1 - 2186E111CBF069B2587B512E03F4AEAF0458AAF47FFAC1EF3EF66038DEBB7841 - 3C22CFD6D75FC58E9F289EC7040DAB001EB1089F268A052F1942582DFEAD9FFD - EEE30FF9DEC29CD8228F069D7B988656048F58824F13C52AA30C20562DFEAFB7 - C44FF264444767687885F08805F834D1E5C4C495D5E1AB92031D5DA65D2A8647 - 1AC64FAEA7EBDABB0E97ECD9FA26173A7A9376AB011E690A9F8E2199B8B659F1 - 0BA007A5D4048FD48D8F7DE918B2896769FFB70D0029B3ED79F482FBB0745F5D - 2935C22375E10B741C4336715DBDC5C132802EFD8D5F0AE1536A8647AAC68FA0 - A3F88C54367955BDAB17019339B8DBC9895FE3353E99AAF013E8E8D2D34FC926 - 2FAD6A1940979CF8D7689786E011D3F81274F4C4F32FC8269FAA77E9C3005195 - ED7FBAE2277972E09FA4E10DC223A6F015E8E893AFBE219B7CACDA650071F7B2 - F5E517628B3C19F1A76968C3F04859FC21E828BEF7F2FBA3E9852EAEB7F04180 - A64AF296B124FE6D6A856B357953145F83CEED3CF7AC0CC1BFFDCACB01962AAA - FB741DFE900F458235791A62093C52043F033A7AEF9BEFC910826E76CE0458C9 - E8DE1CA9F0359F44EDC554699845F0485EFCCC5D59DB989A9C9740044DE2677D - 479AC4D7A0CF8B595A088F18C7A763D13169E2BBA9CA7579C6CF8ACE65FCDEAA - F633D73D628696C223C6F007E8E2A858A93C1AC14815F8B2EDBAE2AE48B63DD2 - A3E22904B1171E298D1F47E710C2E9044AD5ED885387B11B1E298C2F47470862 - 27752E025365719E9DE2D461EC874772E3ABD139C0A02ABFEE61A8387E0A1D71 - 031EC98CAF478F866070CD57BEE0162C8E17BBA627E30E3CA2C5CF87CE21A43D - 54E5AD66CEE238E1DD8B2A6EC1234AFC62E8D110D85E2AFE6301DED6CB5055C5 - 78EC17BC39CA12F7E091147E79F4680810DFC399A69EA45EA3DEA446A1F16F6C - C7E318372176CD1C37E19110DF2C7A5D71171E01B883E84808DFB6EEFA3BFE03 - 72F83711316020C90000000049454E44AE426082} + 89504E470D0A1A0A0000000D4948445200000060000000600806000000E29877 + 38000000097048597300000B1300000B1301009A9C18000004CE49444154789C + ED9DC16F1B4514874729EDA147E046C59D70DCCE10D4489666A212A49C90AC22 + F80F38F484D4924BA482DA72A01EA7ADE2A8558FBDA0C2A1E5420E2068703635 + 48802BCE343D54B441A4BB0EBB6069D0731A1192383B6BBCFBC6BBEF93468AEC + 58EBFCBEF59BD9D9898731822008822008822008822072E4921FBFAAFDB8A657 + A3B6F6A350AFC626D3D63B46D4AEF9F1A5FA4A34CECACA5CDB1CA9F9F1E5DA6A + D4CD3CF43EEDD9B1EB8B2D7398952D7CEDC74B58C1EF11E1C75F964A029CF9D8 + A1EBBD12342B4BCDC72C3BBA6F8BFEAE35A35758D181330D3FECB85FFB84159D + DA6A7CDF81A0CDFE6528FA99159D9A1F05D841EBFE65E8292B3A4921B0821F1F + 1DEC0034092001A86007A049000940053B004D0248002AD8016812400250C10E + 40930012800A76009A04900054B003D0248004A0821D802601240015EC003409 + 2001A86007A049000940053B004D0248002AD8016812400250C10E4093001280 + 0A76009A04900054B003D0248004A0821D802601240015EC0034092001A86007 + A049000940053B004D02DC1760AAD5439B8ABF1E4A311B4A712B54FC7EA8F8EF + 81127F41839F4325DABDE7A498ED4C890933C7C6D828E0B280EB4B6B2650E262 + A0F8C3500993A6058AAF05525CE854C431E6322E0A687CF5C8B43EF8C86C9C3C + 912AF47D454811074A2C3CAD782F3217714DC0ED6B77CCFACCD4FF0E7E4F93E2 + 49205F7B9BB9862B02E69B1DD33AFBE1F083DF5B9A1AC6F3DCF92E2217045C59 + DE30BFBC773AF3F07748F8C2CC7847990B600B986F76720D7F47495A32D5F123 + ACEC025A39949DFE9F04B1C0CA2C2050FC5DACF0FF9570FC142BA3800DC55F08 + 95786C1352746ED684D393F6C14E4F6EBDC6AA14F175D4212A968040F2459B80 + E2C5BA01BAF79A267CD342C21B274CF7BB6F7AAF896F346CFB83ABAC4C023A15 + 710C2E906CC3DF2651C28EF0B7B19100EF6573CA7B99954540A0C4C5B4E1274A + D827FC94122EB0320830736C0CE669926AFE4174FDE5FFF609D393BDC70E22A9 + 4F80F92698F4634517B009B39A29EA785F09DB9F8434BF9B70DC8EF4042BBA80 + 10A6946D3A469B605B2BA6BB727728E1F7DA143FCB8A2E2050E233AB302C250C + 2DFC5EE39FB2C27F029468DB0732B884F4E1F7AE097E62C52F417C3D55280348 + 1828FCADF69815BE04C9E4F17F5F09CD6F93C36FF983860F43D188E5CD6809B8 + 9B2CE07B127020548276015F909D24410FB1ADBD732AD3F047B0138EDA790A68 + 9F7E3FF3F0476A180ABB17E529E0EB8FAF1B672FC4243F93BB00D83A2ACF2D4C + 6EDEFAC1383B15A18E7386016C1D959780BAFFA779F4D68C716E324E8A5FD156 + D3C19651B07594CE49C2F2B9F9C4B3316E0C733A7A21F17881E4E751C2DF2541 + C3EE45590BB8B6F4D06AD5DB6E0983DD90B1095F441D39F1127381FA4A340EBB + 17C1063A59EE2F736FF6BC55C7B82D61B05B920BB6A39FCBAC6CFC7172E27937 + 6ECA8B27CEAE1BCD1A58AB691D6A462D90A2CACA4CA078034F00BFC2CA8EA956 + 0F058A7F9EFF99CFEF984AE539ECBFDF09CC8C771416CCE658766E3BB338D715 + 8CE71D86B59A79941D3AF30F00D66ADA8E8E5235297E2B7D879B6ADDA81457E1 + 026908E52682713E0C7BADDF00B1055C9DC28AB5408A070304FF00A6179CB9C2 + 1D65CC1C1B834553B06E07E6ECE1C609DC59EBFD031EDCE2ECDD65E33F3E7BEE + 0CCC6A0E3AB1F60FF28F22B0CFA5A93C0000000049454E44AE426082} end> end item @@ -8676,49 +8691,43 @@ object MainForm: TMainForm SourceImages = < item Image.Data = { - 89504E470D0A1A0A0000000D494844520000005E0000005E0806000000AAD2A3 - 6E000000017352474200AECE1CE90000000467414D410000B18F0BFC61050000 - 00097048597300000EC300000EC301C76FA8640000001874455874536F667477 - 617265007061696E742E6E657420342E312E3564475852000004BD4944415478 - 5EEDD55D48547918C7F1D382BA156D41B0575D76157417050BB11544B5BD5D45 - 45DD14D4D245202A141574D56D50EC9ABD40F47257911569655AD32ADD2F745D - 641905A551A42933A7F33B33CFE4382F9E73FE6FCF3373BEF0A8E071063FFC50 - CFF7FDF41C5CFE83C46E0DFD1E9EC0E4C203FCE6D317E109C497095F44CFF8F9 - 93872F0FBE0C5D26BE2CF8AAE87472F0E5C0CF8A4E27035F067C64743AFEF8FC - E163A3D3F1C6E70D9F189D8E2F3E5F7865743A9EF83CE1B5A1D3F1C3E707AF1D - 9D8E173E2FF8B8E83732BDE155FA5EC5E383CF073E09FAE527BF8627109F077C - 52744A20BE7B7855744A18BE5B785DE894207C77F0BAD12921F86EE04DA15302 - F0EDC39B46A798E3DB85B7854E31C6B7076F1B9D628A6F07DE153AC510DF3CBC - 6B748A19BE59782EE814237C73F0DCD02926F866E0B9A2530CF0F5C37347A71C - E3EB8597824E39C4D7072F0D9D7284AF075E2A3AE5005F1D5E3A3A65195F0DBE - 5ED0298BF8C9E1EB0D9DB2849F0CBE5ED1290BF8F1E1EB1D9D328C1F0FBE51D0 - 2983F8D1E11B0D9D32841F0DBE51D12903F8B3C3373A3AA519BF367C8A5E9A46 - FCEAF0297AE534E157864FD16BA701BF1C3E458F96227E297C8A1E2F05FC9FF0 - 297AB212E2A7F0AA29C3A3143F5E09D1F1A3A5F028C58F96023A2A8747297EED - 14D151657894E2574E033AAA0E8F52FCD234A1A3DAF028C5CFA7111DCD0E8F1A - 1D5F333A8A068F1A155F017DA4A363E3DBF6F6E7C1E7BFFD93277F095FAF5074 - 78D468F80AE8C3EDED9BDEB6B58D07F0FE9BB6B6A9E0EBC3E16B168A078F1A05 - 5F01FDF6E3FFB63EB8FBF0DDCB63C7BF013EC40F6EB8A3A395961F1F1ED53BBE - 0A7AFFE05FDDFD43E3DD03437E80FFF9F59123E1EA69F901FE013C970C1ED52B - BE02FAC4A5459BFB7BAEBD073A5DEFBD87A33396FF0CCF268747F586AF803ED5 - E96DCA9EF3C6272FCC9D7CDC7BF5D374FCFCF28F8E078B1F1B696D5D81E7D5E0 - 51BDE02BA0E73ABD2D40F7BB02CAE0262E2E9CE8EFBD3E5A8AFFE055F00F775D - F85E41EAF0483ABE86A5133A1D961FFCD9F908F4DB038363DD03CF5685EF5548 - 0F3C928AAF71E9332FBFFC2BC3773243C5A553FAE091347C034B9F7ED94E6F6C - F2E26F2BC3F79A915E782405DFE0D271400F9E2B5B3AA51F1E71C7B7B0F4DC3F - 5EC9DFF4999981475CF11D2F9D32078FB8E133583A65161E71C167B274CA3C3C - 728DCF68E9941D78E40A9FD9D2297BF0C8363EC3A55376E1912D7CA64BA7ECC3 - 23D3F88C974EB98147A6F0992F9D72078F74E3ABA15B593AE5161EE9C257409F - FAD7DB6A6BE9947B78A48A2F68E9140F7894145FD8D2293EF028097ED2A5DF6F - 5A9EEBF23E57C2A633B1748A173C8A8B1FF97EA2A3EC939653D9FB4DA301FE64 - 5574034BA7F8C123EDF8A5E8C1AF3B279769F9DFCFB4F8B99EA68FB9F3DEF732 - 74434BA778C2236DF8A5E8A8E7CCD2255F1FCDFB0278DCF4E59B5E3AC5171E29 - E397A3A35DBBD66EDBBFEF4FFF6BDFFC10BEB8FC2EEF83E9A553BCE15162FCCA - E868DB8EF567576DD8EE1F3AB8DAFFD6377724FBB4B92F97693E91EB695E5678 - C478FCE1516CFCEAE868CFDE355777EE5E77FAD081D57F0C5E5ABC20F8EDE714 - BE652D19F028327E6D742EC98147B3E2CB4047B2E051557C39E8481E3C2AC397 - 858E64C2A322BE3C7424171E015C203A2AC2A767FB7CEF078A02E2CF49BDCE74 - 0000000049454E44AE426082} + 89504E470D0A1A0A0000000D4948445200000060000000600806000000E29877 + 38000000097048597300000B1300000B1301009A9C180000044149444154789C + ED9D3D6C13571CC09F91488804230B62E85ABE25062AB1D0562441B465020604 + 63983A70074C69918A701A09E297D03636998009061B230545102731892177E2 + 6388DB446A97AAF652D186004AEE09C31F9D892D27B1E324C6F77FF7DEFF27BD + F9F97EBF7BF735F83146100441100441100441108487705BEC08598273DB4973 + CB79C36D01751DF9399CF4C739C50EA62B17D2D010B29C5FB9E5BCABBBF40A23 + 643BB99025AEBABF85E9847BC0DC16092CF14B438841AD22E4CF7C09C4F38511 + 7A9836D77CDBC9610BE7652E475D96D8FEA98EF39F3367BECC1AC654D630FECF + 98663B30166032C06DD18D2D9B578A6089AE4F718CD9B3679BB3863197354D28 + 8C8C6986A58810B2C5EFF2067026EA215FAA0821CB798D2D9A571CCEAB5A8EED + EEE0E8A1C960C7D372F28B110CA31B35423509CCA7F3C786522DB1446AEE4E62 + 746632F8F3C4B2113057828A01E2C38F5AF3F28752901F3247502D407CB1FCD2 + 08973AD25522B433AF5129C0E3F8A583B1A194B3447E31C2D8CBA960C7722BE1 + 3FE635AA0480086B867060F6E1BDDE64C500555642C6342799D7A810005CF9BD + 6C0EC20CA037F07E2511A6829D0B2318C69CFBB2C6BCC6EF01A0547E61AC3042 + 71251886C818C6370C033F078072F25719E18F60E7B38C697ECBB0F06B00584E + FEFC78D7BBEEFD487F5F6A999BF26CEC7EB28561E2C700B002F9D556C2FCD3D2 + 61868DDF02C06AE45788208D7CBF0580B5C85F14412AF97E0A0061D6BA66F985 + 7B4278DDEC78FCE2574C26FC10006A39F38B2B8009F88DE13C6AFA3900A82C5F + F600D1443F282D5FE600D1443FE4221B4069F9B20688EA225FC600519DE4CB16 + 20AA9B7C99024475942F4B80A8AEF2650810D5593E760088B066ADE5630600D5 + DF70650E00241F2F00907CBC0040F2F102C058D316B81E785EA37C375E2B5309 + CF0224D79F8064E30CDC0CA4E9CCC70830D2D007C94658530455E57BBB021AFE + 9A0FB0BA082ACBF72A000C376D2D91BFE208B94803282DDFBB001B4E9609908F + F0E2D6F68AF2E30F6275FF14A24580AEF6DDE3D3031BCB0500F170332C8E5090 + EFC5B7282D027C77B4E5EDF1135FC38B7B9BAA4628954F01ECDA05FCF2C3AE7D + FB5A8E803BAA45F8F7F69E05F229805DBB809FCEEDBD5608502EC2F4E8E73031 + D606038F6F409FF5B7E79FC3950FF0FDE9FD7F96063872EC60AEE7C75DCF61A4 + B10D861B3FC3F8182815F51670EAD4816937C2C5F37B23DD17767EE1F5FCD283 + 2D8053000A800AB6004E0128002AD8023805A000A8600BE0148002A0822D8053 + 000A800AB6004E0128002AD8023805A000A8600BE0148002A0822D8053000A80 + 0AB6004E0128002AEE1F645793C09146C8766698EAA8FEF7F5D2C32D11927705 + 88CB4C75DC6D4264DDC2A47BDCD9C674C0DD3A4ABECB8FE04CAB3DC46C31882D + BD382CF120F204D6339D988FD0837B3972DEBA67BE76F297DC132CD1E53E8178 + B1BF8C3B873B17B7C5156DAEF904411004411004411004C164E1034F1C961B87 + 1CCC4A0000000049454E44AE426082} end> end item @@ -12060,202 +12069,67 @@ object MainForm: TMainForm end> end item - Name = 'icons8-wikimarkup' - SourceImages = < - item - Image.Data = { - 89504E470D0A1A0A0000000D494844520000013C0000013C08030000006ADBFD - 340000026D504C5445FFFFFFFBFBFBEFEFEFF3F3F3F2F2F2E8E8E8F8F8F8F5F5 - F5DFDFDFEEEEEEFEFEFEF6F6F6E0E0E0E2E2E2E3E3E3F1F1F1EAEAEAF7F7F7E6 - E6E6EDEDEDE9E9E9F4F4F4ECECECFDFDFDE1E1E1FCFCFCF9F9F9E7E7E7F0F0F0 - EBEBEBFAFAFAE5E5E5E4E4E42E2E2E8484844E4E4EB9B9B97676765151514B4B - 4BCCCCCCCFCFCF505050717171777777C6C6C67C7C7C858585C9C9C9BCBCBC5A - 5A5A404040D7D7D7DADADA595959CBCBCBBABABAB5B5B5474747DBDBDB5D5D5D - 555555A7A7A7484848747474B6B6B64A4A4AD0D0D0CACACAA6A6A69E9E9E7575 - 75393939DDDDDD4D4D4DD8D8D8C5C5C5C4C4C48F8F8F9D9D9DC8C8C86F6F6F6D - 6D6D979797727272B8B8B8C3C3C3CDCDCDD2D2D2494949878787464646DCDCDC - ADADAD707070B1B1B16161614242426C6C6C3A3A3A8C8C8C4F4F4FC1C1C16363 - 63C0C0C0ACACACD4D4D48B8B8BBDBDBDD3D3D3B0B0B0414141BBBBBBBEBEBE8E - 8E8ED9D9D98A8A8A5252524C4C4C9C9C9C949494C7C7C79292928D8D8DB3B3B3 - ABABAB969696999999959595939393919191909090989898D1D1D15454544444 - 44D6D6D6575757535353434343D5D5D54545455656567D7D7D7878789A9A9A6E - 6E6E7F7F7F737373383838A3A3A37E7E7E8282828080807B7B7B7A7A7A797979 - 8686865C5C5CDEDEDE2F2F2F6868683F3F3F3737378181816767675F5F5F6565 - 656969693C3C3C3B3B3B3131318888886060603636366B6B6B3E3E3E3D3D3D89 - 89896666663535356464645858586262628383835E5E5E333333323232303030 - 3434345B5B5BB4B4B4C2C2C2A8A8A8AEAEAE9F9F9FA5A5A5CECECEB7B7B79B9B - 9BA1A1A1A2A2A2A0A0A0A9A9A9AAAAAAA4A4A4BFBFBFA277A4E2000000217452 - 4E53000000000000000000000000000000000000000000000000000000000000 - 000000A092B002000000097048597300000EC400000EC401952B0E1B000014FE - 49444154789CED5DFB9F14C5B5AFAD5958BA817DCD32E3022B31F7DE44935CEE - 8D1A35281150940B7A458D11504384A817D1C843D1A85C1114218280BC5D1E13 - 505E05CB02B3B054752F823C7781BFE95677CF74577555CFF42E3BDCCF34E7FB - 839F7072CEA953DFADAEAEAA6F770F4200000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000008000376F5CEFEBEBEBBD76B5B780 - 3E1FBEF1CAE51ADF1FA76A7101972E2A9E4AF84F3786704FA40BAFA471E885F3 - E53AD5DB7BF1922E43CD8F2E23A5C3AF9C73E37A6C8B958145CFD60595060D75 - D3F2A18C0D933B1A8457D268B84D97EB56B72E43DD9918DDB24FBB715DF93C2D - 837CFE541D32FD76FC864EDAE522394E84C9F3C32B69343A6394669F543318A8 - EE78BEA33C23C7DCB8338C5A654059D770B1D26243470929176A594746843B5A - 0CAFA4111F2E5F1921477519861F8AC3C8D9F8E41D94465EB1A178E42923AF18 - 5E49A3D17FF2BC0C7CE4559A3CAFA178E48D543BEA8557D23810F2DC0CB7833C - B7A178E4D5D7AA1D75C32B691C10794E86B8E41DB815F29C86625EB6DC53E928 - AEB07160E4F10CB7873CDE50DC392F55AB76B4C2C6019287530DFDBA6CCFC671 - FDA1111B85F441CD4DDD71C83B6C70CF945F9D105E49E3B02371C8FB5ECD303C - D57C300E2367E29377A831A592876293875229B5CC8A1AE391D7AD6630538D83 - 4E5EB366618FBE8F4D1EF67B2A8457D218933C3583891B4F0D9C3C5BC5FEFCF1 - 66BFD412E4514DACBDCF254F175E39630A0FEBD4D522F7945FB6BA0CCDFFCC77 - 6862B5E41D90C8CB71BB02923FD68C8D424325C8636A2C61561A79DB1F25BC72 - C6546AAFC59B0E83B230796A061337EFC9ABA19CA45C39F288D5B97B577B7BFB - 77DFF1FFB4EF2C60C7F66D2D7EA951E4116BEB966EEEDC2E876FDE3D0A15B63F - E1F00A1A532D9B7705F517ABDAFEED7E4BACD8B961A8195A366DDC2075DF09DF - B5F98418AABD6C19F906A5FDAA424529C61079EB8739EB19ADE76D36EAED466A - DDD70A7931D3A6F13F082B431E656B3DF2DCF070CAB0314CDE089FBC58E19533 - EAED065EF3954A5EBCB469BC5AE62962E465FC70B528D9A88EBC6C84E7ED366A - ED69FCA58EBC58693331461E633E793C5C5394642C455E8CF04A1A75764E9EE6 - B28D979693C7FA431E4E35698A128D25C993C3877CB16AA583CF577CC6B1E97F - 978F8AF274F1E9271F7B9E8EF3679BEE2A519281FFFED1673E56AE5CF5617D84 - 732479E57B1A45DE1999BC7FE0563F2438D81786B0603C2A93F7F597BC3EBD27 - 42CBA870FF272CFF779C8EF0E413676D8FE46DDFF477D66A4935682325BE3721 - F483D111CE59346CBD4CDE517D011A632BFA46264F73242593574E6D29439EE0 - 69A2F7A9B808CCB3EB38A3F5743BB9F488B864A47449A9929A7A6C5B486DEF40 - AD7AE712E495D59506405E19B5A51C7981A789164B0B6ADBFE3E5AC131D12226 - 2EE889D5135D9289D6BC273292B3CE399387CEB91479E574A58190575A6D294B - 9E10DED221D061316B6D739427C71226EF058E64A23CF955FB374B72EE181395 - B624796574A5019157526D0991F7954A5E103EF4A0D8788ED8EF6233AAA1D17B - 884C1E7DA738E9292565D14271DF49C8DA8802CA91575A571A1879A5D4963079 - 6FABE405E12BA46D39210B223D51239537CD847C529CC7D4924675C91D581299 - B60C792575A5019257426D095FB6EB6A55F20AE159F43F8C4A856F088D3CA1A1 - C5D226DCA9EA2D33AB2F8913B24FE299BDE9DF99C3CEE5C82BA52B0D94BC68B5 - 4599F35263A3741913ED950A67EC8D084FEEFA57163AADB196351728099764A2 - 37E5F971FE5D61F27CE7B2E495D09514F2341A0663AB55F222D516F586D110AD - CBD4CCA3C2D023D6FC77233C4DD413BA5FF0626F16AE5BB5A49554DA731EAC8B - 2A200679D1BA524CF26A55F2A2D416CDDD365297A9412BA5F587C5FAFCF558A8 - A1E6D7C327D479B629449E5F52F62F221F79BAD25FA828CE31C88BD495222EDB - F0F6AC69AC1F14E4D1AB2DDD9AED59942E93C173A5735CE71837A3F34CE30BB6 - 3CE5F15AE99FDB224A1AB155767C0D67F40594DA9E95ED692AEEDE766C6CB545 - 475E942E63E0575F111764941E486B3D0D3C47B96A89357BA927DF29255D1689 - 66D657B3705AD37BD759254F230045D43F36EEC1406CB5457F3010119EC6C798 - BCB27939D5A0F3AC3D4565C1C0ADEB4F1E29A192D27CDE15DC6C76A0211839AA - B3425E6C5D696C2AEEA94A5CB525E254451F5E8BFF1A5ABC2D70CF7C439E69BC - 74B6151E79BCAE5E6D49697C56FC8B30F7605D97D673562EDBD8BA5226B55A47 - DE01CD91544CB525EA482A22FCA63495E5ED933A5129835FB215EE08637F0CAF - FFBD9CAFAE173623398B4F79695700D2393768E6BCB8BA5206C7262FA6DA1279 - 9EA70F6F9496B39475356B3CD3F845F5AAE5FD7CBD4D933393BA9C17BDAC7D4B - BDD6B50534A434378C98BA52BF0E4307280065233C3DE30BF296F5C43A7E1350 - 3C1B9FD76BCE333539DBF04AB14B8CF5780DE90B48DF8200D4BF93E4810840C2 - 49B236FC39713DCB27A8979C3BA8EC69E2BD5207FDE4E40AAE55721A9979624A - 42FEDB7FA44653401AAF1BB000D4CF63F84117800CFCAC440BA5EFAB9E267E86 - 28539E5BD93C773693721A78C6742291F78C4FDEE00B40FDD230065B0032F07F - 2D13EFA3C4EAD1796E62EAC0730A9B3E44C999C18BE50AA6B5E100C911805C64 - 9E96EF055B87693C8F2B4B642FFB7C67A527E734F053624246FE395A202F4102 - 10472BDA26DF0B4851D8113C47AFD73E7A9523642ADF1F8772B66E1413DA6C95 - 70CCA51650AD025081BC27E7CBA3A978C629783ED111DED816CAA5DB1D673967 - C3949C74CC351907A7026A01D52A00152DAB89D4D8B1C21188EF99C1BD4473B3 - F5CA6DE0E354CE39C392E78D59F2C84B8C00E40DBD49D2B28C3C3EC6BB6E7DCF - 0CFE2393EE2902E6AFE1DD17739AE80FA2B34D4FB5897748A580EA1580BCEA2F - CAE38A2EF2AEDBC0B37E62303673A147E226736739E7D372874EE2B630790911 - 805CCC904EDF6CF611AA113D33F8CDC3C22CB66FAD34B0168673B64E910AC8CF - 158574B580AA15800A30A788AB384A9FBF5BF26CE3531E0B6AF9E0C3134269D6 - 63C3A59C267A7B9AF0976064FDA3D850C94B800054C476224D695346BA935ED1 - B3016F08445846BB464E102BCE8F9372B6A2A9E21440C863FC6FA7212F090290 - 87DF4BAB384A67BAF75BDFB3FE7430E5398773C7C405337987EFDE829CADA85D - DAC991F7F9DF4E475EF50B402E4C34C216C9CBB35ED1936F01B606FF778E2E30 - C4F353461606E439AFEA0CDF23AFB9174975AA0554AF0054C0B81E229D211DCA - 089E267A24288690CE31E8614B749E28E6AC4B3DD329DDBA0F374875AA0554AF - 0054342EB4A56390132325CFA34CB86A1F426894C00F77FE9D90B335759D0AC3 - 989043A6D4905A40150B40AE2983274B4F5DE4AC3F899ED98944E08A5F54A678 - 4C90B32F08DB2F13CFB1058D92D2A7E43AD502AA5800728D69FCE00342FDC462 - 1F8B9E63A4E79D16F1EB583C3F75464AF0950DF4B3C7A4BD1E7938683D810210 - 760E9186BE25B7F796737C5974BB6C09B0C7F1740F0B53A44DCF18FEDED544EF - 8A4FFC116B4273E14586640A408EB10DED9636AFE4957ADF332BFE7F84F4D471 - CBB809411BCC7AFCEDE0291E748E31F1AA9D542334944001881B33E853F92DAE - FD8B7171696BA2FB83FD874DDF776CA39F178E3B897D2E78BE05CD61C26EC5A6 - DED32C5E43491480B8D140235F971E35B33E4F15CE424C7497203150F67B9EAD - 158942649E7E2C3CC6B3565A6F77BC1990175140350B409ED1447BE473A4797C - 2E727D5AD16571C370E46D9EAD062D128F8AE90B77FB29DBC4330646A60F1137 - 7ADA02AA5900F28C265A280E1866BDF1BBC2AABE06AD0A1E42A3E4F458E48CC6 - FAD9C12D8337D15298F44CF45BF1748BB243DE980CC84B9A00E4197F940E3949 - FE1D3CD6F31C7D3CB844F3F6C626878D2C3A28BC254BC87F16C8CBA285C29F80 - 277C3138198C2AA0AA05A08271987890C42FC58B7CB350EBAC62BE9C2076ED86 - FB55830CFE0F61B142E99542CE3496AE7ECB7E4779042D590250C1689C91DE1F - A4E3B3AE671ABF245EA0472E3947349C91B934B8391372DCCB69E075132C7144 - EE1B176E482DA0CA0520CFF89124B65ACB0C64704F03AF60F9A08E657585F0BD - E2A716C87B2DAE31833FCD0B3C30F283D2905A40750B40AE318D6F8A232FC7D8 - 0CE43CB252DB287C0C86B0E79D97A6DDF08782E51CC9B1675D631B5EC2C411C9 - 3E531A520BA86E01A840DE1AF18AE3A3E6BAE739F20171885D7518F5CEABA5C9 - ED45E7CC900FBD17A8F0701963FF5E78CA344C5E920420D7D8F802959AFC8D63 - 34F04C31576E5621BC814F85C249023BEE3C74D1801F141F1FE51BDBBD4A436A - 01D52E0039C636BC527E2E6C428D4BDE0AB1BA07EA0AE1B5B54BA789F54D77EE - 0C0DB537A9B4D2DED2A634A41650F502107226FBCBD21B90B98E75AEDF414138 - 23BF0EC21BFF22DE850FFFC8879E91921EF5B3E9159C0E37A41650F5021072C6 - D8AB538878CD911B4ED75B84575728BDEA871BA94F84D71A09798E0F5D9CFEB5 - 3411D2DFBACFCA4B0DA90554B900E419D3B84B7A849D4DC21903DF14F6AA943C - 89B28560BE2A110E3D3BEC5D0E4FE3C4179429F9D5A3DE1239E10210763B7145 - DE977E904277A30F8513786BFD0C5FBFCEA247DF0B6E0E94F4380FA9AC13861D - 1FA75B8A872D091780DC7FDE27ACD1F8E2EDC47D68349A14D461D3E38D42F8D0 - 2E71553D6D0DAA41D704F673847C886A9486D402AA5D002A18477F2D4632721E - 99C63722799FE0E081A71AB45B2891D2C9DCF26769D29CFF70F05981040B4045 - E3D3E226236FEF40E8DE6982C868FF8D4F75C5D8563457DA0B9F3451D32F859E - 3036BB29D4503205A0A271815409E969437DC1591EB35E7997DF008AB1A6F332 - B7A048AE1D8EEE9B2F4A707C2B67CA0D255400C21E1D0F4A9FB223FB1F449B83 - 798DD23DA2A4C6F181F44CE448B44D7A5480DC905FEE4EAC005420CF903F6B45 - 1F193A51CCB5D37915D70F36D178E901F973A85D7AAA3E3723DC504205A082D1 - DC615351375CB2D7F673118BBDE66CF385F005C2E13361BB9B1E126A26D6E3C3 - C30DE90BA87E01C8FD672B9FF4C4E74CACD373C565F3D6A5A1F0A5D2C3410796 - 8A477C943E6D2A0D690BA87E01C8FD67163D7144EC468E768937805F84C387AC - 16EF186F7C24B64BE945DD6705122A00216716ABEB919FADCB051731233B95F0 - EEE0F1A09CB5FF75E976919FD9A4252F910290F3EF36FC6FDAB7A4DC44EC5F43 - E1067A49283227514DC937196D436A014910803C0DA29759FA577D2CD231C2D3 - AFFDF0349AB13FE4E3FFAFBC3D1E19BA86D402122100B9A2D87DD2A4278059F7 - D786C20DD4207FCD5974E7ABBC365D436A010910800A46E35F22AEDB3C9DA384 - 67D1CF35EFCEBBADE60EBFECEE89EE0C01C8331A787CC487E529BB107E2D08D7 - A03EA27D0DD739CFAAD337A416900801C8335E88FA2AFFB42784C74EBCF02C9A - D5A977266C0B6AD536A416900401A8609C217E97422CEBF458FF6DBE20FCEE89 - 11EF3093A9C533E73B42002A185BEED70E3D4A7F237F73CB0DCFA28DFA819AB3 - 674434A416900401A8683CA9BB07E40879AA702C2C869BE8BC963B426667231A - 520B488400E4229D3AA7BB1089B5F55EFF0D6631FC51EDDD96910D510DA9F644 - 0840C8EBC93ADD07541879658C363C3D4577DD32765E3836BD3304201743355F - 2BE305FC50FC344A285CBB9F63F94B1279778200E4A006CD51770DC4625F4484 - 4FD59047C9C411510DA9F6A40840C839D37B4DBB5879561B5E9BBA577391DBF6 - 7643D750B20520E41C4B2DFD5AF9F211219DF511E1F5BF52BD29DB86339A8692 - 2C0079C8E23DE12D17F1DE21D5CB37ED343C52897578A6BCA9B90304A0227973 - 48F80E4AD98A88F00CBEA64C917C37E2FE989DD290BE80A408409EF191F0891E - BF0E1779CF3B29E119BC787F78D66364121EAB6B485F404204A082F167E1333D - E2C9DDBA70030FFB05090F3D721567B40D690B48880054349E0AFFFA009DD718 - 159EC1DFD23079F32FB9DF7ED492975801A868FC22FC53896C156E8B08CFE0CF - 43332461D38DC88634F6A408402EB2E85278E1CB96FB0F8B85C34D74EFD69033 - D9E91D5EDD6102900B130DF9A574DD32F2D513C26327E1F0A609F2D0236C72E1 - E4EFCE12800AC6EC469A2701F8D2236D96089FE7FCBA9488FA120DA9F6E40840 - 5E455799754FAE887BEEB1C6E36C89F06D823377270FD5956848B5274600728D - 26AAEF5BBEFCFAF5EBBD1CDBAE5DBDFAD3CB25C3C7FC61B9E7E9FCB777C1D427 - 4B35A4DA13240055DAA8DA132400B946B3C6459B0B6CB4A54B869B82675B5B4D - 4DB65443AA3D410250A58DAA3D490250858DAA3D390250C58DAA3D390250C58D - AABDE20210B97D0250858DAAFD1605A078BFE93D6001C8FB4DEFD8E19535AA76 - 03CF1AB000D4908AF79BDEE95B1080CC08CFDB6CD4DB8D5B1080D2A9D5BA9127 - 6918C4EADCBDABBDFDBBEFDA1DEC2C60C7F66D2D7ECE68F2B66EE9E6CEED72F8 - E6DDA390B7D38929B50C8631951AB77957507FB1AA0DDFEE0FCF799A0C2D9B76 - 6D90BAEF84EFDA7C420CD592E7FC06115340F2C79A8BBF3813499E336ED558FE - E74AA3C24E279ED43228C6D4487E1129C550F9004C2B0099B8794F5E0D6534F4 - B970CD656B395AA882FDF9E3CD7EA925C8A39A587B9F818A3B9D5852CB601831 - AEEFD4D522F73442006A3E95EFD0C4CA3D8D204F03CA0E35BBD2422901280A87 - 7DF2E2492D8361C478D891F2956905203EF20EC661A4FFE49512806290174B6A - 1914637FC893335490BC1202501CF262A9428362EC0F7952864A92172D00C522 - 2F8E2A3428C67E912766E81F7967E2B81EACF3B5852801280A479C5F490A7A57 - 566A191CA371380E791A01C8407587E230A239928A415E94001493BCB252CBE0 - 18FB495E90A1C2E445084071C92BAB0A0D8AB1BFE4F9192A4D9E5E008A4D5E19 - A965708CFD26AF98A102E4750D172BD50A4091E48D0877B4B4D4323846DC6FF2 - FC0CC3FB415E573E4FCB209F3F258DBC624327ED72911C279491575A6A191CA3 - D119A334FBA49A818FBCE3F98EF28C1C73E37A6C4BDDC9C9B0E8D93AB952AFA1 - 6E5A3E94B1916A474BAB42836134DCA6CB75AB5B97A1EE4C8C6ED9A7DDB89B37 - AEF7F5F5F57AB876B5B7B7CF47D178EDCAE59A50A56E43972E863DD5F09F6E64 - FE3F04A0A117CE97E914375EBCA4CB50F3A3CB48E9F0E7262300000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000000000000000000009C4FF0172AE - 9D982FABA9400000000049454E44AE426082} + Name = 'icons8-textile' + SourceImages = < + item + Image.Data = { + 89504E470D0A1A0A0000000D4948445200000060000000600803000000D54687 + 0A000000017352474200AECE1CE90000000467414D410000B18F0BFC61050000 + 0300504C5445000000FFE6AD84E610CEE610E6E69CB5EFE6B5A5EF84EFE684A5 + EF52BD6B526BEF52BD29526BAD19BD6B196BEF19BD29196BADB5CEE6B5A5CE84 + CEE684A5CE52BD4A526BCE52BD08526B8C19BD4A196BCE19BD08196B8CB594A5 + 8494A54210194210B50810B552634ACE311984319C84A531CEA531CE73DECEEF + 63CE735A8473DE84EF63847319CE739CCE731984739CA5525AA5105AEF10DEEF + 105AA510DEA51019EF109CEF1019A5109CA5A510EFA510CE52DECECE63CE525A + 8452DE84CE63845219CE529CCE521984529CE6EFBD423A19A59C734242421008 + 007B735AE6EFEF849C52E6C594193A0842104A4210E642107B0810E608107B08 + 104AB5B59C5A421952EFEF52EF6B52946B529CEF52EF29529CAD52942952EFAD + 19EF6B199CEF19EF29199CADEFA57319946B19EFEF19942919EFAD526B6B52C5 + EF526B2952C5AD196B6B19C5EF196B2919C5AD84E631CEE63184A573A5E610EF + E61052EFCE52EF4A52944A529CCE52EF08529C8C52940852EF8C19EF4A199CCE + 19EF08199C8CEFA55219944A19EFCE19940819EF8C52C5CE526B0852C58C196B + 4A19C5CE196B0819C58C4242B50842B5C5A573EF73DEEFEF63EF735AA573DEA5 + EF63A5315AEF31DEEF315AA531DEA53119EF319CEF3119A5319CA57319EF739C + EF7319A5739CA5A531EFA5317B525AEF52DEEFCE63EF525AA552DEA5CE63A552 + 19EF529CEF5219A5529C84B5A56310196310B52910B5193A21191021E6C5ADE6 + C5EFE69CEFE6C5CEE69CCE4242E642427B0842E608427B08424AE69C945A424A + A59C52A5E631EFE631C5A55263104A6310E663107B2910E629107B29104A6342 + B52942B584106BCE10EFCE106B8410EF841029CE10ADCE10298410AD84B510CE + B51084104ACE10CECE104A8410CE841008CE108CCE100884108C849410CE9410 + B5EFB584EFB5B5CEB584CEB5B5EF9484EF94B5CE9484CE949C736B6342E66342 + 7B2942E629427B29424AE69CB584316BCE31EFCE316B8431EF843129CE31ADA5 + 734A84314ACE31CECE314A8431CE843108CE318C002919FFF79CFFDE94000019 + FFDEAD000000F264CAE80000010074524E53FFFFFFFFFFFFFFFFFFFFFFFFFFFF + FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF + FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF + FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF + FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF + FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF + FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF + FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF + FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0053F7072500000009704859730000 + 0EC300000EC301C76FA86400000289494441546843ED97DDADE3201046417225 + F4626C241EB72E6A5917E0765C86B3DF3703896F1C7922DDF51BE7612180E7C0 + F0B3BAEE71335D60D205265D60D205265D60D205265D60D205265D60D20526EE + E16FE5E16AE536BAC0E47F09F6BD56DEF995609B4246EC18C6C54DB5ED9DDF08 + 36E7DCE87D41E16E1104064639C4AF0425855ABB668F296A8D535F59C9DF0846 + E7E65ABDA4CCCEB599E458B4FC4680EFBE12301DEF4BFD46C089CD39E7417E0D + 71DB220E08128236B0FB81C5E0F7C4BC480B02974DB27514E4E7A78A0A062448 + 49FC15600323C6311E885A499C87527C585048DC9720D740E1792D5490D795CD + EBBA6246C35FC42E1C3A673F6860B462441AE2CA080B06661F58FD29900DCAFC + 17C757F9B0077461EEFC8AC9A601C3F7D16DEC3DECC19F16B70906AC6941C94F + EA49FB20E0688EF228D982C80EB1530D7B25E0CD631FC7C8F9056741BD9FD2E2 + B8E719F39AA31B35AD5782092597C90BD2727416F07E8E1B4029027D0BB01FC2 + 9580BB1EF0A5846007380B64BB2BDA22396D4BBE1270CD0DE9009F5710F68AB4 + C8D2DBAE598258BF6CE7F42CE0749B5E496EE536688EAE047A1C7E721630E32D + E14271CBCEB0BACBACD5749D04C7DC378E029E7E1C4B6E550DC19079C6ADD5C4 + B1E970424E029635952D432F815CCB52E22E7374632C651B7183710D18987748 + BE95200903D5F5148894D370019FA645DFD983409E045C31AC420E289960C3CA + 3858BB198E3301C1EB8B35E2516A15BF3F8F20DF34E129F06971F38405809C96 + D92D1327BCE1D9E1031558AE2BBAF384BE8068DA82CE6705947599E785FF5557 + 5E8243DEC88F1F6F5CF5BD7314DC421798DCFFF741FD43E436BAC0A40B4CBAC0 + A40B4CBAC0A40B4CBAC0A40B4CBAC0A40B4C6E163C1EFF0089F464836E63FC71 + 0000000049454E44AE426082} end> end item @@ -16497,1207 +16371,2095 @@ object MainForm: TMainForm C895C94D15F9ED6FC7D9A2E0829BE75FE95E533E2BD255DAD4709CFF0775F948 AA1FAD341C0000000049454E44AE426082} end> + end + item + Name = 'icons8-markdown' + SourceImages = < + item + Image.Data = { + 89504E470D0A1A0A0000000D4948445200000060000000600806000000E29877 + 3800000006624B474400FF00FF00FFA0BDA793000006CE494441545809ED997F + 50545514C7CF7BEC8E895A8E069A35656139E34C7F9452EA984EA158D938D6A4 + 4318A441588C36E934538936E9D4983F111141604441766D9C1A7F4C8C82250A + A1526AE6A456F803050CD4FC9520BBCBBEEE5979EC826FDFEEBEDDFB36D6C370 + F6DE7BEE8F73DFE7BB7BEFBBEF01D01F11200244800810012240048800112002 + 44800810012240048800112002448008100122400488001108650242D78B1B1F + 97344914857809A468098481AC419FAE6DA8EC3D0109E0A600D2DF8C65356369 + 2A33E597B8F666BE3BC557A6CE8CB0190D9B01A4D83B1EFAE44140106097C52E + 26949B732FE3F80E016213DE8F84365B15532B0A9D64DC09D4582571148A2062 + 28A9CD6626F84842371B6214A4628C264C78FBBDC96097B663814C5F02925D7A + 4D94EC3053DFB0144D262088C2BBA22049D1B28352DD09448B2040A4EE6129A0 + 4C60206EC246B944A9EE048C2880EE5129A0930009E06411941C091014ECCEA0 + 248093455072244050B03B831A9C59DF72A5C5796E3B4892049F2D5D0D478E9F + 70DBC6978A291363203531CE6D976B376EC2B40FE6B9ADF7A542EDBA0219479E + 13975F80C01EF92D98330B0644F497E3684E873D1505B3A64FD3DCFFFFDE918B + 0078D1BD7B85038A603068FE91419FDEBD206D760A8485719B264E35A8C6F5CA + 86463D0E33A74DD17C8173931321A27F3FCDFDBB4347AE022080375F8D85D123 + 9EC1AC4F3679C28B3026FA599FFA74C7C6DC05C0FDE0E394193030E241AFF90C + 19FC6848AFFBAE20B80B80C1703F48FB701678B31F84F7EC090B585BA351FBDE + 8131BB8BE92200C218FAC460488E7B03B3AA36373901060D88546D134A95BA09 + 80D05E7F79BCEABA1E3B76348C1B796FBD9ED05500DC0FE6A5BCA3B81F3CF6F0 + 20983D231E75BAA78C8B0056AB0D6C369B22C8DEE1E1F0696A3218C2C23AEA71 + BDFF243509EEEBD1A3C3E79A69B97DDBB51852792E02DC6A6981ECA26FDC82C2 + D36DCAF4A91DF5A9097180773E1D8E2E9915EB0BBA7842A7C8ED5663E79E7218 + F66414C48C19A9480B9FEF1C3FF527180D469814334EB10D3A7794ED858AEA23 + 980D49E32600D2CADA6406FCB63F141981C5BBECA3A444C07DE1AE8A76C7D90B + F59067DADA5E0ACD84CB1224A3FAB7B919BE589505AD16ABECEA94E2B31E3C23 + 7472B6176E35B7C0A274F77DDB9B75FB84AB004807BFC5D9455B30EB93A5E717 + 4243E3259FFA74C7C65C97201948C98FFB61F8D3C3E085E786CB2ED574F7BE9F + 60FFA15F54DBF85289CB5CDA9C1418FBFC085FBADDD5B6EFFD7D40ED7D81DC61 + F3773BA1F0DB1D725135E5FE0B90A32FCF2980F3F517E5A2DBB4E6DC79C82C28 + 765BAFA5025F107D9D951FB017446A73D85956EE357C1C4737016EB7B6C2976B + D6B3FDC0827115AD99DDBE621B8B5579CF50ECE4A5D3D6D6068B3372E0CCF90B + 5EF6F0BDD9C123C720ABD0EC5347DD04C0599DABAB07BC33C2BC92A5E717B175 + BF49A92A203E14386DD91AB874E59F808CE73AC8E9DA0BB084FDCAEC76BBABDB + 635E57017036BBCA2BA1ACE200663B19FAF71DFCB9938F47E1CAD56B307F5906 + E01D5AA0C66F62822E58BE06B49CD87517002F1AD7F8DAFA06CC3A0C9785B51B + 4D8EBC1E1FB5750DB068D53AC04726FEC64321D398A028AC96B1822280EB7E80 + DF1A5EEBBE1A906327FF8015B905801BB45A3BB53A7CDEB5283D1B5050B5766A + 75BADC862A4D00278DBF044902A8BBD8A8D484BB6F6F5535E0297DC6546DEFAD + 333614C3B113A7FC9A67D004C05997EEAFC224A866DAF63DF4EBFB00E03B685F + 2662DE5E02BBF755FAD245B16D509620C59904D1B9AE700B541DFED5EB19ECA9 + 3C001BB76EF3BABD5A431280D1C15BC7256BF3E064CD195652FF3FFAFB495895 + BBC9AFBDC3350209D04EA3D56281CF57AE553D87E03966F1EA6CC0435D7B37BF + 1312C005E1F51B3761FED20CC0D4C5EDC85EBD7E0316AEC8047C4AEB7004E883 + 04E802B2A1B10916AECCECF4C8046F9BF1A0D578E94A97D6FE1749000586A76A + CEC2B2EC0D8E751EF787AF3273E1AFB3B50A2DFD7719FC1F223447A8A83E0CEB + 8BB73211EC70E8E86FDC2E5298109FCC8E42DCC6A7813D10A025C80320DED524 + 006FC21EC627013C00E25D4D02F026EC617C12C00320DED52840E05FC0F29E75 + E88C6F410182F3303E7420FA732517990052A53F23505FED04D801AC52045134 + 6B1F827AFA43400030310360A7E11FD8402F31A37FDD0808A565A6BC8922C613 + C20C6F31254E639E4C1702355649988E911C029416E5348559DB460902EC4227 + 1957022556491C556ECEBD8C51D8171F13A7C5C6278D95404804906200844758 + 8D8119FD6B2760632CEB18CB3DA20885BB37E757681F8A7A1201224004880011 + 2002448008100122400488001120024480081001224004880011200244800810 + 81EE46E03F67EBEC02047C01690000000049454E44AE426082} + end> + end + item + Name = 'icons8-js' + SourceImages = < + item + Image.Data = { + 89504E470D0A1A0A0000000D4948445200000060000000600806000000E29877 + 3800000006624B474400FF00FF00FFA0BDA79300000613494441545809ED996B + 6C145514C7FF33DBD296BE295D5CA49457454ACB435E091134180AB13CD46063 + F4831FD062349A468D1F8C89DFF4136A44FC4040A32662783421544050438C44 + 0984D8022D60C19497C5BEDBED73BB3B9E3376D63B1B10509919266773CFDE7B + CEBD77CFEEEFDCB9AF05E4250484801010024240080801212004848010100242 + 4008080121200484801010024240080801212004848010100242400808012120 + 048480DF0868893FA8BCA6BA44D7A3EB016D39C938C0189BD846F4DB21A0B512 + C36618388400B6ED5DB9EEB4DA3B1E802777EC183598A9BF671878811A044824 + FDFF04A2148C8F43C1F6D7B6CCDF10E18F3703C0F00732B41A1AF134EAD92C72 + 87091C4C0DC756EFACA818D2D9D14086BE49E03309C7A48C987FC0DEB4B55FEF + 288D69FA2FA498C1A05C923304A23A62B3F4A8A657923F814F101C4E8128F44A + 9D1681471C762CEE4608307B1EF90523BA64CE1328E4006438EF573C8E10C8E4 + 008C942573838004C00DEA8A4F098002C38DA204C00DEA8ACF24A5EC9B625A52 + 120A32B290164842C7E0007EEF0B23128B79F2F7DD150148D27554AF78DC0670 + CDFEDD369D9519B97978BAA818A563F2A16BB4CB662349F7D020BEBDDC84ED8D + F5188C46C9E29D745704E0567095154CC68B33E7DAC05BFDB246A5E08929F761 + 7EF01EBC79F4077040AC3AB7735FAC0153B2726E085F053C91A6A5574AE7A926 + D7CBBE78021E9B5C641BF9E7BB3BF161DD7174D2D4B328381E95C5B3C1D318D3 + 5E180CA130330B4D3DDDACBA2EBE7802EECFC9B381DC5A5F8BDF7ABACC05F8C0 + A50B387CF5A2AD7E417EC8A6BBA9F8E209E05D8F0AB19D763EAA7EAABD1525B4 + 305BB6E440C02ABA9EFB22002DFD7DC8A685D6A2595E38155B1B6A2D15DF5F69 + 32256EF05041F7D077F9D75FE5A76B576D7DD74C9A8657672F407EDA689BDD8B + 8A2F0250D3D4681EB654C00F8F9F882D0FAD40D5ACF998909EA95679AAEC8B00 + F40F0FE3ED633FE24A6F8F0D6E40D3B1ECDE426C5EB21CAFCF59689BA66C0D5D + 547C1100E6D7DCD78BAA23DFE1CB5FEB118E0CB1292E1A9D8A97860AB071F132 + 8C4B4B8FDBBD50F04D0018265F337CD5D880E70E1FC017E74EA38BCE016CB724 + 486BC21B7317E1EF4B0AABC6BDDC5701B030F60D47B0F3FC193C4F81D875E1AC + 6536F3A2EC5C94E6E59B652FBCDD15DB503D61CC1A0AB9828C4C14E78E8D5BAE + F68671B2BDC5D407A2C3F8FCEC2914D215C4023A019B467AE3CBBABAB6BFDA90 + EA6AF24C00F816F3A96933E23076D3C8FD8CE0B1213D3999B3B8F4D308B79409 + E95978A9E4014BC5F196E678002CE3D9CE76A801C84E49B1AA5CCF3D3305F1BD + BD4A83EFF32D7D2A5DB65965CE79C1E59CE572C2CE677ACE18249E8C735352B9 + 695CFA68D714575C2E782600F51D6D3614F3F2C7814FB43C5D3C3BBDC456C7A3 + DC325C0A77E31C8D704BCF4C1E85B7E62D36E7F9D0E80C3C189A606E45AD7ACE + 1BBB3A38F38478660A6AA2CBB3DAB63F303B2F6882E13DFC86E23966597DE305 + 765FD379D5846D67EAF0CEA2A5E03E5CC1412B5D78FD85F65A7F2F8E269C9CB9 + 8F5BE2992780017C74F204DA06FAB9785D19A27FB336D61E43E2655B033D3DEF + D71E071FC8AEDB71C4D843E783774FFCECA9BF27B5D5FB76A99B8A91AFEA5E96 + 430BE4334533C107276B2E8F1A31F08DE6270D75E635F38DBE1DEFF3D74E2AC2 + 123A74F1E758EDF8A939D27C05DBE990D6FA0F01B6DA3B997B2E00D68FE73F50 + C6A6A6216618E6BD7E2416B3AA6E29E79D13AF07DCBF85A01BF439B7D4D1E146 + 9E5903127FF7300157773B89F537D37B2311B0DCAC9DDBF59E5A03DC86E1867F + 09801BD4159F120005861B4509801BD4159F1C805E4597A2B3047A3800179DF5 + 29DE140217751838A018A4E82C81FDBA8ED8A7E4F3F64E39D441D27F261065F6 + FA9EF28A93F4515B4924394B60CB9E472BEA75F6991A8EBD0C1887B82CE20881 + 83C4BC8A3D9901D8595131941A3656691A3693314A22E9CE1020B6C6A650B06D + 153367171ABFA9525E535DA2EBD1F5805646F62924F6BF93C820E9B6080C50EB + 0BB4D9F906016CDBBB72DD69D225090121200484801010024240080801212004 + 8480101002424008080121200484801010024240080801212004848010100242 + 4008080121E063027F022693919A528D837B0000000049454E44AE426082} + end> + end + item + Name = 'icons8-sql' + SourceImages = < + item + Image.Data = { + 89504E470D0A1A0A0000000D4948445200000060000000600806000000E29877 + 3800000006624B474400FF00FF00FFA0BDA793000009CD494441545809ED596B + 4C1CD7153E33BBBC59C3C2B260A8C1E0105EE1D1C4712C1C9BB61179A9B595AA + 49938A4855A42A525A358D7F58A9D47FFD57B5B6D2A8F69FFE6855A7AED2DA69 + A5246E9D38698A1325B59D60FC066C4330D818B26B5858D8651F3D6760666716 + 767C6F197631DCD53D3BE7DE73EEB933DF37F73900E227101008080404020201 + 818040402020101008AC3504249E073E7F62B83C04B67D5867078A0B45A41802 + 630866A74D96F634B4BAFB62C5E61AD6317750ADF3E07761DE8922526204BC72 + 38D4DCD8563698D825669163AAB936FFE60BF0CD6122AB3322DBF792C222CC04 + 60B076149158109080192B1E021C2C6D0B1F05813CE59FE18F87008670C28517 + 0141002F6216FB0B022C0694379C208017318BFD05011603CA1B4E10C08B98C5 + FE82008B01E50D2708E045CC627F4180C580F2861304F02266B1BF20C0624079 + C309027811B3D85F106031A0BCE10401BC8859EC2F08B01850DE703C044CF206 + 5FABFEF89D7782F5D9790838CE1A74ADFB45A3708C1503660224D9F62A06F5A2 + 88648E80478E84769BBBC4ACCC0434B5BA2ED921DC82558FA0F85044D221303F + EC1C96C3A196C6B6B2419DC954C57AA6762E6377E76D67540A5CC64A4528AB31 + DD9CB6DB6BB66E2D9CB0EAE1987B004B831139B81BFD562BF8F8685092150EBD + 428A5562590FF8E2436FBE9C16EC07803C94D59C3C19206FAC7DB8C89261D8B2 + 1E20A5075F40D4573BF8F88850108886E959495FB270F580F32786CB4360DB87 + ADEE4071A1881443600CC1ECB4C9D29E8656775FACD85CC33AE60EAA751EFC2E + CC3B512C4B53BE20040361484BB741EEBA74AEB8B8DE06FFE45CFDF40C1B64E7 + A683C4FC445C4DF1387B7125D4CCBA12B2B3469E7FF32D013F8AC8FDF7A321F8 + EC83EBE0199DD66E2123D30635CD2ED8FE580514ADCFD1CAE395C989207CF44E + 3F5CEC1A05D2553B1158D75204DB1F2F8775CE4CB558BB9E3B750BFEF9D75E2D + 5FFF75373CF96CB596B748714664FB5E8CF534CA1D13330118A91D65C929301D + 823F1F380B03BDB717C40ACC84A1FBB311B8F0F9287CEF857AA84530E39D86BF + F4C1C1D7BBF0CD0FC59B14324EFE6708BA4F8E40C78F9B60C3A63C83CF6C30AC + F8A88533D3B3AA6AED550266AC648E961D1CBE095DFFFEC78B8B82AFAF109A8D + C05BE8A7EF1D64A7B7FDE06FCF2C0A3ED95521920FFEAE1BC6BF9A518B927D35 + 326FD23A4F0F3009C366BA353C0517CF8C199CB73F5E018D0F162B6FE6D1377B + 60F4865FB1536FF8F4C3EBF0E433D54A9EFE8EFFE32AF8A7626FAD233F03DA9F + DA04AE926CF08E4DC3FB47AE80771E7422E1E8DFFAE0D917EFA3AA2B56787AC0 + 921F62A0CF38EC6CAA2F8047765581BB3407AA6A9DB0B3A3CED0C6651CE3D502 + 02F4DCA91135AB4CB61D3F6982A62DC5505AEE8086FBDDD0F1D366906DB147BA + 8C644F7853D60BB47B355362776BE665918D40D4872A2CCED667A16CA303B273 + D2202B7B4E6667C3100947149F7E9C336683733A156CA8CA83E2B25C52352974 + 67C3BDF71568799AECAFF51849D78C2B4449EA10B40E870CFD73F7768F41107B + 002D21A95C9625D8F3EB87495D2034F9EA0BCBE32658D5565AB10E2EE19BAFE6 + 6F0CF8A0F9A11235BBE2AE49ED0155750560B7C716EA345EFFFE57A7E1FAB589 + 3B0243FB05BD534E823D438EC3B897F0E13E435F6FA5E9492580D6E9DBDACB0D + 18D0C44C24BC81AB967E93E182366BFA8A99598B77DEAC1C6379C01FD6575B71 + BAF16E93707BDFF84E25F87023F5F9C7370CADF59EFB0A4868427DECE97BA0E2 + 9E7C833D1A316401621DC9609070183314ACF04C527B006121E159C1CE8E5A78 + EA8775E0746551914168ACFFC3DE2E8827C8E0B48A3249EF012A763431D212F2 + C2E951E83C36003707275513D0EAE5ED433D505AE18092AFCDAD749037CDAE28 + 51E57FC19F84C71CFA4229E9AF98BEF53BEB29BD3DEA0D0D9BDDF0E2CF1F8467 + 7ED400FAF19B969F9D4707B42748C773222D83CA8C3F84FF0B937FCA589E68AE + 585833352549ED0117BE1855DE6EF551EBF0E08D364EF476D7E346CA96668343 + FBBB55335CEBF1683AED0FB40C2AFA1D3166B514BF5ACACA4DD36C2B51492A01 + 47DFEC05DFED8086C3CBBFDC6A98072A6B8C13AF7F3204A1505459BA966C301E + 45DD1C9AD2E2E895C1ABE3FA2C94C46DD60CC6159049EA105450649C7407AF4E + 182008C40D2BB431534F1636DE9BAF10A156B872C16338CAA672DF7800AE5C8C + F51A2A8B2795CA569224B50734E2B98DFE18FABDB7AE400E0E1115D5F9100E45 + E05F87FB0CD89494E782BAACA421A8FE01B7725C4D4E34471C7CFD0C3C814B56 + 177E3BF08ECD00F5B030F618B2935437141A7A1895E965DC1380F3A76FE98B34 + 9D76EDF1C7D99AD14225A904346F298193FF1E8291A1B9150F0D477F4210133D + CFFDDB4A0D263AF9EC3DEB8169FFDC89281D57BFB1FFACC147CDD8D364F8D6AE + 4A35BBE8950E07491633D63416C2732F352D66B2B48C67089A436D09CDA7A5CB + F0037CA8A2F5D9778C421F631ED8B6DEE0E7C8CBC0FA8D90916017AC77DEF57C + 2DAC8F9B37F4F6E5D42500E3D86AD2180F01C74DE2309BF20A32946567DB1315 + 8B7E362C7467C1B79FAB81EFE3B29496A9F181695878E9175BA0E9A162A04F98 + F17635FFE90783F8E166AEA7A865C9BAE256E4186B5B48169B6BF72763B5D148 + F813F476A25892A2912878F0438A6F3CA89CEF3B0B33172525516334DE7B46FD + 40F567F053E7BB7FE9513EECA8FE0545D9F0FCCBCD4071D5B2245C3D7238D4D2 + D85636C8D216330114ECFC89E1F210D8F6A1DE8E625C176241AA13CD093431D3 + 55BD9747BFBB095AE30E00559B955704720237E7EF21F8AFB0824FED633DBA2C + 5DBA3E1ED92D45E1374B8FB4B408D3B8133E74A05B39E2DE89F340CBD665F816 + 108DFEAC797BC96B4BBBD3B9DA961170EAD47076DA8CAD1F008A50529AE8CBDB + 97F8F9B3BAD165F97D2060371CB3FEAACA6F56CE58119C6712366D6FF3E6523F + 48514BDE0AD386188CB44A5A0EF095A6A3D26B56814FF12C2380824991CCFD78 + 1D4559ADE9A63FCD76C0CA87C31EC51E4E3709EFC05AD6F76F0C7A17A73104B3 + D3264B7B1A5ADDC62DBDC943611D13ABCE340F7E17163951444A8C80175742CD + AC2B21E621687EF9B986C1C7456662D0F5166744B6EFD51798E9CC0460105AFB + E365AD26E6C182BE573363C5438063AD42FF7F3C771E6B1D1E0258630A3F0E04 + 04011C602D87AB20603950E5882908E0006B395C0501CB812A47CCD411C0BCAC + E6789ABBD0357504702CABEF425C996F39750430DFE2EA761404A4985F418020 + 20C508A4B879D1030401294620C5CD8B1E2008483102296E9EA7074CA6F85EEF + 9AE6718F39C17AB33C041C670DBAD6FDA25138C68A013301926C7B15837A5144 + 3247C0234742BBCD5D625666029A5A5D97EC106EC1AA47507C2822E910981F76 + 0ECBE1504B635BD9A0CE24548180404020201010080804040202018180404020 + 6040E07F8F2A9E1072D527DE0000000049454E44AE426082} + end> + end + item + Name = 'icons8-php' + SourceImages = < + item + Image.Data = { + 89504E470D0A1A0A0000000D494844520000006400000064080600000070E295 + 54000000017352474200AECE1CE90000000467414D410000B18F0BFC61050000 + 00097048597300000EC300000EC301C76FA86400000DAE49444154785EED9C0B + 7054D519C7BF4D42DE214F424810792A8A0A16450BF22896822888B5542CEDA8 + 75AC9DE9A4ED385AECB463B59DB1B58CF681A2ED4C67AAA5B64A05F15144232D + D022A2808880BC9F0292377993C7F6FFBF7B1276B3E7ECEEDD249B40CF6FE6CF + EE5D763777CF77CFF73A67572C168BC562B1582C168BC562B1582C168BC562B1 + 582C168BC562B1582C16CBF98E47DDF6599E58B296E7180F2542295092BA9FA0 + 1407B57F0E2FD406B5289D859AA04675BF6551F1743EA7CFD2A70C82C1CFC0CD + 25D048682874313408CA8732A134A8DD28140D4263F91BA4156A37060DD100D5 + 41D5502974023A0A1D82F643FB60A433B8ED13C4DC204F2C7917FF7A38A81CEC + CBA0F1D058A52288577C2CE18CFA0CFA18DA0E6D8176414760DF8645C537E26E + ECE87183E0AAE74D3F88833D0DFA1274AD3A4E87626D80707096D54034D207D0 + BF958E43CD984DB8E9397ACC2030046701AFFEAF40B7406320FAFEF311BABF9D + D09BD01A680B0C4357D8ED74AB4160040E3863C01DD03C88B12019BA906092C0 + D8B3127A09DA0BE3D060DD42B7180486A0EB9903DD0D4D812E34239860D2B01E + 7A1E7A0D86A9E5835D216A83A8D89007DD057D07E26CE8F17870F4D02ED9B767 + AB3A3A47BF7E893261E2CD929CC2442CE63031E0ACF923F402541A6DAC89CA20 + 6A46DC0F7D0F1AC6C762C5FA775F964F77BEAF8ECE919935406E5BF043494CEC + F5C9C974FA19E80FD1CC185706812198FBDF06FD1CE28CE8D618140EAFD72B2B + 5FFAAD949D66C213C890A197C9CC39F78AC713D35332C14C8D33E667B8B3E2E1 + E2E98C3B1111D1D92BF734027A0ABA09621A1B73EAEB6BE495179F9406DC7666 + DCF8E93261D2CDEAA8CFD00CAD861E800E44E2C6C2FAFC277EBF96D5F07DD026 + 682ED42BC62067AACBE46C933EDBCCCB1FACEEF52938561C33FAD8FBD4588624 + A4413033B230879EC6DDA5100378AF5259FEB9B4B6B22B124CEE804275AF4F92 + 0B2DE558624CB37D0FE9311A042FE425F71AC4E01DD6B2B140173B48BFC424E9 + 9FC9CFDCA7E118722C5F5563AB451B43F08251B861D173B5F340849C3A71484A + 4F1F534791111FDF4FD2D333252B67A0A4A6F5978404BD47F47ADB64D5F2A7E5 + F4A923EA9173A4A665CAD8F1ECCA74C6837438091958AE938525A7A44B5C5CF0 + 3578ECC81EA9AAFC5C1D45464242A2A467644B56763EFE7E063E87AB6B761B74 + 0762CA3EDFE139820C02630CC1CDEBD055CE032E2859FD1739B8EF2375E40E7E + A09CBC41326AF43572E9E5D73A03E94F73F35959F6A7C7A4F92C6B31F72426A5 + 48E1E01172C5D8C9B86582E8A3ADAD55DE5CF99C9CFCECA07AC41D344C5E7E91 + 8C1E73BD8C183556E20D1794063633E7C028EC3C77C0D6750730460E6E96436C + FEB982BE7DEBFB6F4B63233BDDEEE10CA8AF3B23C78FEE91E347F64A41E13049 + C115DD4E65C529D9B97D833A720FCFAFAAF2B41CD8BB1DB3C423F905439D14B9 + B1B15E3EFA702D0C1D71661A000D5A5B5325470EED9453270F4BD1904B22AD85 + 0642D7CC987DD7AA92D5CF77642A1DF317C6A0711E876E701E700907B3A1A1CB + 9D03A7D6A0DB2B59FD42C0FB9597B2F9DA755A5B9B650B2E9CCF8EED758EEBEB + 6AB469B45B78DE278EEF977FADF9AB9C8D7C164F861EC7D877D8C1B9830778F3 + 75E81EDE8986EAAA5237271296CAF253B26D73893A1218491FD0A381B365E7C7 + FF75EED3D06D6DEC7C740F278E1F90DD3BDE534711C131BF43D9A063866441AC + BEA36E8F57949D14AFE683D12D0C1E7269905837748E139D39746087346296F0 + EAAB28E3425F30746BBAF7A7CB4B4C32BB8EEACA52C7DD98661ECFADE8A24B02 + DE93EE2837AFD09878B4B367D707CE7B4708C79C634F1BF8823AACF3106E7ECD + FBD1B2F6AD65B27F2F93874032FAE7C89D77FF441D054237B775F33BB27BE726 + AD319911CD9EF75DC9CE1D282BFEF694D4D57215361006E98953D9E90FA6BCF4 + 84BCBEE2191493C1339759DDD7BEF1A0BCB1E2596487C1019D817FF6BCFBB559 + D999EA72F970D35BB25FD3E4240CECB7DFF9809381B9E04708F08BE3608CFE38 + 88DA55114EF9F2F293EA28906C7C70134C73BF3879AE14169DCB7AFCE1FBD6D5 + 564A1D826663833E59608663223D234B9212B94E160CEB16BAAEEAAAD3EA9140 + 9826EB8C41F8DA1BA6DD8E6254FFB7DB5A7D81DE25F7D016FC8B1321D61D51C3 + 54F44C55993A0A243BA740DDD3C3ABA9F022F39F6F6E6E960AC4135D854E7798 + 37C0DC32696A6A900643D697935BA05A31FAB8C759190ABAC38183B80F438757 + 5A5BD8C672050761220D3213EA52256E1A3012EE839136C36B09FDB5A9424F4A + 4A958C4C66EA7A9868B4A07ED1919D3BC8491CF4868EC30C09EF6ECCE7EDC185 + E67A48F9829934C875CE6117283304C6B8B87867EA87A3E64CB9BA170867404A + 6ABAF1FD19071250E99B283724027CDF6CF877D3FB723033C3B46218F36A6B2A + D551207475FE35940BAEA341BAE4AE4899A15DC2699D96CEED54665A30B5197C + 7530D3494BCFC20CD4C72736143D063F4FCA4FEB079C332B2535C368B02454F5 + A961CE9B297E6585BEDDC2F3CE88AEB7368A9F2664F7311C4CEF38F5752425A7 + 391F3C141CEC2AB8161DCCD078259ADA257986A04A58F957A0BAD7C18B84B3C4 + 14F7F877C3A5B69F9F3AE264893A18ECA35CB9CCA641BA5415B1D2ADD5A4A324 + 33332F64D38DC6DC8AE2CF1400878DBCCA3118EB90CE3019C8411C30D1505F8B + 0C4D9FE9F4CFCA93A6C6066D1A4DC225226CB36CFBA0447B5E64E4A5AE7AB2FE + B4D1207A071E21B53515C866EAD551205939E6C0C860BB65D3DB72EC30370906 + 43B7316AF4F8906E8557B2896A5CFD2DC8D0743015676FCC54BC854AD5E9AA36 + AE7F55DB75264C89870CBD5C1DB9A68C06F9D4773F3AE8FF75451D617BBAA9B1 + BE43BC6A5919EFDAF11E0AB6A5B2ED43FD55467772C5B8294EFC3055D23446A8 + 1D2674A3E6012F08D98AA14BF33F6F7A013EFFE3ADEB64D5CB4B50896F36CC0E + 8F8CBBE646271189923D1E14236C28FED877EC9E75252F3927A8832D6F7F97C5 + 0FD1D2DCE404F2500C2A1C2E33E7DEEB14862BFFFE1B646115EA7FCE31E6AA1B + 64D234EEB7D0B361ED3F64F727C13D259ECFADF38B65F3C67F3A9D651D49C9A9 + 4E86D80EE311DBFFE16A8B8B878F9119B3EF0A78AD4B7EC919C2AD9151EFBC33 + D50884EBDFECA4B68B7DA970C6C846C13675C6022728F23575757A3F1FAA4267 + A54C97A483C19A89065BF1267CB3D9FFBCEBC21A83BDB329D3E777C518B4C19A + 38AF78B9A1F813E7219734E36A3765486EA19B2A281A2EB3E6DCDBB11CCB80CE + C1ED0C9F1B2AC3E2793186E8A01BF4B9A2E8D66D3AC32272C8B0CB65C6CD7787 + CD28C3B003DA1CF770F18D8CC8CF3A0FB9849B0E4255D991C2D930FEBA9932EB + 966F0704EA32431DC1A5D834C427139C55A6DE1703B653C187B9E2238106B87E + F25CF9F24DDF8AB610F4E7B945C5D31BE8B2C88B10BF17E18AB2D2E3C6D48FBE + 5AA7B8F878276565E0CB2FB8D8D9FE39FF9B0FC91726CC70628E3F959821BAF7 + 60504E4C34B7EE79A1B05AD6BD3627AFD0A9D04DC984EE3514CF9BEE2E154618 + 543442264E9927F3173E28578E9B8CC7BBBCA99F634F1B74B4DF7933037A154A + E541246C58BB1C8193DBB502E98FFA63FAAC85CE74EE0C03647C5C02AE725FB5 + 1CCAE7B212D65DC94C7943ED32A1DF37D546DC50B1AEE46539AA49B779814C9A + F655751408CF9B6D1A66769C0DA13A042EA187E2FAC13BDC48D7B1C94119E551 + E81148BB1BC51F36E55E7F65A9361F1F3E6A9C338DFB222D2D6765F9B2C5DACC + EDCAABA73ACB013184D3948B538FD218A4C3CCEA81C5D00A48EF87FC606BDBD4 + 5CCBCD3357D0BD8DAF82D7CF1EAE06C6108E31C77A71BB3148C0BCC37F301272 + DBA86F8137045C34A26BD0116A8DA2B7E152B3AE60A4EBE41A490CE118DFA7C6 + BC8320478827F0B25F08BD0519670A5B1ABAC0C8801DAA65D2DB3011D1C1B810 + AE33DD4D70D038B60BD55807A08D4C7822FBCA0B20EE5ED4F6454CAD87B4B44C + 494EEE952FCD448429954EE3722F2AF41E8663C9315DA0C6380863AA8017D0D1 + 72AD9D3B143A25F55E29375C695CD84FE817F1EEBD98C2806E5AC3A0BBEA4295 + 1D091CC39F42F7A8B1D512369B42F6C5E77099F77710BFD0E9B8AA83FBB63B15 + 7167B88A57605C6BEE5DD8613E7CF0136D2A3D207FB071D34237C05D793F80D6 + C0182113A6B00621BF424A8C27B2347E0CE2ACE97259FA7F02B75EFE197A0456 + A87C38822FEC44649076305BE8E2B84BE51710B741F6E81C3F8F611AF71F882E + 6A236645C48B80AE0CD20E0C4343DC0AF1AB5A345054EF73014277C49EFF93D0 + 2A1842BF201382A8075255F64C4BF84B0DC5D02428F4DED00B1706D38DD01288 + CB19F530066EDCD32D57B69A31DC4EC41F0E60EF21FC66AC0B03A66CAB207E37 + 7D533433A233DDEA6A548CE146AC5910EB98091093810BC5A5D125B198E31229 + EB097EC3963F12D0A58D22FEF4D840C1387C6FFEA8007F6A833FBB4197C612FE + 7C330E8DC0553806E937A075D021182164FA1A2D31191C357358BE737FCC5488 + 19DA688806EA6B7187F180EBBB5C70E757B6F8D34C1FC12CB58BBEDF7D33C144 + AF5CADA86B3CF8C35C1AE40CBA12E2F719F90366FC4133C69F589D17AF72C681 + DD10BFF3D7AEC350794FCD8250F429F7A132377E7185BF1A4163F157E7D81367 + 3F9F06643CE24CE3B6402ED3714B0B138AF61610AF600656AE2B73D300B73CB2 + 65C11D73DC7FC63DA9DCE8C5451CFE26C9018C785524055BACE8530631A10CC5 + 41E7E0B3514663F096C7F1E2F5FA3E87C7C32B9A06A1D81FA15178CBE3B66853 + 518BC562B1582C168BC562B1582C168BC562B1582C168BC562B1582C168BC562 + 891891FF012639FDF74190BB900000000049454E44AE426082} + end> + end + item + Name = 'server-interbase' + SourceImages = < + item + Image.Data = { + 89504E470D0A1A0A0000000D494844520000006400000064080600000070E295 + 54000000017352474200AECE1CE90000000467414D410000B18F0BFC61050000 + 00097048597300000DD600000DD601906F799C0000109D49444154785EED9D09 + 7854D515C7CF9B3590442081BA1412512C286E15030A6E88A245A4802B0A5590 + 165BB4B58055D12A285AEA527129B456EB5A2BA268DD455410B59AD852506471 + 814450541296ECB3BDFEFFF7BD192693992493D9DE407EDF77BE77DF633E32F3 + FEEFDE73EEB9CB930EAC85661E2DCBB6A201A269B62E28F685F58115C30E80F5 + 80F17A679813A6C3BCB03AD80ED8F7B0AF619B609FC336B86AEDD5F9DB3E40D1 + BA584E90AAE2121BEEECA1289E021B0C1B083B10E6802502C5FA12560A7B0FB6 + 0C4A6F28DC544A212D832504A92C1E88275CA700E7C046C07AF17A8AA110AC3D + 2FC116C356149697F971CC281915A4B2B8A41F0E3F875D04DB8FD732C857B027 + 600F41982FD4950C907641B6159768F8A367A0381D360C66B56633007B157617 + 2AD1B2C2F28FD2DAA4A5ED6654151DABE99A3612C59B6003D445EB435F334B17 + EDCDEEE5E9F1356911044D131DF39DB013D585EC63096C069AB28F8DD3D49152 + 412044010E7F805D06B3F35A16C328ED7ED84D10A65A5D4901291184751BE1EB + 281C16C0D867D89360643619A2BC699C2697A40B825A918BC3DDB0C9B0B4F9A8 + 3443C73F0FBF6E66E1A6B246E3527248EA0D83183FC2E119D811EAC29ECF87B0 + F3505B183227059B794C1888311C07E625F61631C82058297EFB10E3347112AE + 217A9F3E52E5EDC6E6693E8C39A5BD917AD8A5A8294F1BA7ED272141AA7A0D14 + DDA65F832223A93DD55FB415A65DA6169497FD35911BD1EE26ABAA6800C5B811 + C5B9B0BD5D0CC2B07E01A2CB2B13E941B64B10BD7F7FD135DBB528CE36AE7460 + C207F31E88F20BE3347EDA2548554D67FA8CDB8CB30E22A028F3E1E899B98E9B + B89B1A339A62CA7A6F75E06D850365C3E0E8E31A118B4B10B39FC13FD04D5DE8 + A03538623910A26C314E5BA7CD4D16C4600F9C9DBE0E31DA0ED3460B2B8B4ADA + DC9AB44910336A603A646FEAF4258B2168876E36CBADD2A6260BB58389C2E761 + 71FB9C0E14ECA30C45D3B5C2388D4DAB3718623085CE71803D2D6B9B6E3E831D + 0D51E8EC63D296268BBDF00E3112E710D80D4631362DD610D40E8EF4BD0FCBF6 + C125ABC054FD51A825EB8DD3E6C414A4B2E8584D346D398AD93AEC9A5634B74B + 1C834BC475E62912A8F85AEAFFFCB0F92FCD785ED3FD630A2AFE6B9E3625B620 + C52567E3F08271D64154EC76710EFAB1B8460D17D7194345EBD645025BBE915D + A32749E0FB4AF343CD60D07A026A095B9E6644150462F07A192C5B6687A4157B + DF83C53D768412C2B6FFBEE65511EFDBEF49ED75B749602B67B1B6C8123DA09F + D1FDAB8FCCD3DDC412E44C1C3837A90313AD5B57718F3E535CE78C1047FFBEB8 + 60DE3A8F573C6FBC230D8F2C145FD9FF8C6BADC35A3208B5840F7D136209F206 + 0EA719677B310E87384F1A24EEF3CE16D76970A54EA3C3ADD73788EFA355E2FB + CF6A6978F829D177B66B12CA5310649C590ED14C1088C189CE6B6051C5DA1BB0 + 17F714D7F9A3C47DEE5962DB9793EC45F984C0A6AFA0061E6E0865EFD7471A1F + 5B2475733933A85D705A513144F9C638358826C85D384C33CEA280A7C4D6A300 + 51855BF4DA3A09546E473F34E37394134673B9C479FA49E21E375A9C838F450F + CD26FE2FCBE1A4B72A016CFBF5107BEF22F3D368A9FEF59AD45C7D8B6AB21260 + 2604613F2F441341AA8A4B9CD0BF02C5D6273EE30BDB1055D80EC04773DCA2C1 + 187504BEDB26FE0D5F8AF87CE607AD8DADE7FEE2BE682C9AA59178D00A214285 + 043696E3CE6862EFD35B6C453F343F69E0FF7483D4CFFB9BF21BAAB624C63A4D + D70E2BA8D83D4DB58920A81DA7E3C06993ED033FC276C0BECAE969B99D458728 + DE77CB44DFCEF5331602DFD379FC00714FBC405CA79E207A4D2DFCC1C7A2A3A6 + DB0F2A16FBC15C13B41BB602DE25CBA471F12BF01DAB9321443803504B429D92 + 4841FE82C314E32C71B4BC5CC4E7A72034FC81F8D77D219EE508BDBD19AC390E + BBB8460E974E53C6ABD0D5B7EA53F5B068FBE48BE3982354AD570402E25FFF85 + 04AA76A8669902D0AFD4A289F27DBCD6F84CF2B8158284522A2141B6150FB469 + A2739A644A16CB380EEFA7DA6869F448E30BAF4B6073135F965A70A35D670D93 + 4ED3A6A866D6F7C97AE5F71C471EA63A730C4203DF6C35BE13C3597CDE7E486F + 255410EF8A0FA5FA92DF28B192CC2A87DF717497CDFF56272141503BFAE3F089 + 71963A6CDD0BD0668F510ED2F3DADBE241672A41C7D8228E23FA49E75933C47E + 785F09C03FA808A9CF8168A6EAC4BF7683E8A8B11A7C9FADE77EB0E6395486B8 + 8D8F3F23F57FFAABE80D499D351A841151AF60B4152EC8541CDA1DC3C50B9FBE + 9C5F8C17377ABB9E37DF15CF8B4BD08420DAF627E709D43AE548A7E9974B0EFC + 04830D12F8EA6BD4846F45472D6573AA3A78AEE68379FAF69DE2453FC3BBEC7D + F1BCFA96E868BA52CC851064210BE1823C8943B38E4AAAB1F53A4072E75C2BCE + 938FC30FDF2EBEB59FE3C66D51E987C0D6EF10FB6F4613B34E39DEB6E238E250 + C99D777353E78C268A4F3B850847DF55AD9AB0C0668855BE453C4B968BFF0BB4 + DCC96F9A5AE23E08F26B169420DF1F38506CBACE01142E3B4E3F68B7595B3A5F + 834A1A74ACE1305A7BEF236978E0711C9B651B9AE09E70AEE4FEFE2A3CF92EF3 + 4A185EAFF810B6EAEC3BD157E0E76B799DE12F0E12ADEB3EEA237537DE2E0D8F + 71EA405AF900821CCF821204B583EBBDB7C1125D7A9C104C51E4DE8E8003374B + 6F68907AF48219666AE894B9CE3A4DDC679F2E0D4F2C96BAD95CFE17117AC237 + E4CE9E2EEE8B634F87F2AFFF5C6C3FE8AEF252D1F0BE5B2AD59742CCF4F7A1AA + 355D0A0B2ACABCC1C791D37B322A06695CF4A2785E36D6C1342E7C411A1E79DA + E8D7F4ED23B5D367CBAE0B2E47D87A1AFCC285EA33219C0EC9BBEFD616C52076 + FC3FB1C4F095AE949A5F5E9BA90E6DBEAE494F1682827078D112343EFBB23A06 + DBFA4EBF992C9D665C8E27BB5025F36A264F971CF42382893ED6A6BC3B6E14D7 + 4F861AE77142DF547FF703523DFE4AD1AB6BCCAB1941691014A469D73483F8D7 + D295A1F942F4E518F863A999364BAA274D0B8D31F8FEB746F5091CFD0E56E739 + 932F12D7688E16C407532075B3EE921D434649FD3D0F8AEEF198FF9231940641 + 412C338941DFB1D368365003F21FBF57DC637E62E4C6C260FF45EB5EA8F24C0C + 6DC3E18DADFFF323B2E3B891B273289AB0B06849AFAB97C6279F939D674D909D + 23C6AB318C76A6CE5381D220284877F39879E8AC0386C3664639E7F29F4997B7 + 1719371E8E9BA870B862B3E45C7A8191D434F1976F965D632E93FA3BE6C361D8 + 246FC11F55D416D856856B0B64C7E051523BF30FE25F13738E4126511A040589 + EEE92C0253E39DAE9C04C73D47DD68FFFA2FD1572837D2E426BE0F57428C49EA + 663B8EEE2FFB3CF77795C9ADBF7381EC3C79AC9A74A06A9F7561A41B12845B1C + 5903F60F541F210C556B0270DCA78AFBC2D1AA3FA170183DF0C6675E925D13E0 + 94D1A3769E749CE4FF63BEF8CA56C9CE61E74BFDFD10820942EBA334080AD2E6 + C9C06921420F52FBBB39E814961A829834CC7F546AA6CE54595881EF608DC943 + 0FBDF686B9B87E9D04BE6D75B28195501A040589E8656598C86F831AE31A71AA + D44C9C865E769579113563F12BE8B72C5535C856DC533ACFB94665643DCF65EF + FC8CA020A94BB7C689EEF3470D419D271E275A7EAED4CE883291DCA6A1977EB5 + D45C79432AC62BD285D2202888751A5984BC514351F4C61D2547AB882912A655 + 3CAF2CB56AF4D456940641412C35C6EA47481B8DC8F1ED20CE41C748E322AEB2 + CB6A940641412CE5FDFC1FAF334B114499DDC299833ED68CC86463F6A134080A + C2B57096C1FBD6BB66A9299C111289E3C8435596760F40691014A4DC3C5A026F + E94AF16F8A68B65003FCEB8C3C57385A7E9E04BEFED63CCB6A389F212448F35F + 9A49FC016978880398BB615636DA8C728E02A679742F55706F614310B4BE1B70 + B04CE84B3C0B5F10FFC6DDBB1EA9DE3642E2489832676A25CBA143574BA79520 + EE0627E3CC8C6D8D1A0DF645EA6EBA0305D35973FC2332A502D8EFB0F73DC83C + CB5A3E292C2F5323634A90FC6FD5DA919607AB3380F79D0FA4E1B145AA6CEBD6 + 550DBF46A2FA2C3939E659D612BAF7411F42B825AAE5A8BFED5E9528646FDC39 + FC64F3EA6E9C434AE0D4B78626296429A17B1F2EC83298E58279CEA1AA9E72B5 + 9ADA9973D9B866F3A8F4C646719F3F2AAA7FC912D854AD308A6182E89A8D8E7D + A371662D9856AFBE78AA081C7BA72B269A570D38A49B33E15CC99932412DBCCC + 42561694977D6796770BD27DD387AC1DC60C030BC21CD6AEF3A7A82502BCF921 + 07CF25652F2F5503585DDE794ECDEDB21FCC9729640D2F85872A4DC296CAE212 + 36D26CBAAC0BBEB1FBC231E238E670A9BFF32F6ACC834B08BABCB1508D262A10 + 997997FF5BEA6E9967CC42B42EAC044722C20ACDA98E1064A01D9F61B3958ED7 + 45248456D055DC178C121D9D45CF4B4BA5F34DD3C43D6E8CF9AFF8154CE1A3F6 + 544FBCCA080AACC96A9FCD76D4BE1BB9DBAC41B85397C2F2527A46BEB2C1F2D0 + AF342C784C8961EB5D2475772C30969F99F856944AF5B85FA9DA63611E0D1783 + 34A92104CD167B594CA534112B1B60A231FFC9F9A149769CA45D7DD15435A1DA + 8234C0B80C8153784334BBE9F8002741BD629C6517BED56B118D5DA1A609112E + 12CABBE766FCCA66CF9D15E0B2E826629058B580AF96C84AB8C68493E0B8AE83 + 38870E413FE5A7AA6C21980DFD93516C4A2C41DE81451F94C802E85F38719ADB + 5CD0B9736E70E4BA900CF362C0A6477D174954415095188ECD8259AEE71E0F8D + FF7C5E6A7E3E438D9970FDB94560E034BBC7C6E6FB9C90D88E5BD359E75F374E + B217EFF20FA4EEFAB9E2BE782C7E6DEC9F9B4616DA75F74AB3DC8C98DFB07093 + 7A19D6D5304B8D93B407CE6CF47FFA995A759B61B82E6F66D78AD8DEA0C547C6 + EC41DE679C65377573EF5399E10CC335E92D0E97B7A50EF3AD6A4DD703642181 + 8A2D51E774A591D508BEB98F4C8BB42A0814E5B222EEF59EF503D7BED59F9AA5 + B4C3A998130BCACB5A5D15D4262F0751DEC6216ADC9C4DF83FCBD8E802DFEC16 + 7D93C508DA2488C9F53063FF876C25330B3A39F3FB76A3D83A71E5142A8B4BB8 + 5294B3D2F657173A680D4E1CE1567E3177C48C249E1AC2A68BB3D7B8F6382B56 + C064184EED191D8F18242E4108FE009BAD9FC13252FFB304EE52C3D7E9C5BD99 + 4FDC8210FCA16771F8252CAB532B29820FEA78DCA3A5C6697CB44B10823FF820 + 0E57C0F688799C4982625C827BD3EECD52121E2880A3E78B87B9135DC6B7E6C8 + 306CA6583312DAB9262923371085A9540EFD5A2AC79D46E8C0CF851809BFB038 + 69436910856F52580C8BBECC69CF85A12DA3A9A4ECC6D76E1F1209BE10FB27CC + DE71706B6F819D3EF63392B63562D20421F862DC4572188A7360593BB7B30D30 + 27758DAEEB23F19BE3EA67B446D29AAC48D0840DC6E121583F7561CF813BEE4F + 82103107991221A935241C7C61AE713806760B8C535EB21D66BDF9BA59365129 + 1183A4AC868483DAC2BD1CB9C7F95858CA1E8214C1A697EBEBAE8710497B917D + 2CD22208D9D6FB58D1021A5F08CF012FEE3896B6BFDD4ED8E1E5AB026F2E706E + 5FA57DAE9600A69CB4DF94EDBD0648C0666353F65BD879B0DD1B5E5903BEAC9E + 35E2EE8004D6F428FF8FBA982E32FA94A229E3FB8298A8A47167ED4C7D1FE6E4 + E8AC1F853D8EA6296363BD9668362A8BD07DD1E44814E96346C28E82A53A15C3 + D9347CFCB927C7E282BCBAB5DA1ABEC726B358AE1DD7D18A55156F62CD3901C6 + D0991980C36189EE7AC7A79EB305B9C0926BFA56A02624B50F910C2C274834D0 + B471EB38A664B81529D717B0CC7711715B3CEEC4165C78C80E1B07CF985BE2DE + 21DCE09ED36E36E0A76E35975B74D0415B11F93FEDD2997558D6CC7C00000000 + 49454E44AE426082} + end> + end + item + Name = 'server-firebird' + SourceImages = < + item + Image.Data = { + 89504E470D0A1A0A0000000D494844520000006400000064080600000070E295 + 54000000017352474200AECE1CE90000000467414D410000B18F0BFC61050000 + 00097048597300000EC300000EC301C76FA86400001BFF49444154785EED5D07 + 7C1445DB9FD97235BD9142124A08096008A10602848E5445942A2845407C05C1 + 82A828EAEBAB48B1BCA27C82D850414069D2A4482886DE6B42124A202424A45F + D9DDF99ED9BBC3CB650381DC8500EFFFF7FBDFEDCC3CBB33B3CFF4B618D56CE8 + 1806356DD7966FDAA2391F1514C8D4F3F06482D42AE4C7715877E1A288DF78AB + 680AC8FD48859F7C4233B46F1FF527924488C1804A8A8B494ECE75E94A5ABA98 + B67397F9F4A54BE251103B0C2CA6F23511354D21BCB737133F7CB0A667D3A65C + E7B0DA6C33F85705F83356678472F32474E6AC8852CF8B68E72E135AB0B0F44D + B0FE37756BDC887B7DF433DA0FA21AB2A8513487424359C45863284A08A5A408 + 68FF41C17CEE9C7078FB0EF3B6BF924C1BC06917D0240BD500D4048530B54398 + 0E639FD50E8B8DE1FB436EF0F7F5B128C0642268EF010125C18BDFBBCF2C1E3D + 2E9C4DCF108F4A123A01CEA9C0B3C0034002A4A0F169018CA6841C15DBBC191F + D73C8E0B486CAF42F1AD79A4565BA24CE08ED36704B4798B2977CB76D3EAB5EB + 8D3FC173B78293280B3C6CC018F98D18AA99B6F43BCFD49C0C3F420A036466C3 + F5A2F91EE4B13E6AC1DB0BEF01D1F7805D811EF4BEBB00D54003E0181F1F66E9 + 9303D4B9DF2EF0207997FC6FFA49792CD987BCF3BA3EA3417DF62D900DA4373E + 1450AB709DB75ED5CFDFB9D1BB44BA012F233F80987202C88A1F3D49DF47D502 + A4605A8C8C02FAC937381F2A60377737BC70E8539ABC0D2BBD889867090765F1 + 157FB2F0737743423CBF10E422E53B1E44A85438E49DD7F40B8E24F998087D01 + C0EBA97EE4FD37F504EA8A3410791D18240B571FB4C0A79B36E1767F3ECB9D14 + 5D865C630D9B0089E4A7AF3D848436FC77205357967E40A09B385A3B73DF666F + 68F3406481D7CFF991699374C4CB13D3F2FF2920274BDE5BB4090F657F9FF58E + 9B587C1114630DABE96A00F9BFB9EE868611EC2C90B9DB62B366A05302DF67D5 + F79E19E25588E0357F6284727BF64C37E2E7C39C04E7C78135A151E188D8C8FA + EC1F8B3FF3209670836220ECB967FDC82B13759950A4D204747F816590EFBFA7 + E97FBA76DC97102893299356799147A2B93C70FE179097056B36BA7569AF3A79 + 788BF7CD3850EE5AE345DAB6E07F07F7FBA3E26FDF8AEFB2F917CF4B8496C7C0 + D2F37E64F2582D6159B4129CEFB7D68B4AAFC333DE7B556F306558E2435992E2 + 475E7D5E970509AFAF55AE46827961A47646C61E1F915C8080034F6FF721CD1A + 7305E036C22272DF22A64B82EA58DA6E1F395E36AE5AE4298587C8754B4DA803 + FF01F4293C66BFE1B6D600E52C4987C002572FF224DE9EF838383F284D476D68 + 30B368C3F79E37E348790E125DBBE63CED50FA5AC4EE31A0820EFFF5BFEE4709 + 346109144FF4FF93B7F484E3D01A7076B7483D38D06AF0F8FFCE7433DD8C2F30 + FF882F79B297FA0C38DFDBC4D728826DB4F507CF8B049AB1364E9FA0A3C3185F + 016B56367622A044E8F6D60BBA02899608D6789B4EF99109433559E01C6791AA + 66C44673717B967A65933310202B5F19ADA5CAF81858139BB3CE46CB97476BAF + 4BA7FF893FBD86777003DCDA5A44AA094D1B724DF72EF3CA2127212056BEF382 + 9C33E65A241E1AC44D1FA7BB6EFF1E24E0ABA3B5F9E0D6DA22E262D4ABCD46EE + FCC1F31A390E01B0F26BE8EC4136A6430C0F43CE7044FCDC57F5C5F6EF433AE6 + 47260ED1E482DB2316111741AFC5811BBEF448215089D9B8FD1B0FA256E16DE0 + 4C07ED1E4AA878D47FE53C77D1FEBD980FFA92413DD417C139D422E57CA817CF + 74DB430E8187565EDEE44D82FD990C70F3B7883CBC080E60A69F5CE175F3DD50 + 16EEF22109CDB883E0ACB348391133C66A1789FBC0A30316D2EBAEAD793AD316 + 6F9178E8C12436E7D795D2CEA3F51D51A6AFF126E181CCCF5699DBA25265FE90 + EEEA67E6BFA65FECE5FE8FF8A7BF18D0E4B9C56FC3E5BB161BE7222196EB3520 + 513DC1D30D47491252971A49415E21B996992D5D38744638B7FF94705C22F26C + E125CB1D3502FE33C6688FCD7C4E57CB6A96B1618F19F59D52305110D17CAB55 + 85B8AD42C26A310DD7CC71DF1F13C1B959AD505AA688629FCE3F5C504C5A8251 + B0D83A0F5D5AF0BDBF7BDB6D4D88BF6D46DC01D09ECBBE21A17DA70474E2BC48 + 15B46D75927973B1816C02D76C8BD0BD81568D076CFFD26345AB4665BB61AFCF + 2F29FDF0FB52DAF23A66B151C6ED14C27EF7967EE7889EEA3656B38CC7A61549 + AB924CD46E9FC5C6B998FBA2EED7970669065A8D95C2F57C8236ED350B7B4F0A + 7FAFFCCBF4FB852CE937B03E6F71BD2DE8EC648EE5B2EAE815CFAF5D33CBBD37 + F3CFDA0C643411D47162E1A1E49302558AD9625B1E76B794C7E8DEEA17077702 + 654860B072CB5E335A9D64FA164C2E51060504CACFDECFCAD0178AD3215D54DC + BC7FE912CE2CF19CBD76967BCAEBC3B5871AD7656780442CB0A2C4E7D1B60997 + 0EFF0D2DC6AAE38F3DE6977ED96C32D9874FCD61F4E9245D336891BD220B5500 + D6FA5F0E6E5A5CFB8BC9BA15A17E8C4A5ED30124F0E021EF16975CCE9106804D + A12CE802B488E4FA748EE51B513F4FA489E8B94F7DD0375B03D1C2B5025ABD3D + 171516131419C2CA91B485CD9E1C9474E08EBBC4F181E3FA693A756BC18F8F0C + 659F75D3E0E8D44C510D750F1DE22805A2E691DC63339FD50E5DB2D94427CDF6 + 533B2720F74A8E1438A29BBA154B9381355CB5FD1894934FDA269F127E021BDA + A32F870A8BAC3913744B5E7A5233D46A94B1162AA77E6F14CE81CB972D364E05 + 1D2D8DF6D0E1E0368DB9511B3E72EF412D37EF37A38D99A3518FEE8FA2D0D050 + C4B11C5ABF713DFA7EF167E8B9AE57D1D83E6A2A56695CCB93D0F62382947249 + 3C0E09EB707C633EA663532E367CF08DFF82339D3C73166AFF30DD2D65585755 + 9900E61610143B367FC5A56C49B148565448C3DA6CCB4DB3DC92431D2AD50E53 + 0A0D3B8F09F5E132D3625335F01CAA3BE651F598D6D1DC63750399E886A12CF6 + F5C08896BD368F69E2BA784D42F0F250E675095D81FEAF89EA4E1D8436EF3882 + 7E9DA1456E1A8BECDD22EDAA84EA3F9DBF002EC75B6C9C835EADF96FD6BCEFF6 + ACE34BFE6485914CF9AAA43D5CD2457A65A0A890AF5FD2AD1FDD53DDD36A94B1 + EF8C805ABF58F80D5C8EB6D854099EAF0FD67C38A8A36A4C4C3D48F22EC05F47 + 05F4C56AA3181DC6B0D1612C8A0A6551BD2006B9EB709948435314BDBBA494BC + BFC430068C347ECE44F31D73DDF727342E1B450354F0B1E30BB79DBD2C76B65A + DD443985D40F62E277CC76DF1D645D3D68C3E8792568F1266373B8A43DCFBB46 + 881F53FFB3F1BA0D8FB7E52394938373700CEA9E51F38AD71C3827D2A9635A5E + 37849C1711E0C984D7F2C6817A0D76370B88A4658957A05CA77337B3814E6FC2 + 4F1FAC39F0FE486DB921F9CF5719D1A4AF4A12E1F22F8B8D05E55EC9FCE775CB + C7F7523F6135CA80F63DAA3D22FF507E09A9D2583FC6C8FBF737DDF6F76DCDD7 + B35AB914B4B84B3E2DA0EFB7988E2EDA6C7C1714409543ADAB0D0D829929C7E6 + 7BCE51399403254682A2C615ACBE9423F5B75AC928930D343CAE97D8847BCCBE + B946B91A2A7350C60F54A62A78ED09CDDB7D5B82321C9EEF2A62609B480ECD9F + A08BD9F591C7F26EB1F2546B04B0DA702E53FAEDAFA3D0ED70089B8EC7E8E944 + 551F309599652CA390497DD563A2821816899088ECB86237147A082DB748DD35 + B8B60DD9118ECFAE2EB6A8C7A0756FEA13DF1BAA3904A9B54CEBD1C5483B9422 + 9E500AD398AE2A866311ADBB6EC25E215C4214BC30074D1A8D086D3D2AD07A83 + 0E25570521B5BD196FC7E7572769B7E58D27346EBFBEACFF31C013BF0FB62EAC + C5FEC1C154619B5278EAFA33A85B537E38986EAE53BBA9908840A67387282E44 + 5E8C6FC7DDA70474A398ACA7325584E946114D1970758FD9378EC7BFBDA27F23 + D89BF91C6C5CAE9475FB859D2525CA711FD89AA7EB99E9EA7E19371532B6B37A + 80BB0AC2E6A0C5EDC7E486072D7BAB8AAB3B4E08698ECFBF578C8FE0D0CF9374 + 13BD74986E7770298A8DE4D0D174F0D4210C94FD9BF348ABC274E443864D212C + D41DFD9534B8E7AC40E73C9281550599B5CAF8F2F23D6649C91F1B0DD0FA3874 + 5E442BFE36A3C55B4D08E4D179E8B829C95695ED1B7068CE70ED1B602AD3AA74 + 015252AF88254A61F0D162D4218AA52B20E5612C39BBEA54382E65AEFB8140CF + B2B957825C1638B1E0604E21A1FD0FA740C3A391EF0CD02C98DA4BAD66ADC9E1 + CC1509FDB0CB44924E8B8507D2C4E41213A1634A749DD375A0069ACB4DFBC5F1 + 23E60ED384D172D7D9E83FAF2473CD4173145CBA6C7CEEF311DAE313BBA91A5B + 8D65F0F13A237AED17039DCAD82FC76E701BBE53209D7C72C84EE959120265D0 + 4920A7C16046DF4D5B6A68FFE8ACE293FB532189803F33571AC40F56191393CE + 087EA08CEE20361D48174DAC052E2704BDB5EA8039AAC747C5DF4233B25C38AB + CA37FBAA8341E92F80C965806E438692DF949DA3E44E4A27FA232BA479389BA8 + 949D4E5DA677A053F4C7C9D8F7E70921AEEDBB455387CC2FB986C9CD51E70AE7 + 0900A52959D2E869CB0C9B95C25A15B60C6751C786DC04305538FA5D55408326 + 5BC96FCAA6B559E4EB8669AFDDA290104FDC524973A9B4EC86F28FFEB8004641 + 427397269BEBFE9C6C1E05E62B16EB5B42FAED80F9BDB350C42985B72AEC1FCB + D1D5212E5BE0566420794AFE52D2FC0199826E56951552BBAE0F534BA9E372F1 + 3ABD03D1C91B57A204B818784E36DD1E472E6443B814C25B152642050F908B0D + 57A0D4480C4AFEDAD838880900B150C6478F631AD28AD24E633666E5D30B7495 + FED4144043A0767DDFF2F55D5549DF01CFBA6E611B84B8CC0CA2231B07C9A565 + 0CD32D8A8BA0DD0FD9C156AE59AFF34A08ED84D0659135066FF6544FA9EB0D09 + C82E9C657897761A78A48F0EBB6C4391BB1AEB95FCB5D9C99902FAE74C841F13 + 715388FEDB5D979AE4130E6ACA2907FAC989AA4FFED54135DA319C6558153B4B + 71EE12D472C30115FA0B76722243A83EE3A7C3A1E504AC1444521394E13BB819 + FFCA9AB1BAB3B3FB6926F9689C5F5C511A21A6502228CE733B03816E4C7D257F + 6D0CD063A4E1A00EF154A300A54A8612A20E17F7049A46B598011FF755AF487A + 417779C970CDACDE516C3043CFC35008A733782E0B529F2877465D01AE961EC5 + 28F96B2307710BF26002181583FC953446C933D5BB803AC00DB799D155B570CD + 28EDD5BD2FEA564CEDA01AD02E9C55D3790DA5F03993AB8F09B4262D337BE72C + A858D4AC4508EBA6E4AF3DBD75D89FE111F690CB3505EA794C15E2F22DCC3141 + 4C8F0503343B0FBCA8DFF34E57F5E8DE919CA78EAE9F5108932B586A4068C1DF + A60B605A07743AC6B4E27BD5D2DD3E3E6E3C7267388CD44ADAA2F4D662AA0C97 + 9D5E50C79B6936BFBF66DB9FA3741BC6B6E0DB85B8B9A67EB81DE72599D0C51B + 848EFABAA2CEC4EDC3B9414AFE3A52CD6268EC49900314B44519445F906BF696 + 6B26C5F3B3378ED4EE1BDF824FF4A315B582FFD5C174E8FC7EF497898ED7D1CE + A9D311EE85DB76AAC3462BF9ED4828143846920828052A1605867BC80A09A33F + CE02B4EAEA7CF7B866CF9C1EEAA90DBC31ABE46F759140653A61954128349271 + 1034FA5A9C8EC9F1AAC901F4881B05FF1D2911C230A288CC8E59C7C60696B6B1 + D3160534F4651A2F1BA8D9FD740C17CB401894FCAC4E2ED867461B53C48FC0E4 + D4116D1B02DD7093DE11ECE34A7E2B51109189310BA8C831EBD8D8D897A14B77 + 14C7F0EF143E5A1C36FF51F5A6C4303648C9AFEAE6E92C094DFB532EAA5CB2BF + 85627A3BD57F223CE9A211305482252664604A4D245F495B94015A8C22BC1967 + ECBBE66777562DEB14C6062BF953DD3440D53DFC77435181910C031B97747E3B + 86B17D0645737D94FCAF88370C24972932A26B4ADAB231AE16130357B414BC6B + 8C69CA4D1DD6886BADF4FC7BC197FF34A28357A58960725547D0F3B5D6FC17FE + F47C4705FF95488059C52487C92E96321D2B177BB60F61E8EAED321B76EE1001 + A39AF06FC89D1985E75737979D34A32F0F9A698BEA7B1A245760663BD5173DEB + B0614AFE57C4825209E519C81526ED064953D2988DDDC2E461613AAD7A5798DA + 9C9FD2A616E3A6F4ECEAE63968E24ED86C3A0CAFC065D3B543A2B871FF8AE586 + 29F97F2BA6E741A8104A63922E8929D0D2022D29B381078362FD19BAE4F16EA0 + ED1EC68E557A6E75B3146A8A216B8D85900A07830D9D14733A1282D9C4B75BF3 + 9F79F177DEC13D974B2FD079E67211397E3E0F0C0E1AB367EF3A6C13B8A2AB32 + EE08ED83D9C71383591FA56756375FDD614207AF4974DEDC25F546231F26664E + 826A65A407A352F2FF763C91232BE404ED689C387A4D82BE48D932CD9E432338 + 3AF27BC7EB6187346087F174C058E199D5C9AD1744F4E53133DD2BBEC41232E7 + A281276EFC5547D5A696FED85BC9FFCAF0F035896AE418554849460139AE948D + 6C8CF6C2A863303B124C77B22AC3B38937D345E979D5490952DFD45DA67C88F3 + 64B0713AE2FC98568B3BABB7270432B594FCAF0C690BEB50B6444FE92E94BBE2 + 87B3A5DD4AD9C89EA31B42AB0155FE8CC1601D4E68E90B2D3485675527B75F12 + D1911C896E57BB06742A7A87B1031727AAB6B6F567FC94FCAE2CCFDF20E84211 + D90926CB32A055E9C2F6BC529A75C050019FACC341058FE997082A85F6814C23 + F9987585675527F7428F1C404FCB7626D4931A73731624A8963DE2C5E895FCBD + 136E834403D8417F6485149AD1D6ED97A11E71D09C3DE9C4C8F3D13CDDA8D801 + 785B0469712DA5E75437F5F2BE64E721DA93895FD251B5F7E396AA29C16A8C95 + FCBC536EBA44BFDD8036032D0A01E41ECC11F7285536F67CAE014B7349A5C67E + 340C8294A3FC9CEA64BF10080887EEE854082578A970EC47CDF9A57F7455ED1A + 52878DA153AE4AFEDD290D6682B65C91E8989ABCDCCAA610B43C5D5C69A40B39 + 153468231D3F99DE84EF087FFD80B704B41918A5675437C3B518CD88E19F0353 + B91DAF95409D7EB5D9490BDBA8920FF6561F7C259A7B0A9EE7945C61E36628AE + F28C841E0322C33E3FD75EDD5195DE2784BD654B8A2AB6EB5663EAF62C89F64D + 0C16DBF298D490FB6C5E73DE991BF1EF1A1064F46DAA685C7E41FC69F355719D + 4010FDD20E5DBA6A0B3FDDE9EE0FA55B9D76FE4C74C70026AE813B9310E38523 + 1FF1664003AEC3D05D26F24B8648A738E47359CAF8352992DB342F8EEF663556 + 88C3D0916CF7A7F1835211D1BD158A185997FD60716B15FDE2418D428E91A0B3 + 8504651B08314A48A0558C9E455C8006E33A7A8C7CE8AA41576AC00E792682C2 + 571B76150928C16A55B65F71BA80984686B303DD692869B2AA8081D07C12096A + B33D5BA2AD17C5531D7CA1CC1D11C67557BAFF5E52C760140AC558943B831B7B + 306C2377868D7063709006232D3DB842E11E5771E17911ADCE94E807648E0065 + DCAC4328F2CDE4B79F3384AB8E158F125F8FE4F8CEFE0CFD1897E261C927F2C9 + 5591AE3952B8F77F24D061256841AA403724FD6A796316945108C0F46DBA389F + 0EC4295540F6E4E1B98B9AF191615AFC35D894CBE4594672F15A051B1DFF4784 + D6664AE86401A127CCC9A712D9E0A810741C847EBC20162975601C190ED9FC9B + 587E1094C1D3C0C61169E7E9AE5B85FB1E76D263AE3E3A2B5045D01388CAA09C + 4200D7BFCE10BF28BD4D13D8C6CE3E0CFAAC09FF3E543B43C0C61E99E945A4C2 + F9FA87997F5C91D09E5C89E68E72C3398A4DDC4C03391CA442E35A79628D5265 + E4C866EE18438FB8EF9F39D221B0B16DBC21095ECC80782F1CAC74CFC34ADA27 + 1F7AD85C70D5287FEAA9DCBC4C457D8E9273C5040D0964BAD25689D2831DD9D6 + 9361350C1EB02557A22D063A7289EA6971ABDE7E4C9C92FCC3CA45D011FCFA92 + F40E98E8819DE550612730D72C1F7737A4AB37E3A3F46025B6F362383F1E0FDC + 9227A54323E2283C23E4F910B60F56907D18791DFA1D838E08E78A44F90337B4 + 002B875BF5CA85830524B593173334940EDB2A78A0C456B46DAF631EDF9E47C8 + 6523D932C09F1D5F8B4E692AC83E6C7CE18C4876E54B74A24F2E4194702B8520 + 81A073A9A52872901FFB88BC6A44C1132546EB30CE34914EC905E4E3166E7864 + 333D53A9BAE841E61FD725342D55A0A7B9DEF20B12B75408458681EC80F4FD74 + 274FECAEE45145BC2120B42247DAD540833DBA7BE12825998785D9D0AFEB7F42 + C82810E54F055638FE47715B85004AF61490E32DF47858033AFEAFE0A1127DE0 + C99F664AD72E9BD09E09B5D8DEAC82CCC340DA311F7C5A100F16113A425E6151 + 6583523FA41CA0E8DA38F9BCF89FF4DBCC2ADA3398C3088AABEE1946B26E7B1E + 1D2B50967BD0F9DE0511ADCF93E85121F214EDED50991C222357407F1D2F41F1 + 03BC98FAF23E37BB5450112F9A90EF8E42B2B09E1AB74A74634294641E64AECC + 95D0A40C71195C567AEABBD20A01903423597BC9441EEBE7C1F8C959CB21008E + F4875CF255B69493654607C7F8B1DDE53DC70A720F22938B087A3255483648F2 + D14F955ED05D6E50B012A8373980D9353B980DACCCCC4DFBB3C2F9DDC5A4C3B2 + BA6CDA135E8CCBF72BD6049C3410D4354548818448E739E8B1E695C69DE4101B + F2FE2E265BA1E3F754271DA3554A1DF684DE8FF7DA02B25183B1C763EE4CB492 + CC83C47346821E4D152F649AE529E3CBC03BC2DDE4101B5A4DF76736BE5B8BF5 + BAD5434AA0628B3A27ACBF2A9059C9F5B86DCDB455F1B266E3345546BA78E982 + 99506554F6309D32B89B1C62C3E5A412B2394F4003BAEA18BDBC454D81B48C2A + 9650C4D662F219D421B1BDF44C6D25B9FB9DFBA005DA2B4348B92CC8270A55F6 + BB25E5E08CE41A35D88359B7A01653CFADECD9FD3741D771C6A4096BB245343F + 298C5BDF9CEEBA7D80B0BA484223AF88FB0A2479354E954E4FAA4A0EB121E7B8 + 912C4D2A25F11DD528CC9BBE6B87D4439774F01845AE2D268BAF8B24E8493DAE + FF200C38D2A5591F42D376E235E937C820F4C870FABDF82AC1190AA128BE28A0 + 1F7F2B26FEF538DC224AE1432B712A8CFF2C252D36979271A12C7AA6990ACB0B + E3EF57E6426B657896287E994F664035F922D83A65AFA2B314422142965DF76B + 11390D81ED96A0C21A955D04681D13ABC2014B8AC9F53D06B2B6A706F7F4A7ED + 663B99FB855B213BF4CD922E251B09ED63D0AD71D4C52970A6426440C84EEC35 + 929FFE28214DEAB1B87E7DBB2545C150C740C5DEF6F75232EB801169FB6B9926 + 7AEB4DF7030B20574CCD93D04B79D252F8A3F505FD4C9253E1748558919F25A1 + 1F7F2E21E7CF0B24A1198FF572DB182215AFC2CC5901F5DC6424CF1C329166FD + D4384CFE408E43E46B12695DB1B484A081D7C58B5B8C640418FF0D2E65568B38 + 0BAE52880C08F891A366B4F0BB12C2E74B28AE298B399A237AA8B15BB21975DC + 6A22830F9A51FCA33C0E91BF4D6A7D0135893B4D048DC823A59F14910FF389BC + 90E338D065A0E9B6BA50C79F416F8ED2E21113B50C4F176E0FCA970E6D359341 + 2D79FCE5F71E4C974897268F3B439299A0FF1413F32613F906F442BFA4502D5F + 14AD4E85D810AAC368F240151E35508DBD7E3192B49F8C64482083867CA0635E + 1CA1C62E5DDC7C2BD099A3159023BE2C25457B0442BF47350FE8EA6372CBE05E + C59D82965E839BB0F8992C89B4C826A8379855BD78FCC55B1A5CAF156D3A5703 + E8B445B240D0CFA088E566720CEA3EBA12932E91AD729FE26E702F15628FBA40 + FAE9537A183E3DB1755C4F1E4F19CEA3B03EA018B925E644D02FCFEFA0B36E02 + 429B0492922EC9DFA6FA057818486B8F7B869AA21025D0E9939E9E180DEAC0E2 + 1EAD18E41F07754C14349D4320D49519C7A78B2F2FC3EB4D91083A0559E130A5 + 48328F4B6817E822099C37026F3BAD5A9DA8C90AB1079D0FA30717D0CF663452 + 23542F18A3205F8CFCF418B9F3086B418085F72D9810311612549C43D0F5AB04 + 658352E807F8E960DF69205DC4579933E6EF1110FA7F1C2F8A6483B809ED0000 + 000049454E44AE426082} + end> + end + item + Name = 'server-rds-mysql' + SourceImages = < + item + Image.Data = { + 89504E470D0A1A0A0000000D494844520000006400000064080600000070E295 + 54000000097048597300000B1300000B1301009A9C18000013B549444154789C + ED9D797C54D5D9C7BFE7CE4CD6C9BE02595992B089288802868255C08DB62ACA + 0B822056A9FDB455D1DAB7D5BAB4A2F811D1EADB564105D7B6168BB228A8B46C + 15411002610B4BC84676B2CF7ACFFBC72493C4DC494232779280DF3F60EEC99D + F39C99DF9CED39CF39574829F92E63C6DCDB26AD254655526F94144706111091 + 8630F983EA44204195200442012941550DA0A808E1FA9B1402848270AA804428 + 2014056977F41346BF3F06C7268D57845223A5DAB6605E4455A5501411929214 + F3B5BFC9F0BF5255F3A504890045601002295554A92285409102104845454809 + 085404420A8490180C028BD5C9A9BC521C81D528460952B45B86434FDCD626CD + A8CFC73D2F62A5CA1229C4022104ED7F04EF23205D51C49D0E2956A3CA478122 + 1F17A1154A0FDA8E4788374029061634A6B9AA8DEF902DECCDC5200A85C22A90 + 037C588656F48420FD84E44DA1882221C4FC1EB0DF3E82B902F225F2ED9E1046 + 7741A4FB1FFA23C42A0551289077E96DB7BB4829E74844BE10E21D20C1577675 + 15442200D95F085609290A0462AE9EF6F441CC561079C07B2013F5B6A69B2052 + 8A0102B9DAA0C802017D5088EF209885E08C80F700DD84F1BE20820404EF00F9 + 20EEF47AFE3D8D14B3403923051F00C9DECEDE9B820C00DE4128792066773D1B + 5F0EB2A0ABE36C21C5ED0A9C16820F902479AB38DD144480205120DE17AE1AD1 + 0D21FA2AF27604B920FE81176A8CE6C430D06668F74D8A74605524A08E077587 + 70CDD12F6A8410B74A55DE2AA59C8041EE541507AAF3FCAB9FA6207951F51EDF + 208524C81680C42F4D416C40C3F572D1222542B25134F88D35FAF91DF3331AD1 + 724DB587A620B951656D1355097E028204215509E6909AC04D8A748409491D10 + DC95F25F7008EA8050B52E605380EA3F3236CCBFA65E01874169F47F758CB62F + 2B4EA38F3229182BAD0416DB08C4B44EC199AC4283CF9D4FBD9F068391643BF6 + 75672D725258AD9D08AB0387D2B92F4A5B90C41682B81C9B10E78F7F56157147 + CEBD6509572639153B42F6A42BACF7A228E050D5CC4AAB73556C61EDBC84F23A + 9C4633AEBEB6FD9AA22D88CDD6FC5A4884AA12BCAB928012FBE39610394F152A + A2856B39392E94E9631219101D4269553D874E97F3F59142AAEB6D1A995FF848 + 40416046CE3D17137CF250B8F26441403E0EC58EA18381ADB620A1A1AEFF1505 + 9C0D88BA7A2272EAE6280D3C690B3321BEB354F1938983B9715C2A71E14154D4 + 581891524EFF28339FEF3D4D6179ED797E1C9FB7814D6D80D7313825D541014F + 584CF2E4E9E0FCB79DE62A0894A07A3627B44601226328A0427D15C11913094A + 1835D15454BE4DA82DD65CA40A8886FF7BFC67A61913D2358575AA9235DB8FB1 + 62C3018EE557B45B78A93A518C7EAA39265108A10829D5CE7EEE2EA1AA124511 + 3235394606F8191587B37BF68C4603F5F5D6BAD379658A844045B8BE28814045 + C516599459B1BFFFB6B2ADC320AC0114893C9CDE361FCDDC8F1E71BF0CF42F4B + 09353AD737A820155A4DA4AFBA64B0D224C69AEDC73859788ECBD3E299342A11 + 45080C8AE0B6CC746ECB4CE7ADCF0EF2EC075F61B53BBBF5C1FB1AAA6B5D9178 + E2D73BCB52469515279EA2D8F3FD1E570C838362081D3935C069366FB488DA50 + 97E3B6F53D53C60E3300FC37BB8887FEB2C59D3E203A84DB7F90C1ACC943890E + 0B04E0AEA92398323A89FB966FE2F099F26E7CC4BE45D31A6855B50CF11F56F0 + E990C4924BF3365ED260290DD3BCDF630FA3F807614EBEF413635078866AB76A + DE63773800301A5A67535056C3B20F7733E9A1F759F6E16E6C8DB5222936940D + CFDCCA03B78CE1471386306D6C2A999724921AAF5DB80B09A7D5847F787D5AD4 + E8DC75C660EDEF133CF4213157CF0B3298FC971BFDCDF7786CCBA5CA986103AD + 6B5FFC953FC00DBFFD90EC5CED5FFE80E8109E597035999778F65A1FCDAB606F + 4E89DC9B6F65C7910A516BD17784E6AB3EE4BB084562ABF55FE1B4197E796C65 + 661B9788660D09884A5C6C0A8EBC47AAEDB7F77BB24FA9BB8F163A015E5C748D + C7FB0ACA6A98B774032B361EA0CE62D7BC273D3192599333C4F3778E121B7F3B + 91876764101E6C6AD77E5F443A150222EB169A132A166BFD5DB386F49FF6AB25 + 021E6D3F67D7286B60C668B9EDA5BB8200566F3EC8EF57ED68F76DA1417E8405 + FB1317114C48901FA1417E2444873071C400AE1CD67A09BBBAC1CECB1B8EF3F7 + 9D79EDE6D915DC3524294606F8FBAE863421A57C366BD9B4DFB4C9C7C3FD8ECE + 1624AFA45AFE7AC5769E5B3891B9D78E60F7D1B3ACFBEA84C7FBABEB6D54D7DB + C82BAD6995FECABFF6302C355E9D35F57271EB950922D0CF4068A089DFDD328C + EB46C5B364CD614E149FEF9CA657A3F91D7BC5F7F18FADC7F8DBBF5D43E53FFD + FC87C4860775299F2379153CBFF688BC61C976DEDA72CA9D7EC5E0483E7A6402 + 77667A7D81AED7E13567D4A32BFEC389C27300BCB1787AB7F22AAFB1B16CDD31 + 7EBC7407DB0E97BAD31F9E91C19F165C4668E085D7B734E155EFE0BCA51B0018 + 9E12CDDC6B4778BC6FD4A0586ECD4C67C8808876F33B515CCBFD2BF6F2D80707 + B1D85C038C49C363F8E891098C4E0DF75AB97B135E15A4A0AC86A7DEDE09C0EF + 665F85C9A89DFD806833CFFFF4076C7A6E26E387751C8BB676770133966E67DF + A94A006242FD59F5F371DC3CB6BFF70ADF4BF0BAFFFCCDCFB22828ABC16454F8 + C9C434CD7B36EC3AC9B31FEC02E0B507A7121CD0711354546961DE2B5FF3FEF6 + 33EEB43FDC319285D70CF44EC17B09BA2C68ACD97E1C805993877ABCE7AFEBBE + A5AACE4A7080094327176F00967C7498673F3AECBEFEC5F543F8C5F543BA5ED8 + 5E862E826CCBCA075C7D457B23AE573FDEC7E77B4FB75C37919D09037A6FFB19 + 1E79E780FB7AE13503BB2E4A2F5BF1D445903DC78AA8ACB100306D6CAAC7FB5E + 5FBF9F7B967DD6251B9FEE2BE2C155DFBAAF175E3390F9933DDBEA2BE8228894 + B076670E00D75F31480F13007C7EA09887DFDEEFBE7EE0C634A68FEEA79B3D5F + A0DBA2F83FB71D0560DCD07E8405FBEB6586CFBE3DCB92167DCA73732E6170BC + 59377B7AA39B20074F9791DFE81E997E85BE23A1F7B79F69E5EF5AB1682C4643 + 2FEB1C3A89AE6123EF7C910DC0FCA923F53403C01FFE99CDA1BC6A0022CD7EBC + 386FB4EE36F54057413ED8E26A4AD21222183754FFB6FDDEBFEEC1D918803169 + 780C3FBAA2C776A675195D05A9AAB3B26AD34100FE383F534F5380CB5DFFEB16 + C3E1A76E1FD1E7D654748F745BFAF7AF51A56450FF707E7673679A91EEB5FD9B + F69F65FB91E650D867678F6AEFF68EE2D67C8EEE82D45BEC3CB9DAB568F5F0CC + 2BF8B107778A37F9CDBB07DC31E0E3D3A3189F1EADBB4D6FE19358D0D59B0FF1 + D91ED7FAC6B2FB26332C394A577B55F5765EF9F4B8FBFA77B70CD3D59E37F159 + 70EE7DCB37712CDFE5ADBD66B4FE0B4DAF7F7E92CA5A974B26212A90B1832275 + B7E90D7C2648809F9170B36B82985370CE27365FFBFCA4FBF5BCC9293EB1D95D + 7C26C8B4B1A9C4860761B33BF9CF81331DBFC10BACD9958FDAD899640E8D213C + D8CF2776BB83CF04199EE2EA5837EE3E45BDB5D33114DDA2C1E6646B76F312F0 + CCF1BA6F33EF363E132473A4EBCBF8FBBF8F7470A777C7A16F6E39ED7E3D7BA2 + C646A45EB63DD22782C4470493961081C5E6606776812F4CBAD977AA9213675D + E14311663FA6F5726FB04F04B92C2D0E80AF0EF7CCC9472F6F6C1E022FBA4EBF + E5006FE013419AA24BB273353693FA802D074B28AC6C00203536B8570F817D22 + 4842740800C59575BE30A7C92B1B73DCAF1FB8517F6F4157F1892051A1AE3D22 + 350DDA81D6BE60DD378594D7B8268A2392C21891D43BB740F844107F3FD7C910 + 7687E768FA1BC60DE2B22171BAAE2ABDF165F34471F1CD6DB793F5067C2288DA + B84661326A1FD9111F19CCABBF9CCACD570ED25590BFEDCCC3E67045B98F1914 + C9F0C4503DCD75099F08D2B427C4EC21206EF5AF6F00E0CAA1FDD0332EC7E650 + F9C77F9B977A17DF9CA1F4AE59888F0469EACCE322DB9EC0F1A30943DCA3B0B4 + 840871F9C0F6E37DBBCBCA2F9AA3EA2F1F1841525480AEF6CE179F08925BEC5A + EBD60AAE9E3929A3D5F54FAFD5B7D92AABB1F2C99E42F7F5C2CCC45E751C854F + 0AD3B4EB766C7A7CABF4003F23A307C7B64ABB2A2D4A244405EA5A9E173E39EA + 7E3D2A29444C1BA1EFFACCF9E01341F6E594E074AA449803DC4E4680C1FDC309 + F0736DE2FACFFE33ACDD9923011EBA49DF794245AD8D17D71D735FCF9F388097 + 66653063742C417EED9F15A6373E11C46273B065BFCBE5DEB2891AD0386104C8 + 3A55CAA32BB7A9005346C432304EDF139F567E71924FBF3DEBEED2132203983B + BE3F7FBE7318774D18407C987EC17DEDE1B3F673F5E64300DCF1830C9AF64326 + C5360BE270AA58ED4EBEC82A9600BFBF6DB8EE657AE4EDFDF2B71F1E533FCF2E + A7A471D2680E3070D3A531BC3A67280B331308F6F76D8DF19920DBB2F2C92DAE + C2CF64E089B9135D892D76AA96348EC45EF8E4A804189D1AC19569FAB7ED070B + 6AE5EB5B0B58B43A9BC7FF95C3E6EC726AADAE09ECF491D1BC327B28E30787EB + 5E8E267C3AC278B0F1F88DB9D70E67F1CC2B1897DEEC0ACF29AC0490F9E50DEE + 358CA7EFF0BC2D4E0F0E15D4F2972D79DCB73A9B57BF3C43698D8DD040230F4D + 4D61D1E4443AD8E9EC157C2AC8DEE3C5BCFCD13700DC7FF368AEB9CC15EC60B3 + 3BF9F64489FBBEE5EB8FB3EFD439E2C202B8F75ADFBBCB1B6C4EBE3C5CC1CFDF + 3DCCBAFDAE15C71F0E8B62F91D1924EB3C02F4F918FCC57FEEE1A535DFB8E3A6 + EA2D7616BDBCD97D1E4A130BFFBC9BC28A06EE9F3698F8F09E99BC399C9237B7 + 17F0D4C727A8A8B3931019C0B23BD2993844BFC96B8F4C8A96AFD9C3A407DF63 + EE73EBC97CF07DBEDC97DBE61EBB5365E6B2FF526F75B2E6E1093D50CA66F6E7 + D5F08B770FB3ED982B8CE981EB92F99F2BF55979ECB1596A5E690DDBB2F229AF + 6EF0784F75839DEB9FD94AA09F8165F32EF55DE13468B0AB2CDF9CCBB24DA7A9 + B53AB9E5F2381E9A9AE2753BBDCA6DA04545AD8DAB1FFB9241F1666EBBAAE7A3 + 46761C3FC7BC15596CCC2A63FCE0701EBC2EC5ABF9F786471E7548ADC5C18CE7 + B6F3C88C0CC6A747B1F3A8EF0E401340BF707F6242FC88083211E8A750D5E020 + BFC2829430614838A535FDF9DB9E920EF3EA0CBD5010CFFEF0E73F3EC2FCC9A9 + 2842B48A70EF161A43D90093C2D8D430C6A48492161F4C6C48FB0176D34646B3 + 3EAB9C5A2FAC50F742413C2325BCB33597A997C6931C134C6EA977D7E88580BB + AF4E60C290704203B4BF9AD21A1B157576CA6BED9CA9B070B8B0961325F5383A + 78225B67E95382806B91E9933D8504E8E4041C3730AC951859F9351457DBC82E + ACE348512DC5D5DA27DD193DAC869E2F7D4E90269A0EA3F12652C2D28DA778F6 + D6666FF3FA0365EC3E55E5755B9EE8F5A32C5F73BCB89E8D59CDFDD3E2A92917 + AE2FABAFB0626B3E59F9AEF053A341B87D59661F787EBF17C4034FACCD616BE3 + CC1C5CBEAC97670F65CA507DA31E3D0822FA6CDFE24D5EDA9CCBCA6DCDC1E161 + 8146EE9F92C4A3D7A77A636551F33BD614449134F8FEA9B44D08DF06E674B00F + 77C381521E78FF08070B9A0FE01C9B1AC6F25919A44477CDF3DB6850D367A429 + 884155970AC95F7BDDD9453DC4990A0BBFFF570E4B379EE250A14B9828B38917 + 6E4F273DBE0B4BCD52BE2611CF6BFD495390BC88224B5168E97D7683FC4CF9FE + A12D6E769DACE2F18F7278EAE313ECCD7585363D73CB904ED71429258A109BC3 + 83FDEF8D0EF5EF7C0D91460B4EA3055067A092FD7D3D69CDFEBC1AFEB8EE244B + D69FA4D6E2E485DBD3090BECB8DB95521E96929B4C46037E26ED1FBA66EAD8C2 + 74C6160D24A32AD01AA9044F5343232B1182EF9FC8D69A3DA7AB59F8D621B2F2 + 6B796DEE50E2C2FCDBFC76A52A404802A3EBAA8CD135D3EDE62A6B9928E1AC53 + DB19A9296B4DAEEB7C927AD549953F7975E141379A2392770883918ECE83BFD8 + B03B559E589BC3A22949BC70C7D0C099CB2AAC0515CDAD916272A2DA0C947E93 + 7C83D5AAE43AD4F68F34D714E4C8E94F5B5D9BFC837646DFF49BD90EC4BBF6AA + B308A56783C97A23AF6F2D206748AD6D5472B8D2248814922093117B9579CEA1 + 8F47ED90F68E9BB54ECD3754A79DF27DEBDE33C6A40C0A8C4E7ECAD3F3442E76 + B61DAB709A9CCD8F4935AA26CA2979BC2A24EF5D461BC0620253CB16664C9B3C + 3A2588D361A7EAC42ECCD69AA723C2D3521B1C96F9AA492074794C54DF7838B1 + 16D50D0E793AAF4215125483405583DE2C530A9E3E977008EED9094ACB877801 + AC6C9387B6209327B74DB3D6638D4BA638D1B02028D7906CAAB14F513D9C5C7D + B1E3300882ECCE2DB1E72A16045547535D792926A9B137E6EEB649DA82CC99D3 + 36CD60C46EA9C52E6B08AEB0DD643AEB38680D93A940CFEDE4EC9D045A144E85 + 591C3725145592A49831AA91A89D6C4EB405F9EA2BCFEF30082AECD67AFF28AE + 0B7184EF1692F02E14FA82444A192CA12AD264B8CE2F22B0AEC0DFD4DE230B35 + D116E4ECD976AC822D48C5191A94633E17391D2976F2BD8FC585400A29A68518 + 0C3986202355E101E7ED99D31624A0A3484107D80D0821BE42D04F4AF5196001 + 5ACFD6BB589072B522C4A34211450E15148713531776817BA15796C5A0DE2DA5 + 331ED4375C69175585592DA4EC2F90F34076FBEC10EF0D9304C512F56E29D578 + 50DF6C4A3C4FA48FC5ECC62198D2258494F300AF1DE2E2C571ABC0F55C4B598C + 54175CC0356695AB46300FE13D219AD069222110B86B4C1CA82B9BD2FB30AB1A + 6BC45D7A08D1844E8234B50302842C91A80BBBD994F524ABDD4278B169F2840F + A6DAAEA60CD1D494A9F1C8BED094C9169DB5FE4234E143DF478B3EA6B9F3EF15 + C27CA75FD7B58FE8081F3BA35A35652DFB9826614C80CF7CFB020C08F75CCCA7 + 4D93277A28DC47E2AE15429620E5DD52AA8F81FA34301E977F4C175F720B1409 + C148B94B201F1348EF3F70B70BFC3F9C434FDE627F724C0000000049454E44AE + 426082} + end> + end + item + Name = 'logo-sequal' + SourceImages = < + item + Image.Data = { + 89504E470D0A1A0A0000000D494844520000006400000064080600000070E295 + 54000000017352474200AECE1CE90000000467414D410000B18F0BFC61050000 + 00097048597300000EC300000EC301C76FA86400000B4249444154785EED9D0B + 70D4C51DC777F7FFB8BBDC25B93CA1098F189022CA432108C2A430CC54A88EA3 + 8D8E7D286AA7D551A9D65A6DED3843B5B5763A0547ADD23AB6B5B454C4DA6955 + AC561115AD4880040AA8A00984242610925CEEFD7F6D7FBFBDA48356920BE8B8 + 7F673F3397BDDD7BCCFEF7BBBFC7FE33B74B140AC530D0C1D297A49E6C66E90D + CDD46E3CCC597998D0804EB8ED12F7FD1E125A5E47C3D7CDE7C6D431DEE0DB15 + 9F16E917DE61FD373EA50F56872576C746DDDAD6E69B89E73B0B89AFDAAC15DE + BAD8C5E75653476DEA0F6F9DC32A23DFF3BAE2A63790F15824C0F5A99526AB88 + 3C1CFADAD95B29A57BF1BDD9AD87B4C0BC89E27332E32B41120FBCA6476EAA77 + 3CC7AD4EDCF3D2EDCEFB3DD77A7DE920C93A84B0E32EC5E3841607895E534ACC + F935EB83974CBF0684C9C4EE7A8115AF3C5F6A17E61B41926B1BF5F0F23AC7DA + DDB920FD44D3ABF68E768D3830B61A7508A56CF06D39F0AA1CCF8378C25834C4 + 8C59D5AF16AE3CFF6A10E5E0C0AA5758D1AD8BA415C51782A49FDAA5851A66BA + F6DEAEF3926BDED80225A3A66E1346208A0F730D6835B66B138D19C10BA625C3 + 2B168E05511256639B66D64D90D27D7D78664988D5DCC1500CCEF9B4F486A6D7 + ED3D2046D070410663583110705D446706944EE6E93DE1C47DAF6E84EF294031 + 9CC37D524E46E90589FDE01FA24C3DD6F8636B7B3BA5A66613C235D1980FA009 + 5888CEC181D94D1DF5D94D07EEC6E6E4EFDE92F2DAA51624FBF20156F1D20D9E + 97CCCEB11BDBBEC9D396185C31C8A38183290574DD3DDC47ECA6F66F8395448A + 7FB2D4B577774A6725520B62ED6817FD4BFD6567BDDB93249431B48E931B4414 + 45873C605F77B1DDDCB1189B20964877FD725BC8E603A2CC6C684EF0810CC603 + 3A6AEB1802E30D85DC0BBEC73B9ABC4434651C6521F9E2B4F4D0F2E7AE75C0BD + 68C10BCFBC915B90147D34BD1D2D906261A0775A8F25B0EA75C745B34C482B08 + C7C55E8E0009EAB522633AF5349DA385F1941D14155BBECC575A418C33C6F216 + 720983499D72F6763D0CD9158C203FD5051DC358A28D2B3E88151A099CAC03FC + D4903A8694DDF91DD13FC8905A686100D715A73280F859460CCDCA6E697D041B + 9C03479520A3C1985925062C78E9CC340DC13AD0F520309FA4D782CFA18B32CE + 1A1B8FDE7FB1F8DEC84DF54A90D1C0D3B67051817327AED5C645F78214E8B746 + EFF85143D773698149E0713FB8C1637DD73DA99BE78C53828C86F0F23A9E5CDB + 2856E5A1CB66DEAB4DA900911CEF437776F3C30577A79B75E31391DB163F800D + A1AF4E57F7B24E0610C57D0DE6B8397BFC3A637AD51A561931C0726C7041F9CE + 6E07DEAF6993CB49E8AABACBC03A62B195FF64C1F3A74A671D88F482200B8E8A + 650389DCB0E00698E5BFD1AA8A0D62BBB8A6C05BEFB0E43BCE62F069AEEEC1EB + C23220161173EE842F1BA7953DDFF7ADC7B5E2BB96A9DBEFA78AB5AB939A8341 + 3EB5BEE9CECC73FB6E81D57BA917CF62FEE4520D5440215C8F70C7E334A86BD4 + D489565BBA3D7C73FD0F8DDAF297E3F7BD6214DEB2C8165F2829BE1104C96E3D + 44930FBEC64AD75DE9C24A7E56F6E5F7565A3B0ECF218E378EC7329885115A14 + 242C1A021FA76D63E5917B0A6F5BFC347E3676FBD37AF12F2FFADF6A53567C25 + C810F1559BF5C25B178BC1E59C7F21F3ECDE49F6F6768B272DAA9F5DCD834BA7 + 6A5A59F84D7CBD9534D0CA3FDFC1C257CC9132887F6E88AFDECC067EB1C918AC + 7E2C033F7B31FFFF9B48822F2DE478C06551ABA983B9FBBAB997B1890EA9B139 + 6F223567557B346848994929140A8542A15028140A8542A15028140A8542A150 + 28140A8542A15028140A8542A15028140A8542E16F7CF77384F8AF36537BF707 + A3EB39E784150649F4A106F5F304C5E8F09D852437EC8AD8BB3A74E8795EB31D + 2F1037E4D022015E78C792815CABBCF8469023F3EF67956FDEEC0DDCF5C2267B + 77673DA1340E233DF2CFBA29C59F47076951B03DB8E4F4E90557CEC9F6DFF857 + 1A7DE85229DD972F7EA72EB0723FA0753B63C53C9ED5793C53C213D9E2111FF1 + 6C098FA543ACD08C86AE982DBE439B542E4A19F18F2083F31906D8115B6B50B1 + 5F2F6E1A30FC8351173FCA2A0AF107A0E27AF5DA322CA4C4378204164D12EED5 + EB4D0DEDC280F53C1E3CB7AF03257B28A5697CAA8D8F622125BE10C439D8CB8A + 575F8C7BF72ED42795CD17BBCDE5BBDD1F271E3175DCE1F48F583D76F95ADD9C + 3D5ECAF881F84210880562927B3DC931C400CF837B9CE42C6064701FF8A04ECC + 793521AC6A151169C540FC612187FB73E5C15E9BA76CE8F5F1BBCD0C033A2CD7 + E3341220C6DC09016CD26755E5F7D9CF085F08029955AE3CD447D15D51B15F56 + 1E139D4300D1186EE734A0D7966ECCB59DF2BE8D9F2AFE10A4B53757BEDFC360 + 70D142443D0F30D3424BE9366756BF8B0DA9DF6F532EEB54715B8F8932F3ECBE + 244F5AD06BE8763EC38ABA791ED14F2B33212110D75A70751D16D2E20B41E2EB + FE25863FD4306329C1BD76F336104A380475ADA6C4829457B82AF3DC89E21559 + F1852013C99FC460B2F2F0C59835C138E72789E771163689DBD6BF1AAB3DCB1E + D1CC59D5CA657D52D8EF1E4988F89197BBC26D6121C32A2D20E6C2D3C41E8105 + CBE7889764C61782F45FFFA4B008B7A53717A4F301B2296A309D0F645B82174C + FBBB68B2F08C24B9915E10FB3F9D5A74CD659CA7ADA5B4C09801838AA2E4D76F + B0247D4A05C68F443BB99E86AF9A2BB5BB42A417C469CB2D0AED3D5D55E20918 + CA60393C6848B8CF7B4DA9D8E7BD9DACC1427AE417645F9728B35B5A523C9E25 + B0D083DA08131DC5B05C8F8D29C4DA6FF1CF99AB5F91FE5A11E93B995EDF2C4A + AFBDBFC28B6708D120AA8FE478F086229E3B95B00E99F593C46698AC3C227DFC + 40A416C46AEEA0953BBE8F77799936B9FC169E76A0C77945758833103FCE18D3 + 6B4E1BD3DD7BF95A2DBC7C8EF4F103915A90A135032EEA9C3D5D2ED5A1BBF99C + 58816F3134A24FAD14F7AF9C9663BE1003915A90F4337B45FFDC23F1D95E6FAA + 5A8831D2A210D71F9643B5AA62A27FB1E2196C2ABC7B693E562505520B421C4F + F4CF79AF6711A4BC21EE7AB618F1E1C0F547004C29EBEC0CCCABD9B69F2CA0A1 + 6567F8661365A905C96EDA2FCAF4134D71B0103CF60EA67F7E2E8B5515BD844F + 2BAE5921F7A4FB08D276D669EFA7D15F37E0296DBA3EB9FCBB5E4C645823F717 + FF21150DE17BD7639516057D133F106905C96C7C7BF019E1EE07F131F9AD3F28 + E78EA769630B63453F5D96C4A6F08A85E225BF20AD20BC3F256285F376F778E7 + 9D23C6E04DC5E1E38707F12364106D42740B6466FB633F7A56374EAFF0C5FA63 + 086905D1C64545DF9CD6DEAFC32047C115392366589C533C670A5CDC3A51B55D + 5F8981482B48E2C1D7857F72767716F14476E4153ABA2BDB657A6DA91DBCE8AC + D7B1A9E01BE78897FC849482D8FB8FD0CAAD37E30ABD04ACE37AAF3F8DE7E00E + DFD7417745187B14DC557BCF858F6AE6ECF1CA423E09528F358A32BBB52D69BF + DDED0D9EF229DA4E08E71AAC3FE08AA838854DAF29F1557635849482B0F2B088 + 15947B4BBC238912B1161C7E788525B08AC8CEA27BBED28ACFF519B9F3AAFC86 + 948250531727E3D8BB3ABF04AE0A67BF3D6C404777556010F3BC9ACDE0AEB203 + 3F7FD1885C3B5F09F249E0F5246864C54271929AB3FFE8143E143F4E34BC18EA + 3DAED3920248774B1E134D86E6DBF3A6A413C4DAD3252C01027A198B862E82CC + 69E8FFE8E8963EE6411D8C2F7A6DD981C0E2C9E25E4BA861862FAD03914E10BB + A95D94D61BAD673A078E6AB042A7C4E51A0C3A1EBDFDFF0FC73568D884E53CBF + 17DC95155BF9BCAED796FB569013FBE5CF086BDB21CD9C3BD175DEEBB9D3DADE + 7605B7DC63903941FAF4B14E8B832806A4BB7DA186991762FCC86EDA4F034BA6 + F856102949ADDF39EA8992FADB6EE926D7C920ED4564FFDD4AFBAF7E9CBA5D71 + 3CB5F304692F364254B75D5235702FC6148542F1398690FF029A8D9B27B85043 + 410000000049454E44AE426082} + end> + end + item + Name = 'icons8-key-100-pink' + SourceImages = < + item + Image.Data = { + 89504E470D0A1A0A0000000D494844520000006400000064080600000070E295 + 54000000017352474200AECE1CE90000000467414D410000B18F0BFC61050000 + 00097048597300000EC100000EC101B8916BED0000001874455874536F667477 + 617265005061696E742E4E455420352E312E36FCD1C7AF000000B66558496649 + 492A000800000005001A010500010000004A0000001B01050001000000520000 + 0028010300010000000200000031010200100000005A00000069870400010000 + 006A00000000000000D9760100E8030000D9760100E80300005061696E742E4E + 455420352E312E3600030000900700040000003032333001A003000100000001 + 00000005A0040001000000940000000000000002000100020004000000523938 + 00020007000400000030313030000000008CF53740E4EAF7DB00000684494441 + 54785EED9C5F8C1D6519879FF7DB026B410B3456531A2818439A81201AF14C51 + 88240AD1BB12B4DD6E132F4C30263424C6987883E28531D1C4849AA0912BDA6D + 43421B2F309AF897A87310A912185B8D01C28242CB22E05AAAED7EAF177B9A6E + DF0BB3E7CC3BA7DF9C9927996CF27BBF3DE74C9ECC9CF3FD1BE8E8E8E8E8E8E8 + E8E8F0476C90128F64FDCB227A45844D0A1B053609B256D177016B027269442F + 002E19FCCB62404E45F40DE0B4206F297A029807FE11E0A580BCFC99B2F74FF3 + 56C970DE85ECCDFA6BD7C096886E01B600D70EFE5E1D9077D8F61E44F46DE079 + E0087014381A9023A7E1C86CD93B61DB8F93B10AE9678FCAF36CEC297C04F810 + F041E0DA804CD9B6E783882E017F010E034F093C71357FEFF7CA3BD5B6AD8BB1 + 083998F52F3C89DE0D7C292057D97ACA44F405E03BD3C80FB695BDFFDABA37B5 + 0BD99F15372A3C1C90CCD69A44449F89B06BB6CC9FB6354F6A15B22F2B3E25F0 + 48402EB6B52612D145E0AE9932FF89AD79519B90FD59912BFC2C206B6DADC944 + F484C0AD3BCAFC0FB6E6412D420E64C5C5119E0DC8665B9B0422FA5C44AEAFE3 + 1759B0810711EE9D54190001B9660A76DBDC03F72BE481AC1FD6A3F301D9686B + 934444E71790CDF794BD686B5570173297153707E43736AF4A44FF031C078E05 + 4423FAE6F2C5C8A9802C0EDABC1358038480AC8BA8001B800D01B9D0BE665522 + FAD19932FFADCDAB508790FB02F2359BAF96881E077E073C093C2930BF04AFCE + 96F9EBB6ED30ECCD8ACB81F706D804DC047C18C803F26EDB76B544F4BE9932BF + DFE655A843C8E301F998CD5743441F9E463E3F8E0E18673BAC3F0CC82E5B5B0D + 117D7CA6CC6FB579155CBFD41FCA8A8B581E161995625C320006EF55D87C086E + DA9BF52FB061155C85AC85EBEBB857A74A40A6A7D0EB6C5E0557210A37DA6CD2 + D1E54152375C85D04221C0076C50056F21D7D860482EB7C118586F8321A97ACE + E7E02DE47D3618924FDA600CDC618321711D917013F240D60FC095361F8680DC + 329715B336AF8BB9ACD815909B6D3E24AE42DCFA2107B26203C8AB361F96889E + 06BE1960CFF6323F66EB1EECCD8AF784E5B1A8AF78CC569E46D757EDB89EC14D + C8FEACBF5996E7A93D7933A2AE63450109C03A9B57E4AAED65EF451B8E82DB2D + 6B308EE4CDBA805CE679D420C3F5DCDD8484B34B715A8782DB249C9B1071B817 + 379529E4229B8D8A9B1085459BB588B76D302A6E42585E21D84A14FE6DB35171 + 1312A0B542229A9E9088BC66B3B6A0C882CD46C54DC88EB27732A2AFD87CD289 + E882E7EA133721035EB0C1A41310D773F616F29C0D269D88BA8E4E780BF9B30D + 5AC0511B54C15588402DCB2B13E7B00DAAE02DE48F369B7402F294CDAAE02A64 + 7B991FF3BEA7A64C445FF11AE53D83AB90013FB7C104F32B1B54A513528D5FD8 + A02AEE42D6203F8DE8299B4F1A115505F78D3BEE42065B8E1FB3F904F2CB9D65 + 3E6FC3AAB80B6179F4F31BDE53AFA921E0BAC8FA0CB508D959E687816FDB7C52 + 88E8433BCAFCD736F7A0162100D3C85723FA239B379D883E11915A764F51A790 + 6D656F29227745744F44C7B6F1BE4E22FAE388DCEE39BA6B715B06F4FF98CB8A + 5B04B95FC0752FC5B888E83181AFBF863CE8BD85CD32162167D89715EF17F874 + 40B646746B40AEB06D52607045FF0DF83DF09820877694BD93B65D1D8C5588E5 + 40D6BF32A25B811B800CB80ED81C90B17DAE882E0C466C8F002570780AFEF4D9 + 327FCBB61D07633BF1D57230EB5F7212FD5640BE686B9E44742EC2BDB3657EDC + D6CE27B57DA98FCAB6B2B728C8AA3A5C11E5758E9F734456FDFBE1C5D46490A2 + 906159E2D43947D369BC9049A31392189D90C4E88424462B850C3A7EB53E196E + 545A276420E39E99323F606B29D02A212B647CCFD652A135429A2083360901BE + 9FBA0C5A26E473735951F52101B5D31A210199060EA52EA53542688894560961 + 85947D59719BADA540EB84309022F0099BA7402B85A44C272431DA2C64D5538B + E3A49542225A06F8AECD53A0754206326EABEB595C55699590D465D02621112D + 237C3C6519B44908F0D214F22F1BA6466B8404E476450FEDCFFAD3B69612AD11 + C2B2943B5297D22A2134404AEB847056CA976D9E02AD1432C0EDC1959EB45948 + 9274421223492111FD6B9DFB12BB857243B2B3CC0F02BBEB903278CDDDDD42B9 + 219929F33DDE5256C8D8636BA990AC109CA5344106A90BC1494A5364D0042154 + 94D22419344508234A699A0C9A248421A534510629EE535F0D7359F105E04E45 + A7DE60E18695B54B59FFB4204BC0A33365FEE0CA5A4747474747474747475BF9 + 1F7FA73D2F7ABAF21F0000000049454E44AE426082} + end> end> Left = 593 Top = 339 end object VirtualImageListMain: TVirtualImageList DisabledGrayscale = True - DisabledSuffix = '_Disabled' Images = < item CollectionIndex = 0 CollectionName = 'icons8-circular-arrow-100' - Disabled = False Name = 'icons8-circular-arrow-100' end item CollectionIndex = 1 CollectionName = 'icons8-server-100' - Disabled = False Name = 'icons8-server-100' end item CollectionIndex = 2 CollectionName = 'icons8-cut-100' - Disabled = False Name = 'icons8-cut-100' end item CollectionIndex = 3 CollectionName = 'icons8-copy-100' - Disabled = False Name = 'icons8-copy-100' end item CollectionIndex = 4 CollectionName = 'icons8-paste-100' - Disabled = False Name = 'icons8-paste-100' end item CollectionIndex = 5 CollectionName = 'icons8-database-100' - Disabled = False Name = 'icons8-database-100' end item CollectionIndex = 6 CollectionName = 'icons8-database-symbol-100' - Disabled = False Name = 'icons8-database-symbol-100' end item CollectionIndex = 7 CollectionName = 'icons8-delete-database-100' - Disabled = False Name = 'icons8-delete-database-100' end item CollectionIndex = 8 CollectionName = 'icons8-database-administrator-100' - Disabled = False Name = 'icons8-database-administrator-100' end item CollectionIndex = 9 CollectionName = 'icons8-outgoing-data-100' - Disabled = False Name = 'icons8-outgoing-data-100' end item CollectionIndex = 10 CollectionName = 'icons8-save-button-100' - Disabled = False Name = 'icons8-save-button-100' end item CollectionIndex = 11 CollectionName = 'icons8-user-account-100' - Disabled = False Name = 'icons8-user-account-100' end item CollectionIndex = 12 CollectionName = 'icons8-edit' - Disabled = False Name = 'icons8-edit' end item CollectionIndex = 13 CollectionName = 'icons8-lightning-bolt-100' - Disabled = False Name = 'icons8-lightning-bolt-100' end item CollectionIndex = 14 CollectionName = 'icons8-data-sheet-100' - Disabled = False Name = 'icons8-data-sheet-100' end item CollectionIndex = 15 CollectionName = 'icons8-data-sheet-100-add' - Disabled = False Name = 'icons8-data-sheet-100-add' end item CollectionIndex = 16 CollectionName = 'icons8-data-sheet-100-delete' - Disabled = False Name = 'icons8-data-sheet-100-delete' end item CollectionIndex = 17 CollectionName = 'icons8-data-sheet-100-edit' - Disabled = False Name = 'icons8-data-sheet-100-edit' end item CollectionIndex = 18 CollectionName = 'icons8-data-sheet-100-key' - Disabled = False Name = 'icons8-data-sheet-100-key' end item CollectionIndex = 19 CollectionName = 'icons8-sheets-100' - Disabled = False Name = 'icons8-sheets-100' end item CollectionIndex = 20 CollectionName = 'icons8-export-100' - Disabled = False Name = 'icons8-export-100' end item CollectionIndex = 21 CollectionName = 'icons8-add-user-male-100' - Disabled = False Name = 'icons8-add-user-male-100' end item CollectionIndex = 22 CollectionName = 'icons8-key-100-blue' - Disabled = False Name = 'icons8-key-100-blue' end item CollectionIndex = 23 CollectionName = 'icons8-key-100-green' - Disabled = False Name = 'icons8-key-100-green' end item CollectionIndex = 24 CollectionName = 'icons8-key-100-red' - Disabled = False Name = 'icons8-key-100-red' end item CollectionIndex = 25 CollectionName = 'icons8-key' - Disabled = False Name = 'icons8-key' end item CollectionIndex = 26 CollectionName = 'icons8-close-button' - Disabled = False Name = 'icons8-close-button' end item CollectionIndex = 27 CollectionName = 'icons8-data-backup' - Disabled = False Name = 'icons8-data-backup' end item CollectionIndex = 28 CollectionName = 'icons8-reset' - Disabled = False Name = 'icons8-reset' end item CollectionIndex = 29 CollectionName = 'icons8-disconnected' - Disabled = False Name = 'icons8-disconnected' end item CollectionIndex = 30 CollectionName = 'icons8-find' - Disabled = False Name = 'icons8-find' end item CollectionIndex = 31 CollectionName = 'icons8-help' - Disabled = False Name = 'icons8-help' end item CollectionIndex = 32 CollectionName = 'icons8-html' - Disabled = False Name = 'icons8-html' end item CollectionIndex = 33 CollectionName = 'icons8-compose' - Disabled = False Name = 'icons8-compose' end item CollectionIndex = 34 CollectionName = 'icons8-print' - Disabled = False Name = 'icons8-print' end item CollectionIndex = 35 CollectionName = 'icons8-go' - Disabled = False Name = 'icons8-go' end item CollectionIndex = 36 CollectionName = 'icons8-server' - Disabled = False Name = 'icons8-server' end item CollectionIndex = 37 CollectionName = 'icons8-connected' - Disabled = False Name = 'icons8-connected' end item CollectionIndex = 38 CollectionName = 'icons8-server-100-export' - Disabled = False Name = 'icons8-server-100-export' end item CollectionIndex = 39 CollectionName = 'icons8-support' - Disabled = False Name = 'icons8-support' end item CollectionIndex = 40 CollectionName = 'icons8-undo' - Disabled = False Name = 'icons8-undo' end item CollectionIndex = 41 CollectionName = 'icons8-data-grid' - Disabled = False Name = 'icons8-data-grid' end item CollectionIndex = 42 CollectionName = 'icons8-rhombus' - Disabled = False Name = 'icons8-rhombus' end item CollectionIndex = 43 CollectionName = 'icons8-user' - Disabled = False Name = 'icons8-user' end item CollectionIndex = 44 CollectionName = 'icons8-note' - Disabled = False Name = 'icons8-note' end item CollectionIndex = 45 CollectionName = 'icons8-add' - Disabled = False Name = 'icons8-add' end item CollectionIndex = 46 CollectionName = 'icons8-delete-button' - Disabled = False Name = 'icons8-delete-button' end item CollectionIndex = 47 CollectionName = 'icons8-image' - Disabled = False Name = 'icons8-image' end item CollectionIndex = 48 CollectionName = 'icons8-source-code' - Disabled = False Name = 'icons8-source-code' end item CollectionIndex = 49 CollectionName = 'icons8-microsoft-excel' - Disabled = False Name = 'icons8-microsoft-excel' end item CollectionIndex = 50 CollectionName = 'icons8-csv' - Disabled = False Name = 'icons8-csv' end item CollectionIndex = 51 CollectionName = 'icons8-folder' - Disabled = False Name = 'icons8-folder' end item CollectionIndex = 52 CollectionName = 'icons8-opened-folder' - Disabled = False Name = 'icons8-opened-folder' end item CollectionIndex = 53 CollectionName = 'icons8-filter' - Disabled = False Name = 'icons8-filter' end item CollectionIndex = 54 CollectionName = 'icons8-paper-100-save' - Disabled = False Name = 'icons8-paper-100-save' end item CollectionIndex = 55 CollectionName = 'icons8-checked' - Disabled = False Name = 'icons8-checked' end item CollectionIndex = 56 CollectionName = 'icons8-index' - Disabled = False Name = 'icons8-index' end item CollectionIndex = 57 CollectionName = 'icons8-play' - Disabled = False Name = 'icons8-play' end item CollectionIndex = 58 CollectionName = 'icons8-rename' - Disabled = False Name = 'icons8-rename' end item CollectionIndex = 59 CollectionName = 'icons8-find-and-replace' - Disabled = False Name = 'icons8-find-and-replace' end item CollectionIndex = 60 CollectionName = 'icons8-sort-left' - Disabled = False Name = 'icons8-sort-left' end item CollectionIndex = 61 CollectionName = 'icons8-sort-right' - Disabled = False Name = 'icons8-sort-right' end item CollectionIndex = 62 CollectionName = 'icons8-word-wrap' - Disabled = False Name = 'icons8-word-wrap' end item CollectionIndex = 63 CollectionName = 'icons8-error-100-stop' - Disabled = False Name = 'icons8-error-100-stop' end item CollectionIndex = 64 CollectionName = 'icons8-checked-checkbox' - Disabled = False Name = 'icons8-checked-checkbox' end item CollectionIndex = 65 CollectionName = 'icons8-unchecked-checkbox' - Disabled = False Name = 'icons8-unchecked-checkbox' end item CollectionIndex = 66 CollectionName = 'icons8-sheets-of-paper-with-a-question-mark' - Disabled = False Name = 'icons8-sheets-of-paper-with-a-question-mark' end item CollectionIndex = 67 CollectionName = 'icons8-page' - Disabled = False Name = 'icons8-page' end item CollectionIndex = 68 CollectionName = 'icons8-brief' - Disabled = False Name = 'icons8-brief' end item CollectionIndex = 69 CollectionName = 'icons8-internet' - Disabled = False Name = 'icons8-internet' end item CollectionIndex = 70 CollectionName = 'icons8-database-100-yellow' - Disabled = False Name = 'icons8-database-100-yellow' end item CollectionIndex = 71 CollectionName = 'icons8-grid-2' - Disabled = False Name = 'icons8-grid-2' end item CollectionIndex = 72 CollectionName = 'icons8-database-symbol' - Disabled = False Name = 'icons8-database-symbol' end item CollectionIndex = 73 CollectionName = 'icons8-chevron-down' - Disabled = False Name = 'icons8-chevron-down' end item CollectionIndex = 74 CollectionName = 'icons8-sort-up' - Disabled = False Name = 'icons8-sort-up' end item CollectionIndex = 75 CollectionName = 'icons8-caret-arrowhead-facing-down' - Disabled = False Name = 'icons8-caret-arrowhead-facing-down' end item CollectionIndex = 76 CollectionName = 'icons8-sort-left-other' - Disabled = False Name = 'icons8-sort-left-other' end item CollectionIndex = 77 CollectionName = 'icons8-sort-right-other' - Disabled = False Name = 'icons8-sort-right-other' end item CollectionIndex = 78 CollectionName = 'icons8-double-left' - Disabled = False Name = 'icons8-double-left' end item CollectionIndex = 79 CollectionName = 'icons8-double-right' - Disabled = False Name = 'icons8-double-right' end item CollectionIndex = 80 CollectionName = 'icons8-event' - Disabled = False Name = 'icons8-event' end item CollectionIndex = 81 CollectionName = 'icons8-eye' - Disabled = False Name = 'icons8-eye' end item CollectionIndex = 82 CollectionName = 'icons8-eye-other' - Disabled = False Name = 'icons8-eye-other' end item CollectionIndex = 83 CollectionName = 'icons8-denied' - Disabled = False Name = 'icons8-denied' end item CollectionIndex = 84 CollectionName = 'icons8-user-100-edit' - Disabled = False Name = 'icons8-user-100-edit' end item CollectionIndex = 85 CollectionName = 'icons8-add-user-male' - Disabled = False Name = 'icons8-add-user-male' end item CollectionIndex = 86 CollectionName = 'icons8-denied-other' - Disabled = False Name = 'icons8-denied-other' end item CollectionIndex = 87 CollectionName = 'icons8-add-other' - Disabled = False Name = 'icons8-add-other' end item CollectionIndex = 88 CollectionName = 'icons8-delete-button-other' - Disabled = False Name = 'icons8-delete-button-other' end item CollectionIndex = 89 CollectionName = 'icons8-skip-to-start' - Disabled = False Name = 'icons8-skip-to-start' end item CollectionIndex = 90 CollectionName = 'icons8-end' - Disabled = False Name = 'icons8-end' end item CollectionIndex = 91 CollectionName = 'icons8-rhombus-add' - Disabled = False Name = 'icons8-rhombus-add' end item CollectionIndex = 92 CollectionName = 'icons8-rhombus-delete' - Disabled = False Name = 'icons8-rhombus-delete' end item CollectionIndex = 93 CollectionName = 'icons8-rhombus-edit' - Disabled = False Name = 'icons8-rhombus-edit' end item CollectionIndex = 94 CollectionName = 'icons8-update' - Disabled = False Name = 'icons8-update' end item CollectionIndex = 95 CollectionName = 'icons8-collaboration' - Disabled = False Name = 'icons8-collaboration' end item CollectionIndex = 96 CollectionName = 'icons8-bug' - Disabled = False Name = 'icons8-bug' end item CollectionIndex = 97 CollectionName = 'icons8-collaboration-other' - Disabled = False Name = 'icons8-collaboration-other' end item CollectionIndex = 98 CollectionName = 'icons8-support-orange' - Disabled = False Name = 'icons8-support-orange' end item CollectionIndex = 99 CollectionName = 'icons8-more-info' - Disabled = False Name = 'icons8-more-info' end item CollectionIndex = 100 CollectionName = 'icons8-export' - Disabled = False Name = 'icons8-export' end item CollectionIndex = 101 CollectionName = 'icons8-import' - Disabled = False Name = 'icons8-import' end item CollectionIndex = 102 CollectionName = 'icons8-eye-otherB' - Disabled = False Name = 'icons8-eye-otherB' end item CollectionIndex = 103 CollectionName = 'icons8-eye-otherC' - Disabled = False Name = 'icons8-eye-otherC' end item CollectionIndex = 104 CollectionName = 'icons8-play-selected' - Disabled = False Name = 'icons8-play-selected' end item CollectionIndex = 105 CollectionName = 'icons8-play-cropped' - Disabled = False Name = 'icons8-play-cropped' end item CollectionIndex = 106 CollectionName = 'icons8-semicolon' - Disabled = False Name = 'icons8-semicolon' end item CollectionIndex = 107 CollectionName = 'icons8-caret-arrowhead-facing-down-other-gray' - Disabled = False Name = 'icons8-caret-arrowhead-facing-down-other-gray' end item CollectionIndex = 108 CollectionName = 'icons8-caret-arrowhead-facing-down-other' - Disabled = False Name = 'icons8-caret-arrowhead-facing-down-other' end item CollectionIndex = 109 CollectionName = 'icons8-alphabetical-sorting' - Disabled = False Name = 'icons8-alphabetical-sorting' end item CollectionIndex = 110 CollectionName = 'icons8-alphabetical-sorting-2' - Disabled = False Name = 'icons8-alphabetical-sorting-2' end item CollectionIndex = 111 CollectionName = 'icons8-red-triangle' - Disabled = False Name = 'icons8-red-triangle' end item CollectionIndex = 112 CollectionName = 'icons8-star-filled' - Disabled = False Name = 'icons8-star-filled' end item CollectionIndex = 113 CollectionName = 'icons8-star-filled-gray' - Disabled = False Name = 'icons8-star-filled-gray' end item CollectionIndex = 114 CollectionName = 'icons8-code-file' - Disabled = False Name = 'icons8-code-file' end item CollectionIndex = 115 CollectionName = 'icons8-color-palette' - Disabled = False Name = 'icons8-color-palette' end item CollectionIndex = 116 CollectionName = 'icons8-querytab-right' - Disabled = False Name = 'icons8-querytab-right' end item CollectionIndex = 117 CollectionName = 'icons8-querytab-left' - Disabled = False Name = 'icons8-querytab-left' end item CollectionIndex = 118 CollectionName = 'icons8-select-all' - Disabled = False Name = 'icons8-select-all' end item CollectionIndex = 119 CollectionName = 'icons8-source-code-other' - Disabled = False Name = 'icons8-source-code-other' end item CollectionIndex = 120 CollectionName = 'icons8-refresh-right' - Disabled = False Name = 'icons8-refresh-right' end item CollectionIndex = 121 CollectionName = 'icons8-refresh-left' - Disabled = False Name = 'icons8-refresh-left' end item CollectionIndex = 122 CollectionName = 'icons8-refresh' - Disabled = False Name = 'icons8-refresh' end item CollectionIndex = 123 CollectionName = 'icons8-windows-xp' - Disabled = False Name = 'icons8-windows-xp' end item CollectionIndex = 124 CollectionName = 'icons8-apple-logo' - Disabled = False Name = 'icons8-apple-logo' end item CollectionIndex = 125 CollectionName = 'icons8-linux' - Disabled = False Name = 'icons8-linux' end item CollectionIndex = 126 CollectionName = 'icons8-key-100-lightblue' - Disabled = False Name = 'icons8-key-100-lightblue' end item CollectionIndex = 127 CollectionName = 'icons8-unchecked-checkbox-other' - Disabled = False Name = 'icons8-unchecked-checkbox-other' end item CollectionIndex = 128 CollectionName = 'icons8-checked-checkbox-other' - Disabled = False Name = 'icons8-checked-checkbox-other' end item CollectionIndex = 129 CollectionName = 'icons8-edit-property' - Disabled = False Name = 'icons8-edit-property' end item CollectionIndex = 130 CollectionName = 'icons8-add-property' - Disabled = False Name = 'icons8-add-property' end item CollectionIndex = 131 CollectionName = 'icons8-delete-document' - Disabled = False Name = 'icons8-delete-document' end item CollectionIndex = 132 CollectionName = 'icons8-querytab-add' - Disabled = False Name = 'icons8-querytab-add' end item CollectionIndex = 133 CollectionName = 'icons8-querytab-close' - Disabled = False Name = 'icons8-querytab-close' end item CollectionIndex = 134 CollectionName = 'icons8-close-button-small-centered' - Disabled = False - Name = 'icons8-close-button-other' + Name = 'icons8-close-button-small-centered' end item CollectionIndex = 135 CollectionName = 'icons8-server-edit' - Disabled = False Name = 'icons8-server-edit' end item CollectionIndex = 136 CollectionName = 'icons8-data-grid-relation' - Disabled = False Name = 'icons8-data-grid-relation' end item CollectionIndex = 137 CollectionName = 'icons8-settings' - Disabled = False Name = 'icons8-settings' end item CollectionIndex = 138 CollectionName = 'icons8-invert-selection' - Disabled = False Name = 'icons8-invert-selection' end item CollectionIndex = 139 CollectionName = 'icons8-alphabetical-sorting-delete' - Disabled = False Name = 'icons8-alphabetical-sorting-delete' end item CollectionIndex = 140 CollectionName = 'icons8-broom' - Disabled = False Name = 'icons8-broom' end item CollectionIndex = 141 CollectionName = 'icons8-data' - Disabled = False Name = 'icons8-data' end item CollectionIndex = 142 CollectionName = 'icons8-search-more' - Disabled = False Name = 'icons8-search-more' end item CollectionIndex = 143 CollectionName = 'icons8-sort' - Disabled = False Name = 'icons8-sort' end item CollectionIndex = 144 CollectionName = 'icons8-secure' - Disabled = False Name = 'icons8-secure' end item CollectionIndex = 145 CollectionName = 'icons8-bar-chart' - Disabled = False Name = 'icons8-bar-chart' end item CollectionIndex = 146 CollectionName = 'icons8-find-other' - Disabled = False Name = 'icons8-find-other' end item CollectionIndex = 147 CollectionName = 'icons8-lock' - Disabled = False Name = 'icons8-lock' end item CollectionIndex = 148 CollectionName = 'icons8-paper-money' - Disabled = False Name = 'icons8-paper-money' end item CollectionIndex = 149 CollectionName = 'icons8-clock-outline' - Disabled = False Name = 'icons8-clock-outline' end item CollectionIndex = 150 CollectionName = 'icons8-hourglass' - Disabled = False Name = 'icons8-hourglass' end item CollectionIndex = 151 CollectionName = 'icons8-active-state' - Disabled = False Name = 'icons8-active-state' end item CollectionIndex = 152 CollectionName = 'icons8-image-other' - Disabled = False Name = 'icons8-image-other' end item CollectionIndex = 153 CollectionName = 'icons8-latex' - Disabled = False Name = 'icons8-latex' end item CollectionIndex = 154 - CollectionName = 'icons8-wikimarkup' - Disabled = False - Name = 'icons8-wikimarkup' + CollectionName = 'icons8-textile' + Name = 'icons8-textile' end item CollectionIndex = 155 CollectionName = 'icons8-copy-rows' - Disabled = False Name = 'icons8-copy-rows' end item CollectionIndex = 156 CollectionName = 'icons8-paste-rows' - Disabled = False Name = 'icons8-paste-rows' end item CollectionIndex = 157 CollectionName = 'icons8-checked-small' - Disabled = False Name = 'icons8-checked-small' end item CollectionIndex = 158 CollectionName = 'icons8-close-button-small' - Disabled = False Name = 'icons8-close-button-small' end item CollectionIndex = 159 CollectionName = 'icons8-close-window' - Disabled = False Name = 'icons8-close-window' end item CollectionIndex = 160 CollectionName = 'icons8-close-window-dark' - Disabled = False Name = 'icons8-close-window-dark' end item CollectionIndex = 161 CollectionName = 'icons8-error-small' - Disabled = False Name = 'icons8-error-small' end item CollectionIndex = 162 CollectionName = 'icons8-edit-small' - Disabled = False Name = 'icons8-edit-small' end item CollectionIndex = 163 CollectionName = 'icons8-add-small' - Disabled = False Name = 'icons8-add-small' end item CollectionIndex = 164 CollectionName = 'icons8-mysql-logo' - Disabled = False Name = 'icons8-mysql-logo' end item CollectionIndex = 165 CollectionName = 'icons8-comments' - Disabled = False Name = 'icons8-comments' end item CollectionIndex = 166 CollectionName = 'icons8-mariadb-logo' - Disabled = False Name = 'icons8-mariadb-logo' end item CollectionIndex = 167 CollectionName = 'icons8-inactive-state' - Disabled = False Name = 'icons8-inactive-state' end item CollectionIndex = 168 CollectionName = 'icons8-star-filled-small' - Disabled = False Name = 'icons8-star-filled-small' end item CollectionIndex = 169 CollectionName = 'icons8-percona-logo' - Disabled = False Name = 'icons8-percona-logo' end item CollectionIndex = 170 CollectionName = 'icons8-terminal' - Disabled = False Name = 'icons8-terminal' end item CollectionIndex = 171 CollectionName = 'icons8-tokudb-logo' - Disabled = False Name = 'icons8-tokudb-logo' end item CollectionIndex = 172 CollectionName = 'icons8-infinidb-logo' - Disabled = False Name = 'icons8-infinidb-logo' end item CollectionIndex = 173 CollectionName = 'icons8-infobright-logo' - Disabled = False Name = 'icons8-infobright-logo' end item CollectionIndex = 174 CollectionName = 'icons8-folder-other' - Disabled = False Name = 'icons8-folder-other' end item CollectionIndex = 175 CollectionName = 'icons8-unchecked-checkbox-grey' - Disabled = False Name = 'icons8-unchecked-checkbox-grey' end item CollectionIndex = 176 CollectionName = 'icons8-checked-checkbox-grey' - Disabled = False Name = 'icons8-checked-checkbox-grey' end item CollectionIndex = 177 CollectionName = 'icons8-internet-small' - Disabled = False Name = 'icons8-internet-small' end item CollectionIndex = 178 CollectionName = 'icons8-light-small' - Disabled = False Name = 'icons8-light-small' end item CollectionIndex = 179 CollectionName = 'icons8-mariadb-logo-small' - Disabled = False Name = 'icons8-mariadb-logo-small' end item CollectionIndex = 180 CollectionName = 'icons8-csv-small' - Disabled = False Name = 'icons8-csv-small' end item CollectionIndex = 181 CollectionName = 'icons8-final-state-small' - Disabled = False Name = 'icons8-final-state-small' end item CollectionIndex = 182 CollectionName = 'icons8-query-inner-join-small' - Disabled = False Name = 'icons8-query-inner-join-small' end item CollectionIndex = 183 CollectionName = 'icons8-star-filled-gray-small' - Disabled = False Name = 'icons8-star-filled-gray-small' end item CollectionIndex = 184 CollectionName = 'icons8-circular-arrow-violet' - Disabled = False Name = 'icons8-circular-arrow-violet' end item CollectionIndex = 185 CollectionName = 'icons8-paypal' - Disabled = False Name = 'icons8-paypal' end item CollectionIndex = 186 CollectionName = 'icons8-pie-chart' - Disabled = False Name = 'icons8-pie-chart' end item CollectionIndex = 187 CollectionName = 'icons8-postgresql' - Disabled = False Name = 'icons8-postgresql' end item CollectionIndex = 188 CollectionName = 'icons8-azure' - Disabled = False Name = 'icons8-azure' end item CollectionIndex = 189 CollectionName = 'icons8-run-file' - Disabled = False Name = 'icons8-run-file' end item CollectionIndex = 190 CollectionName = 'icons8-clock-outline-other' - Disabled = False Name = 'icons8-clock-outline-other' end item CollectionIndex = 191 CollectionName = 'icons8-filter-database' - Disabled = False Name = 'icons8-filter-database' end item CollectionIndex = 192 CollectionName = 'icons8-filter-table' - Disabled = False Name = 'icons8-filter-table' end item CollectionIndex = 193 CollectionName = 'icons8-clear-symbol' - Disabled = False Name = 'icons8-clear-symbol' end item CollectionIndex = 194 CollectionName = 'server-memsql' - Disabled = False Name = 'server-memsql' end item CollectionIndex = 195 CollectionName = 'icons8-redshift' - Disabled = False Name = 'icons8-redshift' end item CollectionIndex = 196 CollectionName = 'icons8-sqlite' - Disabled = False Name = 'icons8-sqlite' end item CollectionIndex = 197 CollectionName = 'server-proxysqladmin' - Disabled = False Name = 'server-proxysqladmin' end item CollectionIndex = 198 CollectionName = 'code-folding' - Disabled = False Name = 'code-folding' + end + item + CollectionIndex = 199 + CollectionName = 'icons8-markdown' + Name = 'icons8-markdown' + end + item + CollectionIndex = 200 + CollectionName = 'icons8-js' + Name = 'icons8-js' + end + item + CollectionIndex = 201 + CollectionName = 'icons8-sql' + Name = 'icons8-sql' + end + item + CollectionIndex = 202 + CollectionName = 'icons8-php' + Name = 'icons8-php' + end + item + CollectionIndex = 203 + CollectionName = 'server-interbase' + Name = 'server-interbase' + end + item + CollectionIndex = 204 + CollectionName = 'server-firebird' + Name = 'server-firebird' + end + item + CollectionIndex = 205 + CollectionName = 'server-rds-mysql' + Name = 'server-rds-mysql' + end + item + CollectionIndex = 206 + CollectionName = 'logo-sequal' + Name = 'logo-sequal' end> ImageCollection = ImageCollectionIcons8 ImageNameAvailable = False @@ -18938,14 +19700,24 @@ object MainForm: TMainForm item Image.Data = { 89504E470D0A1A0A0000000D49484452000000100000001008060000001FF3FF - 61000000D64944415478DA63FCFFFF3F03258091A606FCF9F387958585E53759 - 06FCFCF9936BF1E2C5535455558FD8DBDBCF23C90098E64F9F3EB97DFEFCF99B - 838343072E43300C8069FEF5EB97A70410000DF8FD000870198262004C331313 - 93A7828282C4F7EFDF19BE7DFBC60074C9EFC78F1F3F707474C430046E004C33 - 2727A7A79696960448E3D7AF5FE11864C88B172F1E383B3BA318023760CB962D - E577EEDC49F5F7F757FEF2E50B5813D0F9601780F8200C0A8FF7EFDFDFCBC8C8 - 88929595BD4C5D17501C06548905AAA403AAA44418A0282F100B00A40F11F06C - 75C2A50000000049454E44AE426082} + 610000000774494D4507D7091C0832217B3A19F6000000097048597300001EC1 + 00001EC101C36954530000000467414D410000B18F0BFC6105000001DF494441 + 5478DAA5534B4B1B5114FE924C8C8FBA5123F8A0208258A9AFA011410441A588 + 54C4552BAE4A97EEBB125DE8FF1091E0220BD1A5ABA828BEC08D0F14290815AD + 181F8831F7E5B977D2CC8C5DA8786072EEBD73BEEF7CE7BB13E09DE1D33F3389 + E49852F82994AC9452424880EB2CF45A8153761E01C1159DCBCDA9919AA8A509 + A452A343D1C292B7741E9F3B6ED0D910109B01CF9F4C53674E5D381865269893 + E9ECDFBB5FED93604C845C04CAB07EAFFBF1AAEEF72922E5020E811E9A22B672 + 61F2B7CDD9FF40B1D6E1ECFA6B4B11D26E029E2130E08E52608BBCEDE971D089 + 847D9E89CBDB94570123023212560088AF5D6028143220048380DF6F0AE73748 + 1DD50409F1A9221F69F66C04ED8215F061301A06F689A0ADCDA36020EA2838FE + 730BCEA55781A2BD45CD16B7FFA25F77DED9B1ABF59A22BE7E0E8B26D3B0BAF2 + 5C6AE8262036A5E5D1085F9A49C1EF7CA0B6D651B0B787DEC66214E699721C9E + DEA02064B94C94365BC0EFC3D2EE25BAF5E6E0C0066B0F1E1FB1BC9FCCF25587 + 73B2376713706E7B40B55DF5F44D9D920755551E0FFA22E1EC562B08D8DEBA3C + A0113E7FFC80B3AB0794452274C84C67933B3B0DC81D522AE9BA05B53A113B6A + 4A0B59A0EF573F827C61E6CFC33390A487E0FA2EB5F0AACFF6A578022F20FEE3 + 581645BC0000000049454E44AE426082} end> end item @@ -20208,20 +20980,25 @@ object MainForm: TMainForm item Image.Data = { 89504E470D0A1A0A0000000D49484452000000100000001008060000001FF3FF - 61000001974944415478DA63FCFFFF3F0336F0E7CF1F56161696DF0C04002336 - 037EFEFCC9B578F1E229AAAAAA47ECEDEDE79164004CF3A74F9FDC3E7FFEFCCD - C1C1A1039F212806C034FFFAF5CB5302088006FC7E0004F80C811B00D3CCC4C4 - E4A9A0A020F1FDFB77866FDFBE31005DF2FBF1E3C70F1C1D1DB11A023600A699 - 9393D3534B4B4B02A4F1EBD7AF700C32E4C58B170F9C9D9D310C011BB065CB96 - F23B77EEA4FAFBFB2B7FF9F205AC09E87CB00B407C100685C7FBF7EFEF656464 - 44C9CACA5EA6AE0B280E036262E1CAD39373EF7CB8C4F0E5C72786EFDFBFFDF7 - B208AD8B724E6F212A1D5C7E767CEE5B961B0CC65AA60CB242AA0CFBAEAC6738 - 7EE530838D5C682F512931BED3FD7F90B7270303331383BF661E43CF9E140666 - 062686759B77FD6024262F785719FCCF8ECE61F0D24E81CB6FBA3C95A1657A33 - 034E0390815DBEE27F5F6F07863F0CFF182ADD1632B4EF8C67E06066C7EF0264 - 905C17F2FF3DDF65066B3D1B0655492386DBCFCF311CBD7484C14131AA972803 - 4060CA86968EB58716647DFDF185979B83E773B05DC2B49C809A0A00938D5CC5 - DBE34CD90000000049454E44AE426082} + 610000000774494D4507D7091C082D1B706CCEDA000000097048597300001EC1 + 00001EC101C36954530000000467414D410000B18F0BFC610500000203494441 + 5478DAA5524D48545114FEDECC9B99D28450C7C4C44D1024953FC8234982C442 + C28C68653FAB7057482B2B488C30DA0AD1BE1286162E424117AEACA89416E142 + 44B345A060D19833A2BDFBD73957E7CDBCC145D1817BCFBDE79EF39DF39D7381 + FF1487B797D3E90163D0AB8CAED55A436940B2567C3690A4F34B414943763DFB + F8C651CF65006DCCED2B5E59E5BF641E7CB57492B50520341BFC7AF939659694 + 454290164AE435D9726F775B8720844A1400188B7AB5FEE65F65DFDC2650A990 + 0760D224A9B76B81534F5B15BA9E7660FCD654C8CED2DD520E7F1720C29BDC05 + C805B2B43F398DEAF243B8F8EC5C60CFAD2DBFA8024100D448B85160F4FD1A86 + 273A114BC4E00B0149CEA9B9EB28898F00E413A38863874BE8AD880277C18D3A + B8EC25E1AB499BE9CCA353987EF0C152B8E45505552EAD6C404A1DAEC0D0DD25 + 42E39FBEE3CE6A2B7AF0055248EBD4F7D543DCFD08977E0D87D5D7ECA3848500 + 8466B83CA2D0D994049669A40BA3E8BF76CF6A8790CF3754A06CBF75C7C2B75F + 284DB87900FE752CD18883A9CF3FA0B21259910D4A16691F6FE6D3C1FD48321E + 4C6E0740CA9D1E1085B3272A61660C32BF3742A3BBD09C0CCE5C413482A21E10 + 85E37507B0FA730B5A6864FC300007158AD646174CC1BC7B985A6CF4952EB5F3 + 750C51D80C05DC7F3117BAAF67B6C7583B7B7DD583C335A6D8B6DEB7B2A7EF1F + 2FC319C14F17DD760000000049454E44AE426082} end> end item @@ -20230,23 +21007,25 @@ object MainForm: TMainForm item Image.Data = { 89504E470D0A1A0A0000000D49484452000000100000001008060000001FF3FF - 61000001FA4944415478DA63FCFFFF3FC393274F645EBE7C29FEF7EF5F66063C - 404C4CEC959C9CDC232626A67F303146900167CF9E35D6D1D1D9CBCCCCCCCBC8 - C8C8844DF39F3F7F184E9D3A35495656B61FD910B0014009332323A3E33F7FFE - 64021A80A2E9DFBF7F0CBF7EFD621016166678FDFA35C3EDDBB7510C61042A60 - 3C7DFAB4A9B1B1F1C9DFBF7F330005C19A600600BD0536404848084C83E42E5C - B830495A5ABA5F4141E1018A0120C530005208721DC810A0CB1804050551BC04 - F4B6B9A9A9E9691403401A605E00B141068230C81090EB408682D8C0C0C46E00 - 7AC0211B02C32043F8F9F9893300D9109046100DE2737171116F007278C0C288 - 8D8D8D3403409A9F6E9CC6F07CF374862F8FEE30B08A4B323018F94DB32B999C - 83D30090261878B6693AC3C7E32B19541D0219D895B419BE5FDCC970F5F0DE7F - 624E6985040D00D1C71334184CA3B21838EFEE67607872948141809FE10D8B3C - C3B54B4FEF138C051038E0C6C9E0DCB39281D128082EF7A14E9CE1CC9177FF91 - 0D38014ADAD8C2E070B40283A9AB2B03F7C3AD0C3FBFBF62F80614FBFC8989E1 - FE47E9A7E0BC70E6CC19133D3DBD83C0CCC40194C3C84C8FD7F431BCDE338741 - 46F027030BD35386CFAFFF30DC7BCDFA4F29A2A1166CC0E3C78F6541D919E81A - AC39119C2F4EAC8DFF7A646920E39B9712FF04455E8BBA242C30CC6C2F070010 - 3977340F6827150000000049454E44AE426082} + 610000000774494D4507D7091C08311D7F7836B2000000097048597300001EC1 + 00001EC101C36954530000000467414D410000B18F0BFC610500000204494441 + 5478DAA592496854411086FFB748A26344328907B7A3605C0764440888108228 + B8A007357812B783DE849CC41CF4E245CFA210154603824BE2493CB8A3288807 + 09064184884934796326F3667A29ABFB396FC9258A05FDAAAA5FD757D5550DFC + A738E673E3C9E459221C55A4976BADA134208D56C62648D6C9525092785FBFB9 + 707855D137004D746A5FB1A5ED5F329FBB3DB2DE680B609A0DBEF7B99F334BCE + 2221580B2512CD7B8D7FBD5BCE4308D5940290A51EEA38F257D92B2143A54202 + 309766293D1BB3FAC0D045909070E6F971D0AD9D67627BD7A656D4D300F90760 + E460E712D0101B3DFB418D4E0FDCB5FB0D992887D90A0403B891F03DE0CECB31 + ECA9D64C597100B13FF89AABE333A6A8D5CB16A02E665DC164F33D077B8BED10 + 572B70C35A0CD0D315EC2E26158C8C9621A5CE5640ECFB2E30F8761C5DC1349C + 996A1CA0D8BFFFEA3B7C7E3526AC636933274C039846A63CBEC2F6423B2A4119 + 3E674D0065746FC8A3657ED4D4E1AF01724D91EDDA26EA88E6B90E1EBD9F40FD + CB2882ADDD10FD03561B79FA71120FDF8DDB959E5C340529A31E306EDBBA36FC + 78F13833F7B074133BF2F9D83715782E66F580AFB076E5427CFB5945736717BC + 4539046B5660F1F193D61EEEBB94816A4D3A35057ADE57FAB4B1AE74CECC571C + BB82CBD74E4085027AA6869EC269E0FA870C60EA57F860CE273B55D84C739DF9 + 0D524C1E9FA00879F60000000049454E44AE426082} end> end item @@ -20255,24 +21034,29 @@ object MainForm: TMainForm item Image.Data = { 89504E470D0A1A0A0000000D49484452000000100000001008060000001FF3FF - 61000002194944415478DA63FCFFFF3F0336F0E7CF1F56161696DF0C04002336 - 037EFEFCC9B578F1E229AAAAAA47ECEDEDE79164004CF3A74F9FDC3E7FFEFCCD - C1C1A1039F212806C034FFFAF5CB5302088006FC7E0004F80C811B00D3CCC4C4 - E4A9A0A020F1FDFB77866FDFBE31005DF2FBF1E3C70F1C1D1DB11A023600A699 - 9393D3534B4B4B02A4F1EBD7AF700C32E4C58B170FD2C27555BF5E58C3C0CCA3 - C7F0F5CD0106399B9C78B0015BB66C29BF73E74EAABFBFBFF2972F5FC09A80CE - 07BB00C4076133D50F0C920C6F193845ED18F8158D183EDC3FC670F7D09A9744 - B9404DEC29838AF437061E7E638677776E32F08B2833B0F18A31DC38B8EC07C1 - 3050167DC3A028FA84815FC993E1E7F3E50CDFDF3232BCBAF18DE11F03DB5B45 - DF3A2BBCB1A023FF8D4194FD0A03BF4A00C38FA7D31898D8FE30FCFE22CFF0E1 - F48D97221EDD1E9C622A1770A60313A5BF89127C7719C47482809AA73230B1FE - 61F8F55991E1F98133FFE58327987148689DC199124FED98F69F97F11E83BA9D - 1FC3AF970B1818997F31FCF828C3F0EAF07986837F1CDFA5E45608E34C89E777 - CDF9CFFEE72EC31F46710661E1230C82626C40CDB20CAF8E5D6638F6D7EE7552 - 4E8518DEA4BCAAD3E97F58D67C869BCB8B189E02A38A5D5E9FE1FB9BAFFFD88D - B216DA7A452611CC0BADE97ABF4B13D3581898FE325CD8BD9EE1C9D3675F82A6 - DDE2253A334539497ED797176231D55460E097573D661C3EC11E5F6E04006B58 - 55345F31ADC00000000049454E44AE426082} + 610000000467414D410000AFC837058AE90000001974455874536F6674776172 + 650041646F626520496D616765526561647971C9653C0000027A4944415438CB + A5935948D45118C57FFF65C6B2316B320DB3D2CA362B6D71205A5EA5852202C1 + 882022DF7C8F1E5A20417A0DEA415F8AC0160A2C1F2AA47526ADA85C28B73442 + CC6574D4B174FCFFEFD2C3D428415174E1F2C1BDDCF39D73BE730DAD35FFB36C + 806BCF474F6BCD09A95596520AA9402885940AA93442AA195B2285462AF5BAFC + 486EC006505A971D0AA4A4FD4BE7B3373E6E4C30904AA501D4745F4128819002 + 57095CE94E5729127727B795E3BA32690640DC87C3EB8EFF55F76F31812BE4B4 + 07522A00AA83837F7CE8778264F7DFC2F26DA0D4FB94E64BBD476D00F10300A0 + 64473A374303146FCF489CDD6E1860F7B29744DB5E317BC31152733631FA6935 + 6D0FAB2ED800AE5428ADB12DB85D3F886599DC6918C430C104FCCE2362239DF8 + 73B713E96AC56B38A4CC5D846FC1D2D484040DD896C1C1C0426A5E8539104807 + 2036F48C898156E6E51431D5771D6FB2C1E7C636A21326C6D450BEF993815660 + 9B50FB268C65C5EB93500D93FDF799B7620FB12F95189E113CBE1492E4305723 + 451496DDE988030885D61A8F05FBB62C64966DB035B99E3549F5A4AEDC4FACF7 + 32A6C7C5896633146CC62938C5576F161097885071132DD3A0AE6908D55747A4 + 27447ADE5E9CFE2A2CAF662ABA8C81E76FE9CCAB00FFAAC4E4E2531022EE8109 + 8BC7EB10BA05A132E96BB9C8FC742FB1C81246DFB4915D52496EEA62DA7BC6B0 + 4CA619B8322E61FD521F4DC12AD6ED2825A92748474D88C607113ED4BDC3293C + 4377D4477BCF18004A693523483A74AEBAB3C0916A4E665718E77D2D39F93B19 + 0B0FD3F5B693C759E719BE3B0EB424B2313A1EBB0760FCFA9D8B77F927372FCF + B0036B73D09EA9179383E163FB2A9ABB7F97CEEFD0DF4B18DDB42B4300000000 + 49454E44AE426082} end> end item @@ -21858,27 +22642,63 @@ object MainForm: TMainForm SourceImages = < item Image.Data = { - 89504E470D0A1A0A0000000D49484452000000100000001008060000001FF3FF - 61000002564944415478DA63FCFFFF3F032580916203162D5A14FBF2E54B7166 - 66E6BF3F7EFCE0F0F3F3DBB475EB566F6E6EEEAF7FFEFC61F9F2E50B8FAEAEEE - E58B172FEA7371717D3335353D7DF7EE5DE5B76FDF0AABA8A8DC613C77EE9CA1 - A5A5E5F15FBF7EB175777797E6E7E74F041A1A979292320764C39E3D7B5C409A - ECECEC0E2524242C484A4A9AF7E0C103054F4FCFED870F1FB6057B012401D2E4 - EBEBBB79E3C68DFE208DC6C6C667CF9F3F6F585656D69591913123373777F2E6 - CD9B7D41722035A74F9F366D6969A9011B70F6EC59633333B353206FDCBB774F - 494646E6C982050B1240B6898B8BBFF4F6F6DE0A72918585C50990010101011B - 7A7B7B8B959595EFC203D1C6C6E6C8B163C7ACAAABAB5B9B9B9B6BBF7FFFCE29 - 2B2BFBF8DDBB77424E4E4EFB405E01A97BFAF4A9746A6AEAEC6DDBB679A1C4C2 - 8A152B22A2A2A296898989BD7AF8F0A13C3B3BFBCFE2E2E2DEFEFEFE427D7DFD - 8B20EF80D4819CADADAD7D353030703D8A01BF7FFF66555454BCFFECD933A9F9 - F3E727C6C7C72FDCB16387879797D73690FCFEFDFB1D4101E9E8E8B87FEFDEBD - CE20EF62A40390D3EBEBEB1B4101080AA49090903520034F9C3861111414B42E - 3B3B7BEA9123476C6A6B6B9BB12624507A50505078008AD2499326E55DB870C1 - 20393979AE9595D5311616963F0E0E0E0740812B2525F50C674A0485F6BC79F3 - 92383939BF5FBF7E5D534E4EEE11289D9C3C79D21C94C8366CD810803729836C - 0579212B2B6BDAE4C9937341624B972E8D8E8D8D5D0CD20C3284605E68000290 - 4B40E901C40779A9BCBCBCB3ABABAB8C9595F537753313A50600007A0B3F0EC1 - C459730000000049454E44AE426082} + 89504E470D0A1A0A0000000D4948445200000060000000600803000000D54687 + 0A000000017352474200AECE1CE90000000467414D410000B18F0BFC61050000 + 0300504C5445000000FFE6AD84E610CEE610E6E69CB5EFE6B5A5EF84EFE684A5 + EF52BD6B526BEF52BD29526BAD19BD6B196BEF19BD29196BADB5CEE6B5A5CE84 + CEE684A5CE52BD4A526BCE52BD08526B8C19BD4A196BCE19BD08196B8CB594A5 + 8494A54210194210B50810B552634ACE311984319C84A531CEA531CE73DECEEF + 63CE735A8473DE84EF63847319CE739CCE731984739CA5525AA5105AEF10DEEF + 105AA510DEA51019EF109CEF1019A5109CA5A510EFA510CE52DECECE63CE525A + 8452DE84CE63845219CE529CCE521984529CE6EFBD423A19A59C734242421008 + 007B735AE6EFEF849C52E6C594193A0842104A4210E642107B0810E608107B08 + 104AB5B59C5A421952EFEF52EF6B52946B529CEF52EF29529CAD52942952EFAD + 19EF6B199CEF19EF29199CADEFA57319946B19EFEF19942919EFAD526B6B52C5 + EF526B2952C5AD196B6B19C5EF196B2919C5AD84E631CEE63184A573A5E610EF + E61052EFCE52EF4A52944A529CCE52EF08529C8C52940852EF8C19EF4A199CCE + 19EF08199C8CEFA55219944A19EFCE19940819EF8C52C5CE526B0852C58C196B + 4A19C5CE196B0819C58C4242B50842B5C5A573EF73DEEFEF63EF735AA573DEA5 + EF63A5315AEF31DEEF315AA531DEA53119EF319CEF3119A5319CA57319EF739C + EF7319A5739CA5A531EFA5317B525AEF52DEEFCE63EF525AA552DEA5CE63A552 + 19EF529CEF5219A5529C84B5A56310196310B52910B5193A21191021E6C5ADE6 + C5EFE69CEFE6C5CEE69CCE4242E642427B0842E608427B08424AE69C945A424A + A59C52A5E631EFE631C5A55263104A6310E663107B2910E629107B29104A6342 + B52942B584106BCE10EFCE106B8410EF841029CE10ADCE10298410AD84B510CE + B51084104ACE10CECE104A8410CE841008CE108CCE100884108C849410CE9410 + B5EFB584EFB5B5CEB584CEB5B5EF9484EF94B5CE9484CE949C736B6342E66342 + 7B2942E629427B29424AE69CB584316BCE31EFCE316B8431EF843129CE31ADA5 + 734A84314ACE31CECE314A8431CE843108CE318C002919FFF79CFFDE94000019 + FFDEAD000000F264CAE80000010074524E53FFFFFFFFFFFFFFFFFFFFFFFFFFFF + FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF + FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF + FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF + FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF + FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF + FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF + FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF + FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0053F7072500000009704859730000 + 0EC300000EC301C76FA86400000289494441546843ED97DDADE3201046417225 + F4626C241EB72E6A5917E0765C86B3DF3703896F1C7922DDF51BE7612180E7C0 + F0B3BAEE71335D60D205265D60D205265D60D205265D60D205265D60D20526EE + E16FE5E16AE536BAC0E47F09F6BD56DEF995609B4246EC18C6C54DB5ED9DDF08 + 36E7DCE87D41E16E1104064639C4AF0425855ABB668F296A8D535F59C9DF0846 + E7E65ABDA4CCCEB599E458B4FC4680EFBE12301DEF4BFD46C089CD39E7417E0D + 71DB220E08128236B0FB81C5E0F7C4BC480B02974DB27514E4E7A78A0A062448 + 49FC15600323C6311E885A499C87527C585048DC9720D740E1792D5490D795CD + EBBA6246C35FC42E1C3A673F6860B462441AE2CA080B06661F58FD29900DCAFC + 17C757F9B0077461EEFC8AC9A601C3F7D16DEC3DECC19F16B70906AC6941C94F + EA49FB20E0688EF228D982C80EB1530D7B25E0CD631FC7C8F9056741BD9FD2E2 + B8E719F39AA31B35AD5782092597C90BD2727416F07E8E1B4029027D0BB01FC2 + 9580BB1EF0A5846007380B64BB2BDA22396D4BBE1270CD0DE9009F5710F68AB4 + C8D2DBAE598258BF6CE7F42CE0749B5E496EE536688EAE047A1C7E721630E32D + E14271CBCEB0BACBACD5749D04C7DC378E029E7E1C4B6E550DC19079C6ADD5C4 + B1E970424E029635952D432F815CCB52E22E7374632C651B7183710D18987748 + BE95200903D5F5148894D370019FA645DFD983409E045C31AC420E289960C3CA + 3858BB198E3301C1EB8B35E2516A15BF3F8F20DF34E129F06971F38405809C96 + D92D1327BCE1D9E1031558AE2BBAF384BE8068DA82CE6705947599E785FF5557 + 5E8243DEC88F1F6F5CF5BD7314DC421798DCFFF741FD43E436BAC0A40B4CBAC0 + A40B4CBAC0A40B4CBAC0A40B4CBAC0A40B4C6E163C1EFF0089F464836E63FC71 + 0000000049454E44AE426082} end> end item @@ -23936,6 +24756,1012 @@ object MainForm: TMainForm C895C94D15F9ED6FC7D9A2E0829BE75FE95E533E2BD255DAD4709CFF0775F948 AA1FAD341C0000000049454E44AE426082} end> + end + item + Name = 'icons8-markdown' + SourceImages = < + item + Image.Data = { + 89504E470D0A1A0A0000000D4948445200000060000000600806000000E29877 + 3800000006624B474400FF00FF00FFA0BDA793000006CE494441545809ED997F + 50545514C7CF7BEC8E895A8E069A35656139E34C7F9452EA984EA158D938D6A4 + 4318A441588C36E934538936E9D4983F111141604441766D9C1A7F4C8C82250A + A1526AE6A456F803050CD4FC9520BBCBBEEE5979EC826FDFEEBEDDFB36D6C370 + F6DE7BEE8F73DFE7BB7BEFBBEF01D01F11200244800810012240048800112002 + 44800810012240048800112002448008100122400488001108650242D78B1B1F + 97344914857809A468098481AC419FAE6DA8EC3D0109E0A600D2DF8C65356369 + 2A33E597B8F666BE3BC557A6CE8CB0190D9B01A4D83B1EFAE44140106097C52E + 26949B732FE3F80E016213DE8F84365B15532B0A9D64DC09D4582571148A2062 + 28A9CD6626F84842371B6214A4628C264C78FBBDC96097B663814C5F02925D7A + 4D94EC3053DFB0144D262088C2BBA22049D1B28352DD09448B2040A4EE6129A0 + 4C60206EC246B944A9EE048C2880EE5129A0930009E06411941C091014ECCEA0 + 248093455072244050B03B831A9C59DF72A5C5796E3B4892049F2D5D0D478E9F + 70DBC6978A291363203531CE6D976B376EC2B40FE6B9ADF7A542EDBA0219479E + 13975F80C01EF92D98330B0644F497E3684E873D1505B3A64FD3DCFFFFDE918B + 0078D1BD7B85038A603068FE91419FDEBD206D760A8485719B264E35A8C6F5CA + 86463D0E33A74DD17C8173931321A27F3FCDFDBB4347AE022080375F8D85D123 + 9EC1AC4F3679C28B3026FA599FFA74C7C6DC05C0FDE0E394193030E241AFF90C + 19FC6848AFFBAE20B80B80C1703F48FB701678B31F84F7EC090B585BA351FBDE + 8131BB8BE92200C218FAC460488E7B03B3AA36373901060D88546D134A95BA09 + 80D05E7F79BCEABA1E3B76348C1B796FBD9ED05500DC0FE6A5BCA3B81F3CF6F0 + 20983D231E75BAA78C8B0056AB0D6C369B22C8DEE1E1F0696A3218C2C23AEA71 + BDFF243509EEEBD1A3C3E79A69B97DDBB51852792E02DC6A6981ECA26FDC82C2 + D36DCAF4A91DF5A9097180773E1D8E2E9915EB0BBA7842A7C8ED5663E79E7218 + F66414C48C19A9480B9FEF1C3FF527180D469814334EB10D3A7794ED858AEA23 + 980D49E32600D2CADA6406FCB63F141981C5BBECA3A444C07DE1AE8A76C7D90B + F59067DADA5E0ACD84CB1224A3FAB7B919BE589505AD16ABECEA94E2B31E3C23 + 7472B6176E35B7C0A274F77DDB9B75FB84AB004807BFC5D9455B30EB93A5E717 + 4243E3259FFA74C7C65C97201948C98FFB61F8D3C3E085E786CB2ED574F7BE9F + 60FFA15F54DBF85289CB5CDA9C1418FBFC085FBADDD5B6EFFD7D40ED7D81DC61 + F3773BA1F0DB1D725135E5FE0B90A32FCF2980F3F517E5A2DBB4E6DC79C82C28 + 765BAFA5025F107D9D951FB017446A73D85956EE357C1C4737016EB7B6C2976B + D6B3FDC0827115AD99DDBE621B8B5579CF50ECE4A5D3D6D6068B3372E0CCF90B + 5EF6F0BDD9C123C720ABD0EC5347DD04C0599DABAB07BC33C2BC92A5E717B175 + BF49A92A203E14386DD91AB874E59F808CE73AC8E9DA0BB084FDCAEC76BBABDB + 635E57017036BBCA2BA1ACE200663B19FAF71DFCB9938F47E1CAD56B307F5906 + E01D5AA0C66F62822E58BE06B49CD87517002F1AD7F8DAFA06CC3A0C9785B51B + 4D8EBC1E1FB5750DB068D53AC04726FEC64321D398A028AC96B1822280EB7E80 + DF1A5EEBBE1A906327FF8015B905801BB45A3BB53A7CDEB5283D1B5050B5766A + 75BADC862A4D00278DBF044902A8BBD8A8D484BB6F6F5535E0297DC6546DEFAD + 333614C3B113A7FC9A67D004C05997EEAFC224A866DAF63DF4EBFB00E03B685F + 2662DE5E02BBF755FAD245B16D509620C59904D1B9AE700B541DFED5EB19ECA9 + 3C001BB76EF3BABD5A431280D1C15BC7256BF3E064CD195652FF3FFAFB495895 + BBC9AFBDC3350209D04EA3D56281CF57AE553D87E03966F1EA6CC0435D7B37BF + 1312C005E1F51B3761FED20CC0D4C5EDC85EBD7E0316AEC8047C4AEB7004E883 + 04E802B2A1B10916AECCECF4C8046F9BF1A0D578E94A97D6FE1749000586A76A + CEC2B2EC0D8E751EF787AF3273E1AFB3B50A2DFD7719FC1F223447A8A83E0CEB + 8BB73211EC70E8E86FDC2E5298109FCC8E42DCC6A7813D10A025C80320DED524 + 006FC21EC627013C00E25D4D02F026EC617C12C00320DED52840E05FC0F29E75 + E88C6F410182F3303E7420FA732517990052A53F23505FED04D801AC52045134 + 6B1F827AFA43400030310360A7E11FD8402F31A37FDD0808A565A6BC8922C613 + C20C6F31254E639E4C1702355649988E911C029416E5348559DB460902EC4227 + 1957022556491C556ECEBD8C51D8171F13A7C5C6278D95404804906200844758 + 8D8119FD6B2760632CEB18CB3DA20885BB37E757681F8A7A1201224004880011 + 2002448008100122400488001120024480081001224004880011200244800810 + 81EE46E03F67EBEC02047C01690000000049454E44AE426082} + end> + end + item + Name = 'icons8-js' + SourceImages = < + item + Image.Data = { + 89504E470D0A1A0A0000000D4948445200000060000000600806000000E29877 + 3800000006624B474400FF00FF00FFA0BDA79300000613494441545809ED996B + 6C145514C7FF33DBD296BE295D5CA49457454ACB435E091134180AB13CD46063 + F4831FD062349A468D1F8C89DFF4136A44FC4040A32662783421544050438C44 + 0984D8022D60C19497C5BEDBED73BB3B9E3376D63B1B10509919266773CFDE7B + CEBD77CFEEEFDCB9AF05E4250484801010024240080801212004848010100242 + 4008080121200484801010024240080801212004848010100242400808012120 + 048480DF0868893FA8BCA6BA44D7A3EB016D39C938C0189BD846F4DB21A0B512 + C36618388400B6ED5DB9EEB4DA3B1E802777EC183598A9BF671878811A044824 + FDFF04A2148C8F43C1F6D7B6CCDF10E18F3703C0F00732B41A1AF134EAD92C72 + 87091C4C0DC756EFACA818D2D9D14086BE49E03309C7A48C987FC0DEB4B55FEF + 288D69FA2FA498C1A05C923304A23A62B3F4A8A657923F814F101C4E8128F44A + 9D1681471C762CEE4608307B1EF90523BA64CE1328E4006438EF573C8E10C8E4 + 008C942573838004C00DEA8A4F098002C38DA204C00DEA8ACF24A5EC9B625A52 + 120A32B290164842C7E0007EEF0B23128B79F2F7DD150148D27554AF78DC0670 + CDFEDD369D9519B97978BAA818A563F2A16BB4CB662349F7D020BEBDDC84ED8D + F5188C46C9E29D745704E0567095154CC68B33E7DAC05BFDB246A5E08929F761 + 7EF01EBC79F4077040AC3AB7735FAC0153B2726E085F053C91A6A5574AE7A926 + D7CBBE78021E9B5C641BF9E7BB3BF161DD7174D2D4B328381E95C5B3C1D318D3 + 5E180CA130330B4D3DDDACBA2EBE7802EECFC9B381DC5A5F8BDF7ABACC05F8C0 + A50B387CF5A2AD7E417EC8A6BBA9F8E209E05D8F0AB19D763EAA7EAABD1525B4 + 305BB6E440C02ABA9EFB22002DFD7DC8A685D6A2595E38155B1B6A2D15DF5F69 + 32256EF05041F7D077F9D75FE5A76B576D7DD74C9A8657672F407EDA689BDD8B + 8A2F0250D3D4681EB654C00F8F9F882D0FAD40D5ACF998909EA95679AAEC8B00 + F40F0FE3ED633FE24A6F8F0D6E40D3B1ECDE426C5EB21CAFCF59689BA66C0D5D + 547C1100E6D7DCD78BAA23DFE1CB5FEB118E0CB1292E1A9D8A97860AB071F132 + 8C4B4B8FDBBD50F04D0018265F337CD5D880E70E1FC017E74EA38BCE016CB724 + 486BC21B7317E1EF4B0AABC6BDDC5701B030F60D47B0F3FC193C4F81D875E1AC + 6536F3A2EC5C94E6E59B652FBCDD15DB503D61CC1A0AB9828C4C14E78E8D5BAE + F68671B2BDC5D407A2C3F8FCEC2914D215C4023A019B467AE3CBBABAB6BFDA90 + EA6AF24C00F816F3A96933E23076D3C8FD8CE0B1213D3999B3B8F4D308B79409 + E95978A9E4014BC5F196E678002CE3D9CE76A801C84E49B1AA5CCF3D3305F1BD + BD4A83EFF32D7D2A5DB65965CE79C1E59CE572C2CE677ACE18249E8C735352B9 + 695CFA68D714575C2E782600F51D6D3614F3F2C7814FB43C5D3C3BBDC456C7A3 + DC325C0A77E31C8D704BCF4C1E85B7E62D36E7F9D0E80C3C189A606E45AD7ACE + 1BBB3A38F38478660A6AA2CBB3DAB63F303B2F6882E13DFC86E23966597DE305 + 765FD379D5846D67EAF0CEA2A5E03E5CC1412B5D78FD85F65A7F2F8E269C9CB9 + 8F5BE2992780017C74F204DA06FAB9785D19A27FB336D61E43E2655B033D3DEF + D71E071FC8AEDB71C4D843E783774FFCECA9BF27B5D5FB76A99B8A91AFEA5E96 + 430BE4334533C107276B2E8F1A31F08DE6270D75E635F38DBE1DEFF3D74E2AC2 + 123A74F1E758EDF8A939D27C05DBE990D6FA0F01B6DA3B997B2E00D68FE73F50 + C6A6A6216618E6BD7E2416B3AA6E29E79D13AF07DCBF85A01BF439B7D4D1E146 + 9E5903127FF7300157773B89F537D37B2311B0DCAC9DDBF59E5A03DC86E1867F + 09801BD4159F120005861B4509801BD4159F1C805E4597A2B3047A3800179DF5 + 29DE140217751838A018A4E82C81FDBA8ED8A7E4F3F64E39D441D27F261065F6 + FA9EF28A93F4515B4924394B60CB9E472BEA75F6991A8EBD0C1887B82CE20881 + 83C4BC8A3D9901D8595131941A3656691A3693314A22E9CE1020B6C6A650B06D + 153367171ABFA9525E535DA2EBD1F5805646F62924F6BF93C820E9B6080C50EB + 0BB4D9F906016CDBBB72DD69D225090121200484801010024240080801212004 + 8480101002424008080121200484801010024240080801212004848010100242 + 4008080121E063027F022693919A528D837B0000000049454E44AE426082} + end> + end + item + Name = 'icons8-sql' + SourceImages = < + item + Image.Data = { + 89504E470D0A1A0A0000000D4948445200000060000000600806000000E29877 + 3800000006624B474400FF00FF00FFA0BDA793000009CD494441545809ED596B + 4C1CD7153E33BBBC59C3C2B260A8C1E0105EE1D1C4712C1C9BB61179A9B595AA + 49938A4855A42A525A358D7F58A9D47FFD57B5B6D2A8F69FFE6855A7AED2DA69 + A5246E9D38698A1325B59D60FC066C4330D818B26B5858D8651F3D6760666716 + 767C6F197631DCD53D3BE7DE73EEB933DF37F73900E227101008080404020201 + 818040402020101008AC3504249E073E7F62B83C04B67D5867078A0B45A41802 + 630866A74D96F634B4BAFB62C5E61AD6317750ADF3E07761DE8922526204BC72 + 38D4DCD8563698D825669163AAB936FFE60BF0CD6122AB3322DBF792C222CC04 + 60B076149158109080192B1E021C2C6D0B1F05813CE59FE18F87008670C28517 + 0141002F6216FB0B022C0694379C208017318BFD05011603CA1B4E10C08B98C5 + FE82008B01E50D2708E045CC627F4180C580F2861304F02266B1BF20C0624079 + C309027811B3D85F106031A0BCE10401BC8859EC2F08B01850DE703C044CF206 + 5FABFEF89D7782F5D9790838CE1A74ADFB45A3708C1503660224D9F62A06F5A2 + 88648E80478E84769BBBC4ACCC0434B5BA2ED921DC82558FA0F85044D221303F + EC1C96C3A196C6B6B2419DC954C57AA6762E6377E76D67540A5CC64A4528AB31 + DD9CB6DB6BB66E2D9CB0EAE1987B004B831139B81BFD562BF8F8685092150EBD + 428A5562590FF8E2436FBE9C16EC07803C94D59C3C19206FAC7DB8C89261D8B2 + 1E20A5075F40D4573BF8F88850108886E959495FB270F580F32786CB4360DB87 + ADEE4071A1881443600CC1ECB4C9D29E8656775FACD85CC33AE60EAA751EFC2E + CC3B512C4B53BE20040361484BB741EEBA74AEB8B8DE06FFE45CFDF40C1B64E7 + A683C4FC445C4DF1387B7125D4CCBA12B2B3469E7FF32D013F8AC8FDF7A321F8 + EC83EBE0199DD66E2123D30635CD2ED8FE580514ADCFD1CAE395C989207CF44E + 3F5CEC1A05D2553B1158D75204DB1F2F8775CE4CB558BB9E3B750BFEF9D75E2D + 5FFF75373CF96CB596B748714664FB5E8CF534CA1D13330118A91D65C929301D + 823F1F380B03BDB717C40ACC84A1FBB311B8F0F9287CEF857AA84530E39D86BF + F4C1C1D7BBF0CD0FC59B14324EFE6708BA4F8E40C78F9B60C3A63C83CF6C30AC + F8A88533D3B3AA6AED550266AC648E961D1CBE095DFFFEC78B8B82AFAF109A8D + C05BE8A7EF1D64A7B7FDE06FCF2C0A3ED95521920FFEAE1BC6BF9A518B927D35 + 326FD23A4F0F3009C366BA353C0517CF8C199CB73F5E018D0F162B6FE6D1377B + 60F4865FB1536FF8F4C3EBF0E433D54A9EFE8EFFE32AF8A7626FAD233F03DA9F + DA04AE926CF08E4DC3FB47AE80771E7422E1E8DFFAE0D917EFA3AA2B56787AC0 + 921F62A0CF38EC6CAA2F8047765581BB3407AA6A9DB0B3A3CED0C6651CE3D502 + 02F4DCA91135AB4CB61D3F6982A62DC5505AEE8086FBDDD0F1D366906DB147BA + 8C644F7853D60BB47B355362776BE665918D40D4872A2CCED667A16CA303B273 + D2202B7B4E6667C3100947149F7E9C336683733A156CA8CA83E2B25C52352974 + 67C3BDF71568799AECAFF51849D78C2B4449EA10B40E870CFD73F7768F41107B + 002D21A95C9625D8F3EB87495D2034F9EA0BCBE32658D5565AB10E2EE19BAFE6 + 6F0CF8A0F9A11235BBE2AE49ED0155750560B7C716EA345EFFFE57A7E1FAB589 + 3B0243FB05BD534E823D438EC3B897F0E13E435F6FA5E9492580D6E9DBDACB0D + 18D0C44C24BC81AB967E93E182366BFA8A99598B77DEAC1C6379C01FD6575B71 + BAF16E93707BDFF84E25F87023F5F9C7370CADF59EFB0A4868427DECE97BA0E2 + 9E7C833D1A316401621DC9609070183314ACF04C527B006121E159C1CE8E5A78 + EA8775E0746551914168ACFFC3DE2E8827C8E0B48A3249EF012A763431D212F2 + C2E951E83C36003707275513D0EAE5ED433D505AE18092AFCDAD749037CDAE28 + 51E57FC19F84C71CFA4229E9AF98BEF53BEB29BD3DEA0D0D9BDDF0E2CF1F8467 + 7ED400FAF19B969F9D4707B42748C773222D83CA8C3F84FF0B937FCA589E68AE + 585833352549ED0117BE1855DE6EF551EBF0E08D364EF476D7E346CA96668343 + FBBB55335CEBF1683AED0FB40C2AFA1D3166B514BF5ACACA4DD36C2B51492A01 + 47DFEC05DFED8086C3CBBFDC6A98072A6B8C13AF7F3204A1505459BA966C301E + 45DD1C9AD2E2E895C1ABE3FA2C94C46DD60CC6159049EA105450649C7407AF4E + 182008C40D2BB431534F1636DE9BAF10A156B872C16338CAA672DF7800AE5C8C + F51A2A8B2795CA569224B50734E2B98DFE18FABDB7AE400E0E1115D5F9100E45 + E05F87FB0CD89494E782BAACA421A8FE01B7725C4D4E34471C7CFD0C3C814B56 + 177E3BF08ECD00F5B030F618B2935437141A7A1895E965DC1380F3A76FE98B34 + 9D76EDF1C7D99AD14225A904346F298193FF1E8291A1B9150F0D477F4210133D + CFFDDB4A0D263AF9EC3DEB8169FFDC89281D57BFB1FFACC147CDD8D364F8D6AE + 4A35BBE8950E07491633D63416C2732F352D66B2B48C67089A436D09CDA7A5CB + F0037CA8A2F5D9778C421F631ED8B6DEE0E7C8CBC0FA8D90916017AC77DEF57C + 2DAC8F9B37F4F6E5D42500E3D86AD2180F01C74DE2309BF20A32946567DB1315 + 8B7E362C7467C1B79FAB81EFE3B29496A9F181695878E9175BA0E9A162A04F98 + F17635FFE90783F8E166AEA7A865C9BAE256E4186B5B48169B6BF72763B5D148 + F813F476A25892A2912878F0438A6F3CA89CEF3B0B33172525516334DE7B46FD + 40F567F053E7BB7FE9513EECA8FE0545D9F0FCCBCD4071D5B2245C3D7238D4D2 + D85636C8D216330114ECFC89E1F210D8F6A1DE8E625C176241AA13CD093431D3 + 55BD9747BFBB095AE30E00559B955704720237E7EF21F8AFB0824FED633DBA2C + 5DBA3E1ED92D45E1374B8FB4B408D3B8133E74A05B39E2DE89F340CBD665F816 + 108DFEAC797BC96B4BBBD3B9DA961170EAD47076DA8CAD1F008A50529AE8CBDB + 97F8F9B3BAD165F97D2060371CB3FEAACA6F56CE58119C6712366D6FF3E6523F + 48514BDE0AD386188CB44A5A0EF095A6A3D26B56814FF12C2380824991CCFD78 + 1D4559ADE9A63FCD76C0CA87C31EC51E4E3709EFC05AD6F76F0C7A17A73104B3 + D3264B7B1A5ADDC62DBDC943611D13ABCE340F7E17163951444A8C80175742CD + AC2B21E621687EF9B986C1C7456662D0F5166744B6EFD51798E9CC0460105AFB + E365AD26E6C182BE573363C5438063AD42FF7F3C771E6B1D1E0258630A3F0E04 + 04011C602D87AB20603950E5882908E0006B395C0501CB812A47CCD411C0BCAC + E6789ABBD0357504702CABEF425C996F39750430DFE2EA761404A4985F418020 + 20C508A4B879D1030401294620C5CD8B1E2008483102296E9EA7074CA6F85EEF + 9AE6718F39C17AB33C041C670DBAD6FDA25138C68A013301926C7B15837A5144 + 3247C0234742BBCD5D625666029A5A5D97EC106EC1AA47507C2822E910981F76 + 0ECBE1504B635BD9A0CE24548180404020201010080804040202018180404020 + 6040E07F8F2A9E1072D527DE0000000049454E44AE426082} + end> + end + item + Name = 'icons8-php' + SourceImages = < + item + Image.Data = { + 89504E470D0A1A0A0000000D494844520000006400000064080600000070E295 + 54000000017352474200AECE1CE90000000467414D410000B18F0BFC61050000 + 00097048597300000EC300000EC301C76FA86400000DAE49444154785EED9C0B + 7054D519C7BF4D42DE214F424810792A8A0A16450BF22896822888B5542CEDA8 + 75AC9DE9A4ED385AECB463B59DB1B58CF681A2ED4C67AAA5B64A05F15144232D + D022A2808880BC9F0292377993C7F6FFBF7B1276B3E7ECEEDD249B40CF6FE6CF + EE5D763777CF77CFF73A67572C168BC562B1582C168BC562B1582C168BC562B1 + 582C168BC562B1582C16CBF98E47DDF6599E58B296E7180F2542295092BA9FA0 + 1407B57F0E2FD406B5289D859AA04675BF6551F1743EA7CFD2A70C82C1CFC0CD + 25D048682874313408CA8732A134A8DD28140D4263F91BA4156A37060DD100D5 + 41D5502974023A0A1D82F643FB60A433B8ED13C4DC204F2C7917FF7A38A81CEC + CBA0F1D058A52288577C2CE18CFA0CFA18DA0E6D8176414760DF8645C537E26E + ECE87183E0AAE74D3F88833D0DFA1274AD3A4E87626D80707096D54034D207D0 + BF958E43CD984DB8E9397ACC2030046701AFFEAF40B7406320FAFEF311BABF9D + D09BD01A680B0C4357D8ED74AB4160040E3863C01DD03C88B12019BA906092C0 + D8B3127A09DA0BE3D060DD42B7180486A0EB9903DD0D4D812E34239860D2B01E + 7A1E7A0D86A9E5835D216A83A8D89007DD057D07E26CE8F17870F4D02ED9B767 + AB3A3A47BF7E893261E2CD929CC2442CE63031E0ACF923F402541A6DAC89CA20 + 6A46DC0F7D0F1AC6C762C5FA775F964F77BEAF8ECE919935406E5BF043494CEC + F5C9C974FA19E80FD1CC185706812198FBDF06FD1CE28CE8D618140EAFD72B2B + 5FFAAD949D66C213C890A197C9CC39F78AC713D35332C14C8D33E667B8B3E2E1 + E2E98C3B1111D1D92BF734027A0ABA09621A1B73EAEB6BE495179F9406DC7666 + DCF8E93261D2CDEAA8CFD00CAD861E800E44E2C6C2FAFC277EBF96D5F07DD026 + 682ED42BC62067AACBE46C933EDBCCCB1FACEEF52938561C33FAD8FBD4588624 + A4413033B230879EC6DDA5100378AF5259FEB9B4B6B22B124CEE804275AF4F92 + 0B2DE558624CB37D0FE9311A042FE425F71AC4E01DD6B2B140173B48BFC424E9 + 9FC9CFDCA7E118722C5F5563AB451B43F08251B861D173B5F340849C3A71484A + 4F1F534791111FDF4FD2D333252B67A0A4A6F5978404BD47F47ADB64D5F2A7E5 + F4A923EA9173A4A665CAD8F1ECCA74C6837438091958AE938525A7A44B5C5CF0 + 3578ECC81EA9AAFC5C1D45464242A2A467644B56763EFE7E063E87AB6B761B74 + 0762CA3EDFE139820C02630CC1CDEBD055CE032E2859FD1739B8EF2375E40E7E + A09CBC41326AF43572E9E5D73A03E94F73F35959F6A7C7A4F92C6B31F72426A5 + 48E1E01172C5D8C9B86582E8A3ADAD55DE5CF99C9CFCECA07AC41D344C5E7E91 + 8C1E73BD8C183556E20D1794063633E7C028EC3C77C0D6750730460E6E96436C + FEB982BE7DEBFB6F4B63233BDDEEE10CA8AF3B23C78FEE91E347F64A41E13049 + C115DD4E65C529D9B97D833A720FCFAFAAF2B41CD8BB1DB3C423F905439D14B9 + B1B15E3EFA702D0C1D71661A000D5A5B5325470EED9453270F4BD1904B22AD85 + 0642D7CC987DD7AA92D5CF77642A1DF317C6A0711E876E701E700907B3A1A1CB + 9D03A7D6A0DB2B59FD42C0FB9597B2F9DA755A5B9B650B2E9CCF8EED758EEBEB + 6AB469B45B78DE278EEF977FADF9AB9C8D7C164F861EC7D877D8C1B9830778F3 + 75E81EDE8986EAAA5237271296CAF253B26D73893A1218491FD0A381B365E7C7 + FF75EED3D06D6DEC7C740F278E1F90DD3BDE534711C131BF43D9A063866441AC + BEA36E8F57949D14AFE683D12D0C1E7269905837748E139D39746087346296F0 + EAAB28E3425F30746BBAF7A7CB4B4C32BB8EEACA52C7DD98661ECFADE8A24B02 + DE93EE2837AFD09878B4B367D707CE7B4708C79C634F1BF8823AACF3106E7ECD + FBD1B2F6AD65B27F2F93874032FAE7C89D77FF441D054237B775F33BB27BE726 + AD319911CD9EF75DC9CE1D282BFEF694D4D57215361006E98953D9E90FA6BCF4 + 84BCBEE2191493C1339759DDD7BEF1A0BCB1E2596487C1019D817FF6BCFBB559 + D999EA72F970D35BB25FD3E4240CECB7DFF9809381B9E04708F08BE3608CFE38 + 88DA55114EF9F2F293EA28906C7C70134C73BF3879AE14169DCB7AFCE1FBD6D5 + 564A1D826663833E59608663223D234B9212B94E160CEB16BAAEEAAAD3EA9140 + 9826EB8C41F8DA1BA6DD8E6254FFB7DB5A7D81DE25F7D016FC8B1321D61D51C3 + 54F44C55993A0A243BA740DDD3C3ABA9F022F39F6F6E6E960AC4135D854E7798 + 37C0DC32696A6A900643D697935BA05A31FAB8C759190ABAC38183B80F438757 + 5A5BD8C672050761220D3213EA52256E1A3012EE839136C36B09FDB5A9424F4A + 4A958C4C66EA7A9868B4A07ED1919D3BC8491CF4868EC30C09EF6ECCE7EDC185 + E67A48F9829934C875CE6117283304C6B8B87867EA87A3E64CB9BA170867404A + 6ABAF1FD19071250E99B283724027CDF6CF877D3FB723033C3B46218F36A6B2A + D551207475FE35940BAEA341BAE4AE4899A15DC2699D96CEED54665A30B5197C + 7530D3494BCFC20CD4C72736143D063F4FCA4FEB079C332B2535C368B02454F5 + A961CE9B297E6585BEDDC2F3CE88AEB7368A9F2664F7311C4CEF38F5752425A7 + 391F3C141CEC2AB8161DCCD078259ADA257986A04A58F957A0BAD7C18B84B3C4 + 14F7F877C3A5B69F9F3AE264893A18ECA35CB9CCA641BA5415B1D2ADD5A4A324 + 33332F64D38DC6DC8AE2CF1400878DBCCA3118EB90CE3019C8411C30D1505F8B + 0C4D9FE9F4CFCA93A6C6066D1A4DC225226CB36CFBA0447B5E64E4A5AE7AB2FE + B4D1207A071E21B53515C866EAD551205939E6C0C860BB65D3DB72EC30370906 + 43B7316AF4F8906E8557B2896A5CFD2DC8D0743015676FCC54BC854AD5E9AA36 + AE7F55DB75264C89870CBD5C1DB9A68C06F9D4773F3AE8FF75451D617BBAA9B1 + BE43BC6A5919EFDAF11E0AB6A5B2ED43FD55467772C5B8294EFC3055D23446A8 + 1D2674A3E6012F08D98AA14BF33F6F7A013EFFE3ADEB64D5CB4B50896F36CC0E + 8F8CBBE646271189923D1E14236C28FED877EC9E75252F3927A8832D6F7F97C5 + 0FD1D2DCE404F2500C2A1C2E33E7DEEB14862BFFFE1B646115EA7FCE31E6AA1B + 64D234EEB7D0B361ED3F64F727C13D259ECFADF38B65F3C67F3A9D651D49C9A9 + 4E86D80EE311DBFFE16A8B8B878F9119B3EF0A78AD4B7EC919C2AD9151EFBC33 + D50884EBDFECA4B68B7DA970C6C846C13675C6022728F23575757A3F1FAA4267 + A54C97A483C19A89065BF1267CB3D9FFBCEBC21A83BDB329D3E777C518B4C19A + 38AF78B9A1F813E7219734E36A3765486EA19B2A281A2EB3E6DCDBB11CCB80CE + C1ED0C9F1B2AC3E2793186E8A01BF4B9A2E8D66D3AC32272C8B0CB65C6CD7787 + CD28C3B003DA1CF770F18D8CC8CF3A0FB9849B0E4255D991C2D930FEBA9932EB + 966F0704EA32431DC1A5D834C427139C55A6DE1703B653C187B9E2238106B87E + F25CF9F24DDF8AB610F4E7B945C5D31BE8B2C88B10BF17E18AB2D2E3C6D48FBE + 5AA7B8F878276565E0CB2FB8D8D9FE39FF9B0FC91726CC70628E3F959821BAF7 + 60504E4C34B7EE79A1B05AD6BD3627AFD0A9D04DC984EE3514CF9BEE2E154618 + 543442264E9927F3173E28578E9B8CC7BBBCA99F634F1B74B4DF7933037A154A + E541246C58BB1C8193DBB502E98FFA63FAAC85CE74EE0C03647C5C02AE725FB5 + 1CCAE7B212D65DC94C7943ED32A1DF37D546DC50B1AEE46539AA49B779814C9A + F655751408CF9B6D1A66769C0DA13A042EA187E2FAC13BDC48D7B1C94119E551 + E81148BB1BC51F36E55E7F65A9361F1F3E6A9C338DFB222D2D6765F9B2C5DACC + EDCAABA73ACB013184D3948B538FD218A4C3CCEA81C5D00A48EF87FC606BDBD4 + 5CCBCD3357D0BD8DAF82D7CF1EAE06C6108E31C77A71BB3148C0BCC37F301272 + DBA86F8137045C34A26BD0116A8DA2B7E152B3AE60A4EBE41A490CE118DFA7C6 + BC8320478827F0B25F08BD0519670A5B1ABAC0C8801DAA65D2DB3011D1C1B810 + AE33DD4D70D038B60BD55807A08D4C7822FBCA0B20EE5ED4F6454CAD87B4B44C + 494EEE952FCD448429954EE3722F2AF41E8663C9315DA0C6380863AA8017D0D1 + 72AD9D3B143A25F55E29375C695CD84FE817F1EEBD98C2806E5AC3A0BBEA4295 + 1D091CC39F42F7A8B1D512369B42F6C5E77099F77710BFD0E9B8AA83FBB63B15 + 7167B88A57605C6BEE5DD8613E7CF0136D2A3D207FB071D34237C05D793F80D6 + C0182113A6B00621BF424A8C27B2347E0CE2ACE97259FA7F02B75EFE197A0456 + A87C38822FEC44649076305BE8E2B84BE51710B741F6E81C3F8F611AF71F882E + 6A236645C48B80AE0CD20E0C4343DC0AF1AB5A345054EF73014277C49EFF93D0 + 2A1842BF201382A8075255F64C4BF84B0DC5D02428F4DED00B1706D38DD01288 + CB19F530066EDCD32D57B69A31DC4EC41F0E60EF21FC66AC0B03A66CAB207E37 + 7D533433A233DDEA6A548CE146AC5910EB98091093810BC5A5D125B198E31229 + EB097EC3963F12D0A58D22FEF4D840C1387C6FFEA8007F6A833FBB4197C612FE + 7C330E8DC0553806E937A075D021182164FA1A2D31191C357358BE737FCC5488 + 19DA688806EA6B7187F180EBBB5C70E757B6F8D34C1FC12CB58BBEDF7D33C144 + AF5CADA86B3CF8C35C1AE40CBA12E2F719F90366FC4133C69F589D17AF72C681 + DD10BFF3D7AEC350794FCD8250F429F7A132377E7185BF1A4163F157E7D81367 + 3F9F06643CE24CE3B6402ED3714B0B138AF61610AF600656AE2B73D300B73CB2 + 65C11D73DC7FC63DA9DCE8C5451CFE26C9018C785524055BACE8530631A10CC5 + 41E7E0B3514663F096C7F1E2F5FA3E87C7C32B9A06A1D81FA15178CBE3B66853 + 518BC562B1582C168BC562B1582C168BC562B1582C168BC562B1582C168BC562 + 891891FF012639FDF74190BB900000000049454E44AE426082} + end> + end + item + Name = 'server-interbase' + SourceImages = < + item + Image.Data = { + 89504E470D0A1A0A0000000D494844520000006400000064080600000070E295 + 54000000017352474200AECE1CE90000000467414D410000B18F0BFC61050000 + 00097048597300000DD600000DD601906F799C0000109D49444154785EED9D09 + 7854D515C7CF9B3590442081BA1412512C286E15030A6E88A245A4802B0A5590 + 165BB4B58055D12A285AEA527129B456EB5A2BA268DD455410B59AD852506471 + 814450541296ECB3BDFEFFF7BD192693992493D9DE407EDF77BE77DF633E32F3 + FEEFDE73EEB9CB930EAC85661E2DCBB6A201A269B62E28F685F58115C30E80F5 + 80F17A679813A6C3BCB03AD80ED8F7B0AF619B609FC336B86AEDD5F9DB3E40D1 + BA584E90AAE2121BEEECA1289E021B0C1B083B10E6802502C5FA12560A7B0FB6 + 0C4A6F28DC544A212D832504A92C1E88275CA700E7C046C07AF17A8AA110AC3D + 2FC116C356149697F971CC281915A4B2B8A41F0E3F875D04DB8FD732C857B027 + 600F41982FD4950C907641B6159768F8A367A0381D360C66B56633007B157617 + 2AD1B2C2F28FD2DAA4A5ED6654151DABE99A3612C59B6003D445EB435F334B17 + EDCDEEE5E9F1356911044D131DF39DB013D585EC63096C069AB28F8DD3D49152 + 412044010E7F805D06B3F35A16C328ED7ED84D10A65A5D4901291184751BE1EB + 281C16C0D867D89360643619A2BC699C2697A40B825A918BC3DDB0C9B0B4F9A8 + 3443C73F0FBF6E66E1A6B246E3527248EA0D83183FC2E119D811EAC29ECF87B0 + F3505B183227059B794C1888311C07E625F61631C82058297EFB10E3347112AE + 217A9F3E52E5EDC6E6693E8C39A5BD917AD8A5A8294F1BA7ED272141AA7A0D14 + DDA65F832223A93DD55FB415A65DA6169497FD35911BD1EE26ABAA6800C5B811 + C5B9B0BD5D0CC2B07E01A2CB2B13E941B64B10BD7F7FD135DBB528CE36AE7460 + C207F31E88F20BE3347EDA2548554D67FA8CDB8CB30E22A028F3E1E899B98E9B + B89B1A339A62CA7A6F75E06D850365C3E0E8E31A118B4B10B39FC13FD04D5DE8 + A03538623910A26C314E5BA7CD4D16C4600F9C9DBE0E31DA0ED3460B2B8B4ADA + DC9AB44910336A603A646FEAF4258B2168876E36CBADD2A6260BB58389C2E761 + 71FB9C0E14ECA30C45D3B5C2388D4DAB3718623085CE71803D2D6B9B6E3E831D + 0D51E8EC63D296268BBDF00E3112E710D80D4631362DD610D40E8EF4BD0FCBF6 + C125ABC054FD51A825EB8DD3E6C414A4B2E8584D346D398AD93AEC9A5634B74B + 1C834BC475E62912A8F85AEAFFFCB0F92FCD785ED3FD630A2AFE6B9E3625B620 + C52567E3F08271D64154EC76710EFAB1B8460D17D7194345EBD645025BBE915D + A32749E0FB4AF343CD60D07A026A095B9E6644150462F07A192C5B6687A4157B + DF83C53D768412C2B6FFBEE65511EFDBEF49ED75B749602B67B1B6C8123DA09F + D1FDAB8FCCD3DDC412E44C1C3837A90313AD5B57718F3E535CE78C1047FFBEB8 + 60DE3A8F573C6FBC230D8F2C145FD9FF8C6BADC35A3208B5840F7D136209F206 + 0EA719677B310E87384F1A24EEF3CE16D76970A54EA3C3ADD73788EFA355E2FB + CF6A6978F829D177B66B12CA5310649C590ED14C1088C189CE6B6051C5DA1BB0 + 17F714D7F9A3C47DEE5962DB9793EC45F984C0A6AFA0061E6E0865EFD7471A1F + 5B2475733933A85D705A513144F9C638358826C85D384C33CEA280A7C4D6A300 + 51855BF4DA3A09546E473F34E37394134673B9C479FA49E21E375A9C838F450F + CD26FE2FCBE1A4B72A016CFBF5107BEF22F3D368A9FEF59AD45C7D8B6AB21260 + 2604613F2F441341AA8A4B9CD0BF02C5D6273EE30BDB1055D80EC04773DCA2C1 + 187504BEDB26FE0D5F8AF87CE607AD8DADE7FEE2BE682C9AA59178D00A214285 + 043696E3CE6862EFD35B6C453F343F69E0FF7483D4CFFB9BF21BAAB624C63A4D + D70E2BA8D83D4DB58920A81DA7E3C06993ED033FC276C0BECAE969B99D458728 + DE77CB44DFCEF5331602DFD379FC00714FBC405CA79E207A4D2DFCC1C7A2A3A6 + DB0F2A16FBC15C13B41BB602DE25CBA471F12BF01DAB9321443803504B429D92 + 4841FE82C314E32C71B4BC5CC4E7A72034FC81F8D77D219EE508BDBD19AC390E + BBB8460E974E53C6ABD0D5B7EA53F5B068FBE48BE3982354AD570402E25FFF85 + 04AA76A8669902D0AFD4A289F27DBCD6F84CF2B8158284522A2141B6150FB469 + A2739A644A16CB380EEFA7DA6869F448E30BAF4B6073135F965A70A35D670D93 + 4ED3A6A866D6F7C97AE5F71C471EA63A730C4203DF6C35BE13C3597CDE7E486F + 255410EF8A0FA5FA92DF28B192CC2A87DF717497CDFF56272141503BFAE3F089 + 71963A6CDD0BD0668F510ED2F3DADBE241672A41C7D8228E23FA49E75933C47E + 785F09C03FA808A9CF8168A6EAC4BF7683E8A8B11A7C9FADE77EB0E6395486B8 + 8D8F3F23F57FFAABE80D499D351A841151AF60B4152EC8541CDA1DC3C50B9FBE + 9C5F8C17377ABB9E37DF15CF8B4BD08420DAF627E709D43AE548A7E9974B0EFC + 04830D12F8EA6BD4846F45472D6573AA3A78AEE68379FAF69DE2453FC3BBEC7D + F1BCFA96E868BA52CC851064210BE1823C8943B38E4AAAB1F53A4072E75C2BCE + 938FC30FDF2EBEB59FE3C66D51E987C0D6EF10FB6F4613B34E39DEB6E238E250 + C99D777353E78C268A4F3B850847DF55AD9AB0C0668855BE453C4B968BFF0BB4 + DCC96F9A5AE23E08F26B169420DF1F38506CBACE01142E3B4E3F68B7595B3A5F + 834A1A74ACE1305A7BEF236978E0711C9B651B9AE09E70AEE4FEFE2A3CF92EF3 + 4A185EAFF810B6EAEC3BD157E0E76B799DE12F0E12ADEB3EEA237537DE2E0D8F + 71EA405AF900821CCF821204B583EBBDB7C1125D7A9C104C51E4DE8E8003374B + 6F68907AF48219666AE894B9CE3A4DDC679F2E0D4F2C96BAD95CFE17117AC237 + E4CE9E2EEE8B634F87F2AFFF5C6C3FE8AEF252D1F0BE5B2AD59742CCF4F7A1AA + 355D0A0B2ACABCC1C791D37B322A06695CF4A2785E36D6C1342E7C411A1E79DA + E8D7F4ED23B5D367CBAE0B2E47D87A1AFCC285EA33219C0EC9BBEFD616C52076 + FC3FB1C4F095AE949A5F5E9BA90E6DBEAE494F1682827078D112343EFBB23A06 + DBFA4EBF992C9D665C8E27BB5025F36A264F971CF42382893ED6A6BC3B6E14D7 + 4F861AE77142DF547FF703523DFE4AD1AB6BCCAB1941691014A469D73483F8D7 + D295A1F942F4E518F863A999364BAA274D0B8D31F8FEB746F5091CFD0E56E739 + 932F12D7688E16C407532075B3EE921D434649FD3D0F8AEEF198FF9231940641 + 412C338941DFB1D368365003F21FBF57DC637E62E4C6C260FF45EB5EA8F24C0C + 6DC3E18DADFFF323B2E3B891B273289AB0B06849AFAB97C6279F939D674D909D + 23C6AB318C76A6CE5381D220284877F39879E8AC0386C3664639E7F29F4997B7 + 1719371E8E9BA870B862B3E45C7A8191D434F1976F965D632E93FA3BE6C361D8 + 246FC11F55D416D856856B0B64C7E051523BF30FE25F13738E4126511A040589 + EEE92C0253E39DAE9C04C73D47DD68FFFA2FD1572837D2E426BE0F57428C49EA + 663B8EEE2FFB3CF77795C9ADBF7381EC3C79AC9A74A06A9F7561A41B12845B1C + 5903F60F541F210C556B0270DCA78AFBC2D1AA3FA170183DF0C6675E925D13E0 + 94D1A3769E749CE4FF63BEF8CA56C9CE61E74BFDFD10820942EBA334080AD2E6 + C9C06921420F52FBBB39E814961A829834CC7F546AA6CE54595881EF608DC943 + 0FBDF686B9B87E9D04BE6D75B28195501A040589E8656598C86F831AE31A71AA + D44C9C865E769579113563F12BE8B72C5535C856DC533ACFB94665643DCF65EF + FC8CA020A94BB7C689EEF3470D419D271E275A7EAED4CE883291DCA6A1977EB5 + D45C79432AC62BD285D2202888751A5984BC514351F4C61D2547AB882912A655 + 3CAF2CB56AF4D456940641412C35C6EA47481B8DC8F1ED20CE41C748E322AEB2 + CB6A940641412CE5FDFC1FAF334B114499DDC299833ED68CC86463F6A134080A + C2B57096C1FBD6BB66A9299C111289E3C8435596760F40691014A4DC3C5A026F + E94AF16F8A68B65003FCEB8C3C57385A7E9E04BEFED63CCB6A389F212448F35F + 9A49FC016978880398BB615636DA8C728E02A679742F55706F614310B4BE1B70 + B04CE84B3C0B5F10FFC6DDBB1EA9DE3642E2489832676A25CBA143574BA79520 + EE0627E3CC8C6D8D1A0DF645EA6EBA0305D35973FC2332A502D8EFB0F73DC83C + CB5A3E292C2F5323634A90FC6FD5DA919607AB3380F79D0FA4E1B145AA6CEBD6 + 550DBF46A2FA2C3939E659D612BAF7411F42B825AAE5A8BFED5E9528646FDC39 + FC64F3EA6E9C434AE0D4B78626296429A17B1F2EC83298E58279CEA1AA9E72B5 + 9ADA9973D9B866F3A8F4C646719F3F2AAA7FC912D854AD308A6182E89A8D8E7D + A371662D9856AFBE78AA081C7BA72B269A570D38A49B33E15CC99932412DBCCC + 42561694977D6796770BD27DD387AC1DC60C030BC21CD6AEF3A7A82502BCF921 + 07CF25652F2F5503585DDE794ECDEDB21FCC9729640D2F85872A4DC296CAE212 + 36D26CBAAC0BBEB1FBC231E238E670A9BFF32F6ACC834B08BABCB1508D262A10 + 997997FF5BEA6E9967CC42B42EAC044722C20ACDA98E1064A01D9F61B3958ED7 + 45248456D055DC178C121D9D45CF4B4BA5F34DD3C43D6E8CF9AFF8154CE1A3F6 + 544FBCCA080AACC96A9FCD76D4BE1BB9DBAC41B85397C2F2527A46BEB2C1F2D0 + AF342C784C8961EB5D2475772C30969F99F856944AF5B85FA9DA63611E0D1783 + 34A92104CD167B594CA534112B1B60A231FFC9F9A149769CA45D7DD15435A1DA + 8234C0B80C8153784334BBE9F8002741BD629C6517BED56B118D5DA1A609112E + 12CABBE766FCCA66CF9D15E0B2E826629058B580AF96C84AB8C68493E0B8AE83 + 38870E413FE5A7AA6C21980DFD93516C4A2C41DE81451F94C802E85F38719ADB + 5CD0B9736E70E4BA900CF362C0A6477D174954415095188ECD8259AEE71E0F8D + FF7C5E6A7E3E438D9970FDB94560E034BBC7C6E6FB9C90D88E5BD359E75F374E + B217EFF20FA4EEFAB9E2BE782C7E6DEC9F9B4616DA75F74AB3DC8C98DFB07093 + 7A19D6D5304B8D93B407CE6CF47FFA995A759B61B82E6F66D78AD8DEA0C547C6 + EC41DE679C65377573EF5399E10CC335E92D0E97B7A50EF3AD6A4DD703642181 + 8A2D51E774A591D508BEB98F4C8BB42A0814E5B222EEF59EF503D7BED59F9AA5 + B4C3A998130BCACB5A5D15D4262F0751DEC6216ADC9C4DF83FCBD8E802DFEC16 + 7D93C508DA2488C9F53063FF876C25330B3A39F3FB76A3D83A71E5142A8B4BB8 + 5294B3D2F657173A680D4E1CE1567E3177C48C249E1AC2A68BB3D7B8F6382B56 + C064184EED191D8F18242E4108FE009BAD9FC13252FFB304EE52C3D7E9C5BD99 + 4FDC8210FCA16771F8252CAB532B29820FEA78DCA3A5C6697CB44B10823FF820 + 0E57C0F688799C4982625C827BD3EECD52121E2880A3E78B87B9135DC6B7E6C8 + 306CA6583312DAB9262923371085A9540EFD5A2AC79D46E8C0CF851809BFB038 + 69436910856F52580C8BBECC69CF85A12DA3A9A4ECC6D76E1F1209BE10FB27CC + DE71706B6F819D3EF63392B63562D20421F862DC4572188A7360593BB7B30D30 + 27758DAEEB23F19BE3EA67B446D29AAC48D0840DC6E121583F7561CF813BEE4F + 82103107991221A935241C7C61AE713806760B8C535EB21D66BDF9BA59365129 + 1183A4AC868483DAC2BD1CB9C7F95858CA1E8214C1A697EBEBAE8710497B917D + 2CD22208D9D6FB58D1021A5F08CF012FEE3896B6BFDD4ED8E1E5AB026F2E706E + 5FA57DAE9600A69CB4DF94EDBD0648C0666353F65BD879B0DD1B5E5903BEAC9E + 35E2EE8004D6F428FF8FBA982E32FA94A229E3FB8298A8A47167ED4C7D1FE6E4 + E8AC1F853D8EA6296363BD9668362A8BD07DD1E44814E96346C28E82A53A15C3 + D9347CFCB927C7E282BCBAB5DA1ABEC726B358AE1DD7D18A55156F62CD3901C6 + D0991980C36189EE7AC7A79EB305B9C0926BFA56A02624B50F910C2C274834D0 + B471EB38A664B81529D717B0CC7711715B3CEEC4165C78C80E1B07CF985BE2DE + 21DCE09ED36E36E0A76E35975B74D0415B11F93FEDD2997558D6CC7C00000000 + 49454E44AE426082} + end> + end + item + Name = 'server-firebird' + SourceImages = < + item + Image.Data = { + 89504E470D0A1A0A0000000D494844520000006400000064080600000070E295 + 54000000017352474200AECE1CE90000000467414D410000B18F0BFC61050000 + 00097048597300000EC300000EC301C76FA86400001BFF49444154785EED5D07 + 7C1445DB9FD97235BD9142124A08096008A10602848E5445942A2845407C05C1 + 82A828EAEBAB48B1BCA27C82D850414069D2A4482886DE6B42124A202424A45F + D9DDF99ED9BBC3CB650381DC8500EFFFF7FBDFEDCC3CBB33B3CFF4B618D56CE8 + 1806356DD7966FDAA2391F1514C8D4F3F06482D42AE4C7715877E1A288DF78AB + 680AC8FD48859F7C4233B46F1FF527924488C1804A8A8B494ECE75E94A5ABA98 + B67397F9F4A54BE251103B0C2CA6F23511354D21BCB737133F7CB0A667D3A65C + E7B0DA6C33F85705F83356678472F32474E6AC8852CF8B68E72E135AB0B0F44D + B0FE37756BDC887B7DF433DA0FA21AB2A8513487424359C45863284A08A5A408 + 68FF41C17CEE9C7078FB0EF3B6BF924C1BC06917D0240BD500D4048530B54398 + 0E639FD50E8B8DE1FB436EF0F7F5B128C0642268EF010125C18BDFBBCF2C1E3D + 2E9C4DCF108F4A123A01CEA9C0B3C0034002A4A0F169018CA6841C15DBBC191F + D73C8E0B486CAF42F1AD79A4565BA24CE08ED36704B4798B2977CB76D3EAB5EB + 8D3FC173B78293280B3C6CC018F98D18AA99B6F43BCFD49C0C3F420A036466C3 + F5A2F91EE4B13E6AC1DB0BEF01D1F7805D811EF4BEBB00D54003E0181F1F66E9 + 9303D4B9DF2EF0207997FC6FFA49792CD987BCF3BA3EA3417DF62D900DA4373E + 1450AB709DB75ED5CFDFB9D1BB44BA012F233F80987202C88A1F3D49DF47D502 + A4605A8C8C02FAC937381F2A60377737BC70E8539ABC0D2BBD889867090765F1 + 157FB2F0737743423CBF10E422E53B1E44A85438E49DD7F40B8E24F998087D01 + C0EBA97EE4FD37F504EA8A3410791D18240B571FB4C0A79B36E1767F3ECB9D14 + 5D865C630D9B0089E4A7AF3D848436FC77205357967E40A09B385A3B73DF666F + 68F3406481D7CFF991699374C4CB13D3F2FF2920274BDE5BB4090F657F9FF58E + 9B587C1114630DABE96A00F9BFB9EE868611EC2C90B9DB62B366A05302DF67D5 + F79E19E25588E0357F6284727BF64C37E2E7C39C04E7C78135A151E188D8C8FA + EC1F8B3FF3209670836220ECB967FDC82B13759950A4D204747F816590EFBFA7 + E97FBA76DC97102893299356799147A2B93C70FE179097056B36BA7569AF3A79 + 788BF7CD3850EE5AE345DAB6E07F07F7FBA3E26FDF8AEFB2F917CF4B8496C7C0 + D2F37E64F2582D6159B4129CEFB7D68B4AAFC333DE7B556F306558E2435992E2 + 475E7D5E970509AFAF55AE46827961A47646C61E1F915C8080034F6FF721CD1A + 7305E036C22272DF22A64B82EA58DA6E1F395E36AE5AE4298587C8754B4DA803 + FF01F4293C66BFE1B6D600E52C4987C002572FF224DE9EF838383F284D476D68 + 30B368C3F79E37E348790E125DBBE63CED50FA5AC4EE31A0820EFFF5BFEE4709 + 346109144FF4FF93B7F484E3D01A7076B7483D38D06AF0F8FFCE7433DD8C2F30 + FF882F79B297FA0C38DFDBC4D728826DB4F507CF8B049AB1364E9FA0A3C3185F + 016B56367622A044E8F6D60BBA02899608D6789B4EF99109433559E01C6791AA + 66C44673717B967A65933310202B5F19ADA5CAF81858139BB3CE46CB97476BAF + 4BA7FF893FBD86777003DCDA5A44AA094D1B724DF72EF3CA2127212056BEF382 + 9C33E65A241E1AC44D1FA7BB6EFF1E24E0ABA3B5F9E0D6DA22E262D4ABCD46EE + FCC1F31A390E01B0F26BE8EC4136A6430C0F43CE7044FCDC57F5C5F6EF433AE6 + 47260ED1E482DB2316111741AFC5811BBEF448215089D9B8FD1B0FA256E16DE0 + 4C07ED1E4AA878D47FE53C77D1FEBD980FFA92413DD417C139D422E57CA817CF + 74DB430E8187565EDEE44D82FD990C70F3B7883CBC080E60A69F5CE175F3DD50 + 16EEF22109CDB883E0ACB348391133C66A1789FBC0A30316D2EBAEAD793AD316 + 6F9178E8C12436E7D795D2CEA3F51D51A6AFF126E181CCCF5699DBA25265FE90 + EEEA67E6BFA65FECE5FE8FF8A7BF18D0E4B9C56FC3E5BB161BE7222196EB3520 + 513DC1D30D47491252971A49415E21B996992D5D38744638B7FF94705C22F26C + E125CB1D3502FE33C6688FCD7C4E57CB6A96B1618F19F59D52305110D17CAB55 + 85B8AD42C26A310DD7CC71DF1F13C1B959AD505AA688629FCE3F5C504C5A8251 + B0D83A0F5D5AF0BDBF7BDB6D4D88BF6D46DC01D09ECBBE21A17DA70474E2BC48 + 15B46D75927973B1816C02D76C8BD0BD81568D076CFFD26345AB4665BB61AFCF + 2F29FDF0FB52DAF23A66B151C6ED14C27EF7967EE7889EEA3656B38CC7A61549 + AB924CD46E9FC5C6B998FBA2EED7970669065A8D95C2F57C8236ED350B7B4F0A + 7FAFFCCBF4FB852CE937B03E6F71BD2DE8EC648EE5B2EAE815CFAF5D33CBBD37 + F3CFDA0C643411D47162E1A1E49302558AD9625B1E76B794C7E8DEEA17077702 + 654860B072CB5E335A9D64FA164C2E51060504CACFDECFCAD0178AD3215D54DC + BC7FE912CE2CF19CBD76967BCAEBC3B5871AD7656780442CB0A2C4E7D1B60997 + 0EFF0D2DC6AAE38F3DE6977ED96C32D9874FCD61F4E9245D336891BD220B5500 + D6FA5F0E6E5A5CFB8BC9BA15A17E8C4A5ED30124F0E021EF16975CCE9106804D + A12CE802B488E4FA748EE51B513F4FA489E8B94F7DD0375B03D1C2B5025ABD3D + 171516131419C2CA91B485CD9E1C9474E08EBBC4F181E3FA693A756BC18F8F0C + 659F75D3E0E8D44C510D750F1DE22805A2E691DC63339FD50E5DB2D94427CDF6 + 533B2720F74A8E1438A29BBA154B9381355CB5FD1894934FDA269F127E021BDA + A32F870A8BAC3913744B5E7A5233D46A94B1162AA77E6F14CE81CB972D364E05 + 1D2D8DF6D0E1E0368DB9511B3E72EF412D37EF37A38D99A3518FEE8FA2D0D050 + C4B11C5ABF713DFA7EF167E8B9AE57D1D83E6A2A56695CCB93D0F62382947249 + 3C0E09EB707C633EA663532E367CF08DFF82339D3C73166AFF30DD2D65585755 + 9900E61610143B367FC5A56C49B148565448C3DA6CCB4DB3DC92431D2AD50E53 + 0A0D3B8F09F5E132D3625335F01CAA3BE651F598D6D1DC63750399E886A12CF6 + F5C08896BD368F69E2BA784D42F0F250E675095D81FEAF89EA4E1D8436EF3882 + 7E9DA1456E1A8BECDD22EDAA84EA3F9DBF002EC75B6C9C835EADF96FD6BCEFF6 + ACE34BFE6485914CF9AAA43D5CD2457A65A0A890AF5FD2AD1FDD53DDD36A94B1 + EF8C805ABF58F80D5C8EB6D854099EAF0FD67C38A8A36A4C4C3D48F22EC05F47 + 05F4C56AA3181DC6B0D1612C8A0A6551BD2006B9EB709948435314BDBBA494BC + BFC430068C347ECE44F31D73DDF727342E1B450354F0B1E30BB79DBD2C76B65A + DD443985D40F62E277CC76DF1D645D3D68C3E8792568F1266373B8A43DCFBB46 + 881F53FFB3F1BA0D8FB7E52394938373700CEA9E51F38AD71C3827D2A9635A5E + 37849C1711E0C984D7F2C6817A0D76370B88A4658957A05CA77337B3814E6FC2 + 4F1FAC39F0FE486DB921F9CF5719D1A4AF4A12E1F22F8B8D05E55EC9FCE775CB + C7F7523F6135CA80F63DAA3D22FF507E09A9D2583FC6C8FBF737DDF6F76DCDD7 + B35AB914B4B84B3E2DA0EFB7988E2EDA6C7C1714409543ADAB0D0D829929C7E6 + 7BCE51399403254682A2C615ACBE9423F5B75AC928930D343CAE97D8847BCCBE + B946B91A2A7350C60F54A62A78ED09CDDB7D5B82321C9EEF2A62609B480ECD9F + A08BD9F591C7F26EB1F2546B04B0DA702E53FAEDAFA3D0ED70089B8EC7E8E944 + 551F309599652CA390497DD563A2821816899088ECB86237147A082DB748DD35 + B8B60DD9118ECFAE2EB6A8C7A0756FEA13DF1BAA3904A9B54CEBD1C5483B9422 + 9E500AD398AE2A866311ADBB6EC25E215C4214BC30074D1A8D086D3D2AD07A83 + 0E25570521B5BD196FC7E7572769B7E58D27346EBFBEACFF31C013BF0FB62EAC + C5FEC1C154619B5278EAFA33A85B537E38986EAE53BBA9908840A67387282E44 + 5E8C6FC7DDA70474A398ACA7325584E946114D1970758FD9378EC7BFBDA27F23 + D89BF91C6C5CAE9475FB859D2525CA711FD89AA7EB99E9EA7E19371532B6B37A + 80BB0AC2E6A0C5EDC7E486072D7BAB8AAB3B4E08698ECFBF578C8FE0D0CF9374 + 13BD74986E7770298A8DE4D0D174F0D4210C94FD9BF348ABC274E443864D212C + D41DFD9534B8E7AC40E73C9281550599B5CAF8F2F23D6649C91F1B0DD0FA3874 + 5E442BFE36A3C55B4D08E4D179E8B829C95695ED1B7068CE70ED1B602AD3AA74 + 015252AF88254A61F0D162D4218AA52B20E5612C39BBEA54382E65AEFB8140CF + B2B957825C1638B1E0604E21A1FD0FA740C3A391EF0CD02C98DA4BAD66ADC9E1 + CC1509FDB0CB44924E8B8507D2C4E41213A1634A749DD375A0069ACB4DFBC5F1 + 23E60ED384D172D7D9E83FAF2473CD4173145CBA6C7CEEF311DAE313BBA91A5B + 8D65F0F13A237AED17039DCAD82FC76E701BBE53209D7C72C84EE959120265D0 + 4920A7C16046DF4D5B6A68FFE8ACE293FB532189803F33571AC40F56191393CE + 087EA08CEE20361D48174DAC052E2704BDB5EA8039AAC747C5DF4233B25C38AB + CA37FBAA8341E92F80C965806E438692DF949DA3E44E4A27FA232BA479389BA8 + 949D4E5DA677A053F4C7C9D8F7E70921AEEDBB455387CC2FB986C9CD51E70AE7 + 0900A52959D2E869CB0C9B95C25A15B60C6751C786DC04305538FA5D55408326 + 5BC96FCAA6B559E4EB8669AFDDA290104FDC524973A9B4EC86F28FFEB8004641 + 427397269BEBFE9C6C1E05E62B16EB5B42FAED80F9BDB350C42985B72AEC1FCB + D1D5212E5BE0566420794AFE52D2FC0199826E56951552BBAE0F534BA9E372F1 + 3ABD03D1C91B57A204B818784E36DD1E472E6443B814C25B152642050F908B0D + 57A0D4480C4AFEDAD838880900B150C6478F631AD28AD24E633666E5D30B7495 + FED4144043A0767DDFF2F55D5549DF01CFBA6E611B84B8CC0CA2231B07C9A565 + 0CD32D8A8BA0DD0FD9C156AE59AFF34A08ED84D0659135066FF6544FA9EB0D09 + C82E9C657897761A78A48F0EBB6C4391BB1AEB95FCB5D9C99902FAE74C841F13 + 715388FEDB5D979AE4130E6ACA2907FAC989AA4FFED54135DA319C6558153B4B + 71EE12D472C30115FA0B76722243A83EE3A7C3A1E504AC1444521394E13BB819 + FFCA9AB1BAB3B3FB6926F9689C5F5C511A21A6502228CE733B03816E4C7D257F + 6D0CD063A4E1A00EF154A300A54A8612A20E17F7049A46B598011FF755AF487A + 417779C970CDACDE516C3043CFC35008A733782E0B529F2877465D01AE961EC5 + 28F96B2307710BF26002181583FC953446C933D5BB803AC00DB799D155B570CD + 28EDD5BD2FEA564CEDA01AD02E9C55D3790DA5F03993AB8F09B4262D337BE72C + A858D4AC4508EBA6E4AF3DBD75D89FE111F690CB3505EA794C15E2F22DCC3141 + 4C8F0503343B0FBCA8DFF34E57F5E8DE919CA78EAE9F5108932B586A4068C1DF + A60B605A07743AC6B4E27BD5D2DD3E3E6E3C7267388CD44ADAA2F4D662AA0C97 + 9D5E50C79B6936BFBF66DB9FA3741BC6B6E0DB85B8B9A67EB81DE72599D0C51B + 848EFABAA2CEC4EDC3B9414AFE3A52CD6268EC49900314B44519445F906BF696 + 6B26C5F3B3378ED4EE1BDF824FF4A315B582FFD5C174E8FC7EF497898ED7D1CE + A9D311EE85DB76AAC3462BF9ED4828143846920828052A1605867BC80A09A33F + CE02B4EAEA7CF7B866CF9C1EEAA90DBC31ABE46F759140653A61954128349271 + 1034FA5A9C8EC9F1AAC901F4881B05FF1D2911C230A288CC8E59C7C60696B6B1 + D3160534F4651A2F1BA8D9FD740C17CB401894FCAC4E2ED867461B53C48FC0E4 + D4116D1B02DD7093DE11ECE34A7E2B51109189310BA8C831EBD8D8D897A14B77 + 14C7F0EF143E5A1C36FF51F5A6C4303648C9AFEAE6E92C094DFB532EAA5CB2BF + 85627A3BD57F223CE9A211305482252664604A4D245F495B94015A8C22BC1967 + ECBBE66777562DEB14C6062BF953DD3440D53DFC77435181910C031B97747E3B + 86B17D0645737D94FCAF88370C24972932A26B4ADAB231AE16130357B414BC6B + 8C69CA4D1DD6886BADF4FC7BC197FF34A28357A58960725547D0F3B5D6FC17FE + F47C4705FF95488059C52487C92E96321D2B177BB60F61E8EAED321B76EE1001 + A39AF06FC89D1985E75737979D34A32F0F9A698BEA7B1A245760663BD5173DEB + B0614AFE57C4825209E519C81526ED064953D2988DDDC2E461613AAD7A5798DA + 9C9FD2A616E3A6F4ECEAE63968E24ED86C3A0CAFC065D3B543A2B871FF8AE586 + 29F97F2BA6E741A8104A63922E8929D0D2022D29B381078362FD19BAE4F16EA0 + ED1EC68E557A6E75B3146A8A216B8D85900A07830D9D14733A1282D9C4B75BF3 + 9F79F177DEC13D974B2FD079E67211397E3E0F0C0E1AB367EF3A6C13B8A2AB32 + EE08ED83D9C71383591FA56756375FDD614207AF4974DEDC25F546231F26664E + 826A65A407A352F2FF763C91232BE404ED689C387A4D82BE48D932CD9E432338 + 3AF27BC7EB6187346087F174C058E199D5C9AD1744F4E53133DD2BBEC41232E7 + A281276EFC5547D5A696FED85BC9FFCAF0F035896AE418554849460139AE948D + 6C8CF6C2A863303B124C77B22AC3B38937D345E979D5490952DFD45DA67C88F3 + 64B0713AE2FC98568B3BABB7270432B594FCAF0C690BEB50B6444FE92E94BBE2 + 87B3A5DD4AD9C89EA31B42AB0155FE8CC1601D4E68E90B2D3485675527B75F12 + D1911C896E57BB06742A7A87B1031727AAB6B6F567FC94FCAE2CCFDF20E84211 + D90926CB32A055E9C2F6BC529A75C050019FACC341058FE997082A85F6814C23 + F9987585675527F7428F1C404FCB7626D4931A73731624A8963DE2C5E895FCBD + 136E834403D8417F6485149AD1D6ED97A11E71D09C3DE9C4C8F3D13CDDA8D801 + 785B0469712DA5E75437F5F2BE64E721DA93895FD251B5F7E396AA29C16A8C95 + FCBC536EBA44BFDD8036032D0A01E41ECC11F7285536F67CAE014B7349A5C67E + 340C8294A3FC9CEA64BF10080887EEE854082578A970EC47CDF9A57F7455ED1A + 52878DA153AE4AFEDD290D6682B65C91E8989ABCDCCAA610B43C5D5C69A40B39 + 153468231D3F99DE84EF087FFD80B704B41918A5675437C3B518CD88E19F0353 + B91DAF95409D7EB5D9490BDBA8920FF6561F7C259A7B0A9EE7945C61E36628AE + F28C841E0322C33E3FD75EDD5195DE2784BD654B8A2AB6EB5663EAF62C89F64D + 0C16DBF298D490FB6C5E73DE991BF1EF1A1064F46DAA685C7E41FC69F355719D + 4010FDD20E5DBA6A0B3FDDE9EE0FA55B9D76FE4C74C70026AE813B9310E38523 + 1FF1664003AEC3D05D26F24B8648A738E47359CAF8352992DB342F8EEF663556 + 88C3D0916CF7A7F1835211D1BD158A185997FD60716B15FDE2418D428E91A0B3 + 8504651B08314A48A0558C9E455C8006E33A7A8C7CE8AA41576AC00E792682C2 + 571B76150928C16A55B65F71BA80984686B303DD692869B2AA8081D07C12096A + B33D5BA2AD17C5531D7CA1CC1D11C67557BAFF5E52C760140AC558943B831B7B + 306C2377868D7063709006232D3DB842E11E5771E17911ADCE94E807648E0065 + DCAC4328F2CDE4B79F3384AB8E158F125F8FE4F8CEFE0CFD1897E261C927F2C9 + 5591AE3952B8F77F24D061256841AA403724FD6A796316945108C0F46DBA389F + 0EC4295540F6E4E1B98B9AF191615AFC35D894CBE4594672F15A051B1DFF4784 + D6664AE86401A127CCC9A712D9E0A810741C847EBC20162975601C190ED9FC9B + 587E1094C1D3C0C61169E7E9AE5B85FB1E76D263AE3E3A2B5045D01388CAA09C + 4200D7BFCE10BF28BD4D13D8C6CE3E0CFAAC09FF3E543B43C0C61E99E945A4C2 + F9FA87997F5C91D09E5C89E68E72C3398A4DDC4C03391CA442E35A79628D5265 + E4C866EE18438FB8EF9F39D221B0B16DBC21095ECC80782F1CAC74CFC34ADA27 + 1F7AD85C70D5287FEAA9DCBC4C457D8E9273C5040D0964BAD25689D2831DD9D6 + 9361350C1EB02557A22D063A7289EA6971ABDE7E4C9C92FCC3CA45D011FCFA92 + F40E98E8819DE550612730D72C1F7737A4AB37E3A3F46025B6F362383F1E0FDC + 9227A54323E2283C23E4F910B60F56907D18791DFA1D838E08E78A44F90337B4 + 002B875BF5CA85830524B593173334940EDB2A78A0C456B46DAF631EDF9E47C8 + 6523D932C09F1D5F8B4E692AC83E6C7CE18C4876E54B74A24F2E4194702B8520 + 81A073A9A52872901FFB88BC6A44C1132546EB30CE34914EC905E4E3166E7864 + 333D53A9BAE841E61FD725342D55A0A7B9DEF20B12B75408458681EC80F4FD74 + 274FECAEE45145BC2120B42247DAD540833DBA7BE12825998785D9D0AFEB7F42 + C82810E54F055638FE47715B85004AF61490E32DF47858033AFEAFE0A1127DE0 + C99F664AD72E9BD09E09B5D8DEAC82CCC340DA311F7C5A100F16113A425E6151 + 6583523FA41CA0E8DA38F9BCF89FF4DBCC2ADA3398C3088AABEE1946B26E7B1E + 1D2B50967BD0F9DE0511ADCF93E85121F214EDED50991C222357407F1D2F41F1 + 03BC98FAF23E37BB5450112F9A90EF8E42B2B09E1AB74A74634294641E64AECC + 95D0A40C71195C567AEABBD20A01903423597BC9441EEBE7C1F8C959CB21008E + F4875CF255B69493654607C7F8B1DDE53DC70A720F22938B087A3255483648F2 + D14F955ED05D6E50B012A8373980D9353B980DACCCCC4DFBB3C2F9DDC5A4C3B2 + BA6CDA135E8CCBF72BD6049C3410D4354548818448E739E8B1E695C69DE4101B + F2FE2E265BA1E3F754271DA3554A1DF684DE8FF7DA02B25183B1C763EE4CB492 + CC83C47346821E4D152F649AE529E3CBC03BC2DDE4101B5A4DF76736BE5B8BF5 + BAD5434AA0628B3A27ACBF2A9059C9F5B86DCDB455F1B266E3345546BA78E982 + 99506554F6309D32B89B1C62C3E5A412B2394F4003BAEA18BDBC454D81B48C2A + 9650C4D662F219D421B1BDF44C6D25B9FB9DFBA005DA2B4348B92CC8270A55F6 + BB25E5E08CE41A35D88359B7A01653CFADECD9FD3741D771C6A4096BB245343F + 298C5BDF9CEEBA7D80B0BA484223AF88FB0A2479354E954E4FAA4A0EB121E7B8 + 912C4D2A25F11DD528CC9BBE6B87D4439774F01845AE2D268BAF8B24E8493DAE + FF200C38D2A5591F42D376E235E937C820F4C870FABDF82AC1190AA128BE28A0 + 1F7F2B26FEF538DC224AE1432B712A8CFF2C252D36979271A12C7AA6990ACB0B + E3EF57E6426B657896287E994F664035F922D83A65AFA2B314422142965DF76B + 11390D81ED96A0C21A955D04681D13ABC2014B8AC9F53D06B2B6A706F7F4A7ED + 663B99FB855B213BF4CD922E251B09ED63D0AD71D4C52970A6426440C84EEC35 + 929FFE28214DEAB1B87E7DBB2545C150C740C5DEF6F75232EB801169FB6B9926 + 7AEB4DF7030B20574CCD93D04B79D252F8A3F505FD4C9253E1748558919F25A1 + 1F7F2E21E7CF0B24A1198FF572DB182215AFC2CC5901F5DC6424CF1C329166FD + D4384CFE408E43E46B12695DB1B484A081D7C58B5B8C640418FF0D2E65568B38 + 0BAE52880C08F891A366B4F0BB12C2E74B28AE298B399A237AA8B15BB21975DC + 6A22830F9A51FCA33C0E91BF4D6A7D0135893B4D048DC823A59F14910FF389BC + 90E338D065A0E9B6BA50C79F416F8ED2E21113B50C4F176E0FCA970E6D359341 + 2D79FCE5F71E4C974897268F3B439299A0FF1413F32613F906F442BFA4502D5F + 14AD4E85D810AAC368F240151E35508DBD7E3192B49F8C64482083867CA0635E + 1CA1C62E5DDC7C2BD099A3159023BE2C25457B0442BF47350FE8EA6372CBE05E + C59D82965E839BB0F8992C89B4C826A8379855BD78FCC55B1A5CAF156D3A5703 + E8B445B240D0CFA088E566720CEA3EBA12932E91AD729FE26E702F15628FBA40 + FAE9537A183E3DB1755C4F1E4F19CEA3B03EA018B925E644D02FCFEFA0B36E02 + 429B0492922EC9DFA6FA057818486B8F7B869AA21025D0E9939E9E180DEAC0E2 + 1EAD18E41F07754C14349D4320D49519C7A78B2F2FC3EB4D91083A0559E130A5 + 48328F4B6817E822099C37026F3BAD5A9DA8C90AB1079D0FA30717D0CF663452 + 23542F18A3205F8CFCF418B9F3086B418085F72D9810311612549C43D0F5AB04 + 658352E807F8E960DF69205DC4579933E6EF1110FA7F1C2F8A6483B809ED0000 + 000049454E44AE426082} + end> + end + item + Name = 'server-rds-mysql' + SourceImages = < + item + Image.Data = { + 89504E470D0A1A0A0000000D494844520000006400000064080600000070E295 + 54000000097048597300000B1300000B1301009A9C18000013B549444154789C + ED9D797C54D5D9C7BFE7CE4CD6C9BE02595992B089288802868255C08DB62ACA + 0B822056A9FDB455D1DAB7D5BAB4A2F811D1EADB564105D7B6168BB228A8B46C + 15411002610B4BC84676B2CF7ACFFBC72493C4DC494232779280DF3F60EEC99D + F39C99DF9CED39CF39574829F92E63C6DCDB26AD254655526F94144706111091 + 8630F983EA44204195200442012941550DA0A808E1FA9B1402848270AA804428 + 2014056977F41346BF3F06C7268D57845223A5DAB6605E4455A5501411929214 + F3B5BFC9F0BF5255F3A504890045601002295554A92285409102104845454809 + 085404420A8490180C028BD5C9A9BC521C81D528460952B45B86434FDCD626CD + A8CFC73D2F62A5CA1229C4022104ED7F04EF23205D51C49D0E2956A3CA478122 + 1F17A1154A0FDA8E4788374029061634A6B9AA8DEF902DECCDC5200A85C22A90 + 037C588656F48420FD84E44DA1882221C4FC1EB0DF3E82B902F225F2ED9E1046 + 7741A4FB1FFA23C42A0551289077E96DB7BB4829E74844BE10E21D20C1577675 + 15442200D95F085609290A0462AE9EF6F441CC561079C07B2013F5B6A69B2052 + 8A0102B9DAA0C802017D5088EF209885E08C80F700DD84F1BE20820404EF00F9 + 20EEF47AFE3D8D14B3403923051F00C9DECEDE9B820C00DE4128792066773D1B + 5F0EB2A0ABE36C21C5ED0A9C16820F902479AB38DD144480205120DE17AE1AD1 + 0D21FA2AF27604B920FE81176A8CE6C430D06668F74D8A74605524A08E077587 + 70CDD12F6A8410B74A55DE2AA59C8041EE541507AAF3FCAB9FA6207951F51EDF + 208524C81680C42F4D416C40C3F572D1222542B25134F88D35FAF91DF3331AD1 + 724DB587A620B951656D1355097E028204215509E6909AC04D8A748409491D10 + DC95F25F7008EA8050B52E605380EA3F3236CCBFA65E01874169F47F758CB62F + 2B4EA38F3229182BAD0416DB08C4B44EC199AC4283CF9D4FBD9F068391643BF6 + 75672D725258AD9D08AB0387D2B92F4A5B90C41682B81C9B10E78F7F56157147 + CEBD6509572639153B42F6A42BACF7A228E050D5CC4AAB73556C61EDBC84F23A + 9C4633AEBEB6FD9AA22D88CDD6FC5A4884AA12BCAB928012FBE39610394F152A + A2856B39392E94E9631219101D4269553D874E97F3F59142AAEB6D1A995FF848 + 40416046CE3D17137CF250B8F26441403E0EC58EA18381ADB620A1A1AEFF1505 + 9C0D88BA7A2272EAE6280D3C690B3321BEB354F1938983B9715C2A71E14154D4 + 581891524EFF28339FEF3D4D6179ED797E1C9FB7814D6D80D7313825D541014F + 584CF2E4E9E0FCB79DE62A0894A07A3627B44601226328A0427D15C11913094A + 1835D15454BE4DA82DD65CA40A8886FF7BFC67A61913D2358575AA9235DB8FB1 + 62C3018EE557B45B78A93A518C7EAA39265108A10829D5CE7EEE2EA1AA124511 + 3235394606F8191587B37BF68C4603F5F5D6BAD379658A844045B8BE28814045 + C516599459B1BFFFB6B2ADC320AC0114893C9CDE361FCDDC8F1E71BF0CF42F4B + 09353AD737A820155A4DA4AFBA64B0D224C69AEDC73859788ECBD3E299342A11 + 45080C8AE0B6CC746ECB4CE7ADCF0EF2EC075F61B53BBBF5C1FB1AAA6B5D9178 + E2D73BCB52469515279EA2D8F3FD1E570C838362081D3935C069366FB488DA50 + 97E3B6F53D53C60E3300FC37BB8887FEB2C59D3E203A84DB7F90C1ACC943890E + 0B04E0AEA92398323A89FB966FE2F099F26E7CC4BE45D31A6855B50CF11F56F0 + E990C4924BF3365ED260290DD3BCDF630FA3F807614EBEF413635078866AB76A + DE63773800301A5A67535056C3B20F7733E9A1F759F6E16E6C8DB5222936940D + CFDCCA03B78CE1471386306D6C2A999724921AAF5DB80B09A7D5847F787D5AD4 + E8DC75C660EDEF133CF4213157CF0B3298FC971BFDCDF7786CCBA5CA986103AD + 6B5FFC953FC00DBFFD90EC5CED5FFE80E8109E597035999778F65A1FCDAB606F + 4E89DC9B6F65C7910A516BD17784E6AB3EE4BB084562ABF55FE1B4197E796C65 + 661B9788660D09884A5C6C0A8EBC47AAEDB7F77BB24FA9BB8F163A015E5C748D + C7FB0ACA6A98B774032B361EA0CE62D7BC273D3192599333C4F3778E121B7F3B + 91876764101E6C6AD77E5F443A150222EB169A132A166BFD5DB386F49FF6AB25 + 021E6D3F67D7286B60C668B9EDA5BB8200566F3EC8EF57ED68F76DA1417E8405 + FB1317114C48901FA1417E2444873071C400AE1CD67A09BBBAC1CECB1B8EF3F7 + 9D79EDE6D915DC3524294606F8FBAE863421A57C366BD9B4DFB4C9C7C3FD8ECE + 1624AFA45AFE7AC5769E5B3891B9D78E60F7D1B3ACFBEA84C7FBABEB6D54D7DB + C82BAD6995FECABFF6302C355E9D35F57271EB950922D0CF4068A089DFDD328C + EB46C5B364CD614E149FEF9CA657A3F91D7BC5F7F18FADC7F8DBBF5D43E53FFD + FC87C4860775299F2379153CBFF688BC61C976DEDA72CA9D7EC5E0483E7A6402 + 77667A7D81AED7E13567D4A32BFEC389C27300BCB1787AB7F22AAFB1B16CDD31 + 7EBC7407DB0E97BAD31F9E91C19F165C4668E085D7B734E155EFE0BCA51B0018 + 9E12CDDC6B4778BC6FD4A0586ECD4C67C8808876F33B515CCBFD2BF6F2D80707 + B1D85C038C49C363F8E891098C4E0DF75AB97B135E15A4A0AC86A7DEDE09C0EF + 665F85C9A89DFD806833CFFFF4076C7A6E26E387751C8BB676770133966E67DF + A94A006242FD59F5F371DC3CB6BFF70ADF4BF0BAFFFCCDCFB22828ABC16454F8 + C9C434CD7B36EC3AC9B31FEC02E0B507A7121CD0711354546961DE2B5FF3FEF6 + 33EEB43FDC319285D70CF44EC17B09BA2C68ACD97E1C805993877ABCE7AFEBBE + A5AACE4A7080094327176F00967C7498673F3AECBEFEC5F543F8C5F543BA5ED8 + 5E862E826CCBCA075C7D457B23AE573FDEC7E77B4FB75C37919D09037A6FFB19 + 1E79E780FB7AE13503BB2E4A2F5BF1D445903DC78AA8ACB100306D6CAAC7FB5E + 5FBF9F7B967DD6251B9FEE2BE2C155DFBAAF175E3390F9933DDBEA2BE8228894 + B076670E00D75F31480F13007C7EA09887DFDEEFBE7EE0C634A68FEEA79B3D5F + A0DBA2F83FB71D0560DCD07E8405FBEB6586CFBE3DCB92167DCA73732E6170BC + 59377B7AA39B20074F9791DFE81E997E85BE23A1F7B79F69E5EF5AB1682C4643 + 2FEB1C3A89AE6123EF7C910DC0FCA923F53403C01FFE99CDA1BC6A0022CD7EBC + 386FB4EE36F54057413ED8E26A4AD21222183754FFB6FDDEBFEEC1D918803169 + 780C3FBAA2C776A675195D05A9AAB3B26AD34100FE383F534F5380CB5DFFEB16 + C3E1A76E1FD1E7D654748F745BFAF7AF51A56450FF707E7673679A91EEB5FD9B + F69F65FB91E650D867678F6AEFF68EE2D67C8EEE82D45BEC3CB9DAB568F5F0CC + 2BF8B107778A37F9CDBB07DC31E0E3D3A3189F1EADBB4D6FE19358D0D59B0FF1 + D91ED7FAC6B2FB26332C394A577B55F5765EF9F4B8FBFA77B70CD3D59E37F159 + 70EE7DCB37712CDFE5ADBD66B4FE0B4DAF7F7E92CA5A974B26212A90B1832275 + B7E90D7C2648809F9170B36B82985370CE27365FFBFCA4FBF5BCC9293EB1D95D + 7C26C8B4B1A9C4860761B33BF9CF81331DBFC10BACD9958FDAD899640E8D213C + D8CF2776BB83CF04199EE2EA5837EE3E45BDB5D33114DDA2C1E6646B76F312F0 + CCF1BA6F33EF363E132473A4EBCBF8FBBF8F7470A777C7A16F6E39ED7E3D7BA2 + C646A45EB63DD22782C4470493961081C5E6606776812F4CBAD977AA9213675D + E14311663FA6F5726FB04F04B92C2D0E80AF0EF7CCC9472F6F6C1E022FBA4EBF + E5006FE013419AA24BB273353693FA802D074B28AC6C00203536B8570F817D22 + 4842740800C59575BE30A7C92B1B73DCAF1FB8517F6F4157F1892051A1AE3D22 + 350DDA81D6BE60DD378594D7B8268A2392C21891D43BB740F844107F3FD7C910 + 7687E768FA1BC60DE2B22171BAAE2ABDF165F34471F1CD6DB793F5067C2288DA + B84661326A1FD9111F19CCABBF9CCACD570ED25590BFEDCCC3E67045B98F1914 + C9F0C4503DCD75099F08D2B427C4EC21206EF5AF6F00E0CAA1FDD0332EC7E650 + F9C77F9B977A17DF9CA1F4AE59888F0469EACCE322DB9EC0F1A30943DCA3B0B4 + 840871F9C0F6E37DBBCBCA2F9AA3EA2F1F1841525480AEF6CE179F08925BEC5A + EBD60AAE9E3929A3D5F54FAFD5B7D92AABB1F2C99E42F7F5C2CCC45E751C854F + 0AD3B4EB766C7A7CABF4003F23A307C7B64ABB2A2D4A244405EA5A9E173E39EA + 7E3D2A29444C1BA1EFFACCF9E01341F6E594E074AA449803DC4E4680C1FDC309 + F0736DE2FACFFE33ACDD9923011EBA49DF794245AD8D17D71D735FCF9F388097 + 66653063742C417EED9F15A6373E11C46273B065BFCBE5DEB2891AD0386104C8 + 3A55CAA32BB7A9005346C432304EDF139F567E71924FBF3DEBEED2132203983B + BE3F7FBE7318774D18407C987EC17DEDE1B3F673F5E64300DCF1830C9AF64326 + C5360BE270AA58ED4EBEC82A9600BFBF6DB8EE657AE4EDFDF2B71F1E533FCF2E + A7A471D2680E3070D3A531BC3A67280B331308F6F76D8DF19920DBB2F2C92DAE + C2CF64E089B9135D892D76AA96348EC45EF8E4A804189D1AC19569FAB7ED070B + 6AE5EB5B0B58B43A9BC7FF95C3E6EC726AADAE09ECF491D1BC327B28E30787EB + 5E8E267C3AC278B0F1F88DB9D70E67F1CC2B1897DEEC0ACF29AC0490F9E50DEE + 358CA7EFF0BC2D4E0F0E15D4F2972D79DCB73A9B57BF3C43698D8DD040230F4D + 4D61D1E4443AD8E9EC157C2AC8DEE3C5BCFCD13700DC7FF368AEB9CC15EC60B3 + 3BF9F64489FBBEE5EB8FB3EFD439E2C202B8F75ADFBBCB1B6C4EBE3C5CC1CFDF + 3DCCBAFDAE15C71F0E8B62F91D1924EB3C02F4F918FCC57FEEE1A535DFB8E3A6 + EA2D7616BDBCD97D1E4A130BFFBC9BC28A06EE9F3698F8F09E99BC399C9237B7 + 17F0D4C727A8A8B3931019C0B23BD2993844BFC96B8F4C8A96AFD9C3A407DF63 + EE73EBC97CF07DBEDC97DBE61EBB5365E6B2FF526F75B2E6E1093D50CA66F6E7 + D5F08B770FB3ED982B8CE981EB92F99F2BF55979ECB1596A5E690DDBB2F229AF + 6EF0784F75839DEB9FD94AA09F8165F32EF55DE13468B0AB2CDF9CCBB24DA7A9 + B53AB9E5F2381E9A9AE2753BBDCA6DA04545AD8DAB1FFB9241F1666EBBAAE7A3 + 46761C3FC7BC15596CCC2A63FCE0701EBC2EC5ABF9F786471E7548ADC5C18CE7 + B6F3C88C0CC6A747B1F3A8EF0E401340BF707F6242FC88083211E8A750D5E020 + BFC2829430614838A535FDF9DB9E920EF3EA0CBD5010CFFEF0E73F3EC2FCC9A9 + 2842B48A70EF161A43D90093C2D8D430C6A48492161F4C6C48FB0176D34646B3 + 3EAB9C5A2FAC50F742413C2325BCB33597A997C6931C134C6EA977D7E88580BB + AF4E60C290704203B4BF9AD21A1B157576CA6BED9CA9B070B8B0961325F5383A + 78225B67E95382806B91E9933D8504E8E4041C3730AC951859F9351457DBC82E + ACE348512DC5D5DA27DD193DAC869E2F7D4E90269A0EA3F12652C2D28DA778F6 + D6666FF3FA0365EC3E55E5755B9EE8F5A32C5F73BCB89E8D59CDFDD3E2A92917 + AE2FABAFB0626B3E59F9AEF053A341B87D59661F787EBF17C4034FACCD616BE3 + CC1C5CBEAC97670F65CA507DA31E3D0822FA6CDFE24D5EDA9CCBCA6DCDC1E161 + 8146EE9F92C4A3D7A77A636551F33BD614449134F8FEA9B44D08DF06E674B00F + 77C381521E78FF08070B9A0FE01C9B1AC6F25919A44477CDF3DB6850D367A429 + 884155970AC95F7BDDD9453DC4990A0BBFFF570E4B379EE250A14B9828B38917 + 6E4F273DBE0B4BCD52BE2611CF6BFD495390BC88224B5168E97D7683FC4CF9FE + A12D6E769DACE2F18F7278EAE313ECCD7585363D73CB904ED71429258A109BC3 + 83FDEF8D0EF5EF7C0D91460B4EA3055067A092FD7D3D69CDFEBC1AFEB8EE244B + D69FA4D6E2E485DBD3090BECB8DB95521E96929B4C46037E26ED1FBA66EAD8C2 + 74C6160D24A32AD01AA9044F5343232B1182EF9FC8D69A3DA7AB59F8D621B2F2 + 6B796DEE50E2C2FCDBFC76A52A404802A3EBAA8CD135D3EDE62A6B9928E1AC53 + DB19A9296B4DAEEB7C927AD549953F7975E141379A2392770883918ECE83BFD8 + B03B559E589BC3A22949BC70C7D0C099CB2AAC0515CDAD916272A2DA0C947E93 + 7C83D5AAE43AD4F68F34D714E4C8E94F5B5D9BFC837646DFF49BD90EC4BBF6AA + B308A56783C97A23AF6F2D206748AD6D5472B8D2248814922093117B9579CEA1 + 8F47ED90F68E9BB54ECD3754A79DF27DEBDE33C6A40C0A8C4E7ECAD3F3442E76 + B61DAB709A9CCD8F4935AA26CA2979BC2A24EF5D461BC0620253CB16664C9B3C + 3A2588D361A7EAC42ECCD69AA723C2D3521B1C96F9AA492074794C54DF7838B1 + 16D50D0E793AAF4215125483405583DE2C530A9E3E977008EED9094ACB877801 + AC6C9387B6209327B74DB3D6638D4BA638D1B02028D7906CAAB14F513D9C5C7D + B1E3300882ECCE2DB1E72A16045547535D792926A9B137E6EEB649DA82CC99D3 + 36CD60C46EA9C52E6B08AEB0DD643AEB38680D93A940CFEDE4EC9D045A144E85 + 591C3725145592A49831AA91A89D6C4EB405F9EA2BCFEF30082AECD67AFF28AE + 0B7184EF1692F02E14FA82444A192CA12AD264B8CE2F22B0AEC0DFD4DE230B35 + D116E4ECD976AC822D48C5191A94633E17391D2976F2BD8FC585400A29A68518 + 0C3986202355E101E7ED99D31624A0A3484107D80D0821BE42D04F4AF5196001 + 5ACFD6BB589072B522C4A34211450E15148713531776817BA15796C5A0DE2DA5 + 331ED4375C69175585592DA4EC2F90F34076FBEC10EF0D9304C512F56E29D578 + 50DF6C4A3C4FA48FC5ECC62198D2258494F300AF1DE2E2C571ABC0F55C4B598C + 54175CC0356695AB46300FE13D219AD069222110B86B4C1CA82B9BD2FB30AB1A + 6BC45D7A08D1844E8234B50302842C91A80BBBD994F524ABDD4278B169F2840F + A6DAAEA60CD1D494A9F1C8BED094C9169DB5FE4234E143DF478B3EA6B9F3EF15 + C27CA75FD7B58FE8081F3BA35A35652DFB9826614C80CF7CFB020C08F75CCCA7 + 4D93277A28DC47E2AE15429620E5DD52AA8F81FA34301E977F4C175F720B1409 + C148B94B201F1348EF3F70B70BFC3F9C434FDE627F724C0000000049454E44AE + 426082} + end> + end + item + Name = 'logo-sequal' + SourceImages = < + item + Image.Data = { + 89504E470D0A1A0A0000000D494844520000006400000064080600000070E295 + 54000000017352474200AECE1CE90000000467414D410000B18F0BFC61050000 + 00097048597300000EC300000EC301C76FA86400000B4249444154785EED9D0B + 70D4C51DC777F7FFB8BBDC25B93CA1098F189022CA432108C2A430CC54A88EA3 + 8D8E7D286AA7D551A9D65A6DED3843B5B5763A0547ADD23AB6B5B454C4DA6955 + AC561115AD4880040AA8A00984242610925CEEFD7F6D7FBFBDA48356920BE8B8 + 7F673F3397BDDD7BCCFEF7BBBFC7FE33B74B140AC530D0C1D297A49E6C66E90D + CDD46E3CCC597998D0804EB8ED12F7FD1E125A5E47C3D7CDE7C6D431DEE0DB15 + 9F16E917DE61FD373EA50F56872576C746DDDAD6E69B89E73B0B89AFDAAC15DE + BAD8C5E75653476DEA0F6F9DC32A23DFF3BAE2A63790F15824C0F5A99526AB88 + 3C1CFADAD95B29A57BF1BDD9AD87B4C0BC89E27332E32B41120FBCA6476EAA77 + 3CC7AD4EDCF3D2EDCEFB3DD77A7DE920C93A84B0E32EC5E3841607895E534ACC + F935EB83974CBF0684C9C4EE7A8115AF3C5F6A17E61B41926B1BF5F0F23AC7DA + DDB920FD44D3ABF68E768D3830B61A7508A56CF06D39F0AA1CCF8378C25834C4 + 8C59D5AF16AE3CFF6A10E5E0C0AA5758D1AD8BA415C51782A49FDAA5851A66BA + F6DEAEF3926BDED80225A3A66E1346208A0F730D6835B66B138D19C10BA625C3 + 2B168E05511256639B66D64D90D27D7D78664988D5DCC1500CCEF9B4F486A6D7 + ED3D2046D070410663583110705D446706944EE6E93DE1C47DAF6E84EF294031 + 9CC37D524E46E90589FDE01FA24C3DD6F8636B7B3BA5A66613C235D1980FA009 + 5888CEC181D94D1DF5D94D07EEC6E6E4EFDE92F2DAA51624FBF20156F1D20D9E + 97CCCEB11BDBBEC9D396185C31C8A38183290574DD3DDC47ECA6F66F8395448A + 7FB2D4B577774A6725520B62ED6817FD4BFD6567BDDB93249431B48E931B4414 + 45873C605F77B1DDDCB1189B20964877FD725BC8E603A2CC6C684EF0810CC603 + 3A6AEB1802E30D85DC0BBEC73B9ABC4434651C6521F9E2B4F4D0F2E7AE75C0BD + 68C10BCFBC915B90147D34BD1D2D906261A0775A8F25B0EA75C745B34C482B08 + C7C55E8E0009EAB522633AF5349DA385F1941D14155BBECC575A418C33C6F216 + 720983499D72F6763D0CD9158C203FD5051DC358A28D2B3E88151A099CAC03FC + D4903A8694DDF91DD13FC8905A686100D715A73280F859460CCDCA6E697D041B + 9C03479520A3C1985925062C78E9CC340DC13AD0F520309FA4D782CFA18B32CE + 1A1B8FDE7FB1F8DEC84DF54A90D1C0D3B67051817327AED5C645F78214E8B746 + EFF85143D773698149E0713FB8C1637DD73DA99BE78C53828C86F0F23A9E5CDB + 2856E5A1CB66DEAB4DA900911CEF437776F3C30577A79B75E31391DB163F800D + A1AF4E57F7B24E0610C57D0DE6B8397BFC3A637AD51A561931C0726C7041F9CE + 6E07DEAF6993CB49E8AABACBC03A62B195FF64C1F3A74A671D88F482200B8E8A + 650389DCB0E00698E5BFD1AA8A0D62BBB8A6C05BEFB0E43BCE62F069AEEEC1EB + C23220161173EE842F1BA7953DDFF7ADC7B5E2BB96A9DBEFA78AB5AB939A8341 + 3EB5BEE9CECC73FB6E81D57BA917CF62FEE4520D5440215C8F70C7E334A86BD4 + D489565BBA3D7C73FD0F8DDAF297E3F7BD6214DEB2C8165F2829BE1104C96E3D + 44930FBEC64AD75DE9C24A7E56F6E5F7565A3B0ECF218E378EC7329885115A14 + 242C1A021FA76D63E5917B0A6F5BFC347E3676FBD37AF12F2FFADF6A53567C25 + C810F1559BF5C25B178BC1E59C7F21F3ECDE49F6F6768B272DAA9F5DCD834BA7 + 6A5A59F84D7CBD9534D0CA3FDFC1C257CC9132887F6E88AFDECC067EB1C918AC + 7E2C033F7B31FFFF9B48822F2DE478C06551ABA983B9FBBAB997B1890EA9B139 + 6F223567557B346848994929140A8542A15028140A8542A15028140A8542A150 + 28140A8542A15028140A8542A15028140A8542E16F7CF77384F8AF36537BF707 + A3EB39E784150649F4A106F5F304C5E8F09D852437EC8AD8BB3A74E8795EB31D + 2F1037E4D022015E78C792815CABBCF8469023F3EF67956FDEEC0DDCF5C2267B + 77673DA1340E233DF2CFBA29C59F47076951B03DB8E4F4E90557CEC9F6DFF857 + 1A7DE85229DD972F7EA72EB0723FA0753B63C53C9ED5793C53C213D9E2111FF1 + 6C098FA543ACD08C86AE982DBE439B542E4A19F18F2083F31906D8115B6B50B1 + 5F2F6E1A30FC8351173FCA2A0AF107A0E27AF5DA322CA4C4378204164D12EED5 + EB4D0DEDC280F53C1E3CB7AF03257B28A5697CAA8D8F622125BE10C439D8CB8A + 575F8C7BF72ED42795CD17BBCDE5BBDD1F271E3175DCE1F48F583D76F95ADD9C + 3D5ECAF881F84210880562927B3DC931C400CF837B9CE42C6064701FF8A04ECC + 793521AC6A151169C540FC612187FB73E5C15E9BA76CE8F5F1BBCD0C033A2CD7 + E3341220C6DC09016CD26755E5F7D9CF085F08029955AE3CD447D15D51B15F56 + 1E139D4300D1186EE734A0D7966ECCB59DF2BE8D9F2AFE10A4B53757BEDFC360 + 70D142443D0F30D3424BE9366756BF8B0DA9DF6F532EEB54715B8F8932F3ECBE + 244F5AD06BE8763EC38ABA791ED14F2B33212110D75A70751D16D2E20B41E2EB + FE25863FD4306329C1BD76F336104A380475ADA6C4829457B82AF3DC89E21559 + F1852013C99FC460B2F2F0C59835C138E72789E771163689DBD6BF1AAB3DCB1E + D1CC59D5CA657D52D8EF1E4988F89197BBC26D6121C32A2D20E6C2D3C41E8105 + CBE7889764C61782F45FFFA4B008B7A53717A4F301B2296A309D0F645B82174C + FBBB68B2F08C24B9915E10FB3F9D5A74CD659CA7ADA5B4C09801838AA2E4D76F + B0247D4A05C68F443BB99E86AF9A2BB5BB42A417C469CB2D0AED3D5D55E20918 + CA60393C6848B8CF7B4DA9D8E7BD9DACC1427AE417645F9728B35B5A523C9E25 + B0D083DA08131DC5B05C8F8D29C4DA6FF1CF99AB5F91FE5A11E93B995EDF2C4A + AFBDBFC28B6708D120AA8FE478F086229E3B95B00E99F593C46698AC3C227DFC + 40A416C46AEEA0953BBE8F77799936B9FC169E76A0C77945758833103FCE18D3 + 6B4E1BD3DD7BF95A2DBC7C8EF4F103915A90A135032EEA9C3D5D2ED5A1BBF99C + 58816F3134A24FAD14F7AF9C9663BE1003915A90F4337B45FFDC23F1D95E6FAA + 5A8831D2A210D71F9643B5AA62A27FB1E2196C2ABC7B693E562505520B421C4F + F4CF79AF6711A4BC21EE7AB618F1E1C0F547004C29EBEC0CCCABD9B69F2CA0A1 + 6567F8661365A905C96EDA2FCAF4134D71B0103CF60EA67F7E2E8B5515BD844F + 2BAE5921F7A4FB08D276D669EFA7D15F37E0296DBA3EB9FCBB5E4C645823F717 + FF21150DE17BD7639516057D133F106905C96C7C7BF019E1EE07F131F9AD3F28 + E78EA769630B63453F5D96C4A6F08A85E225BF20AD20BC3F256285F376F778E7 + 9D23C6E04DC5E1E38707F12364106D42740B6466FB633F7A56374EAFF0C5FA63 + 086905D1C64545DF9CD6DEAFC32047C115392366589C533C670A5CDC3A51B55D + 5F8981482B48E2C1D7857F72767716F14476E4153ABA2BDB657A6DA91DBCE8AC + D7B1A9E01BE78897FC849482D8FB8FD0CAAD37E30ABD04ACE37AAF3F8DE7E00E + DFD7417745187B14DC557BCF858F6AE6ECF1CA423E09528F358A32BBB52D69BF + DDED0D9EF229DA4E08E71AAC3FE08AA838854DAF29F1557635849482B0F2B088 + 15947B4BBC238912B1161C7E788525B08AC8CEA27BBED28ACFF519B9F3AAFC86 + 948250531727E3D8BB3ABF04AE0A67BF3D6C404777556010F3BC9ACDE0AEB203 + 3F7FD1885C3B5F09F249E0F5246864C54271929AB3FFE8143E143F4E34BC18EA + 3DAED3920248774B1E134D86E6DBF3A6A413C4DAD3252C01027A198B862E82CC + 69E8FFE8E8963EE6411D8C2F7A6DD981C0E2C9E25E4BA861862FAD03914E10BB + A95D94D61BAD673A078E6AB042A7C4E51A0C3A1EBDFDFF0FC73568D884E53CBF + 17DC95155BF9BCAED796FB569013FBE5CF086BDB21CD9C3BD175DEEBB9D3DADE + 7605B7DC63903941FAF4B14E8B832806A4BB7DA186991762FCC86EDA4F034BA6 + F856102949ADDF39EA8992FADB6EE926D7C920ED4564FFDD4AFBAF7E9CBA5D71 + 3CB5F304692F364254B75D5235702FC6148542F1398690FF029A8D9B27B85043 + 410000000049454E44AE426082} + end> + end + item + Name = 'key_vector' + SourceImages = < + item + Image.Data = { + 89504E470D0A1A0A0000000D49484452000000100000001008060000001FF3FF + 61000000017352474200AECE1CE90000000467414D410000B18F0BFC61050000 + 00097048597300000EC300000EC301C76FA8640000001874455874536F667477 + 617265005061696E742E4E455420352E312E36FCD1C7AF000000B66558496649 + 492A000800000005001A010500010000004A0000001B01050001000000520000 + 0028010300010000000200000031010200100000005A00000069870400010000 + 006A00000000000000600000000100000060000000010000005061696E742E4E + 455420352E312E3600030000900700040000003032333001A003000100000001 + 00000005A0040001000000940000000000000002000100020004000000523938 + 0002000700040000003031303000000000C2087FD6D5255A4D0000013B494441 + 54384FDD8C4B4B026118858F635184BCD885124BDA77A1887E84AD8330C995E0 + 2E68DBB2458B685FEDFA01B58DA06D57BB29220C06038A1853605333A3BDC3E8 + F7B58B61C4DAFBEC0EE73907E86D3462A542BC6745DC078D38EDEFFFA544BC25 + E22CC59929C5ACA867C988FB9DAE68C419B1F4DD163B552992A67452425667B8 + 714AEABAD753BCC14B085841C2549077815803FD2DC6E4DCFBD0C2C0F4A1D7EB + 7AC0808A1705786D018F4D205F016E9BA8C1097ABD8E038D78D988B8F7D1D160 + 02D7365062A0EC007600575F139C778A19FFE6970AF1468DF8596C7F4811294A + 41055920DDBE091B7A366CE90774B7EADF04BCE133E6E628632E62BF0EA08D52 + DF70F3BCF5B419C4FC490883489BE396D7EFC08ABA5991D4A408AB521DD1AD23 + BA48F99D3FC9516DB73C65BCE5C6F4F2315DAEF9FB1EE50766138FD293CD4ECC + 0000000049454E44AE426082} + end> end> Left = 689 Top = 339 @@ -23947,4 +25773,32 @@ object MainForm: TMainForm Left = 689 Top = 299 end + object popupDataTop: TPopupMenu + Left = 352 + Top = 320 + object menuQueryExactRowCount: TMenuItem + AutoCheck = True + Caption = 'Query exact row count' + OnClick = menuQueryExactRowCountClick + end + end + object TimerCloseTabByButton: TTimer + Enabled = False + Interval = 100 + OnTimer = TimerCloseTabByButtonTimer + Left = 761 + Top = 195 + end + object popupApplyFilter: TPopupMenu + Left = 200 + Top = 312 + object menuAlwaysGenerateFilter: TMenuItem + AutoCheck = True + Caption = 'Always generate filter' + Hint = + 'Generate filter based on this text, even if the current filter i' + + 's not empty' + OnClick = menuAlwaysGenerateFilterClick + end + end end diff --git a/source/main.pas b/source/main.pas index 1ee3ddaff..0f3e8d921 100644 --- a/source/main.pas +++ b/source/main.pas @@ -8,19 +8,21 @@ interface uses - Windows, SysUtils, Classes, Graphics, GraphUtil, Forms, Controls, Menus, StdCtrls, Dialogs, Buttons, - Messages, ExtCtrls, ComCtrls, StdActns, ActnList, ImgList, ToolWin, Clipbrd, SynMemo, StrUtils, - SynEdit, SynEditTypes, SynEditKeyCmds, VirtualTrees, DateUtils, - ShlObj, SynEditMiscClasses, SynEditSearch, SynEditRegexSearch, SynCompletionProposal, SynEditHighlighter, - SynHighlighterSQL, Tabs, SynUnicode, SynRegExpr, ExtActns, IOUtils, Types, Themes, ComObj, - CommCtrl, Contnrs, Generics.Collections, Generics.Defaults, SynEditExport, SynExportHTML, SynExportRTF, Math, ExtDlgs, Registry, AppEvnts, - routine_editor, trigger_editor, event_editor, options, EditVar, apphelpers, createdatabase, table_editor, + Winapi.Windows, System.SysUtils, System.Classes, Vcl.Graphics, Vcl.GraphUtil, Vcl.Forms, Vcl.Controls, Vcl.Menus, Vcl.StdCtrls, Vcl.Dialogs, Vcl.Buttons, + Winapi.Messages, Vcl.ExtCtrls, Vcl.ComCtrls, Vcl.StdActns, Vcl.ActnList, Vcl.ImgList, Vcl.ToolWin, Vcl.Clipbrd, SynMemo, System.StrUtils, + SynEdit, SynEditTypes, SynEditKeyCmds, System.DateUtils, + Winapi.ShlObj, SynEditMiscClasses, SynEditSearch, SynEditRegexSearch, SynCompletionProposal, SynEditHighlighter, + SynHighlighterSQL, Vcl.Tabs, SynUnicode, SynRegExpr, Vcl.ExtActns, System.IOUtils, System.Types, Vcl.Themes, System.Win.ComObj, + Winapi.CommCtrl, System.Contnrs, System.Generics.Collections, System.Generics.Defaults, SynEditExport, SynExportHTML, SynExportRTF, System.Math, Vcl.ExtDlgs, System.Win.Registry, Vcl.AppEvnts, + routine_editor, trigger_editor, event_editor, preferences, EditVar, apphelpers, createdatabase, table_editor, TableTools, View, Usermanager, SelectDBObject, connections, sqlhelp, dbconnection, - insertfiles, searchreplace, loaddata, copytable, VirtualTrees.HeaderPopup, VirtualTrees.Utils, Cromis.DirectoryWatch, SyncDB, gnugettext, - JumpList, System.Actions, System.UITypes, pngimage, - System.ImageList, Vcl.Styles.UxTheme, Vcl.Styles.Utils.Menus, Vcl.Styles.Utils.Forms, + insertfiles, searchreplace, loaddata, copytable, csv_detector, Cromis.DirectoryWatch, SyncDB, gnugettext, + VirtualTrees, VirtualTrees.HeaderPopup, VirtualTrees.Utils, VirtualTrees.Types, + JumpList, System.Actions, System.UITypes, Vcl.Imaging.pngimage, + System.ImageList, Vcl.Styles.Utils.Forms, Vcl.VirtualImageList, Vcl.BaseImageCollection, Vcl.ImageCollection, System.IniFiles, extra_controls, - SynEditCodeFolding; + SynEditCodeFolding, SynEditStrConst, texteditor, System.Character, generic_types, Sequal.Suggest, + VirtualTrees.BaseAncestorVCL, VirtualTrees.BaseTree, VirtualTrees.AncestorVCL; type @@ -51,31 +53,54 @@ TResultTab = class(TObject) Results: TDBQuery; Grid: TVirtualStringTree; FilterText: String; + private + FTabIndex: Integer; public constructor Create(AOwner: TQueryTab); destructor Destroy; override; + property TabIndex: Integer read FTabIndex; end; TResultTabs = TObjectList; TQueryTab = class(TComponent) + const + IdentBackupFilename = 'BackupFilename'; + IdentFilename = 'Filename'; + IdentFileEncoding = 'FileEncoding'; + IdentCaption = 'Caption'; + IdentPid = 'pid'; + IdentEditorHeight = 'EditorHeight'; + IdentHelpersWidth = 'HelpersWidth'; + IdentBindParams = 'BindParams'; + IdentEditorTopLine = 'EditorTopLine'; + IdentTabFocused = 'TabFocused'; + HelperNodeColumns = 0; + HelperNodeFunctions = 1; + HelperNodeKeywords = 2; + HelperNodeSnippets = 3; + HelperNodeHistory = 4; + HelperNodeProfile = 5; + HelperNodeBinding = 6; private - FMemo: TSynMemo; FMemoFilename: String; FQueryRunning: Boolean; FLastChange: TDateTime; - procedure SetMemo(Value: TSynMemo); + FDirectoryWatchNotficationRunning: Boolean; + FErrorLine: Integer; + FFileEncoding: String; procedure SetMemoFilename(Value: String); procedure SetQueryRunning(Value: Boolean); procedure TimerLastChangeOnTimer(Sender: TObject); procedure TimerStatusUpdateOnTimer(Sender: TObject); - procedure MemoOnChange(Sender: TObject); function GetBindParamsActivated: Boolean; procedure SetBindParamsActivated(Value: Boolean); + procedure SetErrorLine(Value: Integer); public Number: Integer; Uid: String; ExecutionThread: TQueryThread; CloseButton: TSpeedButton; pnlMemo: TPanel; + Memo: TSynMemo; pnlHelpers: TPanel; filterHelpers: TButtonedEdit; treeHelpers: TVirtualStringTree; @@ -99,19 +124,30 @@ TQueryTab = class(TComponent) TimerStatusUpdate: TTimer; function GetActiveResultTab: TResultTab; procedure DirectoryWatchNotify(const Sender: TObject; const Action: TWatchAction; const FileName: string); + procedure DirectoryWatchErrorHandler(const Sender: TObject; const ErrorCode: Integer; const ErrorMessage: string); procedure MemofileModifiedTimerNotify(Sender: TObject); - function LoadContents(Filename: String; ReplaceContent: Boolean; Encoding: TEncoding): Boolean; + function LoadContents(Filepath: String; ReplaceContent: Boolean; Encoding: TEncoding): Boolean; property BindParamsActivated: Boolean read GetBindParamsActivated write SetBindParamsActivated; procedure SaveContents(Filename: String; OnlySelection: Boolean); procedure BackupUnsavedContent; property ActiveResultTab: TResultTab read GetActiveResultTab; - property Memo: TSynMemo read FMemo write SetMemo; property MemoFilename: String read FMemoFilename write SetMemoFilename; function MemoBackupFilename: String; property QueryRunning: Boolean read FQueryRunning write SetQueryRunning; constructor Create(AOwner: TComponent); override; destructor Destroy; override; class function GenerateUid: String; + property ErrorLine: Integer read FErrorLine write SetErrorLine; + property FileEncoding: String read FFileEncoding write FFileEncoding; + end; + TQueryTabList = class(TObjectList) + public + function ActiveTab: TQueryTab; + function ActiveMemo: TSynMemo; + function ActiveHelpersTree: TVirtualStringTree; + function HasActiveTab: Boolean; + function TabByNumber(Number: Integer): TQueryTab; + function TabByControl(Control: TWinControl): TQueryTab; end; TQueryHistoryItem = class(TObject) @@ -132,8 +168,6 @@ TQueryHistoryItemComparer = class(TComparer) function Compare(const Left, Right: TQueryHistoryItem): Integer; override; end; - TThreeStateBoolean = (nbUnset, nbFalse, nbTrue); - ITaskbarList = interface(IUnknown) [SID_ITaskbarList] function HrInit: HRESULT; stdcall; @@ -163,10 +197,17 @@ TQueryHistoryItemComparer = class(TComparer) end; TMainForm = class(TExtForm) + actDataEditWithoutLookup: TAction; + actTreeShowColumns: TAction; MainMenu1: TMainMenu; MainMenuFile: TMenuItem; FileNewItem: TMenuItem; MainMenuHelp: TMenuItem; + FollowForeignKey: TMenuItem; + menuDataEditWithoutLookup: TMenuItem; + menuTreeShowColumns2: TMenuItem; + menuTreeShowColumns1: TMenuItem; + menuRenameSnippet: TMenuItem; N1: TMenuItem; FileExitItem: TMenuItem; menuAbout: TMenuItem; @@ -175,6 +216,7 @@ TMainForm = class(TExtForm) PasteItem: TMenuItem; StatusBar: TStatusBar; ActionList1: TActionList; + actFollowForeignKey: TAction; actCopy: TAction; actPaste: TAction; actNewWindow: TAction; @@ -384,7 +426,7 @@ TMainForm = class(TExtForm) menuDeleteSnippet: TMenuItem; menuHelp: TMenuItem; menuLoadSnippet: TMenuItem; - menuInsertSnippetAtCursor: TMenuItem; + menuInsertAtCursor: TMenuItem; menuExplore: TMenuItem; menuSQLhelp2: TMenuItem; menuSQLhelpData: TMenuItem; @@ -439,7 +481,7 @@ TMainForm = class(TExtForm) N26: TMenuItem; actSessionManager: TAction; Sessionmanager1: TMenuItem; - actCreateRoutine: TAction; + actCreateProcedure: TAction; btnExit: TToolButton; lblSorryNoData: TLabel; menuPrint: TMenuItem; @@ -459,7 +501,7 @@ TMainForm = class(TExtForm) menuAutoRefresh: TMenuItem; popupMainTabs: TPopupMenu; menuNewQueryTab: TMenuItem; - menuCloseTab: TMenuItem; + menuCloseQueryTab: TMenuItem; actNewQueryTab: TAction; actCloseQueryTab: TAction; Newquerytab1: TMenuItem; @@ -467,7 +509,6 @@ TMainForm = class(TExtForm) pnlRight: TPanel; btnCloseFilterPanel: TSpeedButton; actFilterPanel: TAction; - actFindInVT1: TMenuItem; TimerFilterVT: TTimer; actFindTextOnServer: TAction; actFindTextOnServer1: TMenuItem; @@ -548,7 +589,6 @@ TMainForm = class(TExtForm) actCancelOperation: TAction; actToggleComment: TAction; Uncomment1: TMenuItem; - actSynchronizeDatabase: TAction; Disconnect1: TMenuItem; N4: TMenuItem; ImportCSVfile1: TMenuItem; @@ -565,13 +605,8 @@ TMainForm = class(TExtForm) menuGroupObjects: TMenuItem; actLogHorizontalScrollbar: TAction; actGroupObjects: TAction; - lblExplainProcessAnalyzer: TLabel; - menuExplainAnalyzer: TMenuItem; menuQueryExplain: TMenuItem; actExplainCurrentQuery: TAction; - actExplainAnalyzeCurrentQuery: TAction; - Explaincurrentquery1: TMenuItem; - Explainanalyzerforcurrentquery1: TMenuItem; menuAutoExpand: TMenuItem; menuTreeOptions: TMenuItem; menuClearDataTabFilter: TMenuItem; @@ -623,8 +658,6 @@ TMainForm = class(TExtForm) actGotoTab31: TMenuItem; actGotoTab41: TMenuItem; actGotoTab51: TMenuItem; - actCopyRows: TAction; - Copyselectedrows1: TMenuItem; actClearQueryLog: TAction; ControlBarMain: TControlBar; ImageCollectionIcons8: TImageCollection; @@ -635,7 +668,6 @@ TMainForm = class(TExtForm) filterQueryHelpers: TButtonedEdit; TimerStoreTabs: TTimer; Duplicaterowwithkeys1: TMenuItem; - imgDonate: TImage; actGoToQueryResults: TAction; Switchtoqueryresults1: TMenuItem; actGoToDataMultiFilter: TAction; @@ -706,7 +738,6 @@ TMainForm = class(TExtForm) ReformatSQL3: TMenuItem; Clear1: TMenuItem; Explaincurrentquery2: TMenuItem; - Explainanalyzerforcurrentquery2: TMenuItem; Newquerytab2: TMenuItem; Closequerytab1: TMenuItem; Wraplonglines1: TMenuItem; @@ -725,7 +756,70 @@ TMainForm = class(TExtForm) actCodeFoldingFoldSelection: TAction; Foldselection1: TMenuItem; SetdelimiterusedinSQLexecution1: TMenuItem; + actConnectionProperties: TAction; + Connectionproperties1: TMenuItem; + menuCopyAs: TMenuItem; + actRenameQueryTab: TAction; + menuRenameQueryTab: TMenuItem; + Renametab1: TMenuItem; + actNewQueryTabNofocus: TAction; + DataGUIDlowercase: TMenuItem; + DataGUIDlowercaseWobraces: TMenuItem; + actCreateFunction: TAction; + Storedfunction1: TMenuItem; + menuEditorCommands: TMenuItem; + N16: TMenuItem; + actCloseAllQueryTabs: TAction; + actCloseAllQueryTabs1: TMenuItem; + N25: TMenuItem; + Closeallquerytabs1: TMenuItem; + menuCloseRightQueryTabs: TMenuItem; + actSynMoveDown: TAction; + actSynMoveUp: TAction; + actCopyTabsToSpaces: TAction; + Copywithtabstospaces1: TMenuItem; + Movelinedown1: TMenuItem; + Movelineup1: TMenuItem; + menuCloseTabOnDblClick: TMenuItem; + Undo1: TMenuItem; + actSequalSuggest: TAction; + SequalSuggest1: TMenuItem; + SequalSuggest2: TMenuItem; + popupDataTop: TPopupMenu; + menuQueryExactRowCount: TMenuItem; + menuCloseTabOnMiddleClick: TMenuItem; + TimerCloseTabByButton: TTimer; + menuTabsInMultipleLines: TMenuItem; + ToolBarDonate: TToolBar; + btnDonate: TToolButton; + actResetPanelDimensions: TAction; + popupApplyFilter: TPopupMenu; + menuAlwaysGenerateFilter: TMenuItem; + actGenerateData: TAction; + Generatedata1: TMenuItem; + Generatedata2: TMenuItem; + actCopyGridNodes: TAction; + actCopyGridNodes1: TMenuItem; + actQueryTable: TAction; + Selecttop1000rows1: TMenuItem; + MainMenuDisplay: TMenuItem; + actDisplayObjectSize: TAction; + menuDisplaysizeofobjects1: TMenuItem; + menuShowonlyfavorites1: TMenuItem; + menuFilterpanel1: TMenuItem; + menuResetpaneldimensions1: TMenuItem; + actDisplayLogPanel: TAction; + actDisplayTreeFilters: TAction; + menuDisplayLogPanel1: TMenuItem; + menuTreefilters1: TMenuItem; + N27: TMenuItem; + actCopyColumnNames: TAction; + Copycolumnnames1: TMenuItem; + actCopyFormatted: TAction; + Copyformattedtext1: TMenuItem; procedure actCreateDBObjectExecute(Sender: TObject); + procedure actDataEditWithoutLookupExecute(Sender: TObject); + procedure actTreeShowColumnsExecute(Sender: TObject); procedure menuConnectionsPopup(Sender: TObject); procedure actExitApplicationExecute(Sender: TObject); procedure WMCopyData(var Msg: TWMCopyData); message WM_COPYDATA; @@ -735,6 +829,8 @@ TMainForm = class(TExtForm) procedure AfterFormCreate; procedure FormShow(Sender: TObject); procedure FormResize(Sender: TObject); + procedure AddEditorCommandMenu(const S: string); + procedure EditorCommandOnClick(Sender: TObject); procedure actUserManagerExecute(Sender: TObject); procedure actAboutBoxExecute(Sender: TObject); procedure actApplyFilterExecute(Sender: TObject); @@ -742,6 +838,7 @@ TMainForm = class(TExtForm) procedure actTableToolsExecute(Sender: TObject); procedure actPrintListExecute(Sender: TObject); procedure actCopyTableExecute(Sender: TObject); + procedure popupListHeaderPopup(Sender: TObject); procedure ShowStatusMsg(Msg: String=''; PanelNr: Integer=6); procedure actExecuteQueryExecute(Sender: TObject); procedure actCreateDatabaseExecute(Sender: TObject); @@ -796,7 +893,6 @@ TMainForm = class(TExtForm) TargetCanvas: TCanvas); procedure LogSQL(Msg: String; Category: TDBLogCategory=lcInfo; Connection: TDBConnection=nil); procedure KillProcess(Sender: TObject); - procedure SynMemoQueryStatusChange(Sender: TObject; Changes: TSynStatusChanges); procedure TimerHostUptimeTimer(Sender: TObject); procedure ListTablesNewText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; NewText: String); @@ -807,7 +903,7 @@ TMainForm = class(TExtForm) procedure SynMemoQueryDragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean); procedure SynMemoQueryDragDrop(Sender, Source: TObject; X, Y: Integer); - procedure SynMemoQueryDropFiles(Sender: TObject; X, Y: Integer; AFiles: TStrings); + procedure SynMemoQueryDropFiles(Sender: TObject; X, Y: Integer; AFiles: TUnicodeStrings); procedure popupHostPopup(Sender: TObject); procedure popupDBPopup(Sender: TObject); procedure popupDataGridPopup(Sender: TObject); @@ -834,9 +930,10 @@ TMainForm = class(TExtForm) TColumnIndex; NewText: String); procedure AnyGridPaintText(Sender: TBaseVirtualTree; const TargetCanvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType); + procedure menuRenameSnippetClick(Sender: TObject); procedure menuDeleteSnippetClick(Sender: TObject); procedure menuExploreClick(Sender: TObject); - procedure menuInsertSnippetAtCursorClick(Sender: TObject); + procedure menuInsertAtCursorClick(Sender: TObject); procedure menuLoadSnippetClick(Sender: TObject); procedure AnyGridHeaderClick(Sender: TVTHeader; HitInfo: TVTHeaderHitInfo); procedure AnyGridCompareNodes(Sender: TBaseVirtualTree; Node1, Node2: @@ -882,7 +979,7 @@ TMainForm = class(TExtForm) procedure AnyGridAfterCellPaint(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; CellRect: TRect); - procedure menuShowSizeColumnClick(Sender: TObject); + procedure actDisplayObjectSizeExecute(Sender: TObject); procedure AnyGridBeforeCellPaint(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; CellPaintMode: TVTCellPaintMode; CellRect: TRect; var ContentRect: TRect); @@ -906,6 +1003,7 @@ TMainForm = class(TExtForm) procedure ListTablesInitNode(Sender: TBaseVirtualTree; ParentNode, Node: PVirtualNode; var InitialStates: TVirtualNodeInitStates); procedure AnyGridAfterPaint(Sender: TBaseVirtualTree; TargetCanvas: TCanvas); + procedure actFollowForeignKeyExecute(Sender: TObject); procedure actCopyOrCutExecute(Sender: TObject); procedure actPasteExecute(Sender: TObject); procedure actSelectAllExecute(Sender: TObject); @@ -919,20 +1017,13 @@ TMainForm = class(TExtForm) procedure PageControlMainMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure actNewQueryTabExecute(Sender: TObject); procedure actCloseQueryTabExecute(Sender: TObject); - procedure menuCloseQueryTab(Sender: TObject); + procedure menuCloseQueryTabClick(Sender: TObject); procedure CloseQueryTab(PageIndex: Integer); - procedure CloseButtonOnMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); - procedure CloseButtonOnMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); + procedure CloseButtonOnClick(Sender: TObject); function GetMainTabAt(X, Y: Integer): Integer; procedure FixQueryTabCloseButtons; - function ActiveQueryTab: TQueryTab; - function GetOrCreateEmptyQueryTab: TQueryTab; - function GetQueryTabByNumber(Number: Integer): TQueryTab; - function GetQueryTabByHelpers(FindTree: TBaseVirtualTree): TQueryTab; - function ActiveQueryMemo: TSynMemo; - function ActiveQueryHelpers: TVirtualStringTree; + function GetOrCreateEmptyQueryTab(DoFocus: Boolean): TQueryTab; function ActiveSynMemo(AcceptReadOnlyMemo: Boolean): TSynMemo; - function QueryTabActive: Boolean; function IsQueryTab(PageIndex: Integer; IncludeFixed: Boolean): Boolean; procedure popupMainTabsPopup(Sender: TObject); procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean); @@ -960,7 +1051,6 @@ TMainForm = class(TExtForm) procedure actDataShowAllExecute(Sender: TObject); procedure AnyGridInitNode(Sender: TBaseVirtualTree; ParentNode, Node: PVirtualNode; var InitialStates: TVirtualNodeInitStates); - procedure editFilterVTRightButtonClick(Sender: TObject); procedure AnyGridFocusChanged(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex); procedure ListTablesKeyPress(Sender: TObject; var Key: Char); @@ -971,9 +1061,6 @@ TMainForm = class(TExtForm) procedure ListDatabasesInitNode(Sender: TBaseVirtualTree; ParentNode, Node: PVirtualNode; var InitialStates: TVirtualNodeInitStates); procedure ListDatabasesGetNodeDataSize(Sender: TBaseVirtualTree; var NodeDataSize: Integer); - procedure ListDatabasesBeforeCellPaint(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; - Node: PVirtualNode; Column: TColumnIndex; CellPaintMode: TVTCellPaintMode; CellRect: TRect; - var ContentRect: TRect); procedure menuFetchDBitemsClick(Sender: TObject); procedure ListDatabasesGetImageIndex(Sender: TBaseVirtualTree; Node: PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex; var Ghosted: Boolean; var ImageIndex: TImageIndex); @@ -1023,7 +1110,6 @@ TMainForm = class(TExtForm) procedure actCancelOperationExecute(Sender: TObject); procedure AnyGridChange(Sender: TBaseVirtualTree; Node: PVirtualNode); procedure actToggleCommentExecute(Sender: TObject); - procedure actSynchronizeDatabaseExecute(Sender: TObject); procedure DBtreeBeforeCellPaint(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; CellPaintMode: TVTCellPaintMode; CellRect: TRect; var ContentRect: TRect); @@ -1036,10 +1122,7 @@ TMainForm = class(TExtForm) procedure DBtreeExpanding(Sender: TBaseVirtualTree; Node: PVirtualNode; var Allowed: Boolean); procedure actGroupObjectsExecute(Sender: TObject); - procedure lblExplainProcessAnalyzerClick(Sender: TObject); procedure popupSqlLogPopup(Sender: TObject); - procedure actExplainAnalyzeCurrentQueryExecute(Sender: TObject); - procedure menuQueryExplainClick(Sender: TObject); procedure menuAutoExpandClick(Sender: TObject); procedure pnlLeftResize(Sender: TObject); procedure editDatabaseTableFilterChange(Sender: TObject); @@ -1047,9 +1130,6 @@ TMainForm = class(TExtForm) procedure editDatabaseTableFilterMenuClick(Sender: TObject); procedure editDatabaseTableFilterExit(Sender: TObject); procedure menuClearDataTabFilterClick(Sender: TObject); - procedure ListVariablesBeforeCellPaint(Sender: TBaseVirtualTree; - TargetCanvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; - CellPaintMode: TVTCellPaintMode; CellRect: TRect; var ContentRect: TRect); procedure actUnixTimestampColumnExecute(Sender: TObject); procedure PopupQueryLoadPopup(Sender: TObject); procedure DonateClick(Sender: TObject); @@ -1085,7 +1165,7 @@ TMainForm = class(TExtForm) procedure actGotoFilterExecute(Sender: TObject); procedure actGotoTabNumberExecute(Sender: TObject); procedure StatusBarClick(Sender: TObject); - procedure SynMemoQueryMouseWheel(Sender: TObject; Shift: TShiftState; + procedure AnySynMemoMouseWheel(Sender: TObject; Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean); procedure SynMemoQueryKeyPress(Sender: TObject; var Key: Char); procedure filterQueryHelpersChange(Sender: TObject); @@ -1108,12 +1188,48 @@ TMainForm = class(TExtForm) procedure actCodeFoldingStartRegionExecute(Sender: TObject); procedure actCodeFoldingEndRegionExecute(Sender: TObject); procedure actCodeFoldingFoldSelectionExecute(Sender: TObject); + procedure actConnectionPropertiesExecute(Sender: TObject); + procedure actRenameQueryTabExecute(Sender: TObject); + procedure menuRenameQueryTabClick(Sender: TObject); + procedure SynMemoQueryStatusChange(Sender: TObject; Changes: TSynStatusChanges); + procedure actCloseAllQueryTabsExecute(Sender: TObject); + procedure menuCloseRightQueryTabsClick(Sender: TObject); + procedure popupFilterPopup(Sender: TObject); + procedure actSynMoveDownExecute(Sender: TObject); + procedure actSynMoveUpExecute(Sender: TObject); + procedure actCopyTabsToSpacesExecute(Sender: TObject); + procedure actCopyUpdate(Sender: TObject); + procedure FormBeforeMonitorDpiChanged(Sender: TObject; OldDPI, + NewDPI: Integer); + procedure menuToggleAllClick(Sender: TObject); + procedure menuCopyColumnNamesClick(Sender: TObject); + procedure FormAfterMonitorDpiChanged(Sender: TObject; OldDPI, + NewDPI: Integer); + procedure menuCloseTabOnDblClickClick(Sender: TObject); + procedure TimerRefreshTimer(Sender: TObject); + procedure SynCompletionProposalChange(Sender: TObject; AIndex: Integer); + procedure SynMemoQuerySpecialLineColors(Sender: TObject; Line: Integer; + var Special: Boolean; var FG, BG: TColor); + procedure SynMemoSQLLogSpecialLineColors(Sender: TObject; Line: Integer; + var Special: Boolean; var FG, BG: TColor); + procedure actSequalSuggestExecute(Sender: TObject); + procedure menuQueryExactRowCountClick(Sender: TObject); + procedure menuCloseTabOnMiddleClickClick(Sender: TObject); + procedure TimerCloseTabByButtonTimer(Sender: TObject); + procedure menuTabsInMultipleLinesClick(Sender: TObject); + procedure actResetPanelDimensionsExecute(Sender: TObject); + procedure menuAlwaysGenerateFilterClick(Sender: TObject); + procedure SynMemoQueryTokenHint(Sender: TObject; Coords: TBufferCoord; + const Token: string; TokenType: Integer; Attri: TSynHighlighterAttributes; + var HintText: string); + procedure actCopyGridNodesExecute(Sender: TObject); + procedure actQueryTableExecute(Sender: TObject); + procedure actDisplayLogPanelExecute(Sender: TObject); + procedure actDisplayTreeFiltersExecute(Sender: TObject); + procedure actCopyFormattedExecute(Sender: TObject); private // Executable file details - FAppVerMajor: Integer; - FAppVerMinor: Integer; - FAppVerRelease: Integer; - FAppVerRevision: Integer; + FAppVerMajor, FAppVerMinor, FAppVerRelease, FAppVerRevision: Word; FAppVersion: String; FLastHintMousepos: TPoint; @@ -1136,9 +1252,11 @@ TMainForm = class(TExtForm) FFilterTextDatabase, FFilterTextData: String; FTreeRefreshInProgress: Boolean; + FRefreshActionDisabledAt: Cardinal; FDataGridColumnWidthsCustomized: Boolean; FDataGridLastClickedColumnHeader: Integer; FDataGridLastClickedColumnLeftPos: Integer; + FDataGridSortItems: TSortItems; FSnippetFilenames: TStringList; FConnections: TDBConnectionList; FTreeClickHistory: TNodeArray; @@ -1146,14 +1264,14 @@ TMainForm = class(TExtForm) FOperatingGrid: TBaseVirtualTree; FActiveDbObj: TDBObject; FActiveObjectGroup: TListNodeType; - FIsWine: Boolean; FBtnAddTab: TSpeedButton; FDBObjectsMaxSize: Int64; FDBObjectsMaxRows: Int64; FSearchReplaceDialog: TfrmSearchReplace; - FPreferencesDialog: Toptionsform; FCreateDatabaseDialog: TCreateDatabaseForm; + FTableToolsDialog: TfrmTableTools; FGridEditFunctionMode: Boolean; + FDataEditWithoutLookup: Boolean; FClipboardHasNull: Boolean; FTimeZoneOffset: Integer; FGridCopying: Boolean; @@ -1165,8 +1283,15 @@ TMainForm = class(TExtForm) FLastPortableSettingsSave: Cardinal; FLastAppSettingsWrites: Integer; FFormatSettings: TFormatSettings; + FDefaultHintFontName: String; FActionList1DefaultCaptions: TStringList; FActionList1DefaultHints: TStringList; + FEditorCommandStrings: TStringList; + FLastSelWordInEditor: String; + FMatchingBraceForegroundColor: TColor; + FMatchingBraceBackgroundColor: TColor; + FSynEditInOnPaintTransient: Boolean; + //FHelpData: TSimpleKeyValuePairs; // Host subtabs backend structures FHostListResults: TDBQueryList; @@ -1199,6 +1324,7 @@ TMainForm = class(TExtForm) procedure SetSnippetFilenames; function TreeClickHistoryPrevious(MayBeNil: Boolean=False): PVirtualNode; procedure OperationRunning(Runs: Boolean); + procedure OpenQueryFiles(Filenames: TStrings; Encoding: TEncoding; ForceRun: Boolean); function RunQueryFiles(Filenames: TStrings; Encoding: TEncoding; ForceRun: Boolean): Boolean; function RunQueryFile(Filename: String; Encoding: TEncoding; Conn: TDBConnection; ProgressDialog: IProgressDialog; FilesizeSum: Int64; var CurrentPosition: Int64): Boolean; @@ -1208,15 +1334,14 @@ TMainForm = class(TExtForm) function InitTabsIniFile: TIniFile; procedure StoreTabs; function RestoreTabs: Boolean; + procedure SetHintFontByControl(Control: TWinControl=nil); public - QueryTabs: TObjectList; + QueryTabs: TQueryTabList; ActiveObjectEditor: TDBObjectEditor; FileEncodings: TStringList; - ImportSettingsDone: Boolean; // Data grid related stuff DataGridHiddenColumns: TStringList; - DataGridSortColumns: TOrderColArray; DataGridWantedRowCount: Int64; DataGridTable: TDBObject; DataGridFocusedCell: TStringList; @@ -1230,8 +1355,6 @@ TMainForm = class(TExtForm) SelectedTableForeignKeys: TForeignKeyList; SelectedTableTimestampColumns: TStringList; FilterPanelManuallyOpened: Boolean; - MatchingBraceForegroundColor, - MatchingBraceBackgroundColor: TColor; // Task button interface TaskbarList: ITaskbarList; @@ -1239,12 +1362,13 @@ TMainForm = class(TExtForm) TaskbarList3: ITaskbarList3; TaskbarList4: ITaskbarList4; - property AppVerRevision: Integer read FAppVerRevision; + property AppVerRevision: Word read FAppVerRevision; property AppVersion: String read FAppVersion; property Connections: TDBConnectionList read FConnections; property Delimiter: String read FDelimiter write SetDelimiter; - property IsWine: Boolean read FIsWine; property FocusedTables: TDBObjectList read FFocusedTables; + function GetAlternatingRowBackground(Node: PVirtualNode): TColor; + procedure PaintAlternatingRowBackground(TargetCanvas: TCanvas; Node: PVirtualNode; CellRect: TRect); procedure PaintColorBar(Value, Max: Extended; TargetCanvas: TCanvas; CellRect: TRect); procedure CallSQLHelpWithKeyword( keyword: String ); procedure AddOrRemoveFromQueryLoadHistory(Filename: String; AddIt: Boolean; CheckIfFileExists: Boolean); @@ -1267,14 +1391,15 @@ TMainForm = class(TExtForm) procedure CalcNullColors; procedure HandleDataGridAttributes(RefreshingData: Boolean); function GetRegKeyTable: String; - procedure SaveListSetup( List: TVirtualStringTree ); - procedure RestoreListSetup( List: TVirtualStringTree ); procedure UpdateEditorTab; procedure SetWindowCaption; procedure DefaultHandler(var Message); override; - procedure SetupSynEditors; + procedure SetupSynEditors; overload; + procedure SetupSynEditors(BaseForm: TComponent); overload; + procedure SetupSynEditor(Editor: TSynMemo); function AnyGridEnsureFullRow(Grid: TVirtualStringTree; Node: PVirtualNode): Boolean; procedure DataGridEnsureFullRows(Grid: TVirtualStringTree; SelectedOnly: Boolean); + property DataGridSortItems: TSortItems read FDataGridSortItems write FDataGridSortItems; function GetEncodingByName(Name: String): TEncoding; function GetEncodingName(Encoding: TEncoding): String; function GetCharsetByEncoding(Encoding: TEncoding): String; @@ -1295,6 +1420,9 @@ TMainForm = class(TExtForm) property ActionList1DefaultCaptions: TStringList read FActionList1DefaultCaptions; property ActionList1DefaultHints: TStringList read FActionList1DefaultHints; function SelectedTableFocusedColumn: TTableColumn; + property FormatSettings: TFormatSettings read FFormatSettings; + property MatchingBraceForegroundColor: TColor read FMatchingBraceForegroundColor write FMatchingBraceForegroundColor; + property MatchingBraceBackgroundColor: TColor read FMatchingBraceBackgroundColor write FMatchingBraceBackgroundColor; end; @@ -1303,10 +1431,19 @@ TMainForm = class(TExtForm) SecondInstMsgId: UINT = 0; SysLanguage: String; MainFormCreated: Boolean = False; + MainFormAfterCreateDone: Boolean = False; PostponedLogItems: TDBLogItems; const CheckedStates = [csCheckedNormal, csCheckedPressed, csMixedNormal, csMixedPressed]; + ErrorLineForeground: TColor = $00000000; + ErrorLineBackground: TColor = $00D2B7FF; + WarningLineForeground: TColor = $00000000; + WarningLineBackground: TColor = $00B7CDFF; + NoteLineForeground: TColor = $00000000; + NoteLineBackground: TColor = $00D3F7FF; + InfoLineForeground: TColor = $00000000; + InfoLineBackground: TColor = $00C6FFEC; {$I const.inc} @@ -1314,8 +1451,9 @@ TMainForm = class(TExtForm) implementation uses - About, printlist, dbstructures, UpdateCheck, - column_selection, data_sorting, grideditlinks, ExportGrid, jpeg, GIFImg; + About, printlist, dbstructures, dbstructures.mysql, UpdateCheck, + column_selection, data_sorting, grideditlinks, ExportGrid, Vcl.Imaging.jpeg, Vcl.Imaging.GIFImg, + reformatter; @@ -1331,11 +1469,16 @@ procedure TMainForm.ShowStatusMsg(Msg: String=''; PanelNr: Integer=6); Msg := _(SIdle); if Msg <> StatusBar.Panels[PanelNr].Text then begin StatusBar.Panels[PanelNr].Text := Msg; - if PanelNr = 6 then begin + if (PanelNr = 6) and IsWindow(StatusBar.Handle) then begin // Immediately repaint this special panel, as it holds critical update messages, // while avoiding StatusBar.Repaint which refreshes all panels SendMessage(StatusBar.Handle, SB_GETRECT, PanelNr, Integer(@PanelRect)); StatusBar.OnDrawPanel(StatusBar, StatusBar.Panels[PanelNr], PanelRect); + InvalidateRect(StatusBar.Handle, PanelRect, False); + // Alternatives: + //RedrawWindow(StatusBar.Handle, @PanelRect, 0, RDW_UPDATENOW); + //UpdateWindow(StatusBar.Handle); + //StatusBar.Repaint; end; end; end; @@ -1344,28 +1487,20 @@ procedure TMainForm.ShowStatusMsg(Msg: String=''; PanelNr: Integer=6); procedure TMainForm.StatusBarClick(Sender: TObject); var Click: TPoint; - i, j: Integer; + i: Integer; PanelRect: TRect; - Infos: TStringList; - InfoText: String; begin // Handle click events on specific statusbar panels + // Prevent SendMessage on Wine + if IsWine then + Exit; Click := StatusBar.ScreenToClient(Mouse.CursorPos); for i:=0 to StatusBar.Panels.Count-1 do begin SendMessage(StatusBar.Handle, SB_GETRECT, i, Integer(@PanelRect)); if PtInRect(PanelRect, Click) then begin // We found the clicked panel case i of - 3: begin - if ActiveConnection <> nil then begin - Infos := ActiveConnection.ConnectionInfo; - InfoText := ''; - for j:=0 to Infos.Count-1 do begin - InfoText := InfoText + Infos.Names[j] + ': ' + Infos.ValueFromIndex[j] + CRLF; - end; - MessageDialog(Trim(InfoText), mtInformation, [mbOK]); - end; - end; + 3: actConnectionProperties.Execute; end; Break; end; @@ -1387,8 +1522,10 @@ procedure TMainForm.StatusBarDrawPanel(StatusBar: TStatusBar; Panel: TStatusPane 2: ImageIndex := 149; 3: begin Conn := ActiveConnection; - if Conn <> nil then + if Conn <> nil then try ImageIndex := Conn.Parameters.ImageIndex; + except + end; end; 5: ImageIndex := 190; 6: begin @@ -1416,8 +1553,11 @@ procedure TMainForm.StatusBarMouseMove(Sender: TObject; Shift: TShiftState; X, Y i: Integer; Infos: TStringList; HintText: String; + Conn: TDBConnection; begin // Display various server, client and connection related details in a hint + if IsWine then + Exit; if (FLastHintMousepos.X = X) and (FLastHintMousepos.Y = Y) then Exit; FLastHintMousepos := Point(X, Y); @@ -1434,8 +1574,9 @@ procedure TMainForm.StatusBarMouseMove(Sender: TObject; Shift: TShiftState; X, Y Exit; FLastHintControlIndex := i; if FLastHintControlIndex = 3 then begin - if ActiveConnection <> nil then begin - Infos := ActiveConnection.ConnectionInfo; + Conn := ActiveConnection; + if (Conn <> nil) and (not Conn.IsLockedByThread) then begin + Infos := Conn.ConnectionInfo; HintText := ''; for i:=0 to Infos.Count-1 do begin HintText := HintText + Infos.Names[i] + ': ' + StrEllipsis(Infos.ValueFromIndex[i], 200) + CRLF; @@ -1526,9 +1667,9 @@ procedure TMainForm.actGoToQueryResultsExecute(Sender: TObject); Tab: TQueryTab; Grid: TVirtualStringTree; begin - if QueryTabActive then begin + if QueryTabs.HasActiveTab then begin // Switch between query editor and result grid - Tab := ActiveQueryTab; + Tab := QueryTabs.ActiveTab; if Tab.Memo.Focused then begin if Tab.ActiveResultTab <> nil then begin Grid := Tab.ActiveResultTab.Grid; @@ -1549,7 +1690,7 @@ procedure TMainForm.actGoToQueryResultsExecute(Sender: TObject); SelectNode(DataGrid, 0); end else begin ToggleFilterPanel(True); - SynMemoFilter.SetFocus; + SynMemoFilter.TrySetFocus; end; end else begin MessageBeep(MB_ICONASTERISK); @@ -1562,7 +1703,7 @@ procedure TMainForm.actGoToDataMultiFilterExecute(Sender: TObject); // Go to multi column filter generator if PageControlMain.ActivePage = tabData then begin ToggleFilterPanel(True); - editFilterSearch.SetFocus; + editFilterSearch.TrySetFocus; end else begin MessageBeep(MB_ICONASTERISK); end; @@ -1609,6 +1750,11 @@ procedure TMainForm.actGridEditFunctionExecute(Sender: TObject); ActiveGrid.EditNode(ActiveGrid.FocusedNode, ActiveGrid.FocusedColumn); end; +procedure TMainForm.actDataEditWithoutLookupExecute(Sender: TObject); +begin + FDataEditWithoutLookup := True; + DataGrid.EditNode(DataGrid.FocusedNode, DataGrid.FocusedColumn); +end; procedure TMainForm.StoreLastSessions; var @@ -1617,13 +1763,13 @@ procedure TMainForm.StoreLastSessions; JumpTask: TJumpTask; SessionPath: String; i: Integer; - LastConnect, DummyDate: TDateTime; + LastConnect: TDateTime; begin // Store names of open sessions OpenSessions := TStringList.Create; for Connection in Connections do OpenSessions.Add(Connection.Parameters.SessionPath); - AppSettings.WriteString(asLastSessions, ImplodeStr(DELIM, OpenSessions)); + AppSettings.WriteString(asLastSessions, Implode(DELIM, OpenSessions)); OpenSessions.Free; if Assigned(ActiveConnection) then AppSettings.WriteString(asLastActiveSession, ActiveConnection.Parameters.SessionPath); @@ -1636,8 +1782,7 @@ procedure TMainForm.StoreLastSessions; AppSettings.GetSessionPaths('', SessionPaths); for SessionPath in SessionPaths do begin AppSettings.SessionPath := SessionPath; - DummyDate := StrToDateTime('2000-01-01'); - LastConnect := StrToDateTimeDef(AppSettings.ReadString(asLastConnect), DummyDate); + LastConnect := StrToDateTimeDef(AppSettings.ReadString(asLastConnect), DateTimeNever); if DaysBetween(LastConnect, Now) <= 30 then SortedSessions.Values[SessionPath] := IntToStr(AppSettings.ReadInt(asConnectCount)); end; @@ -1663,6 +1808,25 @@ procedure TMainForm.StoreLastSessions; end; +procedure TMainForm.FormAfterMonitorDpiChanged(Sender: TObject; OldDPI, + NewDPI: Integer); +begin + // DPI settings change finished + FormResize(Sender); +end; + +procedure TMainForm.FormBeforeMonitorDpiChanged(Sender: TObject; OldDPI, + NewDPI: Integer); +var + Factor: Extended; +begin + // Moving window to different screen or user changed DPI setting for current screen + Factor := 100 / PixelsPerInchDesigned * NewDPI; + LogSQL(f_('Scaling controls to screen DPI: %d%%', [Round(Factor)])); + //LogSQL('PixelsPerInchDesigned:'+PixelsPerInchDesigned.ToString+' OldDPI:'+OldDPI.ToString+' NewDPI:'+NewDPI.ToString); +end; + + procedure TMainForm.FormCloseQuery(Sender: TObject; var CanClose: Boolean); var i: Integer; @@ -1714,6 +1878,7 @@ procedure TMainForm.FormDestroy(Sender: TObject); AppSettings.WriteInt(asCompletionProposalNbLinesInWindow, SynCompletionProposal.NbLinesInWindow); AppSettings.WriteInt(asDbtreewidth, pnlLeft.width); AppSettings.WriteBool(asGroupTreeObjects, actGroupObjects.Checked); + AppSettings.WriteBool(asTreeShowColumns, actTreeShowColumns.Checked); AppSettings.WriteInt(asDataPreviewHeight, pnlPreview.Height); AppSettings.WriteBool(asDataPreviewEnabled, actDataPreview.Checked); AppSettings.WriteInt(asLogHeight, SynMemoSQLLog.Height); @@ -1728,8 +1893,8 @@ procedure TMainForm.FormDestroy(Sender: TObject); if WindowState = wsNormal then begin AppSettings.WriteInt(asMainWinLeft, Left); AppSettings.WriteInt(asMainWinTop, Top); - AppSettings.WriteInt(asMainWinWidth, Width); - AppSettings.WriteInt(asMainWinHeight, Height); + AppSettings.WriteIntDpiAware(asMainWinWidth, Self, Width); + AppSettings.WriteIntDpiAware(asMainWinHeight, Self, Height); end; SaveListSetup(ListDatabases); SaveListSetup(ListVariables); @@ -1754,18 +1919,13 @@ procedure TMainForm.FormCreate(Sender: TObject); var i, j, MonitorIndex: Integer; QueryTab: TQueryTab; - Action: TAction; - dwInfoSize, // Size of VERSIONINFO structure - dwVerSize, // Size of Version Info Data - dwWnd: DWORD; // Handle for the size call. - FI: PVSFixedFileInfo; // Delphi structure; see WINDOWS.PAS - ptrVerBuf: Pointer; - FunctionCategories: TStringList; - miGroup, miFilterGroup, miFunction, miFilterFunction: TMenuItem; - NTHandle: THandle; + Action, CopyAsAction: TAction; + ExportFormat: TGridExportFormat; + CopyAsMenu, CommandMenu: TMenuItem; TZI: TTimeZoneInformation; - wine_nt_to_unix_file_name: procedure(p1:pointer; p2:pointer); stdcall; dti: TDBDatatypeCategoryIndex; + EditorCommand: TSynEditorCommand; + CmdCap: String; begin caption := APPNAME; @@ -1798,26 +1958,8 @@ procedure TMainForm.FormCreate(Sender: TObject); end; // Detect version - dwInfoSize := GetFileVersionInfoSize(PChar(Application.ExeName), dwWnd); - GetMem(ptrVerBuf, dwInfoSize); - GetFileVersionInfo(PChar(Application.ExeName), dwWnd, dwInfoSize, ptrVerBuf); - VerQueryValue(ptrVerBuf, '\', Pointer(FI), dwVerSize ); - FAppVerMajor := HiWord(FI.dwFileVersionMS); - FAppVerMinor := LoWord(FI.dwFileVersionMS); - FAppVerRelease := HiWord(FI.dwFileVersionLS); - FAppVerRevision := LoWord(FI.dwFileVersionLS); + GetExecutableVersion(Application.ExeName, FAppVerMajor, FAppVerMinor, FAppVerRelease, FAppVerRevision); FAppVersion := Format('%d.%d.%d.%d', [FAppVerMajor, FAppVerMinor, FAppVerRelease, FAppVerRevision]); - FreeMem(ptrVerBuf); - - // Detect if we're running on Wine, not on native Windows - // Idea taken from http://ruminatedrumblings.blogspot.com/2008/04/detecting-virtualized-environment.html - NTHandle := LoadLibrary('NTDLL.DLL'); - if NTHandle>32 then - wine_nt_to_unix_file_name := GetProcAddress(NTHandle, 'wine_nt_to_unix_file_name') - else - wine_nt_to_unix_file_name := nil; - FIsWine := Assigned(wine_nt_to_unix_file_name); - FreeLibrary(NTHandle); // Taskbar button interface for Windows 7 // Possibly fails. See http://www.heidisql.com/forum.php?t=22451 @@ -1835,52 +1977,47 @@ procedure TMainForm.FormCreate(Sender: TObject); // Load snippet filenames SetSnippetFilenames; - // Create function menu items in popupQuery and popupFilter - menuQueryInsertFunction.Clear; - menuFilterInsertFunction.Clear; - FunctionCategories := GetFunctionCategories; - for i:=0 to FunctionCategories.Count-1 do begin - // Create a menu item which gets subitems later - miGroup := TMenuItem.Create(popupQuery); - miGroup.Caption := FunctionCategories[i]; - menuQueryInsertFunction.Add(miGroup); - miFilterGroup := TMenuItem.Create(popupFilter); - miFilterGroup.Caption := miGroup.Caption; - menuFilterInsertFunction.Add(miFilterGroup); - for j:=0 to Length(MySqlFunctions)-1 do begin - if MySqlFunctions[j].Category <> FunctionCategories[i] then - continue; - miFunction := TMenuItem.Create(popupQuery); - miFunction.Caption := MySqlFunctions[j].Name; - miFunction.ImageIndex := 13; - // Prevent generating a hotkey - miFunction.Caption := StringReplace(miFunction.Caption, '&', '&&', [rfReplaceAll]); - // Prevent generating a seperator line - if miFunction.Caption = '-' then - miFunction.Caption := '&-'; - miFunction.Hint := MySqlFunctions[j].Name + MySqlFunctions[j].Declaration + ' - ' + StrEllipsis(MySqlFunctions[j].Description, 200); - // Prevent generating a seperator for ShortHint and LongHint - miFunction.Hint := StringReplace( miFunction.Hint, '|', '¦', [rfReplaceAll] ); - miFunction.Tag := j; - // Place menuitem on menu - miFunction.OnClick := insertFunction; - miGroup.Add(miFunction); - // Create a copy of the menuitem for popupFilter - miFilterFunction := TMenuItem.Create(popupFilter); - miFilterFunction.Caption := miFunction.Caption; - miFilterFunction.Hint := miFunction.Hint; - miFilterFunction.ImageIndex := miFunction.ImageIndex; - miFilterFunction.Tag := miFunction.Tag; - miFilterFunction.OnClick := miFunction.OnClick; - miFilterFunction.Enabled := miFunction.Enabled; - miFilterGroup.Add(miFilterFunction); + // Dynamically create actions and menuitems in "Copy as" context menu + for ExportFormat:=Low(TGridExportFormat) to High(TGridExportFormat) do begin + CopyAsAction := TAction.Create(ActionList1); + CopyAsAction.ActionList := ActionList1; + CopyAsAction.Category := actExportData.Category; + CopyAsAction.Name := TfrmExportGrid.CopyAsActionPrefix + Integer(ExportFormat).ToString; + CopyAsAction.Caption := TfrmExportGrid.FormatToDescription[ExportFormat]; + CopyAsAction.ImageIndex := TfrmExportGrid.FormatToImageIndex[ExportFormat]; + CopyAsAction.Tag := Integer(ExportFormat); + CopyAsAction.OnExecute := actCopyOrCutExecute; + CopyAsMenu := TMenuItem.Create(popupDataGrid); + CopyAsMenu.Action := CopyAsAction; + menuCopyAs.Add(CopyAsMenu); + end; + + // Generate submenu with SynEdit commands + FEditorCommandStrings := TStringList.Create; + SynEditKeyCmds.GetEditorCommandValues(AddEditorCommandMenu); + for i:=0 to FEditorCommandStrings.Count-1 do begin + EditorCommand := ConvertCodeStringToCommand(FEditorCommandStrings[i]); + CommandMenu := TMenuItem.Create(MainMenu1); + CmdCap := FEditorCommandStrings[i]; + CmdCap := Copy(CmdCap, 3, Length(CmdCap)-2); + // Insert spaces before uppercase chars + for j:=Length(CmdCap) downto 1 do begin + if (j > 1) and CmdCap[j].IsUpper then + Insert(' ', CmdCap, j); + end; + CommandMenu.Caption := CmdCap; + for j:=0 to SynMemoQuery.Keystrokes.Count-1 do begin + if SynMemoQuery.Keystrokes[j].Command = EditorCommand then begin + CommandMenu.Caption := CommandMenu.Caption + ' (' + ShortCutToText(SynMemoQuery.Keystrokes[j].ShortCut) + ')'; + Break; + end; end; + CommandMenu.OnClick := EditorCommandOnClick; + menuEditorCommands.Add(CommandMenu); end; - FunctionCategories.Free; - Delimiter := AppSettings.ReadString(asDelimiter); - InheritFont(SynCompletionProposal.Font); + Delimiter := AppSettings.ReadString(asDelimiter); // Define static query tab as first one in our QueryTabs list QueryTab := TQueryTab.Create(Self); @@ -1892,14 +2029,14 @@ procedure TMainForm.FormCreate(Sender: TObject); QueryTab.filterHelpers := filterQueryHelpers; QueryTab.treeHelpers := treeQueryHelpers; QueryTab.Memo := SynMemoQuery; - QueryTab.MemoLineBreaks := lbsNone; + QueryTab.MemoLineBreaks := TLineBreaks(AppSettings.ReadInt(asLineBreakStyle)); QueryTab.spltHelpers := spltQueryHelpers; QueryTab.spltQuery := spltQuery; QueryTab.tabsetQuery := tabsetQuery; InheritFont(QueryTab.tabsetQuery.Font); QueryTab.ResultTabs := TResultTabs.Create(True); - QueryTabs := TObjectList.Create(True); + QueryTabs := TQueryTabList.Create(True); QueryTabs.Add(QueryTab); // Populate generic results for "Host" subtabs @@ -1911,22 +2048,9 @@ procedure TMainForm.FormCreate(Sender: TObject); // Enable auto completion in data tab, filter editor SynCompletionProposal.AddEditor(SynMemoFilter); - // Fix node height on Virtual Trees for current DPI settings - FixVT(DBTree); - FixVT(ListDatabases); - FixVT(ListVariables); - FixVT(ListStatus); - FixVT(ListProcesses); - FixVT(ListCommandStats); - FixVT(ListTables); - FixVT(treeQueryHelpers); - // Window position Left := AppSettings.ReadInt(asMainWinLeft); Top := AppSettings.ReadInt(asMainWinTop); - // .. dimensions - Width := AppSettings.ReadInt(asMainWinWidth); - Height := AppSettings.ReadInt(asMainWinHeight); // ... state if AppSettings.ReadBool(asMainWinMaximized) then WindowState := wsMaximized; @@ -1947,6 +2071,7 @@ procedure TMainForm.FormCreate(Sender: TObject); actPreferencesLogging.OnExecute := actPreferences.OnExecute; actPreferencesData.ImageIndex := actPreferences.ImageIndex; actPreferencesData.OnExecute := actPreferences.OnExecute; + menuAlwaysGenerateFilter.Checked := AppSettings.ReadBool(asAlwaysGenerateFilter); pnlQueryMemo.Height := AppSettings.ReadInt(asQuerymemoheight); pnlQueryHelpers.Width := AppSettings.ReadInt(asQueryhelperswidth); @@ -1963,16 +2088,9 @@ procedure TMainForm.FormCreate(Sender: TObject); LogToFile := AppSettings.ReadBool(asLogToFile); if AppSettings.ReadBool(asLogHorizontalScrollbar) then actLogHorizontalScrollbar.Execute; - if AppSettings.ReadBool(asFavoriteObjectsOnly) then - actFavoriteObjectsOnly.Execute; // Data-Font: - DataGrid.Font.Name := AppSettings.ReadString(asDataFontName); - QueryGrid.Font.Name := AppSettings.ReadString(asDataFontName); - DataGrid.Font.Size := AppSettings.ReadInt(asDataFontSize); - QueryGrid.Font.Size := AppSettings.ReadInt(asDataFontSize); - FixVT(DataGrid, AppSettings.ReadInt(asGridRowLineCount)); - FixVT(QueryGrid, AppSettings.ReadInt(asGridRowLineCount)); + ApplyFontToGrids; // Load color settings DatatypeCategories[dtcInteger].Color := AppSettings.ReadInt(asFieldColorNumeric); DatatypeCategories[dtcReal].Color := AppSettings.ReadInt(asFieldColorReal); @@ -1983,25 +2101,26 @@ procedure TMainForm.FormCreate(Sender: TObject); DatatypeCategories[dtcOther].Color := AppSettings.ReadInt(asFieldColorOther); CalcNullColors; + FDataGridSortItems := TSortItems.Create(True); + DataLocalNumberFormat := AppSettings.ReadBool(asDataLocalNumberFormat); + DataGridTable := nil; + FActiveDbObj := nil; - // Database tree options + // Display options, and database tree options actGroupObjects.Checked := AppSettings.ReadBool(asGroupTreeObjects); - if AppSettings.ReadBool(asDisplayObjectSizeColumn) then - menuShowSizeColumn.Click; + actTreeShowColumns.Checked := AppSettings.ReadBool(asTreeShowColumns); + actDisplayObjectSize.Checked := AppSettings.ReadBool(asDisplayObjectSizeColumn); + actDisplayObjectSizeExecute(nil); + actDisplayLogPanel.Checked := AppSettings.ReadBool(asDisplayLogPanel); + actDisplayLogPanelExecute(nil); + actDisplayTreeFilters.Checked := AppSettings.ReadBool(asDisplayTreeFilters); + actDisplayTreeFiltersExecute(nil); if AppSettings.ReadBool(asAutoExpand) then menuAutoExpand.Click; if AppSettings.ReadBool(asDoubleClickInsertsNodeText) then menuDoubleClickInsertsNodeText.Click; - // Restore width of columns of all VirtualTrees - RestoreListSetup(ListDatabases); - RestoreListSetup(ListVariables); - RestoreListSetup(ListStatus); - RestoreListSetup(ListProcesses); - RestoreListSetup(ListCommandStats); - RestoreListSetup(ListTables); - // Shortcuts FActionList1DefaultCaptions := TStringList.Create; FActionList1DefaultHints := TStringList.Create; @@ -2012,7 +2131,11 @@ procedure TMainForm.FormCreate(Sender: TObject); FActionList1DefaultHints.Insert(i, Action.Hint); end; - // Size of completion proposal window + // Completion proposal window + // The proposal form gets scaled a second time when it shows its form with Scaled=True. + // We already store and restore the dimensions DPI aware. + SynCompletionProposal.Form.Scaled := False; + SynCompletionProposal.TimerInterval := AppSettings.ReadInt(asCompletionProposalInterval); SynCompletionProposal.Width := AppSettings.ReadInt(asCompletionProposalWidth); SynCompletionProposal.NbLinesInWindow := AppSettings.ReadInt(asCompletionProposalNbLinesInWindow); @@ -2023,6 +2146,7 @@ procedure TMainForm.FormCreate(Sender: TObject); // SynMemo font, hightlighting and shortcuts SetupSynEditors; + PageControlMain.MultiLine := AppSettings.ReadBool(asTabsInMultipleLines); SetMainTab(tabHost); FBtnAddTab := TSpeedButton.Create(PageControlMain); FBtnAddTab.Parent := PageControlMain; @@ -2052,7 +2176,7 @@ procedure TMainForm.FormCreate(Sender: TObject); FGridCopying := False; FGridPasting := False; - FileEncodings := Explode(',', _('Auto detect (may fail)')+',ANSI,ASCII,Unicode,Unicode Big Endian,UTF-8,UTF-7'); + FileEncodings := Explode(',', _('Auto detect (may fail)')+',ANSI,ASCII,Unicode,Unicode Big Endian,UTF-8,UTF-7,UTF-8-BOM'); // Detect timezone offset in seconds, once case GetTimeZoneInformation(TZI) of @@ -2063,11 +2187,21 @@ procedure TMainForm.FormCreate(Sender: TObject); end; FTimeZoneOffset := FTimeZoneOffset * 60; + // Fix node height on Virtual Trees + FixVT(DBTree); + FixVT(ListDatabases); + FixVT(ListVariables); + FixVT(ListStatus); + FixVT(ListProcesses); + FixVT(ListCommandStats); + FixVT(ListTables); + FixVT(treeQueryHelpers); + // Set noderoot for query helpers box treeQueryHelpers.RootNodeCount := 7; // Initialize taskbar jump list - if not FIsWine then begin + if not IsWine then begin FJumpList := TJumpList.Create; FJumpList.ApplicationId := APPNAME + IntToStr(GetExecutableBits); end; @@ -2076,12 +2210,7 @@ procedure TMainForm.FormCreate(Sender: TObject); FLastPortableSettingsSave := 0; FLastAppSettingsWrites := 0; FFormatSettings := TFormatSettings.Create('en-US'); - - if RunningAsUwp then begin - actUpdateCheck.Enabled := False; - actUpdateCheck.Hint := f_('Please update %s through the Microsoft Store.', [APPNAME]); - actWebDownloadpage.Hint := 'ms-windows-store://pdp/?PRODUCTID=9NXPRT2T0ZJF'; - end; + FDefaultHintFontName := Screen.HintFont.Name; // Now we are free to use certain methods, which are otherwise fired too early MainFormCreated := True; @@ -2105,23 +2234,15 @@ procedure TMainForm.AfterFormCreate; LoadedParams, ConnectionParams: TConnectionParameters; LastUpdatecheck, LastStatsCall, LastConnect: TDateTime; UpdatecheckInterval, i: Integer; - DefaultLastrunDate, LastActiveSession, Environment: String; + LastActiveSession, Environment, RunFrom: String; frm : TfrmUpdateCheck; StatsCall: THttpDownload; SessionPaths: TStringlist; DlgResult: TModalResult; - Tab: TQueryTab; - SessionManager: TConnForm; begin - DefaultLastrunDate := '2000-01-01'; - - // Do an updatecheck if checked in settings if AppSettings.ReadBool(asUpdatecheck) then begin - try - LastUpdatecheck := StrToDateTime(AppSettings.ReadString(asUpdatecheckLastrun)); - except - LastUpdatecheck := StrToDateTime(DefaultLastrunDate); - end; + // Do an updatecheck if checked in settings + LastUpdatecheck := StrToDateTimeDef(AppSettings.ReadString(asUpdatecheckLastrun), DateTimeNever); UpdatecheckInterval := AppSettings.ReadInt(asUpdatecheckInterval); if DaysBetween(Now, LastUpdatecheck) >= UpdatecheckInterval then begin frm := TfrmUpdateCheck.Create(Self); @@ -2130,14 +2251,14 @@ procedure TMainForm.AfterFormCreate; frm.ReadCheckFile; // Show the dialog if release is available, or - when wanted - build checks are activated if (AppSettings.ReadBool(asUpdatecheckBuilds) and frm.btnBuild.Enabled) - or frm.btnRelease.Enabled then begin + or frm.LinkLabelRelease.Enabled then begin frm.ShowModal; end; except on E:Exception do LogSQL(f_('Error when checking for updates: %s', [E.Message])); end; - frm.Free; + frm.Free; // FormClose has no caFree, as it may not have been called end; end; @@ -2147,22 +2268,16 @@ procedure TMainForm.AfterFormCreate; // Probably hide image FHasDonatedDatabaseCheck := nbUnset; - imgDonate.Visible := HasDonated(True) <> nbTrue; - imgDonate.Repaint; + ToolBarDonate.Visible := HasDonated(True) <> nbTrue; // Call user statistics if checked in settings if AppSettings.ReadBool(asDoUsageStatistics) then begin - try - LastStatsCall := StrToDateTime(AppSettings.ReadString(asLastUsageStatisticCall)); - except - LastStatsCall := StrToDateTime(DefaultLastrunDate); - end; + LastStatsCall := StrToDateTimeDef(AppSettings.ReadString(asLastUsageStatisticCall), DateTimeNever); if DaysBetween(Now, LastStatsCall) >= 30 then begin // Report used app version, bits, and theme name (so we find mostly unused ones for removal) // Also report environment: WinDesktop, WinUWP or Wine - if RunningAsUwp then Environment := 'WinUWP' - else if IsWine then Environment := 'Wine' + if IsWine then Environment := 'Wine' else if AppSettings.PortableMode then Environment := 'WinDesktopPortable' else Environment := 'WinDesktop'; @@ -2175,11 +2290,7 @@ procedure TMainForm.AfterFormCreate; // Enumerate actively used server versions for i:=0 to SessionPaths.Count-1 do begin AppSettings.SessionPath := SessionPaths[i]; - try - LastConnect := StrToDateTime(AppSettings.ReadString(asLastConnect)); - except - LastConnect := StrToDateTime(DefaultLastrunDate); - end; + LastConnect := StrToDateTimeDef(AppSettings.ReadString(asLastConnect), DateTimeNever); if LastConnect > LastStatsCall then begin StatsCall.URL := StatsCall.URL + '&s[]=' + IntToStr(AppSettings.ReadInt(asNetType)) + '-' + IntToStr(AppSettings.ReadInt(asServerVersion)); end; @@ -2196,10 +2307,24 @@ procedure TMainForm.AfterFormCreate; end; ConnectionParams := nil; - ParseCommandLine(Windows.GetCommandLine, ConnectionParams, FileNames); + RunFrom := ''; + ParseCommandLine(GetCommandLine, ConnectionParams, FileNames, RunFrom); + + // Delete scheduled task from previous + if RunFrom = 'scheduler' then begin + DeleteRestartTask; + if HasDonated(False) <> nbTrue then begin + apphelpers.ShellExec(APPDOMAIN + 'after-updatecheck?rev=' + AppVerRevision.ToString); + end; + end; + if ConnectionParams <> nil then begin // Minimal parameter for command line mode is hostname - InitConnection(ConnectionParams, True, Connection); + try + InitConnection(ConnectionParams, True, Connection); + except on E:Exception do + ErrorDialog(E.Message); + end; end else if AppSettings.ReadBool(asAutoReconnect) then begin // Auto connection via preference setting // Do not autoconnect if we're in commandline mode and the connection was not successful @@ -2226,11 +2351,11 @@ procedure TMainForm.AfterFormCreate; // Display session manager if Connections.Count = 0 then begin // Cannot be done in OnCreate because we need ready forms here: - SessionManager := TConnForm.Create(Self); + connform := TConnForm.Create(Self); DlgResult := mrCancel; try - DlgResult := SessionManager.ShowModal; - SessionManager.Free; + DlgResult := connform.ShowModal; + FreeAndNil(connform); except // Work around VCL bug: Suppress access violation in TCustomForm.IsFormSizeStored // when closing dialog via Alt+F4 @@ -2247,14 +2372,9 @@ procedure TMainForm.AfterFormCreate; end; // Load SQL file(s) by command line - if not RunQueryFiles(FileNames, nil, false) then begin - for i:=0 to FileNames.Count-1 do begin - Tab := GetOrCreateEmptyQueryTab; - Tab.LoadContents(FileNames[i], True, nil); - if i = FileNames.Count-1 then - SetMainTab(Tab.TabSheet); - end; - end; + OpenQueryFiles(FileNames, nil, False); + + MainFormAfterCreateDone := True; end; @@ -2266,10 +2386,7 @@ function TMainForm.InitTabsIniFile: TIniFile; begin // Try to open tabs.ini for writing or reading // Taking multiple application instances into account - if AppSettings.PortableMode then - TabsIniFilename := ExtractFilePath(Application.ExeName) + 'tabs.ini' - else - TabsIniFilename := AppSettings.DirnameUserAppData + 'tabs.ini'; + TabsIniFilename := AppSettings.DirnameUserAppData + 'tabs.ini'; WaitingSince := GetTickCount64; Attempts := 0; while not FileIsWritable(TabsIniFilename) do begin @@ -2283,7 +2400,7 @@ function TMainForm.InitTabsIniFile: TIniFile; end; // Catch errors when file cannot be created if not FileExists(TabsIniFilename) then begin - SaveUnicodeFile(TabsIniFilename, ''); + SaveUnicodeFile(TabsIniFilename, '', UTF8NoBOMEncoding); end; Result := TIniFile.Create(TabsIniFilename); end; @@ -2292,10 +2409,11 @@ function TMainForm.InitTabsIniFile: TIniFile; procedure TMainForm.StoreTabs; var Tab: TQueryTab; - Section: String; + Section, TabCaption: String; Sections: TStringList; TabsIni: TIniFile; SectionTabExists: Boolean; + pid: Cardinal; begin // Store query tab unsaved contents and setup, in tabs.ini @@ -2306,28 +2424,39 @@ procedure TMainForm.StoreTabs; Tab.BackupUnsavedContent; Section := Tab.Uid; - if Tab.Memo.GetTextLen > 0 then begin - // Avoid writing the tabs.ini file if nothing was effectively changed - if TabsIni.ReadString(Section, 'BackupFilename', '') <> Tab.MemoBackupFilename then - TabsIni.WriteString(Section, 'BackupFilename', Tab.MemoBackupFilename); - if TabsIni.ReadString(Section, 'Filename', '') <> Tab.MemoFilename then - TabsIni.WriteString(Section, 'Filename', Tab.MemoFilename); - if TabsIni.ReadInteger(Section, 'pid', 0) <> Integer(GetCurrentProcessId) then - TabsIni.WriteInteger(Section, 'pid', Integer(GetCurrentProcessId)); - if TabsIni.ReadInteger(Section, 'EditorHeight', 0) <> Tab.pnlMemo.Height then - TabsIni.WriteInteger(Section, 'EditorHeight', Tab.pnlMemo.Height); - if TabsIni.ReadInteger(Section, 'HelpersWidth', 0) <> Tab.pnlHelpers.Width then - TabsIni.WriteInteger(Section, 'HelpersWidth', Tab.pnlHelpers.Width); - if TabsIni.ReadString(Section, 'BindParams', '') <> Tab.ListBindParams.AsText then - TabsIni.WriteString(Section, 'BindParams', Tab.ListBindParams.AsText); - end; - end; - - // Tabs with deleted files don't get restored anyway. But closed tabs with physically existing - // files still need to be erased + // Avoid writing the tabs.ini file if nothing was effectively changed + TabCaption := Tab.TabSheet.Caption; + TabCaption := TabCaption.Trim([' ','*']); + if ExecRegExpr('^'+QuoteRegExprMetaChars(_('Query')+' #')+'\d+$', TabCaption) then + TabCaption := ''; + if TabsIni.ReadString(Section, TQueryTab.IdentBackupFilename, '') <> Tab.MemoBackupFilename then + TabsIni.WriteString(Section, TQueryTab.IdentBackupFilename, Tab.MemoBackupFilename); + if TabsIni.ReadString(Section, TQueryTab.IdentFilename, '') <> Tab.MemoFilename then + TabsIni.WriteString(Section, TQueryTab.IdentFilename, Tab.MemoFilename); + if TabsIni.ReadString(Section, TQueryTab.IdentCaption, '') <> TabCaption then + TabsIni.WriteString(Section, TQueryTab.IdentCaption, TabCaption); + if TabsIni.ReadInteger(Section, TQueryTab.IdentPid, 0) <> Integer(GetCurrentProcessId) then + TabsIni.WriteInteger(Section, TQueryTab.IdentPid, Integer(GetCurrentProcessId)); + if TabsIni.ReadInteger(Section, TQueryTab.IdentEditorHeight, 0) <> Tab.pnlMemo.Height then + TabsIni.WriteInteger(Section, TQueryTab.IdentEditorHeight, Tab.pnlMemo.Height); + if TabsIni.ReadInteger(Section, TQueryTab.IdentHelpersWidth, 0) <> Tab.pnlHelpers.Width then + TabsIni.WriteInteger(Section, TQueryTab.IdentHelpersWidth, Tab.pnlHelpers.Width); + if TabsIni.ReadString(Section, TQueryTab.IdentBindParams, '') <> Tab.ListBindParams.AsText then + TabsIni.WriteString(Section, TQueryTab.IdentBindParams, Tab.ListBindParams.AsText); + if TabsIni.ReadInteger(Section, TQueryTab.IdentEditorTopLine, 1) <> Tab.Memo.TopLine then + TabsIni.WriteInteger(Section, TQueryTab.IdentEditorTopLine, Tab.Memo.TopLine); + if TabsIni.ReadBool(Section, TQueryTab.IdentTabFocused, False) <> (Tab.TabSheet = Tab.TabSheet.PageControl.ActivePage) then + TabsIni.WriteBool(Section, TQueryTab.IdentTabFocused, (Tab.TabSheet = Tab.TabSheet.PageControl.ActivePage)); + if TabsIni.ReadString(Section, TQueryTab.IdentFileEncoding, 'UTF-8') <> Tab.FileEncoding then + TabsIni.WriteString(Section, TQueryTab.IdentFileEncoding, Tab.FileEncoding); + end; + + // Tabs with deleted backup files don't get restored anyway. But a section from a closed user loaded tab + // still needs to be erased. Otherwise it's loaded on next app start again. Sections := TStringList.Create; TabsIni.ReadSections(Sections); for Section in Sections do begin + // Loop through local tabs SectionTabExists := False; for Tab in QueryTabs do begin if Tab.Uid = Section then begin @@ -2335,8 +2464,9 @@ procedure TMainForm.StoreTabs; Break; end; end; - // Delete tab section if no tab was closed - if not SectionTabExists then begin + // Delete tab section if tab was closed and section belongs to this app instance + pid := Cardinal(TabsIni.ReadInteger(Section, TQueryTab.IdentPid, 0)); + if (not SectionTabExists) and (pid = GetCurrentProcessId) then begin TabsIni.EraseSection(Section); end; end; @@ -2349,7 +2479,7 @@ procedure TMainForm.StoreTabs; ErrorDialog(_('Storing tab setup failed'), 'Tabs won''t be stored in this session.' + CRLF + CRLF + E.Message + CRLF + CRLF + - SysErrorMessage(Windows.GetLastError) + SysErrorMessage(GetLastError) ); end; end; @@ -2359,12 +2489,25 @@ procedure TMainForm.StoreTabs; function TMainForm.RestoreTabs: Boolean; var Tab: TQueryTab; - Sections: TStringList; - Section, Filename, BackupFilename: String; + Sections, SlowTabs: TStringList; + Section, Filename, BackupFilename, TabCaption: String; TabsIni: TIniFile; pid: Cardinal; - EditorHeight, HelpersWidth: Integer; + EditorHeight, HelpersWidth, EditorTopLine: Integer; BindParams: String; + TabFocused: Boolean; + TabLoadStart, TabLoadTime: UInt64; + Encoding: TEncoding; +const + SlowLoadMilliseconds = 5000; + + procedure CheckSlowTabLoad(CurTab: TQueryTab); + begin + TabLoadTime := GetTickCount64 - TabLoadStart; + if TabLoadTime > SlowLoadMilliseconds then begin + SlowTabs.Add('• ' + Trim(Tab.TabSheet.Caption) + ' (' + FormatTimeNumber(TabLoadTime / 1000, True) + ')'); + end; + end; begin // Restore query tab setup from tabs.ini Result := True; @@ -2375,51 +2518,73 @@ function TMainForm.RestoreTabs: Boolean; Sections := TStringList.Create; TabsIni.ReadSections(Sections); + SlowTabs := TStringList.Create; for Section in Sections do begin - - Filename := TabsIni.ReadString(Section, 'Filename', ''); - BackupFilename := TabsIni.ReadString(Section, 'BackupFilename', ''); - pid := Cardinal(TabsIni.ReadInteger(Section, 'pid', 0)); - EditorHeight := TabsIni.ReadInteger(Section, 'EditorHeight', 0); - HelpersWidth := TabsIni.ReadInteger(Section, 'HelpersWidth', 0); - BindParams := TabsIni.ReadString(Section, 'BindParams', ''); - - // Don't restore this tab if it belongs to a different running process - if (pid > 0) and (pid <> GetCurrentProcessId) and ProcessExists(pid) then + TabLoadStart := GetTickCount64; + + Filename := TabsIni.ReadString(Section, TQueryTab.IdentFilename, ''); + BackupFilename := TabsIni.ReadString(Section, TQueryTab.IdentBackupFilename, ''); + TabCaption := TabsIni.ReadString(Section, TQueryTab.IdentCaption, ''); + pid := Cardinal(TabsIni.ReadInteger(Section, TQueryTab.IdentPid, 0)); + EditorHeight := TabsIni.ReadInteger(Section, TQueryTab.IdentEditorHeight, 0); + HelpersWidth := TabsIni.ReadInteger(Section, TQueryTab.IdentHelpersWidth, 0); + BindParams := TabsIni.ReadString(Section, TQueryTab.IdentBindParams, ''); + EditorTopLine := TabsIni.ReadInteger(Section, TQueryTab.IdentEditorTopLine, 1); + TabFocused := TabsIni.ReadBool(Section, TQueryTab.IdentTabFocused, False); + Encoding := GetEncodingByName(TabsIni.ReadString(Section, TQueryTab.IdentFileEncoding, 'UTF-8')); + + // Don't restore this tab if it belongs to a different running Heidi process + if (pid > 0) and (pid <> GetCurrentProcessId) and ProcessExists(pid, APPNAME) then begin + LogSQL(IfThen(BackupFilename.IsEmpty, Filename, BackupFilename)+' loaded in process #'+pid.ToString); Continue; + end; // Either we have a backup file, or a user stored file. // Both of them may not exist. if not BackupFilename.IsEmpty then begin if FileExists(BackupFilename) then begin - Tab := GetOrCreateEmptyQueryTab; + Tab := GetOrCreateEmptyQueryTab(False); Tab.Uid := Section; - Tab.LoadContents(BackupFilename, True, UTF8NoBOMEncoding); + Tab.LoadContents(BackupFilename, True, Encoding); Tab.MemoFilename := Filename; Tab.Memo.Modified := True; + if not TabCaption.IsEmpty then + SetTabCaption(Tab.TabSheet.PageIndex, TabCaption); if EditorHeight > 50 then Tab.pnlMemo.Height := EditorHeight; - if HelpersWidth > 50 then - Tab.pnlHelpers.Width := HelpersWidth; + // Causes sporadic long-waiters: + //if HelpersWidth > 50 then + // Tab.pnlHelpers.Width := HelpersWidth; Tab.ListBindParams.AsText := BindParams; Tab.BindParamsActivated := Tab.ListBindParams.Count > 0; + Tab.Memo.TopLine := EditorTopLine; + if TabFocused then + SetMainTab(Tab.TabSheet); + CheckSlowTabLoad(Tab); end else begin // Remove tab section if backup file is gone or inaccessible for some reason TabsIni.EraseSection(Section); end; end else if not Filename.IsEmpty then begin if FileExists(Filename) then begin - Tab := GetOrCreateEmptyQueryTab; + Tab := GetOrCreateEmptyQueryTab(False); Tab.Uid := Section; - Tab.LoadContents(Filename, True, nil); + Tab.LoadContents(Filename, True, Encoding); Tab.MemoFilename := Filename; + if not TabCaption.IsEmpty then + SetTabCaption(Tab.TabSheet.PageIndex, TabCaption); if EditorHeight > 50 then - Tab.Memo.Height := EditorHeight; - if HelpersWidth > 50 then - Tab.pnlHelpers.Width := HelpersWidth; + Tab.pnlMemo.Height := EditorHeight; + // Causes sporadic long-waiters: + //if HelpersWidth > 50 then + // Tab.pnlHelpers.Width := HelpersWidth; Tab.ListBindParams.AsText := BindParams; Tab.BindParamsActivated := Tab.ListBindParams.Count > 0; + Tab.Memo.TopLine := EditorTopLine; + if TabFocused then + SetMainTab(Tab.TabSheet); + CheckSlowTabLoad(Tab); end else begin // Remove tab section if user stored file was deleted by user TabsIni.EraseSection(Section); @@ -2431,19 +2596,43 @@ function TMainForm.RestoreTabs: Boolean; Sections.Free; // Close file TabsIni.Free; + + // Warn user about tabs which were loading slow + if SlowTabs.Count > 0 then begin + MessageDialog( + f_('%d tab(s) took longer than expected to restore. Closing and reopening these should fix that: %s', + [SlowTabs.Count, sLineBreak + sLineBreak + SlowTabs.Text]), + mtWarning, [mbOk]); + end; + SlowTabs.Free; + except on E:Exception do begin Result := False; ErrorDialog(_('Restoring tab setup failed'), 'Tabs won''t be stored in this session.' + CRLF + CRLF + E.Message + CRLF + CRLF + - SysErrorMessage(Windows.GetLastError) + SysErrorMessage(GetLastError) ); end; end; end; +procedure TMainForm.SetHintFontByControl(Control: TWinControl=nil); +var + UseFontName: String; +begin + // Set hint font name to match the underlying control + if Assigned(Control) and (Control is TSynMemo) then + UseFontName := TSynMemo(Control).Font.Name + else + UseFontName := FDefaultHintFontName; + if Screen.HintFont.Name <> UseFontName then + Screen.HintFont.Name := UseFontName; +end; + + procedure TMainForm.TimerStoreTabsTimer(Sender: TObject); begin // Backup unsaved content every 10 seconds @@ -2452,11 +2641,10 @@ procedure TMainForm.TimerStoreTabsTimer(Sender: TObject); procedure TMainForm.actSessionManagerExecute(Sender: TObject); -var - Dialog: TConnForm; begin - Dialog := TConnForm.Create(Self); - Dialog.ShowModal; + connform := TConnForm.Create(Self); + connform.ShowModal; + FreeAndNil(connform); end; @@ -2465,7 +2653,6 @@ procedure TMainForm.actDisconnectExecute(Sender: TObject); Connection: TDBConnection; Node: PVirtualNode; DlgResult: Integer; - Dialog: TConnForm; begin // Disconnect active connection. If it's the last, exit application Connection := ActiveConnection; @@ -2476,8 +2663,9 @@ procedure TMainForm.actDisconnectExecute(Sender: TObject); // TODO: focus last session? SelectNode(DBtree, GetNextNode(DBtree, nil)); if FConnections.Count = 0 then begin - Dialog := TConnForm.Create(Self); - DlgResult := Dialog.ShowModal; + connform := TConnForm.Create(Self); + DlgResult := connform.ShowModal; + FreeAndNil(connform); if DlgResult = mrCancel then actExitApplication.Execute; end; @@ -2490,8 +2678,9 @@ procedure TMainForm.ConnectionsNotify(Sender: TObject; const Item: TDBConnection Tab: TQueryTab; ResultTab: TResultTab; i: Integer; - Keys: TStringList; + Keys, NamesInKey: TStringList; rx: TRegExpr; + ForceDeleteTableKey: Boolean; begin // Connection removed or added case Action of @@ -2526,24 +2715,26 @@ procedure TMainForm.ConnectionsNotify(Sender: TObject; const Item: TDBConnection end; end; - // Remove filters if unwanted - if not AppSettings.ReadBool(asReuseEditorConfiguration) then begin - AppSettings.SessionPath := Item.Parameters.SessionPath; - Keys := AppSettings.GetKeyNames; - rx := TRegExpr.Create; - rx.Expression := '.+'+QuoteRegExprMetaChars(DELIM)+'.+'; - for i:=0 to Keys.Count-1 do begin - if rx.Exec(Keys[i]) then begin - AppSettings.SessionPath := Item.Parameters.SessionPath + '\' + Keys[i]; + // Remove table keys if unwanted or empty + ForceDeleteTableKey := not AppSettings.ReadBool(asReuseEditorConfiguration); + AppSettings.SessionPath := Item.Parameters.SessionPath; + Keys := AppSettings.GetKeyNames; + rx := TRegExpr.Create; + rx.Expression := '.+'+QuoteRegExprMetaChars(DELIM)+'.+'; + for i:=0 to Keys.Count-1 do begin + if rx.Exec(Keys[i]) then begin + AppSettings.SessionPath := Item.Parameters.SessionPath + '\' + Keys[i]; + NamesInKey := AppSettings.GetValueNames; + if (NamesInKey.Count = 0) or ForceDeleteTableKey then begin AppSettings.DeleteCurrentKey; end; end; - rx.Free; end; + rx.Free; FreeAndNil(ActiveObjectEditor); - RefreshHelperNode(HELPERNODE_PROFILE); - RefreshHelperNode(HELPERNODE_COLUMNS); + RefreshHelperNode(TQueryTab.HelperNodeProfile); + RefreshHelperNode(TQueryTab.HelperNodeColumns); // Last chance to access connection related properties before disconnecting @@ -2573,18 +2764,20 @@ procedure TMainForm.actImportCSVExecute(Sender: TObject); // Import Textfile Dialog := Tloaddataform.Create(Self); Dialog.ShowModal; + Dialog.Free; end; procedure TMainForm.actPreferencesExecute(Sender: TObject); begin // Preferences - FPreferencesDialog := Toptionsform.Create(Self); + frmPreferences := TfrmPreferences.Create(Self); if Sender = actPreferencesLogging then - FPreferencesDialog.pagecontrolMain.ActivePage := FPreferencesDialog.tabLogging + frmPreferences.pagecontrolMain.ActivePage := frmPreferences.tabLogging else if Sender = actPreferencesData then - FPreferencesDialog.pagecontrolMain.ActivePage := FPreferencesDialog.tabGridFormatting; - FPreferencesDialog.ShowModal; - FreeAndNil(FPreferencesDialog); + frmPreferences.pagecontrolMain.ActivePage := frmPreferences.tabGridFormatting; + frmPreferences.ShowModal; + frmPreferences.Free; + frmPreferences := nil; // Important in SetupSynEditors end; procedure TMainForm.actHelpExecute(Sender: TObject); @@ -2596,18 +2789,14 @@ procedure TMainForm.actHelpExecute(Sender: TObject); procedure TMainForm.FormResize(Sender: TObject); var PanelRect: TRect; - Tab: TQueryTab; w0, w1, w2, w3, w4, w5, w6: Integer; - function GridNeedHeight: Integer; - begin - // Return missing number of height pixels the query grid needs - Result := Max(0, Tab.spltQuery.MinSize - (Tab.TabSheet.Height - Tab.pnlMemo.Height - Tab.spltQuery.Height - Tab.tabsetQuery.Height)); - end; - - function CalcPanelWidth(PreferredWidth, Percentage: Integer): Integer; + function CalcPanelWidth(SampleText: String; MaxPercentage: Integer): Integer; + var + MaxPixels: Integer; begin - Result := Round(Min(PreferredWidth, Width / 100 * Percentage)); + MaxPixels := StatusBar.Canvas.TextWidth(SampleText) + VirtualImageListMain.Width + 30; + Result := Round(Min(MaxPixels, Width / 100 * MaxPercentage)); end; begin // Exit early when user pressed "Cancel" on connection dialog @@ -2618,13 +2807,14 @@ procedure TMainForm.FormResize(Sender: TObject); Exit; // Super intelligent calculation of status bar panel width - w1 := CalcPanelWidth(110, 10); - w2 := CalcPanelWidth(140, 10); - w3 := CalcPanelWidth(170, 15); - w4 := CalcPanelWidth(150, 15); - w5 := CalcPanelWidth(140, 10); - w6 := CalcPanelWidth(250, 20); + w1 := CalcPanelWidth('r10 : c10 (10 KiB)', 12); + w2 := CalcPanelWidth('Connected: 1 day, 00:00 h', 12); + w3 := CalcPanelWidth('MariaDB or MySQL 5.7.6', 12); + w4 := CalcPanelWidth('Uptime: 13 days, 00:00 h', 12); + w5 := CalcPanelWidth('Server time: 20:00 PM', 12); + w6 := CalcPanelWidth('DummyDummyDummyDummyDummy', 20); w0 := StatusBar.Width - w1 - w2 - w3 - w4 - w5 - w6; + //logsql(format('IconWidth:%d 0:%d 1:%d 2:%d 3:%d 4:%d 5:%d 6:%d', [VirtualImageListMain.Width, w0, w1, w2, w3, w4, w5, w6])); StatusBar.Panels[0].Width := w0; StatusBar.Panels[1].Width := w1; StatusBar.Panels[2].Width := w2; @@ -2634,32 +2824,52 @@ procedure TMainForm.FormResize(Sender: TObject); StatusBar.Panels[6].Width := w6; // Retreive the rectancle of the statuspanel (in our case the fifth panel) - SendMessage(StatusBar.Handle, SB_GETRECT, 5, Integer(@PanelRect)); - // Position the progressbar over the panel on the statusbar - with PanelRect do - ProgressBarStatus.SetBounds(Left, Top, Right-Left, Bottom-Top); + if not IsWine then begin + SendMessage(StatusBar.Handle, SB_GETRECT, 5, Integer(@PanelRect)); + // Position the progressbar over the panel on the statusbar + ProgressBarStatus.SetBounds( + PanelRect.Left, + PanelRect.Top, + PanelRect.Right-PanelRect.Left, + PanelRect.Bottom-PanelRect.Top + ); + end; + lblDataTop.Width := pnlDataTop.Width - tlbDataButtons.Width - 10; FixQueryTabCloseButtons; - // Ensure query grids are not overlapped by sql log - for Tab in QueryTabs do begin - // Decrease height of pnlMemo if grid has not enough height - Tab.pnlMemo.Height := Max(Tab.pnlMemo.Height-GridNeedHeight, Tab.spltQuery.MinSize); - // Try again and resize SQLLog if required - SynMemoSQLLog.Height := Max(SynMemoSQLLog.Height-GridNeedHeight, spltTopBottom.MinSize); - end; - // Right aligned button - if imgDonate.Visible then begin - imgDonate.Width := 122; - imgDonate.Height := 22; - imgDonate.Left := ControlBarMain.Width - imgDonate.Width; + // Do not set ToolBar.Align to alRight. See issue #1967 + if ToolBarDonate.Visible then begin + //ToolBarDonate.Width := ToolBarDonate.Buttons[0].Width; + ToolBarDonate.Left := ControlBarMain.Width - ToolBarDonate.Width; + //ToolBarDonate.Buttons[0].Height := ToolBarMainButtons.Buttons[0].Height; end; end; procedure TMainForm.FormShow(Sender: TObject); begin + // Window dimensions + if WindowState <> wsMaximized then begin + Width := AppSettings.ReadIntDpiAware(asMainWinWidth, Self); + Height := AppSettings.ReadIntDpiAware(asMainWinHeight, Self); + end; + + LogSQL(f_('Scaling controls to screen DPI: %d%%', [Round(ScaleFactor*100)])); + if TStyleManager.IsCustomStyleActive and (ScaleFactor<>1) then begin + LogSQL(f_('Caution: Style "%s" selected and non-default DPI factor - be aware that some styles appear broken with high DPI settings!', [TStyleManager.ActiveStyle.Name])); + end; + + + // Restore width of columns of all VirtualTrees + RestoreListSetup(ListDatabases); + RestoreListSetup(ListVariables); + RestoreListSetup(ListStatus); + RestoreListSetup(ListProcesses); + RestoreListSetup(ListCommandStats); + RestoreListSetup(ListTables); + // Manually set focus to tree - otherwise the database filter as the first // control catches focus on startup, which is ugly. if DBtree.CanFocus then @@ -2671,7 +2881,28 @@ procedure TMainForm.FormShow(Sender: TObject); // Simulated link label, has non inherited blue font color lblExplainProcess.Font.Color := clBlue; - lblExplainProcessAnalyzer.Font.Color := clBlue; + + // Call once after all query tabs were created: + ValidateControls(Sender); +end; + +procedure TMainForm.AddEditorCommandMenu(const S: string); +begin + FEditorCommandStrings.Add(S); +end; + +procedure TMainForm.EditorCommandOnClick(Sender: TObject); +var + EditorCommand: TSynEditorCommand; + Editor: TSynMemo; +begin + EditorCommand := IndexToEditorCommand(TMenuItem(Sender).MenuIndex); + Editor := ActiveSynMemo(False); + if Assigned(Editor) then begin + Editor.BeginUndoBlock; + Editor.ExecuteCommand(EditorCommand, #0, nil); + Editor.EndUndoBlock; + end; end; procedure TMainForm.actUserManagerExecute(Sender: TObject); @@ -2680,6 +2911,7 @@ procedure TMainForm.actUserManagerExecute(Sender: TObject); begin Dialog := TUserManagerForm.Create(Self); Dialog.ShowModal; + Dialog.Free; end; procedure TMainForm.actAboutBoxExecute(Sender: TObject); @@ -2697,7 +2929,7 @@ procedure TMainForm.actClearEditorExecute(Sender: TObject); m: TSynMemo; begin if Sender = actClearQueryEditor then begin - m := ActiveQueryMemo + m := QueryTabs.ActiveMemo end else if Sender = actClearQueryLog then begin m := SynMemoSQLLog; m.Gutter.LineNumberStart := m.Gutter.LineNumberStart + m.Lines.Count; @@ -2710,9 +2942,9 @@ procedure TMainForm.actClearEditorExecute(Sender: TObject); m.SelStart := 0; m.SelEnd := 0; if Sender = actClearQueryEditor then begin - ActiveQueryTab.MemoFilename := ''; - ActiveQueryTab.Memo.Modified := False; - ActiveQueryTab.Uid := ''; + QueryTabs.ActiveTab.MemoFilename := ''; + QueryTabs.ActiveTab.Memo.Modified := False; + QueryTabs.ActiveTab.Uid := ''; end; if m = SynMemoFilter then begin InvalidateVT(DataGrid, VTREE_NOTLOADED_PURGECACHE, False); @@ -2728,42 +2960,43 @@ procedure TMainForm.menuClearDataTabFilterClick(Sender: TObject); AppSettings.DeleteValue(asFilter); LogSQL(f_('Data filter for %s deleted', [ActiveDbObj.Name]), lcInfo); end; + if AppSettings.ValueExists(asSort) then begin + AppSettings.DeleteValue(asSort); + LogSQL(f_('Sort order for %s deleted', [ActiveDbObj.Name]), lcInfo); + end; end; procedure TMainForm.actTableToolsExecute(Sender: TObject); var - Act: TAction; - InDBTree: Boolean; Node: PVirtualNode; DBObj: PDBObject; - Dialog: TfrmTableTools; begin // Show table tools dialog - Dialog := TfrmTableTools.Create(Self); - Act := Sender as TAction; - Dialog.PreSelectObjects.Clear; - InDBTree := (Act.ActionComponent is TMenuItem) - and (TPopupMenu((Act.ActionComponent as TMenuItem).GetParentMenu).PopupComponent = DBTree); - if InDBTree then - Dialog.PreSelectObjects.Add(ActiveDbObj) + FTableToolsDialog := TfrmTableTools.Create(Self); + FTableToolsDialog.PreSelectObjects.Clear; + if DBTreeClicked(Sender) then + FTableToolsDialog.PreSelectObjects.Add(ActiveDbObj) else begin Node := GetNextNode(ListTables, nil, True); while Assigned(Node) do begin DBObj := ListTables.GetNodeData(Node); - Dialog.PreSelectObjects.Add(DBObj^); + FTableToolsDialog.PreSelectObjects.Add(DBObj^); Node := GetNextNode(ListTables, Node, True); end; end; if Sender = actMaintenance then - Dialog.ToolMode := tmMaintenance + FTableToolsDialog.ToolMode := tmMaintenance else if Sender = actFindTextOnServer then - Dialog.ToolMode := tmFind + FTableToolsDialog.ToolMode := tmFind else if Sender = actExportTables then - Dialog.ToolMode := tmSQLExport + FTableToolsDialog.ToolMode := tmSQLExport else if Sender = actBulkTableEdit then - Dialog.ToolMode := tmBulkTableEdit; - Dialog.ShowModal; + FTableToolsDialog.ToolMode := tmBulkTableEdit + else if Sender = actGenerateData then + FTableToolsDialog.ToolMode := tmGenerateData; + FTableToolsDialog.ShowModal; + FreeAndNil(FTableToolsDialog); end; @@ -2799,12 +3032,15 @@ procedure TMainForm.actUnixTimestampColumnExecute(Sender: TObject); function TMainForm.HandleUnixTimestampColumn(Sender: TBaseVirtualTree; Column: TColumnIndex): Boolean; +var + ResultCol: Integer; begin // Shorthand for various places where we would normally have to add all these conditions + ResultCol := Column - 1; Result := (Sender = DataGrid) - and (Column > NoColumn) + and (ResultCol > NoColumn) and (DataGridResult <> nil) - and (DataGridResult.DataType(Column).Category in [dtcInteger, dtcReal]) + and (DataGridResult.DataType(ResultCol).Category in [dtcInteger, dtcReal]) and (SelectedTableTimestampColumns.IndexOf(DataGrid.Header.Columns[Column].Text) > -1); end; @@ -2830,9 +3066,22 @@ procedure TMainForm.actCopyTableExecute(Sender: TObject); // copy table Dialog := TCopyTableForm.Create(Self); Dialog.ShowModal; + Dialog.Free; end; +procedure TMainForm.actCopyTabsToSpacesExecute(Sender: TObject); +begin + // issue #1285: copy text with tabs converted to spaces + actCopyOrCutExecute(Sender); + Clipboard.TryAsText := StringReplace(Clipboard.TryAsText, #9, ' ', [rfReplaceAll]); +end; + +procedure TMainForm.actCopyUpdate(Sender: TObject); +begin + actCopyTabsToSpaces.Enabled := actCopy.Enabled; +end; + procedure TMainForm.menuConnectionsPopup(Sender: TObject); var i: integer; @@ -2860,7 +3109,7 @@ procedure TMainForm.menuConnectionsPopup(Sender: TObject); AppSettings.GetSessionPaths('', SessionPaths); for i:=0 to SessionPaths.Count-1 do begin item := TMenuItem.Create(menuConnections); - item.Caption := SessionPaths[i]; + item.Caption := EscapeHotkeyPrefix(SessionPaths[i]); item.OnClick := SessionConnect; for Connection in Connections do begin if SessionPaths[i] = Connection.Parameters.SessionPath then begin @@ -2887,7 +3136,7 @@ procedure TMainForm.MainMenuFileClick(Sender: TObject); AppSettings.GetSessionPaths('', SessionPaths); for i:=0 to SessionPaths.Count-1 do begin Item := TMenuItem.Create(menuConnectTo); - Item.Caption := SessionPaths[i]; + Item.Caption := EscapeHotkeyPrefix(SessionPaths[i]); Item.OnClick := SessionConnect; for Connection in Connections do begin if SessionPaths[i] = Connection.Parameters.SessionPath then begin @@ -2956,15 +3205,16 @@ procedure TMainForm.actImportSettingsExecute(Sender: TObject); Dialog := TOpenDialog.Create(Self); Dialog.Title := f_('Import %s settings from file ...', [APPNAME]); Dialog.Filter := _('Text files')+' (*.txt)|*.txt|'+_('Registry dump, deprecated')+' (*.reg)|*.reg|'+_('All files')+' (*.*)|*.*'; - ImportSettingsDone := False; if Dialog.Execute then try if LowerCase(ExtractFileExt(Dialog.FileName)) = 'reg' then ShellExec('regedit.exe', '', '"'+Dialog.FileName+'"') - else begin + else AppSettings.ImportSettings(Dialog.FileName); - MessageDialog(f_('Settings successfully restored from %s', [Dialog.FileName]), mtInformation, [mbOK]); + // Refresh in session manager per timer interval + if Assigned(connform) then begin + connform.timerSettingsImport.Enabled := True; end; - ImportSettingsDone := True; + MessageDialog(f_('Settings successfully restored from %s', [Dialog.FileName]), mtInformation, [mbOK]); except on E:Exception do ErrorDialog(E.Message); @@ -2976,18 +3226,25 @@ procedure TMainForm.actImportSettingsExecute(Sender: TObject); function TMainForm.GetCurrentQuery(Tab: TQueryTab): String; var BatchAll: TSQLBatch; - Query: TSQLSentence; + Query, PrevQuery: TSQLSentence; begin // Return SQL query on cursor position Result := ''; - BatchAll := TSQLBatch.Create; + BatchAll := TSQLBatch.Create(ActiveConnection.Parameters.NetTypeGroup); BatchAll.SQL := Tab.Memo.Text; + PrevQuery := nil; for Query in BatchAll do begin if (Tab.Memo.SelStart >= Query.LeftOffset-1) and (Tab.Memo.SelStart < Query.RightOffset) then begin Result := Query.SQL; Tab.LeftOffsetInMemo := Query.LeftOffset; break; end; + PrevQuery := Query; + end; + // Prefer query left to the current one, if current one contains no text + if Trim(Result).IsEmpty and Assigned(PrevQuery) then begin + Result := PrevQuery.SQL; + Tab.LeftOffsetInMemo := PrevQuery.LeftOffset; end; BatchAll.Free; end; @@ -2996,34 +3253,42 @@ function TMainForm.GetCurrentQuery(Tab: TQueryTab): String; procedure TMainForm.actExecuteQueryExecute(Sender: TObject); var ProfileNode: PVirtualNode; + Conn: TDBConnection; Batch: TSQLBatch; Tab: TQueryTab; BindParam: Integer; - NewSQL, msg, Command, SQLNoComments: String; + NewSQL, msg, Command, SQLNoComments, CurrentQuery: String; Query: TSQLSentence; rx: TRegExpr; ContainsUnsafeQueries, DoExecute: Boolean; begin - Screen.Cursor := crHourGlass; - Tab := ActiveQueryTab; + Tab := QueryTabs.ActiveTab; + Conn := ActiveConnection; OperationRunning(True); + DoExecute := True; ShowStatusMsg(_('Splitting SQL queries ...')); - Batch := TSQLBatch.Create; + Batch := TSQLBatch.Create(Conn.Parameters.NetTypeGroup); if Sender = actExecuteSelection then begin Batch.SQL := Tab.Memo.SelText; Tab.LeftOffsetInMemo := Tab.Memo.SelStart; end else if Sender = actExecuteCurrentQuery then begin Batch.SQL := GetCurrentQuery(Tab); end else if Sender = actExplainCurrentQuery then begin - Batch.SQL := 'EXPLAIN ' + GetCurrentQuery(Tab); + CurrentQuery := GetCurrentQuery(Tab); + if CurrentQuery.Trim.IsEmpty then begin + ErrorDialog(_('Current query is empty'), _('Please move the cursor inside the query you want to use.')); + DoExecute := False; + end else begin + Batch.SQL := Conn.SqlProvider.GetSql(qExplain, [CurrentQuery]); + end; end else begin Batch.SQL := Tab.Memo.Text; Tab.LeftOffsetInMemo := 0; end; // Check if there is bind parameters - if tab.ListBindParams.Count > 0 then begin + if (tab.ListBindParams.Count > 0) and DoExecute then begin NewSQL := Batch.SQL; // Replace all parameters by their values // by descending to avoid having problems with similar variables name (eg test & test1) @@ -3040,8 +3305,7 @@ procedure TMainForm.actExecuteQueryExecute(Sender: TObject); Batch.SQL := NewSQL; end; - DoExecute := True; - if AppSettings.ReadBool(asWarnUnsafeUpdates) then begin + if AppSettings.ReadBool(asWarnUnsafeUpdates) and DoExecute then begin ShowStatusMsg(_('Checking queries for unsafe UPDATEs/DELETEs ...')); rx := TRegExpr.Create; rx.ModifierI := True; @@ -3057,7 +3321,6 @@ procedure TMainForm.actExecuteQueryExecute(Sender: TObject); end; rx.Free; if ContainsUnsafeQueries then begin - Screen.Cursor := crDefault; msg := _('Your query contains UPDATEs and/or DELETEs without a WHERE clause. Please confirm that you know what you''re doing.'); DoExecute := MessageDialog(_('Run unsafe queries without a WHERE clause?'), msg, mtConfirmation, [mbYes, mbNo], asWarnUnsafeUpdates) = mrYes; end; @@ -3070,10 +3333,10 @@ procedure TMainForm.actExecuteQueryExecute(Sender: TObject); Tab.ResultTabs.Clear; Tab.tabsetQuery.Tabs.Clear; FreeAndNil(Tab.QueryProfile); - ProfileNode := FindNode(Tab.treeHelpers, HELPERNODE_PROFILE, nil); + ProfileNode := FindNode(Tab.treeHelpers, TQueryTab.HelperNodeProfile, nil); Tab.DoProfile := Assigned(ProfileNode) and (Tab.treeHelpers.CheckState[ProfileNode] in CheckedStates); if Tab.DoProfile then try - ActiveConnection.Query('SET profiling=1'); + Conn.Query('SET profiling=1'); except on E:EDbError do begin ErrorDialog(f_('Query profiling requires %s or later, and the server must not be configured with %s.', ['MySQL 5.0.37', '--disable-profiling']), E.Message); @@ -3083,9 +3346,9 @@ procedure TMainForm.actExecuteQueryExecute(Sender: TObject); // Start the execution thread Screen.Cursor := crAppStart; - ActiveConnection.Ping(True); // Prevents SynEdit paint exceptions if connection was killed outside + Conn.Ping(True); // Prevents SynEdit paint exceptions if connection was killed outside Tab.QueryRunning := True; - Tab.ExecutionThread := TQueryThread.Create(ActiveConnection, Batch, Tab.Number); + Tab.ExecutionThread := TQueryThread.Create(Conn, Batch, Tab.Number); end; ValidateQueryControls(Sender); @@ -3105,42 +3368,71 @@ procedure TMainForm.AfterQueryExecution(Thread: TQueryThread); Tab: TQueryTab; NewTab: TResultTab; col: TVirtualTreeColumn; - TabCaption: String; + TabCaption, TabCaptions, BatchHead: String; + TabCaptionsList: TStringList; + TabsetColor: TColor; Results: TDBQuery; - i: Integer; + i, HeaderPadding, HeaderLineBreaks: Integer; begin // Single query or query packet has finished ShowStatusMsg(_('Setting up result grid(s) ...')); - Tab := GetQueryTabByNumber(Thread.TabNumber); + Tab := QueryTabs.TabByNumber(Thread.TabNumber); + + // Use session color on result tabs + TabsetColor := Thread.Connection.Parameters.SessionColor; + if TabsetColor <> clNone then begin + Tab.tabsetQuery.SelectedColor := TabsetColor; + Tab.tabsetQuery.UnselectedColor := ColorAdjustLuma(TabsetColor, 20, False); + end + else begin + Tab.tabsetQuery.SelectedColor := clWindow; + Tab.tabsetQuery.UnselectedColor := clBtnFace; + end; + // Get tab caption list from comment, similar to a name:xyz in a single query + BatchHead := Copy(Thread.Batch.SQL, 1, SIZE_KB); + TabCaptions := RegExprGetMatch('--\s+names\:\s*([^\r\n]+)', BatchHead, 1, False, True); + TabCaptionsList := Explode(',', TabCaptions); + LogSQL('TabCaptionsList: '+TabCaptionsList.CommaText, lcDebug); // Create result tabs for Results in Thread.Connection.GetLastResults do begin NewTab := TResultTab.Create(Tab); Tab.ResultTabs.Add(NewTab); NewTab.Results := Results; try - TabCaption := NewTab.Results.TableName; - // Add postfix to tab name so tab captions are unique - i := 1; - while Tab.tabsetQuery.Tabs.IndexOf(TabCaption) > -1 do begin - Inc(i); - TabCaption := NewTab.Results.TableName + ' #' + IntToStr(i); + TabCaption := NewTab.Results.ResultName; + if TabCaption.IsEmpty and (TabCaptionsList.Count > NewTab.TabIndex) then + TabCaption := TabCaptionsList[NewTab.TabIndex]; + if TabCaption.IsEmpty then + TabCaption := NewTab.Results.TableName; + except + on E:EDbError do begin + TabCaption := _('Result')+' #'+IntToStr(NewTab.TabIndex+1); end; - except on E:EDbError do - TabCaption := _('Result')+' #'+IntToStr(Tab.ResultTabs.Count); end; - + TabCaption := Trim(TabCaption); TabCaption := TabCaption + ' (' + FormatNumber(Results.RecordCount) + 'r × ' + FormatNumber(Results.ColumnCount) + 'c)'; Tab.tabsetQuery.Tabs.Add(TabCaption); + NewTab.Grid.Name := Format('Tab%dGrid%d', [Tab.Number, NewTab.TabIndex+1]); NewTab.Grid.BeginUpdate; NewTab.Grid.Header.Options := NewTab.Grid.Header.Options + [hoVisible]; NewTab.Grid.Header.Columns.BeginUpdate; NewTab.Grid.Header.Columns.Clear; + HeaderLineBreaks := 0; + HeaderPadding := NewTab.Grid.Header.Height - GetTextHeight(NewTab.Grid.Font); + col := NewTab.Grid.Header.Columns.Add; + col.CaptionAlignment := taRightJustify; + col.Alignment := taRightJustify; + col.Options := col.Options + [coFixed]- [coAllowClick, coAllowFocus, coEditable, coResizable]; + if not AppSettings.ReadBool(asShowRowId) then + col.Options := col.Options - [coVisible]; + col.Text := '#'; for i:=0 to NewTab.Results.ColumnCount-1 do begin col := NewTab.Grid.Header.Columns.Add; col.Text := NewTab.Results.ColumnNames[i]; + col.Hint := _('Source table') + ': ' + IfEmpty(NewTab.Results.TableName(i), '-'); if NewTab.Results.DataType(i).Category in [dtcInteger, dtcReal] then col.Alignment := taRightJustify; if NewTab.Results.ColIsPrimaryKeyPart(i) then @@ -3149,8 +3441,10 @@ procedure TMainForm.AfterQueryExecution(Thread: TQueryThread); col.ImageIndex := ICONINDEX_UNIQUEKEY else if NewTab.Results.ColIsKeyPart(i) then col.ImageIndex := ICONINDEX_INDEXKEY; + HeaderLineBreaks := Max(HeaderLineBreaks, col.text.CountChar(#10)); end; NewTab.Grid.Header.Columns.EndUpdate; + NewTab.Grid.Header.Height := GetTextHeight(NewTab.Grid.Font) * (HeaderLineBreaks+1) + HeaderPadding; NewTab.Grid.RootNodeCount := NewTab.Results.RecordCount; NewTab.Grid.EndUpdate; for i:=0 to NewTab.Grid.Header.Columns.Count-1 do @@ -3158,20 +3452,20 @@ procedure TMainForm.AfterQueryExecution(Thread: TQueryThread); if Tab.tabsetQuery.TabIndex = -1 then Tab.tabsetQuery.TabIndex := 0; end; + Thread.Connection.ShowWarnings; ShowStatusMsg; end; procedure TMainForm.FinishedQueryExecution(Thread: TQueryThread); var - Tab, WarningsTab: TQueryTab; - MetaInfo, ErroneousSQL, RegName, MsgTitle, MsgText: String; + Tab: TQueryTab; + MetaInfo, ErroneousSQL, RegName: String; ProfileAllTime: Extended; ProfileNode: PVirtualNode; History: TQueryHistory; HistoryItem: TQueryHistoryItem; - Warnings: TDBQuery; - HistoryNum, MaxWarnings, RegItemsSize, KeepDays: Integer; + HistoryNum, RegItemsSize, KeepDays: Integer; DoDelete, ValueFound: Boolean; MinDate: TDateTime; @@ -3179,6 +3473,7 @@ procedure TMainForm.FinishedQueryExecution(Thread: TQueryThread); var rx: TRegExpr; SelStart, ErrorPos: Integer; + ErrorCoord: TBufferCoord; begin // Try to set memo cursor to the relevant position if Tab.LeftOffsetInMemo > 0 then @@ -3198,18 +3493,21 @@ procedure TMainForm.FinishedQueryExecution(Thread: TQueryThread); rx.Free; if ErroneousSQL <> '' then begin - // Examine 1kb of memo text at given offset - ErrorPos := Pos(ErroneousSQL, Copy(Tab.Memo.Text, SelStart, SIZE_KB)); - if ErrorPos > 0 then + // Examine 1M of memo text at given offset + ErrorPos := Pos(ErroneousSQL, Copy(Tab.Memo.Text, SelStart, SIZE_MB)); + if ErrorPos > 0 then begin Inc(SelStart, ErrorPos-1); - Tab.Memo.SelLength := 0; - Tab.Memo.SelStart := SelStart; + Tab.Memo.SelLength := 0; + Tab.Memo.SelStart := SelStart; + ErrorCoord := Tab.Memo.CharIndexToRowCol(SelStart); + Tab.ErrorLine := ErrorCoord.Line; + end; end; end; begin // Find right query tab - Tab := GetQueryTabByNumber(Thread.TabNumber); + Tab := QueryTabs.TabByNumber(Thread.TabNumber); // Error handling if not Thread.ErrorMessage.IsEmpty then begin @@ -3248,43 +3546,12 @@ procedure TMainForm.FinishedQueryExecution(Thread: TQueryThread); Tab.MaxProfileTime := Max(Time, Tab.MaxProfileTime); Tab.QueryProfile.Next; end; - ProfileNode := FindNode(Tab.treeHelpers, HELPERNODE_PROFILE, nil); + ProfileNode := FindNode(Tab.treeHelpers, TQueryTab.HelperNodeProfile, nil); Tab.treeHelpers.ReinitNode(ProfileNode, True); Tab.treeHelpers.InvalidateChildren(ProfileNode, True); Thread.Connection.Query('SET profiling=0'); end; - // Show warnings - if Thread.WarningCount > 0 then begin - MsgTitle := f_('Your query produced %s warnings.', [FormatNumber(Thread.WarningCount)]); - MsgText := ''; - Warnings := Thread.Connection.GetResults('SHOW WARNINGS LIMIT 5'); - if Warnings.RecordCount < 5 then - MsgText := MsgText + _('Warnings from last query:')+CRLF - else if Warnings.RecordCount < Thread.WarningCount then - MsgText := MsgText + f_('First %s warnings:', [FormatNumber(Warnings.RecordCount)])+CRLF; - while not Warnings.Eof do begin - MsgText := MsgText + Warnings.Col('Level') + ': ' + Warnings.Col('Message') + CRLF; - Warnings.Next; - end; - MsgText := Trim(MsgText); - if (Warnings.RecordCount = Thread.WarningCount) or (Warnings.RecordCount < 5) then - MessageDialog(MsgTitle, MsgText, mtWarning, [mbOk], asQueryWarningsMessage) - else begin - MsgText := MsgText + CRLF+CRLF + _('Show all warnings in a new query tab?'); - MaxWarnings := MakeInt(Thread.Connection.GetVar('SELECT @@max_error_count')); - if MaxWarnings < Thread.WarningCount then - MsgText := MsgText + CRLF+CRLF+ f_('The server variable %s is currently set to %d, so you won''t see all warnings.', ['@@max_error_count', MaxWarnings]); - if MessageDialog(MsgTitle, MsgText, mtWarning, [mbYes, mbNo], asQueryWarningsMessage) = mrYes then begin - actNewQueryTab.Execute; - WarningsTab := QueryTabs[QueryTabs.Count-1]; - WarningsTab.Memo.Text := 'SHOW WARNINGS'; - actExecuteQueryExecute(WarningsTab); - end; - end; - end; - - // Store successful query packet in history if it's not a batch. // Assume that a bunch of up to 5 queries is not a batch. AppSettings.ResetPath; @@ -3343,7 +3610,7 @@ procedure TMainForm.FinishedQueryExecution(Thread: TQueryThread); LogSQL(f_('Error when updating query history: %s', [E.Message]), lcError); end; - RefreshHelperNode(HELPERNODE_HISTORY); + RefreshHelperNode(TQueryTab.HelperNodeHistory); end; // Clean up @@ -3389,7 +3656,7 @@ procedure TMainForm.tabsetQueryGetImageIndex(Sender: TObject; TabIndex: Integer; begin // Give result tabs of editable results a table icon try - ActiveQueryTab.ResultTabs[TabIndex].Results.TableName; + QueryTabs.ActiveTab.ResultTabs[TabIndex].Results.TableName; ImageIndex := 14; except ImageIndex := -1; @@ -3397,34 +3664,6 @@ procedure TMainForm.tabsetQueryGetImageIndex(Sender: TObject; TabIndex: Integer; end; -procedure TMainForm.menuQueryExplainClick(Sender: TObject); -var - SQL: String; -begin - // Sub menu with EXPLAIN items pops up - SQL := GetCurrentQuery(ActiveQueryTab); - actExplainCurrentQuery.Enabled := ActiveConnection.Parameters.IsAnyMySQL; - actExplainAnalyzeCurrentQuery.Enabled := actExplainCurrentQuery.Enabled; -end; - - -procedure TMainForm.actExplainAnalyzeCurrentQueryExecute(Sender: TObject); -var - Conn: TDBConnection; - SQL: String; -begin - // Send EXPLAIN output to analyzer - Conn := ActiveConnection; - SQL := GetCurrentQuery(ActiveQueryTab); - try - Conn.ExplainAnalyzer(SQL, Conn.Database); - except - on E:EDbError do - ErrorDialog(E.Message); - end; -end; - - procedure TMainForm.actExportDataExecute(Sender: TObject); var ExportDialog: TfrmExportGrid; @@ -3433,6 +3672,7 @@ procedure TMainForm.actExportDataExecute(Sender: TObject); ExportDialog := TfrmExportGrid.Create(Self); ExportDialog.Grid := ActiveGrid; ExportDialog.ShowModal; + ExportDialog.Free; end; @@ -3443,8 +3683,8 @@ procedure TMainForm.actDataPreviewUpdate(Sender: TObject); // Enable or disable ImageView action Grid := ActiveGrid; (Sender as TAction).Enabled := (Grid <> nil) - and (Grid.FocusedColumn <> NoColumn) - and (GridResult(Grid).DataType(Grid.FocusedColumn).Category = dtcBinary) + and (Grid.FocusedColumn > 0) // may be NoColumn/-1 or InvalidColumn/-2 + and (GridResult(Grid).DataType(Grid.FocusedColumn-1).Category = dtcBinary) end; @@ -3470,7 +3710,7 @@ procedure TMainForm.UpdatePreviewPanel; ImgType: String; Content, Header: AnsiString; ContentStream: TMemoryStream; - StrLen: Integer; + StrLen, ResultCol: Integer; Graphic: TGraphic; begin // Load BLOB contents into preview area @@ -3478,6 +3718,9 @@ procedure TMainForm.UpdatePreviewPanel; Results := GridResult(Grid); if not Assigned(Results) then Exit; + ResultCol := Grid.FocusedColumn -1; + if ResultCol < 0 then + Exit; Screen.Cursor := crHourGlass; try ShowStatusMsg(_('Loading contents into image viewer ...')); @@ -3488,8 +3731,8 @@ procedure TMainForm.UpdatePreviewPanel; RowNum := Grid.GetNodeData(Grid.FocusedNode); Results.RecNo := RowNum^; - Content := AnsiString(Results.Col(Grid.FocusedColumn)); - StrLen := Results.ColumnLengths(Grid.FocusedColumn); + Content := AnsiString(Results.Col(ResultCol)); + StrLen := Results.ColumnLengths(ResultCol); ContentStream := TMemoryStream.Create; ContentStream.Write(Content[1], StrLen); ContentStream.Position := 0; @@ -3581,18 +3824,18 @@ procedure TMainForm.actDataSaveBlobToFileExecute(Sender: TObject); Results := GridResult(Grid); Dialog := TSaveDialog.Create(Self); Dialog.Filter := _('All files')+' (*.*)|*.*'; - Dialog.FileName := Results.ColumnOrgNames[Grid.FocusedColumn]; - if not (Results.DataType(Grid.FocusedColumn).Category in [dtcBinary, dtcSpatial]) then + Dialog.FileName := Results.ColumnOrgNames[Grid.FocusedColumn-1]; + if not (Results.DataType(Grid.FocusedColumn-1).Category in [dtcBinary, dtcSpatial]) then Dialog.FileName := Dialog.FileName + '.txt'; if Dialog.Execute then begin Screen.Cursor := crHourGlass; AnyGridEnsureFullRow(Grid, Grid.FocusedNode); RowNum := Grid.GetNodeData(Grid.FocusedNode); Results.RecNo := RowNum^; - if Results.DataType(Grid.FocusedColumn).Category in [dtcBinary, dtcSpatial] then - Content := AnsiString(Results.Col(Grid.FocusedColumn)) + if Results.DataType(Grid.FocusedColumn-1).Category in [dtcBinary, dtcSpatial] then + Content := AnsiString(Results.Col(Grid.FocusedColumn-1)) else - Content := Utf8Encode(Results.Col(Grid.FocusedColumn)); + Content := Utf8Encode(Results.Col(Grid.FocusedColumn-1)); StrLen := Length(Content); try FileStream := TFileStream.Create(Dialog.FileName, fmCreate or fmOpenWrite); @@ -3613,19 +3856,19 @@ procedure TMainForm.actInsertFilesExecute(Sender: TObject); begin Dialog := TfrmInsertFiles.Create(Self); Dialog.ShowModal; + Dialog.Free; end; // Drop Table(s) procedure TMainForm.actDropObjectsExecute(Sender: TObject); var msg, db: String; - Node: PVirtualNode; + Node, SiblingDB: PVirtualNode; Obj: PDBObject; DBObject: TDBObject; ObjectList: TDBObjectList; Editor: TDBObjectEditor; Conn: TDBConnection; - DisableForeignKeys: Boolean; begin Conn := ActiveConnection; @@ -3641,8 +3884,16 @@ procedure TMainForm.actDropObjectsExecute(Sender: TObject); try db := DBObject.Database; Node := FindDBNode(DBtree, Conn, db); - SetActiveDatabase('', Conn); - Conn.Query(Conn.GetSQLSpecifity(spDatabaseDrop, [Conn.QuoteIdent(db)])); + // Set focus on previous or next database, to prevent "Cannot drop database xyz, because it is currently in use" + // MS SQL on top cannot "un-use" the current database + SiblingDB := DBtree.GetNextSibling(Node); + if not Assigned(SiblingDB) then + SiblingDB := DBtree.GetPreviousSibling(Node); + if Assigned(SiblingDB) then + SetActiveDatabase(DBtree.Text[SiblingDB, 0], Conn) + else + SetActiveDatabase('', Conn); // Fallback if there is no sibling. Works on MySQL only. + Conn.Query(qDatabaseDrop, [Conn.QuoteIdent(db)]); DBtree.DeleteNode(Node); Conn.ClearDbObjects(db); Conn.RefreshAllDatabases; @@ -3681,9 +3932,8 @@ procedure TMainForm.actDropObjectsExecute(Sender: TObject); if MessageDialog(f_('Drop %d object(s) in database "%s"?', [ObjectList.Count, Conn.Database]), msg, mtCriticalConfirmation, [mbok,mbcancel]) = mrOk then begin try // Disable foreign key checks to avoid SQL errors - DisableForeignKeys := (Conn.Parameters.NetTypeGroup = ngMySQL) and (Conn.ServerVersionInt >= 40014); - if DisableForeignKeys then - Conn.Query('SET @OLD_FOREIGN_KEY_CHECKS=@@FOREIGN_KEY_CHECKS, FOREIGN_KEY_CHECKS=0'); + if Conn.SqlProvider.Has(qDisableForeignKeyChecks) then + Conn.Query(qDisableForeignKeyChecks); // Compose and run DROP [TABLE|VIEW|...] queries Editor := ActiveObjectEditor; for DBObject in ObjectList do begin @@ -3691,8 +3941,8 @@ procedure TMainForm.actDropObjectsExecute(Sender: TObject); if Assigned(Editor) and Editor.Modified and Editor.DBObject.IsSameAs(DBObject) then Editor.Modified := False; end; - if DisableForeignKeys then - Conn.Query('SET FOREIGN_KEY_CHECKS=@OLD_FOREIGN_KEY_CHECKS'); + if Conn.SqlProvider.Has(qEnableForeignKeyChecks) then + Conn.Query(qEnableForeignKeyChecks); // Refresh ListTables + dbtree so the dropped tables are gone: Conn.ClearDbObjects(ActiveDatabase); RefreshTree; @@ -3711,14 +3961,13 @@ procedure TMainForm.actLaunchCommandlineExecute(Sender: TObject); path, p, log, cmd: String; sep: Char; Conn: TDBConnection; - PasswordStart, PasswordEnd: Integer; begin // Launch mysql.exe Conn := ActiveConnection; if not Conn.Parameters.IsAnyMySQL then ErrorDialog(_('Command line only works on MySQL connections.')) else begin - if FIsWine then begin + if IsWine then begin cmd := 'mysql'; sep := '/'; end else begin @@ -3733,49 +3982,16 @@ procedure TMainForm.actLaunchCommandlineExecute(Sender: TObject); CRLF+CRLF+f_('Current setting is: "%s"', [path])); end else begin p := ''; - if FIsWine then begin + if IsWine then begin p := ' -e '+path+cmd; path := ''; cmd := '$TERM'; end; - if Conn.Parameters.WantSSL then - p := p + ' --ssl'; - if not Conn.Parameters.SSLPrivateKey.IsEmpty then - p := p + ' --ssl-key="'+Conn.Parameters.SSLPrivateKey+'"'; - if not Conn.Parameters.SSLCertificate.IsEmpty then - p := p + ' --ssl-cert="'+Conn.Parameters.SSLCertificate+'"'; - if not Conn.Parameters.SSLCACertificate.IsEmpty then - p := p + ' --ssl-ca="'+Conn.Parameters.SSLCACertificate+'"'; - - case Conn.Parameters.NetType of - ntMySQL_NamedPipe: - p := p + ' --pipe --socket="'+Conn.Parameters.Hostname+'"'; - ntMySQL_SSHtunnel: - p := p + ' --host="localhost" --port='+IntToStr(Conn.Parameters.SSHLocalPort); - else - p := p + ' --host="'+Conn.Parameters.Hostname+'" --port='+IntToStr(Conn.Parameters.Port); - end; - - p := p + ' --user="'+Conn.Parameters.Username+'"'; - // Markers for removing password from log line - PasswordStart := -1; - PasswordEnd := -1; - if Conn.Parameters.Password <> '' then begin - PasswordStart := Length(path + cmd + p) +14; - p := p + ' --password="'+StringReplace(Conn.Parameters.Password, '"', '\"', [rfReplaceAll])+'"'; - PasswordEnd := Length(path + cmd + p); - end; - if Conn.Parameters.Compressed then - p := p + ' --compress'; - if ActiveDatabase <> '' then - p := p + ' --database="' + ActiveDatabase + '"'; - log := path + cmd + p; - if PasswordStart > -1 then begin - Delete(log, PasswordStart, PasswordEnd-PasswordStart); - Insert('********', log, PasswordStart); - end; + log := path + cmd + p + Conn.Parameters.GetExternalCliArguments(Conn, nbTrue); LogSQL(f_('Launching command line: %s', [log]), lcInfo); + + p := p + Conn.Parameters.GetExternalCliArguments(Conn, nbFalse); ShellExec(cmd, path, p); end; end; @@ -3785,27 +4001,31 @@ procedure TMainForm.actLaunchCommandlineExecute(Sender: TObject); // Load SQL-file, make sure that SheetQuery is activated procedure TMainForm.actLoadSQLExecute(Sender: TObject); var - i: Integer; - Dialog: TOpenTextFileDialog; + ProceedResult: Integer; + Dialog: TExtFileOpenDialog; Encoding: TEncoding; - Tab: TQueryTab; begin AppSettings.ResetPath; - Dialog := TOpenTextFileDialog.Create(Self); - Dialog.Options := Dialog.Options + [ofAllowMultiSelect]; - Dialog.Filter := _('SQL files')+' (*.sql)|*.sql|'+_('All files')+' (*.*)|*.*'; - Dialog.DefaultExt := 'sql'; + Dialog := TExtFileOpenDialog.Create(Self); + Dialog.Options := Dialog.Options + [fdoAllowMultiSelect]; + Dialog.AddFileType('*.sql', _('SQL files')); + Dialog.AddFileType('*.*', _('All files')); + Dialog.DefaultExtension := 'sql'; Dialog.Encodings.Assign(FileEncodings); Dialog.EncodingIndex := AppSettings.ReadInt(asFileDialogEncoding, Self.Name); if Dialog.Execute then begin Encoding := GetEncodingByName(Dialog.Encodings[Dialog.EncodingIndex]); - if not RunQueryFiles(Dialog.Files, Encoding, Sender=actRunSQL) then begin - for i:=0 to Dialog.Files.Count-1 do begin - Tab := GetOrCreateEmptyQueryTab; - Tab.LoadContents(Dialog.Files[i], True, Encoding); - if i = Dialog.Files.Count-1 then - SetMainTab(Tab.TabSheet); - end; + if Encoding = nil then begin + ProceedResult := MessageDialog(_('Really auto-detect file encoding?') + SLineBreak + SLineBreak + + _('Auto detecting the encoding of a file is highly discouraged. You may experience data loss if the detection fails.') + SLineBreak + SLineBreak + + _('To avoid this message select the correct encoding before pressing Open.'), + mtConfirmation, [mbYes, mbCancel]); + end else begin + ProceedResult := mrYes; + end; + + if ProceedResult = mrYes then begin + OpenQueryFiles(Dialog.Files, Encoding, Sender=actRunSQL); end; AppSettings.WriteInt(asFileDialogEncoding, Dialog.EncodingIndex, Self.Name); end; @@ -3813,10 +4033,55 @@ procedure TMainForm.actLoadSQLExecute(Sender: TObject); end; -function TMainForm.RunQueryFiles(Filenames: TStrings; Encoding: TEncoding; ForceRun: Boolean): Boolean; +procedure TMainForm.OpenQueryFiles(Filenames: TStrings; Encoding: TEncoding; ForceRun: Boolean); var - i, FilesProcessed: Integer; - Filesize, FilesizeSum, CurrentPosition: Int64; + Tab, FileInTab: TQueryTab; + FileHints: TStringList; + i: Integer; +begin + // Decides whether to run or load files, prevents duplicates etc. + if RunQueryFiles(Filenames, Encoding, ForceRun) then + Exit; + + FileHints := TStringList.Create; + + for i:=0 to Filenames.Count-1 do begin + + FileInTab := nil; + for Tab in QueryTabs do begin + if Tab.MemoFilename = Filenames[i] then begin + FileInTab := Tab; + FileHints.Add(f_('This file is already open in query tab #%d.', [FileInTab.Number]) + ' ' + ExtractFileName(Filenames[i])); + if i = Filenames.Count-1 then + SetMainTab(FileInTab.TabSheet); + Break; + end; + end; + + if not Assigned(FileInTab) then begin + Tab := GetOrCreateEmptyQueryTab(False); + Tab.LoadContents(Filenames[i], True, Encoding); + if i = Filenames.Count-1 then + SetMainTab(Tab.TabSheet); + end; + end; + + if not FileHints.IsEmpty then begin + if MainFormAfterCreateDone then + MessageDialog(FileHints.Text, mtInformation, [mbOK]) + else begin + for i:=0 to FileHints.Count-1 do + LogSQL(FileHints[i]); + end; + end; + FileHints.Free; +end; + + +function TMainForm.RunQueryFiles(Filenames: TStrings; Encoding: TEncoding; ForceRun: Boolean): Boolean; +var + i, FilesProcessed: Integer; + Filesize, FilesizeSum, CurrentPosition: Int64; StartTime: UInt64; msgtext: String; AbsentFiles, PopupFileList: TStringList; @@ -3883,7 +4148,7 @@ function TMainForm.RunQueryFiles(Filenames: TStrings; Encoding: TEncoding; Force Dialog.Free; end else begin msgtext := f_('One or more of the selected files are larger than %s:', [FormatByteNumber(RunFileSize, 0)]) + CRLF + - ImplodeStr(CRLF, PopupFileList) + CRLF + CRLF + + Implode(CRLF, PopupFileList) + CRLF + CRLF + _('Just run these files to avoid loading them into the query-editor (= memory)?') + CRLF + CRLF + _('Press') + CRLF + _(' [Yes] to run file(s) without loading it into the editor') + CRLF + @@ -3951,7 +4216,10 @@ function TMainForm.RunQueryFile(FileName: String; Encoding: TEncoding; Conn: TDB begin ProgressDialog.SetLine(1, PChar(_('Clean up ...')), False, Dummy); Queries.Free; - Stream.Free; + try + Stream.Free; + except; // Eat error when stream wasn't yet created properly + end; // BringToFront; // Not sure why I added this initially, but it steals focus from other applications if ProgressDialog.HasUserCancelled then MessageText := 'File "%s" partially executed, with %s queries and %s affected rows' @@ -3972,7 +4240,7 @@ function TMainForm.RunQueryFile(FileName: String; Encoding: TEncoding; Conn: TDB ErrorCount := 0; RowsAffected := 0; LinesRemain := ''; - Queries := TSQLBatch.Create; + Queries := TSQLBatch.Create(Conn.Parameters.NetTypeGroup); try // Start file operations @@ -4024,6 +4292,7 @@ function TMainForm.RunQueryFile(FileName: String; Encoding: TEncoding; Conn: TDB try Conn.Query(Queries[i].SQL, False, lcScript); RowsAffected := RowsAffected + Conn.RowsAffected; + Conn.ShowWarnings; except on E:Exception do begin if actQueryStopOnErrors.Checked then @@ -4048,23 +4317,26 @@ function TMainForm.RunQueryFile(FileName: String; Encoding: TEncoding; Conn: TDB end; except - on E:EFileStreamError do begin - StopProgress; - Result := False; - ErrorDialog(f_('Error while reading file "%s"', [FileName]), E.Message); - AddOrRemoveFromQueryLoadHistory(FileName, False, True); - end; - on E:EDbError do begin - StopProgress; - Result := False; - ErrorDialog(E.Message + CRLF + CRLF + - f_('Notice: You can disable the "%s" option to ignore such errors', [actQueryStopOnErrors.Caption]) - ); - end; - on E:EEncodingError do begin - StopProgress; - Result := False; - ErrorDialog(E.Message); + on E:Exception do begin + if (E is EFileStreamError) + or (E is EEncodingError) + or (E is EReadError) + then begin + StopProgress; + Result := False; + ErrorDialog(f_('Error while reading file "%s"', [FileName]), E.Message); + AddOrRemoveFromQueryLoadHistory(FileName, False, True); + end + else if E is EDbError then begin + StopProgress; + Result := False; + ErrorDialog(E.Message + CRLF + CRLF + + f_('Notice: You can disable the "%s" option to ignore such errors', [actQueryStopOnErrors.Caption]) + ); + end + else begin + raise; + end; end; end; end; @@ -4086,6 +4358,8 @@ procedure TMainForm.SessionConnect(Sender: TObject); for i:=High(FTreeClickHistory) downto Low(FTreeClickHistory) do begin if FTreeClickHistory[i] <> nil then begin DBObj := DBtree.GetNodeData(FTreeClickHistory[i]); + if (DBObj = nil) or (DBObj.Connection = nil) or (not DBObj.Connection.Active) then // Session disconnected + Break; if DBObj.Connection.Parameters.SessionPath = SessionPath then begin Node := FTreeClickHistory[i]; break; @@ -4120,9 +4394,7 @@ procedure TMainForm.SessionConnect(Sender: TObject); function TMainform.InitConnection(Params: TConnectionParameters; ActivateMe: Boolean; var Connection: TDBConnection): Boolean; var RestoreLastActiveDatabase: Boolean; - StartupScript, LastActiveDatabase: String; - StartupBatch: TSQLBatch; - Query: TSQLSentence; + LastActiveDatabase: String; SessionNode, DBNode: PVirtualNode; begin Connection := Params.CreateConnection(Self); @@ -4165,42 +4437,26 @@ function TMainform.InitConnection(Params: TConnectionParameters; ActivateMe: Boo end; end; - // Process startup script - StartupScript := Trim(Connection.Parameters.StartupScriptFilename); - if StartupScript <> '' then begin - StartupScript := ExpandFileName(StartupScript); - if not FileExists(StartupScript) then - ErrorDialog(f_('Startup script file not found: %s', [StartupScript])) - else begin - StartupBatch := TSQLBatch.Create; - StartupBatch.SQL := ReadTextfile(StartupScript, nil); - for Query in StartupBatch do try - Connection.Query(Query.SQL); - except - // Suppress popup, errors get logged into SQL log - end; - StartupBatch.Free; - end; - end; - if Params.WantSSL and not Connection.IsSSL then begin MessageDialog(_('SSL not used.'), _('Your SSL settings were not accepted by the server, or the server does not support any SSL configuration.'), mtWarning, - [mbOK] + [mbOK], + asSSLWarnUnused ); end; // Apply favorite object paths AppSettings.SessionPath := Params.SessionPath; Connection.Favorites.Text := AppSettings.ReadString(asFavoriteObjects); + actFavoriteObjectsOnly.Checked := False; // Tree node filtering needs a hit once when connected editDatabaseTableFilterChange(Self); except on E:EDbError do begin - ErrorDialog(E.Message); + MessageDialog(_('Connection failed'), E.Message, mtError, [mbOK], asUnused, E.Hint); // attempt failed if AppSettings.SessionPathExists(Params.SessionPath) then begin // Save "refused" counter @@ -4213,6 +4469,7 @@ function TMainform.InitConnection(Params: TConnectionParameters; ActivateMe: Boo end; StoreLastSessions; + ValidateControls(Connection); ShowStatusMsg; end; @@ -4280,7 +4537,7 @@ procedure TMainForm.actUpdateCheckExecute(Sender: TObject); begin frm := TfrmUpdateCheck.Create(Self); frm.ShowModal; - FreeAndNil(frm); + frm.Free; // FormClose has no caFree, as it may not have been called end; @@ -4298,18 +4555,31 @@ procedure TMainForm.actCreateDBObjectExecute(Sender: TObject); Obj.Database := ActiveDatabase; if a = actCreateTable then Obj.NodeType := lntTable else if a = actCreateView then Obj.NodeType := lntView - else if a = actCreateRoutine then Obj.NodeType := lntProcedure + else if a = actCreateProcedure then Obj.NodeType := lntProcedure else if a = actCreateTrigger then Obj.NodeType := lntTrigger - else if a = actCreateEvent then Obj.NodeType := lntEvent; + else if a = actCreateEvent then Obj.NodeType := lntEvent + else if a = actCreateFunction then Obj.NodeType := lntFunction; + PlaceObjectEditor(Obj); end; +procedure TMainForm.actTreeShowColumnsExecute(Sender: TObject); +begin + // Show columns in table nodes on tree + RefreshTree(nil); +end; + + procedure TMainForm.actEmptyTablesExecute(Sender: TObject); var TableOrView: TDBObject; Objects: TDBObjectList; - Names: String; + Names, QueryDisableChecks, QueryEnableChecks: String; + Conn: TDBConnection; + Dialog: TTaskDialog; + DialogResult: TModalResult; + DisableForeignKeyChecks: Boolean; begin // Delete rows from selected tables and views @@ -4326,21 +4596,48 @@ procedure TMainForm.actEmptyTablesExecute(Sender: TObject); if Objects.Count = 0 then ErrorDialog(_('No table(s) selected.')) else begin - if MessageDialog(f_('Empty %d table(s) and/or view(s)?', [Objects.count]), Names, - mtConfirmation, [mbOk, mbCancel]) = mrOk then begin + Conn := ActiveConnection; + QueryDisableChecks := Conn.SqlProvider.GetSql(qDisableForeignKeyChecks); + QueryEnableChecks := Conn.SqlProvider.GetSql(qEnableForeignKeyChecks); + if (Win32MajorVersion >= 6) and StyleServices.Enabled then begin + Dialog := TTaskDialog.Create(Self); + Dialog.Text := f_('Empty %d table(s) and/or view(s)?', [Objects.count]); + Dialog.CommonButtons := [tcbOk, tcbCancel]; + Dialog.Flags := Dialog.Flags + [tfUseHiconMain]; + Dialog.CustomMainIcon := ConfirmIcon; + if not QueryDisableChecks.IsEmpty then + Dialog.VerificationText := _('Disable foreign key checks'); + Dialog.Execute; + DialogResult := Dialog.ModalResult; + DisableForeignKeyChecks := tfVerificationFlagChecked in Dialog.Flags; + Dialog.Free; + end else begin + DialogResult := MessageDialog(f_('Empty %d table(s) and/or view(s)?', [Objects.count]), Names, mtConfirmation, [mbOk, mbCancel]); + DisableForeignKeyChecks := False; + end; + if DialogResult = mrOk then begin Screen.Cursor := crHourglass; EnableProgress(Objects.Count); try - for TableOrView in Objects do begin - TableOrView.Connection.Query(TableOrView.Connection.GetSQLSpecifity(spEmptyTable) + TableOrView.QuotedName); - ProgressStep; + if DisableForeignKeyChecks and (not QueryDisableChecks.IsEmpty) then + Conn.Query(QueryDisableChecks); + try + for TableOrView in Objects do begin + Conn.Query(qEmptyTable, [TableOrView.QuotedName]); + ProgressStep; + end; + actRefresh.Execute; + except + on E:EDbError do begin + SetProgressState(pbsError); + ErrorDialog(E.Message); + end; end; - actRefresh.Execute; + if DisableForeignKeyChecks and (not QueryEnableChecks.IsEmpty) then + Conn.Query(QueryEnableChecks); except - on E:EDbError do begin - SetProgressState(pbsError); + on E:EDbError do ErrorDialog(E.Message); - end; end; Objects.Free; DisableProgress; @@ -4357,27 +4654,12 @@ procedure TMainForm.actBatchInOneGoExecute(Sender: TObject); function TMainForm.DBTreeClicked(Sender: TObject): Boolean; -var - ClickedControl: TComponent; - ClickedMenu: TMenu; begin // Find out if user rightclicked in tree or in database tab, // which is a bit complex, so outsourced here. - Result := DBTree.Focused or (PageControlMain.ActivePage <> tabDatabase); - if Sender is TAction then begin - ClickedControl := (Sender as TAction).ActionComponent; - if ClickedControl is TMenuItem then begin - ClickedMenu := (ClickedControl as TMenuItem).GetParentMenu; - if ClickedMenu is TPopupMenu then - Result := (ClickedMenu as TPopupMenu).PopupComponent = DBTree; - end; - end else if Sender is TPopupMenu then begin - Result := (Sender as TPopupMenu).PopupComponent = DBTree; - end else if Sender is TMenuItem then begin - ClickedMenu := (Sender as TMenuItem).GetParentMenu; - if ClickedMenu is TPopupMenu then - Result := (ClickedMenu as TPopupMenu).PopupComponent = DBTree; - end; + Result := DBTree.Focused + or (PageControlMain.ActivePage <> tabDatabase) + or (PopupComponent(Sender) = DBtree); end; @@ -4456,9 +4738,9 @@ procedure TMainForm.actRunRoutinesExecute(Sender: TObject); ParamValues := ''; case Obj.Connection.Parameters.NetTypeGroup of ngMySQL, ngPgSQL: - ParamValues := '(' + ImplodeStr(', ', Params) + ')'; + ParamValues := '(' + Implode(', ', Params) + ')'; ngMSSQL: - ParamValues := ' ' + ImplodeStr(' ', Params); + ParamValues := ' ' + Implode(' ', Params); else raise Exception.CreateFmt(_(MsgUnhandledNetType), [Integer(Obj.Connection.Parameters.NetType)]); end; @@ -4475,7 +4757,7 @@ procedure TMainForm.actRunRoutinesExecute(Sender: TObject); procedure TMainForm.actNewWindowExecute(Sender: TObject); begin - ShellExec( ExtractFileName(paramstr(0)), ExtractFilePath(paramstr(0)) ); + ShellExec( ExtractFileName(paramstr(0)), GetAppDir); end; @@ -4486,12 +4768,15 @@ procedure TMainForm.actQueryFindReplaceExecute(Sender: TObject); // Display search + replace dialog if not Assigned(FSearchReplaceDialog) then FSearchReplaceDialog := TfrmSearchReplace.Create(Self); + if FSearchReplaceDialog.Visible then + Exit; FSearchReplaceDialog.chkReplace.Checked := Sender = actQueryReplace; if (ActiveSynMemo(False) <> nil) or (ActiveGrid <> nil) then begin OldDataLocalNumberFormat := DataLocalNumberFormat; DataLocalNumberFormat := False; FSearchReplaceDialog.ShowModal; DataLocalNumberFormat := OldDataLocalNumberFormat; + ValidateControls(Sender); end; end; @@ -4546,10 +4831,29 @@ procedure TMainForm.actRefreshExecute(Sender: TObject); tab1, tab2: TTabSheet; List: TVirtualStringTree; OldDbObject: TDBObject; + DoProceed: Boolean; + i: Integer; +const + HeaderDragStates: THeaderStates = [ + hsAutoSizing, hsDragging, hsDragPending, hsColumnWidthTracking, hsColumnWidthTrackPending, hsHeightTracking, hsHeightTrackPending, hsResizing + ]; begin // Refresh - // Force data tab update when appropriate. + + // Do not refresh when *any* tree is dragged or resized by user in this moment. + // This is not limited to the focused control, as we also refresh ListDatabases if only its tab is active. + for i:=0 to ComponentCount-1 do begin + if not(Components[i] is TVirtualStringTree) then + continue; + if (HeaderDragStates * TVirtualStringTree(Components[i]).Header.States <> []) then begin + Exit; + end; + end; + + // Disable refresh action and re-enable in ApplicationOnIdle event tab1 := PageControlMain.ActivePage; + actRefresh.Enabled := False; + FRefreshActionDisabledAt := GetTickCount; if ActiveControl = DBtree then RefreshTree else if tab1 = tabHost then begin @@ -4569,6 +4873,12 @@ procedure TMainForm.actRefreshExecute(Sender: TObject); OldDbObject := TDBObject.Create(FActiveDbObj.Connection); OldDbObject.Assign(FActiveDbObj); RefreshTree(OldDbObject); + end else if tab1 = tabEditor then begin + DoProceed := True; + if ActiveObjectEditor.Modified then + DoProceed := MessageDialog(_('Discard changes?'), mtConfirmation, [mbCancel, mbOK]) = mrOk; + if DoProceed then + RefreshTree; end else if tab1 = tabData then InvalidateVT(DataGrid, VTREE_NOTLOADED_PURGECACHE, False); end; @@ -4597,12 +4907,12 @@ procedure TMainForm.actSQLhelpExecute(Sender: TObject); and Assigned(DataGrid.FocusedNode) then begin keyword := SelectedTableFocusedColumn.DataType.Name; - end else if ActiveControl = ActiveQueryHelpers then begin + end else if ActiveControl = QueryTabs.ActiveHelpersTree then begin // Makes only sense if one of the nodes "SQL fn" or "SQL kw" was selected - Tree := ActiveQueryHelpers; + Tree := QueryTabs.ActiveHelpersTree; if Assigned(Tree.FocusedNode) and (Tree.GetNodeLevel(Tree.FocusedNode)=1) - and (Tree.FocusedNode.Parent.Index in [HELPERNODE_FUNCTIONS, HELPERNODE_KEYWORDS]) then + and (Tree.FocusedNode.Parent.Index in [TQueryTab.HelperNodeFunctions, TQueryTab.HelperNodeKeywords]) then keyword := Tree.Text[Tree.FocusedNode, 0]; end; @@ -4615,21 +4925,52 @@ procedure TMainForm.actSQLhelpExecute(Sender: TObject); end; -procedure TMainForm.actSynchronizeDatabaseExecute(Sender: TObject); -var - SyncForm: TfrmSyncDB; -begin - SyncForm := TfrmSyncDB.Create(Self); - SyncForm.ShowModal; -end; - - procedure TMainForm.actSynEditCompletionProposeExecute(Sender: TObject); begin // Show completion proposal explicitely, without the use of its own ShortCut property, // to support a customized shortcut, see SynCompletionProposal.Editor := ActiveSynMemo(False); - SynCompletionProposal.ActivateCompletion; + if Screen.ActiveControl is TCustomSynEdit then + SynCompletionProposal.ActivateCompletion + else + MessageBeep(MB_ICONEXCLAMATION); +end; + +procedure TMainForm.actSynMoveDownExecute(Sender: TObject); +var + Editor: TSynMemo; +begin + // Move line of text one down + Editor := ActiveSynMemo(False); + if Assigned(Editor) and (Editor.CaretY < Editor.Lines.Count) then begin + //Logsql('Editor.CaretY:'+Editor.CaretY.ToString+' Editor.Lines.Count:'+Editor.Lines.Count.ToString); + Editor.Lines.Exchange(Editor.CaretY-1, Editor.CaretY); + Editor.CaretY := Editor.CaretY + 1; + // OnStatusChanged implicitly fired here + if Assigned(Editor.OnChange) then + Editor.OnChange(Editor); + Editor.Repaint; + end else begin + MessageBeep(MB_ICONERROR); + end; +end; + +procedure TMainForm.actSynMoveUpExecute(Sender: TObject); +var + Editor: TSynMemo; +begin + // Move line of text one up + Editor := ActiveSynMemo(False); + if Assigned(Editor) and (Editor.CaretY >= 2) then begin + Editor.Lines.Exchange(Editor.CaretY-1, Editor.CaretY-2); + Editor.CaretY := Editor.CaretY - 1; + // OnStatusChanged implicitly fired here + if Assigned(Editor.OnChange) then + Editor.OnChange(Editor); + Editor.Repaint; + end else begin + MessageBeep(MB_ICONERROR); + end; end; {*** @@ -4639,8 +4980,9 @@ procedure TMainForm.actSynEditCompletionProposeExecute(Sender: TObject); } procedure TMainform.CallSQLHelpWithKeyword( keyword: String ); begin - if FActiveDbObj.Connection.ServerVersionInt >= 40100 then begin - SqlHelpDialog := TfrmSQLhelp.Create(Self); + if FActiveDbObj.Connection.SqlProvider.Has(qHelpKeyword) then begin + if not Assigned(SqlHelpDialog) then + SqlHelpDialog := TfrmSQLhelp.Create(Self); SqlHelpDialog.Show; SqlHelpDialog.Keyword := keyword; end else @@ -4652,28 +4994,31 @@ procedure TMainForm.actSaveSynMemoToTextfileExecute(Sender: TObject); var Comp: TComponent; Memo: TSynMemo; - Dialog: TSaveDialog; - Item: TMenuItem; + Dialog: TExtFileSaveDialog; begin // Save to textfile, from any TSynMemo (SQL log, "CREATE code" tab in editor, ...) - Item := (Sender as TAction).ActionComponent as TMenuItem; - Comp := (Item.GetParentMenu as TPopupMenu).PopupComponent; + Memo := nil; // Try to find memo from menu item's popup component, and if that fails, check ActiveControl. // See #353 - if (Comp <> nil) and (Comp is TSynMemo) then begin - Memo := Comp as TSynMemo; - end else if ActiveControl is TSynMemo then begin + Comp := PopupComponent(Sender); + if Comp is TSynMemo then + Memo := Comp as TSynMemo + else if ActiveControl is TSynMemo then Memo := ActiveControl as TSynMemo; - end else - Memo := nil; - if Memo <> nil then begin - Dialog := TSaveDialog.Create(Self); - Dialog.Options := Dialog.Options + [ofOverwritePrompt]; - Dialog.Filter := _('SQL files')+' (*.sql)|*.sql|'+_('All files')+' (*.*)|*.*'; - Dialog.DefaultExt := 'sql'; + if Assigned(Memo) then begin + Dialog := TExtFileSaveDialog.Create(Self); + Dialog.Options := Dialog.Options + [fdoOverWritePrompt]; + Dialog.AddFileType('*.sql', _('SQL files')); + Dialog.AddFileType('*.*', _('All files')); + Dialog.DefaultExtension := 'sql'; + Dialog.LineBreakIndex := TLineBreaks(AppSettings.ReadInt(asLineBreakStyle)); if Dialog.Execute then begin Screen.Cursor := crHourGlass; - SaveUnicodeFile(Dialog.FileName, Memo.Text); + SaveUnicodeFile( + Dialog.FileName, + Implode(GetLineBreak(Dialog.LineBreakIndex), Memo.Lines), + UTF8NoBOMEncoding + ); Screen.Cursor := crDefault; end; end else begin @@ -4687,26 +5032,37 @@ procedure TMainForm.actSaveSQLAsExecute(Sender: TObject); i: Integer; CanSave: TModalResult; OnlySelection: Boolean; - SaveDialog: TSaveDialog; + Dialog: TExtFileSaveDialog; + QueryTab: TQueryTab; + DefaultFilename: String; begin // Save SQL CanSave := mrNo; - SaveDialog := TSaveDialog.Create(Self); - SaveDialog.Options := SaveDialog.Options + [ofOverwritePrompt]; + QueryTab := QueryTabs.ActiveTab; + Dialog := TExtFileSaveDialog.Create(Self); + if QueryTab.MemoFilename.IsEmpty then + DefaultFilename := QueryTab.TabSheet.Caption + else + DefaultFilename := ExtractFileName(QueryTab.MemoFilename); + DefaultFilename := DefaultFilename.Trim([' ', '*']); + Dialog.FileName := ValidFilename(DefaultFilename); + Dialog.Options := Dialog.Options + [fdoOverwritePrompt]; if (Sender = actSaveSQLSnippet) or (Sender = actSaveSQLSelectionSnippet) then begin - SaveDialog.InitialDir := AppSettings.DirnameSnippets; - SaveDialog.Options := SaveDialog.Options + [ofNoChangeDir]; - SaveDialog.Title := _('Save snippet'); - end; - SaveDialog.Filter := _('SQL files')+' (*.sql)|*.sql|'+_('All files')+' (*.*)|*.*'; - SaveDialog.DefaultExt := 'sql'; - while (CanSave = mrNo) and SaveDialog.Execute do begin + Dialog.DefaultFolder := AppSettings.DirnameSnippets; + Dialog.Options := Dialog.Options + [fdoNoChangeDir]; + Dialog.Title := _('Save snippet'); + end; + Dialog.AddFileType('*.sql', _('SQL files')); + Dialog.AddFileType('*.*', _('All files')); + Dialog.DefaultExtension := 'sql'; + Dialog.LineBreakIndex := QueryTab.MemoLineBreaks; + while (CanSave = mrNo) and Dialog.Execute do begin // Save complete content or just the selected text, // depending on the tag of calling control CanSave := mrYes; for i:=0 to QueryTabs.Count-1 do begin - if QueryTabs[i].MemoFilename = SaveDialog.FileName then begin - CanSave := MessageDialog(f_('Overwrite "%s"?', [SaveDialog.FileName]), f_('This file is already open in query tab #%d.', [QueryTabs[i].Number]), + if QueryTabs[i].MemoFilename = Dialog.FileName then begin + CanSave := MessageDialog(f_('Overwrite "%s"?', [Dialog.FileName]), f_('This file is already open in query tab #%d.', [QueryTabs[i].Number]), mtWarning, [mbYes, mbNo, mbCancel]); break; end; @@ -4714,35 +5070,55 @@ procedure TMainForm.actSaveSQLAsExecute(Sender: TObject); end; if CanSave = mrYes then begin OnlySelection := (Sender = actSaveSQLselection) or (Sender = actSaveSQLSelectionSnippet); - ActiveQueryTab.SaveContents(SaveDialog.FileName, OnlySelection); + QueryTab.MemoLineBreaks := Dialog.LineBreakIndex; + QueryTab.SaveContents(Dialog.FileName, OnlySelection); for i:=0 to QueryTabs.Count-1 do begin - if QueryTabs[i] = ActiveQueryTab then + if QueryTabs[i] = QueryTab then continue; - if QueryTabs[i].MemoFilename = SaveDialog.FileName then + if QueryTabs[i].MemoFilename = Dialog.FileName then QueryTabs[i].Memo.Modified := True; end; ValidateQueryControls(Sender); SetSnippetFilenames; end; - SaveDialog.Free; + Dialog.Free; end; procedure TMainForm.actSaveSQLExecute(Sender: TObject); var i: Integer; + ObjEditor: TDBObjectEditor; + Handled: Boolean; begin - if ActiveQueryTab.MemoFilename <> '' then begin - ActiveQueryTab.SaveContents(ActiveQueryTab.MemoFilename, False); - for i:=0 to QueryTabs.Count-1 do begin - if QueryTabs[i] = ActiveQueryTab then - continue; - if QueryTabs[i].MemoFilename = ActiveQueryTab.MemoFilename then - QueryTabs[i].Memo.Modified := True; + Handled := False; + if QueryTabs.HasActiveTab then begin + // Save SQL tab contents to file + if QueryTabs.ActiveTab.MemoFilename <> '' then begin + QueryTabs.ActiveTab.SaveContents(QueryTabs.ActiveTab.MemoFilename, False); + for i:=0 to QueryTabs.Count-1 do begin + if QueryTabs[i] = QueryTabs.ActiveTab then + continue; + if QueryTabs[i].MemoFilename = QueryTabs.ActiveTab.MemoFilename then + QueryTabs[i].Memo.Modified := True; + end; + ValidateQueryControls(Sender); + end else + actSaveSQLAsExecute(Sender); + Handled := True; + end + else if PageControlMain.ActivePage = tabEditor then begin + // Save table, procedure, etc. + ObjEditor := ActiveObjectEditor; + if Assigned(ObjEditor) and ObjEditor.Modified then begin + ObjEditor.ApplyModifications; + Handled := True; end; - ValidateQueryControls(Sender); - end else - actSaveSQLAsExecute(Sender); + end; + if not Handled then begin + MessageBeep(MB_ICONASTERISK); + end; + end; @@ -4752,6 +5128,30 @@ procedure TMainForm.actQueryStopOnErrorsExecute(Sender: TObject); end; +procedure TMainForm.actQueryTableExecute(Sender: TObject); +var + Objects: TDBObjectList; + Obj: TDBObject; + Tab: TQueryTab; + Conn: TDBConnection; +begin + // Query table data + Conn := ActiveConnection; + if not Assigned(Conn) then + Exit; + Objects := GetFocusedObjects(Sender, [lntTable, lntView]); + + if Objects.Count = 0 then + ErrorDialog(_('No table selected.'), _('Please select one or more table(s) or view(s).')); + + for Obj in Objects do begin + Tab := GetOrCreateEmptyQueryTab(True); + Tab.Memo.Text := Conn.ApplyLimitClause('SELECT', '* FROM '+Obj.QuotedName, AppSettings.ReadInt(asDatagridRowsPerStep), 0); + SetTabCaption(Tab.TabSheet.TabIndex, Obj.Name); + actExecuteQueryExecute(Sender); + end; +end; + procedure TMainForm.actQueryWordWrapExecute(Sender: TObject); begin // SetupSynEditors applies all customizations to any SynEditor @@ -4784,6 +5184,25 @@ procedure TMainForm.actCodeFoldingStartRegionExecute(Sender: TObject); end; +procedure TMainForm.actConnectionPropertiesExecute(Sender: TObject); +var + Conn: TDBConnection; + i: Integer; + Infos: TStringList; + InfoText: String; +begin + Conn := ActiveConnection; + if Conn <> nil then begin + Infos := Conn.ConnectionInfo; + InfoText := ''; + for i:=0 to Infos.Count-1 do begin + InfoText := InfoText + Infos.Names[i] + ': ' + Infos.ValueFromIndex[i] + sLineBreak; + end; + MessageDialog(Trim(InfoText), mtInformation, [mbOK]); + end; +end; + + procedure TMainForm.actCodeFoldingEndRegionExecute(Sender: TObject); var Memo: TSynMemo; @@ -4892,24 +5311,19 @@ procedure TMainform.popupQueryLoadClick(Sender: TObject); Filename: String; FileList: TStringList; p: Integer; - Tab: TQueryTab; begin // Click on the popupQueryLoad Filename := (Sender as TMenuItem).Caption; Filename := StripHotkey(Filename); - if Pos('\', Filename) = 0 then // assuming we load a snippet - Filename := AppSettings.DirnameSnippets + Filename + '.sql' + if Pos(PathDelim, Filename) = 0 then // assuming we load a snippet + Filename := AppSettings.DirnameSnippets + Filename + FILEEXT_SNIPPET else begin // assuming we load a file from the recent-list p := Pos(' ', Filename) + 1; filename := Copy(Filename, p, Length(Filename)); end; FileList := TStringList.Create; FileList.Add(Filename); - if not RunQueryFiles(FileList, nil, false) then begin - Tab := GetOrCreateEmptyQueryTab; - Tab.LoadContents(Filename, True, nil); - SetMainTab(Tab.TabSheet); - end; + OpenQueryFiles(FileList, nil, False); FileList.Free; end; @@ -4988,7 +5402,7 @@ procedure TMainForm.SetDelimiter(Value: String); Msg := _('Empty value.') else begin rx := TRegExpr.Create; - rx.Expression := '(/\*|--|#|\''|\"|`)'; + rx.Expression := '(/\*|--|#|\''|\")'; if rx.Exec(Value) then Msg := _('Start-of-comment tokens or string literal markers are not allowed.') end; @@ -5012,7 +5426,7 @@ procedure TMainForm.actApplyFilterExecute(Sender: TObject); begin // If filter box is empty but filter generator box has text, most users expect // the filter to be auto generated on button click - if (SynMemoFilter.GetTextLen = 0) + if ((SynMemoFilter.GetTextLen = 0) or menuAlwaysGenerateFilter.Checked) and (editFilterSearch.Text <> '') and (Sender is TAction) and ((Sender as TAction).ActionComponent = btnFilterApply) @@ -5066,7 +5480,7 @@ procedure TMainForm.actDataInsertExecute(Sender: TObject); Results: TDBQuery; RowNum: Int64; DupeNum: PInt64; - i: Integer; + Col, ResultCol: Integer; Value: String; IsNull, AllowNewNode: Boolean; begin @@ -5089,18 +5503,21 @@ procedure TMainForm.actDataInsertExecute(Sender: TObject); // Copy values from source row, ensure we have whole cell data DupeNum := Grid.GetNodeData(DupeNode); AnyGridEnsureFullRow(Grid, DupeNode); - for i:=0 to Grid.Header.Columns.Count-1 do begin - if not (coVisible in Grid.Header.Columns[i].Options) then + for Col:=0 to Grid.Header.Columns.Count-1 do begin + ResultCol := Col - 1; + if not (coVisible in Grid.Header.Columns[Col].Options) then continue; // Ignore invisible key column - if Results.ColIsPrimaryKeyPart(i) and (Sender = actDataDuplicateRowWithoutKeys) then + if ResultCol < 0 then + Continue; // Ignore static row id column + if Results.ColIsPrimaryKeyPart(ResultCol) and (Sender = actDataDuplicateRowWithoutKeys) then continue; // Empty value for primary key column - if Results.ColIsVirtual(i) then + if Results.ColIsVirtual(ResultCol) then continue; // Don't copy virtual column value Results.RecNo := DupeNum^; - Value := Results.Col(i); - IsNull := Results.IsNull(i); + Value := Results.Col(ResultCol); + IsNull := Results.IsNull(ResultCol); Results.RecNo := RowNum; - Results.SetCol(i, Value, IsNull, False); + Results.SetCol(ResultCol, Value, IsNull, False); end; end; except on E:EDbError do @@ -5196,9 +5613,13 @@ procedure TMainForm.LogSQL(Msg: String; Category: TDBLogCategory=lcInfo; Connect LogIt: Boolean; LogItem: TDBLogItem; begin + OldSettingsPath := AppSettings.SessionPath; LogItem := TDBLogItem.Create; LogItem.Category := Category; - LogItem.LineText := Msg; + if AppSettings.ReadBool(asLogTimestamp) then + LogItem.LineText := '['+FormatDateTime('hh:nn:ss.zzz', Now)+'] '+ Msg + else + LogItem.LineText := Msg; LogItem.Connection := Connection; PostponedLogItems.Add(LogItem); @@ -5207,8 +5628,6 @@ procedure TMainForm.LogSQL(Msg: String; Category: TDBLogCategory=lcInfo; Connect if csDestroying in ComponentState then Exit; - OldSettingsPath := AppSettings.SessionPath; - for LogItem in PostponedLogItems do begin // Log only wanted events @@ -5230,9 +5649,7 @@ procedure TMainForm.LogSQL(Msg: String; Category: TDBLogCategory=lcInfo; Connect snip := (MaxLineWidth > 0) and (Len > MaxLineWidth); IsSQL := LogItem.Category in [lcSQL, lcUserFiredSQL]; if snip then begin - Msg := - Copy(Msg, 0, MaxLineWidth) + - '/* '+f_('large SQL query (%s), snipped at %s characters', [FormatByteNumber(Len), FormatNumber(MaxLineWidth)]) + ' */'; + Msg := Copy(Msg, 1, MaxLineWidth) + '...'; end else if (not snip) and IsSQL then Msg := Msg + Delimiter; if not IsSQL then @@ -5255,7 +5672,7 @@ procedure TMainForm.LogSQL(Msg: String; Category: TDBLogCategory=lcInfo; Connect // Causes access violations on a reconnected session firing a user-query: // SynMemoSQLLog.Repaint; // SynMemoSQLLog.Update; - // See TDBConnection.Log and TQueryThread.LogFromOutside + // See TDBConnection.Log and TQueryThread.LogFromThread // See https://github.com/HeidiSQL/HeidiSQL/issues/57 // Log to file? @@ -5317,7 +5734,7 @@ procedure TMainForm.actAttachDatabaseExecute(Sender: TObject); try for i:=0 to NewFiles.Count-1 do begin // Remove path if it's the application directory - if ExtractFilePath(NewFiles[i]) = ExtractFilePath(Application.ExeName) then + if ExtractFilePath(NewFiles[i]) = GetAppDir then NewFiles[i] := ExtractFileName(NewFiles[i]); if OldFiles.IndexOf(NewFiles[i]) = -1 then begin OldFiles.Add(NewFiles[i]); @@ -5326,7 +5743,7 @@ procedure TMainForm.actAttachDatabaseExecute(Sender: TObject); end; end; AppSettings.SessionPath := Conn.Parameters.SessionPath; - AppSettings.WriteString(asHost, implodestr(DELIM, OldFiles)); + AppSettings.WriteString(asHost, Implode(DELIM, OldFiles)); RefreshTree; except on E:EDbError do begin @@ -5364,7 +5781,7 @@ procedure TMainForm.actDetachDatabaseExecute(Sender: TObject); end; end; AppSettings.SessionPath := Obj.Connection.Parameters.SessionPath; - AppSettings.WriteString(asHost, implodestr(DELIM, OldFiles)); + AppSettings.WriteString(asHost, Implode(DELIM, OldFiles)); RefreshTree; except on E:EDbError do begin @@ -5433,31 +5850,32 @@ procedure TMainForm.AnyGridAdvancedHeaderDraw(Sender: TVTHeader; var PaintInfo: THeaderPaintInfo; const Elements: THeaderPaintElements); var PaintArea, TextArea, IconArea, SortArea: TRect; - SortText, ColCaption: String; + SortText, ColCaption, ColIndex: String; TextSpace, ColSortIndex, NumCharTop: Integer; ColSortDirection: VirtualTrees.TSortDirection; - Size: TSize; - DC: HDC; + TextSize: TSize; + DeviceContext: HDC; DrawFormat: Cardinal; + ColInfo: TTableColumn; const NumSortChars: Array of Char = ['¹','²','³','⁴','⁵','⁶','⁷','⁸','⁹','⁺']; procedure GetSortIndex(Column: TVirtualTreeColumn; var SortIndex: Integer; var SortDirection: VirtualTrees.TSortDirection); - var i: Integer; + var + SortItem: TSortItem; begin SortIndex := -1; if Column.Owner.Header.Treeview = DataGrid then begin // Data grid supports multiple sorted columns - for i:=0 to Length(DataGridSortColumns)-1 do begin - if DataGridSortColumns[i].ColumnName = PaintInfo.Column.Text then begin - SortIndex := i; - if DataGridSortColumns[i].SortDirection = ORDER_ASC then - SortDirection := sdAscending - else - SortDirection := sdDescending; - Break; - end; + SortItem := FDataGridSortItems.FindByColumn(PaintInfo.Column.Text); + if Assigned(SortItem) then begin + SortIndex := FDataGridSortItems.IndexOf(SortItem); + if SortItem.Order = sioAscending then + SortDirection := sdAscending + else + SortDirection := sdDescending; end; + end else begin // We're in a query grid, supporting a single sorted column if Column.Owner.Header.SortColumn = Column.Index then begin @@ -5472,13 +5890,33 @@ procedure TMainForm.AnyGridAdvancedHeaderDraw(Sender: TVTHeader; PaintArea := PaintInfo.PaintRectangle; PaintArea.Inflate(-PaintInfo.Column.Margin, 0); - DC := PaintInfo.TargetCanvas.Handle; + DeviceContext := PaintInfo.TargetCanvas.Handle; // Draw column name. Code taken from TVirtualTreeColumns.DrawButtonText and modified for our needs if hpeText in Elements then begin + + TextArea := PaintArea; + SetBkMode(DeviceContext, TRANSPARENT); + DrawFormat := DT_TOP or DT_NOPREFIX or DT_LEFT; + + if AppSettings.ReadBool(asShowRowId) and (PaintInfo.Column.Index > 0) then begin + // Paint gray column number left to its caption + ColIndex := PaintInfo.Column.Index.ToString; + if Sender.Treeview = DataGrid then begin + ColInfo := SelectedTableColumns.FindByName(PaintInfo.Column.Text); + if Assigned(ColInfo) then + ColIndex := (SelectedTableColumns.IndexOf(ColInfo) + 1).ToString; + end; + + SetTextColor(DeviceContext, ColorToRGB(clGrayText)); + DrawTextW(DeviceContext, PWideChar(ColIndex), Length(ColIndex), PaintArea, DrawFormat); + // Move caption text to right + GetTextExtentPoint32W(DeviceContext, PWideChar(ColIndex), Length(ColIndex), TextSize); + Inc(TextArea.Left, TextSize.cx + 5); + end; + ColCaption := PaintInfo.Column.Text; // Leave space for icons - TextArea := PaintArea; if PaintInfo.Column.ImageIndex > -1 then Dec(TextArea.Right, Sender.Images.Width); GetSortIndex(PaintInfo.Column, ColSortIndex, ColSortDirection); @@ -5487,16 +5925,14 @@ procedure TMainForm.AnyGridAdvancedHeaderDraw(Sender: TVTHeader; if not (coWrapCaption in PaintInfo.Column.Options) then begin // Do we need to shorten the caption due to limited space? - GetTextExtentPoint32W(DC, PWideChar(ColCaption), Length(ColCaption), Size); + GetTextExtentPoint32W(DeviceContext, PWideChar(ColCaption), Length(ColCaption), TextSize); TextSpace := TextArea.Right - TextArea.Left; - if TextSpace < Size.cx then - ColCaption := VirtualTrees.Utils.ShortenString(DC, ColCaption, TextSpace); + if TextSpace < TextSize.cx then + ColCaption := VirtualTrees.Utils.ShortenString(DeviceContext, ColCaption, TextSpace); end; - SetBkMode(DC, TRANSPARENT); - SetTextColor(DC, ColorToRGB(clWindowText)); - DrawFormat := DT_TOP or DT_NOPREFIX or DT_LEFT; - DrawTextW(DC, PWideChar(ColCaption), Length(ColCaption), TextArea, DrawFormat); + SetTextColor(DeviceContext, ColorToRGB(clWindowText)); + DrawTextW(DeviceContext, PWideChar(ColCaption), Length(ColCaption), TextArea, DrawFormat); end; // Draw image, if any @@ -5512,9 +5948,9 @@ procedure TMainForm.AnyGridAdvancedHeaderDraw(Sender: TVTHeader; // Paint sort icon and number if hpeOverlay in Elements then begin SortArea := PaintArea; + Inc(SortArea.Left, SortArea.Width - Sender.Images.Width); GetSortIndex(PaintInfo.Column, ColSortIndex, ColSortDirection); if ColSortIndex > -1 then begin - Inc(SortArea.Left, SortArea.Width - Sender.Images.Width); // Prepare default font size, also if user selected a bigger one for the grid - we reserved a 16x16 space. // Font.Height + Font.Size must be set with these values to get this working, larger or smaller Size/Height // result in wrong size for multiple sort columns. @@ -5542,26 +5978,27 @@ procedure TMainForm.AnyGridAdvancedHeaderDraw(Sender: TVTHeader; procedure TMainForm.DataGridBeforePaint(Sender: TBaseVirtualTree; TargetCanvas: TCanvas); var vt: TVirtualStringTree; - Select: String; - RefreshingData, IsKeyColumn: Boolean; + Select, FixedFilter: String; + RefreshingData, IsKeyColumn, NeedFullColumns: Boolean; i, ColWidth, VisibleColumns, MaximumRows, FullColumnCount: Integer; ColMaxLen, Offset: Int64; - KeyCols, ColWidths, WantedColumnOrgnames: TStringList; - WantedColumns: TTableColumnList; - c: TTableColumn; + ColWidths, WantedColumnOrgnames: TStringList; + KeyCols, WantedColumns: TTableColumnList; + c, ColumnInKey: TTableColumn; OldScrollOffset: TPoint; DBObj: TDBObject; rx: TRegExpr; + OldCursor: TBufferCoord; + Col: TVirtualTreeColumn; procedure InitColumn(idx: Integer; TblCol: TTableColumn); var k: Integer; - Col: TVirtualTreeColumn; begin col := vt.Header.Columns.Add; col.Text := TblCol.Name; col.Hint := TblCol.Comment; - col.Options := col.Options + [coSmartResize]; + col.Options := col.Options + [coSmartResize, coEditable]; if DatagridHiddenColumns.IndexOf(TblCol.Name) > -1 then col.Options := col.Options - [coVisible]; // Column header icon @@ -5594,6 +6031,8 @@ procedure TMainForm.DataGridBeforePaint(Sender: TBaseVirtualTree; TargetCanvas: DBObj.Connection.Ping(True); if SelectedTableColumns.Count = 0 then begin + vt.Header.Columns.Clear; + vt.Clear; EnableDataTab(False); end else begin EnableDataTab(True); @@ -5623,9 +6062,12 @@ procedure TMainForm.DataGridBeforePaint(Sender: TBaseVirtualTree; TargetCanvas: WantedColumns := TTableColumnList.Create(False); WantedColumnOrgnames := TStringList.Create; FullColumnCount := 0; + // If any column has INVISIBLE attribute: + NeedFullColumns := False; for i:=0 to SelectedTableColumns.Count-1 do begin c := SelectedTableColumns[i]; - IsKeyColumn := KeyCols.IndexOf(c.Name) > -1; + ColumnInKey := KeyCols.FindByName(c.Name); + IsKeyColumn := Assigned(ColumnInKey); ColMaxLen := StrToInt64Def(c.LengthSet, 0); if (DatagridHiddenColumns.IndexOf(c.Name) = -1) or (IsKeyColumn) @@ -5637,10 +6079,10 @@ procedure TMainForm.DataGridBeforePaint(Sender: TBaseVirtualTree; TargetCanvas: and (not IsKeyColumn) // We need full length of any key column, so DataGridLoadFullRow() has the chance to fetch the right row and ((ColMaxLen > GRIDMAXDATA) or (ColMaxLen = 0)) // No need to blow SQL with LEFT() if column is shorter anyway then begin - Select := Select + DBObj.Connection.GetSQLSpecifity(spFuncLeft, [c.CastAsText, GRIDMAXDATA]) + ', '; - end else if DBObj.Connection.Parameters.IsAnyMSSQL and (c.DataType.Index=dtTimestamp) then begin + Select := Select + DBObj.Connection.SqlProvider.GetSql(qFuncLeft, [c.CastAsText, GRIDMAXDATA]) + ', '; + end else if DBObj.Connection.Parameters.IsAnyMSSQL and (c.DataType.Index=dbdtTimestamp) then begin Select := Select + ' CAST(' + DBObj.Connection.QuoteIdent(c.Name) + ' AS INT), '; - end else if DBObj.Connection.Parameters.IsAnyMSSQL and (c.DataType.Index=dtHierarchyid) then begin + end else if DBObj.Connection.Parameters.IsAnyMSSQL and (c.DataType.Index=dbdtHierarchyid) then begin Select := Select + ' CAST(' + DBObj.Connection.QuoteIdent(c.Name) + ' AS NVARCHAR('+IntToStr(GRIDMAXDATA)+')), '; end else begin Select := Select + ' ' + DBObj.Connection.QuoteIdent(c.Name) + ', '; @@ -5648,24 +6090,31 @@ procedure TMainForm.DataGridBeforePaint(Sender: TBaseVirtualTree; TargetCanvas: end; WantedColumns.Add(c); WantedColumnOrgnames.Add(c.Name); + NeedFullColumns := NeedFullColumns or c.Invisible; end; end; // Cut last comma Delete(Select, Length(Select)-1, 2); // Shorten the whole query if all columns are involved - if FullColumnCount = SelectedTableColumns.Count then + if (FullColumnCount = SelectedTableColumns.Count) and (not NeedFullColumns) then Select := '*'; // Include db name for cases in which dbtree is switching databases and pending updates are in process Select := Select + ' FROM '+DBObj.QuotedDbAndTableName; // Append WHERE clause, and gracefully allow superfluous WHERE from user input - if SynMemoFilter.GetTextLen > 0 then begin + // Also, don't add a "WHERE ..." when the filter contains comments only + if Length(Trim(TSQLBatch.GetSQLWithoutComments(SynMemoFilter.Text))) > 0 then begin rx := TRegExpr.Create; rx.ModifierI := True; rx.Expression := '^\s*WHERE\s+'; - SynMemoFilter.Text := rx.Replace(SynMemoFilter.Text, ''); + FixedFilter := rx.Replace(SynMemoFilter.Text, ''); + if FixedFilter <> SynMemoFilter.Text then begin + OldCursor := SynMemoFilter.CaretXY; + SynMemoFilter.Text := FixedFilter; + SynMemoFilter.CaretXY := OldCursor; + end; rx.Free; Select := Select + ' WHERE ' + SynMemoFilter.Text + CRLF; tbtnDataFilter.ImageIndex := 108; @@ -5674,10 +6123,10 @@ procedure TMainForm.DataGridBeforePaint(Sender: TBaseVirtualTree; TargetCanvas: SynMemoFilter.OnStatusChange(SynMemoFilter, []); // Append ORDER clause - if Length(DataGridSortColumns) > 0 then begin - Select := Select + ' ORDER BY ' + ComposeOrderClause(DataGridSortColumns); + if FDataGridSortItems.Count > 0 then begin + Select := Select + ' ORDER BY ' + FDataGridSortItems.ComposeOrderClause(DBObj.Connection); tbtnDataSorting.ImageIndex := 108; - tbtnDataSorting.Caption := _('Sorting') + ' ('+IntToStr(Length(DataGridSortColumns))+')'; + tbtnDataSorting.Caption := _('Sorting') + ' ('+IntToStr(FDataGridSortItems.Count)+')'; end else begin tbtnDataSorting.ImageIndex := 107; tbtnDataSorting.Caption := _('Sorting'); @@ -5724,9 +6173,16 @@ procedure TMainForm.DataGridBeforePaint(Sender: TBaseVirtualTree; TargetCanvas: // Set up grid column headers ShowStatusMsg(_('Setting up columns ...')); VisibleColumns := 0; + Col := vt.Header.Columns.Add; + Col.CaptionAlignment := taRightJustify; + Col.Alignment := taRightJustify; + Col.Options := col.Options + [coFixed]- [coAllowClick, coAllowFocus, coEditable, coResizable]; + if not AppSettings.ReadBool(asShowRowId) then + Col.Options := col.Options - [coVisible]; + Col.Text := '#'; for i:=0 to WantedColumns.Count-1 do begin InitColumn(i, WantedColumns[i]); - if coVisible in vt.Header.Columns[i].Options then + if coVisible in vt.Header.Columns[i+1].Options then Inc(VisibleColumns); end; @@ -5755,10 +6211,11 @@ procedure TMainForm.DataGridBeforePaint(Sender: TBaseVirtualTree; TargetCanvas: end; vt.EndUpdate; + ApplyFontToGrids; // Do not steel filter while writing filters if not SynMemoFilter.Focused then - vt.SetFocus; + vt.TrySetFocus; DataGridFocusedNodeIndex := Min(DataGridFocusedNodeIndex, Int64(vt.RootNodeCount)-1); SelectNode(vt, DataGridFocusedNodeIndex); @@ -5772,10 +6229,12 @@ procedure TMainForm.DataGridBeforePaint(Sender: TBaseVirtualTree; TargetCanvas: if (FDataGridLastClickedColumnHeader >= 0) and (FDataGridLastClickedColumnHeader < vt.Header.Columns.Count) then begin // See issue #3309 // Horizontal offset based on the left side of a just sorted column - OldScrollOffset.X := -(vt.Header.Columns[FDataGridLastClickedColumnHeader].Left - FDataGridLastClickedColumnLeftPos); + OldScrollOffset.X := -(vt.Header.Columns[FDataGridLastClickedColumnHeader].Left - vt.OffsetX - FDataGridLastClickedColumnLeftPos); // logsql('Fixing x-offset to '+OldScrollOffset.X.ToString + // ', FDataGridLastClickedColumnHeader:'+FDataGridLastClickedColumnHeader.ToString + - // ', FDataGridLastClickedColumnLeftPos: '+FDataGridLastClickedColumnLeftPos.ToString); + // ', FDataGridLastClickedColumnLeftPos: '+FDataGridLastClickedColumnLeftPos.ToString + + // ', vt.Header.Columns[FDataGridLastClickedColumnHeader].Left: '+vt.Header.Columns[FDataGridLastClickedColumnHeader].Left.ToString + // ); end; vt.OffsetXY := OldScrollOffset; @@ -5807,7 +6266,7 @@ procedure TMainForm.DataGridBeforePaint(Sender: TBaseVirtualTree; TargetCanvas: procedure TMainForm.DataGridColumnResize(Sender: TVTHeader; Column: TColumnIndex); begin // Remember current table after last column resizing so we can auto size them as long as this did not happen - if not (tsUpdating in Sender.Treeview.TreeStates) then + if not TBaseVirtualTree(Sender.Treeview).IsUpdating then FDataGridColumnWidthsCustomized := True; end; @@ -5819,6 +6278,7 @@ procedure TMainForm.DataGridColumnResize(Sender: TVTHeader; Column: TColumnIndex procedure TMainForm.DisplayRowCountStats(Sender: TBaseVirtualTree); var DBObject: TDBObject; + ObjInCache: PDBObject; IsFiltered, IsLimited: Boolean; cap: String; RowsTotal: Int64; @@ -5833,27 +6293,65 @@ procedure TMainForm.DisplayRowCountStats(Sender: TBaseVirtualTree); cap := ActiveDatabase + '.' + DBObject.Name; IsLimited := DataGridWantedRowCount <= Datagrid.RootNodeCount; IsFiltered := SynMemoFilter.GetTextLen > 0; - if DBObject.NodeType = lntTable then begin - if (not IsLimited) and (not IsFiltered) then - RowsTotal := DataGrid.RootNodeCount // No need to fetch via SHOW TABLE STATUS - else - RowsTotal := DBObject.RowCount(True); - if RowsTotal > -1 then begin - cap := cap + ': ' + FormatNumber(RowsTotal) + ' ' + _('rows total'); - if DBObject.Engine = 'InnoDB' then - cap := cap + ' ('+_('approximately')+')'; - // Display either LIMIT or WHERE effect, not both at the same time - if IsLimited then - cap := cap + ', '+_('limited to') + ' ' + FormatNumber(Datagrid.RootNodeCount) - else if IsFiltered then begin - if Datagrid.RootNodeCount = RowsTotal then - cap := cap + ', '+_('all rows match to filter') + case DBObject.NodeType of + lntTable: begin + if (not IsLimited) and (not IsFiltered) then begin + RowsTotal := DataGrid.RootNodeCount; // No need to fetch via SHOW TABLE STATUS + DBObject.RowsAreExact := True; + menuQueryExactRowCount.Enabled := False; + end + else begin + Screen.Cursor := crHourGlass; + if (not DBObject.RowsAreExact) or menuQueryExactRowCount.Checked then + RowsTotal := DBObject.RowCount(True, menuQueryExactRowCount.Checked) else - cap := cap + ', ' + FormatNumber(Datagrid.RootNodeCount) + ' '+_('rows match to filter'); + RowsTotal := DBObject.Rows; + Screen.Cursor := crDefault; + menuQueryExactRowCount.Enabled := True; + end; + if RowsTotal > -1 then begin + cap := cap + ': ' + FormatNumber(RowsTotal) + ' ' + _('rows total'); + if DBObject.Engine = 'InnoDB' then begin + if DBObject.RowsAreExact then + cap := cap + ' ('+_('exact')+')' + else + cap := cap + ' ('+_('approximately')+')'; + end; + // Display either LIMIT or WHERE effect, not both at the same time + if IsLimited then + cap := cap + ', '+_('limited to') + ' ' + FormatNumber(Datagrid.RootNodeCount) + else if IsFiltered then begin + if Datagrid.RootNodeCount = RowsTotal then + cap := cap + ', '+_('all rows match to filter') + else + cap := cap + ', ' + FormatNumber(Datagrid.RootNodeCount) + ' '+_('rows match to filter'); + end; + // Update cached object reference with new row count, which may enable "Data" option + // in table copy dialog. See issue #666 + if Assigned(DBtree.FocusedNode) then begin + ObjInCache := DBtree.GetNodeData(DBtree.FocusedNode); + if Assigned(ObjInCache) and ObjInCache.IsSameAs(DBObject) then begin + ObjInCache.Rows := RowsTotal; + ObjInCache.RowsAreExact := DBObject.RowsAreExact; + end; + end; end; end; + + lntView: begin + cap := cap + ': ' + FormatNumber(DataGrid.RootNodeCount) + ' ' + _('rows'); + end; end; lblDataTop.Caption := cap; + lblDataTop.Hint := cap; +end; + + +procedure TMainForm.menuQueryExactRowCountClick(Sender: TObject); +begin + // Activate exact row count mode and let DisplayRowCountStats do the rest + // See https://www.heidisql.com/forum.php?t=41310 + DisplayRowCountStats(DataGrid); end; @@ -5863,10 +6361,14 @@ procedure TMainForm.AnyGridInitNode(Sender: TBaseVirtualTree; ParentNode, Node: Idx: PInt64; begin // Display multiline grid rows + // Mark all nodes as multiline capable. Fixes painting issues with long lines. (?) + // See issue #1897 and https://www.heidisql.com/forum.php?t=41502 + // Laggy performance with large grid contents (?) if AppSettings.ReadInt(asGridRowLineCount) = 1 then Exclude(Node.States, vsMultiLine) else Include(Node.States, vsMultiLine); + Sender.NodeHeight[Node] := TVirtualStringTree(Sender).DefaultNodeHeight; // Node may have data already, if added via InsertRow if not (vsOnFreeNodeCallRequired in Node.States) then begin Idx := Sender.GetNodeData(Node); @@ -5894,19 +6396,25 @@ procedure TMainForm.PageControlMainChange(Sender: TObject); Exit; tab := PageControlMain.ActivePage; + // Query helpers need a hit here, since RefreshHelperNode now only does its update on the active tab + // See https://www.heidisql.com/forum.php?t=37961 + RefreshHelperNode(TQueryTab.HelperNodeColumns); + RefreshHelperNode(TQueryTab.HelperNodeSnippets); + RefreshHelperNode(TQueryTab.HelperNodeHistory); // Move focus to relevant controls in order for them to receive keyboard events. // Do this only if the user clicked the new tab. Not on automatic tab changes. if Sender = PageControlMain then begin - if tab = tabHost then PageControlHostChange(Sender) - else if tab = tabDatabase then ListTables.SetFocus + if tab = tabHost then + PageControlHostChange(Sender) + else if tab = tabDatabase then + ListTables.TrySetFocus else if tab = tabData then begin - if DataGrid.CanFocus and DataGrid.Enabled then - DataGrid.SetFocus; + DataGrid.TrySetFocus; end else if IsQueryTab(tab.PageIndex, True) then begin - ActiveQueryMemo.SetFocus; - ActiveQueryMemo.WordWrap := actQueryWordWrap.Checked; - SynMemoQueryStatusChange(ActiveQueryMemo, []); + QueryTabs.ActiveMemo.TrySetFocus; + QueryTabs.ActiveMemo.WordWrap := actQueryWordWrap.Checked; + SynMemoQueryStatusChange(QueryTabs.ActiveMemo, [scCaretX]); end; end; @@ -5943,8 +6451,9 @@ procedure TMainForm.PageControlHostChange(Sender: TObject); else if tab = tabProcesslist then list := ListProcesses else if tab = tabCommandStats then list := ListCommandStats else Exit; // Silence compiler warning - list.SetFocus; + list.TrySetFocus; UpdateFilterPanel(Sender); + PageControlTabHighlight(PageControlHost); end; @@ -6060,8 +6569,8 @@ procedure TMainForm.ListTablesGetText(Sender: TBaseVirtualTree; end; 1: if Obj.Rows > -1 then CellText := FormatNumber(Obj.Rows); 2: if Obj.Size > -1 then CellText := FormatByteNumber(Obj.Size); - 3: if Obj.Created <> 0 then CellText := DateTimeToStr(Obj.Created); - 4: if Obj.Updated <> 0 then CellText := DateTimeToStr(Obj.Updated); + 3: CellText := DateTimeToStrDef(Obj.Created, ''); + 4: CellText := DateTimeToStrDef(Obj.Updated, ''); 5: CellText := Obj.Engine; 6: CellText := Obj.Comment; 7: if Obj.Version > -1 then CellText := IntToStr(Obj.Version); @@ -6134,6 +6643,7 @@ procedure TMainForm.ValidateControls(Sender: TObject); RowNum: PInt64; CellText: String; Conn: TDBConnection; + ResultCol: Integer; begin // When adding some new TAction here, be sure to apply this procedure to its OnUpdate event @@ -6146,18 +6656,19 @@ procedure TMainForm.ValidateControls(Sender: TObject); CellText := ''; if HasConnection and Assigned(Grid) then begin Results := GridResult(Grid); + ResultCol := Grid.FocusedColumn -1; if (Results<>nil) and Assigned(Grid.FocusedNode) then begin RowNum := Grid.GetNodeData(Grid.FocusedNode); Results.RecNo := RowNum^; GridHasChanges := Results.Modified or Results.Inserted; - if Grid.FocusedColumn > NoColumn then begin - EnableTimestamp := Results.DataType(Grid.FocusedColumn).Category in [dtcInteger, dtcReal]; - CellText := Results.Col(Grid.FocusedColumn, True); + if ResultCol > NoColumn then begin + EnableTimestamp := Results.DataType(ResultCol).Category in [dtcInteger, dtcReal]; + CellText := Results.Col(ResultCol, True); end; end; end; - inDataTab := PageControlMain.ActivePage = tabData; - inDataOrQueryTab := inDataTab or QueryTabActive; + inDataTab := Grid = DataGrid; + inDataOrQueryTab := inDataTab or QueryTabs.HasActiveTab; inDataOrQueryTabNotEmpty := inDataOrQueryTab and Assigned(Grid) and (Grid.RootNodeCount > 0); inGrid := Assigned(Grid) and (ActiveControl = Grid); @@ -6172,19 +6683,20 @@ procedure TMainForm.ValidateControls(Sender: TObject); actDataCancelChanges.Enabled := HasConnection and GridHasChanges; actDataSaveBlobToFile.Enabled := HasConnection and inDataOrQueryTabNotEmpty and Assigned(Grid.FocusedNode); actGridEditFunction.Enabled := HasConnection and inDataOrQueryTabNotEmpty and Assigned(Grid.FocusedNode); + actDataEditWithoutLookup.Enabled := HasConnection and inDataTab; actDataPreview.Enabled := HasConnection and inDataOrQueryTabNotEmpty and Assigned(Grid.FocusedNode); actDataOpenUrl.Enabled := (Length(CellText) nil; inSynMemoEditable := inSynMemo and (not ActiveSynMemo(True).ReadOnly); @@ -6200,6 +6712,7 @@ procedure TMainForm.ValidateControls(Sender: TObject); ValidateQueryControls(Sender); UpdateLineCharPanel; + PageControlTabHighlight(PageControlMain); end; @@ -6208,8 +6721,15 @@ procedure TMainForm.ValidateQueryControls(Sender: TObject); NotEmpty, HasSelection, HasConnection: Boolean; Tab: TQueryTab; cap: String; - InQueryTab: Boolean; + InQueryTab, InEditorTab: Boolean; + Conn: TDBConnection; begin + // Enable/disable TActions, according to the current window/connection state + + // Prevent superfluous calls while setting up query tabs + if not MainFormAfterCreateDone then + Exit; + for Tab in QueryTabs do begin cap := Trim(Tab.TabSheet.Caption); if cap[Length(cap)] = '*' then @@ -6219,26 +6739,38 @@ procedure TMainForm.ValidateQueryControls(Sender: TObject); if Tab.TabSheet.Caption <> cap then SetTabCaption(Tab.TabSheet.PageIndex, cap); end; - InQueryTab := QueryTabActive; - Tab := ActiveQueryTab; + InQueryTab := QueryTabs.HasActiveTab; + InEditorTab := PageControlMain.ActivePage = tabEditor; + Tab := QueryTabs.ActiveTab; NotEmpty := InQueryTab and (Tab.Memo.GetTextLen > 0); HasSelection := InQueryTab and Tab.Memo.SelAvail; - HasConnection := ActiveConnection <> nil; + Conn := ActiveConnection; + HasConnection := Conn <> nil; actExecuteQuery.Enabled := HasConnection and InQueryTab and NotEmpty and (not Tab.QueryRunning); actExecuteSelection.Enabled := HasConnection and InQueryTab and HasSelection and (not Tab.QueryRunning); actExecuteCurrentQuery.Enabled := actExecuteQuery.Enabled; - actExplainAnalyzeCurrentQuery.Enabled := actExecuteQuery.Enabled; + actExplainCurrentQuery.Enabled := actExecuteQuery.Enabled and Conn.SqlProvider.Has(qExplain); actSaveSQLAs.Enabled := InQueryTab and NotEmpty; - actSaveSQL.Enabled := actSaveSQLAs.Enabled and Tab.Memo.Modified; + actSaveSQL.Enabled := (actSaveSQLAs.Enabled and Tab.Memo.Modified) or InEditorTab; actSaveSQLselection.Enabled := InQueryTab and HasSelection; actSaveSQLSnippet.Enabled := InQueryTab and NotEmpty; actSaveSQLSelectionSnippet.Enabled := InQueryTab and HasSelection; actClearQueryEditor.Enabled := InQueryTab; actSetDelimiter.Enabled := InQueryTab; actCloseQueryTab.Enabled := IsQueryTab(PageControlMain.ActivePageIndex, False); + actCloseAllQueryTabs.Enabled := QueryTabs.Count > 1; actCodeFoldingStartRegion.Enabled := InQueryTab; actCodeFoldingEndRegion.Enabled := InQueryTab; actCodeFoldingFoldSelection.Enabled := HasSelection; + if InQueryTab then begin + if HasConnection and (Conn.Parameters.SessionColor <> clNone) then begin + Tab.Memo.Gutter.Color := Conn.Parameters.SessionColor; + end + else begin + Tab.Memo.Gutter.Color := clBtnFace; + end; + end; + end; @@ -6261,10 +6793,10 @@ procedure TMainForm.KillProcess(Sender: TObject); if pid = Conn.ThreadId then LogSQL(f_('Ignoring own process id #%d when trying to kill it.', [pid])) else try - Conn.Query(Conn.GetSQLSpecifity(spKillProcess, [pid])); + Conn.Query(qKillQuery, [pid]); except on E:EDbError do begin - if Conn.LastErrorCode <> 1094 then + if Conn.LastErrorCode <> ER_NO_SUCH_THREAD then if MessageDialog(E.Message, mtError, [mbOK, mbAbort]) = mrAbort then break; end; @@ -6277,6 +6809,31 @@ procedure TMainForm.KillProcess(Sender: TObject); end; +procedure TMainForm.SynCompletionProposalChange(Sender: TObject; + AIndex: Integer); +var + Proposal: TSynCompletionProposal; + SelectedFuncName: String; + SQLFunc: TSQLFunction; +begin + Proposal := Sender as TSynCompletionProposal; + if (AIndex >= 0) and (AIndex < Proposal.ItemList.Count) then begin + Proposal.Title := Proposal.InsertItem(AIndex); + // Show function description in hint panel + ShowStatusMsg('', 0); + SelectedFuncName := RegExprGetMatch('}function\\column\{\}\\color\{\w+\}([^\\]+)\\', Proposal.DisplayItem(AIndex), 1); + if not SelectedFuncName.IsEmpty then begin + for SQLFunc in ActiveConnection.SQLFunctions do begin + if SQLFunc.Name.ToUpper = SelectedFuncName.ToUpper then begin + ShowStatusMsg(SQLFunc.Description.Replace(SLineBreak, ' '), 0); + Break; + end; + end; + end; + end; +end; + + { Proposal about to insert a String into synmemo } procedure TMainForm.SynCompletionProposalCodeCompletion(Sender: TObject; var Value: String; Shift: TShiftState; Index: Integer; EndToken: Char); @@ -6313,6 +6870,8 @@ procedure TMainForm.SynCompletionProposalCodeCompletion(Sender: TObject; end; rx.Free; Proposal.Form.CurrentEditor.UndoList.AddGroupBreak; + // Hide hint text added in .OnChange event + ShowStatusMsg('', 0); end; @@ -6336,11 +6895,12 @@ procedure TMainForm.SynCompletionProposalExecute(Kind: SynCompletionType; i, j, ImageIndex, ColumnsInList: Integer; Results: TDBQuery; DBObjects: TDBObjectList; - sql, TableClauses, TableName, LeftPart, Token1, Token2, Token3, Token, Ident: String; + CurrentQuery, TableClauses, TableName, LeftPart, Token1, Token2, Token3, Ident: String; Tables: TStringList; rx: TRegExpr; - Start, TokenTypeInt: Integer; - Attri: TSynHighlighterAttributes; + CaretToken: String; + CaretStart, CaretTokenTypeInt: Integer; + CaretAttri: TSynHighlighterAttributes; Proposal: TSynCompletionProposal; Editor: TCustomSynEdit; Queries: TSQLBatch; @@ -6348,10 +6908,11 @@ procedure TMainForm.SynCompletionProposalExecute(Kind: SynCompletionType; Conn: TDBConnection; RoutineEditor: TfrmRoutineEditor; Param: TRoutineParam; + DisplayText: String; + SQLFunc: TSQLFunction; procedure AddTable(Obj: TDBObject); var - DisplayText: String; FunctionDeclaration: String; FuncParams: TRoutineParamList; FuncParam: TRoutineParam; @@ -6371,8 +6932,7 @@ procedure TMainForm.SynCompletionProposalExecute(Kind: SynCompletionType; FuncParams.Free; end; - DisplayText := Format(SYNCOMPLETION_PATTERN, - [Obj.ImageIndex, LowerCase(_(Obj.ObjType)), Obj.Name, FunctionDeclaration]); + DisplayText := SynCompletionProposalPrettyText(Obj.ImageIndex, _(LowerCase(Obj.ObjType)), Obj.Name, FunctionDeclaration); Proposal.AddItem(DisplayText, Obj.Name+FunctionDeclaration); end; @@ -6381,12 +6941,13 @@ procedure TMainForm.SynCompletionProposalExecute(Kind: SynCompletionType; dbname, tblname: String; Columns: TTableColumnList; Col: TTableColumn; + Keys: TTableKeyList; Obj: TDBObject; begin dbname := ''; tblname := LeftToken; if Pos('.', tblname) > -1 then begin - dbname := Copy(tblname, 0, Pos('.', tblname)-1); + dbname := Copy(tblname, 1, Pos('.', tblname)-1); tblname := Copy(tblname, Pos('.', tblname)+1, Length(tblname)); end; // db and table name may already be quoted @@ -6398,9 +6959,14 @@ procedure TMainForm.SynCompletionProposalExecute(Kind: SynCompletionType; for Obj in DBObjects do begin if (Obj.Name.ToLowerInvariant = tblname.ToLowerInvariant) and (Obj.NodeType in [lntTable, lntView]) then begin Columns := Obj.TableColumns; + Keys := Obj.TableKeys; for Col in Columns do begin - Proposal.InsertList.Add(Col.Name); - Proposal.ItemList.Add(Format(SYNCOMPLETION_PATTERN, [ICONINDEX_FIELD, LowerCase(Col.DataType.Name), Col.Name, '']) ); + // Put formatted text and icon into proposal + DisplayText := SynCompletionProposalPrettyText(Keys.ImageIndex(Col.Name), LowerCase(Col.DataType.Name), Col.Name, Col.Comment, DatatypeCategories[Col.DataType.Category].NullColor); + if CurrentInput.StartsWith(Conn.QuoteChar) then + Proposal.AddItem(DisplayText, Conn.QuoteChar + Col.Name) + else + Proposal.AddItem(DisplayText, Col.Name); Inc(ColumnsInList); end; Columns.Free; @@ -6411,12 +6977,17 @@ procedure TMainForm.SynCompletionProposalExecute(Kind: SynCompletionType; begin Proposal := Sender as TSynCompletionProposal; + Proposal.Font.Assign(Font); + Proposal.TitleFont.Size := Proposal.Font.Size; + Proposal.ItemHeight := ScaleSize(PROPOSAL_ITEM_HEIGHT); Proposal.ClearList; + Proposal.Columns[0].ColumnWidth := ScaleSize(100); // Kind of random value, but fits well + Proposal.Columns[1].ColumnWidth := ScaleSize(100); Conn := ActiveConnection; Editor := Proposal.Form.CurrentEditor; - Editor.GetHighlighterAttriAtRowColEx(Editor.PrevWordPos, Token, TokenTypeInt, Start, Attri); + Editor.GetHighlighterAttriAtRowColEx(Editor.CaretXY, CaretToken, CaretTokenTypeInt, CaretStart, CaretAttri); CanExecute := AppSettings.ReadBool(asCompletionProposal) and - (not (TtkTokenKind(TokenTypeInt) in [SynHighlighterSQL.tkString, SynHighlighterSQL.tkComment])); + (not (TtkTokenKind(CaretTokenTypeInt) in [SynHighlighterSQL.tkString, SynHighlighterSQL.tkComment])); if not CanExecute then Exit; @@ -6426,7 +6997,7 @@ procedure TMainForm.SynCompletionProposalExecute(Kind: SynCompletionType; rx := TRegExpr.Create; // Find token1.token2.token3, while cursor is somewhere in token3 - Ident := '[^\s,\(\)=\.]'; + Ident := '[^\s,\(\)=\.\!<>]'; rx.Expression := '(('+Ident+'+)\.)?('+Ident+'+)\.('+Ident+'*)$'; LeftPart := Copy(Editor.LineText, 1, Editor.CaretX-1); if rx.Exec(LeftPart) then begin @@ -6442,8 +7013,8 @@ procedure TMainForm.SynCompletionProposalExecute(Kind: SynCompletionType; try Results := Conn.GetResults('SHOW '+UpperCase(rx.Match[1])+' VARIABLES'); while not Results.Eof do begin - Proposal.InsertList.Add(Results.Col(0)); - Proposal.ItemList.Add(Format(SYNCOMPLETION_PATTERN, [ICONINDEX_PRIMARYKEY, 'variable', Results.Col(0), ' ('+StringReplace(Results.Col(1), '\', '\\', [rfReplaceAll])+')'] ) ); + DisplayText := SynCompletionProposalPrettyText(ICONINDEX_PRIMARYKEY, _('Variable'), Results.Col(0), StringReplace(Results.Col(1), '\', '\\', [rfReplaceAll])); + Proposal.AddItem(DisplayText, Results.Col(0)); Results.Next; end; except @@ -6458,15 +7029,15 @@ procedure TMainForm.SynCompletionProposalExecute(Kind: SynCompletionType; // 1. find currently edited sql query around the cursor position in synmemo if Editor = SynMemoFilter then begin // Make sure the below regexp can find structure - sql := 'SELECT * FROM '+ActiveDbObj.QuotedName+' WHERE ' + Editor.Text; + CurrentQuery := 'SELECT * FROM '+ActiveDbObj.QuotedName+' WHERE ' + Editor.Text; end else begin // In a query tab - Queries := TSQLBatch.Create; + Queries := TSQLBatch.Create(Conn.Parameters.NetTypeGroup); Queries.SQL := Editor.Text; for Query in Queries do begin if (Query.LeftOffset <= Editor.SelStart) and (Editor.SelStart < Query.RightOffset) then begin - sql := Query.SQL; - break; + CurrentQuery := Query.SQLWithoutComments; + Break; end; end; Queries.Free; @@ -6476,10 +7047,10 @@ procedure TMainForm.SynCompletionProposalExecute(Kind: SynCompletionType; rx.ModifierG := True; rx.ModifierI := True; rx.Expression := '\b(FROM|INTO|UPDATE)\s+(IGNORE\s+)?(.+)(WHERE|HAVING|ORDER|GROUP)?'; - if rx.Exec(sql) then begin + if rx.Exec(CurrentQuery) then begin TableClauses := rx.Match[3]; // Ensure tables in JOIN clause(s) are splitted by comma - TableClauses := StringReplace(TableClauses, 'JOIN', ',', [rfReplaceAll, rfIgnoreCase]); + TableClauses := ReplaceRegExpr('\sJOIN\s', TableClauses, ',', [rroModifierI]); // Remove surrounding parentheses TableClauses := StringReplace(TableClauses, '(', ' ', [rfReplaceAll]); TableClauses := StringReplace(TableClauses, ')', ' ', [rfReplaceAll]); @@ -6539,8 +7110,8 @@ procedure TMainForm.SynCompletionProposalExecute(Kind: SynCompletionType; // All databases for i:=0 to Conn.AllDatabases.Count-1 do begin - Proposal.InsertList.Add(ActiveConnection.AllDatabases[i]); - Proposal.ItemList.Add(Format(SYNCOMPLETION_PATTERN, [ICONINDEX_DB, 'database', Conn.AllDatabases[i], ''])); + DisplayText := SynCompletionProposalPrettyText(ICONINDEX_DB, _('database'), Conn.AllDatabases[i], ''); + Proposal.AddItem(DisplayText, Conn.AllDatabases[i]); end; // Tables from current db @@ -6555,18 +7126,16 @@ procedure TMainForm.SynCompletionProposalExecute(Kind: SynCompletionType; end; // Functions - for i:=0 to Length(MySQLFunctions)-1 do begin - // Hide unsupported functions - if MySqlFunctions[i].Version > Conn.ServerVersionInt then - continue; - Proposal.InsertList.Add(MySQLFunctions[i].Name + MySQLFunctions[i].Declaration); - Proposal.ItemList.Add(Format(SYNCOMPLETION_PATTERN, [ICONINDEX_FUNCTION, 'function', MySQLFunctions[i].Name, MySQLFunctions[i].Declaration])); + for SQLFunc in Conn.SQLFunctions do begin + DisplayText := SynCompletionProposalPrettyText(ICONINDEX_FUNCTION, _('function'), SQLFunc.Name, SQLFunc.Declaration); + Proposal.AddItem(DisplayText, SQLFunc.Name + SQLFunc.Declaration); end; + // Keywords for i:=0 to MySQLKeywords.Count-1 do begin - Proposal.InsertList.Add(MySQLKeywords[i]); - Proposal.ItemList.Add(Format(SYNCOMPLETION_PATTERN, [ICONINDEX_KEYWORD, 'keyword', MySQLKeywords[i], '']) ); + DisplayText := SynCompletionProposalPrettyText(ICONINDEX_KEYWORD, _('keyword'), MySQLKeywords[i], ''); + Proposal.AddItem(DisplayText, MySQLKeywords[i]); end; // Procedure params @@ -6577,8 +7146,8 @@ procedure TMainForm.SynCompletionProposalExecute(Kind: SynCompletionType; else if Param.Context = 'OUT' then ImageIndex := 121 else if Param.Context = 'INOUT' then ImageIndex := 122 else ImageIndex := -1; - Proposal.InsertList.Add(Param.Name); - Proposal.ItemList.Add(Format(SYNCOMPLETION_PATTERN, [ImageIndex, Param.Datatype, Param.Name, ''])); + DisplayText := SynCompletionProposalPrettyText(ImageIndex, Param.Datatype, Param.Name, ''); + Proposal.AddItem(DisplayText, Param.Name); end; end; @@ -6609,39 +7178,225 @@ procedure TMainForm.SynMemoQueryScanForFoldRanges(Sender: TObject; end; -procedure TMainForm.SynMemoQueryStatusChange(Sender: TObject; Changes: - TSynStatusChanges); +procedure TMainForm.SynMemoQuerySpecialLineColors(Sender: TObject; + Line: Integer; var Special: Boolean; var FG, BG: TColor); var Edit: TSynMemo; + Tab: TQueryTab; begin - // Don't ask for saving empty contents. See issue #614 + // Paint error line with red background Edit := Sender as TSynMemo; - if Edit.GetTextLen = 0 then begin - ActiveQueryTab.MemoFilename := ''; - ActiveQueryTab.Memo.Modified := False; + Tab := QueryTabs.TabByControl(Edit); + if Tab <> QueryTabs.ActiveTab then + Exit; + if Line = Tab.ErrorLine then begin + Special := True; + FG := ErrorLineForeground; + BG := ErrorLineBackground; end; - // Update various controls - ValidateQueryControls(Sender); - UpdateLineCharPanel; end; - -procedure TMainForm.TimerHostUptimeTimer(Sender: TObject); +procedure TMainForm.SynMemoSQLLogSpecialLineColors(Sender: TObject; + Line: Integer; var Special: Boolean; var FG, BG: TColor); var - Conn: TDBConnection; - Uptime: Integer; - ServerNow: TDateTime; - ServerNowStr: String; + Edit: TSynMemo; + LineText, Search: String; begin - // Display server uptime and current date time - Conn := ActiveConnection; - if Assigned(Conn) then begin - Uptime := Conn.ServerUptime; - if Uptime >= 0 then - ShowStatusMsg(_('Uptime')+': '+FormatTimeNumber(Conn.ServerUptime, False), 4) - else - ShowStatusMsg(_('Uptime')+': '+_('unknown'), 4); + // Paint error line with red background, or warning in orange + Edit := Sender as TSynMemo; + LineText := Copy(Edit.Lines[Line-1], 1, 100); + Search := _(MsgSQLError); + Search := Copy(Search, 1, Pos('%', Search)-1); + //Logsql(LineText+' ::: '+Search); + if LineText.Contains(Search) then begin + Special := True; + FG := ErrorLineForeground; + BG := ErrorLineBackground; + end + else if LineText.Contains(_(SLogPrefixWarning)+':') then begin + Special := True; + FG := WarningLineForeground; + BG := WarningLineBackground; + end + else if LineText.Contains(_(SLogPrefixNote)+':') then begin + Special := True; + FG := NoteLineForeground; + BG := NoteLineBackground; + end + else if LineText.Contains(_(SLogPrefixInfo)+':') then begin + Special := True; + FG := InfoLineForeground; + BG := InfoLineBackground; + end; +end; + + +procedure TMainForm.SynMemoQueryStatusChange(Sender: TObject; Changes: TSynStatusChanges); +var + Edit: TSynMemo; + Tab: TQueryTab; + ContentOrCursor: Boolean; +begin + if not MainFormAfterCreateDone then + Exit; + + Edit := Sender as TSynMemo; + Tab := QueryTabs.TabByControl(Edit); + if Tab <> QueryTabs.ActiveTab then + Exit; + + ContentOrCursor := (scCaretX in Changes) or (scCaretY in Changes) or (scModified in Changes); + if ContentOrCursor then begin + // Disable error marker + Tab.ErrorLine := -1; + + // Check if bind param detection is enabled for text size <1M + // Uncheck checkbox if it's bigger + // Code moved back from TQueryTab.MemoOnChange here + Tab.TimerLastChange.Enabled := False; + Tab.FLastChange := Now; + Tab.TimerLastChange.Enabled := True; + + // Don't ask for saving empty contents. See issue #614 + if Edit.GetTextLen = 0 then begin + Tab.MemoFilename := ''; + Tab.Memo.Modified := False; + end; + + // Update various controls + ValidateQueryControls(Sender); + + UpdateLineCharPanel; + end; +end; + + +procedure TMainForm.SynMemoQueryTokenHint(Sender: TObject; Coords: TBufferCoord; + const Token: string; TokenType: Integer; Attri: TSynHighlighterAttributes; + var HintText: string); +var + SQLFunc: TSQLFunction; + Conn: TDBConnection; + AllObjects: TDBObjectList; + Obj: TDBObject; + i, ColumnNameChars: Integer; + Column: TTableColumn; + Parameters: TRoutineParamList; + Params: TStringList; + Param: TRoutineParam; +begin + // Activate hint for SQL function in query editors + Conn := ActiveConnection; + if Assigned(Conn) then begin + case TtkTokenKind(TokenType) of + + SynHighlighterSQL.tkFunction: begin + for SQLFunc in ActiveConnection.SQLFunctions do begin + if SQLFunc.Name.ToUpper = Token.ToUpper then begin + HintText := SQLFunc.Name + SQLFunc.Declaration + sLineBreak + sLineBreak + SQLFunc.Description; + Break; + end; + end; + end; + + SynHighlighterSQL.tkTableName: begin + // Show some details from table listing cache + if (not Conn.IsLockedByThread) and Conn.DbObjectsCached(Conn.Database) then begin + AllObjects := Conn.GetDBObjects(Conn.Database); + for Obj in AllObjects do begin + if (Obj.NodeType = lntTable) and (Obj.Name.ToLower = Token.ToLower) then begin + HintText := _(Obj.ObjType) + ' ' + Obj.Name + ':' + sLineBreak + + _('Rows') + ': ' + FormatNumber(Obj.Rows) + sLineBreak + + _('Size') + ': ' + FormatByteNumber(Obj.DataLen + Obj.IndexLen) + SLineBreak; + ColumnNameChars := 0; + for Column in Obj.TableColumns do begin + ColumnNameChars := Max(ColumnNameChars, Length(Column.Name)); + end; + for Column in Obj.TableColumns do begin + HintText := HintText + Format('%s%'+ColumnNameChars.ToString+'s: %s', [SLineBreak, Column.Name, Column.FullDataType]); + end; + + Break; + end; + end; + end; + end; + + SynHighlighterSQL.tkProcName: begin + // Show routine parameters, comment and body + if (not Conn.IsLockedByThread) and Conn.DbObjectsCached(Conn.Database) then begin + AllObjects := Conn.GetDBObjects(Conn.Database); + for Obj in AllObjects do begin + if (Obj.NodeType in [lntFunction, lntProcedure]) and (Obj.Name.ToLower = Token.ToLower) then begin + Parameters := TRoutineParamList.Create; + Conn.ParseRoutineStructure(Obj, Parameters); + HintText := _(Obj.ObjType) + ' ' + Obj.Name; + Params := TStringList.Create; + for Param in Parameters do begin + Params.Add(Param.Name + ' ['+Param.Datatype+']'); + end; + HintText := HintText + '(' + Implode(', ', Params) + ')' + sLineBreak + sLineBreak; + Params.Free; + if not Obj.Returns.IsEmpty then + HintText := HintText + 'Returns: ' + Obj.Returns + sLineBreak + sLineBreak; + if not Obj.Comment.IsEmpty then + HintText := HintText + Obj.Comment + sLineBreak + sLineBreak; + if not Obj.Body.IsEmpty then + HintText := HintText + StrEllipsis(Obj.Body, SIZE_KB); + HintText := Trim(HintText); + Break; + end; + end; + end; + end; + + SynHighlighterSQL.tkDatatype: begin + for i:=Low(Conn.Datatypes) to High(Conn.Datatypes) do begin + if Conn.Datatypes[i].Name.ToLower = Token.ToLower then begin + HintText := WrapText(Conn.Datatypes[i].Description, 100); + Break; + end; + end; + end; + + { Keywords consist of more than one word too often, so this would be of zero help for the user: + SynHighlighterSQL.tkKey: begin + if Conn.Parameters.IsAnyMySQL then begin + if not Assigned(FHelpData) then + FHelpData := TSimpleKeyValuePairs.Create; + if not FHelpData.TryGetValue(Token, HintText) then begin + HintText := Conn.GetVar('HELP '+Conn.EscapeString(Token), 1); + if (HintText.ToUpper = 'Y') or (HintText.ToUpper = 'N') then + HintText := ''; + FHelpData.Add(Token, HintText); + end; + end; + end; } + + SynHighlighterSQL.tkString: begin + HintText := _('String:') + ' ' + FormatByteNumber(Length(Token)); + end; + + end; + end; +end; + +procedure TMainForm.TimerHostUptimeTimer(Sender: TObject); +var + Conn: TDBConnection; + Uptime: Integer; + ServerNow: TDateTime; + ServerNowStr: String; +begin + // Display server uptime and current date time + Conn := ActiveConnection; + if Assigned(Conn) then begin + Uptime := Conn.ServerUptime; + if Uptime >= 0 then + ShowStatusMsg(_('Uptime')+': '+FormatTimeNumber(Conn.ServerUptime, False), 4) + else + ShowStatusMsg(_('Uptime')+': '+_('unknown'), 4); ServerNow := Conn.ServerNow; if ServerNow >= 0 then begin @@ -6656,6 +7411,14 @@ procedure TMainForm.TimerHostUptimeTimer(Sender: TObject); end; +procedure TMainForm.TimerRefreshTimer(Sender: TObject); +begin + // Auto-refreshing grid or list. Only if main form is active, to prevent issues like #669 + if Screen.ActiveForm = Self then + actRefresh.Execute; +end; + + procedure TMainForm.ListTablesEditing(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; var Allowed: Boolean); var @@ -6686,9 +7449,9 @@ procedure TMainForm.ListTablesNewText(Sender: TBaseVirtualTree; Node: // rename table case Obj.NodeType of lntTable: - sql := Obj.Connection.GetSQLSpecifity(spRenameTable); + sql := Obj.Connection.SqlProvider.GetSql(qRenameTable); lntView: - sql := Obj.Connection.GetSQLSpecifity(spRenameView); + sql := Obj.Connection.SqlProvider.GetSql(qRenameView); else raise EDbError.Create('Cannot rename '+Obj.ObjType); end; @@ -6731,11 +7494,15 @@ procedure TMainForm.TimerConnectedTimer(Sender: TObject); procedure TMainForm.Copylinetonewquerytab1Click(Sender: TObject); var Tab: TQueryTab; + LineText: String; begin // Create new query tab with current line in SQL log. This is for lazy mouse users. if actNewQueryTab.Execute then begin Tab := QueryTabs[MainForm.QueryTabs.Count-1]; - Tab.Memo.Text := SynMemoSQLLog.LineText; + LineText := SynMemoSQLLog.LineText; + if AppSettings.ReadBool(asLogTimestamp) then + LineText := ReplaceRegExpr('^\s*\[[^\]]+\]\s', LineText, ''); + Tab.Memo.Text := LineText; end; end; @@ -6743,9 +7510,12 @@ procedure TMainForm.Copylinetonewquerytab1Click(Sender: TObject); procedure TMainForm.QuickFilterClick(Sender: TObject); var Filter, Val, Col: String; + TableCol: TTableColumn; Act: TAction; Item: TMenuItem; Conn: TDBConnection; + ShiftKeyPressed: Boolean; + OldDataLocalNumberFormat: Boolean; begin // Set filter for "where..."-clause if (PageControlMain.ActivePage <> tabData) or (DataGrid.FocusedColumn = NoColumn) then @@ -6753,30 +7523,37 @@ procedure TMainForm.QuickFilterClick(Sender: TObject); Filter := ''; Conn := ActiveConnection; + ShiftKeyPressed := KeyPressed(VK_SHIFT); if Sender is TAction then begin // Normal case for most quick filters Act := Sender as TAction; if ExecRegExpr('Prompt\d+$', Act.Name) then begin // Item needs prompt - Col := DataGrid.Header.Columns[DataGrid.FocusedColumn].Text; - Col := Conn.QuoteIdent(Col, False); - if (SelectedTableFocusedColumn.DataType.Index = dtJson) - and (Conn.Parameters.NetTypeGroup = ngPgSQL) then begin - Col := Col + '::text'; - end; - Val := DataGrid.Text[DataGrid.FocusedNode, DataGrid.FocusedColumn]; - if InputQuery(_('Specify filter-value...'), Act.Caption, Val) then begin - if Act = actQuickFilterPrompt1 then - Filter := Col + ' = ''' + Val + '''' - else if Act = actQuickFilterPrompt2 then - Filter := Col + ' != ''' + Val + '''' - else if Act = actQuickFilterPrompt3 then - Filter := Col + ' > ''' + Val + '''' - else if Act = actQuickFilterPrompt4 then - Filter := Col + ' < ''' + Val + '''' - else if Act = actQuickFilterPrompt5 then - Filter := Conn.GetSQLSpecifity(spLikeCompare, [Col, '''%' + Val + '%''']); + TableCol := SelectedTableFocusedColumn; + if Assigned(TableCol) then begin + Col := Conn.QuoteIdent(TableCol.Name, False); + + if (TableCol.DataType.Index = dbdtJson) + and (Conn.Parameters.NetTypeGroup = ngPgSQL) then begin + Col := Col + '::text'; + end; + OldDataLocalNumberFormat := DataLocalNumberFormat; + DataLocalNumberFormat := False; + Val := DataGrid.Text[DataGrid.FocusedNode, DataGrid.FocusedColumn]; + DataLocalNumberFormat := OldDataLocalNumberFormat; + if InputQuery(_('Specify filter-value...'), Act.Caption, Val) then begin + if Act = actQuickFilterPrompt1 then + Filter := Col + ' = ' + Conn.EscapeString(Val, TableCol.DataType) + else if Act = actQuickFilterPrompt2 then + Filter := Col + ' != ' + Conn.EscapeString(Val, TableCol.DataType) + else if Act = actQuickFilterPrompt3 then + Filter := Col + ' > ' + Conn.EscapeString(Val, TableCol.DataType) + else if Act = actQuickFilterPrompt4 then + Filter := Col + ' < ' + Conn.EscapeString(Val, TableCol.DataType) + else if Act = actQuickFilterPrompt5 then + Filter := Conn.SqlProvider.GetSql(qLikeCompare, [Col, Conn.EscapeString('%'+Val+'%', TableCol.DataType)]); + end; end; end else begin @@ -6795,7 +7572,7 @@ procedure TMainForm.QuickFilterClick(Sender: TObject); SynMemoFilter.UndoList.AddGroupBreak; SynMemoFilter.SelectAll; - if KeyPressed(VK_SHIFT) + if ShiftKeyPressed and (Pos(Filter, SynMemoFilter.Text) = 0) and (Pos(SynMemoFilter.Text, Filter) = 0) and (not SynMemoFilter.Text.Trim.IsEmpty) then begin @@ -6810,9 +7587,41 @@ procedure TMainForm.QuickFilterClick(Sender: TObject); procedure TMainForm.popupQueryPopup(Sender: TObject); +var + SQLFuncs: TSQLFunctionList; + i, j: Integer; + miGroup, miFunction: TMenuItem; begin // Sets cursor into memo and activates TAction(s) like paste - ActiveQueryMemo.SetFocus; + QueryTabs.ActiveMemo.SetFocus; + // Create function menu items in popup menu + menuQueryInsertFunction.Clear; + SQLFuncs := ActiveConnection.SQLFunctions; + for i:=0 to SQLFuncs.Categories.Count-1 do begin + // Create a menu item which gets subitems later + miGroup := TMenuItem.Create(popupQuery); + miGroup.Caption := SQLFuncs.Categories[i]; + menuQueryInsertFunction.Add(miGroup); + for j:=0 to SQLFuncs.Count-1 do begin + if SQLFuncs[j].Category <> SQLFuncs.Categories[i] then + Continue; + miFunction := TMenuItem.Create(popupQuery); + miFunction.Caption := SQLFuncs[j].Name; + miFunction.ImageIndex := 13; + // Prevent generating a hotkey + miFunction.Caption := StringReplace(miFunction.Caption, '&', '&&', [rfReplaceAll]); + // Prevent generating a seperator line + if miFunction.Caption = '-' then + miFunction.Caption := '&-'; + miFunction.Hint := SQLFuncs[j].Name + SQLFuncs[j].Declaration + ' - ' + StrEllipsis(SQLFuncs[j].Description, 200); + // Prevent generating a seperator for ShortHint and LongHint + miFunction.Hint := StringReplace( miFunction.Hint, '|', '¦', [rfReplaceAll] ); + miFunction.Tag := j; + // Place menuitem on menu + miFunction.OnClick := insertFunction; + miGroup.Add(miFunction); + end; + end; end; @@ -6858,10 +7667,10 @@ procedure TMainForm.SynMemoQueryDragOver(Sender, Source: TObject; X, H: TVirtualStringTree; begin // dragging an object over the query-memo - Memo := ActiveQueryMemo; + Memo := QueryTabs.ActiveMemo; src := Source as TControl; // Accepting drag's from the same editor, from DBTree and from QueryHelpers - H := ActiveQueryHelpers; + H := QueryTabs.ActiveHelpersTree; Accept := (src = DBtree) or ((src = H) and Assigned(H.FocusedNode) and (H.GetNodeLevel(H.FocusedNode) in [1,2])); // set x-position of cursor Memo.CaretX := (x - Memo.Gutter.Width) div Memo.CharWidth - 1 + Memo.LeftChar; @@ -6883,37 +7692,41 @@ procedure TMainForm.SynMemoQueryDragDrop(Sender, Source: TObject; X, History: TQueryHistory; begin // dropping a tree node or listbox item into the query-memo - ActiveQueryMemo.UndoList.AddGroupBreak; + QueryTabs.ActiveMemo.UndoList.AddGroupBreak; src := Source as TControl; Text := ''; ShiftPressed := KeyPressed(VK_SHIFT); - Tree := ActiveQueryHelpers; + Tree := QueryTabs.ActiveHelpersTree; // Check for allowed controls as source has already // been performed in OnDragOver. So, only do typecasting here. if src = DBtree then begin // Insert table or database name. If a table is dropped and Shift is pressed, prepend the db name. case ActiveDbObj.NodeType of lntDb: Text := ActiveDbObj.QuotedDatabase(False); - lntTable..lntEvent: begin - if ShiftPressed then - Text := ActiveDbObj.QuotedDatabase(False) + '.'; - Text := Text + ActiveDbObj.QuotedName(False); + lntTable..lntEvent, lntColumn: begin + Text := ''; + if ShiftPressed then begin + Text := Text + ActiveDbObj.QuotedDatabase(False) + '.'; + if ActiveDbObj.NodeType = lntColumn then + Text := Text + ActiveDbObj.QuotedName(False) + '.'; + end; + Text := Text + ActiveDbObj.Connection.QuoteIdent(DBtree.Text[DBtree.FocusedNode, DBtree.FocusedColumn], False); end; end; end else if src = Tree then begin case Tree.GetNodeLevel(Tree.FocusedNode) of 1: case Tree.FocusedNode.Parent.Index of - HELPERNODE_SNIPPETS: - Text := ReadTextFile(AppSettings.DirnameSnippets + Tree.Text[Tree.FocusedNode, 0] + '.sql', nil); - HELPERNODE_HISTORY: + TQueryTab.HelperNodeSnippets: + Text := ReadTextFile(AppSettings.DirnameSnippets + Tree.Text[Tree.FocusedNode, 0] + FILEEXT_SNIPPET, nil); + TQueryTab.HelperNodeHistory: Text := ''; else begin Node := Tree.GetFirstChild(Tree.FocusedNode.Parent); while Assigned(Node) do begin if Tree.Selected[Node] then begin ItemText := Tree.Text[Node, 0]; - if Node.Parent.Index = HELPERNODE_COLUMNS then + if Node.Parent.Index = TQueryTab.HelperNodeColumns then ItemText := ActiveConnection.QuoteIdent(ItemText, False); // Quote column names if ShiftPressed then Text := Text + ItemText + ',' + CRLF @@ -6927,8 +7740,8 @@ procedure TMainForm.SynMemoQueryDragDrop(Sender, Source: TObject; X, end; 2: case Tree.FocusedNode.Parent.Parent.Index of - HELPERNODE_HISTORY: begin - History := ActiveQueryTab.HistoryDays.Objects[Tree.FocusedNode.Parent.Index] as TQueryHistory; + TQueryTab.HelperNodeHistory: begin + History := QueryTabs.ActiveTab.HistoryDays.Objects[Tree.FocusedNode.Parent.Index] as TQueryHistory; Text := History[Tree.FocusedNode.Index].SQL; end; end; @@ -6937,10 +7750,10 @@ procedure TMainForm.SynMemoQueryDragDrop(Sender, Source: TObject; X, raise Exception.Create(_('Unspecified source control in drag''n drop operation!')); if Text <> '' then begin - ActiveQueryMemo.SelText := Text; - ActiveQueryMemo.UndoList.AddGroupBreak; + QueryTabs.ActiveMemo.SelText := Text; + QueryTabs.ActiveMemo.UndoList.AddGroupBreak; // Requires to set focus, as doubleclick actions also call this procedure - ActiveQueryMemo.SetFocus; + QueryTabs.ActiveMemo.SetFocus; end; end; @@ -6948,18 +7761,10 @@ procedure TMainForm.SynMemoQueryDragDrop(Sender, Source: TObject; X, procedure TMainForm.SynMemoQueryDropFiles(Sender: TObject; X, Y: Integer; AFiles: TUnicodeStrings); -var - i: Integer; - Tab: TQueryTab; begin // One or more files from explorer or somewhere else was dropped onto the // query-memo - load their contents into seperate tabs - if not RunQueryFiles(AFiles, nil, False) then begin - for i:=0 to AFiles.Count-1 do begin - Tab := GetOrCreateEmptyQueryTab; - Tab.LoadContents(AFiles[i], False, nil); - end; - end; + OpenQueryFiles(AFiles, nil, False); end; @@ -6973,6 +7778,7 @@ procedure TMainForm.SynMemoQueryKeyPress(Sender: TObject; var Key: Char); //OldSelStart, OldSelEnd: Integer; LineWithToken: String; TableIndex, ProcIndex: Integer; + OldOnChange: TNotifyEvent; const WordChars = ['A'..'Z', 'a'..'z', '_']; IgnoreChars = [#8]; // Backspace, and probably more which should not trigger uppercase @@ -7015,7 +7821,10 @@ procedure TMainForm.SynMemoQueryKeyPress(Sender: TObject; var Key: Char); //OldSelEnd := Editor.SelEnd; EndOfTokenRowCol := Editor.WordEndEx(StartOfTokenRowCol); + OldOnChange := Editor.OnChange; + Editor.OnChange := nil; Editor.InsertBlock(StartOfTokenRowCol, EndOfTokenRowCol, PWideChar(Replacement), True); + Editor.OnChange := OldOnChange; Editor.CaretXY := OldCaretXY; //Editor.SelStart := OldSelStart; // breaks at least some undo steps @@ -7056,7 +7865,7 @@ procedure TMainForm.SynMemoQueryKeyPress(Sender: TObject; var Key: Char); end; -procedure TMainForm.SynMemoQueryMouseWheel(Sender: TObject; Shift: TShiftState; +procedure TMainForm.AnySynMemoMouseWheel(Sender: TObject; Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean); var Editor: TSynEdit; @@ -7074,6 +7883,7 @@ procedure TMainForm.SynMemoQueryMouseWheel(Sender: TObject; Shift: TShiftState; NewFontSize := Max(NewFontSize, 1); AppSettings.ResetPath; AppSettings.WriteInt(asFontSize, NewFontSize); + Editor.Font.Size := NewFontSize; SetupSynEditors; Handled := True; end else begin @@ -7085,104 +7895,154 @@ procedure TMainForm.SynMemoQueryMouseWheel(Sender: TObject; Shift: TShiftState; procedure TMainForm.SynMemoQueryPaintTransient(Sender: TObject; Canvas: TCanvas; TransientType: TTransientType); var Editor : TSynEdit; - OpenChars: array of Char; - CloseChars: array of Char; - P: TBufferCoord; + BufCrd: TBufferCoord; Pix: TPoint; - D: TDisplayCoord; + DisCrd: TDisplayCoord; + Pnt: TPoint; S: String; - I: Integer; + I, SearchPos, CharIndex: Integer; Attri: TSynHighlighterAttributes; - ArrayLength: Integer; - start: Integer; + SelStart: Integer; TmpCharA, TmpCharB: Char; - - function IsCharBracket(AChar: Char): Boolean; - begin - Result := CharInSet(AChar, ['{','[','(','<','}',']',')','>']); - end; + rx: TRegExpr; + SelWord, Line: String; +const + BracketChars: TSysCharSet = ['{','[','(','<','}',']',')','>']; + OpenChars: Array of Char = ['{','[','(','<']; + CloseChars: Array of Char = ['}',']',')','>']; function CharToPixels(P: TBufferCoord): TPoint; begin Result := Editor.RowColumnToPixels(Editor.BufferToDisplayPos(P)); end; begin - // Highlight matching brackets - Editor := TSynEdit(Sender); - if Editor.SelAvail then exit; - ArrayLength := 3; + if not MainFormCreated then + Exit; + if (FMatchingBraceBackgroundColor = clNone) and (FMatchingBraceForegroundColor = clNone) then + Exit; + if FSynEditInOnPaintTransient then + Exit; + FSynEditInOnPaintTransient := True; - SetLength(OpenChars, ArrayLength); - SetLength(CloseChars, ArrayLength); - for i := 0 to ArrayLength - 1 do - Case i of - 0: begin OpenChars[i] := '('; CloseChars[i] := ')'; end; - 1: begin OpenChars[i] := '{'; CloseChars[i] := '}'; end; - 2: begin OpenChars[i] := '['; CloseChars[i] := ']'; end; - 3: begin OpenChars[i] := '<'; CloseChars[i] := '>'; end; + Editor := TSynEdit(Sender); + // Check for Editor.GetTextLen causes some endless loop in SynEdit. + // But not due to activated WordWrap. Must be some interlocked WM_GETTEXTLENGTH message, or an undefined text length. + //if Editor.GetTextLen > 5*SIZE_MB then + // Exit; + + // Highlight matching words, if selected text is a (small) word + if Editor.SelLength < Editor.CharsInWindow then begin + SelWord := Editor.SelText; + BufCrd := Editor.CaretXY; + CharIndex := Editor.RowColToCharIndex(BufCrd); + // Ensure GetWordAtRowCol finds the word by moving Char to the left of the selection + BufCrd.Char := Max(0, BufCrd.Char - (CharIndex - Editor.SelStart)); + if SelWord <> FLastSelWordInEditor then + Editor.Invalidate; // causes lots of additional implicit calls to OnPaintTransient + FLastSelWordInEditor := SelWord; + if (not SelWord.IsEmpty) and (SelWord = Editor.GetWordAtRowCol(BufCrd)) then begin + rx := TRegExpr.Create; + rx.Expression := '\b(' + QuoteRegExprMetaChars(SelWord) + ')\b'; + rx.ModifierI := True; + // Note: TopLine is wrong when lines are soft-wrapped, so we use RowToLine + for i:=Editor.RowToLine(Editor.TopLine) to Editor.RowToLine(Editor.TopLine + Editor.LinesInWindow) do begin + Line := Editor.Lines[i-1]; + if rx.Exec(Line) then while True do begin + SearchPos := rx.MatchPos[1]; + BufCrd := BufferCoord(SearchPos, i); + DisCrd := Editor.BufferToDisplayPos(BufCrd); + Pnt := Editor.RowColumnToPixels(DisCrd); + if (not Editor.IsPointInSelection(BufCrd)) // Found match is not the selection itself + and Editor.GetHighlighterAttriAtRowCol(BufCrd, SelWord, Attri) + then begin + //logsql(SelWord+': '+Attri.FriendlyName); + Canvas.Font.Size := Editor.Font.Size; + Canvas.Font.Style := Attri.Style; + // Todo: check if we need to handle TransientType ttAfter and ttBefore + Canvas.Font.Color:= FMatchingBraceForegroundColor; + Canvas.Brush.Color:= FMatchingBraceBackgroundColor; + if Canvas.Font.Color = clNone then + Canvas.Font.Color := Editor.Font.Color; + if Canvas.Brush.Color = clNone then + Canvas.Brush.Color := Editor.Color; + Canvas.TextOut(Pnt.X, Pnt.Y, rx.Match[1]); + end; + if not rx.ExecNext then + Break; + end; + end; + rx.Free; end; + end; - P := Editor.CaretXY; - D := Editor.DisplayXY; + // Highlight matching brackets, only without selection + if not Editor.SelAvail then begin - Start := Editor.SelStart; + BufCrd := Editor.CaretXY; + SelStart := Editor.SelStart; - if (Start > 0) and (Start <= length(Editor.Text)) then - TmpCharA := Editor.Text[Start] - else - TmpCharA := #0; + if (SelStart > 0) and (SelStart <= Editor.GetTextLen) then + TmpCharA := Editor.Text[SelStart] + else + TmpCharA := #0; - if (Start >= 0) and (Start < length(Editor.Text)) then - TmpCharB := Editor.Text[Start + 1] - else - TmpCharB := #0; + if (SelStart >= 0) and (SelStart < Editor.GetTextLen) then + TmpCharB := Editor.Text[SelStart + 1] + else + TmpCharB := #0; - if not IsCharBracket(TmpCharA) and not IsCharBracket(TmpCharB) then - Exit; - S := TmpCharB; - if not IsCharBracket(TmpCharB) then begin - P.Char := P.Char - 1; - S := TmpCharA; - end; - Editor.GetHighlighterAttriAtRowCol(P, S, Attri); + if CharInSet(TmpCharA, BracketChars) or CharInSet(TmpCharB, BracketChars) then begin + S := TmpCharB; + if not CharInSet(TmpCharB, BracketChars) then begin + BufCrd.Char := BufCrd.Char - 1; + S := TmpCharA; + end; - if (Editor.Highlighter.SymbolAttribute = Attri) then begin - for i:=Low(OpenChars) to High(OpenChars) do begin - if (S = OpenChars[i]) or (S = CloseChars[i]) then begin - Pix := CharToPixels(P); + if Editor.GetHighlighterAttriAtRowCol(BufCrd, S, Attri) and (Attri.FriendlyName = SYNS_FriendlyAttrSymbol) then + begin - Editor.Canvas.Brush.Style := bsSolid; - Editor.Canvas.Font.Assign(Editor.Font); - Editor.Canvas.Font.Style := Attri.Style; + for i:=Low(OpenChars) to High(OpenChars) do begin + if (S = OpenChars[i]) or (S = CloseChars[i]) then begin + Pix := CharToPixels(BufCrd); + + Canvas.Brush.Style := bsSolid; + Canvas.Font.Assign(Editor.Font); + Canvas.Font.Style := Attri.Style; + + if (TransientType = ttAfter) then begin + Canvas.Font.Color := MatchingBraceForegroundColor; + Canvas.Brush.Color := MatchingBraceBackgroundColor; + end else begin + Canvas.Font.Color := Attri.Foreground; + Canvas.Brush.Color := Attri.Background; + end; + if Canvas.Font.Color = clNone then + Canvas.Font.Color := Editor.Font.Color; + if Canvas.Brush.Color = clNone then + Canvas.Brush.Color := Editor.Color; + + Canvas.TextOut(Pix.X, Pix.Y, S); + BufCrd := Editor.GetMatchingBracketEx(BufCrd); + + if (BufCrd.Char > 0) and (BufCrd.Line > 0) then begin + Pix := CharToPixels(BufCrd); + if Pix.X > Editor.Gutter.Width then begin + if S = OpenChars[i] then + Canvas.TextOut(Pix.X, Pix.Y, CloseChars[i]) + else + Canvas.TextOut(Pix.X, Pix.Y, OpenChars[i]); + end; + end; - if (TransientType = ttAfter) then begin - Editor.Canvas.Font.Color := MatchingBraceForegroundColor; - Editor.Canvas.Brush.Color := MatchingBraceBackgroundColor; - end else begin - Editor.Canvas.Font.Color := Attri.Foreground; - Editor.Canvas.Brush.Color := Attri.Background; - end; - if Editor.Canvas.Font.Color = clNone then - Editor.Canvas.Font.Color := Editor.Font.Color; - if Editor.Canvas.Brush.Color = clNone then - Editor.Canvas.Brush.Color := Editor.Color; - - Editor.Canvas.TextOut(Pix.X, Pix.Y, S); - P := Editor.GetMatchingBracketEx(P); - - if (P.Char > 0) and (P.Line > 0) then begin - Pix := CharToPixels(P); - if Pix.X > Editor.Gutter.Width then begin - if S = OpenChars[i] then - Editor.Canvas.TextOut(Pix.X, Pix.Y, CloseChars[i]) - else Editor.Canvas.TextOut(Pix.X, Pix.Y, OpenChars[i]); end; end; - + Canvas.Brush.Style := bsSolid; end; end; - Editor.Canvas.Brush.Style := bsSolid; end; + + // Release event handler + FSynEditInOnPaintTransient := False; end; @@ -7191,7 +8051,7 @@ procedure TMainForm.popupHostPopup(Sender: TObject); menuFetchDBitems.Enabled := (PageControlHost.ActivePage = tabDatabases) and (ListDatabases.SelectedCount > 0); Kill1.Enabled := (PageControlHost.ActivePage = tabProcessList) and (ListProcesses.SelectedCount > 0); menuEditVariable.Enabled := False; - if ActiveConnection.ServerVersionInt >= 40003 then + if ActiveConnection.Has(frEditVariables) then menuEditVariable.Enabled := (PageControlHost.ActivePage = tabVariables) and Assigned(ListVariables.FocusedNode) else menuEditVariable.Hint := _(SUnsupported); @@ -7201,21 +8061,26 @@ procedure TMainForm.popupHostPopup(Sender: TObject); procedure TMainForm.popupDBPopup(Sender: TObject); var Obj: PDBObject; - HasFocus, IsDb, IsObject: Boolean; - Version: Integer; + IsDb, IsObject: Boolean; + Conn: TDBConnection; begin // DBtree and ListTables both use popupDB as menu - if DBtreeClicked(Sender) then begin + actQueryTable.Caption := f_('Select top %s rows', [FormatNumber(AppSettings.ReadInt(asDatagridRowsPerStep))]); + actQueryTable.Hint := f_('Selects the first %s rows in a new query tab', [FormatNumber(AppSettings.ReadInt(asDatagridRowsPerStep))]); + + if PopupComponent(Sender) = DBtree then begin Obj := DBTree.GetNodeData(DBTree.FocusedNode); IsDb := Obj.NodeType = lntDb; IsObject := Obj.NodeType in [lntTable..lntEvent]; actCreateDatabase.Enabled := (Obj.NodeType = lntNone) and (Obj.Connection.Parameters.NetTypeGroup in [ngMySQL, ngMSSQL, ngPgSQL]); + actConnectionProperties.Enabled := Obj.NodeType = lntNone; actAttachDatabase.Visible := Obj.Connection.Parameters.IsAnySQLite; actAttachDatabase.Enabled := actAttachDatabase.Visible and (Obj.NodeType = lntNone); actCreateTable.Enabled := IsDb or IsObject or (Obj.GroupType = lntTable); actCreateView.Enabled := IsDb or IsObject or (Obj.GroupType = lntView); - actCreateRoutine.Enabled := IsDb or IsObject or (Obj.GroupType in [lntFunction, lntProcedure]); + actCreateProcedure.Enabled := IsDb or IsObject or (Obj.GroupType in [lntFunction, lntProcedure]); + actCreateFunction.Enabled := actCreateProcedure.Enabled; actCreateTrigger.Enabled := IsDb or IsObject or (Obj.GroupType = lntTrigger); actCreateEvent.Enabled := IsDb or IsObject or (Obj.GroupType = lntEvent); actDropObjects.Enabled := IsObject or @@ -7224,43 +8089,81 @@ procedure TMainForm.popupDBPopup(Sender: TObject); actDetachDatabase.Enabled := actDetachDatabase.Visible and (Obj.NodeType = lntDb); actCopyTable.Enabled := Obj.NodeType in [lntTable, lntView]; actEmptyTables.Enabled := Obj.NodeType in [lntTable, lntView]; + actQueryTable.Enabled := Obj.NodeType in [lntTable, lntView]; actRunRoutines.Enabled := Obj.NodeType in [lntProcedure, lntFunction]; menuClearDataTabFilter.Enabled := Obj.NodeType in [lntTable, lntView]; - menuEditObject.Enabled := IsDb or IsObject; + menuEditObject.Enabled := (IsDb and Obj.Connection.Parameters.IsAnyMySQL) or IsObject; // Enable certain items which are valid only here menuTreeExpandAll.Enabled := True; menuTreeCollapseAll.Enabled := True; menuTreeOptions.Enabled := True; end else begin - HasFocus := Assigned(ListTables.FocusedNode); + Obj := ListTables.GetNodeData(ListTables.FocusedNode); actCreateDatabase.Enabled := False; + actConnectionProperties.Enabled := False; actAttachDatabase.Visible := False; actCreateTable.Enabled := True; actCreateView.Enabled := True; - actCreateRoutine.Enabled := True; + actCreateProcedure.Enabled := True; + actCreateFunction.Enabled := True; actCreateTrigger.Enabled := True; actCreateEvent.Enabled := True; actDropObjects.Enabled := ListTables.SelectedCount > 0; actDetachDatabase.Visible := False; actEmptyTables.Enabled := True; + actQueryTable.Enabled := Assigned(Obj) and (Obj.NodeType in [lntTable, lntView]); actRunRoutines.Enabled := True; menuClearDataTabFilter.Enabled := False; - menuEditObject.Enabled := HasFocus; - actCopyTable.Enabled := False; - if HasFocus then begin - Obj := ListTables.GetNodeData(ListTables.FocusedNode); - actCopyTable.Enabled := Obj.NodeType in [lntTable, lntView]; - end; + menuEditObject.Enabled := Assigned(Obj); + actCopyTable.Enabled := Assigned(Obj) and (Obj.NodeType in [lntTable, lntView]); menuTreeExpandAll.Enabled := False; menuTreeCollapseAll.Enabled := False; menuTreeOptions.Enabled := False; end; - if (ActiveConnection <> nil) and (ActiveConnection.Parameters.IsAnyMySQL) then begin - Version := ActiveConnection.ServerVersionInt; - actCreateView.Enabled := actCreateView.Enabled and (Version >= 50001); - actCreateRoutine.Enabled := actCreateRoutine.Enabled and (Version >= 50003); - actCreateTrigger.Enabled := actCreateTrigger.Enabled and (Version >= 50002); - actCreateEvent.Enabled := actCreateEvent.Enabled and (Version >= 50100); + Conn := ActiveConnection; + if (Conn <> nil) and (Conn.Parameters.IsAnyMySQL) then begin + actCreateView.Enabled := actCreateView.Enabled and Conn.Has(frCreateView); + actCreateProcedure.Enabled := actCreateProcedure.Enabled and Conn.Has(frCreateProcedure); + actCreateFunction.Enabled := actCreateFunction.Enabled and Conn.Has(frCreateFunction); + actCreateTrigger.Enabled := actCreateTrigger.Enabled and Conn.Has(frCreateTrigger); + actCreateEvent.Enabled := actCreateEvent.Enabled and Conn.Has(frCreateEvent); + end; +end; + + +procedure TMainForm.popupFilterPopup(Sender: TObject); +var + SQLFuncs: TSQLFunctionList; + i, j: Integer; + miGroup, miFunction: TMenuItem; +begin + // Create function menu items in popup menu + menuFilterInsertFunction.Clear; + SQLFuncs := ActiveConnection.SQLFunctions; + for i:=0 to SQLFuncs.Categories.Count-1 do begin + // Create a menu item which gets subitems later + miGroup := TMenuItem.Create(popupFilter); + miGroup.Caption := SQLFuncs.Categories[i]; + menuFilterInsertFunction.Add(miGroup); + for j:=0 to SQLFuncs.Count-1 do begin + if SQLFuncs[j].Category <> SQLFuncs.Categories[i] then + Continue; + miFunction := TMenuItem.Create(popupFilter); + miFunction.Caption := SQLFuncs[j].Name; + miFunction.ImageIndex := 13; + // Prevent generating a hotkey + miFunction.Caption := StringReplace(miFunction.Caption, '&', '&&', [rfReplaceAll]); + // Prevent generating a seperator line + if miFunction.Caption = '-' then + miFunction.Caption := '&-'; + miFunction.Hint := SQLFuncs[j].Name + SQLFuncs[j].Declaration + ' - ' + StrEllipsis(SQLFuncs[j].Description, 200); + // Prevent generating a seperator for ShortHint and LongHint + miFunction.Hint := StringReplace( miFunction.Hint, '|', '¦', [rfReplaceAll] ); + miFunction.Tag := j; + // Place menuitem on menu + miFunction.OnClick := insertFunction; + miGroup.Add(miFunction); + end; end; end; @@ -7270,13 +8173,15 @@ procedure TMainForm.popupDataGridPopup(Sender: TObject); Grid: TVirtualStringTree; Results: TDBQuery; i: Integer; - Col, Value: String; + Col, Value, FocusedColumnName: String; CellFocused, InDataGrid, HasNullValue, HasNotNullValue: Boolean; RowNumber: PInt64; Node: PVirtualNode; OldDataLocalNumberFormat: Boolean; IncludedValues: TStringList; Act: TAction; + Datatype: TDBDatatype; + ForeignKey: TForeignKey; const CLPBRD : String = 'CLIPBOARD'; begin @@ -7285,7 +8190,7 @@ procedure TMainForm.popupDataGridPopup(Sender: TObject); // Make sure ValidateControls detects the grid as focused, which is not the case when // it has 0 nodes, even with TreeOptions.SelectionOptions.RightclickSelect enabled Grid.SetFocus; - CellFocused := Assigned(Grid.FocusedNode) and (Grid.FocusedColumn > NoColumn); + CellFocused := Assigned(Grid.FocusedNode) and (Grid.FocusedColumn > 0); InDataGrid := Grid = DataGrid; DataInsertValue.Enabled := CellFocused; QFvalues.Enabled := CellFocused; @@ -7294,14 +8199,17 @@ procedure TMainForm.popupDataGridPopup(Sender: TObject); menuSQLHelpData.Enabled := InDataGrid; Refresh3.Enabled := InDataGrid; actGridEditFunction.Enabled := CellFocused; + actFollowForeignKey.Enabled := False; if not CellFocused then Exit; + if not InDataGrid then + Exit; Results := GridResult(Grid); - Col := Results.Connection.QuoteIdent(Results.ColumnOrgNames[Grid.FocusedColumn], False); - if InDataGrid - and (SelectedTableFocusedColumn.DataType.Index = dtJson) + Datatype := Results.DataType(Grid.FocusedColumn-1); + Col := Results.Connection.QuoteIdent(Results.ColumnOrgNames[Grid.FocusedColumn-1], False); + if (Datatype.Index = dbdtJson) and Results.Connection.Parameters.IsAnyPostgreSQL then begin Col := Col + '::text'; end; @@ -7319,35 +8227,35 @@ procedure TMainForm.popupDataGridPopup(Sender: TObject); HasNotNullValue := False; OldDataLocalNumberFormat := DataLocalNumberFormat; DataLocalNumberFormat := False; - IncludedValues := TStringList.Create; + IncludedValues := TStringList.Create; // Used to skip duplicates while Assigned(Node) do begin AnyGridEnsureFullRow(Grid, Node); RowNumber := Grid.GetNodeData(Node); Results.RecNo := RowNumber^; - if Results.IsNull(Grid.FocusedColumn) then + if Results.IsNull(Grid.FocusedColumn-1) then HasNullValue := True else begin HasNotNullValue := True; Value := Grid.Text[Node, Grid.FocusedColumn]; if IncludedValues.IndexOf(Value) = -1 then begin - actQuickFilterFocused1.Hint := actQuickFilterFocused1.Hint + Results.Connection.EscapeString(Value) + ', '; - actQuickFilterFocused2.Hint := actQuickFilterFocused2.Hint + Results.Connection.EscapeString(Value) + ', '; + actQuickFilterFocused1.Hint := actQuickFilterFocused1.Hint + Results.Connection.EscapeString(Value, Datatype) + ', '; + actQuickFilterFocused2.Hint := actQuickFilterFocused2.Hint + Results.Connection.EscapeString(Value, Datatype) + ', '; actQuickFilterFocused3.Hint := actQuickFilterFocused3.Hint + - Results.Connection.GetSQLSpecifity(spLikeCompare, [Col, '''' + Results.Connection.EscapeString(Value, True, False) + '%''']) + + Results.Connection.SqlProvider.GetSql(qLikeCompare, [Col, '''' + Results.Connection.EscapeString(Value, True, False) + '%''']) + ' OR '; actQuickFilterFocused4.Hint := actQuickFilterFocused4.Hint + - Results.Connection.GetSQLSpecifity(spLikeCompare, [Col, '''%' + Results.Connection.EscapeString(Value, True, False) + '''']) + + Results.Connection.SqlProvider.GetSql(qLikeCompare, [Col, '''%' + Results.Connection.EscapeString(Value, True, False) + '''']) + ' OR '; actQuickFilterFocused5.Hint := actQuickFilterFocused5.Hint + - Results.Connection.GetSQLSpecifity(spLikeCompare, [Col, '''%' + Results.Connection.EscapeString(Value, True, False) + '%''']) + + Results.Connection.SqlProvider.GetSql(qLikeCompare, [Col, '''%' + Results.Connection.EscapeString(Value, True, False) + '%''']) + ' OR '; - actQuickFilterFocused6.Hint := actQuickFilterFocused6.Hint + Col + ' > ' + Results.Connection.EscapeString(Value) + ' OR '; - actQuickFilterFocused7.Hint := actQuickFilterFocused7.Hint + Col + ' < ' + Results.Connection.EscapeString(Value) + ' OR '; + actQuickFilterFocused6.Hint := actQuickFilterFocused6.Hint + Col + ' > ' + Results.Connection.EscapeString(Value, Datatype) + ' OR '; + actQuickFilterFocused7.Hint := actQuickFilterFocused7.Hint + Col + ' < ' + Results.Connection.EscapeString(Value, Datatype) + ' OR '; IncludedValues.Add(Value); end; end; Node := Grid.GetNextSelected(Node); - if Length(actQuickFilterFocused1.Hint) > SIZE_MB then + if Length(actQuickFilterFocused1.Hint) > SIZE_KB then Break; end; DataLocalNumberFormat := OldDataLocalNumberFormat; @@ -7392,23 +8300,23 @@ procedure TMainForm.popupDataGridPopup(Sender: TObject); actQuickFilterPrompt2.Hint := Col + ' != "..."'; actQuickFilterPrompt3.Hint := Col + ' > "..."'; actQuickFilterPrompt4.Hint := Col + ' < "..."'; - actQuickFilterPrompt5.Hint := Results.Connection.GetSQLSpecifity(spLikeCompare, [Col, '"%...%"']); + actQuickFilterPrompt5.Hint := Results.Connection.SqlProvider.GetSql(qLikeCompare, [Col, '"%...%"']); actQuickFilterNull.Hint := Col + ' IS NULL'; actQuickFilterNotNull.Hint := Col + ' IS NOT NULL'; // Block 3: WHERE col = [clipboard content] - Value := Trim(Clipboard.AsText); + Value := Trim(Clipboard.TryAsText); if Length(Value) < SIZE_KB then begin actQuickFilterClipboard1.Enabled := true; - actQuickFilterClipboard1.Hint := Col + ' = ' + Results.Connection.EscapeString(Value); + actQuickFilterClipboard1.Hint := Col + ' = ' + Results.Connection.EscapeString(Value, Datatype); actQuickFilterClipboard2.Enabled := true; - actQuickFilterClipboard2.Hint := Col + ' != ' + Results.Connection.EscapeString(Value); + actQuickFilterClipboard2.Hint := Col + ' != ' + Results.Connection.EscapeString(Value, Datatype); actQuickFilterClipboard3.Enabled := true; - actQuickFilterClipboard3.Hint := Col + ' > ' + Results.Connection.EscapeString(Value); + actQuickFilterClipboard3.Hint := Col + ' > ' + Results.Connection.EscapeString(Value, Datatype); actQuickFilterClipboard4.Enabled := true; - actQuickFilterClipboard4.Hint := Col + ' < ' + Results.Connection.EscapeString(Value); + actQuickFilterClipboard4.Hint := Col + ' < ' + Results.Connection.EscapeString(Value, Datatype); actQuickFilterClipboard5.Enabled := true; - actQuickFilterClipboard5.Hint := Results.Connection.GetSQLSpecifity(spLikeCompare, [Col, '''%' + Results.Connection.EscapeString(Value, True, False) + '%''']); + actQuickFilterClipboard5.Hint := Results.Connection.SqlProvider.GetSql(qLikeCompare, [Col, '''%' + Results.Connection.EscapeString(Value, True, False) + '%''']); actQuickFilterClipboard6.Enabled := true; actQuickFilterClipboard6.Hint := Col + ' IN (' + Value + ')'; end else begin @@ -7421,7 +8329,7 @@ procedure TMainForm.popupDataGridPopup(Sender: TObject); actQuickFilterClipboard4.Enabled := false; actQuickFilterClipboard4.Hint := Col + ' < ' + CLPBRD; actQuickFilterClipboard5.Enabled := false; - actQuickFilterClipboard5.Hint := Results.Connection.GetSQLSpecifity(spLikeCompare, [Col, '%' + CLPBRD + '%']); + actQuickFilterClipboard5.Hint := Results.Connection.SqlProvider.GetSql(qLikeCompare, [Col, '%' + CLPBRD + '%']); actQuickFilterClipboard6.Enabled := false; actQuickFilterClipboard6.Hint := Col + ' IN (' + CLPBRD + ')'; end; @@ -7434,10 +8342,19 @@ procedure TMainForm.popupDataGridPopup(Sender: TObject); // Stop here if Act = actRemoveFilter then Break; - if not Act.Hint.IsEmpty then + if not IsEmpty(Act.Hint) then Act.Caption := StrEllipsis(Act.Hint, 100); end; + FocusedColumnName := Results.ColumnOrgNames[Grid.FocusedColumn-1]; + //find foreign key for current column + for ForeignKey in ActiveDBObj.TableForeignKeys do begin + i := ForeignKey.Columns.IndexOf(FocusedColumnName); + if i > -1 then begin + actFollowForeignKey.Enabled := True; + break; + end; + end; end; @@ -7446,7 +8363,9 @@ procedure TMainForm.QFvaluesClick(Sender: TObject); Data: TDBQuery; DbObj: TDBObject; Conn: TDBConnection; - Col, Query: String; + ColIdx, ResultCol: Integer; + ColName, Query: String; + ColType: TDBDatatype; TableCol: TTableColumn; Item: TMenuItem; i: Integer; @@ -7460,27 +8379,30 @@ procedure TMainForm.QFvaluesClick(Sender: TObject); QFvalues[0].Caption := ''; QFvalues[0].Hint := ''; QFvalues[0].OnClick := nil; - if DataGrid.FocusedColumn = NoColumn then + ColIdx := DataGrid.FocusedColumn; + ResultCol := ColIdx - 1; + if ColIdx = NoColumn then Exit; - Col := DataGridResult.ColumnOrgNames[DataGrid.FocusedColumn]; + ColName := DataGridResult.ColumnOrgNames[ResultCol]; + ColType := DataGridResult.DataType(ResultCol); ShowStatusMsg(_('Fetching distinct values ...')); DbObj := ActiveDbObj; Conn := DbObj.Connection; - MaxSize := SIZE_GB; - ColumnHasIndex := DataGridResult.ColIsKeyPart(DataGrid.FocusedColumn) - or DataGridResult.ColIsUniqueKeyPart(DataGrid.FocusedColumn) - or DataGridResult.ColIsPrimaryKeyPart(DataGrid.FocusedColumn); + MaxSize := SIZE_GB*2; + ColumnHasIndex := DataGridResult.ColIsKeyPart(ResultCol) + or DataGridResult.ColIsUniqueKeyPart(ResultCol) + or DataGridResult.ColIsPrimaryKeyPart(ResultCol); if ColumnHasIndex then begin MaxSize := MaxSize * 5; end; try if DbObj.Size > MaxSize then raise Exception.Create(f_('Table too large (>%s), avoiding long running SELECT query', [FormatByteNumber(MaxSize)])); - Query := Conn.QuoteIdent(Col)+', COUNT(*) AS c FROM '+DbObj.QuotedName; + Query := Conn.QuoteIdent(ColName)+', COUNT(*) AS c FROM '+DbObj.QuotedName; if SynMemoFilter.Text <> '' then Query := Query + ' WHERE ' + SynMemoFilter.Text + CRLF; - Query := Query + ' GROUP BY '+Conn.QuoteIdent(Col)+' ORDER BY c DESC, '+Conn.QuoteIdent(Col); - Data := Conn.GetResults(Conn.ApplyLimitClause('SELECT', Query, 30, 0)); + Query := Query + ' GROUP BY '+Conn.QuoteIdent(ColName)+' ORDER BY c DESC, '+Conn.QuoteIdent(ColName); + Data := Conn.GetResults(Conn.ApplyLimitClause('SELECT', Query, 50, 0)); for i:=0 to Data.RecordCount-1 do begin if QFvalues.Count > i then Item := QFvalues[i] @@ -7488,10 +8410,12 @@ procedure TMainForm.QFvaluesClick(Sender: TObject); Item := TMenuItem.Create(QFvalues); QFvalues.Add(Item); end; - if Data.IsNull(Col) then - Item.Hint := Conn.QuoteIdent(Col)+' IS NULL' + if Data.IsNull(ColName) then + Item.Hint := Conn.QuoteIdent(ColName)+' IS NULL' + else if ColType.Category in [dtcBinary, dtcSpatial] then + Item.Hint := Conn.QuoteIdent(ColName)+'='+Data.HexValue(0, False) else - Item.Hint := Conn.QuoteIdent(Col)+'='+Conn.EscapeString(Data.Col(Col)); + Item.Hint := Conn.QuoteIdent(ColName)+'='+Conn.EscapeString(Data.Col(ColName)); Item.Caption := StrEllipsis(Item.Hint, 100) + ' (' + FormatNumber(Data.Col('c')) + ')'; if SynMemoFilter.Text <> '' then begin if Pos(Item.Hint, SynMemoFilter.Text) > 0 then @@ -7509,7 +8433,7 @@ procedure TMainForm.QFvaluesClick(Sender: TObject); QFvalues[0].Caption := StrEllipsis(E.Message, 100); QFvalues[0].Hint := E.Message; for TableCol in SelectedTableColumns do begin - if (TableCol.Name = Col) and (TableCol.DataType.Index in [dtEnum, dtSet]) then begin + if (TableCol.Name = ColName) and (TableCol.DataType.Index in [dbdtEnum, dbdtSet]) then begin ValueList := TableCol.ValueList; for i:=0 to ValueList.Count-1 do begin if QFvalues.Count > i+1 then @@ -7518,7 +8442,7 @@ procedure TMainForm.QFvaluesClick(Sender: TObject); Item := TMenuItem.Create(QFvalues); QFvalues.Add(Item); end; - Item.Hint := Conn.QuoteIdent(Col)+'='+Conn.EscapeString(ValueList[i]); + Item.Hint := Conn.QuoteIdent(ColName)+'='+Conn.EscapeString(ValueList[i]); Item.Caption := StrEllipsis(Item.Hint, 100); Item.OnClick := QuickFilterClick; end; @@ -7551,7 +8475,7 @@ procedure TMainForm.DataInsertValueClick(Sender: TObject); begin // Local and UTC date/time menu items Conn := ActiveConnection; - DateTimeSQL := 'SELECT ' + Conn.GetSQLSpecifity(spFuncNow); + DateTimeSQL := 'SELECT ' + Conn.SqlProvider.GetSql(qFuncNow); LocalTime := Conn.ParseDateTime(Conn.GetVar(DateTimeSQL)); DecodeDateTime(LocalTime, y, m, d, h, i, s, ms); DataDateTime.Caption := Format(FrmDateTime, [_('Date and time'), y,m,d,h,i,s]); @@ -7574,6 +8498,8 @@ procedure TMainForm.DataInsertValueClick(Sender: TObject); StrUid := GuidToString(Uid); DataGUID.Caption := _('GUID') + ': ' + StrUid; DataGUIDwobraces.Caption := _('GUID without braces') + ': ' + Copy(StrUid, 2, Length(StrUid)-2); + DataGUIDlowercase.Caption := _('GUID lowercase') + ': ' + StrUid.ToLower; + DataGUIDlowercaseWobraces.Caption := _('GUID lowercase without braces') + ': ' + Copy(StrUid, 2, Length(StrUid)-2).ToLower; ColNum := DataGrid.FocusedColumn; DataDefaultValue.Caption := _('Default value')+': ?'; @@ -7712,14 +8638,16 @@ function TMainForm.FindDBObjectNode(Tree: TBaseVirtualTree; Obj: TDBObject): PVi end; // Search in grouped table/view/... nodes - GroupedNode := Tree.GetFirstChild(ObjectNode); - while Assigned(GroupedNode) do begin - GroupedObj := Tree.GetNodeData(GroupedNode); - if GroupedObj.IsSameAs(Obj) then begin - Result := GroupedNode; - break; + if ObjectObj.NodeType = lntGroup then begin + GroupedNode := Tree.GetFirstChild(ObjectNode); + while Assigned(GroupedNode) do begin + GroupedObj := Tree.GetNodeData(GroupedNode); + if GroupedObj.IsSameAs(Obj) then begin + Result := GroupedNode; + break; + end; + GroupedNode := Tree.GetNextSibling(GroupedNode); end; - GroupedNode := Tree.GetNextSibling(GroupedNode); end; ObjectNode := Tree.GetNextSibling(ObjectNode); @@ -7746,9 +8674,9 @@ procedure TMainForm.btnDataClick(Sender: TObject); btn.Down := not btn.Down; if not btn.Down then Exit; if btn = tbtnDataColumns then - frm := TColumnSelectionForm.Create(self) + frm := TfrmColumnSelection.Create(self) else if btn = tbtnDataSorting then - frm := TDataSortingForm.Create(self) + frm := TfrmDataSorting.Create(self) else frm := TForm.Create(self); // Dummy fallback, should never get created // Position new form relative to btn's position @@ -7769,7 +8697,7 @@ procedure TMainForm.btnDataClick(Sender: TObject); procedure TMainForm.filterQueryHelpersChange(Sender: TObject); begin // Filter nodes in query helpers - FilterNodesByEdit(Sender as TButtonedEdit, ActiveQueryHelpers); + FilterNodesByEdit(Sender as TButtonedEdit, QueryTabs.ActiveHelpersTree); end; @@ -7779,6 +8707,7 @@ procedure TMainForm.tabsetQueryMouseMove(Sender: TObject; Shift: TShiftState; X, Tabs: TTabSet; Rect: TRect; Org: TPoint; + QueryTab: TQueryTab; ResultTab: TResultTab; HintSQL: TStringList; begin @@ -7794,12 +8723,15 @@ procedure TMainForm.tabsetQueryMouseMove(Sender: TObject; Shift: TShiftState; X, // Check if user wants these balloon hints if not AppSettings.ReadBool(asHintsOnResultTabs) then Exit; + QueryTab := QueryTabs.ActiveTab; + if idx >= QueryTab.ResultTabs.Count then + Exit; // Make SQL readable for the tooltip balloon. WrapText() is unsuitable here. // See issue #2014 // Also, wee need to work around the awful looking balloon text: // http://qc.embarcadero.com/wc/qcmain.aspx?d=73771 - ResultTab := ActiveQueryTab.ResultTabs[idx]; + ResultTab := QueryTab.ResultTabs[idx]; HintSQL := TStringList.Create; HintSQL.Text := Trim(ResultTab.Results.SQL); for i:=0 to HintSQL.Count-1 do begin @@ -7831,15 +8763,17 @@ procedure TMainForm.insertFunction(Sender: TObject); var f : String; sm : TSynMemo; + Conn: TDBConnection; begin // Detect which memo is focused if SynMemoFilter.Focused then sm := SynMemoFilter else - sm := ActiveQueryMemo; - // Restore function name from array - f := MySQLFunctions[TControl(Sender).tag].Name - + MySQLFunctions[TControl(Sender).tag].Declaration; + sm := QueryTabs.ActiveMemo; + // Restore function name from tag + Conn := ActiveConnection; + f := Conn.SQLFunctions[TControl(Sender).tag].Name + + Conn.SQLFunctions[TControl(Sender).tag].Declaration; sm.UndoList.AddGroupBreak; sm.SelText := f; sm.UndoList.AddGroupBreak; @@ -7848,27 +8782,59 @@ procedure TMainForm.insertFunction(Sender: TObject); end; +procedure TMainForm.menuRenameSnippetClick(Sender: TObject); +var + OldName, NewName: String; +begin + if not Assigned(QueryTabs.ActiveHelpersTree.FocusedNode) then + Exit; + + OldName := QueryTabs.ActiveHelpersTree.Text[QueryTabs.ActiveHelpersTree.FocusedNode, 0]; + NewName := OldName; + if InputQuery(_('Rename'), 'Rename snippet "'+OldName+'"', NewName) then + begin + Screen.Cursor := crHourGlass; + if NewName.IsEmpty then begin + Screen.Cursor := crDefault; + ErrorDialog(f_('Failed renaming %s', ['"' + OldName + '" => "' + NewName + '"'])); + end + else begin + OldName := ChangeFileExt(AppSettings.DirnameSnippets + OldName, FILEEXT_SNIPPET); + NewName := ChangeFileExt(AppSettings.DirnameSnippets + NewName, FILEEXT_SNIPPET); + LogSQL(Format('Rename snippet "%s" to "%s"', [OldName, NewName]), lcDebug); + if RenameFile(OldName, NewName) then begin + // Refresh list with snippets + SetSnippetFilenames; + end else begin + Screen.Cursor := crDefault; + ErrorDialog(f_('Failed renaming %s', ['"' + OldName + '" => "' + NewName + '"'])); + end; + end; + Screen.Cursor := crDefault; + end; +end; + {** Delete a snippet file } procedure TMainForm.menuDeleteSnippetClick(Sender: TObject); var - snippetfile : String; + SnippetFile : String; begin // Don't do anything if no item was selected - if not Assigned(ActiveQueryHelpers.FocusedNode) then + if not Assigned(QueryTabs.ActiveHelpersTree.FocusedNode) then Exit; - snippetfile := AppSettings.DirnameSnippets + ActiveQueryHelpers.Text[ActiveQueryHelpers.FocusedNode, 0] + '.sql'; - if MessageDialog(_('Delete snippet file?'), snippetfile, mtConfirmation, [mbOk, mbCancel]) = mrOk then + SnippetFile := AppSettings.DirnameSnippets + QueryTabs.ActiveHelpersTree.Text[QueryTabs.ActiveHelpersTree.FocusedNode, 0] + FILEEXT_SNIPPET; + if MessageDialog(_('Delete snippet file?'), SnippetFile, mtConfirmation, [mbOk, mbCancel]) = mrOk then begin Screen.Cursor := crHourGlass; - if DeleteFile(snippetfile) then begin + if DeleteFileWithUndo(SnippetFile) then begin // Refresh list with snippets SetSnippetFilenames; end else begin Screen.Cursor := crDefault; - ErrorDialog(f_('Failed deleting %s', [snippetfile])); + ErrorDialog(f_('Failed deleting %s', [SnippetFile])); end; Screen.Cursor := crDefault; end; @@ -7889,9 +8855,14 @@ procedure TMainForm.menuDoubleClickInsertsNodeTextClick(Sender: TObject); {** Load snippet at cursor } -procedure TMainForm.menuInsertSnippetAtCursorClick(Sender: TObject); +procedure TMainForm.menuInsertAtCursorClick(Sender: TObject); +var + Tree: TVirtualStringTree; + Tab: TQueryTab; begin - ActiveQueryTab.LoadContents(AppSettings.DirnameSnippets + ActiveQueryHelpers.Text[ActiveQueryHelpers.FocusedNode, 0] + '.sql', False, nil); + Tree := QueryTabs.ActiveHelpersTree; + Tab := QueryTabs.ActiveTab; + Tab.Memo.DragDrop(Tree, Tab.Memo.CaretX, Tab.Memo.CaretY); end; @@ -7900,7 +8871,7 @@ procedure TMainForm.menuInsertSnippetAtCursorClick(Sender: TObject); } procedure TMainForm.menuLoadSnippetClick(Sender: TObject); begin - ActiveQueryTab.LoadContents(AppSettings.DirnameSnippets + ActiveQueryHelpers.Text[ActiveQueryHelpers.FocusedNode, 0] + '.sql', True, nil); + QueryTabs.ActiveTab.LoadContents(AppSettings.DirnameSnippets + QueryTabs.ActiveHelpersTree.Text[QueryTabs.ActiveHelpersTree.FocusedNode, 0] + FILEEXT_SNIPPET, True, nil); end; @@ -7916,21 +8887,53 @@ procedure TMainForm.menuExploreClick(Sender: TObject); procedure TMainForm.menuClearQueryHistoryClick(Sender: TObject); var Values: TStringList; - PathToDelete: String; + HistoryRootKey, ValueNameToDelete: String; + Tab: TQueryTab; + ClickNode: PVirtualNode; + History: TQueryHistory; + DialogResult: TModalResult; begin // Clear query history items in registry - // Take care of MessageDialog, probably changing the current SessionPath - PathToDelete := ActiveConnection.Parameters.SessionPath + '\' + REGKEY_QUERYHISTORY; - AppSettings.SessionPath := PathToDelete; - Values := AppSettings.GetValueNames; - if MessageDialog(_('Clear query history?'), f_('%s history items will be deleted.', [FormatNumber(Values.Count)]), mtConfirmation, [mbYes, mbNo]) = mrYes then begin - Screen.Cursor := crHourglass; - AppSettings.SessionPath := PathToDelete; - AppSettings.DeleteCurrentKey; - RefreshHelperNode(HELPERNODE_HISTORY); - Screen.Cursor := crDefault; + HistoryRootKey := ActiveConnection.Parameters.SessionPath + '\' + REGKEY_QUERYHISTORY; + AppSettings.SessionPath := HistoryRootKey; + + Tab := QueryTabs.ActiveTab; + ClickNode := Tab.treeHelpers.FocusedNode; + + case Tab.treeHelpers.GetNodeLevel(ClickNode) of + 1: begin + Values := AppSettings.GetValueNames; + //showmessage(Values.Text); + DialogResult := MessageDialog( + _('Clear query history?'), + f_('%s history items will be deleted.', [FormatNumber(Values.Count)]), + mtConfirmation, + [mbYes, mbNo] + ); + if DialogResult = mrYes then begin + Screen.Cursor := crHourglass; + // MessageDialog may have changed the current SessionPath + AppSettings.SessionPath := HistoryRootKey; + AppSettings.DeleteCurrentKey; + RefreshHelperNode(TQueryTab.HelperNodeHistory); + Screen.Cursor := crDefault; + end; + Values.Free; + end; + + 2: begin + History := Tab.HistoryDays.Objects[ClickNode.Parent.Index] as TQueryHistory; + ValueNameToDelete := History[ClickNode.Index].RegValue.ToString; + //showmessage(ValueNameToDelete); + Screen.Cursor := crHourglass; + // MessageDialog may have changed the current SessionPath + AppSettings.SessionPath := HistoryRootKey; + AppSettings.DeleteValue(ValueNameToDelete); + RefreshHelperNode(TQueryTab.HelperNodeHistory); + Screen.Cursor := crDefault; + end; end; - Values.Free; + AppSettings.ResetPath; end; @@ -7980,6 +8983,9 @@ procedure TMainForm.AnyGridHeaderClick(Sender: TVTHeader; HitInfo: TVTHeaderHitI Exit; if Sender.Columns[HitInfo.Column].CheckBox then Exit; + // Header click disabled + if not AppSettings.ReadBool(asColumnHeaderClick) then + Exit; // Large query result sorting takes too long, see #293 LongSortRowNum := AppSettings.ReadInt(asQueryGridLongSortRowNum); if TVirtualStringTree(Sender.Treeview).RootNodeCount > LongSortRowNum then begin @@ -7996,7 +9002,7 @@ procedure TMainForm.AnyGridHeaderClick(Sender: TVTHeader; HitInfo: TVTHeaderHitI end; Screen.Cursor := crHourglass; Sender.SortColumn := HitInfo.Column; - Sender.Treeview.SortTree( HitInfo.Column, Sender.SortDirection ); + TBaseVirtualTree(Sender.Treeview).SortTree( HitInfo.Column, Sender.SortDirection ); Screen.Cursor := crDefault; end; @@ -8036,157 +9042,30 @@ procedure TMainForm.AnyGridAfterPaint(Sender: TBaseVirtualTree; {** - Save setup of a VirtualStringTree to registry + Start writing logfile. + Called either in FormShow or after closing preferences dialog } -procedure TMainForm.SaveListSetup( List: TVirtualStringTree ); +procedure TMainForm.SetLogToFile(Value: Boolean); var - i, ColWidth: Integer; - ColWidths, ColsVisible, ColPos, Regname: String; - OwnerForm: TWinControl; + LogfilePattern, LogDir: String; + i : Integer; begin - // Prevent sporadic crash on startup - if List = nil then + if Value = FLogToFile then Exit; - ColWidths := ''; - ColsVisible := ''; - ColPos := ''; - OwnerForm := GetParentFormOrFrame(List); - for i := 0 to List.Header.Columns.Count - 1 do - begin - // Column widths - if ColWidths <> '' then - ColWidths := ColWidths + ','; - ColWidth := List.Header.Columns[i].Width; - ColWidths := ColWidths + IntToStr(ColWidth); - - // Column visibility - if coVisible in List.Header.Columns[i].Options then - begin - if ColsVisible <> '' then - ColsVisible := ColsVisible + ','; - ColsVisible := ColsVisible + IntToStr(i); - end; - // Column position - if ColPos <> '' then - ColPos := ColPos + ','; - ColPos := ColPos + IntToStr(List.Header.Columns[i].Position); - - end; - - // On a windows shutdown, GetParentForm() seems sporadically unable to find the owner form - // In that case we would cause an exception when accessing it. Emergency break in that case. - // See issue #1462 - // TODO: Test this, probably fixed by implementing GetParentFormOrFrame, and then again, probably not. - if not Assigned(OwnerForm) then - Exit; - // Lists can have the same name over different forms or frames. Find parent form or frame, - // so we can prepend its name into the registry value name. - Regname := OwnerForm.Name + '.' + List.Name; - AppSettings.ResetPath; - AppSettings.WriteString(asListColWidths, ColWidths, Regname); - AppSettings.WriteString(asListColsVisible, ColsVisible, Regname); - AppSettings.WriteString(asListColPositions, ColPos, Regname); - AppSettings.WriteString(asListColSort, IntToStr(List.Header.SortColumn) + ',' + IntToStr(Integer(List.Header.SortDirection)), RegName); -end; - - -{** - Restore setup of VirtualStringTree from registry -} -procedure TMainForm.RestoreListSetup( List: TVirtualStringTree ); -var - i : Byte; - colwidth, colpos : Integer; - Value : String; - ValueList : TStringList; - Regname: String; - OwnerForm: TWinControl; -begin - ValueList := TStringList.Create; - - // Column widths - OwnerForm := GetParentFormOrFrame(List); - Regname := OwnerForm.Name + '.' + List.Name; - Value := AppSettings.ReadString(asListColWidths, Regname); - if Value <> '' then begin - ValueList := Explode( ',', Value ); - for i := 0 to ValueList.Count - 1 do - begin - colwidth := MakeInt(ValueList[i]); - // Check if column number exists and width is at least 1 pixel - if (List.Header.Columns.Count > i) and (colwidth > 0) and (colwidth < 1000) then - List.Header.Columns[i].Width := colwidth; - end; - end; - - // Column visibility - Value := AppSettings.ReadString(asListColsVisible, Regname); - if Value <> '' then begin - ValueList := Explode( ',', Value ); - for i:=0 to List.Header.Columns.Count-1 do begin - if ValueList.IndexOf( IntToStr(i) ) > -1 then - List.Header.Columns[i].Options := List.Header.Columns[i].Options + [coVisible] - else - List.Header.Columns[i].Options := List.Header.Columns[i].Options - [coVisible]; - end; - end; - - // Column position - Value := AppSettings.ReadString(asListColPositions, Regname); - if Value <> '' then begin - ValueList := Explode( ',', Value ); - for i := 0 to ValueList.Count - 1 do - begin - colpos := MakeInt(ValueList[i]); - // Check if column number exists - if List.Header.Columns.Count > i then - List.Header.Columns[i].Position := colpos; - end; - end; - - // Sort column and direction - Value := AppSettings.ReadString(asListColSort, Regname); - if Value <> '' then begin - ValueList := Explode(',', Value); - if ValueList.Count = 2 then begin - List.Header.SortColumn := MakeInt(ValueList[0]); - if MakeInt(ValueList[1]) = 0 then - List.Header.SortDirection := sdAscending - else - List.Header.SortDirection := sdDescending; - end; - end; - - ValueList.Free; -end; - - -{** - Start writing logfile. - Called either in FormShow or after closing preferences dialog -} -procedure TMainForm.SetLogToFile(Value: Boolean); -var - LogfilePattern, LogDir: String; - i : Integer; -begin - if Value = FLogToFile then - Exit; - - if Value then begin - // Ensure directory exists - LogDir := AppSettings.ReadString(asSessionLogsDirectory); - LogDir := IncludeTrailingPathDelimiter(LogDir); - ForceDirectories(LogDir); + if Value then begin + // Ensure directory exists + LogDir := AppSettings.ReadString(asSessionLogsDirectory); + LogDir := IncludeTrailingPathDelimiter(LogDir); + ForceDirectories(LogDir); // Determine free filename LogfilePattern := '%.6u.log'; i := 1; - FFileNameSessionLog := LogDir + goodfilename(Format(LogfilePattern, [i])); + FFileNameSessionLog := LogDir + ValidFilename(Format(LogfilePattern, [i])); while FileExists(FFileNameSessionLog) do begin inc(i); - FFileNameSessionLog := LogDir + goodfilename(Format(LogfilePattern, [i])); + FFileNameSessionLog := LogDir + ValidFilename(Format(LogfilePattern, [i])); end; // Create file handle for writing @@ -8225,19 +9104,22 @@ procedure TMainForm.AnyGridGetHint(Sender: TBaseVirtualTree; Node: var Tree: TVirtualStringTree; NewHint: String; + Conn: TDBConnection; + ValIsNumber: Boolean; begin // Disable tooltips on Wine, as they prevent users from clicking + editing clipped cells - if FIsWine then + if IsWine then Exit; Tree := TVirtualStringTree(Sender); - if Tree = ActiveQueryHelpers then begin + if Tree = QueryTabs.ActiveHelpersTree then begin + Conn := ActiveConnection; case Sender.GetNodeLevel(Node) of 1: case Node.Parent.Index of - HELPERNODE_FUNCTIONS: begin - NewHint := MySQLFunctions[Node.Index].Name + MySQLFunctions[Node.Index].Declaration + - ':' + sLineBreak + MySQLFunctions[Node.Index].Description; + TQueryTab.HelperNodeFunctions: begin + NewHint := Conn.SQLFunctions[Node.Index].Name + Conn.SQLFunctions[Node.Index].Declaration + + ':' + sLineBreak + Conn.SQLFunctions[Node.Index].Description; if not NewHint.IsEmpty then begin HintText := NewHint; end; @@ -8247,8 +9129,15 @@ procedure TMainForm.AnyGridGetHint(Sender: TBaseVirtualTree; Node: end; if HintText.IsEmpty then begin - HintText := Tree.Text[Node, Column]; - HintText := StrEllipsis(HintText, SIZE_KB); + try + ValIsNumber := IntToStr(MakeInt(Tree.Text[Node, Column])) = Tree.Text[Node, Column]; + except + ValIsNumber := False; + end; + if ValIsNumber then + HintText := FormatNumber(Tree.Text[Node, Column]) + else + HintText := StrEllipsis(Tree.Text[Node, Column], SIZE_KB); end; // See http://www.heidisql.com/forum.php?t=20458#p20548 if Sender = DBtree then @@ -8297,9 +9186,16 @@ procedure TMainForm.menuOpenLogFolderClick(Sender: TObject); } procedure TMainForm.AnyGridHeaderDraggedOut(Sender: TVTHeader; Column: TColumnIndex; DropPosition: TPoint); +var + Remaining: TColumnsArray; begin - // Hide the draggedout column - Sender.Columns[Column].Options := Sender.Columns[Column].Options - [coVisible]; + // Hide the draggedout column, if it's not the last one + // See also menuToggleAllClick, where hiding all is restricted through the poAllowHideAll option + Remaining := Sender.Columns.GetVisibleColumns; + if Length(Remaining) > 1 then + Sender.Columns[Column].Options := Sender.Columns[Column].Options - [coVisible]; + // Dynamic arrays are free'd when their scope ends, so this should not be required: + SetLength(Remaining, 0); end; @@ -8324,6 +9220,8 @@ procedure TMainForm.ListTablesBeforeCellPaint(Sender: TBaseVirtualTree; TargetCa var Obj: PDBObject; begin + PaintAlternatingRowBackground(TargetCanvas, Node, CellRect); + // Only paint bar in rows + size column if Column in [1, 2] then begin Obj := Sender.GetNodeData(Node); @@ -8335,6 +9233,36 @@ procedure TMainForm.ListTablesBeforeCellPaint(Sender: TBaseVirtualTree; TargetCa end; +function TMainForm.GetAlternatingRowBackground(Node: PVirtualNode): TColor; +var + clEven, clOdd: TColor; + isEven: Boolean; +begin + // Alternating row background. See issue #139 + Result := clNone; + clEven := AppSettings.ReadInt(asRowBackgroundEven); + clOdd := AppSettings.ReadInt(asRowBackgroundOdd); + isEven := Node.Index mod 2 = 0; + if IsEven and (clEven <> clNone) then + Result := clEven + else if (not IsEven) and (clOdd <> clNone) then + Result := clOdd; +end; + + +procedure TMainForm.PaintAlternatingRowBackground(TargetCanvas: TCanvas; Node: PVirtualNode; CellRect: TRect); +var + BgColor: TColor; +begin + // Apply color + BgColor := GetAlternatingRowBackground(Node); + if BgColor <> clNone then begin + TargetCanvas.Brush.Color := BgColor; + TargetCanvas.FillRect(CellRect); + end; +end; + + procedure TMainForm.PaintColorBar(Value, Max: Extended; TargetCanvas: TCanvas; CellRect: TRect); var BarWidth, CellWidth: Integer; @@ -8384,10 +9312,8 @@ procedure TMainForm.ListProcessesFocusChanged(Sender: TBaseVirtualTree; SynMemoProcessView.Enabled := EnableControls; pnlProcessView.Enabled := EnableControls; - lblExplainProcess.Enabled := EnableControls and ActiveConnection.Parameters.IsAnyMySQL; + lblExplainProcess.Enabled := EnableControls and ActiveConnection.SqlProvider.Has(qExplain); menuExplainProcess.Enabled := lblExplainProcess.Enabled; - lblExplainProcessAnalyzer.Enabled := lblExplainProcess.Enabled; - menuExplainAnalyzer.Enabled := lblExplainProcess.Enabled; end; @@ -8403,12 +9329,6 @@ procedure TMainForm.editFilterVTChange(Sender: TObject); end; -procedure TMainForm.editFilterVTRightButtonClick(Sender: TObject); -begin - (Sender as TButtonedEdit).Clear; -end; - - procedure TMainForm.editDatabaseTableFilterKeyPress(Sender: TObject; var Key: Char); begin if Key = #27 then @@ -8469,9 +9389,9 @@ procedure TMainForm.ApplyVTFilter(FromTimer: Boolean); end else if tab = tabData then begin VT := DataGrid; FFilterTextData := editFilterVT.Text; - end else if QueryTabActive and (ActiveQueryTab.ActiveResultTab <> nil) then begin + end else if QueryTabs.HasActiveTab and (QueryTabs.ActiveTab.ActiveResultTab <> nil) then begin VT := ActiveGrid; - ActiveQueryTab.ActiveResultTab.FilterText := editFilterVT.Text; + QueryTabs.ActiveTab.ActiveResultTab.FilterText := editFilterVT.Text; end; if not Assigned(VT) then Exit; @@ -8530,27 +9450,33 @@ procedure TMainForm.ApplyVTFilter(FromTimer: Boolean); procedure TMainForm.ApplyFontToGrids; var - i, j: Integer; QueryTab: TQueryTab; + ResultTab: TResultTab; Grid: TVirtualStringTree; -begin - // Apply somehow changed font settings to all existing grids - DataGrid.Font.Name := AppSettings.ReadString(asDataFontName); - DataGrid.Font.Size := AppSettings.ReadInt(asDataFontSize); - FixVT(Mainform.DataGrid, AppSettings.ReadInt(asGridRowLineCount)); - // .. include invisible mother query grid - QueryGrid.Font.Name := AppSettings.ReadString(asDataFontName); - QueryGrid.Font.Size := AppSettings.ReadInt(asDataFontSize); - // .. and all chid query grids - for i:=Mainform.tabQuery.PageIndex to Mainform.PageControlMain.PageCount-1 do begin - QueryTab := Mainform.QueryTabs[i-Mainform.tabQuery.PageIndex]; - for j:=0 to QueryTab.ResultTabs.Count-1 do begin - Grid := QueryTab.ResultTabs[j].Grid; - Grid.Font.Name := AppSettings.ReadString(asDataFontName); - Grid.Font.Size := AppSettings.ReadInt(asDataFontSize); - FixVT(Grid, AppSettings.ReadInt(asGridRowLineCount)); - end; + IncrementalSearchActive: Boolean; + AllGrids: TObjectList; +begin + // Apply changed settings to all existing data and query grids + LogSQL('Apply grid settings...', lcDebug); + AllGrids := TObjectList.Create(False); + IncrementalSearchActive := AppSettings.ReadBool(asIncrementalSearch); + AllGrids.Add(DataGrid); // Data tab grid + AllGrids.Add(QueryGrid); // Mother query grid + for QueryTab in QueryTabs do begin // Query tab child grids + for ResultTab in QueryTab.ResultTabs do begin + AllGrids.Add(ResultTab.Grid); + end; + end; + for Grid in AllGrids do begin + Grid.Font.Name := AppSettings.ReadString(asDataFontName); + Grid.Font.Size := AppSettings.ReadInt(asDataFontSize); + FixVT(Grid, AppSettings.ReadInt(asGridRowLineCount)); + if IncrementalSearchActive then + Grid.IncrementalSearch := isInitializedOnly + else + Grid.IncrementalSearch := isNone; end; + AllGrids.Free; end; @@ -8568,28 +9494,10 @@ procedure TMainForm.PrepareImageList; end else begin VirtualImageListMain.ImageCollection := ImageCollectionIcons8; end; + // Add all normal color icons from collection to virtual image list VirtualImageListMain.Add('', 0, VirtualImageListMain.ImageCollection.Count-1); -end; - - -procedure TMainForm.ListVariablesBeforeCellPaint(Sender: TBaseVirtualTree; - TargetCanvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; - CellPaintMode: TVTCellPaintMode; CellRect: TRect; var ContentRect: TRect); -var - SessionVal, GlobalVal: String; - vt: TVirtualStringTree; -begin - // Highlight cell if session variable is different to global variable - vt := Sender as TVirtualStringTree; - if Column = 1 then begin - SessionVal := vt.Text[Node, 1]; - GlobalVal := vt.Text[Node, 2]; - if SessionVal <> GlobalVal then begin - TargetCanvas.Brush.Color := clWebBlanchedAlmond; - TargetCanvas.Pen.Color := TargetCanvas.Brush.Color; - TargetCanvas.Rectangle(CellRect); - end; - end; + // Add all icons again in disabled/grayscale mode, used in TExtForm.PageControlTabHighlight + VirtualImageListMain.AddDisabled('', 0, VirtualImageListMain.ImageCollection.Count-1); end; @@ -8648,16 +9556,18 @@ procedure TMainForm.HostListGetImageIndex(Sender: TBaseVirtualTree; Node: PVirtu if Sender = ListProcesses then begin Idx := Sender.GetNodeData(Node); Results := GridResult(Sender); + if not Results.Connection.Active then + Exit; Results.RecNo := Idx^; case Kind of ikNormal, ikSelected: begin case Results.Connection.Parameters.NetTypeGroup of - ngMySQL: IsIdle := Results.Col('Info') = ''; - ngMSSQL: IsIdle := (Results.Col(6) <> 'running') and (Results.Col(6) <> 'runnable'); + ngMySQL: IsIdle := Results.Col('Info', True) = ''; + ngMSSQL: IsIdle := (Results.Col(6, True) <> 'running') and (Results.Col(6, True) <> 'runnable'); else IsIdle := False; end; if IsIdle then begin - if MakeInt(Results.Col(5)) < 60 then + if MakeInt(Results.Col(5, True)) < 60 then ImageIndex := 151 // Idle, same icon as in lower right status panel else ImageIndex := 167 // Long idle thread @@ -8665,9 +9575,9 @@ procedure TMainForm.HostListGetImageIndex(Sender: TBaseVirtualTree; Node: PVirtu ImageIndex := actExecuteQuery.ImageIndex; // Running query end; ikOverlay: begin - if IntToStr(Results.Connection.ThreadId) = Results.Col(0) then + if IntToStr(Results.Connection.ThreadId) = Results.Col(0, True) then ImageIndex := 168; // Indicate users own thread id - if CompareText(Results.Col(4), 'Killed') = 0 then + if CompareText(Results.Col(4, True), 'Killed') = 0 then ImageIndex := 158; // Broken end; else; @@ -8692,11 +9602,15 @@ procedure TMainForm.HostListGetText(Sender: TBaseVirtualTree; Node: PVirtualNode begin Idx := Sender.GetNodeData(Node); Results := GridResult(Sender); - // See issue #3416 - if (Results = nil) and (Sender <> ListVariables) then - Exit; - if Results <> nil then + + // See issue #3416. Note: ListVariables does not depend on a live result, but on a StringList. + if Sender <> ListVariables then begin + // See issue #1875 + if (Results = nil) or (not Results.Connection.Active) then + Exit; Results.RecNo := Idx^; + end; + if (Sender = ListStatus) and (Column in [1,2,3]) then begin CellText := Results.Col(1); @@ -8771,7 +9685,7 @@ procedure TMainForm.HostListGetText(Sender: TBaseVirtualTree; Node: PVirtualNode end else begin // Values directly from a query result - CellText := StrEllipsis(Results.Col(Column), SIZE_KB*50); + CellText := StrEllipsis(Results.Col(Column, True), SIZE_KB*50); end; end; @@ -8782,12 +9696,16 @@ procedure TMainForm.HostListGetText(Sender: TBaseVirtualTree; Node: PVirtualNode procedure TMainForm.menuEditVariableClick(Sender: TObject); var Dialog: TfrmEditVariable; + VarValue: String; begin Dialog := TfrmEditVariable.Create(Self); try try Dialog.VarName := ListVariables.Text[ListVariables.FocusedNode, 0]; - Dialog.VarValue := ListVariables.Text[ListVariables.FocusedNode, 1]; + VarValue := ListVariables.Text[ListVariables.FocusedNode, 1]; + if VarValue = TEXT_NULL then + VarValue := ''; + Dialog.VarValue := VarValue; // Refresh list node if Dialog.ShowModal = mrOK then InvalidateVT(ListVariables, VTREE_NOTLOADED, False); @@ -8820,63 +9738,72 @@ procedure TMainForm.DBtreeGetText(Sender: TBaseVirtualTree; Node: Bytes: Int64; AllListsCached: Boolean; begin - DBObj := Sender.GetNodeData(Node); - case Column of - 0: case DBObj.NodeType of - lntNone: CellText := DBObj.Connection.Parameters.SessionPath; - lntDb: CellText := DBObj.Database; - lntGroup: begin - CellText := DBObj.Name; - if Sender.ChildrenInitialized[Node] then - CellText := CellText + ' (' + FormatNumber(Sender.ChildCount[Node]) + ')'; - end; - lntTable..lntEvent: begin - if (DBObj.Schema <> '') and (DBObj.Connection.Parameters.NetTypeGroup = ngMSSQL) then - CellText := DBObj.Schema + '.' + DBObj.Name - else + try + DBObj := Sender.GetNodeData(Node); + case Column of + 0: case DBObj.NodeType of + lntNone: CellText := DBObj.Connection.Parameters.SessionPath; + lntDb: CellText := DBObj.Database; + lntGroup: begin + CellText := DBObj.Name; + if Sender.ChildrenInitialized[Node] then + CellText := CellText + ' (' + FormatNumber(Sender.ChildCount[Node]) + ')'; + end; + lntTable..lntEvent: try + if (DBObj.Schema <> '') and (DBObj.Connection.Parameters.NetTypeGroup = ngMSSQL) then + CellText := DBObj.Schema + '.' + DBObj.Name + else + CellText := DBObj.Name; + except CellText := DBObj.Name; + end; + lntColumn: CellText := DBObj.Column; end; - lntColumn: CellText := DBObj.Column; - end; - 1: if DBObj.Connection.Active then case DBObj.NodeType of - // Calculate and display the sum of all table sizes in ALL dbs if all table lists are cached - lntNone: begin - AllListsCached := true; - for i:=0 to DBObj.Connection.AllDatabases.Count-1 do begin - if not DBObj.Connection.DbObjectsCached(DBObj.Connection.AllDatabases[i]) then begin - AllListsCached := false; - break; - end; - end; - // Will be also set to a negative value by GetTableSize and results of SHOW TABLES - Bytes := -1; - if AllListsCached then begin - Bytes := 0; + 1: if DBObj.Connection.Active then case DBObj.NodeType of + // Calculate and display the sum of all table sizes in ALL dbs if all table lists are cached + lntNone: begin + AllListsCached := true; for i:=0 to DBObj.Connection.AllDatabases.Count-1 do begin - DBObjects := DBObj.Connection.GetDBObjects(DBObj.Connection.AllDatabases[i]); - Inc(Bytes, DBObjects.DataSize); + if not DBObj.Connection.DbObjectsCached(DBObj.Connection.AllDatabases[i]) then begin + AllListsCached := false; + break; + end; + end; + // Will be also set to a negative value by GetTableSize and results of SHOW TABLES + Bytes := -1; + if AllListsCached then begin + Bytes := 0; + for i:=0 to DBObj.Connection.AllDatabases.Count-1 do begin + DBObjects := DBObj.Connection.GetDBObjects(DBObj.Connection.AllDatabases[i]); + Inc(Bytes, DBObjects.DataSize); + end; end; + if Bytes >= 0 then CellText := FormatByteNumber(Bytes) + else CellText := ''; end; - if Bytes >= 0 then CellText := FormatByteNumber(Bytes) - else CellText := ''; - end; - // Calculate and display the sum of all table sizes in ONE db, if the list is already cached. - lntDb: begin - if not DBObj.Connection.DbObjectsCached(DBObj.Database) then - CellText := '' - else begin - DBObjects := DBObj.Connection.GetDBObjects(DBObj.Database); - CellText := FormatByteNumber(DBObjects.DataSize); + // Calculate and display the sum of all table sizes in ONE db, if the list is already cached. + lntDb: begin + if not DBObj.Connection.DbObjectsCached(DBObj.Database) then + CellText := '' + else begin + DBObjects := DBObj.Connection.GetDBObjects(DBObj.Database); + CellText := FormatByteNumber(DBObjects.DataSize); + end; end; - end; - lntTable: begin - if DBObj.Size >= 0 then - CellText := FormatByteNumber(DBObj.Size) - else - CellText := ''; - end - else CellText := ''; // Applies for views/procs/... which have no size - end; + lntTable: begin + if DBObj.Size >= 0 then + CellText := FormatByteNumber(DBObj.Size) + else + CellText := ''; + end + else CellText := ''; // Applies for views/procs/... which have no size + end; + end; + except + // Uploaded crash reports show multiple different situations with an AV, + // some of them in conjunction with a killed query. + on E:EAccessViolation do + CellText := ''; end; end; @@ -8888,14 +9815,22 @@ procedure TMainForm.DBtreeGetImageIndex(Sender: TBaseVirtualTree; Node: PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex; var Ghosted: Boolean; var ImageIndex: TImageIndex); var - DBObj: PDBObject; + DBObj, ParentObj: PDBObject; + TableKeys: TTableKeyList; begin if Column > 0 then Exit; DBObj := Sender.GetNodeData(Node); + if not Assigned(DBObj) then + Exit; case Kind of ikNormal, ikSelected: begin ImageIndex := DBObj.ImageIndex; + if DBObj.NodeType = lntColumn then begin // Key/index icon + ParentObj := Sender.GetNodeData(Node.Parent); + ImageIndex := ParentObj.TableKeys.ImageIndex(DBObj.Column); + end; + Ghosted := (DBObj.NodeType = lntNone) and (not DBObj.Connection.Active); Ghosted := Ghosted or ((DBObj.NodeType = lntDB) and (not DBObj.Connection.DbObjectsCached(DBObj.Database)) @@ -8958,8 +9893,7 @@ procedure TMainForm.DBtreeInitChildren(Sender: TBaseVirtualTree; Node: PVirtualN DBObjects := DBObj.Connection.GetDBObjects(DBObj.Database, False, DBObj.GroupType); ChildCount := DBObjects.Count; end; - lntTable: - if GetParentFormOrFrame(Sender) is TfrmSelectDBObject then begin + lntTable: begin Columns := DBObj.TableColumns; ChildCount := Columns.Count; end; @@ -8977,9 +9911,24 @@ procedure TMainForm.DBtreeInitNode(Sender: TBaseVirtualTree; ParentNode, Node: Item, ParentObj: PDBObject; DBObjects: TDBObjectList; Columns: TTableColumnList; + + function TreeShowColumns: Boolean; + var f: TWinControl; + begin + Result := False; + if Item.NodeType = lntTable then begin + if Sender = DBtree then // optional in dbtree + Result := actTreeShowColumns.Checked + else begin + f := GetParentFormOrFrame(Sender); + Result := Assigned(f) and (f is TfrmSelectDBObject); + end; + end; + end; + begin Item := Sender.GetNodeData(Node); - if not Assigned(ParentNode) then begin + if (not Assigned(ParentNode)) or (ParentNode = nil) then begin Item^ := TDBObject.Create(FConnections[Node.Index]); // Ensure plus sign is visible for root (and dbs, see below) Include(InitialStates, ivsHasChildren); @@ -9009,14 +9958,14 @@ procedure TMainForm.DBtreeInitNode(Sender: TBaseVirtualTree; ParentNode, Node: end else begin DBObjects := ParentObj.Connection.GetDBObjects(ParentObj.Database); Item^ := DBObjects[Node.Index]; - if (GetParentFormOrFrame(Sender) is TfrmSelectDBObject) and (Item.NodeType = lntTable) then + if TreeShowColumns then Include(InitialStates, ivsHasChildren); end; end; lntGroup: begin DBObjects := ParentObj.Connection.GetDBObjects(ParentObj.Database, False, ParentObj.GroupType); Item^ := DBObjects[Node.Index]; - if (GetParentFormOrFrame(Sender) is TfrmSelectDBObject) and (Item.NodeType = lntTable) then + if TreeShowColumns then Include(InitialStates, ivsHasChildren); end; lntTable: begin @@ -9038,13 +9987,15 @@ procedure TMainForm.DBtreeInitNode(Sender: TBaseVirtualTree; ParentNode, Node: procedure TMainForm.DBtreeFocusChanged(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex); var DBObj, PrevDBObj, ParentDBObj: PDBObject; + TableLevelObj: TDBObject; MainTabToActivate: TTabSheet; - TabHostName: String; + EnteringSession: Boolean; begin // Set wanted main tab and call SetMainTab later, when all lists have been invalidated MainTabToActivate := nil; PrevDBObj := nil; ParentDBObj := nil; + TableLevelObj := nil; if Assigned(Node) then begin LogSQL('DBtreeFocusChanged, Node level: '+IntToStr(Sender.GetNodeLevel(Node))+', FTreeRefreshInProgress: '+IntToStr(Integer(FTreeRefreshInProgress)), lcDebug); @@ -9057,12 +10008,16 @@ procedure TMainForm.DBtreeFocusChanged(Sender: TBaseVirtualTree; Node: PVirtualN DBObj.WasSelected := True; FActiveDbObj := TDBObject.Create(DBObj.Connection); FActiveDbObj.Assign(DBObj^); - if Assigned(Node.Parent) then + if Assigned(Node.Parent) and (DBtree.GetNodeLevel(Node) > 0) then ParentDBObj := Sender.GetNodeData(Node.Parent); + if FActiveDbObj.NodeType = lntColumn then + TableLevelObj := ParentDBObj^ + else + TableLevelObj := FActiveDbObj; case FActiveDbObj.NodeType of lntNone: begin - if (not DBtree.Dragging) and (not QueryTabActive) then + if (not DBtree.Dragging) and (not QueryTabs.HasActiveTab) then MainTabToActivate := tabHost; FActiveDbObj.Connection.Database := ''; end; @@ -9076,11 +10031,11 @@ procedure TMainForm.DBtreeFocusChanged(Sender: TBaseVirtualTree; Node: PVirtualN Exit; end; end; - if (not DBtree.Dragging) and (not QueryTabActive) then + if (not DBtree.Dragging) and (not QueryTabs.HasActiveTab) then MainTabToActivate := tabDatabase; FActiveObjectGroup := FActiveDbObj.GroupType; end; - lntTable..lntEvent: begin + lntTable..lntEvent, lntColumn: begin try FActiveDbObj.Connection.Database := FActiveDbObj.Database; except on E:EDbError do begin @@ -9096,33 +10051,35 @@ procedure TMainForm.DBtreeFocusChanged(Sender: TBaseVirtualTree; Node: PVirtualN SelectedTableForeignKeys.Clear; AppSettings.SessionPath := GetRegKeyTable; SelectedTableTimestampColumns.Text := AppSettings.ReadString(asTimestampColumns); + menuQueryExactRowCount.Checked := False; InvalidateVT(DataGrid, VTREE_NOTLOADED_PURGECACHE, False); try - if FActiveDbObj.NodeType in [lntTable, lntView] then begin - SelectedTableColumns := FActiveDbObj.TableColumns; + if TableLevelObj.NodeType in [lntTable, lntView] then begin + SelectedTableColumns := TableLevelObj.TableColumns; try - SelectedTableKeys := FActiveDbObj.TableKeys; + SelectedTableKeys := TableLevelObj.TableKeys; except // No show stopper, happening when a view references a renamed table column, see #1130 on E:EDbError do ErrorDialog(_('This view probably contains an error in its code.')+sLineBreak+sLineBreak+E.Message); end; - SelectedTableForeignKeys := FActiveDbObj.TableForeignKeys; + SelectedTableForeignKeys := TableLevelObj.TableForeignKeys; end; - if not FTreeRefreshInProgress then - PlaceObjectEditor(FActiveDbObj); + PlaceObjectEditor(TableLevelObj); // When a table is clicked in the tree, and the current // tab is a Host or Database tab, switch to showing table columns. if (PagecontrolMain.ActivePage = tabHost) or (PagecontrolMain.ActivePage = tabDatabase) then MainTabToActivate := tabEditor; + // Todo: prevent reload when focus has changed within a table's children only if DataGrid.Tag = VTREE_LOADED then InvalidateVT(DataGrid, VTREE_NOTLOADED_PURGECACHE, False); // Update the list of columns - RefreshHelperNode(HELPERNODE_COLUMNS); + RefreshHelperNode(TQueryTab.HelperNodeColumns); except on E:EDbError do ErrorDialog(E.Message); end; - FActiveObjectGroup := ParentDBObj.GroupType; + if Assigned(ParentDBObj) then + FActiveObjectGroup := ParentDBObj.GroupType; end; end; @@ -9130,10 +10087,19 @@ procedure TMainForm.DBtreeFocusChanged(Sender: TBaseVirtualTree; Node: PVirtualN PrevDBObj := Sender.GetNodeData(TreeClickHistoryPrevious(True)); // When clicked node is from a different connection than before, do session specific stuff here: - if (PrevDBObj = nil) or (PrevDBObj.Connection <> FActiveDbObj.Connection) then begin + try + EnteringSession := (FActiveDbObj <> nil) + and ((PrevDBObj = nil) or (PrevDBObj.Connection <> FActiveDbObj.Connection)); + except + on E:EAccessViolation do begin + LogSQL(E.ClassName+' while moving focus in tree.', lcError); + EnteringSession := True; + end; + end; + if EnteringSession then begin LogSQL(f_('Entering session "%s"', [FActiveDbObj.Connection.Parameters.SessionPath]), lcInfo); - RefreshHelperNode(HELPERNODE_HISTORY); - RefreshHelperNode(HELPERNODE_PROFILE); + RefreshHelperNode(TQueryTab.HelperNodeHistory); + RefreshHelperNode(TQueryTab.HelperNodeProfile); case FActiveDbObj.Connection.Parameters.NetTypeGroup of ngMySQL: SynSQLSynUsed.SQLDialect := sqlMySQL; @@ -9143,11 +10109,20 @@ procedure TMainForm.DBtreeFocusChanged(Sender: TBaseVirtualTree; Node: PVirtualN SynSQLSynUsed.SQLDialect := sqlPostgres; ngSQLite: SynSQLSynUsed.SQLDialect := sqlStandard; + ngInterbase: + SynSQLSynUsed.SQLDialect := sqlInterbase6; else raise Exception.CreateFmt(_(MsgUnhandledNetType), [Integer(FActiveDbObj.Connection.Parameters.NetType)]); end; + // Extend predefined MySQLFunctions from SynHighlighterSQL with our own functions list + SynSQLSynUsed.FunctionNames.BeginUpdate; + SynSQLSynUsed.FunctionNames.Clear; + SynSQLSynUsed.FunctionNames.AddStrings(FActiveDbObj.Connection.SQLFunctions.Names); + SynSQLSynUsed.FunctionNames.EndUpdate; end; - if (FActiveDbObj.NodeType <> lntNone) + + if (FActiveDbObj <> nil) + and (FActiveDbObj.NodeType <> lntNone) and ( (PrevDBObj = nil) or (PrevDBObj.Connection <> FActiveDbObj.Connection) @@ -9157,11 +10132,8 @@ procedure TMainForm.DBtreeFocusChanged(Sender: TBaseVirtualTree; Node: PVirtualN InvalidateVT(ListTables, VTREE_NOTLOADED, True); if FActiveDbObj.NodeType = lntGroup then InvalidateVT(ListTables, VTREE_NOTLOADED, True); - if FActiveDbObj.Connection.Parameters.IsAnySQLite then // Prefer visible filename over visible left part of path - TabHostName := StrEllipsis(FActiveDbObj.Connection.Parameters.HostName, 60, False) - else - TabHostName := FActiveDbObj.Connection.Parameters.HostName; - SetTabCaption(tabHost.PageIndex, _('Host')+': '+TabHostName); + + SetTabCaption(tabHost.PageIndex, FActiveDbObj.Connection.Parameters.SessionName); SetTabCaption(tabDatabase.PageIndex, _('Database')+': '+FActiveDbObj.Connection.Database); ShowStatusMsg(FActiveDbObj.Connection.Parameters.NetTypeName(False)+' '+FActiveDbObj.Connection.ServerVersionStr, 3); end else begin @@ -9182,6 +10154,7 @@ procedure TMainForm.DBtreeFocusChanged(Sender: TBaseVirtualTree; Node: PVirtualN InvalidateVT(ListProcesses, VTREE_NOTLOADED, False); InvalidateVT(ListCommandstats, VTREE_NOTLOADED, False); InvalidateVT(ListTables, VTREE_NOTLOADED, False); + ValidateQueryControls(Self); end; // Make wanted tab visible before activating, to avoid unset tab on Wine @@ -9190,8 +10163,8 @@ procedure TMainForm.DBtreeFocusChanged(Sender: TBaseVirtualTree; Node: PVirtualN if not FTreeRefreshInProgress then begin SetMainTab(MainTabToActivate); tabDatabase.TabVisible := (FActiveDbObj <> nil) and (FActiveDbObj.NodeType <> lntNone); - tabEditor.TabVisible := (FActiveDbObj <> nil) and (FActiveDbObj.NodeType in [lntTable..lntEvent]); - tabData.TabVisible := (FActiveDbObj <> nil) and (FActiveDbObj.NodeType in [lntTable, lntView]); + tabEditor.TabVisible := (FActiveDbObj <> nil) and (FActiveDbObj.NodeType in [lntTable..lntEvent, lntColumn]); + tabData.TabVisible := (FActiveDbObj <> nil) and (FActiveDbObj.NodeType in [lntTable, lntView, lntColumn]); end; // Store click history item @@ -9268,8 +10241,8 @@ procedure TMainForm.DatabaseChanged(Connection: TDBConnection; Database: String) // Clear Filter issue 3466 FFilterTextDatabase := ''; - if ActiveQueryHelpers <> nil then - ActiveQueryHelpers.Invalidate; + if QueryTabs.ActiveHelpersTree <> nil then + QueryTabs.ActiveHelpersTree.Invalidate; end; @@ -9280,6 +10253,8 @@ procedure TMainForm.ObjectnamesChanged(Connection: TDBConnection; Database: Stri TableNames, ProcNames: TStringList; begin // Tell SQL highlighter about names of tables and procedures in selected database + if (ActiveConnection <> Connection) or (Database <> Connection.Database) then + Exit; SynSQLSynUsed.TableNames.Clear; SynSQLSynUsed.ProcNames.Clear; if Connection.DbObjectsCached(Database) then begin @@ -9316,10 +10291,10 @@ procedure TMainForm.DBtreeDblClick(Sender: TObject); m: TSynMemo; begin // Paste DB or table name into query window on treeview double click. - if AppSettings.ReadBool(asDoubleClickInsertsNodeText) and QueryTabActive and Assigned(DBtree.FocusedNode) then begin + if AppSettings.ReadBool(asDoubleClickInsertsNodeText) and QueryTabs.HasActiveTab and Assigned(DBtree.FocusedNode) then begin DBObj := DBtree.GetNodeData(DBtree.FocusedNode); - if DBObj.NodeType in [lntDb, lntTable..lntEvent] then begin - m := ActiveQueryMemo; + if DBObj.NodeType in [lntDb, lntTable..lntEvent, lntColumn] then begin + m := QueryTabs.ActiveMemo; m.DragDrop(Sender, m.CaretX, m.CaretY); end; end; @@ -9359,25 +10334,54 @@ procedure TMainForm.DBtreePaintText(Sender: TBaseVirtualTree; const TargetCanvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType); var - DBObj: PDBObject; + DBObj, ParentObj: PDBObject; WalkNode: PVirtualNode; + Columns: TTableColumnList; + Datatype: TDBDatatype; begin - // Grey out non-current connection nodes, and rather unimportant "Size" column + // Grey out non-current connection nodes DBObj := Sender.GetNodeData(Node); - if DBObj.Connection <> ActiveConnection then - TargetCanvas.Font.Color := clGrayText - else if (Column = 1) and (DBObj.NodeType in [lntTable..lntEvent]) then + if DBObj.Connection <> ActiveConnection then begin TargetCanvas.Font.Color := clGrayText; + Exit; + end; + + // Set text color + case Column of + 0: begin + if DBObj.NodeType = lntColumn then begin + ParentObj := Sender.GetNodeData(Node.Parent); + Columns := ParentObj.TableColumns; + if Columns.Count > Node.Index then begin + Datatype := Columns[Node.Index].DataType; + TargetCanvas.Font.Color := DatatypeCategories[Datatype.Category].Color; + end; + end; + end; + 1: begin // Grey out rather unimportant "Size" column + if DBObj.NodeType in [lntTable..lntEvent] then + TargetCanvas.Font.Color := clGrayText; + end; + end; // Set bold text if painted node is in focused path - if (Column = Sender.Header.MainColumn) then begin + if (Column = DBtree.Header.MainColumn) then begin WalkNode := Sender.FocusedNode; - while WalkNode <> nil do begin + while Assigned(WalkNode) do begin if WalkNode = Node then begin TargetCanvas.Font.Style := TargetCanvas.Font.Style + [fsBold]; Break; end; - WalkNode := Sender.NodeParent[WalkNode]; + try + // This crashes in some situations, which I could never reproduce. + // See uploaded crash reports and issue #1270. + WalkNode := Sender.NodeParent[WalkNode]; + except + on E:EAccessViolation do begin + LogSQL('DBtreePaintText, NodeParent: '+E.Message, lcError); + Break; + end; + end; end; end; end; @@ -9401,7 +10405,8 @@ procedure TMainForm.RefreshTree(FocusNewObject: TDBObject=nil); // Remember currently selected object if FocusNewObject = nil then begin FocusNewObject := TDBObject.Create(ActiveConnection); - FocusNewObject.Assign(ActiveDbObj); + if FActiveDbObj <> nil then + FocusNewObject.Assign(FActiveDbObj); end; // ReInit tree population @@ -9433,9 +10438,9 @@ procedure TMainForm.RefreshTree(FocusNewObject: TDBObject=nil); if not Assigned(DBtree.FocusedNode) then SetActiveDatabase('', FocusNewObject.Connection); except + on E:Exception do + LogSQL('RefreshTree: '+E.Message, lcInfo); end; - if not Assigned(DBtree.FocusedNode) then - raise Exception.Create(_('Could not find node to focus.')); finally FTreeRefreshInProgress := False; @@ -9484,6 +10489,62 @@ procedure TMainForm.menuTreeExpandAllClick(Sender: TObject); {** Collapse all db nodes } +procedure TMainForm.menuToggleAllClick(Sender: TObject); +var + Grid: TVirtualStringTree; + Col: TColumnIndex; + VisibleColCount: Integer; + DoHide, AllowHideAll: Boolean; +begin + // Toggle visibility of all columns in list + // Always leave one column visible, synced with poAllowHideAll from popupListHeader.Options + // Logsql(PopupComponent(Sender).Name+': '+PopupComponent(Sender).ClassName); + Grid := PopupComponent(Sender) as TVirtualStringTree; + + VisibleColCount := 0; + Col := Grid.Header.Columns.GetFirstColumn; + while Col > NoColumn do begin + if coVisible in Grid.Header.Columns[Col].Options then + Inc(VisibleColCount); + Col := Grid.Header.Columns.GetNextColumn(Col); + end; + DoHide := VisibleColCount = Grid.Header.Columns.Count; + AllowHideAll := poAllowHideAll in popupListHeader.Options; + + Col := Grid.Header.Columns.GetFirstColumn; + while Col > NoColumn do begin + if DoHide and ((Col <> Grid.Header.Columns.GetFirstColumn) or AllowHideAll) then + Grid.Header.Columns[Col].Options := Grid.Header.Columns[Col].Options - [coVisible] + else + Grid.Header.Columns[Col].Options := Grid.Header.Columns[Col].Options + [coVisible]; + Col := Grid.Header.Columns.GetNextColumn(Col); + end; + +end; + +procedure TMainForm.menuCopyColumnNamesClick(Sender: TObject); +var + Grid: TVirtualStringTree; + Col: TColumnIndex; + List: TStringList; +begin + if Sender is TMenuItem then + Grid := PopupComponent(Sender) as TVirtualStringTree + else if Screen.ActiveControl is TVirtualStringTree then + Grid := Screen.ActiveControl as TVirtualStringTree + else + Exit; + + List := TStringList.Create; + Col := Grid.Header.Columns.GetFirstVisibleColumn(True); + while Col > NoColumn do begin + List.Add(Grid.Header.Columns[Col].Text); + Col := Grid.Header.Columns.GetNextVisibleColumn(Col); + end; + Clipboard.TryAsText := List.Text; + List.Free; +end; + procedure TMainForm.menuTreeCollapseAllClick(Sender: TObject); var n: PVirtualNode; @@ -9518,7 +10579,7 @@ procedure TMainForm.editFilterSearchChange(Sender: TObject); for i:=0 to SelectedTableColumns.Count-1 do begin // The normal case: do a LIKE comparison Condition := '''%' + Conn.EscapeString(ed.Text, True, False)+'%'''; - Condition := Conn.GetSQLSpecifity(spLikeCompare, [SelectedTableColumns[i].CastAsText, Condition]); + Condition := Conn.SqlProvider.GetSql(qLikeCompare, [SelectedTableColumns[i].CastAsText, Condition]); if not SelectedTableColumns[i].DataType.ValueMustMatch.IsEmpty then begin // Use an exact comparison for some PostgreSQL data types to overcome SQL errors, e.g. UUID, INT etc. // Also, prevent other errors by matching the value against a certain regular expression. @@ -9538,15 +10599,15 @@ procedure TMainForm.editFilterSearchChange(Sender: TObject); Line := ''; for i:=0 to Conditions.Count-1 do begin if i > 0 then - Line := Line + ' OR '; - Line := Line + Conditions[i]; + Conditions[i] := ' OR ' + Conditions[i]; // Add linebreak near right window edge - if (Length(Line) > SynMemoFilter.CharsInWindow-30) or (i = Conditions.Count-1) then begin - Clause := Clause + Line + CRLF; + if (not Line.IsEmpty) and (Length(Line + Conditions[i]) >= SynMemoFilter.CharsInWindow-5) then begin + Clause := Clause + Line + sLineBreak; Line := ''; end; + Line := Line + Conditions[i]; end; - Clause := Clause + Conn.LikeClauseTail; + Clause := Clause + Line + Conn.LikeClauseTail; end; SynMemoFilter.UndoList.AddGroupBreak; @@ -9556,8 +10617,24 @@ procedure TMainForm.editFilterSearchChange(Sender: TObject); procedure TMainForm.SynMemoFilterStatusChange(Sender: TObject; Changes: TSynStatusChanges); +var + TextHeight: Integer; + LineCount: Integer; + PanelHeight: Integer; +const + MinDisplayLineCount = 2; + MaxDisplayLineCount = 8; begin actClearFilterEditor.Enabled := (Sender as TSynMemo).GetTextLen > 0; + + LineCount := SynMemoFilter.DisplayLineCount; + LineCount := Min(LineCount, MaxDisplayLineCount); + LineCount := Max(LineCount, MinDisplayLineCount); + TextHeight := LineCount * SynMemoFilter.LineHeight + 10; + PanelHeight := pnlFilter.Height + (TextHeight - SynMemoFilter.Height); + PanelHeight := Max(PanelHeight, btnFilterApply.Top + btnFilterApply.Height + 5); + if PanelHeight <> pnlFilter.Height then + pnlFilter.Height := PanelHeight; end; @@ -9605,58 +10682,105 @@ procedure TMainForm.editFilterSearchExit(Sender: TObject); procedure TMainForm.AnyGridGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; var CellText: string); var - EditingAndFocused: Boolean; + EditingAndFocused, IsScientific: Boolean; RowNumber: PInt64; Results: TDBQuery; - Timestamp: Int64; + TimestampInt: Int64; + TimestampFloat: Extended; + FloatFrac: String; + DotPos, i, NumZeros, NumDecimals, KeepDecimals: Integer; + ResultCol: Integer; begin if Column = -1 then Exit; + if TextType <> ttNormal then + Exit; + ResultCol := Column - 1; + if ResultCol < 0 then begin + CellText := (Node.Index +1).ToString; + Exit; + end; + EditingAndFocused := Sender.IsEditing and (Node = Sender.FocusedNode) and (Column = Sender.FocusedColumn); Results := GridResult(Sender); - if not Results.Connection.Active then begin + if (Results = nil) or (not Results.Connection.Active) then begin EnableDataTab(False); Exit; end; // Happens in some crashes, see issue #2462 - if Column >= Results.ColumnCount then + if ResultCol >= Results.ColumnCount then Exit; + RowNumber := Sender.GetNodeData(Node); Results.RecNo := RowNumber^; - if Results.IsNull(Column) and (not EditingAndFocused) then - CellText := TEXT_NULL + if Results.IsNull(ResultCol) then begin + // Grid editors come here through Tree.GetTextInfo(), provide empty string then + CellText := IfThen(EditingAndFocused, '', TEXT_NULL); + end else begin - case Results.DataType(Column).Category of + case Results.DataType(ResultCol).Category of dtcInteger, dtcReal: begin // This is a bit crappy... // UNIX timestamps get *copied* as integers, but *displayed* and *edited* as date/time values. // Normal integers are *copied* and *edited* as raw numbers, but probably *displayed* as formatted numbers. if FGridCopying then begin - CellText := Results.Col(Column); + CellText := Results.Col(ResultCol); end else if HandleUnixTimestampColumn(Sender, Column) then begin try - Timestamp := Trunc(StrToFloat(Results.Col(Column), FFormatSettings)); + TimestampFloat := StrToFloat(Results.Col(ResultCol), FFormatSettings); + TimestampInt := Trunc(TimestampFloat); + Dec(TimestampInt, FTimeZoneOffset); + CellText := DateTimeToStr(UnixToDateTime(TimestampInt)); + + FloatFrac := Results.Col(ResultCol); + if FloatFrac.Contains(FFormatSettings.DecimalSeparator) then begin + FloatFrac := FloatFrac.Substring(Pos(FFormatSettings.DecimalSeparator, FloatFrac)); + CellText := CellText + '.' + FloatFrac; + end; except // EConvertError in StrToFloat or EInvalidOp in Trunc or... - Timestamp := 0; + on E:Exception do begin + CellText := Results.Col(ResultCol); + LogSQL('Error when calculating Unix timestamp from "'+CellText+'": '+E.Message, lcError); + end; end; - Dec(Timestamp, FTimeZoneOffset); - CellText := DateTimeToStr(UnixToDateTime(Timestamp)); end else begin + CellText := Results.Col(ResultCol); + + // Keep only wanted number of trailing zeros after decimal separator + // Bug fixed: Do not cut trailing zeros in scientific values like 2.0e30 => 2.0e3 + if (Results.DataType(ResultCol).Category = dtcReal) and (AppSettings.ReadInt(asRealTrailingZeros) >= 0) then begin + DotPos := Pos('.', CellText); + IsScientific := ContainsText(CellText, 'e'); + if (not IsScientific) and (DotPos > 0) then begin + NumZeros := 0; + NumDecimals := 0; + for i:=DotPos+1 to Length(CellText) do begin + Inc(NumDecimals); + if CellText[i] = '0' then + Inc(NumZeros) + else + NumZeros := 0; + end; + KeepDecimals := Max(NumDecimals - NumZeros, AppSettings.ReadInt(asRealTrailingZeros)); + CellText := Copy(CellText, 1, Length(CellText) - (NumDecimals - KeepDecimals)); + if CellText[Length(CellText)] = '.' then + CellText := Copy(CellText, 1, Length(CellText)-1); + end; + end; + if DataLocalNumberFormat and (not EditingAndFocused) then - CellText := FormatNumber(Results.Col(Column), True) - else - CellText := Results.Col(Column); + CellText := FormatNumber(CellText, True); end; end; dtcBinary, dtcSpatial: begin if actBlobAsText.Checked then - CellText := Results.Col(Column) + CellText := Results.Col(ResultCol) else - CellText := Results.HexValue(Column); + CellText := Results.HexValue(ResultCol, False); end; else begin - CellText := Results.Col(Column); + CellText := Results.Col(ResultCol); if (Length(CellText) = GRIDMAXDATA) and (not Results.HasFullData) and (Sender = DataGrid) then CellText := CellText + ' [...]'; end; @@ -9689,25 +10813,34 @@ procedure TMainForm.AnyGridPaintText(Sender: TBaseVirtualTree; const TargetCanva cl: TColor; r: TDBQuery; RowNumber: PInt64; + ResultCol: Integer; begin if Column = NoColumn then Exit; + ResultCol := Column - 1; + if ResultCol < 0 then begin + TargetCanvas.Font.Color := clGrayText; + //TargetCanvas.Font.Style := [TFontStyle.fsItalic]; + Exit; + end; r := GridResult(Sender); + if not Assigned(r) then + Exit; RowNumber := Sender.GetNodeData(Node); r.RecNo := RowNumber^; // Make primary key columns bold - if r.ColIsPrimaryKeyPart(Column) then + if r.ColIsPrimaryKeyPart(ResultCol) then TargetCanvas.Font.Style := TargetCanvas.Font.Style + [fsBold]; // Do not apply any color on a selected, highlighted cell to keep readability if (vsSelected in Node.States) and (Node = Sender.FocusedNode) and (Column = Sender.FocusedColumn) then cl := GetThemeColor(clHighlightText) - else if r.IsNull(Column) then - cl := DatatypeCategories[r.DataType(Column).Category].NullColor + else if r.IsNull(ResultCol) then + cl := DatatypeCategories[r.DataType(ResultCol).Category].NullColor else - cl := DatatypeCategories[r.DataType(Column).Category].Color; + cl := DatatypeCategories[r.DataType(ResultCol).Category].Color; TargetCanvas.Font.Color := cl; end; @@ -9717,14 +10850,19 @@ procedure TMainForm.AnyGridAfterCellPaint(Sender: TBaseVirtualTree; TargetCanvas var Results: TDBQuery; RowNum: PInt64; + ResultCol: Integer; begin // Don't waist time - if Column = NoColumn then Exit; + if Column = NoColumn then + Exit; + ResultCol := Column - 1; + if ResultCol < 0 then + Exit; // Paint a red triangle at the top left corner of the cell Results := GridResult(Sender); RowNum := Sender.GetNodeData(Node); Results.RecNo := RowNum^; - if Results.Modified(Column) then + if Results.Modified(ResultCol) then VirtualImageListMain.Draw(TargetCanvas, CellRect.Left, CellRect.Top, 111); end; @@ -9737,49 +10875,46 @@ procedure TMainForm.AnyGridAfterCellPaint(Sender: TBaseVirtualTree; TargetCanvas procedure TMainForm.DataGridHeaderClick(Sender: TVTHeader; HitInfo: TVTHeaderHitInfo); var frm: TForm; - i, j: Integer; - columnexists : Boolean; ColName: String; + SortItem: TSortItem; + SortOrder: TSortItemOrder; begin if HitInfo.Column = NoColumn then Exit; if HitInfo.Button = mbLeft then begin + // Header click disabled + if not AppSettings.ReadBool(asColumnHeaderClick) then + Exit; + if HitInfo.Column = NoColumn then + Exit; ColName := Sender.Columns[HitInfo.Column].Text; // Add a new order column after a columns title has been clicked // Check if order column is already existant - columnexists := False; - for i := Low(DataGridSortColumns) to High(DataGridSortColumns) do begin - if DataGridSortColumns[i].ColumnName = ColName then begin - // AddOrderCol is already in the list. Switch its direction: - // ASC > DESC > [delete col] - columnexists := True; - if DataGridSortColumns[i].SortDirection = ORDER_ASC then - DataGridSortColumns[i].SortDirection := ORDER_DESC - else begin - // Delete order col - for j := i to High(DataGridSortColumns) - 1 do - DataGridSortColumns[j] := DataGridSortColumns[j+1]; - SetLength(DataGridSortColumns, Length(DataGridSortColumns)-1); - end; - // We found the matching column, no need to loop further - break; - end; + SortItem := FDataGridSortItems.FindByColumn(ColName); + if Assigned(SortItem) then begin + // AddOrderCol is already in the list. Switch its direction: + // ASC > DESC > [delete col] + if SortItem.Order = sioAscending then + SortItem.Order := sioDescending + else + FDataGridSortItems.Remove(SortItem); + end + else begin + if KeyPressed(VK_SHIFT) then + SortOrder := sioDescending + else + SortOrder := sioAscending; + FDataGridSortItems.AddNew(ColName, SortOrder); + LogSQL('Created sorting for column '+ColName+'/'+Integer(SortOrder).ToString+' in TMainForm.DataGridHeaderClick', lcDebug); end; - if not columnexists then begin - i := Length(DataGridSortColumns); - SetLength(DataGridSortColumns, i+1); - DataGridSortColumns[i] := TOrderCol.Create; - DataGridSortColumns[i].ColumnName := ColName; - DataGridSortColumns[i].SortDirection := ORDER_ASC; - end; // Refresh grid, and remember X scroll offset, so the just clicked column is still at the same place. FDataGridLastClickedColumnHeader := HitInfo.Column; FDataGridLastClickedColumnLeftPos := Sender.Columns[HitInfo.Column].Left; InvalidateVT(DataGrid, VTREE_NOTLOADED_PURGECACHE, False); end else begin - frm := TColumnSelectionForm.Create(self); + frm := TfrmColumnSelection.Create(Self); // Position new form relative to btn's position frm.Top := HitInfo.Y + DataGrid.ClientOrigin.Y - Integer(DataGrid.Header.Height); frm.Left := HitInfo.X + DataGrid.ClientOrigin.X; @@ -9801,12 +10936,13 @@ procedure TMainForm.actDataSetNullExecute(Sender: TObject); Results := GridResult(Grid); Results.RecNo := RowNum^; try - Results.SetCol(Grid.FocusedColumn, '', True, False); + Results.SetCol(Grid.FocusedColumn-1, '', True, False); except on E:EDbError do ErrorDialog(E.Message); end; Grid.RepaintNode(Grid.FocusedNode); + ValidateControls(Sender); end; @@ -9859,29 +10995,34 @@ procedure TMainForm.AnyGridNewText(Sender: TBaseVirtualTree; Node: PVirtualNode; Results: TDBQuery; RowNum: PInt64; Timestamp: Int64; + TimestampFraction, StrWithoutMs: String; IsNull: Boolean; + ResultCol: Integer; begin Results := GridResult(Sender); if not Results.IsEditable then Exit; + ResultCol := Column - 1; RowNum := Sender.GetNodeData(Node); Results.RecNo := RowNum^; try - if (not FGridEditFunctionMode) and (Results.DataType(Column).Category in [dtcInteger, dtcReal]) then begin + if (not FGridEditFunctionMode) and (Results.DataType(ResultCol).Category in [dtcInteger, dtcReal]) then begin if HandleUnixTimestampColumn(Sender, Column) then begin - Timestamp := DateTimeToUnix(StrToDateTime(NewText)); + TimestampFraction := RegExprGetMatch('(\.\d+)$', NewText, 1); + StrWithoutMs := ReplaceRegExpr('\.\d+$', NewText, ''); + Timestamp := DateTimeToUnix(StrToDateTime(StrWithoutMs)); Inc(Timestamp, FTimeZoneOffset); - NewText := IntToStr(Timestamp) + NewText := IntToStr(Timestamp) + TimestampFraction; end else NewText := NewText; end; + FClipboardHasNull := FClipboardHasNull and (Clipboard.TryAsText = ''); IsNull := FGridPasting and FClipboardHasNull; - Results.SetCol(Column, NewText, IsNull, FGridEditFunctionMode); + Results.SetCol(ResultCol, NewText, IsNull, FGridEditFunctionMode); except - on E:EDbError do + on E:Exception do ErrorDialog(E.Message); end; - FGridEditFunctionMode := False; ValidateControls(Sender); end; @@ -9928,6 +11069,9 @@ procedure TMainForm.AnyGridFocusChanged(Sender: TBaseVirtualTree; Node: PVirtual Sender.ScrollIntoView(Sender.FocusedNode, False, True); // Required for highlighting fields with same text Sender.Invalidate; + // Reset flags when moving focus + FGridEditFunctionMode := False; + FDataEditWithoutLookup := False; end; @@ -9946,14 +11090,14 @@ procedure TMainForm.AnyGridKeyDown(Sender: TObject; var Key: Word; Shift: TShift g := TVirtualStringTree(Sender); case Key of VK_HOME: begin - g.FocusedColumn := g.Header.Columns.GetFirstVisibleColumn(False); + g.FocusedColumn := g.Header.Columns.GetFirstVisibleColumn(True); if ssCtrl in Shift then begin // VT itself focuses the first node since v7.0 end else Key := 0; end; VK_END: begin - g.FocusedColumn := g.Header.Columns.GetLastVisibleColumn(False); + g.FocusedColumn := g.Header.Columns.GetLastVisibleColumn(True); if ssCtrl in Shift then begin if g = DataGrid then actDataShowAll.Execute; @@ -9962,15 +11106,17 @@ procedure TMainForm.AnyGridKeyDown(Sender: TObject; var Key: Word; Shift: TShift Key := 0; end; end; - VK_RETURN: if Assigned(g.FocusedNode) then g.EditNode(g.FocusedNode, g.FocusedColumn); - VK_DOWN: if g.FocusedNode = g.GetLast then actDataInsertExecute(actDataInsert); - VK_NEXT: if (g = DataGrid) and (g.FocusedNode = g.GetLast) then actDataShowNext.Execute; + VK_RETURN: if Assigned(g.FocusedNode) and (Shift=[]) then g.EditNode(g.FocusedNode, g.FocusedColumn); + VK_DOWN: if (g.FocusedNode = g.GetLast) and (Shift=[]) then actDataInsertExecute(actDataInsert); + VK_NEXT: if (g = DataGrid) and (g.FocusedNode = g.GetLast) and (Shift=[]) then actDataShowNext.Execute; end; end; procedure TMainForm.AnyGridEditing(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; var Allowed: Boolean); +var + ColInfo: TTableColumn; begin Allowed := False; try @@ -9978,6 +11124,15 @@ procedure TMainForm.AnyGridEditing(Sender: TBaseVirtualTree; Node: ErrorDialog(_('Could not load full row data.')) else begin Allowed := True; + if Sender = DataGrid then begin + ColInfo := SelectedTableColumns.FindByName(Sender.Header.Columns[Column].Text); + if Assigned(ColInfo) then begin + Allowed := ColInfo.GenerationExpression.IsEmpty; + if not Allowed then + ErrorDialog(f_('Column %s is defined as generated per "%s". You cannot edit its content.', [Column.ToString, ColInfo.GenerationExpression])); + end; + end; + // Move Esc shortcut from "Cancel row editing" to "Cancel cell editing" actDataCancelChanges.ShortCut := 0; actDataPostChanges.ShortCut := 0; @@ -10026,43 +11181,49 @@ procedure TMainForm.AnyGridCreateEditor(Sender: TBaseVirtualTree; Node: Conn: TDBConnection; RowNum: PInt64; RefObj: TDBObject; - AllowEdit: Boolean; + AllowEdit, DisplayHex: Boolean; + SQLFunc: TSQLFunction; + ResultCol: Integer; begin VT := Sender as TVirtualStringTree; + EditLink := nil; Results := GridResult(VT); RowNum := VT.GetNodeData(Node); Results.RecNo := RowNum^; + ResultCol := Column - 1; Conn := Results.Connection; // Allow editing, or leave readonly mode AllowEdit := Results.IsEditable; + TblColumn := Results.ColAttributes(ResultCol); // Find foreign key values - if AppSettings.ReadBool(asForeignDropDown) and (Sender = DataGrid) then begin + if AppSettings.ReadBool(asForeignDropDown) and (Sender = DataGrid) and (not FDataEditWithoutLookup) then begin for ForeignKey in SelectedTableForeignKeys do begin idx := ForeignKey.Columns.IndexOf(DataGrid.Header.Columns[Column].Text); if idx > -1 then try // Find the first text column if available and use that for displaying in the pulldown instead of using meaningless id numbers RefObj := ForeignKey.ReferenceTableObj; + if not Assigned(RefObj) then + Continue; + TextCol := ''; - if Assigned(RefObj) then begin - Columns := RefObj.TableColumns; - for TblColumn in Columns do begin - if (TblColumn.DataType.Category = dtcText) and (TblColumn.Name <> ForeignKey.ForeignColumns[idx]) then begin - TextCol := TblColumn.Name; - break; - end; + Columns := RefObj.TableColumns; + for TblColumn in Columns do begin + if (TblColumn.DataType.Category = dtcText) and (TblColumn.Name <> ForeignKey.ForeignColumns[idx]) then begin + TextCol := TblColumn.Name; + break; end; end; KeyCol := Conn.QuoteIdent(ForeignKey.ForeignColumns[idx]); if TextCol <> '' then begin - SQL := KeyCol+', ' + Conn.GetSQLSpecifity(spFuncLeft, [Conn.QuoteIdent(TextCol), 256])+ - ' FROM '+Conn.QuoteIdent(ForeignKey.ReferenceTable, True, '.')+ + SQL := KeyCol+', ' + Conn.SqlProvider.GetSql(qFuncLeft, [Conn.QuoteIdent(TextCol), 256])+ + ' FROM ' + RefObj.QuotedDbAndTableName + ' GROUP BY '+KeyCol+', '+Conn.QuoteIdent(TextCol)+ // MSSQL complains if the text columns is not grouped ' ORDER BY '+Conn.QuoteIdent(TextCol); end else begin SQL := KeyCol+ - ' FROM '+Conn.QuoteIdent(ForeignKey.ReferenceTable, True, '.')+ + ' FROM ' + RefObj.QuotedDbAndTableName + ' GROUP BY '+KeyCol+ ' ORDER BY '+KeyCol; end; @@ -10070,12 +11231,20 @@ procedure TMainForm.AnyGridCreateEditor(Sender: TBaseVirtualTree; Node: ForeignResults := Conn.GetResults(SQL); if ForeignResults.RecordCount < ForeignItemsLimit then begin - EnumEditor := TEnumEditorLink.Create(VT, AllowEdit); + EnumEditor := TEnumEditorLink.Create(VT, AllowEdit, TblColumn); EditLink := EnumEditor; + DisplayHex := (not actBlobAsText.Checked) and (ForeignResults.DataType(0).Category in [dtcBinary, dtcSpatial]); while not ForeignResults.Eof do begin - EnumEditor.ValueList.Add(ForeignResults.Col(0)); - if TextCol <> '' then - EnumEditor.DisplayList.Add(ForeignResults.Col(0)+': '+ForeignResults.Col(1)); + if DisplayHex then + EnumEditor.ValueList.Add(ForeignResults.HexValue(0)) + else + EnumEditor.ValueList.Add(ForeignResults.Col(0)); + if TextCol <> '' then begin + if DisplayHex then + EnumEditor.DisplayList.Add(ForeignResults.Col(1) + ' (' + ForeignResults.HexValue(0) + ')') + else + EnumEditor.DisplayList.Add(ForeignResults.Col(1) + ' (' + ForeignResults.Col(0) + ')'); + end; ForeignResults.Next; end; end else begin @@ -10089,97 +11258,127 @@ procedure TMainForm.AnyGridCreateEditor(Sender: TBaseVirtualTree; Node: end; end; - FGridEditFunctionMode := FGridEditFunctionMode or Results.IsFunction(Column); + FGridEditFunctionMode := FGridEditFunctionMode or Results.IsFunction(ResultCol); if FGridEditFunctionMode then begin - EnumEditor := TEnumEditorLink.Create(VT, AllowEdit); - for idx:=Low(MySQLFunctions) to High(MySQLFunctions) do - EnumEditor.ValueList.Add(MySQLFunctions[idx].Name + MySQLFunctions[idx].Declaration); + EnumEditor := TEnumEditorLink.Create(VT, AllowEdit, TblColumn); + for SQLFunc in Conn.SQLFunctions do + EnumEditor.ValueList.Add(SQLFunc.Name + SQLFunc.Declaration); EnumEditor.AllowCustomText := True; EditLink := EnumEditor; end; - TypeCat := Results.DataType(Column).Category; - TblColumn := Results.ColAttributes(Column); + TypeCat := Results.DataType(ResultCol).Category; if Assigned(EditLink) then // Editor was created above, do nothing now - else if (Results.DataType(Column).Index in [dtEnum, dtBool]) and AppSettings.ReadBool(asFieldEditorEnum) then begin - EnumEditor := TEnumEditorLink.Create(VT, AllowEdit); - EnumEditor.ValueList := Results.ValueList(Column); + else if (Results.DataType(ResultCol).Index in [dbdtEnum, dbdtBool]) and AppSettings.ReadBool(asFieldEditorEnum) then begin + EnumEditor := TEnumEditorLink.Create(VT, AllowEdit, TblColumn); + EnumEditor.ValueList := Results.ValueList(ResultCol); EditLink := EnumEditor; end else if (TypeCat = dtcText) or ((TypeCat in [dtcBinary, dtcSpatial]) and actBlobAsText.Checked) then begin - InplaceEditor := TInplaceEditorLink.Create(VT, AllowEdit); - InplaceEditor.MaxLength := Results.MaxLength(Column); - InplaceEditor.TitleText := Results.ColumnOrgNames[Column]; + InplaceEditor := TInplaceEditorLink.Create(VT, AllowEdit, TblColumn); + InplaceEditor.MaxLength := Results.MaxLength(ResultCol); + InplaceEditor.TitleText := Results.ColumnOrgNames[ResultCol]; InplaceEditor.ButtonVisible := True; EditLink := InplaceEditor; end else if (TypeCat in [dtcBinary, dtcSpatial]) and AppSettings.ReadBool(asFieldEditorBinary) then begin - HexEditor := THexEditorLink.Create(VT, AllowEdit); - HexEditor.MaxLength := Results.MaxLength(Column); - HexEditor.TitleText := Results.ColumnOrgNames[Column]; + HexEditor := THexEditorLink.Create(VT, AllowEdit, TblColumn); + HexEditor.MaxLength := Results.MaxLength(ResultCol); + HexEditor.TitleText := Results.ColumnOrgNames[ResultCol]; EditLink := HexEditor; end else if (TypeCat = dtcTemporal) and AppSettings.ReadBool(asFieldEditorDatetime) and Assigned(TblColumn) // Editor crashes without a column object (on joins), see #1024 then begin // Ensure date/time editor starts with a non-empty text value - if (Results.Col(Column) = '') and AppSettings.ReadBool(asFieldEditorDatetimePrefill) then begin - case Results.DataType(Column).Index of - dtDate: NowText := DateToStr(Now); - dtTime: NowText := TimeToStr(Now); + if (Results.Col(ResultCol) = '') and AppSettings.ReadBool(asFieldEditorDatetimePrefill) then begin + case Results.DataType(ResultCol).Index of + dbdtDate: NowText := DateToStr(Now); + dbdtTime: NowText := TimeToStr(Now); // Add this case to prevent error with datatype year and sql_mode STRICT_TRANS_TABLES // who absolutly want year and not date time // http://www.heidisql.com/forum.php?t=14728 - dtYear: NowText := FormatDateTime('yyyy',Now); + dbdtYear: NowText := FormatDateTime('yyyy',Now); else NowText := DateTimeToStr(Now); end; - MicroSecondsPrecision := MakeInt(Results.ColAttributes(Column).LengthSet); + MicroSecondsPrecision := MakeInt(Results.ColAttributes(ResultCol).LengthSet); // Don't generate MicroSecond when DataType is Year - if (MicroSecondsPrecision > 0) and (Results.DataType(Column).Index <> dtYear ) then + if (MicroSecondsPrecision > 0) and (Results.DataType(ResultCol).Index <> dbdtYear ) then NowText := NowText + '.' + StringOfChar('0', MicroSecondsPrecision); VT.Text[Node, Column] := NowText; end; - DateTimeEditor := TDateTimeEditorLink.Create(VT, AllowEdit); + DateTimeEditor := TDateTimeEditorLink.Create(VT, AllowEdit, TblColumn); EditLink := DateTimeEditor; end else if AppSettings.ReadBool(asFieldEditorDatetime) and HandleUnixTimestampColumn(Sender, Column) and Assigned(TblColumn) // see above then begin - DateTimeEditor := TDateTimeEditorLink.Create(VT, AllowEdit); + DateTimeEditor := TDateTimeEditorLink.Create(VT, AllowEdit, TblColumn); EditLink := DateTimeEditor; - end else if (Results.DataType(Column).Index = dtSet) and AppSettings.ReadBool(asFieldEditorSet) then begin - SetEditor := TSetEditorLink.Create(VT, AllowEdit); - SetEditor.ValueList := Results.ValueList(Column); + end else if (Results.DataType(ResultCol).Index = dbdtSet) and AppSettings.ReadBool(asFieldEditorSet) then begin + SetEditor := TSetEditorLink.Create(VT, AllowEdit, TblColumn); + SetEditor.ValueList := Results.ValueList(ResultCol); EditLink := SetEditor; end else begin - InplaceEditor := TInplaceEditorLink.Create(VT, AllowEdit); + InplaceEditor := TInplaceEditorLink.Create(VT, AllowEdit, TblColumn); InplaceEditor.ButtonVisible := False; EditLink := InplaceEditor; end; - TBaseGridEditorLink(EditLink).TableColumn := TblColumn; + Sender.FocusedNode := Node; + Sender.FocusedColumn := Column; end; -procedure TMainForm.menuShowSizeColumnClick(Sender: TObject); -var - Item: TMenuItem; +procedure TMainForm.actDisplayLogPanelExecute(Sender: TObject); begin - if coVisible in DBtree.Header.Columns[1].Options then - DBtree.Header.Columns[1].Options := DBtree.Header.Columns[1].Options - [coVisible] - else - DBtree.Header.Columns[1].Options := DBtree.Header.Columns[1].Options + [coVisible]; - Item := Sender as TMenuItem; - Item.Checked := coVisible in DBtree.Header.Columns[1].Options; + if actDisplayLogPanel.Checked then begin + SynMemoSQLLog.Visible := True; + spltTopBottom.Visible := True; + // ensure z-order: top panel, splitter, memo + spltTopBottom.BringToFront; + SynMemoSQLLog.BringToFront; + end + else begin + spltTopBottom.Visible := False; + SynMemoSQLLog.Visible := False; + end; AppSettings.ResetPath; - AppSettings.WriteBool(asDisplayObjectSizeColumn, Item.Checked); + AppSettings.WriteBool(asDisplayLogPanel, actDisplayLogPanel.Checked); end; - -procedure TMainForm.menuAutoExpandClick(Sender: TObject); +procedure TMainForm.actDisplayObjectSizeExecute(Sender: TObject); var - Item: TMenuItem; + ColOptions: TVTColumnOptions; begin - // Activate expand on click tree feature + ColOptions := DBtree.Header.Columns[1].Options; + if actDisplayObjectSize.Checked then + ColOptions := ColOptions + [coVisible] + else + ColOptions := ColOptions - [coVisible]; + DBtree.Header.Columns[1].Options := ColOptions; + AppSettings.ResetPath; + AppSettings.WriteBool(asDisplayObjectSizeColumn, actDisplayObjectSize.Checked); +end; + +procedure TMainForm.actDisplayTreeFiltersExecute(Sender: TObject); +begin + ToolBarTree.Visible := actDisplayTreeFilters.Checked; + pnlLeftResize(Sender); // Updates width of filter boxes + AppSettings.ResetPath; + AppSettings.WriteBool(asDisplayTreeFilters, actDisplayTreeFilters.Checked); +end; + +procedure TMainForm.menuAlwaysGenerateFilterClick(Sender: TObject); +begin + // Store setting for toggled filter generation + AppSettings.WriteBool(asAlwaysGenerateFilter, menuAlwaysGenerateFilter.Checked); +end; + +procedure TMainForm.menuAutoExpandClick(Sender: TObject); +var + Item: TMenuItem; +begin + // Activate expand on click tree feature if toAutoExpand in DBtree.TreeOptions.AutoOptions then DBtree.TreeOptions.AutoOptions := DBtree.TreeOptions.AutoOptions - [toAutoExpand] else @@ -10213,7 +11412,10 @@ procedure TMainForm.AutoCalcColWidth(Tree: TVirtualStringTree; Column: TColumnIn if not (coVisible in Col.Options) then Exit; ColTextWidth := Tree.Canvas.TextWidth(Col.Text); - // Add space for sort glyph + // Add space for column id ... + if (Column > 0) and AppSettings.ReadBool(asShowRowId) then + ColTextWidth := ColTextWidth + Tree.Canvas.TextWidth(Column.ToString) + 5; + // ... and sort glyph if Col.ImageIndex > -1 then ColTextWidth := ColTextWidth + 20; Node := Tree.GetFirstVisible; @@ -10234,8 +11436,8 @@ procedure TMainForm.AutoCalcColWidth(Tree: TVirtualStringTree; Column: TColumnIn // here if the query or connection dies. Rect := Tree.GetDisplayRect(Node, Column, True, True); ContentTextWidth := Rect.Right - Rect.Left; - if vsMultiLine in Node.States then - ContentTextWidth := Max(ContentTextWidth, Tree.Canvas.TextWidth(Tree.Text[Node, Column])); + //if vsMultiLine in Node.States then + // ContentTextWidth := Max(ContentTextWidth, Tree.Canvas.TextWidth(Tree.Text[Node, Column])); ColTextWidth := Max(ColTextWidth, ContentTextWidth); inc(i); if i > 100 then break; @@ -10256,14 +11458,17 @@ procedure TMainForm.AnyGridBeforeCellPaint(Sender: TBaseVirtualTree; CellPaintMode: TVTCellPaintMode; CellRect: TRect; var ContentRect: TRect); var r: TDBQuery; - cl, clNull, clEven, clOdd, clSameData: TColor; + cl, clNull, clSameData: TColor; RowNumber: PInt64; - isEven, FocusedIsNull, CurrentIsNull: Boolean; + FocusedIsNull, CurrentIsNull: Boolean; FieldText, FocusedFieldText: String; VT: TVirtualStringTree; + ResultCol: Integer; + SelectedNode: PVirtualNode; begin if Column = -1 then Exit; + ResultCol := Column -1; r := GridResult(Sender); if (r=nil) or (not r.Connection.Active) then begin @@ -10272,19 +11477,20 @@ procedure TMainForm.AnyGridBeforeCellPaint(Sender: TBaseVirtualTree; Exit; end; + if ResultCol < 0 then begin + if r.Connection.Parameters.SessionColor <> AppSettings.GetDefaultInt(asTreeBackground) then + TargetCanvas.Brush.Color := r.Connection.Parameters.SessionColor + else + TargetCanvas.Brush.Color := clBtnFace; + TargetCanvas.FillRect(CellRect); + Exit; + end; + VT := Sender as TVirtualStringTree; RowNumber := Sender.GetNodeData(Node); r.RecNo := RowNumber^; - clEven := AppSettings.ReadInt(asRowBackgroundEven); - clOdd := AppSettings.ReadInt(asRowBackgroundOdd); - isEven := Node.Index mod 2 = 0; - if IsEven and (clEven <> clNone) then - cl := AppSettings.ReadInt(asRowBackgroundEven) - else if (not IsEven) and (clOdd <> clNone) then - cl := AppSettings.ReadInt(asRowBackgroundOdd) - else - cl := clNone; + cl := GetAlternatingRowBackground(Node); if (vsSelected in Node.States) and (Node = Sender.FocusedNode) and (Column = Sender.FocusedColumn) then begin // Focused cell @@ -10295,7 +11501,7 @@ procedure TMainForm.AnyGridBeforeCellPaint(Sender: TBaseVirtualTree; cl := ColorAdjustBrightness(VT.Color, -29) else cl := ColorAdjustBrightness(VT.Color, 29); - end else if r.IsNull(Column) then begin + end else if r.IsNull(ResultCol) then begin // Cell with NULL value clNull := AppSettings.ReadInt(asFieldNullBackground); if clNull <> clNone then @@ -10307,22 +11513,29 @@ procedure TMainForm.AnyGridBeforeCellPaint(Sender: TBaseVirtualTree; end; // Probably display background color on fields with same text - // Result pointer gets moved to the focused node.. careful! - if (Sender.FocusedNode <> nil) then begin - if ((Node <> Sender.FocusedNode) and (Column = Sender.FocusedColumn)) - or ((Node = Sender.FocusedNode) and (Column <> Sender.FocusedColumn)) then begin + // Result pointer gets moved to selected nodes.. careful! + if (Sender.FocusedNode <> nil) and (Sender.FocusedColumn > 0) and (Sender.SelectedCount <= 100) then begin + if ((not Sender.Selected[Node]) and (Column = Sender.FocusedColumn)) + or (Sender.Selected[Node] and (Column <> Sender.FocusedColumn)) then begin clSameData := AppSettings.ReadInt(asHightlightSameTextBackground); if clSameData <> clNone then begin - FieldText := r.Col(Column); - CurrentIsNull := r.IsNull(Column); - RowNumber := Sender.GetNodeData(Sender.FocusedNode); - r.RecNo := RowNumber^; // moving result cursor - FocusedFieldText := r.Col(Sender.FocusedColumn); - FocusedIsNull := r.IsNull(Sender.FocusedColumn); - if (CompareText(FieldText, FocusedFieldText) = 0) and (CurrentIsNull = FocusedIsNull) then begin - TargetCanvas.Brush.Color := clSameData; - TargetCanvas.FillRect(CellRect); + FieldText := r.Col(ResultCol); + CurrentIsNull := r.IsNull(ResultCol); + + SelectedNode := GetNextNode(VT, nil, True); + while Assigned(SelectedNode) do begin + RowNumber := Sender.GetNodeData(SelectedNode); + r.RecNo := RowNumber^; // moving result cursor + FocusedFieldText := r.Col(Sender.FocusedColumn-1); + FocusedIsNull := r.IsNull(Sender.FocusedColumn-1); + if (CompareText(FieldText, FocusedFieldText) = 0) and (CurrentIsNull = FocusedIsNull) then begin + TargetCanvas.Brush.Color := clSameData; + TargetCanvas.FillRect(CellRect); + Break; // No need to look further + end; + SelectedNode := GetNextNode(VT, SelectedNode, True); end; + end; end; end; @@ -10333,8 +11546,9 @@ procedure TMainForm.AnyGridBeforeCellPaint(Sender: TBaseVirtualTree; procedure TMainForm.HandleDataGridAttributes(RefreshingData: Boolean); var rx: TRegExpr; - idx, i: Integer; + i: Integer; Sort, KeyName, FocusedCol, CellFocus, Filter: String; + SortItem: TSortItem; begin actDataResetSorting.Enabled := False; // Clear filter, column names and sort structure if gr @@ -10346,12 +11560,22 @@ procedure TMainForm.HandleDataGridAttributes(RefreshingData: Boolean); if not Assigned(DataGridFocusedCell) then DataGridFocusedCell := TStringList.Create; // Remember focused node and column for selected table - if Assigned(DataGrid.FocusedNode) and (ActiveConnection<>nil) and Assigned(DataGridTable) then begin - KeyName := DataGridTable.QuotedDatabase+'.'+DataGridTable.QuotedName; - FocusedCol := ''; - if DataGrid.FocusedColumn > NoColumn then - FocusedCol := DataGrid.Header.Columns[DataGrid.FocusedColumn].Text; - DataGridFocusedCell.Values[KeyName] := IntToStr(DataGrid.FocusedNode.Index) + DELIM + FocusedCol; + if Assigned(DataGrid.FocusedNode) + and (ActiveConnection <> nil) + and (DataGridTable <> nil) + and Assigned(DataGridTable) + then begin + try + KeyName := DataGridTable.QuotedDatabase+'.'+DataGridTable.QuotedName; + FocusedCol := ''; + if DataGrid.FocusedColumn > NoColumn then + FocusedCol := DataGrid.Header.Columns[DataGrid.FocusedColumn].Text; + DataGridFocusedCell.Values[KeyName] := IntToStr(DataGrid.FocusedNode.Index) + DELIM + FocusedCol; + except + on E:EAccessViolation do begin + LogSQL('HandleDataGridAttributes: '+E.Message, lcError); + end; + end; end; DataGridFocusedNodeIndex := 0; DataGridFocusedColumnName := ''; @@ -10364,7 +11588,7 @@ procedure TMainForm.HandleDataGridAttributes(RefreshingData: Boolean); if not RefreshingData then begin DataGridHiddenColumns.Clear; SynMemoFilter.Clear; - SetLength(DataGridSortColumns, 0); + FDataGridSortItems.Clear; DataGridWantedRowCount := 0; while DataGridFocusedNodeIndex >= DataGridWantedRowCount do Inc(DataGridWantedRowCount, AppSettings.ReadInt(asDatagridRowsPerStep)); @@ -10381,8 +11605,10 @@ procedure TMainForm.HandleDataGridAttributes(RefreshingData: Boolean); else if AppSettings.ValueExists(asFilter) then AppSettings.DeleteValue(asFilter); - for i := 0 to High(DataGridSortColumns) do - Sort := Sort + IntToStr(DataGridSortColumns[i].SortDirection) + '_' + DataGridSortColumns[i].ColumnName + DELIM; + Sort := ''; + for SortItem in FDataGridSortItems do begin + Sort := Sort + IntToStr(Integer(SortItem.Order)) + '_' + SortItem.Column + DELIM; + end; if Sort <> '' then AppSettings.WriteString(asSort, Sort) else if AppSettings.ValueExists(asSort) then @@ -10417,26 +11643,25 @@ procedure TMainForm.HandleDataGridAttributes(RefreshingData: Boolean); // Sort if AppSettings.ValueExists(asSort) then begin - SetLength(DataGridSortColumns, 0); + FDataGridSortItems.Clear; rx := TRegExpr.Create; rx.Expression := '\b(\d)_(.+)\'+DELIM; rx.ModifierG := False; if rx.Exec(AppSettings.ReadString(asSort)) then while true do begin - idx := Length(DataGridSortColumns); // Check if column exists, could be renamed or deleted for i:=0 to SelectedTableColumns.Count-1 do begin if SelectedTableColumns[i].Name = rx.Match[2] then begin - SetLength(DataGridSortColumns, idx+1); - DataGridSortColumns[idx] := TOrderCol.Create; - DataGridSortColumns[idx].ColumnName := rx.Match[2]; - DataGridSortColumns[idx].SortDirection := StrToIntDef(rx.Match[1], ORDER_ASC); - break; + SortItem := FDataGridSortItems.AddNew; + SortItem.Column := rx.Match[2]; + SortItem.Order := TSortItemOrder(StrToIntDef(rx.Match[1], 0)); + LogSQL('Restored sorting for column '+SortItem.Column+'/'+Integer(SortItem.Order).ToString+' in TMainForm.HandleDataGridAttributes', lcDebug); + Break; end; end; if not rx.ExecNext then break; end; - actDataResetSorting.Enabled := Length(DataGridSortColumns) > 0; + actDataResetSorting.Enabled := FDataGridSortItems.Count > 0; end; AppSettings.ResetPath; @@ -10444,10 +11669,13 @@ procedure TMainForm.HandleDataGridAttributes(RefreshingData: Boolean); function TMainForm.GetRegKeyTable: String; +var + o: TDBObject; begin // Return the slightly complex registry path to \Servers\CustomFolder\ActiveServer\curdb|curtable - Result := ActiveDbObj.Connection.Parameters.SessionPath + '\' + - ActiveDatabase + DELIM + ActiveDbObj.Name; + o := ActiveDbObj; + Result := o.Connection.Parameters.SessionPath + '\' + + ActiveDatabase + DELIM + o.Name; end; @@ -10462,7 +11690,10 @@ procedure TMainForm.AnyGridMouseUp(Sender: TObject; Button: TMouseButton; Grid := Sender as TVirtualStringTree; if not Assigned(Grid.FocusedNode) then Exit; - Grid.GetHitTestInfoAt(X, Y, False, Hit); + // Exit early for non-result-grids like ListTables + if Grid <> ActiveGrid then + Exit; + Grid.GetHitTestInfoAt(X, Y, True, Hit); if (Hit.HitNode = nil) or (Hit.HitColumn = NoColumn) or (Hit.HitColumn = InvalidColumn) then begin Results := GridResult(Grid); if Results.Modified then begin @@ -10473,31 +11704,6 @@ procedure TMainForm.AnyGridMouseUp(Sender: TObject; Button: TMouseButton; end; -procedure TMainForm.ListDatabasesBeforeCellPaint(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; - Node: PVirtualNode; Column: TColumnIndex; CellPaintMode: TVTCellPaintMode; CellRect: TRect; - var ContentRect: TRect); -var - vt: TVirtualStringTree; - Val, Max: Extended; - LoopNode: PVirtualNode; -begin - // Display color bars - if Column in [1,2,4..9] then begin - vt := Sender as TVirtualStringTree; - // Find out maximum value in column - LoopNode := vt.GetFirst; - Max := 1; - while Assigned(LoopNode) do begin - Val := MakeFloat(vt.Text[LoopNode, Column]); - if Val > Max then - Max := Val; - LoopNode := vt.GetNext(LoopNode); - end; - PaintColorBar(MakeFloat(vt.Text[Node, Column]), Max, TargetCanvas, CellRect); - end; -end; - - procedure TMainForm.ListDatabasesBeforePaint(Sender: TBaseVirtualTree; TargetCanvas: TCanvas); var vt: TVirtualStringTree; @@ -10687,11 +11893,12 @@ procedure TMainForm.HostListBeforePaint(Sender: TBaseVirtualTree; TargetCanvas: vt.BeginUpdate; OldOffset := vt.OffsetXY; vt.Clear; - if Conn <> nil then begin + Screen.Cursor := crHourglass; + + if Conn <> nil then try Results := GridResult(vt); if Results <> nil then FreeAndNil(Results); - Screen.Cursor := crHourglass; if vt = ListVariables then begin // Do not use FHostListResults on Variables tab, as we cannot query // session and global variables in one query @@ -10704,23 +11911,26 @@ procedure TMainForm.HostListBeforePaint(Sender: TBaseVirtualTree; TargetCanvas: FVariableNames.Sorted := True; FSessionVars := TStringList.Create; FGlobalVars := TStringList.Create; - Variables := Conn.GetResults(Conn.GetSQLSpecifity(spSessionVariables)); + Variables := Conn.GetResults(Conn.SqlProvider.GetSql(qSessionVariables)); while not Variables.Eof do begin FVariableNames.Add(Variables.Col(0)); - FSessionVars.Values[Variables.Col(0)] := Variables.Col(1); + FSessionVars.Values[Variables.Col(0)] := IfThen(Variables.IsNull(1), TEXT_NULL, Variables.Col(1)); Variables.Next; end; Variables.Free; - Variables := Conn.GetResults(Conn.GetSQLSpecifity(spGlobalVariables)); - while not Variables.Eof do begin - FVariableNames.Add(Variables.Col(0)); - FGlobalVars.Values[Variables.Col(0)] := Variables.Col(1); - Variables.Next; + if Conn.SqlProvider.Has(qGlobalVariables) then begin + Variables := Conn.GetResults(Conn.SqlProvider.GetSql(qGlobalVariables)); + while not Variables.Eof do begin + FVariableNames.Add(Variables.Col(0)); + FGlobalVars.Values[Variables.Col(0)] := Variables.Col(1); + FGlobalVars.Values[Variables.Col(0)] := IfThen(Variables.IsNull(1), TEXT_NULL, Variables.Col(1)); + Variables.Next; + end; + Variables.Free; end; - Variables.Free; vt.RootNodeCount := FVariableNames.Count; end else if vt = ListStatus then begin - Results := Conn.GetResults(Conn.GetSQLSpecifity(spGlobalStatus)); + Results := Conn.GetResults(Conn.SqlProvider.GetSql(qGlobalStatus)); FStatusServerUptime := Conn.ServerUptime; end else if vt = ListProcesses then begin case Conn.Parameters.NetTypeGroup of @@ -10774,8 +11984,8 @@ procedure TMainForm.HostListBeforePaint(Sender: TBaseVirtualTree; TargetCanvas: ', RTRIM('+Conn.QuoteIdent('p')+'.'+Conn.QuoteIdent('status')+'), '+ 'NULL AS '+Conn.QuoteIdent('Info')+' '+ 'FROM '+Conn.QuoteIdent('sys')+'.'+Conn.QuoteIdent('sysprocesses')+' AS '+Conn.QuoteIdent('p')+ - ', '+Conn.GetSQLSpecifity(spDatabaseTable)+' AS '+Conn.QuoteIdent('d')+ - ' WHERE '+Conn.QuoteIdent('p')+'.'+Conn.QuoteIdent('dbid')+'='+Conn.QuoteIdent('d')+'.'+Conn.GetSQLSpecifity(spDatabaseTableId) + ', '+Conn.SqlProvider.GetSql(qDatabaseTable)+' AS '+Conn.QuoteIdent('d')+ + ' WHERE '+Conn.QuoteIdent('p')+'.'+Conn.QuoteIdent('dbid')+'='+Conn.QuoteIdent('d')+'.'+Conn.SqlProvider.GetSql(qDatabaseTableId) ); end; ngPgSQL: begin @@ -10801,7 +12011,7 @@ procedure TMainForm.HostListBeforePaint(Sender: TBaseVirtualTree; TargetCanvas: Results.Next; end; end else if vt = ListCommandStats then begin - Results := Conn.GetResults(Conn.GetSQLSpecifity(spCommandsCounters)); + Results := Conn.GetResults(Conn.SqlProvider.GetSql(qCommandsCounters)); FCommandStatsServerUptime := Conn.ServerUptime; FCommandStatsQueryCount := 0; while not Results.Eof do begin @@ -10811,11 +12021,14 @@ procedure TMainForm.HostListBeforePaint(Sender: TBaseVirtualTree; TargetCanvas: end; FHostListResults[Tab.PageIndex] := Results; - Screen.Cursor := crDefault; if Results <> nil then vt.RootNodeCount := Results.RecordCount; vt.OffsetXY := OldOffset; + except + on E:Exception do ErrorDialog(E.Message); end; + + Screen.Cursor := crDefault; // Apply or reset filter editFilterVTChange(Sender); vt.EndUpdate; @@ -10833,10 +12046,43 @@ procedure TMainForm.HostListBeforeCellPaint(Sender: TBaseVirtualTree; TargetCanv var ContentRect: TRect); var vt: TVirtualStringTree; + Val, Max: Extended; + LoopNode: PVirtualNode; + SessionVal, GlobalVal: String; begin + PaintAlternatingRowBackground(TargetCanvas, Node, CellRect); vt := Sender as TVirtualStringTree; - if (Column = 5) and (vt = ListProcesses) then + + if (Column in [1,2,4..9]) and (vt = ListDatabases) then begin + // Find out maximum value in column + LoopNode := vt.GetFirst; + Max := 1; + while Assigned(LoopNode) do begin + Val := MakeFloat(vt.Text[LoopNode, Column]); + if Val > Max then + Max := Val; + LoopNode := vt.GetNext(LoopNode); + end; + PaintColorBar(MakeFloat(vt.Text[Node, Column]), Max, TargetCanvas, CellRect); + end; + + // Highlight cell if session variable is different to global variable + if (Column = 1) and (vt = ListVariables) then begin + SessionVal := vt.Text[Node, 1]; + GlobalVal := vt.Text[Node, 2]; + if SessionVal <> GlobalVal then begin + TargetCanvas.Brush.Color := clWebBlanchedAlmond; + TargetCanvas.Pen.Color := TargetCanvas.Brush.Color; + TargetCanvas.Rectangle(CellRect); + end; + end; + + // Nothing special on Status tab + + if (Column = 5) and (vt = ListProcesses) then begin PaintColorBar(MakeFloat(vt.Text[Node, Column]), FProcessListMaxTime, TargetCanvas, CellRect); + end; + if (Column = 4) and (vt = ListCommandStats) then begin // Only paint bar in percentage column PaintColorBar(MakeFloat(vt.Text[Node, Column]), 100, TargetCanvas, CellRect); @@ -10844,30 +12090,179 @@ procedure TMainForm.HostListBeforeCellPaint(Sender: TBaseVirtualTree; TargetCanv end; +procedure TMainForm.actFollowForeignKeyExecute(Sender: TObject); +var + Results: TDBQuery; + RowNum: PInt64; + FocusedColumnName, ForeignColumnName: String; + ForeignKey: TForeignKey; + i: Integer; + DBObj, ReferenceTable: TDBObject; + Datatype: TDBDatatype; + DbObjects: TDBObjectList; + Filter: String; + Conn: TDBConnection; +begin + Results := GridResult(DataGrid); + RowNum := DataGrid.GetNodeData(DataGrid.FocusedNode); + Results.RecNo := RowNum^; + FocusedColumnName := Results.ColumnOrgNames[DataGrid.FocusedColumn-1]; + Conn := Results.Connection; + ReferenceTable := nil; + + // find foreign key for current column + for ForeignKey in ActiveDBObj.TableForeignKeys do begin + i := ForeignKey.Columns.IndexOf(FocusedColumnName); + if i > -1 then begin + ForeignColumnName := ForeignKey.ForeignColumns[i]; + ReferenceTable := ForeignKey.ReferenceTableObj; + break; + end; + end; + if ForeignColumnName = '' then begin + LogSQL(f_('Foreign key not found for column "%s"', [FocusedColumnName]), lcInfo); + Exit; + end; + if ReferenceTable = nil then begin + LogSQL(_('Foreign key table not found')); + Exit; + end; + Datatype := Results.DataType(DataGrid.FocusedColumn-1); + // filter to show only rows linked by the foreign key + if DataType.Category in [dtcBinary, dtcSpatial] then + Filter := Conn.QuoteIdent(ForeignColumnName)+'='+Results.HexValue(DataGrid.FocusedColumn-1) + else + Filter := Conn.QuoteIdent(ForeignColumnName)+'='+Conn.EscapeString(Results.Col(DataGrid.FocusedColumn-1)); + + // Jumping to ReferenceTable. Caution, this invalidates the above used Results + ActiveDBObj := ReferenceTable; + + SynMemoFilter.Text := Filter; + ToggleFilterPanel(True); + actApplyFilter.Execute; + // SynMemoFilter will be cleared and set value of asFilter (in HandleDataGridAttributes from DataGridBeforePaint) + AppSettings.SessionPath := GetRegKeyTable; + AppSettings.WriteString(asFilter, Filter); +end; + + +procedure TMainForm.actCopyGridNodesExecute(Sender: TObject); +var + SenderControl: TComponent; + SenderName: String; + Grid: TVirtualStringTree; + Header, Body, Line, Data: String; + Separator, Encloser, Terminator: String; + Node: PVirtualNode; + Col: TColumnIndex; + Indent, NodesCopied: Integer; + IsFirstCol: Boolean; +begin + // Copy tree nodes as CSV, from any VirtualTree, not only from data or result grids + // See issue #2083 + SenderControl := PopupComponent(Sender); + if SenderControl=nil then + SenderControl := Screen.ActiveControl; + + if not (SenderControl is TVirtualStringTree) then begin + if SenderControl=nil then + SenderName := 'nil' + else + SenderName := SenderControl.Name; + ErrorDialog(f_('No listing or tree focused. ActiveControl is %s', [SenderName])); + Exit; + end; + + Screen.Cursor := crHourGlass; + Grid := TVirtualStringTree(SenderControl); + // Grid.CopyToClipboard; // Does nothing (?) + + Separator := #9; + Encloser := ''; + Terminator := SLineBreak; + + Header := ''; + Col := Grid.Header.Columns.GetFirstVisibleColumn(True); + IsFirstCol := True; + while Col > NoColumn do begin + Data := Grid.Header.Columns[Col].Text; + //Data := StringReplace(Data, Encloser, Encloser+Encloser, [rfReplaceAll]); + if not IsFirstCol then + Header := Header + Separator; + IsFirstCol := False; + //Header := Header + Encloser + Data + Encloser; + Header := Header + Data; + Col := Grid.Header.Columns.GetNextVisibleColumn(Col); + end; + Header := Header + Terminator; + + Body := ''; + NodesCopied := 0; + Node := Grid.GetFirstInitialized; + while Assigned(Node) do begin + if Grid.IsVisible[Node] then begin + IsFirstCol := True; + Line := ''; + + // One empty cell for each indentation level + for Indent := 1 to Grid.GetNodeLevel(Node) do begin + if not IsFirstCol then + Line := Line + Separator; + IsFirstCol := False; + //Line := Line + Encloser + Encloser; + end; + + // Add data cells + Col := Grid.Header.Columns.GetFirstVisibleColumn(True); + while Col > NoColumn do begin + Data := Grid.Text[Node, Col]; + //Data := StringReplace(Data, Encloser, Encloser+Encloser, [rfReplaceAll]); + if not IsFirstCol then + Line := Line + Separator; + IsFirstCol := False; + //Line := Line + Encloser + Data + Encloser; + Line := Line + Data; + Col := Grid.Header.Columns.GetNextVisibleColumn(Col); + end; + + Body := Body + Line + Terminator; + Inc(NodesCopied); + end; + Node := Grid.GetNextInitialized(Node); + end; + + Clipboard.TryAsText := Header + Body; + + Screen.Cursor := crDefault; + LogSQL(f_('%s: %s lines copied to clipboard', [SLogPrefixInfo, FormatNumber(NodesCopied)]), lcInfo); + MessageBeep(MB_ICONASTERISK); +end; + procedure TMainForm.actCopyOrCutExecute(Sender: TObject); var - Control: TWinControl; + CurrentControl: TWinControl; SendingControl: TComponent; + SenderName, TextCopy: String; Edit: TCustomEdit; Combo: TCustomComboBox; Grid: TVirtualStringTree; SynMemo: TSynMemo; DoCut, DoCopyRows: Boolean; - IsResultGrid: Boolean; + IsResultGrid, HasNulls: Boolean; ClpFormat: Word; ClpData: THandle; APalette: HPalette; - Exporter: TSynExporterRTF; Results: TDBQuery; RowNum: PInt64; ExportDialog: TfrmExportGrid; begin // Copy text from a focused control to clipboard - Control := Screen.ActiveControl; + CurrentControl := Screen.ActiveControl; + SendingControl := TAction(Sender).ActionComponent; + SenderName := TAction(Sender).Name; DoCut := Sender = actCut; - DoCopyRows := Sender = actCopyRows; + DoCopyRows := SenderName.StartsWith(TfrmExportGrid.CopyAsActionPrefix); FClipboardHasNull := False; - SendingControl := (Sender as TAction).ActionComponent; Screen.Cursor := crHourglass; try if SendingControl = btnPreviewCopy then begin @@ -10875,20 +12270,20 @@ procedure TMainForm.actCopyOrCutExecute(Sender: TObject); imgPreview.Picture.SaveToClipBoardFormat(ClpFormat, ClpData, APalette); ClipBoard.SetAsHandle(ClpFormat, ClpData); end; - end else if Control is TCustomEdit then begin - Edit := TCustomEdit(Control); + end else if CurrentControl is TCustomEdit then begin + Edit := TCustomEdit(CurrentControl); if Edit.SelLength > 0 then begin if DoCut then Edit.CutToClipboard else Edit.CopyToClipboard; end; - end else if Control is TCustomComboBox then begin - Combo := TCustomComboBox(Control); + end else if CurrentControl is TCustomComboBox then begin + Combo := TCustomComboBox(CurrentControl); if Combo.SelLength > 0 then begin - Clipboard.AsText := Combo.SelText; + Clipboard.TryAsText := Combo.SelText; if DoCut then Combo.SelText := ''; end; - end else if Control is TVirtualStringTree then begin - Grid := Control as TVirtualStringTree; + end else if CurrentControl is TVirtualStringTree then begin + Grid := CurrentControl as TVirtualStringTree; if Assigned(Grid.FocusedNode) then begin IsResultGrid := Grid = ActiveGrid; FGridCopying := True; @@ -10904,45 +12299,78 @@ procedure TMainForm.actCopyOrCutExecute(Sender: TObject); Results := GridResult(Grid); RowNum := Grid.GetNodeData(Grid.FocusedNode); Results.RecNo := RowNum^; - if Results.IsNull(Grid.FocusedColumn) then begin - Clipboard.AsText := ''; + if Results.IsNull(Grid.FocusedColumn-1) then begin + Clipboard.TryAsText := ''; FClipboardHasNull := True; - end else - Clipboard.AsText := Grid.Text[Grid.FocusedNode, Grid.FocusedColumn]; + end else begin + TextCopy := Grid.Text[Grid.FocusedNode, Grid.FocusedColumn]; + RemoveNullChars(TextCopy, HasNulls); + Clipboard.TryAsText := TextCopy; + end; if DoCut then Grid.Text[Grid.FocusedNode, Grid.FocusedColumn] := ''; end; - end else - Clipboard.AsText := Grid.Text[Grid.FocusedNode, Grid.FocusedColumn]; + end else begin + TextCopy := Grid.Text[Grid.FocusedNode, Grid.FocusedColumn]; + RemoveNullChars(TextCopy, HasNulls); + Clipboard.TryAsText := TextCopy; + end; FGridCopying := False; end; - end else if Control is TSynMemo then begin - SynMemo := Control as TSynMemo; + end else if CurrentControl is TSynMemo then begin + SynMemo := CurrentControl as TSynMemo; if SynMemo.SelAvail then begin - // Create both text and RTF clipboard format, so rich text applications can paste highlighted SQL - Clipboard.Open; - Clipboard.AsText := SynMemo.SelText; - Exporter := TSynExporterRTF.Create(Self); - Exporter.Highlighter := SynSQLSynUsed; - Exporter.ExportAll(Explode(CRLF, SynMemo.SelText)); - if DoCut then SynMemo.CutToClipboard - else SynMemo.CopyToClipboard; - Exporter.CopyToClipboard; - Clipboard.Close; - Exporter.Free; + if DoCut then + SynMemo.CutToClipboard + else + SynMemo.CopyToClipboard; end; end else begin - raise Exception.Create('Unhandled control in clipboard action: '+IfThen(Assigned(Control), Control.Name, 'nil')); + raise Exception.Create('Unhandled control in clipboard action: '+IfThen(Assigned(CurrentControl), CurrentControl.Name, 'nil')); end; except on E:Exception do begin - LogSQL(E.Message); + LogSQL(E.ClassName + ': ' + E.Message); MessageBeep(MB_ICONASTERISK); end; end; Screen.Cursor := crDefault; end; +procedure TMainForm.actCopyFormattedExecute(Sender: TObject); +var + Exporter: TSynExporterRTF; + SynMemo: TSynMemo; +begin + // Copy formatted SQL text to clipboard + if not (Screen.ActiveControl is TSynMemo) then begin + MessageBeep(MB_ICONWARNING); + LogSQL('Active control is not a SynMemo'); + Exit; + end; + + SynMemo := TSynMemo(Screen.ActiveControl); + if SynMemo.Highlighter = nil then begin + MessageBeep(MB_ICONWARNING); + LogSQL('No highlighter assigned to active SynMemo'); + Exit; + end; + + Exporter := TSynExporterRTF.Create(nil); + try + Exporter.Title := APPNAME; + Exporter.UseBackground := True; + Exporter.Highlighter := SynMemo.Highlighter; + Exporter.ExportAsText := False; + Clipboard.Open; + Clipboard.TryAsText := SynMemo.SelText; + Exporter.ExportAll(Explode(SLineBreak, SynMemo.SelText)); + Exporter.CopyToClipboard; + Clipboard.Close; + finally + Exporter.Free; + end; +end; procedure TMainForm.actPasteExecute(Sender: TObject); var @@ -10967,14 +12395,14 @@ procedure TMainForm.actPasteExecute(Sender: TObject); end else if Control is TComboBox then begin Combo := TComboBox(Control); if Combo.Style = csDropDown then begin - Combo.SelText := ClipBoard.AsText; + Combo.SelText := Clipboard.TryAsText; Success := True; end; end else if Control is TVirtualStringTree then begin Grid := Control as TVirtualStringTree; if Assigned(Grid.FocusedNode) and (Grid = ActiveGrid) then begin FGridPasting := True; - Grid.Text[Grid.FocusedNode, Grid.FocusedColumn] := ClipBoard.AsText; + Grid.Text[Grid.FocusedNode, Grid.FocusedColumn] := Clipboard.TryAsText; Success := True; FGridPasting := False; end; @@ -10995,6 +12423,15 @@ procedure TMainForm.actPasteExecute(Sender: TObject); end; +procedure TMainForm.actSequalSuggestExecute(Sender: TObject); +var + SequalSuggestForm: TSequalSuggestForm; +begin + // Show Sequal Suggest dialog + SequalSuggestForm := TSequalSuggestForm.Create(Self); + SequalSuggestForm.ShowModal; +end; + procedure TMainForm.actSelectAllExecute(Sender: TObject); var Control: TWinControl; @@ -11135,23 +12572,28 @@ procedure TMainForm.PlaceObjectEditor(Obj: TDBObject); EditorClass: TDBObjectEditorClass; begin // Place the relevant editor frame onto the editor tab, hide all others - if Assigned(ActiveObjectEditor) and (Obj.NodeType <> ActiveObjectEditor.DBObject.NodeType) then - FreeAndNil(ActiveObjectEditor); - case Obj.NodeType of - lntTable: EditorClass := TfrmTableEditor; - lntView: EditorClass := TfrmView; - lntProcedure, lntFunction: EditorClass := TfrmRoutineEditor; - lntTrigger: EditorClass := TfrmTriggerEditor; - lntEvent: EditorClass := TfrmEventEditor; - else Exit; - end; - if not Assigned(ActiveObjectEditor) then begin - ActiveObjectEditor := EditorClass.Create(tabEditor); - ActiveObjectEditor.Parent := tabEditor; - MainForm.SetupSynEditors; + if FTreeRefreshInProgress and Assigned(ActiveObjectEditor) then begin + ActiveObjectEditor.Init(Obj); + UpdateFilterPanel(Self); + end else begin + if Assigned(ActiveObjectEditor) and (Obj.NodeType <> ActiveObjectEditor.DBObject.NodeType) then + FreeAndNil(ActiveObjectEditor); + case Obj.NodeType of + lntTable: EditorClass := TfrmTableEditor; + lntView: EditorClass := TfrmView; + lntProcedure, lntFunction: EditorClass := TfrmRoutineEditor; + lntTrigger: EditorClass := TfrmTriggerEditor; + lntEvent: EditorClass := TfrmEventEditor; + else Exit; + end; + if not Assigned(ActiveObjectEditor) then begin + ActiveObjectEditor := EditorClass.Create(tabEditor); + ActiveObjectEditor.Parent := tabEditor; + SetupSynEditors(ActiveObjectEditor); + end; + ActiveObjectEditor.Init(Obj); + buttonedEditClear(editFilterVT); end; - ActiveObjectEditor.Init(Obj); - UpdateFilterPanel(Self); end; @@ -11160,6 +12602,8 @@ procedure TMainForm.UpdateEditorTab; Cap: String; begin tabEditor.ImageIndex := ActiveObjectEditor.DBObject.ImageIndex; + // Reset to grayscale if in background: + PageControlTabHighlight(PageControlMain); Cap := _(ActiveObjectEditor.DBObject.ObjType)+': '; if ActiveObjectEditor.DBObject.Name = '' then Cap := Cap + '['+_('Untitled')+']' @@ -11223,10 +12667,11 @@ procedure TMainForm.ListTablesDblClick(Sender: TObject); procedure TMainForm.actNewQueryTabExecute(Sender: TObject); var i: Integer; - QueryTab: TQueryTab; + QueryTab, OldTab: TQueryTab; HelperColumn: TVirtualTreeColumn; begin i := QueryTabs[QueryTabs.Count-1].Number + 1; + OldTab := QueryTabs.ActiveTab; QueryTabs.Add(TQueryTab.Create(Self)); QueryTab := QueryTabs[QueryTabs.Count-1]; @@ -11234,6 +12679,7 @@ procedure TMainForm.actNewQueryTabExecute(Sender: TObject); QueryTab.Uid := TQueryTab.GenerateUid; QueryTab.TabSheet := TTabSheet.Create(PageControlMain); + QueryTab.TabSheet.Name := tabQuery.Name + i.ToString; QueryTab.TabSheet.PageControl := PageControlMain; QueryTab.TabSheet.ImageIndex := tabQuery.ImageIndex; @@ -11243,22 +12689,28 @@ procedure TMainForm.actNewQueryTabExecute(Sender: TObject); QueryTab.CloseButton.Height := 16; QueryTab.CloseButton.Flat := True; VirtualImageListMain.GetBitmap(134, QueryTab.CloseButton.Glyph); - QueryTab.CloseButton.OnMouseDown := CloseButtonOnMouseDown; - QueryTab.CloseButton.OnMouseUp := CloseButtonOnMouseUp; + QueryTab.CloseButton.OnClick := CloseButtonOnClick; SetTabCaption(QueryTab.TabSheet.PageIndex, ''); // Dumb code which replicates all controls from tabQuery QueryTab.pnlMemo := TPanel.Create(QueryTab.TabSheet); + QueryTab.pnlMemo.Name := pnlQueryMemo.Name + i.ToString; QueryTab.pnlMemo.Parent := QueryTab.TabSheet; QueryTab.pnlMemo.BevelOuter := pnlQueryMemo.BevelOuter; QueryTab.pnlMemo.Align := pnlQueryMemo.Align; - QueryTab.pnlMemo.Height := pnlQueryMemo.Height; + if Assigned(OldTab) then + QueryTab.pnlMemo.Height := OldTab.pnlMemo.Height + else + QueryTab.pnlMemo.Height := AppSettings.GetDefaultInt(asQuerymemoheight); QueryTab.pnlMemo.Constraints := pnlQueryMemo.Constraints; QueryTab.Memo := TSynMemo.Create(QueryTab.pnlMemo); + QueryTab.Memo.Name := SynMemoQuery.Name + i.ToString; + QueryTab.Memo.Text := ''; QueryTab.Memo.Parent := QueryTab.pnlMemo; QueryTab.Memo.Align := SynMemoQuery.Align; QueryTab.Memo.Constraints := SynMemoQuery.Constraints; + QueryTab.Memo.HintMode := SynMemoQuery.HintMode; QueryTab.Memo.Left := SynMemoQuery.Left; QueryTab.Memo.Options := SynMemoQuery.Options; QueryTab.Memo.PopupMenu := SynMemoQuery.PopupMenu; @@ -11269,14 +12721,17 @@ procedure TMainForm.actNewQueryTabExecute(Sender: TObject); QueryTab.Memo.Gutter.Assign(SynMemoQuery.Gutter); QueryTab.Memo.Font.Assign(SynMemoQuery.Font); QueryTab.Memo.ActiveLineColor := SynMemoQuery.ActiveLineColor; + QueryTab.Memo.OnStatusChange := SynMemoQuery.OnStatusChange; + QueryTab.Memo.OnSpecialLineColors := SynMemoQuery.OnSpecialLineColors; QueryTab.Memo.OnDragDrop := SynMemoQuery.OnDragDrop; QueryTab.Memo.OnDragOver := SynMemoQuery.OnDragOver; QueryTab.Memo.OnDropFiles := SynMemoQuery.OnDropFiles; QueryTab.Memo.OnKeyPress := SynMemoQuery.OnKeyPress; QueryTab.Memo.OnMouseWheel := SynMemoQuery.OnMouseWheel; QueryTab.Memo.OnReplaceText := SynMemoQuery.OnReplaceText; - QueryTab.Memo.OnStatusChange := SynMemoQuery.OnStatusChange; QueryTab.Memo.OnPaintTransient := SynMemoQuery.OnPaintTransient; + QueryTab.Memo.OnTokenHint := SynMemoQuery.OnTokenHint; + QueryTab.MemoLineBreaks := TLineBreaks(AppSettings.ReadInt(asLineBreakStyle)); SynCompletionProposal.AddEditor(QueryTab.Memo); QueryTab.spltHelpers := TSplitter.Create(QueryTab.pnlMemo); @@ -11288,14 +12743,20 @@ procedure TMainForm.actNewQueryTabExecute(Sender: TObject); QueryTab.spltHelpers.Width := spltQueryHelpers.Width; QueryTab.pnlHelpers := TPanel.Create(QueryTab.pnlMemo); + QueryTab.pnlHelpers.Name := pnlQueryHelpers.Name + i.ToString; QueryTab.pnlHelpers.Parent := QueryTab.pnlMemo; QueryTab.pnlHelpers.Align := pnlQueryHelpers.Align; QueryTab.pnlHelpers.Constraints := pnlQueryHelpers.Constraints; QueryTab.pnlHelpers.BevelOuter := pnlQueryHelpers.BevelOuter; QueryTab.pnlHelpers.Left := pnlQueryHelpers.Left; - QueryTab.pnlHelpers.Width := pnlQueryHelpers.Width; + if Assigned(OldTab) then + QueryTab.pnlHelpers.Width := OldTab.pnlHelpers.Width + else + QueryTab.pnlHelpers.Width := AppSettings.GetDefaultInt(asQueryhelperswidth); QueryTab.filterHelpers := TButtonedEdit.Create(QueryTab.pnlHelpers); + QueryTab.filterHelpers.Name := filterQueryHelpers.Name + i.ToString; + QueryTab.filterHelpers.Text := ''; QueryTab.filterHelpers.Parent := QueryTab.pnlHelpers; QueryTab.filterHelpers.Align := filterQueryHelpers.Align; QueryTab.filterHelpers.TextHint := filterQueryHelpers.TextHint; @@ -11308,6 +12769,7 @@ procedure TMainForm.actNewQueryTabExecute(Sender: TObject); QueryTab.filterHelpers.OnRightButtonClick := filterQueryHelpers.OnRightButtonClick; QueryTab.treeHelpers := TVirtualStringTree.Create(QueryTab.pnlHelpers); + QueryTab.treeHelpers.Name := treeQueryHelpers.Name + i.ToString; QueryTab.treeHelpers.Parent := QueryTab.pnlHelpers; QueryTab.treeHelpers.Align := treeQueryHelpers.Align; QueryTab.treeHelpers.Left := treeQueryHelpers.Left; @@ -11356,11 +12818,12 @@ procedure TMainForm.actNewQueryTabExecute(Sender: TObject); QueryTab.ResultTabs := TResultTabs.Create(True); QueryTab.tabsetQuery := TTabSet.Create(QueryTab.TabSheet); + QueryTab.tabsetQuery.Name := tabsetQuery.Name + i.ToString; QueryTab.tabsetQuery.Parent := QueryTab.TabSheet; // Prevent various problems with alignment of controls. See http://www.heidisql.com/forum.php?t=18924 QueryTab.tabsetQuery.Top := QueryTab.spltQuery.Top + QueryTab.spltQuery.Height; QueryTab.tabsetQuery.Align := tabsetQuery.Align; - InheritFont(QueryTab.tabsetQuery.Font); + QueryTab.tabsetQuery.Font.Assign(tabsetQuery.Font); QueryTab.tabsetQuery.Images := tabsetQuery.Images; QueryTab.tabsetQuery.Style := tabsetQuery.Style; QueryTab.tabsetQuery.TabHeight := tabsetQuery.TabHeight; @@ -11375,10 +12838,13 @@ procedure TMainForm.actNewQueryTabExecute(Sender: TObject); QueryTab.tabsetQuery.OnMouseMove := tabsetQuery.OnMouseMove; QueryTab.tabsetQuery.OnMouseLeave := tabsetQuery.OnMouseLeave; - SetupSynEditors; + SetupSynEditor(QueryTab.Memo); // Show new tab - SetMainTab(QueryTab.TabSheet); + if Sender <> actNewQueryTabNofocus then begin + SetMainTab(QueryTab.TabSheet); + QueryTab.Memo.TrySetFocus; + end; end; @@ -11404,7 +12870,7 @@ procedure TMainForm.actCloseQueryTabExecute(Sender: TObject); end; -procedure TMainForm.menuCloseQueryTab(Sender: TObject); +procedure TMainForm.menuCloseQueryTabClick(Sender: TObject); var aPoint: TPoint; begin @@ -11414,21 +12880,129 @@ procedure TMainForm.menuCloseQueryTab(Sender: TObject); end; -procedure TMainForm.popupMainTabsPopup(Sender: TObject); +procedure TMainForm.menuCloseRightQueryTabsClick(Sender: TObject); +var + aPoint: TPoint; + i, PageIndexClick: Integer; +begin + // Close tabs to the right + aPoint := PageControlMain.ScreenToClient(popupMainTabs.PopupPoint); + PageIndexClick := GetMainTabAt(aPoint.X, aPoint.Y); + if PageIndexClick > -1 then begin + for i:=PageControlMain.PageCount-1 downto PageIndexClick+1 do begin + CloseQueryTab(PageControlMain.Pages[i].PageIndex); + end; + end; +end; + + +procedure TMainForm.menuCloseTabOnDblClickClick(Sender: TObject); +begin + AppSettings.WriteBool(asTabCloseOnDoubleClick, menuCloseTabOnDblClick.Checked); +end; + + +procedure TMainForm.menuCloseTabOnMiddleClickClick(Sender: TObject); +begin + AppSettings.WriteBool(asTabCloseOnMiddleClick, menuCloseTabOnMiddleClick.Checked); +end; + +procedure TMainForm.menuTabsInMultipleLinesClick(Sender: TObject); +begin + AppSettings.WriteBool(asTabsInMultipleLines, menuTabsInMultipleLines.Checked); + PageControlMain.MultiLine := menuTabsInMultipleLines.Checked; +end; + +procedure TMainForm.actCloseAllQueryTabsExecute(Sender: TObject); +var + i: Integer; +begin + // Close all tabs + for i:=PageControlMain.PageCount-1 downto tabQuery.PageIndex do begin + CloseQueryTab(PageControlMain.Pages[i].PageIndex); + end; +end; + + +procedure TMainForm.actRenameQueryTabExecute(Sender: TObject); var aPoint: TPoint; PageIndex: Integer; + NewCaption: String; +begin + // Rename query tab + if Sender = menuRenameQueryTab then begin + aPoint := PageControlMain.ScreenToClient(popupMainTabs.PopupPoint); + PageIndex := GetMainTabAt(aPoint.X, aPoint.Y); + end else begin + PageIndex := PageControlMain.ActivePageIndex; + end; + if not IsQueryTab(PageIndex, True) then begin + // Action may have been triggered through shortcut, and active tab is not a query tab + MessageBeep(MB_ICONASTERISK); + end else begin + NewCaption := PageControlMain.Pages[PageIndex].Caption; + NewCaption := NewCaption.Trim([' ', '*']); + if InputQuery(actRenameQueryTab.Caption, _('Enter new name'), NewCaption) then begin + SetTabCaption(PageIndex, NewCaption); + ValidateQueryControls(Sender); + end; + end; +end; + + +procedure TMainForm.actResetPanelDimensionsExecute(Sender: TObject); +var + Tab: TQueryTab; +begin + // Reset probably overlapping panels to their default dimensions + pnlLeft.Width := AppSettings.GetDefaultInt(asDbtreewidth); + SynMemoSQLLog.Height := AppSettings.GetDefaultInt(asLogHeight); + for Tab in QueryTabs do begin + Tab.pnlMemo.Height := AppSettings.GetDefaultInt(asQuerymemoheight); + Tab.pnlHelpers.Width := AppSettings.GetDefaultInt(asQueryhelperswidth); + end; + if pnlPreview.Visible then begin + pnlPreview.Height := AppSettings.GetDefaultInt(asDataPreviewHeight); + end; + AppSettings.DeleteValue(asCompletionProposalWidth); + AppSettings.DeleteValue(asCompletionProposalNbLinesInWindow); + SynCompletionProposal.Width := AppSettings.ReadInt(asCompletionProposalWidth); + SynCompletionProposal.NbLinesInWindow := AppSettings.ReadInt(asCompletionProposalNbLinesInWindow); +end; + +procedure TMainForm.menuRenameQueryTabClick(Sender: TObject); +begin + // Rename tab by click on menu item (not by shortcut!) + actRenameQueryTabExecute(Sender); +end; + + +procedure TMainForm.popupMainTabsPopup(Sender: TObject); +var + aPoint: TPoint; + PageIndexClick: Integer; begin // Detect if there is a tab under mouse position aPoint := PageControlMain.ScreenToClient(popupMainTabs.PopupPoint); - PageIndex := GetMainTabAt(aPoint.X, aPoint.Y); - menuCloseTab.Enabled := IsQueryTab(PageIndex, False); + PageIndexClick := GetMainTabAt(aPoint.X, aPoint.Y); + menuCloseQueryTab.ImageIndex := actCloseQueryTab.ImageIndex; + menuCloseQueryTab.Caption := actCloseQueryTab.Caption; + menuCloseQueryTab.Enabled := IsQueryTab(PageIndexClick, False); + menuCloseRightQueryTabs.Enabled := (QueryTabs.Count > 0) and (PageIndexClick < QueryTabs.Last.TabSheet.PageIndex) and (PageIndexClick > -1); + menuRenameQueryTab.ImageIndex := actRenameQueryTab.ImageIndex; + menuRenameQueryTab.Caption := actRenameQueryTab.Caption; + menuRenameQueryTab.Enabled := IsQueryTab(PageIndexClick, True); + menuCloseTabOnDblClick.Checked := AppSettings.ReadBool(asTabCloseOnDoubleClick); + menuCloseTabOnMiddleClick.Checked := AppSettings.ReadBool(asTabCloseOnMiddleClick); + menuTabsInMultipleLines.Checked := AppSettings.ReadBool(asTabsInMultipleLines) end; procedure TMainForm.CloseQueryTab(PageIndex: Integer); var NewPageIndex: Integer; + Grid: TVirtualStringTree; begin // Special case: the very first tab gets cleared but not closed if PageIndex = tabQuery.PageIndex then begin @@ -11437,9 +13011,15 @@ procedure TMainForm.CloseQueryTab(PageIndex: Integer); end; if not IsQueryTab(PageIndex, False) then Exit; + // Cancel cell editor if active, preventing crash. See issue #2040 + Grid := ActiveGrid; + if Assigned(Grid) and Grid.IsEditing then + Grid.CancelEditNode; // Ask user if query content shall be saved to disk if not ConfirmTabClose(PageIndex, False) then Exit; + // Block too quick further close actions, fix issue #1496. Action gets enabled again in PageControlMainChange/ValidateQueryControls + actCloseQueryTab.Enabled := False; // Work around bugs in ComCtrls.TPageControl.RemovePage NewPageIndex := PageControlMain.ActivePageIndex; if NewPageIndex >= PageIndex then @@ -11458,9 +13038,8 @@ procedure TMainForm.CloseQueryTab(PageIndex: Integer); procedure TMainForm.actFavoriteObjectsOnlyExecute(Sender: TObject); begin // Click on "tree favorites" main button - AppSettings.ResetPath; - AppSettings.WriteBool(asFavoriteObjectsOnly, (Sender as TAction).Checked); editDatabaseTableFilterChange(Sender); + actFavoriteObjectsOnly.ImageIndex := IfThen(actFavoriteObjectsOnly.Checked, 112, 113); end; @@ -11526,6 +13105,8 @@ procedure TMainForm.editDatabaseTableFilterChange(Sender: TObject); Node := DBtree.GetNextInitialized(Node); end; DBtree.EndUpdate; + // Fix scroll height of the tree. See issue #2063 and #2002 + DBtree.Repaint; rxdb.Free; rxtable.Free; @@ -11553,14 +13134,19 @@ procedure TMainForm.editDatabaseTableFilterLeftButtonClick(Sender: TObject); AppSettings.SessionPath := ''; if Edit = editDatabaseFilter then Setting := asDatabaseFilter + else if Edit = editTableFilter then + Setting := asTableFilter + else if Edit = editFilterVT then + Setting := asFilterVT else - Setting := asTableFilter; + raise Exception.CreateFmt(MsgUnhandledControl, ['editDatabaseTableFilterLeftButtonClick']); History := TStringList.Create; History.Text := AppSettings.ReadString(Setting); for ItemText in History do begin Item := TMenuItem.Create(Menu); Item.Caption := ItemText; Item.OnClick := editDatabaseTableFilterMenuClick; + Item.Tag := 0; Item.Checked := ItemText = Edit.Text; Menu.Items.Add(Item); end; @@ -11574,6 +13160,14 @@ procedure TMainForm.editDatabaseTableFilterLeftButtonClick(Sender: TObject); Item.Enabled := Edit.Text <> ''; Menu.Items.Add(Item); + Item := TMenuItem.Create(Menu); + Item.Caption := _('Empty recent filters'); + Item.ImageIndex := 26; + Item.OnClick := editDatabaseTableFilterMenuClick; + Item.Tag := 2; + Item.Enabled := Menu.Items.Count > 1; + Menu.Items.Add(Item); + P := Edit.ClientToScreen(Edit.ClientRect.TopLeft); Menu.Popup(p.X, p.Y+16); end; @@ -11584,15 +13178,25 @@ procedure TMainForm.editDatabaseTableFilterMenuClick(Sender: TObject); Menu: TPopupMenu; Item: TMenuItem; Edit: TButtonedEdit; + Setting: TAppSettingIndex; begin // Insert text from filter history menu Item := Sender as TMenuItem; Menu := Item.Owner as TPopupMenu; Edit := Menu.Owner as TButtonedEdit; - if Item.Tag = 1 then - Edit.Clear + if Edit = editDatabaseFilter then + Setting := asDatabaseFilter + else if Edit = editTableFilter then + Setting := asTableFilter + else if Edit = editFilterVT then + Setting := asFilterVT else - Edit.Text := Item.Caption; + raise Exception.CreateFmt(MsgUnhandledControl, ['editDatabaseTableFilterMenuClick']); + case Item.Tag of + 0: Edit.Text := Item.Caption; + 1: Edit.Clear; + 2: AppSettings.DeleteValue(Setting); + end; Menu.Free; end; @@ -11609,8 +13213,12 @@ procedure TMainForm.editDatabaseTableFilterExit(Sender: TObject); AppSettings.SessionPath := ''; if Edit = editDatabaseFilter then Setting := asDatabaseFilter + else if Edit = editTableFilter then + Setting := asTableFilter + else if Edit = editFilterVT then + Setting := asFilterVT else - Setting := asTableFilter; + raise Exception.CreateFmt(MsgUnhandledControl, ['editDatabaseTableFilterExit']); History := TStringList.Create; History.Text := AppSettings.ReadString(Setting); i := History.IndexOf(Edit.Text); @@ -11626,25 +13234,49 @@ procedure TMainForm.editDatabaseTableFilterExit(Sender: TObject); end; -procedure TMainForm.CloseButtonOnMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); +procedure TMainForm.CloseButtonOnClick(Sender: TObject); begin FLastMouseDownCloseButton := Sender; + TimerCloseTabByButton.Enabled := True; +end; + +procedure TMainForm.popupListHeaderPopup(Sender: TObject); +var + Item: TMenuItem; + i: Integer; +const + CustomItemTag = 123; +begin + // Add a few items to the top of the grid's header context menu + for i:=popupListHeader.Items.Count-1 downto 0 do begin + Item := popupListHeader.Items[i]; + if Item.Tag = CustomItemTag then + Item.Free; + end; + + Item := TMenuItem.Create(popupListHeader); + Item.Tag := CustomItemTag; + Item.Caption := _('Toggle visibility of all columns'); + Item.OnClick := menuToggleAllClick; + popupListHeader.Items.Insert(0, Item); + + Item := TMenuItem.Create(popupListHeader); + Item.Tag := CustomItemTag; + Item.Caption := _('Copy column names'); + Item.OnClick := menuCopyColumnNamesClick; + Item.ImageIndex := actCopy.ImageIndex; + popupListHeader.Items.Insert(1, Item); end; -procedure TMainForm.CloseButtonOnMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); +procedure TMainForm.TimerCloseTabByButtonTimer(Sender: TObject); var i: Integer; begin - // Click on "Close" button of Query tab - if Button <> mbLeft then - Exit; - // Between MousDown and MouseUp it is possible that the focused tab has switched. As we simulate a mouse-click - // here, we must check if also the MouseDown event was fired on this particular button. See issue #1469. - if (Sender <> FLastMouseDownCloseButton) then - Exit; + // Asynchronous timer for mousedown event on query tab close button + TimerCloseTabByButton.Enabled := False; for i:=0 to QueryTabs.Count-1 do begin - if QueryTabs[i].CloseButton = Sender then begin + if QueryTabs[i].CloseButton = FLastMouseDownCloseButton then begin CloseQueryTab(QueryTabs[i].TabSheet.PageIndex); break; end; @@ -11662,21 +13294,25 @@ procedure TMainForm.PageControlMainMouseUp(Sender: TObject; case Button of mbLeft: begin // Simulate doubleclick on tab to close it - CurTickcount := GetTickCount; - TabNumber := GetMainTabAt(X, Y); - if (TabNumber = FLastTabNumberOnMouseUp) - and (CurTickcount - FLastMouseUpOnPageControl <= GetDoubleClickTime) then begin - CloseQueryTab(TabNumber); - end else begin - FLastMouseUpOnPageControl := CurTickcount; - FLastTabNumberOnMouseUp := TabNumber; + if AppSettings.ReadBool(asTabCloseOnDoubleClick) then begin + CurTickcount := GetTickCount; + TabNumber := GetMainTabAt(X, Y); + if (TabNumber = FLastTabNumberOnMouseUp) + and (CurTickcount - FLastMouseUpOnPageControl <= GetDoubleClickTime) then begin + CloseQueryTab(TabNumber); + end else begin + FLastMouseUpOnPageControl := CurTickcount; + FLastTabNumberOnMouseUp := TabNumber; + end; end; end; mbMiddle: begin // Middle click on tab - TabNumber := GetMainTabAt(X, Y); - CloseQueryTab(TabNumber); + if AppSettings.ReadBool(asTabCloseOnMiddleClick) then begin + TabNumber := GetMainTabAt(X, Y); + CloseQueryTab(TabNumber); + end; end; end; @@ -11716,108 +13352,45 @@ procedure TMainForm.FixQueryTabCloseButtons; btn := QueryTabs[PageIndex-tabQuery.PageIndex].CloseButton; btn.Top := Rect.Top + 2; btn.Left := Rect.Right - 19; - end; - // Set position of "Add tab" button - VisiblePageIndex := PageControlMain.PageCount-1; - for i:=0 to PageControlMain.PageCount-1 do begin - if not PageControlMain.Pages[i].TabVisible then - Dec(VisiblePageIndex); - end; - Rect := PageControlMain.TabRect(VisiblePageIndex); - FBtnAddTab.Top := Rect.Top; - FBtnAddTab.Left := Rect.Right + 5; -end; - - -function TMainForm.ActiveQueryTab: TQueryTab; -var - idx: Integer; -begin - idx := PageControlMain.ActivePageIndex-tabQuery.PageIndex; - if (idx >= 0) and (idx < QueryTabs.Count) then - Result := QueryTabs[idx] - else - Result := nil; -end; - - -function TMainForm.GetOrCreateEmptyQueryTab: TQueryTab; -var - i: Integer; -begin - // Return either a) current query tab if one is active - // or b) the first empty one - // or c) create a new one - // Result should never be nil, unlike in ActiveQueryTab - Result := nil; - if Result = nil then begin - // Search empty tab - for i:=0 to QueryTabs.Count-1 do begin - if (QueryTabs[i].MemoFilename='') and (QueryTabs[i].Memo.GetTextLen=0) then begin - Result := QueryTabs[i]; - break; - end; - end; - // Create new tab - if Result = nil then begin - actNewQueryTabExecute(Self); - Result := QueryTabs[QueryTabs.Count-1]; - end; - end; -end; - - -function TMainForm.GetQueryTabByNumber(Number: Integer): TQueryTab; -var - i: Integer; -begin - // Find right query tab - Result := nil; - for i:=0 to QueryTabs.Count-1 do begin - if QueryTabs[i].Number = Number then begin - Result := QueryTabs[i]; - break; - end; - end; -end; - - -function TMainForm.GetQueryTabByHelpers(FindTree: TBaseVirtualTree): TQueryTab; -var - Tab: TQueryTab; -begin - // Find query tab where passed treeHelpers resides - Result := nil; - for Tab in QueryTabs do begin - if Tab.treeHelpers = FindTree then begin - Result := Tab; - break; - end; - end; -end; - - -function TMainForm.ActiveQueryMemo: TSynMemo; -var - Tab: TQueryTab; -begin - // Return current query memo - Tab := ActiveQueryTab; - Result := nil; - if Tab <> nil then - Result := Tab.Memo; + end; + // Set position of "Add tab" button + VisiblePageIndex := PageControlMain.PageCount-1; + for i:=0 to PageControlMain.PageCount-1 do begin + if not PageControlMain.Pages[i].TabVisible then + Dec(VisiblePageIndex); + end; + Rect := PageControlMain.TabRect(VisiblePageIndex); + FBtnAddTab.Top := Rect.Top; + FBtnAddTab.Left := Rect.Right + 5; end; -function TMainForm.ActiveQueryHelpers: TVirtualStringTree; +function TMainForm.GetOrCreateEmptyQueryTab(DoFocus: Boolean): TQueryTab; var - Tab: TQueryTab; + i: Integer; begin - // Return current query helpers tree - Tab := ActiveQueryTab; + // Return either a) current query tab if one is active + // or b) the first empty one + // or c) create a new one + // Result should never be nil, unlike in QueryTabs.ActiveTab Result := nil; - if Tab <> nil then - Result := Tab.treeHelpers; + // Search empty tab + for i:=0 to QueryTabs.Count-1 do begin + if (QueryTabs[i].MemoFilename='') and (QueryTabs[i].Memo.GetTextLen=0) then begin + Result := QueryTabs[i]; + if DoFocus then + SetMainTab(Result.TabSheet); + Break; + end; + end; + // Create new tab + if Result = nil then begin + if DoFocus then + actNewQueryTabExecute(actNewQueryTab) + else + actNewQueryTabExecute(actNewQueryTabNofocus); + Result := QueryTabs[QueryTabs.Count-1]; + end; end; @@ -11833,17 +13406,25 @@ function TMainForm.ActiveSynMemo(AcceptReadOnlyMemo: Boolean): TSynMemo; if (not AcceptReadOnlyMemo) and Result.ReadOnly then Result := nil; end; - if (not Assigned(Result)) and QueryTabActive then - Result := ActiveQueryMemo; + if (not Assigned(Result)) and QueryTabs.HasActiveTab then + Result := QueryTabs.ActiveMemo; + if (not Assigned(Result)) and (Screen.ActiveForm is TfrmTextEditor) then begin + Result := TfrmTextEditor(Screen.ActiveForm).MemoText; + end; + end; function TMainForm.ActiveGrid: TVirtualStringTree; begin + // Return current data or query grid, if main form is active Result := nil; - if PageControlMain.ActivePage = tabData then Result := DataGrid - else if (ActiveQueryTab <> nil) and (ActiveQueryTab.ActiveResultTab <> nil) then - Result := ActiveQueryTab.ActiveResultTab.Grid; + if Screen.ActiveForm <> Self then + Exit; + if PageControlMain.ActivePage = tabData then + Result := DataGrid + else if (QueryTabs.ActiveTab <> nil) and (QueryTabs.ActiveTab.ActiveResultTab <> nil) then + Result := QueryTabs.ActiveTab.ActiveResultTab.Grid; end; @@ -11876,12 +13457,6 @@ function TMainForm.GridResult(Grid: TBaseVirtualTree): TDBQuery; end; -function TMainForm.QueryTabActive: Boolean; -begin - // Find out if the active main tab is a query tab - Result := IsQueryTab(PageControlMain.ActivePageIndex, True); -end; - function TMainForm.IsQueryTab(PageIndex: Integer; IncludeFixed: Boolean): Boolean; var Min: Integer; @@ -11926,6 +13501,8 @@ procedure TMainForm.SetTabCaption(PageIndex: Integer; Text: String); // Some cases pass -1 which triggers a "List index out of bounds" in below cast if PageIndex = -1 then Exit; + // Escape hotkey accelerator in name of session, database or table + Text := EscapeHotkeyPrefix(Text); Text := StrEllipsis(Text, 70); // Special case if passed text is empty: Reset query tab caption to "Query #123" if (PageIndex = tabQuery.PageIndex) and (Text = '') then @@ -11967,43 +13544,58 @@ function TMainForm.ConfirmTabClear(PageIndex: Integer; AppIsClosing: Boolean): B var msg: String; Tab: TQueryTab; - SaveDialog: TSaveDialog; + Dialog: TExtFileSaveDialog; MsgButtons: TMsgDlgButtons; begin Tab := QueryTabs[PageIndex-tabQuery.PageIndex]; - // Unhide tabsheet so the user sees the memo content - Tab.TabSheet.PageControl.ActivePage := Tab.TabSheet; - // Prompt for saving unsaved contents - if Tab.MemoFilename <> '' then - msg := f_('Save changes to file %s ?', [Tab.MemoFilename]) - else - msg := f_('Save content of tab "%s"?', [Trim(Tab.TabSheet.Caption)]); if AppSettings.RestoreTabsInitValue and AppIsClosing then begin - msg := msg + CRLF + CRLF + _('Your code is saved anyway, as auto-restoring is activated.'); - end; + Result := True; + end - if FConnections.Count > 0 then - MsgButtons := [mbYes, mbNo, mbCancel] - else - MsgButtons := [mbYes, mbNo]; - - case MessageDialog(_('Modified query'), msg, mtConfirmation, MsgButtons, asPromptSaveFileOnTabClose) of - mrNo: Result := True; - mrYes: begin - SaveDialog := TSaveDialog.Create(Self); - SaveDialog.Options := SaveDialog.Options + [ofOverwritePrompt]; - SaveDialog.Filter := _('SQL files')+' (*.sql)|*.sql|'+_('All files')+' (*.*)|*.*'; - SaveDialog.DefaultExt := 'sql'; - if Tab.MemoFilename <> '' then - Tab.SaveContents(Tab.MemoFilename, False) - else if SaveDialog.Execute then - Tab.SaveContents(SaveDialog.FileName, False); - // The save dialog can be cancelled. - Result := not Tab.Memo.Modified; - SaveDialog.Free; - end; - else Result := False; + else begin + // Unhide tabsheet so the user sees the memo content. + // If the dialog is suppressed anyway, the user does not need to see the text, and we avoid + // storing this as the focused tab + if AppSettings.ReadBool(asPromptSaveFileOnTabClose) then begin + Tab.TabSheet.PageControl.ActivePage := Tab.TabSheet; + end; + // Prompt for saving unsaved contents + if Tab.MemoFilename <> '' then + msg := f_('Save changes to file %s ?', [Tab.MemoFilename]) + else + msg := f_('Save content of tab "%s"?', [Trim(Tab.TabSheet.Caption)]); + + if FConnections.Count > 0 then + MsgButtons := [mbYes, mbNo, mbCancel] + else + MsgButtons := [mbYes, mbNo]; + + case MessageDialog(_('Modified query'), msg, mtConfirmation, MsgButtons, asPromptSaveFileOnTabClose) of + mrNo: Result := True; + mrYes: begin + if Tab.MemoFilename <> '' then begin + Tab.SaveContents(Tab.MemoFilename, False); + Result := True; + end + else begin + Dialog := TExtFileSaveDialog.Create(Self); + Dialog.Options := Dialog.Options + [fdoOverwritePrompt]; + Dialog.AddFileType('*.sql', _('SQL files')); + Dialog.AddFileType('*.*', _('All files')); + Dialog.DefaultExtension := 'sql'; + Dialog.LineBreakIndex := Tab.MemoLineBreaks; + if Dialog.Execute then begin + Tab.SaveContents(Dialog.FileName, False); + Tab.MemoLineBreaks := Dialog.LineBreakIndex; + end; + // The save dialog can be cancelled. + Result := not Tab.Memo.Modified; + Dialog.Free; + end; + end; + else Result := False; + end; end; // Auto-backup logic @@ -12014,7 +13606,7 @@ function TMainForm.ConfirmTabClear(PageIndex: Integer; AppIsClosing: Boolean): B end else begin // Delete backup file if tab is closed by user, intentionally if (not Tab.MemoBackupFilename.IsEmpty) and FileExists(Tab.MemoBackupFilename) then begin - if not DeleteFile(Tab.MemoBackupFilename) then begin + if not DeleteFileWithUndo(Tab.MemoBackupFilename) then begin ErrorDialog(f_('Backup file could not be deleted: %s', [Tab.MemoBackupFilename])); end; end; @@ -12075,7 +13667,7 @@ procedure TMainForm.UpdateFilterPanel(Sender: TObject); else if tab = tabDatabase then f := FFilterTextDatabase else if tab = tabEditor then f := FFilterTextEditor else if tab = tabData then f := FFilterTextData - else if QueryTabActive and (ActiveQueryTab.ActiveResultTab <> nil) then f := ActiveQueryTab.ActiveResultTab.FilterText; + else if QueryTabs.HasActiveTab and (QueryTabs.ActiveTab.ActiveResultTab <> nil) then f := QueryTabs.ActiveTab.ActiveResultTab.FilterText; if editFilterVT.Text <> f then editFilterVT.Text := f else @@ -12088,25 +13680,14 @@ procedure TMainform.SetupSynEditors; var i, j: Integer; Editors: TObjectList; - BaseEditor, Editor: TSynMemo; + BaseEditor: TSynMemo; KeyStroke: TSynEditKeyStroke; - ActiveLineColor: TColor; Attri: TSynHighlighterAttributes; Shortcut1, Shortcut2: TShortcut; - - procedure FindEditors(Comp: TComponent); - var i: Integer; - begin - for i:=0 to Comp.ComponentCount-1 do begin - if Comp.Components[i] is TSynMemo then - Editors.Add(Comp.Components[i]); - FindEditors(Comp.Components[i]); - end; - end; - begin - // Restore font, highlighter and shortcuts for each instantiated TSynMemo - Editors := TObjectList.Create; + // Setup all known TSynMemo's + // This version includes global settings for keyboard shortcut, highlighting and completion proposal + Editors := TObjectList.Create(False); BaseEditor := SynMemoQuery; for i:=0 to QueryTabs.Count-1 do Editors.Add(QueryTabs[i].Memo); @@ -12114,80 +13695,65 @@ procedure TMainform.SetupSynEditors; Editors.Add(SynMemoProcessView); Editors.Add(SynMemoSQLLog); if Assigned(ActiveObjectEditor) then - FindEditors(ActiveObjectEditor); - if Assigned(FPreferencesDialog) then - Editors.Add(FPreferencesDialog.SynMemoSQLSample); + FindComponentInstances(ActiveObjectEditor, TSynMemo, Editors); + if Assigned(frmPreferences) then + Editors.Add(frmPreferences.SynMemoSQLSample); if Assigned(FCreateDatabaseDialog) then Editors.Add(FCreateDatabaseDialog.SynMemoCreateCode); if SqlHelpDialog <> nil then begin Editors.Add(SqlHelpDialog.memoDescription); Editors.Add(SqlHelpDialog.MemoExample); end; + if Assigned(FTableToolsDialog) then + Editors.Add(FTableToolsDialog.SynMemoFindText); + if Assigned(frmCsvDetector) then + Editors.Add(frmCsvDetector.SynMemoCreateTable); if AppSettings.ReadBool(asTabsToSpaces) then BaseEditor.Options := BaseEditor.Options + [eoTabsToSpaces] else BaseEditor.Options := BaseEditor.Options - [eoTabsToSpaces]; - ActiveLineColor := StringToColor(AppSettings.ReadString(asSQLColActiveLine)); - MatchingBraceForegroundColor := StringToColor(AppSettings.ReadString(asSQLColMatchingBraceForeground)); - MatchingBraceBackgroundColor := StringToColor(AppSettings.ReadString(asSQLColMatchingBraceBackground)); + FMatchingBraceForegroundColor := StringToColor(AppSettings.ReadString(asSQLColMatchingBraceForeground)); + FMatchingBraceBackgroundColor := StringToColor(AppSettings.ReadString(asSQLColMatchingBraceBackground)); + FSynEditInOnPaintTransient := False; + // Shortcuts + for j:=0 to BaseEditor.Keystrokes.Count-1 do begin + KeyStroke := BaseEditor.Keystrokes[j]; + Shortcut1 := AppSettings.ReadInt(asActionShortcut1, EditorCommandToCodeString(Keystroke.Command)); + Shortcut2 := AppSettings.ReadInt(asActionShortcut2, EditorCommandToCodeString(Keystroke.Command)); + try + if Shortcut1<>0 then + Keystroke.ShortCut := Shortcut1; + if Shortcut2<>0 then + Keystroke.ShortCut2 := Shortcut2; + except + on E:ESynKeyError do begin + LogSQL(f_('Could not apply SynEdit keystroke shortcut "%s" (or secondary: "%s") to %s. %s. Please go to %s > %s > %s to change this settings.', + [ + ShortCutToText(Shortcut1), + ShortCutToText(Shortcut2), + EditorCommandToCodeString(Keystroke.Command), + E.Message, + _('Tools'), + _('Preferences'), + _('Shortcuts') + ]), + lcError); + end; + end; + end; + // Apply events and options to all known editors for i:=0 to Editors.Count-1 do begin - Editor := Editors[i] as TSynMemo; - LogSQL('Setting up TSynMemo "'+Editor.Name+'"', lcDebug); - Editor.Color := GetThemeColor(clWindow); - Editor.ScrollHintColor := GetThemeColor(clInfoBk); - Editor.Font.Name := AppSettings.ReadString(asFontName); - Editor.Font.Size := AppSettings.ReadInt(asFontSize); - Editor.Gutter.BorderColor := GetThemeColor(clWindow); - Editor.Gutter.Color := GetThemeColor(clBtnFace); - Editor.Gutter.Font.Name := Editor.Font.Name; - Editor.Gutter.Font.Size := Editor.Font.Size; - Editor.Gutter.Font.Color := BaseEditor.Gutter.Font.Color; - Editor.Gutter.AutoSize := BaseEditor.Gutter.AutoSize; - Editor.Gutter.DigitCount := BaseEditor.Gutter.DigitCount; - Editor.Gutter.LeftOffset := BaseEditor.Gutter.LeftOffset; - Editor.Gutter.RightOffset := BaseEditor.Gutter.RightOffset; - Editor.Gutter.ShowLineNumbers := BaseEditor.Gutter.ShowLineNumbers; - if Editor <> SynMemoSQLLog then begin - Editor.WordWrap := actQueryWordWrap.Checked; - // Assignment of OnScanForFoldRanges event is required for UseCodeFolding - Editor.OnScanForFoldRanges := BaseEditor.OnScanForFoldRanges; - Editor.UseCodeFolding := actCodeFolding.Checked; - end; - Editor.ActiveLineColor := ActiveLineColor; - Editor.Options := BaseEditor.Options; - if Editor = SynMemoSQLLog then - Editor.Options := Editor.Options + [eoRightMouseMovesCursor]; - Editor.TabWidth := AppSettings.ReadInt(asTabWidth); - Editor.MaxScrollWidth := BaseEditor.MaxScrollWidth; - Editor.WantTabs := BaseEditor.WantTabs; - Editor.OnKeyPress := BaseEditor.OnKeyPress; - Editor.OnPaintTransient := BaseEditor.OnPaintTransient; - // Shortcuts - if Editor = BaseEditor then for j:=0 to Editor.Keystrokes.Count-1 do begin - KeyStroke := Editor.Keystrokes[j]; - Shortcut1 := AppSettings.ReadInt(asActionShortcut1, EditorCommandToCodeString(Keystroke.Command)); - Shortcut2 := AppSettings.ReadInt(asActionShortcut2, EditorCommandToCodeString(Keystroke.Command)); - try - if Shortcut1<>0 then - Keystroke.ShortCut := Shortcut1; - if Shortcut2<>0 then - Keystroke.ShortCut2 := Shortcut2; - except - on E:ESynKeyError do begin - LogSQL(f_('Could not apply SynEdit keystroke shortcut "%s" (or secondary: "%s") to %s. %s. Please go to Tools > Preferences > Shortcuts to change this settings.', - [ShortCutToText(Shortcut1), ShortCutToText(Shortcut2), EditorCommandToCodeString(Keystroke.Command), E.Message, _('Tools'), _('Preferences'), _('Shortcuts')]), lcError); - end; - end; - end else - Editor.Keystrokes := BaseEditor.KeyStrokes; + SetupSynEditor(Editors[i] as TSynMemo); end; + Editors.Free; // Highlighting for i:=0 to SynSQLSynUsed.AttrCount - 1 do begin Attri := SynSQLSynUsed.Attribute[i]; Attri.Foreground := AppSettings.ReadInt(asHighlighterForeground, Attri.Name, Attri.Foreground); Attri.Background := AppSettings.ReadInt(asHighlighterBackground, Attri.Name, Attri.Background); + // IntegerStyle gathers all font styles (bold, italic, ...) in one number Attri.IntegerStyle := AppSettings.ReadInt(asHighlighterStyle, Attri.Name, Attri.IntegerStyle); end; // Completion proposal @@ -12198,11 +13764,72 @@ procedure TMainform.SetupSynEditors; end; +procedure TMainForm.SetupSynEditors(BaseForm: TComponent); +var + Editors: TObjectList; + i: Integer; +begin + // Restore font, highlighter and shortcuts for all TSynMemo's in given base form + Editors := TObjectList.Create(False); + FindComponentInstances(BaseForm, TSynMemo, Editors); + for i:=0 to Editors.Count-1 do begin + SetupSynEditor(Editors[i] as TSynMemo); + end; + Editors.Free; +end; + + +procedure TMainForm.SetupSynEditor(Editor: TSynMemo); +var + BaseEditor: TSynMemo; +begin + LogSQL('Setting up TSynMemo "'+Editor.Name+'"', lcDebug); + BaseEditor := SynMemoQuery; + Editor.Color := GetThemeColor(clWindow); + Editor.ScrollHintColor := GetThemeColor(clInfoBk); + Editor.Font.Name := AppSettings.ReadString(asFontName); + Editor.Font.Size := AppSettings.ReadInt(asFontSize); + Editor.Gutter.BorderColor := GetThemeColor(clWindow); + Editor.Gutter.Font.Name := Editor.Font.Name; + Editor.Gutter.Font.Size := Editor.Font.Size; + Editor.Gutter.Font.Color := BaseEditor.Gutter.Font.Color; + Editor.Gutter.AutoSize := BaseEditor.Gutter.AutoSize; + Editor.Gutter.DigitCount := BaseEditor.Gutter.DigitCount; + Editor.Gutter.LeftOffset := BaseEditor.Gutter.LeftOffset; + Editor.Gutter.RightOffset := BaseEditor.Gutter.RightOffset; + Editor.Gutter.ShowLineNumbers := BaseEditor.Gutter.ShowLineNumbers; + if Editor <> SynMemoSQLLog then begin + Editor.WordWrap := actQueryWordWrap.Checked; + // Assignment of OnScanForFoldRanges event is required for UseCodeFolding + Editor.OnScanForFoldRanges := BaseEditor.OnScanForFoldRanges; + Editor.UseCodeFolding := actCodeFolding.Checked; + end; + Editor.ActiveLineColor := StringToColor(AppSettings.ReadString(asSQLColActiveLine)); + Editor.Options := BaseEditor.Options; + if Editor = SynMemoSQLLog then + Editor.Options := Editor.Options + [eoRightMouseMovesCursor]; + Editor.TabWidth := AppSettings.ReadInt(asTabWidth); + Editor.MaxScrollWidth := BaseEditor.MaxScrollWidth; + Editor.WantTabs := BaseEditor.WantTabs; + Editor.HintMode := BaseEditor.HintMode; + Editor.OnKeyPress := BaseEditor.OnKeyPress; + Editor.OnMouseWheel := BaseEditor.OnMouseWheel; + Editor.OnTokenHint := BaseEditor.OnTokenHint; + if Editor <> SynMemoSQLLog then begin + Editor.OnPaintTransient := BaseEditor.OnPaintTransient; + end; + // Don't reapply shortcuts to base editor again, see issue 1600 + if Editor <> BaseEditor then begin + Editor.Keystrokes := BaseEditor.KeyStrokes; + end; +end; + + procedure TMainForm.actReformatSQLExecute(Sender: TObject); var m: TCustomSynEdit; CursorPosStart, CursorPosEnd: Integer; - NewSQL: String; + Done: Boolean; begin // Reformat SQL query m := ActiveSynMemo(False); @@ -12214,19 +13841,29 @@ procedure TMainForm.actReformatSQLExecute(Sender: TObject); CursorPosEnd := m.SelEnd; if not m.SelAvail then m.SelectAll; - NewSQL := m.SelText; - if Length(NewSQL) = 0 then + if m.SelLength = 0 then ErrorDialog(_('Cannot reformat'), _('The current editor is empty.')) else begin - Screen.Cursor := crHourglass; - m.UndoList.AddGroupBreak; - NewSQL := ReformatSQL(NewSQL); - m.SelText := NewSQL; - m.SelStart := CursorPosStart; - if CursorPosEnd > CursorPosStart then - m.SelEnd := CursorPosStart + Length(NewSQL); - m.UndoList.AddGroupBreak; - Screen.Cursor := crDefault; + frmReformatter := TfrmReformatter.Create(Self); + frmReformatter.InputCode := m.SelText; + if AppSettings.ReadInt(asReformatterNoDialog) <> 0 then begin + frmReformatter.btnOkClick(Self); + Done := True; + end + else begin + Done := frmReformatter.ShowModal = mrOk; + end; + if Done then begin + Screen.Cursor := crHourglass; + m.UndoList.AddGroupBreak; + m.SelText := frmReformatter.OutputCode; + m.SelStart := CursorPosStart; + if CursorPosEnd > CursorPosStart then + m.SelEnd := CursorPosStart + Length(frmReformatter.OutputCode); + m.UndoList.AddGroupBreak; + Screen.Cursor := crDefault; + end; + frmReformatter.Free; end; end; @@ -12252,7 +13889,8 @@ procedure TMainForm.menuQueryHelpersGenerateStatementClick(Sender: TObject); MenuItem: TMenuItem; sql, Val, WhereClause: String; i, idx: Integer; - ColumnNames, DefaultValues, KeyColumns: TStringList; + ColumnNames, DefaultValues: TStringList; + KeyColumns: TTableColumnList; Column: TTableColumn; Tree: TVirtualStringTree; Node: PVirtualNode; @@ -12261,8 +13899,8 @@ procedure TMainForm.menuQueryHelpersGenerateStatementClick(Sender: TObject); MenuItem := (Sender as TMenuItem); ColumnNames := TStringList.Create; DefaultValues := TStringList.Create; - Tree := ActiveQueryHelpers; - Node := Tree.GetFirstChild(FindNode(Tree, HELPERNODE_COLUMNS, nil)); + Tree := QueryTabs.ActiveHelpersTree; + Node := Tree.GetFirstChild(FindNode(Tree, TQueryTab.HelperNodeColumns, nil)); while Assigned(Node) do begin if Tree.Selected[Node] then begin Column := SelectedTableColumns[Node.Index]; @@ -12288,41 +13926,41 @@ procedure TMainForm.menuQueryHelpersGenerateStatementClick(Sender: TObject); KeyColumns := ActiveConnection.GetKeyColumns(SelectedTableColumns, SelectedTableKeys); WhereClause := ''; for i:=0 to KeyColumns.Count-1 do begin - idx := ColumnNames.IndexOf(ActiveConnection.QuoteIdent(KeyColumns[i], False)); + idx := ColumnNames.IndexOf(ActiveConnection.QuoteIdent(KeyColumns[i].Name, False)); if idx > -1 then begin if WhereClause <> '' then WhereClause := WhereClause + ' AND '; - WhereClause := WhereClause + ActiveConnection.QuoteIdent(KeyColumns[i], False)+'='+DefaultValues[idx]; + WhereClause := WhereClause + ActiveConnection.QuoteIdent(KeyColumns[i].Name, False)+'='+DefaultValues[idx]; end; end; if MenuItem = menuQueryHelpersGenerateSelect then begin - sql := 'SELECT '+ImplodeStr(', ', ColumnNames)+CRLF+ - #9'FROM '+ActiveDbObj.QuotedName(False); + sql := 'SELECT ' + Implode(', ', ColumnNames) + SLineBreak + + CodeIndent + 'FROM '+ActiveDbObj.QuotedName(False); end else if MenuItem = menuQueryHelpersGenerateInsert then begin - sql := 'INSERT INTO '+ActiveDbObj.QuotedName(False)+CRLF+ - #9'('+ImplodeStr(', ', ColumnNames)+')'+CRLF+ - #9'VALUES ('+ImplodeStr(', ', DefaultValues)+')'; + sql := 'INSERT INTO ' + ActiveDbObj.QuotedName(False) + SLineBreak + + CodeIndent + '(' + Implode(', ', ColumnNames) + ')' + SLineBreak + + CodeIndent + 'VALUES (' + Implode(', ', DefaultValues) + ')'; end else if MenuItem = menuQueryHelpersGenerateUpdate then begin - sql := 'UPDATE '+ActiveDbObj.QuotedName(False)+CRLF+#9'SET'+CRLF; + sql := 'UPDATE ' + ActiveDbObj.QuotedName(False) + SLineBreak + CodeIndent + 'SET' + SLineBreak; if ColumnNames.Count > 0 then begin for i:=0 to ColumnNames.Count-1 do begin - sql := sql + #9#9 + ColumnNames[i] + '=' + DefaultValues[i] + ',' + CRLF; + sql := sql + CodeIndent(2) + ColumnNames[i] + '=' + DefaultValues[i] + ',' + SLineBreak; end; Delete(sql, Length(sql)-2, 1); end else - sql := sql + #9#9'??? # No column names selected!'+CRLF; - sql := sql + #9'WHERE ' + WhereClause; + sql := sql + CodeIndent(2) + '??? # No column names selected!' + SLineBreak; + sql := sql + CodeIndent + 'WHERE ' + WhereClause; end else if MenuItem = menuQueryHelpersGenerateDelete then begin sql := 'DELETE FROM '+ActiveDbObj.QuotedName(False)+' WHERE ' + WhereClause; end; - ActiveQueryMemo.UndoList.AddGroupBreak; - ActiveQueryMemo.SelText := sql; + QueryTabs.ActiveMemo.UndoList.AddGroupBreak; + QueryTabs.ActiveMemo.SelText := sql; end; @@ -12378,16 +14016,17 @@ procedure TMainForm.DBtreeBeforeCellPaint(Sender: TBaseVirtualTree; TargetCanvas DBObj: PDBObject; AllObjects: TDBObjectList; begin - if CellPaintMode=cpmPaint then begin + if CellPaintMode=cpmPaint then try DBObj := Sender.GetNodeData(Node); if DbObj.Connection.Parameters.SessionColor <> AppSettings.GetDefaultInt(asTreeBackground) then begin TargetCanvas.Brush.Color := DbObj.Connection.Parameters.SessionColor; TargetCanvas.FillRect(CellRect); end; - if (Column=1) and DBObj.Connection.DbObjectsCached(DBObj.Database) then begin + if (Column=1) and (DBObj.NodeType in [lntTable..lntEvent]) and DBObj.Connection.DbObjectsCached(DBObj.Database) then begin AllObjects := DBObj.Connection.GetDBObjects(DBObj.Database); PaintColorBar(DBObj.Size, AllObjects.LargestObjectSize, TargetCanvas, CellRect); end; + except; // Silence sporadic EAccessViolation when reading DbObj.Connection.Parameters, found in uploaded reports end; end; @@ -12408,6 +14047,7 @@ procedure TMainForm.FormMouseWheel(Sender: TObject; Shift: TShiftState; WheelDel var Control: TWinControl; VT: TBaseVirtualTree; + PageControl: TPageControl; begin // Wheel scrolling only works in component which has focus. Help out by doing that by hand at least for any VirtualTree. // See http://www.delphipraxis.net/viewtopic.php?p=1113607 @@ -12419,6 +14059,18 @@ procedure TMainForm.FormMouseWheel(Sender: TObject; Shift: TShiftState; WheelDel VT.OffsetY := VT.OffsetY + (WheelDelta div 2); // Don't know why, but WheelDelta is twice as big as it normally appears VT.UpdateScrollBars(True); Handled := True; + end else if Control is TPageControl then begin + // Scroll tabs horizontally per mouse wheel + PageControl := Control as TPageControl; + if PageControl.MultiLine then begin + Handled := False; + end + else begin + PageControl.ScrollTabs(WheelDelta div WHEEL_DELTA); + if PageControl = PageControlMain then + FixQueryTabCloseButtons; + Handled := True; + end; end else Handled := False; end; @@ -12426,30 +14078,24 @@ procedure TMainForm.FormMouseWheel(Sender: TObject; Shift: TShiftState; WheelDel procedure TMainForm.actDataResetSortingExecute(Sender: TObject); begin - SetLength(DataGridSortColumns, 0); + FDataGridSortItems.Clear; InvalidateVT(DataGrid, VTREE_NOTLOADED_PURGECACHE, False); end; procedure TMainForm.WMCopyData(var Msg: TWMCopyData); var - i: Integer; Connection: TDBConnection; - Tab: TQueryTab; ConnectionParams: TConnectionParameters; FileNames: TStringList; + RunFrom: String; begin // Probably a second instance is posting its command line parameters here if (Msg.CopyDataStruct.dwData = SecondInstMsgId) and (SecondInstMsgId <> 0) then begin LogSQL(f_('Preventing second application instance - disabled in %s > %s > %s.', [_('Tools'), _('Preferences'), _('General')]), lcInfo); ConnectionParams := nil; - ParseCommandLine(ParamBlobToStr(Msg.CopyDataStruct.lpData), ConnectionParams, FileNames); - if not RunQueryFiles(FileNames, nil, False) then begin - for i:=0 to FileNames.Count-1 do begin - Tab := GetOrCreateEmptyQueryTab; - Tab.LoadContents(FileNames[i], True, nil); - end; - end; + ParseCommandLine(ParamBlobToStr(Msg.CopyDataStruct.lpData), ConnectionParams, FileNames, RunFrom); + OpenQueryFiles(FileNames, nil, False); if ConnectionParams <> nil then InitConnection(ConnectionParams, True, Connection); end else @@ -12494,30 +14140,21 @@ procedure TMainForm.AnyGridScroll(Sender: TBaseVirtualTree; DeltaX, DeltaY: Inte end; -procedure TMainForm.lblExplainProcessAnalyzerClick(Sender: TObject); -begin - try - ActiveConnection.ExplainAnalyzer(SynMemoProcessView.Text, listProcesses.Text[listProcesses.FocusedNode, 3]); - except - on E:EDbError do - ErrorDialog(E.Message); - end; -end; - - procedure TMainForm.lblExplainProcessClick(Sender: TObject); var Tab: TQueryTab; UsedDatabase: String; + Conn: TDBConnection; begin // Click on "Explain" link label, in process viewer + Conn := ActiveConnection; actNewQueryTabExecute(Sender); Tab := QueryTabs[QueryTabs.Count-1]; UsedDatabase := listProcesses.Text[listProcesses.FocusedNode, 3]; if not UsedDatabase.IsEmpty then begin - Tab.Memo.Lines.Add('USE ' + ActiveConnection.QuoteIdent(UsedDatabase) + ';'); + Tab.Memo.Lines.Add(Conn.SqlProvider.GetSql(qUSEQuery, [Conn.QuoteIdent(UsedDatabase)]) + ';'); end; - Tab.Memo.Lines.Add('EXPLAIN' + sLineBreak + SynMemoProcessView.Text + ';'); + Tab.Memo.Lines.Add(Conn.SqlProvider.GetSql(qExplain, [SynMemoProcessView.Text]) + ';'); Tab.TabSheet.Show; actExecuteQueryExecute(Sender); end; @@ -12540,10 +14177,10 @@ procedure TMainForm.UpdateLineCharPanel; x := Grid.FocusedColumn+1; if Grid.SelectedCount > 1 then AppendMsg := ' ('+FormatNumber(Grid.SelectedCount)+' sel)'; - end else if QueryTabActive and ActiveQueryMemo.Focused then begin - x := ActiveQueryMemo.CaretX; - y := ActiveQueryMemo.CaretY; - AppendMsg := ' ('+FormatByteNumber(ActiveQueryMemo.GetTextLen)+')'; + end else if QueryTabs.HasActiveTab and QueryTabs.ActiveMemo.Focused then begin + x := QueryTabs.ActiveMemo.CaretX; + y := QueryTabs.ActiveMemo.CaretY; + AppendMsg := ' ('+FormatByteNumber(QueryTabs.ActiveMemo.GetTextLen)+')'; end; if (x > -1) and (y > -1) then begin ShowStatusMsg('r'+FormatNumber(y)+' : c'+FormatNumber(x) + AppendMsg, 1) @@ -12594,11 +14231,12 @@ procedure TMainForm.actCancelOperationExecute(Sender: TObject); Tab.ExecutionThread.Aborted := True; Killer := ActiveConnection.Parameters.CreateConnection(Self); Killer.Parameters := ActiveConnection.Parameters; + Killer.OwnsParameters := False; Killer.LogPrefix := _('Helper connection'); Killer.OnLog := LogSQL; - Killer.Active := True; - KillCommand := Killer.GetSQLSpecifity(spKillQuery, [ActiveConnection.ThreadId]); try + Killer.Active := True; + KillCommand := Killer.SqlProvider.GetSql(qKillQuery, [ActiveConnection.ThreadId]); Killer.Query(KillCommand); except on E:EDbError do begin @@ -12641,8 +14279,9 @@ function TMainForm.GetEncodingByName(Name: String): TEncoding; 2: Result := TEncoding.GetEncoding(437); 3: Result := TEncoding.Unicode; 4: Result := TEncoding.BigEndianUnicode; - 5: Result := TEncoding.UTF8; + 5: Result := UTF8NoBOMEncoding; 6: Result := TEncoding.UTF7; + 7: Result := TEncoding.UTF8; end; end; @@ -12655,8 +14294,9 @@ function TMainForm.GetEncodingName(Encoding: TEncoding): String; else if (Encoding <> nil) and (Encoding.CodePage = 437) then idx := 2 else if Encoding = TEncoding.Unicode then idx := 3 else if Encoding = TEncoding.BigEndianUnicode then idx := 4 - else if Encoding = TEncoding.UTF8 then idx := 5 + else if Encoding = UTF8NoBOMEncoding then idx := 5 else if Encoding = TEncoding.UTF7 then idx := 6 + else if Encoding = TEncoding.UTF8 then idx := 7 else idx := 0; Result := FileEncodings[idx]; end; @@ -12723,10 +14363,12 @@ function TMainForm.GetCharsetByEncoding(Encoding: TEncoding): String; Result := 'utf16le' else if Encoding = TEncoding.BigEndianUnicode then Result := 'utf16' - else if Encoding = TEncoding.UTF8 then + else if Encoding = UTF8NoBOMEncoding then Result := 'utf8' else if Encoding = TEncoding.UTF7 then - Result := 'utf7'; + Result := 'utf7' + else if Encoding = TEncoding.UTF8 then + Result := 'utf8' // Auto-detection not supported here end; @@ -12739,11 +14381,11 @@ procedure TMainForm.treeQueryHelpersBeforeCellPaint(Sender: TBaseVirtualTree; Ta History: TQueryHistory; begin // Paint green value bar in cell - if (Node.Parent.Index=HELPERNODE_PROFILE) + if (Node.Parent.Index=TQueryTab.HelperNodeProfile) and (Column=1) and (Sender.GetNodeLevel(Node)=1) then begin - Tab := GetQueryTabByHelpers(Sender); + Tab := QueryTabs.TabByControl(Sender); if Tab <> nil then begin Tab.QueryProfile.RecNo := Node.Index; PaintColorBar(MakeFloat(Tab.QueryProfile.Col(Column)), Tab.MaxProfileTime, TargetCanvas, CellRect); @@ -12751,8 +14393,8 @@ procedure TMainForm.treeQueryHelpersBeforeCellPaint(Sender: TBaseVirtualTree; Ta end; if (Sender.GetNodeLevel(Node)=2) and (Column=1) - and (Node.Parent.Parent.Index=HELPERNODE_HISTORY) then begin - Tab := GetQueryTabByHelpers(Sender); + and (Node.Parent.Parent.Index=TQueryTab.HelperNodeHistory) then begin + Tab := QueryTabs.TabByControl(Sender); if Tab <> nil then begin History := Tab.HistoryDays.Objects[Node.Parent.Index] as TQueryHistory; PaintColorBar(History[Node.Index].Duration, History.MaxDuration, TargetCanvas, CellRect); @@ -12768,7 +14410,7 @@ procedure TMainForm.treeQueryHelpersPaintText(Sender: TBaseVirtualTree; const Ta Tab: TQueryTab; begin // Paint text in datatype's color - if (Node.Parent.Index=HELPERNODE_COLUMNS) + if (Node.Parent.Index=TQueryTab.HelperNodeColumns) and (Column=1) and (Sender.GetNodeLevel(Node)=1) and (ActiveDbObj.NodeType in [lntView, lntTable]) @@ -12776,9 +14418,9 @@ procedure TMainForm.treeQueryHelpersPaintText(Sender: TBaseVirtualTree; const Ta TargetCanvas.Font.Color := DatatypeCategories[SelectedTableColumns[Node.Index].DataType.Category].Color; end; if (Sender.GetNodeLevel(Node)=2) - and (Node.Parent.Parent.Index=HELPERNODE_HISTORY) + and (Node.Parent.Parent.Index=TQueryTab.HelperNodeHistory) and (ActiveConnection <> nil) then begin - Tab := GetQueryTabByHelpers(Sender); + Tab := QueryTabs.TabByControl(Sender); if Tab <> nil then begin History := Tab.HistoryDays.Objects[Node.Parent.Index] as TQueryHistory; if ActiveConnection.Database <> History[Node.Index].Database then @@ -12789,8 +14431,8 @@ procedure TMainForm.treeQueryHelpersPaintText(Sender: TBaseVirtualTree; const Ta // If there is no value for bind variable, the font style is Italic and Underline if (Sender.GetNodeLevel(Node)=1) and (Column=1) - and (Node.Parent.Index=HELPERNODE_BINDING) then begin - Tab := GetQueryTabByHelpers(Sender); + and (Node.Parent.Index=TQueryTab.HelperNodeBinding) then begin + Tab := QueryTabs.TabByControl(Sender); if StrLen(PChar(Tab.ListBindParams.Items[Node.Index].Value)) = 0 then TargetCanvas.Font.Style := [fsItalic]+[fsUnderline]; @@ -12819,7 +14461,7 @@ procedure TMainForm.treeQueryHelpersDblClick(Sender: TObject); var m: TSynMemo; begin - m := ActiveQueryMemo; + m := QueryTabs.ActiveMemo; m.DragDrop(Sender, m.CaretX, m.CaretY); end; @@ -12829,7 +14471,7 @@ procedure TMainForm.treeQueryHelpersEditing(Sender: TBaseVirtualTree; begin // If current column is value of Bind Param, we allow editing if (Column = 1) - and (Sender.FocusedNode.Parent.Index = HELPERNODE_BINDING) then begin + and (Sender.FocusedNode.Parent.Index = TQueryTab.HelperNodeBinding) then begin Allowed := True; end end; @@ -12845,7 +14487,7 @@ procedure TMainForm.treeQueryHelpersFocusChanging(Sender: TBaseVirtualTree; OldN if not Assigned(NewNode) then Exit; if (Tree.GetNodeLevel(NewNode) = 0) or - (NewNode.Parent.Index=HELPERNODE_SNIPPETS) + (NewNode.Parent.Index=TQueryTab.HelperNodeSnippets) then begin Tree.ClearSelection; Tree.TreeOptions.SelectionOptions := Tree.TreeOptions.SelectionOptions - [toMultiSelect] @@ -12861,8 +14503,8 @@ procedure TMainForm.treeQueryHelpersFreeNode(Sender: TBaseVirtualTree; begin // Free some memory, taken by probably big SQL query history items if (Sender.GetNodeLevel(Node)=1) - and (Node.Parent.Index = HELPERNODE_HISTORY) then begin - Tab := GetQueryTabByHelpers(Sender); + and (Node.Parent.Index = TQueryTab.HelperNodeHistory) then begin + Tab := QueryTabs.TabByControl(Sender); if Tab <> nil then begin Tab.HistoryDays.Objects[Node.Index].Free; Tab.HistoryDays.Delete(Node.Index); @@ -12881,25 +14523,25 @@ procedure TMainForm.treeQueryHelpersGetImageIndex(Sender: TBaseVirtualTree; Node Exit; case Sender.GetNodeLevel(Node) of 0: case Node.Index of - HELPERNODE_COLUMNS: if (ActiveDbObj <> nil) and (ActiveDbObj.NodeType <> lntNone) then + TQueryTab.HelperNodeColumns: if (ActiveDbObj <> nil) and (ActiveDbObj.NodeType <> lntNone) then ImageIndex := ActiveDbObj.ImageIndex else ImageIndex := 14; - HELPERNODE_FUNCTIONS: ImageIndex := 13; - HELPERNODE_KEYWORDS: ImageIndex := 25; - HELPERNODE_SNIPPETS: ImageIndex := 51; - HELPERNODE_HISTORY: ImageIndex := 149; - HELPERNODE_PROFILE: ImageIndex := 145; - HELPERNODE_BINDING: ImageIndex := 119; + TQueryTab.HelperNodeFunctions: ImageIndex := 13; + TQueryTab.HelperNodeKeywords: ImageIndex := 25; + TQueryTab.HelperNodeSnippets: ImageIndex := 51; + TQueryTab.HelperNodeHistory: ImageIndex := 149; + TQueryTab.HelperNodeProfile: ImageIndex := 145; + TQueryTab.HelperNodeBinding: ImageIndex := 119; end; 1: case Node.Parent.Index of - HELPERNODE_COLUMNS: ImageIndex := 42; - HELPERNODE_FUNCTIONS: ImageIndex := 13; - HELPERNODE_KEYWORDS: ImageIndex := 25; - HELPERNODE_SNIPPETS: ImageIndex := 68; - HELPERNODE_HISTORY: ImageIndex := 80; - HELPERNODE_PROFILE: ImageIndex := 145; - HELPERNODE_BINDING: ImageIndex := 42; + TQueryTab.HelperNodeColumns: ImageIndex := ICONINDEX_FIELD; + TQueryTab.HelperNodeFunctions: ImageIndex := 13; + TQueryTab.HelperNodeKeywords: ImageIndex := 25; + TQueryTab.HelperNodeSnippets: ImageIndex := 68; + TQueryTab.HelperNodeHistory: ImageIndex := 80; + TQueryTab.HelperNodeProfile: ImageIndex := 145; + TQueryTab.HelperNodeBinding: ImageIndex := ICONINDEX_FIELD; end; end; end; @@ -12910,37 +14552,38 @@ procedure TMainForm.treeQueryHelpersGetText(Sender: TBaseVirtualTree; Node: PVir var History: TQueryHistory; Tab: TQueryTab; + Conn: TDBConnection; begin // Query helpers tree fetching node text CellText := ''; - Tab := GetQueryTabByHelpers(Sender); + Tab := QueryTabs.TabByControl(Sender); case Column of 0: case Sender.GetNodeLevel(Node) of 0: case Node.Index of - HELPERNODE_COLUMNS: begin + TQueryTab.HelperNodeColumns: begin CellText := _('Columns'); if ActiveDbObj <> nil then case ActiveDbObj.NodeType of lntProcedure, lntFunction: CellText := f_('Parameters in %s', [ActiveDbObj.Name]); lntTable, lntView: CellText := f_('Columns in %s', [ActiveDbObj.Name]); end; end; - HELPERNODE_FUNCTIONS: CellText := _('SQL functions'); - HELPERNODE_KEYWORDS: CellText := _('SQL keywords'); - HELPERNODE_SNIPPETS: CellText := _('Snippets'); - HELPERNODE_HISTORY: CellText := _('Query history'); - HELPERNODE_PROFILE: begin + TQueryTab.HelperNodeFunctions: CellText := _('SQL functions'); + TQueryTab.HelperNodeKeywords: CellText := _('SQL keywords'); + TQueryTab.HelperNodeSnippets: CellText := _('Snippets'); + TQueryTab.HelperNodeHistory: CellText := _('Query history'); + TQueryTab.HelperNodeProfile: begin CellText := _('Query profile'); if Assigned(Tab.QueryProfile) then CellText := CellText + ' ('+FormatNumber(Tab.ProfileTime, 6)+'s)'; end; - HELPERNODE_BINDING: begin + TQueryTab.HelperNodeBinding: begin CellText := _('Bind parameters'); if(Tab.BindParamsActivated) then CellText := CellText + ' ('+FormatNumber(Tab.ListBindParams.Count)+')'; end; end; 1: case Node.Parent.Index of - HELPERNODE_COLUMNS: begin + TQueryTab.HelperNodeColumns: begin if ActiveDbObj <> nil then case ActiveDbObj.NodeType of lntTable, lntView: if SelectedTableColumns.Count > Integer(Node.Index) then @@ -12950,26 +14593,30 @@ procedure TMainForm.treeQueryHelpersGetText(Sender: TBaseVirtualTree; Node: PVir CellText := TfrmRoutineEditor(ActiveObjectEditor).Parameters[Node.Index].Name; end; end; - HELPERNODE_FUNCTIONS: CellText := MySQLFunctions[Node.Index].Name; - HELPERNODE_KEYWORDS: CellText := MySQLKeywords[Node.Index]; - HELPERNODE_SNIPPETS: CellText := FSnippetFilenames[Node.Index]; - HELPERNODE_HISTORY: begin + TQueryTab.HelperNodeFunctions: begin + Conn := ActiveConnection; + if (Conn <> nil) and (Conn.SQLFunctions.Count > Integer(Node.Index)) then + CellText := Conn.SQLFunctions[Node.Index].Name; + end; + TQueryTab.HelperNodeKeywords: CellText := MySQLKeywords[Node.Index]; + TQueryTab.HelperNodeSnippets: CellText := IfThen(Node.Index < Cardinal(FSnippetFilenames.Count), FSnippetFilenames[Node.Index], ''); + TQueryTab.HelperNodeHistory: begin CellText := Tab.HistoryDays[Node.Index]; if CellText = DateToStr(Today) then CellText := CellText + ', '+_('today') else if CellText = DateToStr(Yesterday) then CellText := CellText + ', '+_('yesterday'); end; - HELPERNODE_PROFILE: begin + TQueryTab.HelperNodeProfile: begin if Assigned(Tab.QueryProfile) then begin Tab.QueryProfile.RecNo := Node.Index; CellText := Tab.QueryProfile.Col(Column); end; end; - HELPERNODE_BINDING: CellText := Tab.ListBindParams[Node.Index].Name; + TQueryTab.HelperNodeBinding: CellText := Tab.ListBindParams[Node.Index].Name; end; 2: case Node.Parent.Parent.Index of - HELPERNODE_HISTORY: begin + TQueryTab.HelperNodeHistory: begin History := Tab.HistoryDays.Objects[Node.Parent.Index] as TQueryHistory; CellText := Copy(TimeToStr(History[Node.Index].Time), 1, 5)+': '+History[Node.Index].SQL; end @@ -12979,21 +14626,25 @@ procedure TMainForm.treeQueryHelpersGetText(Sender: TBaseVirtualTree; Node: PVir 1: case Sender.GetNodeLevel(Node) of 0: CellText := ''; 1: case Node.Parent.Index of - HELPERNODE_COLUMNS: begin + TQueryTab.HelperNodeColumns: begin if (ActiveDbObj <> nil) and (ActiveDbObj.NodeType in [lntTable, lntView]) and (SelectedTableColumns.Count > Integer(Node.Index)) then begin CellText := SelectedTableColumns[Node.Index].DataType.Name; end; end; - HELPERNODE_FUNCTIONS: CellText := MySQLFunctions[Node.Index].Declaration; - HELPERNODE_PROFILE: begin + TQueryTab.HelperNodeFunctions: begin + Conn := ActiveConnection; + if (Conn <> nil) and (Conn.SQLFunctions.Count > Integer(Node.Index)) then + CellText := Conn.SQLFunctions[Node.Index].Declaration; + end; + TQueryTab.HelperNodeProfile: begin if Assigned(Tab.QueryProfile) then begin Tab.QueryProfile.RecNo := Node.Index; CellText := FormatNumber(Tab.QueryProfile.Col(Column))+'s'; end; end; - HELPERNODE_BINDING: begin + TQueryTab.HelperNodeBinding: begin // If value is empty, display MsgBindParamNoValue if StrLen(PChar(Tab.ListBindParams[Node.Index].Value))>0 then CellText := Tab.ListBindParams[Node.Index].Value @@ -13003,7 +14654,7 @@ procedure TMainForm.treeQueryHelpersGetText(Sender: TBaseVirtualTree; Node: PVir else CellText := ''; end; 2: case Node.Parent.Parent.Index of - HELPERNODE_HISTORY: begin + TQueryTab.HelperNodeHistory: begin History := Tab.HistoryDays.Objects[Node.Parent.Index] as TQueryHistory; CellText := FormatNumber(History[Node.Index].Duration / 1000, 3)+'s'; end; @@ -13020,14 +14671,14 @@ procedure TMainForm.treeQueryHelpersInitNode(Sender: TBaseVirtualTree; ParentNod case Sender.GetNodeLevel(Node) of 0: begin Include(InitialStates, ivsHasChildren); - if Node.Index = HELPERNODE_PROFILE then + if Node.Index = TQueryTab.HelperNodeProfile then Node.CheckType := ctCheckbox; - if Node.Index = HELPERNODE_BINDING then + if Node.Index = TQueryTab.HelperNodeBinding then Node.CheckType := ctCheckbox; end; 1: begin AppSettings.ResetPath; - if (Node.Parent.Index = HELPERNODE_HISTORY) and AppSettings.ReadBool(asQueryHistoryEnabled) then + if (Node.Parent.Index = TQueryTab.HelperNodeHistory) and AppSettings.ReadBool(asQueryHistoryEnabled) then Include(InitialStates, ivsHasChildren); end; end; @@ -13041,7 +14692,7 @@ procedure TMainForm.treeQueryHelpersNewText(Sender: TBaseVirtualTree; QueryTab: TQueryTab; begin Tree:= Sender as TVirtualStringTree; - QueryTab := ActiveQueryTab; + QueryTab := QueryTabs.ActiveTab; // Save new param value QueryTab.ListBindParams.Items[Sender.FocusedNode.Index].Value := NewText; @@ -13057,7 +14708,7 @@ procedure TMainForm.treeQueryHelpersNodeClick(Sender: TBaseVirtualTree; begin Tree := Sender as TVirtualStringTree; // If the column is clicked a parameter value, it goes directly into the edit mode - if (HitInfo.HitNode.Parent.Index = HELPERNODE_BINDING) and (HitInfo.HitColumn = 1) then + if (HitInfo.HitNode.Parent.Index = TQueryTab.HelperNodeBinding) and (HitInfo.HitColumn = 1) then Tree.EditNode(Sender.FocusedNode,Sender.FocusedColumn); end; @@ -13070,11 +14721,13 @@ procedure TMainForm.treeQueryHelpersInitChildren(Sender: TBaseVirtualTree; Node: Item: TQueryHistoryItem; Tab: TQueryTab; i: Integer; + Conn: TDBConnection; begin - Tab := GetQueryTabByHelpers(Sender); + Tab := QueryTabs.TabByControl(Sender); + Conn := ActiveConnection; case Sender.GetNodeLevel(Node) of 0: case Node.Index of - HELPERNODE_COLUMNS: begin + TQueryTab.HelperNodeColumns: begin ChildCount := 0; if ActiveDbObj <> nil then case ActiveDbObj.NodeType of lntTable, lntView: @@ -13086,17 +14739,17 @@ procedure TMainForm.treeQueryHelpersInitChildren(Sender: TBaseVirtualTree; Node: ChildCount := 0; end; end; - HELPERNODE_FUNCTIONS: ChildCount := Length(MySQLFunctions); - HELPERNODE_KEYWORDS: ChildCount := MySQLKeywords.Count; - HELPERNODE_SNIPPETS: ChildCount := FSnippetFilenames.Count; - HELPERNODE_HISTORY: begin + TQueryTab.HelperNodeFunctions: ChildCount := ActiveConnection.SQLFunctions.Count; + TQueryTab.HelperNodeKeywords: ChildCount := MySQLKeywords.Count; + TQueryTab.HelperNodeSnippets: ChildCount := FSnippetFilenames.Count; + TQueryTab.HelperNodeHistory: begin AppSettings.ResetPath; - if AppSettings.ReadBool(asQueryHistoryEnabled) then begin + if AppSettings.ReadBool(asQueryHistoryEnabled) and (Conn <> nil) then begin // Find all unique days in history if not Assigned(Tab.HistoryDays) then Tab.HistoryDays := TStringList.Create; Tab.HistoryDays.Clear; - History := TQueryHistory.Create(ActiveConnection.Parameters.SessionPath); + History := TQueryHistory.Create(Conn.Parameters.SessionPath); for Item in History do begin QueryDay := DateToStr(Item.Time); if Tab.HistoryDays.IndexOf(QueryDay) = -1 then @@ -13107,20 +14760,22 @@ procedure TMainForm.treeQueryHelpersInitChildren(Sender: TBaseVirtualTree; Node: ChildCount := Tab.HistoryDays.Count; end; end; - HELPERNODE_PROFILE: if not Assigned(Tab.QueryProfile) then ChildCount := 0 + TQueryTab.HelperNodeProfile: if not Assigned(Tab.QueryProfile) then ChildCount := 0 else ChildCount := Tab.QueryProfile.RecordCount; - HELPERNODE_BINDING: ChildCount := Tab.ListBindParams.Count; + TQueryTab.HelperNodeBinding: ChildCount := Tab.ListBindParams.Count; end; 1: case Node.Parent.Index of - HELPERNODE_HISTORY: begin - History := TQueryHistory.Create(ActiveConnection.Parameters.SessionPath); - Tab.HistoryDays.Objects[Node.Index] := History; - for i:=History.Count-1 downto 0 do begin - QueryDay := DateToStr(History[i].Time); - if QueryDay <> Tab.HistoryDays[Node.Index] then - History.Delete(i); + TQueryTab.HelperNodeHistory: begin + if Conn <> nil then begin + History := TQueryHistory.Create(Conn.Parameters.SessionPath); + Tab.HistoryDays.Objects[Node.Index] := History; + for i:=History.Count-1 downto 0 do begin + QueryDay := DateToStr(History[i].Time); + if QueryDay <> Tab.HistoryDays[Node.Index] then + History.Delete(i); + end; + ChildCount := History.Count; end; - ChildCount := History.Count; end; else ChildCount := 0; end; @@ -13151,7 +14806,7 @@ procedure TMainForm.SetSnippetFilenames; LogSQL(f_('Error with snippets directory: %s', [E.Message]), lcError); end; end; - RefreshHelperNode(HELPERNODE_SNIPPETS); + RefreshHelperNode(TQueryTab.HelperNodeSnippets); end; @@ -13162,12 +14817,12 @@ procedure TMainForm.treeQueryHelpersChecking(Sender: TBaseVirtualTree; Tree: TVirtualStringTree; begin Tree := Sender as TVirtualStringTree; - Tab := GetQueryTabByHelpers(Sender); + Tab := QueryTabs.TabByControl(Sender); case Sender.GetNodeLevel(Node) of 0: case Node.Index of - HELPERNODE_BINDING: begin + TQueryTab.HelperNodeBinding: begin // Disallow checkbox clicking on "Bind parameters" when text too big if NewState in CheckedStates then begin if Tab.Memo.GetTextLen < SIZE_MB then begin @@ -13206,39 +14861,54 @@ procedure TMainForm.treeQueryHelpersContextPopup(Sender: TObject; MousePos: TPoi menuQueryHelpersGenerateInsert.Enabled := False; menuQueryHelpersGenerateUpdate.Enabled := False; menuQueryHelpersGenerateDelete.Enabled := False; - menuInsertSnippetAtCursor.Enabled := False; + menuInsertAtCursor.Enabled := False; menuLoadSnippet.Enabled := False; + menuRenameSnippet.Enabled := False; menuDeleteSnippet.Enabled := False; menuExplore.Enabled := False; menuHelp.Enabled := False; menuClearQueryHistory.Enabled := False; + menuClearQueryHistory.Caption := _('Clear query history ...'); case Tree.GetNodeLevel(Tree.FocusedNode) of 0: ; 1: case Tree.FocusedNode.Parent.Index of - HELPERNODE_COLUMNS: if ActiveDbObj.NodeType in [lntTable, lntView] then begin + TQueryTab.HelperNodeColumns: begin + if ActiveDbObj.NodeType in [lntTable, lntView] then begin menuQueryHelpersGenerateSelect.Enabled := True; menuQueryHelpersGenerateInsert.Enabled := True; menuQueryHelpersGenerateUpdate.Enabled := True; menuQueryHelpersGenerateDelete.Enabled := True; + menuInsertAtCursor.Enabled := True; end; - HELPERNODE_FUNCTIONS: menuHelp.Enabled := True; - HELPERNODE_KEYWORDS: menuHelp.Enabled := True; - HELPERNODE_SNIPPETS: begin + end; + TQueryTab.HelperNodeFunctions: begin + menuHelp.Enabled := True; + menuInsertAtCursor.Enabled := True; + end; + TQueryTab.HelperNodeKeywords: begin + menuHelp.Enabled := True; + menuInsertAtCursor.Enabled := True; + end; + TQueryTab.HelperNodeSnippets: begin + menuRenameSnippet.Enabled := True; menuDeleteSnippet.Enabled := True; - menuInsertSnippetAtCursor.Enabled := True; + menuInsertAtCursor.Enabled := True; menuLoadSnippet.Enabled := True; menuExplore.Enabled := True; end; - HELPERNODE_PROFILE: begin // Query profile + TQueryTab.HelperNodeProfile: begin // Query profile end; - HELPERNODE_HISTORY: + TQueryTab.HelperNodeHistory: menuClearQueryHistory.Enabled := True; end; 2: case Tree.FocusedNode.Parent.Parent.Index of - HELPERNODE_HISTORY: + TQueryTab.HelperNodeHistory: begin menuClearQueryHistory.Enabled := True; + menuClearQueryHistory.Caption := _('Delete this query from history'); + menuInsertAtCursor.Enabled := True; + end; end; end; end; @@ -13251,7 +14921,7 @@ procedure TMainForm.treeQueryHelpersCreateEditor(Sender: TBaseVirtualTree; VT: TVirtualStringTree; begin VT := Sender as TVirtualStringTree; - InplaceEditor := TInplaceEditorLink.Create(VT, True); + InplaceEditor := TInplaceEditorLink.Create(VT, True, nil); InplaceEditor.ButtonVisible := true; EditLink := InplaceEditor; end; @@ -13269,41 +14939,42 @@ procedure TMainForm.RefreshHelperNode(NodeIndex: Cardinal); if not Assigned(QueryTabs) then Exit; Conn := ActiveConnection; - for Tab in QueryTabs do begin - Node := FindNode(Tab.treeHelpers, NodeIndex, nil); - // Store node + children states - OldStates := Node.States; - OldCheckState := Node.CheckState; - ExpandedChildren := TStringList.Create; + Tab := QueryTabs.ActiveTab; + if Tab = nil then + Exit; + Node := FindNode(Tab.treeHelpers, NodeIndex, nil); + // Store node + children states + OldStates := Node.States; + OldCheckState := Node.CheckState; + ExpandedChildren := TStringList.Create; + Child := Tab.treeHelpers.GetFirstChild(Node); + while Assigned(Child) do begin + if vsExpanded in Child.States then + ExpandedChildren.Add(IntToStr(Child.Index)); + Child := Tab.treeHelpers.GetNextSibling(Child); + end; + // Keep scroll offset + Tab.treeHelpers.BeginUpdate; + // Remove children and grandchildren + Tab.treeHelpers.ResetNode(Node); + // Restore old node + children states + Tab.treeHelpers.CheckState[Node] := OldCheckState; + Tab.treeHelpers.Expanded[Node] := vsExpanded in OldStates; + // Disable profiling when not on MySQL + if (NodeIndex = TQueryTab.HelperNodeProfile) and (Conn <> nil) and (not Conn.Parameters.IsAnyMySQL) then begin + Tab.treeHelpers.CheckState[Node] := csUncheckedNormal; + end; + // Do not check expansion state of children unless the parent node is expanded, to avoid + // initializing children when not required. Accesses registry items when doing so. + if Tab.treeHelpers.Expanded[Node] then begin Child := Tab.treeHelpers.GetFirstChild(Node); while Assigned(Child) do begin - if vsExpanded in Child.States then - ExpandedChildren.Add(IntToStr(Child.Index)); + Tab.treeHelpers.Expanded[Child] := ExpandedChildren.IndexOf(IntToStr(Child.Index)) > -1; Child := Tab.treeHelpers.GetNextSibling(Child); end; - // Keep scroll offset - Tab.treeHelpers.BeginUpdate; - // Remove children and grandchildren - Tab.treeHelpers.ResetNode(Node); - // Restore old node + children states - Tab.treeHelpers.CheckState[Node] := OldCheckState; - Tab.treeHelpers.Expanded[Node] := vsExpanded in OldStates; - // Disable profiling when not on MySQL - if (NodeIndex = HELPERNODE_PROFILE) and (Conn <> nil) and (not Conn.Parameters.IsAnyMySQL) then begin - Tab.treeHelpers.CheckState[Node] := csUncheckedNormal; - end; - // Do not check expansion state of children unless the parent node is expanded, to avoid - // initializing children when not required. Accesses registry items when doing so. - if Tab.treeHelpers.Expanded[Node] then begin - Child := Tab.treeHelpers.GetFirstChild(Node); - while Assigned(Child) do begin - Tab.treeHelpers.Expanded[Child] := ExpandedChildren.IndexOf(IntToStr(Child.Index)) > -1; - Child := Tab.treeHelpers.GetNextSibling(Child); - end; - end; - ExpandedChildren.Free; - Tab.treeHelpers.EndUpdate; end; + ExpandedChildren.Free; + Tab.treeHelpers.EndUpdate; end; @@ -13330,6 +15001,7 @@ procedure TMainForm.ApplicationEvents1Idle(Sender: TObject; var Done: Boolean); on E:Exception do ErrorDialog(E.Message); end; + Done := True; end; // Sort list tables in idle time, so ListTables.TreeOptions.AutoSort does not crash the list @@ -13337,7 +15009,16 @@ procedure TMainForm.ApplicationEvents1Idle(Sender: TObject; var Done: Boolean); if (PageControlMain.ActivePage = tabDatabase) and (not FListTablesSorted) then begin ListTables.SortTree(ListTables.Header.SortColumn, ListTables.Header.SortDirection); FListTablesSorted := True; + Done := True; + end; + + // Re-enable refresh action when application is idle + if (not actRefresh.Enabled) and (FRefreshActionDisabledAt < (GetTickCount - 1000)) then + begin + actRefresh.Enabled := True; + Done := True; end; + end; @@ -13350,8 +15031,11 @@ procedure TMainForm.ApplicationEvents1ShortCut(var Msg: TWMKey; Combo: TComboBox; rx: TRegExpr; TextMatches: Boolean; + PressedShortcut: TShortCut; + Act: TContainedAction; begin // Support for Ctrl+Backspace shortcut in edit + combobox controls + //LogSQL(msg.CharCode.ToString); Handled := False; if (Msg.CharCode = VK_BACK) and KeyPressed(VK_CONTROL) then begin SendingControl := Screen.ActiveControl; @@ -13365,7 +15049,10 @@ procedure TMainForm.ApplicationEvents1ShortCut(var Msg: TWMKey; Edit.SelStart := rx.MatchPos[0]-1; Edit.SelLength := LastStart - Edit.SelStart; // wParam=1 supports undo, in contrast to setting Edit.SelText - SendMessage(Edit.Handle, EM_REPLACESEL, 1, LongInt(PChar(''))); + if IsWine then + Edit.SelText := '' + else + SendMessage(Edit.Handle, EM_REPLACESEL, 1, LongInt(PChar(''))); end; Handled := True; end @@ -13384,6 +15071,26 @@ procedure TMainForm.ApplicationEvents1ShortCut(var Msg: TWMKey; ', expression "'+rx.Expression+'" matched: '+TextMatches.ToInteger.ToString, lcDebug); rx.Free; + + end else begin + // Listen to certain shortcut(s) in other forms than mainform, which do not listen to ActionList + PressedShortcut := ShortCut(Msg.CharCode, KeyDataToShiftState(Msg.KeyData)); + for Act in ActionList1 do begin + if (Act = actSynEditCompletionPropose) + or (Act = actQueryFind) // Support find/replace on grid text editor + or (Act = actQueryFindAgain) + or (Act = actQueryReplace) + then begin + + if PressedShortcut = Act.ShortCut then begin + Act.Execute; + Handled := True; + Break; + end; + + end; + end; + end; end; @@ -13392,25 +15099,53 @@ procedure TMainForm.ApplicationDeActivate(Sender: TObject); // Prevent completion window from showing up after Alt-Tab. See issue #2640 // and issue #3342 // Does not work for some reason in TApplicationEvents.OnDeactivate - SynCompletionProposal.Form.Enabled := False; + // Triggers an EAccessViolation when changing some VCL styles + try + SynCompletionProposal.Form.Enabled := False; + except + on E:EAccessViolation do + LogSQL(E.Message, lcError); + end; // Gets activated again in SynCompletionProposalExecute end; procedure TMainForm.ApplicationShowHint(var HintStr: string; var CanShow: Boolean; var HintInfo: THintInfo); var - MainTabIndex, QueryTabIndex: integer; + MainTabIndex, QueryTabIndex, NewHideTimeout: integer; pt: TPoint; + Conn: TDBConnection; + Editor: TSynMemo; begin - // Show full filename in tab hint. See issue #3527 - // Code taken from http://www.delphipraxis.net/97988-tabsheet-hint-funktioniert-nicht.html if HintInfo.HintControl = PageControlMain then begin + // Show full filename in tab hint. See issue #3527 + // Code taken from http://www.delphipraxis.net/97988-tabsheet-hint-funktioniert-nicht.html pt := PageControlMain.ScreenToClient(Mouse.CursorPos); MainTabIndex := GetMainTabAt(pt.X, pt.Y); QueryTabIndex := MainTabIndex - tabQuery.PageIndex; - if (QueryTabIndex >= 0) and (QueryTabIndex < QueryTabs.Count) then + if (QueryTabIndex >= 0) and (QueryTabIndex < QueryTabs.Count) then begin HintStr := QueryTabs[QueryTabIndex].MemoFilename; + end + else if MainTabIndex = tabHost.TabIndex then begin + Conn := ActiveConnection; + HintStr := Conn.Parameters.Hostname; + if Conn.Parameters.IsAnySQLite then + HintStr := StringReplace(HintStr, DELIM, SLineBreak, [rfReplaceAll]); + end; HintInfo.ReshowTimeout := 1000; + SetHintFontByControl; + end + else if HintInfo.HintControl is TSynMemo then begin + // Token hint displaying through SynEdit's OnTokenHint event + Editor := TSynMemo(HintInfo.HintControl); + SetHintFontByControl(Editor); + NewHideTimeout := Min(Length(HintStr) * 100, 60*1000); + if NewHideTimeout > HintInfo.HideTimeout then + HintInfo.HideTimeout := NewHideTimeout; + end + else begin + // Probably reset hint font + SetHintFontByControl; end; end; @@ -13430,10 +15165,13 @@ procedure TMainForm.actToggleCommentExecute(Sender: TObject); rx.Expression := '^(\s*)(\-\- |#)?(.*)$'; if not Editor.SelAvail then begin rx.Exec(Editor.LineText); - if rx.MatchLen[2] > 0 then - Editor.LineText := rx.Match[1] + rx.Match[3] - else + if rx.MatchLen[2] > 0 then begin + Editor.LineText := rx.Match[1] + rx.Match[3]; + Editor.CaretX := Editor.CaretX - rx.MatchLen[2]; + end else begin Editor.LineText := '-- '+Editor.LineText; + Editor.CaretX := Editor.CaretX + 3; + end; end else begin Sel := Explode(CRLF, Editor.SelText); IsComment := False; @@ -13446,19 +15184,19 @@ procedure TMainForm.actToggleCommentExecute(Sender: TObject); else Sel[i] := '-- '+Sel[i]; end; - Editor.SelText := ImplodeStr(CRLF, Sel); + Editor.SelText := Implode(CRLF, Sel); + if Assigned(Editor.OnStatusChange) then + Editor.OnStatusChange(Editor, [scCaretX]); end; - if Assigned(Editor.OnChange) then - Editor.OnChange(Sender); end; procedure TMainForm.EnableProgress(MaxValue: Integer); begin // Initialize progres bar and button - SetProgressPosition(0); SetProgressState(pbsNormal); - ProgressBarStatus.Visible := True; + ProgressBarStatus.Visible := True and (not IsWine); + SetProgressPosition(0); ProgressBarStatus.Max := MaxValue; end; @@ -13469,7 +15207,7 @@ procedure TMainForm.DisableProgress; SetProgressPosition(0); ProgressBarStatus.Hide; if Assigned(TaskBarList3) then - TaskBarList3.SetProgressState(Application.MainForm.Handle, 0); + TaskBarList3.SetProgressState(Handle, 0); end; @@ -13484,7 +15222,7 @@ procedure TMainForm.SetProgressPosition(Value: Integer); end; ProgressBarStatus.Repaint; if Assigned(TaskBarList3) then - TaskBarList3.SetProgressValue(Application.MainForm.Handle, Value, ProgressBarStatus.Max); + TaskBarList3.SetProgressValue(Handle, Value, ProgressBarStatus.Max); end; @@ -13508,7 +15246,7 @@ procedure TMainForm.SetProgressState(State: TProgressbarState); pbsPaused: Flag := 8; else Flag := 0; end; - TaskBarList3.SetProgressState(Application.MainForm.Handle, Flag); + TaskBarList3.SetProgressState(Handle, Flag); end; end; @@ -13543,16 +15281,7 @@ function TMainForm.HasDonated(ForceCheck: Boolean): TThreeStateBoolean; CheckWebpage := THttpDownload.Create(MainForm); CheckWebpage.URL := APPDOMAIN + 'hasdonated.php?email='+EncodeURLParam(Email); try - try - CheckWebpage.SendRequest(''); - except - on E:Exception do begin - // Try again without SSL. See issue #65 - LogSQL(E.Message, lcError); - CheckWebpage.URL := ReplaceRegExpr('^https:', CheckWebpage.URL, 'http:'); - CheckWebpage.SendRequest(''); - end; - end; + CheckWebpage.SendRequest(''); CheckResult := CheckWebpage.LastContent; LogSQL('HTTP response: "'+CheckResult+'"', lcDebug); rx.Expression := '^\d'; @@ -13582,7 +15311,7 @@ procedure TMainForm.actPreviousResultExecute(Sender: TObject); Tab: TQueryTab; begin // Go back to the result tab left to the active one - Tab := ActiveQueryTab; + Tab := QueryTabs.ActiveTab; if Tab <> nil then begin if Tab.tabsetQuery.TabIndex > 0 then Tab.tabsetQuery.SelectNext(False) @@ -13597,7 +15326,7 @@ procedure TMainForm.actNextResultExecute(Sender: TObject); Tab: TQueryTab; begin // Advance to the next result tab - Tab := ActiveQueryTab; + Tab := QueryTabs.ActiveTab; if Tab <> nil then begin if Tab.tabsetQuery.TabIndex < Tab.tabsetQuery.Tabs.Count-1 then Tab.tabsetQuery.SelectNext(True) @@ -13635,6 +15364,7 @@ constructor TQueryTab.Create; DirectoryWatch := TDirectoryWatch.Create; DirectoryWatch.WatchSubTree := False; DirectoryWatch.OnNotify := DirectoryWatchNotify; + DirectoryWatch.OnError := DirectoryWatchErrorHandler; // Do not trigger useless file deletion messages, see issue #2948 DirectoryWatch.WatchActions := DirectoryWatch.WatchActions - [waRemoved]; // Do not trigger file access. See https://www.heidisql.com/forum.php?t=15500 @@ -13656,6 +15386,7 @@ constructor TQueryTab.Create; TimerStatusUpdate.Enabled := False; TimerStatusUpdate.Interval := 100; TimerStatusUpdate.OnTimer := TimerStatusUpdateOnTimer; + FFileEncoding := 'UTF-8'; end; @@ -13685,6 +15416,11 @@ procedure TQueryTab.DirectoryWatchNotify(const Sender: TObject; const Action: TW IsCurrentFile: Boolean; begin // Notification about file changes in loaded file's directory + + if FDirectoryWatchNotficationRunning then + Exit; + FDirectoryWatchNotficationRunning := True; + IsCurrentFile := DirectoryWatch.Directory + FileName = MemoFilename; case Action of waRemoved: @@ -13712,15 +15448,13 @@ procedure TQueryTab.DirectoryWatchNotify(const Sender: TObject; const Action: TW end; end; + FDirectoryWatchNotficationRunning := False; end; -procedure TQueryTab.SetMemo(Value: TSynMemo); +procedure TQueryTab.DirectoryWatchErrorHandler(const Sender: TObject; const ErrorCode: Integer; const ErrorMessage: string); begin - // Apply existing SynMemo and its events (only OnChange yet). - // TODO: Move more Memo events from TMainForm.actNewQueryTabExecute here, and keep there procedures in TQueryTab. - FMemo := Value; - FMemo.OnChange := MemoOnChange; + MainForm.LogSQL(Format('File watcher (%d): %s', [ErrorCode, ErrorMessage]), lcError); end; @@ -13730,6 +15464,9 @@ procedure TQueryTab.MemofileModifiedTimerNotify(Sender: TObject); OldCursor: TBufferCoord; begin (Sender as TTimer).Enabled := False; + if FDirectoryWatchNotficationRunning then + Exit; + FDirectoryWatchNotficationRunning := True; if MessageDialog(_('Reload file?'), f_('File was modified from outside: %s', [MemoFilename]), mtConfirmation, [mbYes, mbCancel]) = mrYes then begin OldCursor := Memo.CaretXY; OldTopLine := Memo.TopLine; @@ -13737,32 +15474,41 @@ procedure TQueryTab.MemofileModifiedTimerNotify(Sender: TObject); Memo.CaretXY := OldCursor; Memo.TopLine := OldTopLine; end; + FDirectoryWatchNotficationRunning := False; end; -function TQueryTab.LoadContents(Filename: String; ReplaceContent: Boolean; Encoding: TEncoding): Boolean; +function TQueryTab.LoadContents(Filepath: String; ReplaceContent: Boolean; Encoding: TEncoding): Boolean; var Content: String; Filesize: Int64; LineBreaks: TLineBreaks; + LoadSuccess: Boolean; begin - Result := False; // Load file and add that to the undo-history of SynEdit. // Normally we would do a simple SynMemo.Lines.LoadFromFile but // this would prevent SynEdit from adding this step to the undo-history // so we have to do it by replacing the SelText property + Result := False; Screen.Cursor := crHourGlass; - Filesize := _GetFileSize(filename); - MainForm.LogSQL(f_('Loading file "%s" (%s) into query tab #%d ...', [Filename, FormatByteNumber(Filesize), Number]), lcInfo); + Filesize := _GetFileSize(Filepath); + LoadSuccess := False; + MainForm.LogSQL(f_('Loading file "%s" (%s) into query tab #%d', [Filepath, FormatByteNumber(Filesize), Number]), lcInfo); try - Content := ReadTextfile(Filename, Encoding); - if Pos(AppSettings.DirnameSnippets, Filename) = 0 then - MainForm.AddOrRemoveFromQueryLoadHistory(Filename, True, True); + Content := ReadTextfile(Filepath, Encoding); + LoadSuccess := True; + except on E:Exception do + // File does not exist, is locked or broken + ErrorDialog(E.message + sLineBreak + sLineBreak + Filepath); + end; + + if LoadSuccess then begin + if Pos(AppSettings.DirnameSnippets, Filepath) = 0 then + MainForm.AddOrRemoveFromQueryLoadHistory(Filepath, True, True); Memo.UndoList.AddGroupBreak; - Memo.BeginUpdate; LineBreaks := ScanLineBreaks(Content); if ReplaceContent then begin - Memo.SelectAll; + Memo.Clear; MemoLineBreaks := LineBreaks; end else begin if (MemoLineBreaks <> lbsNone) and (MemoLineBreaks <> LineBreaks) then @@ -13773,23 +15519,25 @@ function TQueryTab.LoadContents(Filename: String; ReplaceContent: Boolean; Encod if MemoLineBreaks = lbsMixed then MessageDialog(_('This file contains mixed linebreaks. They have been converted to Windows linebreaks (CR+LF).'), mtInformation, [mbOK]); - Memo.SelText := Content; + if ReplaceContent then + Memo.Text := Content + else + Memo.SelText := Content; Memo.SelStart := Memo.SelEnd; - Memo.EndUpdate; Memo.Modified := False; - MemoFilename := Filename; + MemoFilename := Filepath; + FileEncoding := MainForm.GetEncodingName(Encoding); + //showmessage(FileEncoding); Result := True; - except on E:Exception do - // File does not exist, is locked or broken - ErrorDialog(E.message + CRLF + CRLF + Filename); end; + Screen.Cursor := crDefault; end; procedure TQueryTab.SaveContents(Filename: String; OnlySelection: Boolean); var - Text, LB: String; + Text, LB, FileDir: String; begin Screen.Cursor := crHourGlass; MainForm.ShowStatusMsg(_('Saving file ...')); @@ -13797,20 +15545,25 @@ procedure TQueryTab.SaveContents(Filename: String; OnlySelection: Boolean); Text := Memo.SelText else Text := Memo.Text; - LB := ''; - case MemoLineBreaks of - lbsUnix: LB := LB_UNIX; - lbsMac: LB := LB_MAC; - lbsWide: LB := LB_WIDE; - end; - if LB <> '' then + LB := GetLineBreak(MemoLineBreaks); + if LB <> CRLF then Text := StringReplace(Text, CRLF, LB, [rfReplaceAll]); - SaveUnicodeFile( Filename, Text ); - MemoFilename := Filename; - Memo.Modified := False; - LastSaveTime := GetTickCount; + try + FileDir := ExtractFilePath(Filename); + if not DirectoryExists(FileDir) then + ForceDirectories(FileDir); + SaveUnicodeFile(Filename, Text, MainForm.GetEncodingByName(FFileEncoding)); + MemoFilename := Filename; + Memo.Modified := False; + LastSaveTime := GetTickCount; + Screen.Cursor := crDefault; + except + on E:Exception do begin + Screen.Cursor := crDefault; + ErrorDialog(E.Message); + end; + end; MainForm.ShowStatusMsg; - Screen.Cursor := crDefault; end; @@ -13829,7 +15582,7 @@ function TQueryTab.MemoBackupFilename: String; Result := ''; end else begin Result := IncludeTrailingBackslash(AppSettings.DirnameBackups) - + goodfilename(Format(BACKUP_FILEPATTERN, [Uid])) + + ValidFilename(Format(BACKUP_FILEPATTERN, [Uid])) ; end; end; @@ -13863,7 +15616,7 @@ procedure TQueryTab.BackupUnsavedContent; if Memo.GetTextLen < SIZE_MB*10 then begin MainForm.LogSQL('Saving backup file to "'+MemoBackupFilename+'"...', lcDebug); MainForm.ShowStatusMsg(_('Saving backup file...')); - SaveUnicodeFile(MemoBackupFilename, Memo.Text); + SaveUnicodeFile(MemoBackupFilename, Memo.Text, UTF8NoBOMEncoding); end else begin MainForm.LogSQL('Unsaved tab contents too large (> 10M) for creating a backup.', lcDebug); end; @@ -13877,8 +15630,10 @@ function TQueryTab.GetBindParamsActivated: Boolean; Node: PVirtualNode; begin // Return state of bind params checkbox - Node := FindNode(treeHelpers, HELPERNODE_BINDING, nil); - Result := treeHelpers.CheckState[Node] in CheckedStates; + Result := False; + Node := FindNode(treeHelpers, TQueryTab.HelperNodeBinding, nil); + if Assigned(Node) then + Result := treeHelpers.CheckState[Node] in CheckedStates; end; @@ -13887,7 +15642,7 @@ procedure TQueryTab.SetBindParamsActivated(Value: Boolean); Node: PVirtualNode; begin // Check bind params checkbox - Node := FindNode(treeHelpers, HELPERNODE_BINDING, nil); + Node := FindNode(treeHelpers, TQueryTab.HelperNodeBinding, nil); if Value then treeHelpers.CheckState[Node] := csCheckedNormal else @@ -13895,12 +15650,21 @@ procedure TQueryTab.SetBindParamsActivated(Value: Boolean); end; +procedure TQueryTab.SetErrorLine(Value: Integer); +begin + if Value <> FErrorLine then begin + FErrorLine := Value; + Memo.Repaint; + end; +end; + + procedure TQueryTab.SetMemoFilename(Value: String); begin FMemoFilename := Value; MainForm.SetTabCaption(TabSheet.PageIndex, ExtractFilename(FMemoFilename)); MainForm.ValidateQueryControls(Self); - if FMemoFilename <> '' then begin + if (FMemoFilename <> '') and FileExists(FMemoFilename) then begin DirectoryWatch.Directory := ExtractFilePath(FMemoFilename); DirectoryWatch.Start; end else @@ -13916,16 +15680,6 @@ procedure TQueryTab.SetQueryRunning(Value: Boolean); end; -procedure TQueryTab.MemoOnChange(Sender: TObject); -begin - // Check if bind param detection is enabled for text size <1M - // Uncheck checkbox if it's bigger - TimerLastChange.Enabled := False; - FLastChange := Now; - TimerLastChange.Enabled := True; -end; - - procedure TQueryTab.TimerLastChangeOnTimer(Sender: TObject); var rx: TRegExpr; @@ -13941,7 +15695,7 @@ procedure TQueryTab.TimerLastChangeOnTimer(Sender: TObject); Exit; if Memo.GetTextLen > SIZE_MB then begin MessageDialog(_('The query is too long to enable detection of bind parameters'), mtError, [mbOK]); - Node := FindNode(treeHelpers, HELPERNODE_BINDING, nil); + Node := FindNode(treeHelpers, TQueryTab.HelperNodeBinding, nil); treeHelpers.CheckState[Node] := csUncheckedNormal; Exit; end; @@ -13990,9 +15744,9 @@ procedure TQueryTab.TimerLastChangeOnTimer(Sender: TObject); ListBindParams.CleanToKeep; // Refresh bind param tree node, so it displays its children. Expand it when it has params for the first time. - MainForm.RefreshHelperNode(HELPERNODE_BINDING); + MainForm.RefreshHelperNode(TQueryTab.HelperNodeBinding); if (ParamCountBefore=0) and (ListBindParams.Count>0) then begin - Node := FindNode(treeHelpers, HELPERNODE_BINDING, nil); + Node := FindNode(treeHelpers, TQueryTab.HelperNodeBinding, nil); treeHelpers.Expanded[Node] := True; end; @@ -14021,6 +15775,88 @@ procedure TQueryTab.TimerStatusUpdateOnTimer(Sender: TObject); end; +{ TQueryTabList } + +function TQueryTabList.ActiveTab: TQueryTab; +var + idx: Integer; + FixedTab: TQueryTab; +begin + // Return active tab + Result := nil; + if Self.Count < 1 then + Exit; + FixedTab := Self[0]; + idx := FixedTab.TabSheet.PageControl.ActivePageIndex - FixedTab.TabSheet.PageIndex; + if (idx >= 0) and (idx < Self.Count) then + Result := Self[idx]; +end; + + +function TQueryTabList.HasActiveTab: Boolean; +begin + Result := ActiveTab <> nil; +end; + + +function TQueryTabList.ActiveMemo: TSynMemo; +var + Tab: TQueryTab; +begin + // Return current query memo + Result := nil; + Tab := ActiveTab; + if Assigned(Tab) then + Result := Tab.Memo; +end; + + +function TQueryTabList.ActiveHelpersTree: TVirtualStringTree; +var + Tab: TQueryTab; +begin + // Return current query helpers tree + Result := nil; + Tab := ActiveTab; + if Assigned(Tab) then + Result := Tab.treeHelpers; +end; + + +function TQueryTabList.TabByNumber(Number: Integer): TQueryTab; +var + Tab: TQueryTab; +begin + // Find right query tab + Result := nil; + for Tab in Self do begin + if Tab.Number = Number then begin + Result := Tab; + break; + end; + end; +end; + + +function TQueryTabList.TabByControl(Control: TWinControl): TQueryTab; +var + Tab: TQueryTab; +begin + // Find query tab where passed control resides + // Supports only most important controls in the upper area, excluding tab close button and result grid + Result := nil; + for Tab in Self do begin + if (Control = Tab.TabSheet) + or (Control = Tab.pnlMemo) or (Control = Tab.Memo) + or (Control = Tab.pnlHelpers) or (Control = Tab.filterHelpers) or (Control = Tab.treeHelpers) + or (Control = Tab.tabsetQuery) + then begin + Result := Tab; + Break; + end; + end; +end; + @@ -14080,6 +15916,7 @@ constructor TResultTab.Create(AOwner: TQueryTab); Grid.OnPaintText := OrgGrid.OnPaintText; Grid.OnStartOperation := OrgGrid.OnStartOperation; FixVT(Grid, AppSettings.ReadInt(asGridRowLineCount)); + FTabIndex := QueryTab.ResultTabs.Count; // Will be 0 for the first one, even if we're already creating the first one here! end; destructor TResultTab.Destroy; @@ -14189,7 +16026,7 @@ function TListBindParam.GetAsText: String; for Param in Self do begin Lines.Add(Param.Name + FPairDelimiter + Param.Value); end; - Result := implodestr(FItemDelimiter, Lines); + Result := Implode(FItemDelimiter, Lines); Lines.Free; end; diff --git a/source/options.dfm b/source/preferences.dfm similarity index 75% rename from source/options.dfm rename to source/preferences.dfm index ea40480fe..56b77b0ba 100644 --- a/source/options.dfm +++ b/source/preferences.dfm @@ -1,34 +1,31 @@ -object optionsform: Toptionsform +object frmPreferences: TfrmPreferences Left = 547 Top = 163 BorderIcons = [biSystemMenu] Caption = 'Preferences' - ClientHeight = 460 - ClientWidth = 722 + ClientHeight = 482 + ClientWidth = 712 Color = clBtnFace Constraints.MinHeight = 480 Constraints.MinWidth = 600 Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText - Font.Height = -11 + Font.Height = -12 Font.Name = 'Tahoma' Font.Style = [] - OldCreateOrder = False Position = poMainFormCenter OnClose = FormClose OnCreate = FormCreate - OnDestroy = FormDestroy OnShow = FormShow DesignSize = ( - 722 - 460) - PixelsPerInch = 96 - TextHeight = 13 + 712 + 482) + TextHeight = 14 object pagecontrolMain: TPageControl Left = 8 Top = 8 - Width = 708 - Height = 417 + Width = 684 + Height = 435 ActivePage = tabMisc Anchors = [akLeft, akTop, akRight, akBottom] Images = MainForm.VirtualImageListMain @@ -40,70 +37,70 @@ object optionsform: Toptionsform ImageIndex = 137 ImageName = 'icons8-settings' DesignSize = ( - 700 - 388) + 676 + 406) object lblMySQLBinaries: TLabel Left = 8 Top = 177 - Width = 152 - Height = 13 + Width = 174 + Height = 14 Caption = 'MySQL command line programs:' end object lblLanguage: TLabel Left = 8 Top = 231 - Width = 112 - Height = 13 + Width = 127 + Height = 14 Caption = 'Application language: *' end object lblCustomSnippetsDirectory: TLabel Left = 8 Top = 204 - Width = 129 - Height = 13 + Width = 146 + Height = 14 Caption = 'Custom snippets directory:' end object lblGUIFont: TLabel Left = 8 Top = 258 - Width = 54 - Height = 13 + Width = 62 + Height = 14 Caption = 'GUI font: *' end object lblGUIFontSize: TLabel - Left = 664 + Left = 640 Top = 258 - Width = 10 - Height = 13 + Width = 12 + Height = 14 Anchors = [akTop, akRight] Caption = 'pt' end object lblTheme: TLabel Left = 8 Top = 285 - Width = 72 - Height = 13 + Width = 85 + Height = 14 Caption = 'Style Theme: *' end object lblIconPack: TLabel Left = 8 Top = 312 - Width = 50 - Height = 13 + Width = 57 + Height = 14 Caption = 'Icon pack:' end object lblWebSearchBaseUrl: TLabel Left = 8 Top = 339 - Width = 102 - Height = 13 + Width = 115 + Height = 14 Hint = 'Used in footer of various message dialogs' Caption = 'Web search base url:' end object chkAutoReconnect: TCheckBox Left = 220 Top = 31 - Width = 475 + Width = 451 Height = 17 Anchors = [akLeft, akTop, akRight] Caption = 'Automatically reconnect to previously opened sessions on startup' @@ -113,7 +110,7 @@ object optionsform: Toptionsform object chkRestoreLastDB: TCheckBox Left = 220 Top = 54 - Width = 475 + Width = 451 Height = 17 Anchors = [akLeft, akTop, akRight] Caption = 'Restore last used database on startup' @@ -136,7 +133,7 @@ object optionsform: Toptionsform Left = 409 Top = 75 Width = 43 - Height = 21 + Height = 22 Enabled = False TabOrder = 4 Text = '1' @@ -146,7 +143,7 @@ object optionsform: Toptionsform Left = 452 Top = 75 Width = 16 - Height = 21 + Height = 22 Associate = editUpdatecheckInterval Enabled = False Max = 999 @@ -157,7 +154,7 @@ object optionsform: Toptionsform object chkUpdateCheckBuilds: TCheckBox Left = 488 Top = 77 - Width = 207 + Width = 183 Height = 17 Anchors = [akLeft, akTop, akRight] Caption = 'Also check for updated nightly builds' @@ -168,7 +165,7 @@ object optionsform: Toptionsform object chkDoStatistics: TCheckBox Left = 220 Top = 100 - Width = 475 + Width = 451 Height = 17 Hint = 'This option, if enabled, will cause HeidiSQL to ping heidisql.co' + @@ -182,7 +179,7 @@ object optionsform: Toptionsform object chkAllowMultiInstances: TCheckBox Left = 220 Top = 8 - Width = 475 + Width = 451 Height = 17 Anchors = [akLeft, akTop, akRight] Caption = 'Allow multiple application instances' @@ -203,8 +200,8 @@ object optionsform: Toptionsform object editMySQLBinaries: TButtonedEdit Left = 220 Top = 174 - Width = 475 - Height = 21 + Width = 451 + Height = 22 Anchors = [akLeft, akTop, akRight] Images = MainForm.VirtualImageListMain RightButton.ImageIndex = 51 @@ -220,8 +217,8 @@ object optionsform: Toptionsform Tag = 1 Left = 220 Top = 228 - Width = 475 - Height = 21 + Width = 451 + Height = 22 Style = csDropDownList Anchors = [akLeft, akTop, akRight] TabOrder = 12 @@ -230,8 +227,8 @@ object optionsform: Toptionsform object editCustomSnippetsDirectory: TButtonedEdit Left = 220 Top = 201 - Width = 475 - Height = 21 + Width = 451 + Height = 22 Anchors = [akLeft, akTop, akRight] Images = MainForm.VirtualImageListMain RightButton.ImageIndex = 51 @@ -247,8 +244,8 @@ object optionsform: Toptionsform Tag = 1 Left = 220 Top = 255 - Width = 362 - Height = 21 + Width = 338 + Height = 22 Style = csDropDownList Anchors = [akLeft, akTop, akRight] TabOrder = 13 @@ -256,10 +253,10 @@ object optionsform: Toptionsform end object editGUIFontSize: TEdit Tag = 1 - Left = 589 + Left = 565 Top = 255 Width = 50 - Height = 21 + Height = 22 Anchors = [akTop, akRight] TabOrder = 14 Text = '8' @@ -267,10 +264,10 @@ object optionsform: Toptionsform end object updownGUIFontSize: TUpDown Tag = 1 - Left = 639 + Left = 615 Top = 255 Width = 16 - Height = 21 + Height = 22 Anchors = [akTop, akRight] Associate = editGUIFontSize Min = 4 @@ -281,7 +278,7 @@ object optionsform: Toptionsform object chkWheelZoom: TCheckBox Left = 220 Top = 123 - Width = 475 + Width = 451 Height = 17 Anchors = [akLeft, akTop, akRight] Caption = 'Use Ctrl+Mousewheel for zooming' @@ -292,8 +289,8 @@ object optionsform: Toptionsform Tag = 1 Left = 220 Top = 282 - Width = 362 - Height = 21 + Width = 338 + Height = 22 Style = csDropDownList Anchors = [akLeft, akTop, akRight] Sorted = True @@ -303,8 +300,8 @@ object optionsform: Toptionsform object comboIconPack: TComboBox Left = 220 Top = 309 - Width = 475 - Height = 21 + Width = 451 + Height = 22 Style = csDropDownList Anchors = [akLeft, akTop, akRight] TabOrder = 18 @@ -313,8 +310,8 @@ object optionsform: Toptionsform object comboWebSearchBaseUrl: TComboBox Left = 220 Top = 336 - Width = 475 - Height = 21 + Width = 451 + Height = 22 Anchors = [akLeft, akTop, akRight] TabOrder = 19 Text = 'comboWebSearchBaseUrl' @@ -330,7 +327,7 @@ object optionsform: Toptionsform 'https://www.google.com/search?q=%query') end object chkThemePreview: TCheckBox - Left = 588 + Left = 564 Top = 284 Width = 97 Height = 17 @@ -345,55 +342,55 @@ object optionsform: Toptionsform ImageIndex = 56 ImageName = 'icons8-index' DesignSize = ( - 700 - 388) + 676 + 406) object Label4: TLabel Left = 8 Top = 11 - Width = 37 - Height = 13 + Width = 42 + Height = 14 Caption = 'Log last' end object lblLogLinesHint: TLabel Left = 297 Top = 11 - Width = 71 - Height = 13 + Width = 82 + Height = 14 Caption = 'lines in SQL log' end object lblLogSnipHint: TLabel Left = 297 Top = 38 - Width = 139 - Height = 13 + Width = 160 + Height = 14 Caption = 'characters (0 = no snipping)' end object lblLogSnip: TLabel Left = 8 Top = 38 - Width = 96 - Height = 13 + Width = 112 + Height = 14 Caption = 'Snip SQL log lines to' end object lblLogLevel: TLabel Left = 8 Top = 95 - Width = 57 - Height = 13 + Width = 65 + Height = 14 Caption = 'Log events:' end object lblQueryHistoryKeepDays: TLabel Left = 438 Top = 247 - Width = 257 - Height = 13 + Width = 241 + Height = 14 Caption = 'days to keep queries before removing them' end object editLogLines: TEdit Left = 220 Top = 8 Width = 53 - Height = 21 + Height = 22 TabOrder = 0 Text = '1' OnChange = Modified @@ -402,7 +399,7 @@ object optionsform: Toptionsform Left = 273 Top = 8 Width = 16 - Height = 21 + Height = 22 Associate = editLogLines Min = 1 Max = 32767 @@ -415,7 +412,7 @@ object optionsform: Toptionsform Left = 273 Top = 35 Width = 16 - Height = 21 + Height = 22 Associate = editLogSnip Max = 32767 Position = 2000 @@ -426,7 +423,7 @@ object optionsform: Toptionsform Left = 220 Top = 35 Width = 53 - Height = 21 + Height = 22 TabOrder = 2 Text = '2000' OnChange = Modified @@ -488,8 +485,8 @@ object optionsform: Toptionsform object editLogDir: TButtonedEdit Left = 361 Top = 62 - Width = 334 - Height = 21 + Width = 310 + Height = 22 Anchors = [akLeft, akTop, akRight] Enabled = False Images = MainForm.VirtualImageListMain @@ -524,7 +521,7 @@ object optionsform: Toptionsform Left = 361 Top = 244 Width = 53 - Height = 21 + Height = 22 Enabled = False TabOrder = 13 Text = '1' @@ -534,7 +531,7 @@ object optionsform: Toptionsform Left = 414 Top = 244 Width = 16 - Height = 21 + Height = 22 Associate = editQueryHistoryKeepDays Enabled = False Min = 1 @@ -552,75 +549,99 @@ object optionsform: Toptionsform TabOrder = 9 OnClick = Modified end + object chkLogTimestamp: TCheckBox + Left = 220 + Top = 292 + Width = 475 + Height = 17 + Caption = 'Add timestamp to all log messages' + TabOrder = 16 + OnClick = Modified + end end object tabSQL: TTabSheet Caption = 'SQL' ImageIndex = 57 ImageName = 'icons8-play' DesignSize = ( - 700 - 388) + 676 + 406) object lblFont: TLabel Left = 8 Top = 11 - Width = 55 - Height = 13 + Width = 63 + Height = 14 Caption = 'Editor font:' end object lblSQLFontSizeUnit: TLabel Left = 446 Top = 11 - Width = 10 - Height = 13 + Width = 12 + Height = 14 Caption = 'pt' end object Label1: TLabel Left = 8 Top = 37 - Width = 51 - Height = 13 + Width = 60 + Height = 14 Caption = 'Tab width:' end object lblMaxQueryResults: TLabel Left = 8 Top = 64 - Width = 101 - Height = 13 + Width = 114 + Height = 14 Caption = 'Maximum result sets:' end object lblSQLColElement: TLabel Left = 8 Top = 186 - Width = 42 - Height = 13 + Width = 49 + Height = 14 Caption = 'Element:' end object lblSQLColBackground: TLabel Left = 220 Top = 280 - Width = 60 - Height = 13 + Width = 68 + Height = 14 Caption = 'Background:' end object lblSQLColForeground: TLabel Left = 220 Top = 233 - Width = 60 - Height = 13 + Width = 67 + Height = 14 Caption = 'Foreground:' end object lblEditorColorsPreset: TLabel Left = 8 Top = 159 - Width = 68 - Height = 13 + Width = 75 + Height = 14 Caption = 'Colors preset:' end + object lblCompletionProposal: TLabel + Left = 8 + Top = 87 + Width = 144 + Height = 14 + Caption = 'Auto completion proposal:' + end + object lblCompletionProposalIntervalUnit: TLabel + Left = 446 + Top = 87 + Width = 15 + Height = 14 + Caption = 'ms' + Enabled = False + end object comboSQLFontName: TComboBox Left = 220 Top = 8 Width = 145 - Height = 21 + Height = 22 Style = csDropDownList TabOrder = 0 OnChange = SQLFontChange @@ -629,7 +650,7 @@ object optionsform: Toptionsform Left = 371 Top = 8 Width = 43 - Height = 21 + Height = 22 TabOrder = 1 Text = '9' OnExit = SQLFontChange @@ -638,7 +659,7 @@ object optionsform: Toptionsform Left = 414 Top = 8 Width = 16 - Height = 21 + Height = 22 Associate = editSQLFontSize Position = 9 TabOrder = 2 @@ -647,9 +668,9 @@ object optionsform: Toptionsform object chkCompletionProposal: TCheckBox Left = 220 Top = 87 - Width = 145 + Width = 101 Height = 17 - Caption = 'Enable autocompletion' + Caption = 'Enable' TabOrder = 8 OnClick = chkCompletionProposalClick end @@ -666,7 +687,7 @@ object optionsform: Toptionsform Left = 220 Top = 34 Width = 41 - Height = 21 + Height = 22 TabOrder = 3 Text = '0' OnExit = SQLFontChange @@ -675,7 +696,7 @@ object optionsform: Toptionsform Left = 261 Top = 34 Width = 16 - Height = 21 + Height = 22 Associate = editSQLTabWidth TabOrder = 4 OnClick = updownSQLFontSizeClick @@ -684,7 +705,7 @@ object optionsform: Toptionsform Left = 220 Top = 61 Width = 41 - Height = 21 + Height = 22 TabOrder = 6 Text = '1' OnChange = Modified @@ -693,7 +714,7 @@ object optionsform: Toptionsform Left = 261 Top = 61 Width = 16 - Height = 21 + Height = 22 Associate = editMaxQueryResults Min = 1 Position = 1 @@ -704,9 +725,9 @@ object optionsform: Toptionsform Left = 220 Top = 183 Width = 145 - Height = 21 + Height = 22 Style = csDropDownList - TabOrder = 13 + TabOrder = 14 OnChange = comboSQLColElementChange end object chkSQLBold: TCheckBox @@ -715,7 +736,7 @@ object optionsform: Toptionsform Width = 61 Height = 17 Caption = 'Bold' - TabOrder = 14 + TabOrder = 15 OnClick = SQLFontChange end object chkSQLItalic: TCheckBox @@ -724,7 +745,7 @@ object optionsform: Toptionsform Width = 50 Height = 17 Caption = 'Italic' - TabOrder = 15 + TabOrder = 16 OnClick = SQLFontChange end object cboxSQLColForeground: TColorBox @@ -734,7 +755,7 @@ object optionsform: Toptionsform Height = 22 NoneColorColor = clNone Style = [cbStandardColors, cbExtendedColors, cbSystemColors, cbIncludeNone, cbCustomColor, cbPrettyNames, cbCustomColors] - TabOrder = 16 + TabOrder = 17 OnChange = SQLFontChange end object cboxSQLColBackground: TColorBox @@ -744,15 +765,15 @@ object optionsform: Toptionsform Height = 22 NoneColorColor = clNone Style = [cbStandardColors, cbExtendedColors, cbSystemColors, cbIncludeNone, cbCustomColor, cbPrettyNames, cbCustomColors] - TabOrder = 17 + TabOrder = 18 OnChange = SQLFontChange end object SynMemoSQLSample: TSynMemo AlignWithMargins = True Left = 371 Top = 156 - Width = 324 - Height = 214 + Width = 300 + Height = 223 Cursor = crHandPoint SingleLineMode = False Anchors = [akLeft, akTop, akRight, akBottom] @@ -761,7 +782,7 @@ object optionsform: Toptionsform Font.Height = -13 Font.Name = 'Courier New' Font.Style = [] - TabOrder = 18 + TabOrder = 19 OnClick = SynMemoSQLSampleClick CodeFolding.GutterShapeSize = 11 CodeFolding.CollapsedLineColor = clGrayText @@ -789,135 +810,159 @@ object optionsform: Toptionsform OnChange = SQLFontChange FontSmoothing = fsmNone end - object chkQueryWarningsMessage: TCheckBox - Left = 220 - Top = 110 - Width = 475 - Height = 17 - Anchors = [akLeft, akTop, akRight] - Caption = 'Show query warnings dialog' - TabOrder = 10 - OnClick = Modified - end object chkAutoUppercase: TCheckBox Left = 220 Top = 133 - Width = 475 + Width = 451 Height = 17 Anchors = [akLeft, akTop, akRight] Caption = 'Auto uppercase reserved words and functions' - TabOrder = 11 + TabOrder = 12 OnClick = Modified end object comboEditorColorsPreset: TComboBox Left = 220 Top = 156 Width = 145 - Height = 21 + Height = 22 Style = csDropDownList ItemIndex = 0 - TabOrder = 12 + TabOrder = 13 Text = 'Current custom settings' OnChange = comboEditorColorsPresetChange Items.Strings = ( 'Current custom settings') end object chkCompletionProposalSearchOnMid: TCheckBox - Left = 432 + Left = 496 Top = 87 - Width = 263 + Width = 175 Height = 17 Anchors = [akLeft, akTop, akRight] - Caption = 'Find matches in middle of entered text' + Caption = 'Find matches in the middle' Enabled = False - TabOrder = 9 + TabOrder = 11 OnClick = Modified end + object editCompletionProposalInterval: TEdit + Left = 371 + Top = 84 + Width = 43 + Height = 22 + Enabled = False + TabOrder = 9 + Text = '0' + OnChange = Modified + end + object updownCompletionProposalInterval: TUpDown + Left = 414 + Top = 84 + Width = 20 + Height = 22 + Associate = editCompletionProposalInterval + Enabled = False + TabOrder = 10 + OnChanging = anyUpDownLimitChanging + end end object tabGridFormatting: TTabSheet Caption = 'Grid formatting' ImageIndex = 41 ImageName = 'icons8-data-grid' DesignSize = ( - 700 - 388) + 676 + 406) object lblMaxColWidth: TLabel Left = 8 Top = 11 - Width = 113 - Height = 13 + Width = 132 + Height = 14 Caption = 'Maximum column width:' end object lblDataFontHint: TLabel Left = 444 Top = 93 - Width = 10 - Height = 13 + Width = 12 + Height = 14 Caption = 'pt' end object lblDataFont: TLabel Left = 8 Top = 92 - Width = 26 - Height = 13 + Width = 29 + Height = 14 Caption = 'Font:' FocusControl = comboDataFontName end object lblMaxTotalRows: TLabel Left = 8 Top = 38 - Width = 144 - Height = 13 + Width = 165 + Height = 14 Caption = 'Rows per page and maximum:' end object lblGridRowsLinecount: TLabel Left = 8 Top = 65 - Width = 122 - Height = 13 + Width = 140 + Height = 14 Caption = 'Lines of text in grid rows:' end object lblGridTextColors: TLabel Left = 8 Top = 119 - Width = 77 - Height = 13 + Width = 87 + Height = 14 Caption = 'Grid text colors:' end object lblNullBackground: TLabel Left = 8 Top = 173 - Width = 87 - Height = 13 + Width = 100 + Height = 14 Hint = 'Use "None" to disable' Caption = 'NULL background:' end object Label2: TLabel Left = 8 Top = 201 - Width = 137 - Height = 13 + Width = 157 + Height = 14 Caption = 'Alternating row background:' end object Label3: TLabel Left = 8 Top = 229 - Width = 112 - Height = 13 + Width = 129 + Height = 14 Caption = 'Same text background:' end object lblLongSortRowNum: TLabel Left = 8 - Top = 303 - Width = 127 - Height = 13 + Top = 285 + Width = 146 + Height = 14 Caption = 'Sort warning on grid rows:' end + object lblRealTrailingZeros: TLabel + Left = 8 + Top = 257 + Width = 153 + Height = 14 + Caption = 'Max decimal zeros for floats:' + end + object lblRealTrailingZerosHint: TLabel + Left = 296 + Top = 257 + Width = 143 + Height = 14 + Caption = 'Set to -1 to keep all zeros' + end object editMaxColWidth: TEdit Left = 220 Top = 8 Width = 42 - Height = 21 + Height = 22 TabOrder = 0 Text = '1' OnChange = Modified @@ -926,7 +971,7 @@ object optionsform: Toptionsform Left = 262 Top = 8 Width = 16 - Height = 21 + Height = 22 Associate = editMaxColWidth Min = 1 Max = 1000 @@ -938,7 +983,7 @@ object optionsform: Toptionsform Left = 220 Top = 89 Width = 145 - Height = 21 + Height = 22 Style = csDropDownList TabOrder = 6 OnChange = DataFontsChange @@ -947,7 +992,7 @@ object optionsform: Toptionsform Left = 371 Top = 89 Width = 42 - Height = 21 + Height = 22 TabOrder = 7 Text = '8' OnChange = DataFontsChange @@ -956,7 +1001,7 @@ object optionsform: Toptionsform Left = 413 Top = 89 Width = 16 - Height = 21 + Height = 22 Associate = editDataFontSize Position = 8 TabOrder = 8 @@ -965,7 +1010,7 @@ object optionsform: Toptionsform Left = 371 Top = 35 Width = 132 - Height = 21 + Height = 22 NumbersOnly = True TabOrder = 3 OnChange = Modified @@ -975,7 +1020,7 @@ object optionsform: Toptionsform Left = 220 Top = 35 Width = 145 - Height = 21 + Height = 22 NumbersOnly = True TabOrder = 2 OnChange = Modified @@ -985,7 +1030,7 @@ object optionsform: Toptionsform Left = 220 Top = 62 Width = 42 - Height = 21 + Height = 22 TabOrder = 4 Text = '1' OnChange = Modified @@ -994,7 +1039,7 @@ object optionsform: Toptionsform Left = 262 Top = 62 Width = 16 - Height = 21 + Height = 22 Associate = editGridRowsLineCount Min = 1 Position = 1 @@ -1005,7 +1050,7 @@ object optionsform: Toptionsform Left = 220 Top = 143 Width = 145 - Height = 21 + Height = 22 Style = csDropDownList TabOrder = 10 OnSelect = comboGridTextColorsSelect @@ -1049,22 +1094,22 @@ object optionsform: Toptionsform end object chkLocalNumberFormat: TCheckBox Left = 220 - Top = 254 - Width = 475 + Top = 310 + Width = 451 Height = 17 Anchors = [akLeft, akTop, akRight] Caption = 'Local number format' - TabOrder = 16 + TabOrder = 20 OnClick = Modified end object chkHintsOnResultTabs: TCheckBox Left = 220 - Top = 277 - Width = 475 + Top = 356 + Width = 451 Height = 17 Anchors = [akLeft, akTop, akRight] Caption = 'Pop up SQL text over result tabs' - TabOrder = 17 + TabOrder = 22 OnClick = Modified end object cboxRowHighlightSameText: TColorBox @@ -1080,48 +1125,84 @@ object optionsform: Toptionsform Left = 220 Top = 116 Width = 145 - Height = 21 + Height = 22 Style = csDropDownList TabOrder = 9 OnSelect = comboGridTextColorsPresetSelect end object editLongSortRowNum: TEdit Left = 220 - Top = 300 + Top = 282 Width = 145 - Height = 21 + Height = 22 TabOrder = 18 Text = '0' end object updownLongSortRowNum: TUpDown Left = 365 - Top = 300 + Top = 282 Width = 16 - Height = 21 + Height = 22 Associate = editLongSortRowNum Max = 2147483647 TabOrder = 19 OnChanging = anyUpDownLimitChanging end + object chkLowercaseHex: TCheckBox + Left = 220 + Top = 333 + Width = 451 + Height = 17 + Anchors = [akLeft, akTop, akRight] + Caption = 'Lowercase hexadecimal' + TabOrder = 21 + end + object editRealTrailingZeros: TEdit + Left = 220 + Top = 254 + Width = 42 + Height = 22 + TabOrder = 16 + Text = '0' + end + object updownRealTrailingZeros: TUpDown + Left = 262 + Top = 254 + Width = 16 + Height = 22 + Associate = editRealTrailingZeros + Min = -1 + TabOrder = 17 + end + object chkShowRowId: TCheckBox + Left = 220 + Top = 379 + Width = 453 + Height = 17 + Anchors = [akLeft, akTop, akRight] + Caption = 'Show static row id column' + TabOrder = 23 + OnClick = Modified + end end object tabDataEditors: TTabSheet Caption = 'Data editors' ImageIndex = 33 ImageName = 'icons8-compose' DesignSize = ( - 700 - 388) + 676 + 406) object lblLineBreakStyle: TLabel - Left = 8 - Top = 188 - Width = 111 - Height = 13 + Left = 3 + Top = 235 + Width = 124 + Height = 14 Caption = 'Default linebreak style:' end object chkEditorBinary: TCheckBox Left = 220 Top = 8 - Width = 475 + Width = 451 Height = 17 Anchors = [akLeft, akTop, akRight] Caption = 'Enable popup BLOB/HEX editor' @@ -1131,7 +1212,7 @@ object optionsform: Toptionsform object chkEditorDatetime: TCheckBox Left = 220 Top = 31 - Width = 475 + Width = 451 Height = 17 Anchors = [akLeft, akTop, akRight] Caption = 'Enable inplace date/time editor' @@ -1141,7 +1222,7 @@ object optionsform: Toptionsform object chkPrefillDateTime: TCheckBox Left = 220 Top = 54 - Width = 475 + Width = 451 Height = 17 Anchors = [akLeft, akTop, akRight] Caption = 'Prefill empty date/time fields with current date/time' @@ -1151,7 +1232,7 @@ object optionsform: Toptionsform object chkEditorEnum: TCheckBox Left = 220 Top = 77 - Width = 475 + Width = 451 Height = 17 Anchors = [akLeft, akTop, akRight] Caption = 'Enable ENUM pulldown editor' @@ -1161,7 +1242,7 @@ object optionsform: Toptionsform object chkEditorSet: TCheckBox Left = 220 Top = 100 - Width = 475 + Width = 451 Height = 17 Anchors = [akLeft, akTop, akRight] Caption = 'Enable SET checkbox editor' @@ -1170,31 +1251,49 @@ object optionsform: Toptionsform end object chkReuseEditorConfiguration: TCheckBox Left = 220 - Top = 139 - Width = 475 + Top = 163 + Width = 451 Height = 17 Anchors = [akLeft, akTop, akRight] Caption = 'Remember filters, sorting and column selection across sessions' - TabOrder = 5 + TabOrder = 6 OnClick = Modified end object chkForeignDropDown: TCheckBox Left = 220 - Top = 162 - Width = 475 + Top = 186 + Width = 451 Height = 17 Anchors = [akLeft, akTop, akRight] Caption = 'Show values in foreign key columns' - TabOrder = 6 + TabOrder = 7 OnClick = Modified end object comboLineBreakStyle: TComboBox Left = 220 - Top = 185 + Top = 232 Width = 145 - Height = 21 + Height = 22 Style = csDropDownList - TabOrder = 7 + TabOrder = 9 + OnClick = Modified + end + object chkColumnHeaderClick: TCheckBox + Left = 220 + Top = 140 + Width = 475 + Height = 17 + Caption = 'Click on column headers toggles sorting' + TabOrder = 5 + OnClick = Modified + end + object chkIncrementalSearch: TCheckBox + Left = 220 + Top = 209 + Width = 469 + Height = 17 + Caption = 'Incremental search through typing' + TabOrder = 8 OnClick = Modified end end @@ -1203,19 +1302,19 @@ object optionsform: Toptionsform ImageIndex = 13 ImageName = 'icons8-lightning-bolt-100' DesignSize = ( - 700 - 388) + 676 + 406) object lblShortcut1: TLabel Left = 306 Top = 64 - Width = 45 - Height = 13 + Width = 52 + Height = 14 Caption = 'Shortcut:' end object lblShortcutHint: TLabel Left = 306 Top = 3 - Width = 391 + Width = 367 Height = 55 Anchors = [akLeft, akTop, akRight] AutoSize = False @@ -1225,17 +1324,35 @@ object optionsform: Toptionsform object lblShortcut2: TLabel Left = 306 Top = 108 - Width = 98 - Height = 13 + Width = 111 + Height = 14 Caption = 'Secondary shortcut:' end object TreeShortcutItems: TVirtualStringTree Left = 0 - Top = 0 + Top = 32 Width = 300 - Height = 388 - Align = alLeft + Height = 374 + Anchors = [akLeft, akTop, akBottom] + Colors.BorderColor = 15987699 + Colors.DisabledColor = clGray + Colors.DropMarkColor = 15385233 + Colors.DropTargetColor = 15385233 + Colors.DropTargetBorderColor = 15385233 + Colors.FocusedSelectionColor = 15385233 + Colors.FocusedSelectionBorderColor = 15385233 + Colors.GridLineColor = 15987699 + Colors.HeaderHotColor = clBlack + Colors.HotColor = clBlack + Colors.SelectionRectangleBlendColor = 15385233 + Colors.SelectionRectangleBorderColor = 15385233 + Colors.SelectionTextColor = clBlack + Colors.TreeLineColor = 9471874 + Colors.UnfocusedColor = clGray + Colors.UnfocusedSelectionColor = clWhite + Colors.UnfocusedSelectionBorderColor = clWhite Header.AutoSizeIndex = 0 + Header.Height = 14 Header.MainColumn = -1 Images = MainForm.VirtualImageListMain TabOrder = 0 @@ -1245,47 +1362,73 @@ object optionsform: Toptionsform OnGetNodeDataSize = TreeShortcutItemsGetNodeDataSize OnInitChildren = TreeShortcutItemsInitChildren OnInitNode = TreeShortcutItemsInitNode + Touch.InteractiveGestures = [igPan, igPressAndTap] + Touch.InteractiveGestureOptions = [igoPanSingleFingerHorizontal, igoPanSingleFingerVertical, igoPanInertia, igoPanGutter, igoParentPassthrough] Columns = <> end - object HotKey1: THotKey - Left = 306 - Top = 83 - Width = 279 - Height = 19 - Anchors = [akLeft, akTop, akRight] - HotKey = 0 - Modifiers = [] + object btnRemoveHotKey1: TButton + Left = 592 + Top = 80 + Width = 81 + Height = 25 + Anchors = [akTop, akRight] + Caption = 'Remove' + ImageIndex = 26 + Images = MainForm.VirtualImageListMain TabOrder = 1 - OnChange = HotKey1Change - OnEnter = HotKeyEnter - OnExit = HotKeyExit + OnClick = btnRemoveHotKeyClick end - object HotKey2: THotKey - Left = 306 - Top = 127 - Width = 279 - Height = 19 - Anchors = [akLeft, akTop, akRight] - HotKey = 0 - InvalidKeys = [] - Modifiers = [] + object btnRemoveHotKey2: TButton + Left = 592 + Top = 144 + Width = 81 + Height = 25 + Anchors = [akTop, akRight] + Caption = 'Remove' + ImageIndex = 26 + Images = MainForm.VirtualImageListMain TabOrder = 2 - OnChange = HotKey2Change - OnEnter = HotKeyEnter - OnExit = HotKeyExit + OnClick = btnRemoveHotKeyClick + end + object editShortcutsFilter: TButtonedEdit + Left = 0 + Top = 4 + Width = 300 + Height = 22 + Images = MainForm.VirtualImageListMain + RightButton.ImageIndex = 193 + RightButton.Visible = True + TabOrder = 3 + TextHint = 'Filter' + OnChange = editShortcutsFilterChange + OnRightButtonClick = editShortcutsFilterRightButtonClick end end object tabFiles: TTabSheet - Caption = 'Files' + Caption = 'Files and tabs' ImageIndex = 10 ImageName = 'icons8-save-button-100' DesignSize = ( - 700 - 388) + 676 + 406) + object Label5: TLabel + Left = 8 + Top = 103 + Width = 148 + Height = 14 + Caption = 'Grayscale inactive tab icons' + end + object lblReformatter: TLabel + Left = 8 + Top = 131 + Width = 70 + Height = 14 + Caption = 'Reformatter:' + end object chkAskFileSave: TCheckBox Left = 220 Top = 8 - Width = 475 + Width = 451 Height = 17 Anchors = [akLeft, akTop, akRight] Caption = 'Prompt to save modified files on tab close' @@ -1297,18 +1440,60 @@ object optionsform: Toptionsform object chkRestoreTabs: TCheckBox Left = 220 Top = 31 - Width = 475 + Width = 451 Height = 17 Anchors = [akLeft, akTop, akRight] Caption = 'Reopen previously used SQL files and unsaved content in tabs *' TabOrder = 1 OnClick = Modified end + object chkTabCloseOnDoubleClick: TCheckBox + Left = 220 + Top = 54 + Width = 477 + Height = 17 + Caption = 'Close tab on doubleclick' + TabOrder = 2 + OnClick = Modified + end + object chkTabCloseOnMiddleClick: TCheckBox + Left = 220 + Top = 77 + Width = 453 + Height = 17 + Anchors = [akLeft, akTop, akRight] + Caption = 'Close tab on middleclick' + TabOrder = 3 + OnClick = Modified + end + object comboTabIconsGrayscaleMode: TComboBox + Left = 220 + Top = 100 + Width = 451 + Height = 22 + Style = csDropDownList + Anchors = [akLeft, akTop, akRight] + TabOrder = 4 + OnClick = Modified + Items.Strings = ( + 'Color icons on all tabs' + 'Grayscale icons on inactive query tabs only' + 'Grayscale icons on every inactive tab') + end + object comboReformatter: TComboBox + Left = 220 + Top = 128 + Width = 451 + Height = 22 + Style = csDropDownList + Anchors = [akLeft, akTop, akRight] + TabOrder = 5 + end end end object btnCancel: TButton - Left = 561 - Top = 429 + Left = 537 + Top = 449 Width = 75 Height = 25 Anchors = [akRight, akBottom] @@ -1318,8 +1503,8 @@ object optionsform: Toptionsform TabOrder = 2 end object btnOK: TButton - Left = 481 - Top = 429 + Left = 457 + Top = 449 Width = 75 Height = 25 Anchors = [akRight, akBottom] @@ -1330,8 +1515,8 @@ object optionsform: Toptionsform OnClick = Apply end object btnApply: TButton - Left = 641 - Top = 429 + Left = 617 + Top = 449 Width = 75 Height = 25 Anchors = [akRight, akBottom] @@ -1342,7 +1527,7 @@ object optionsform: Toptionsform end object btnRestoreDefaults: TButton Left = 8 - Top = 429 + Top = 449 Width = 177 Height = 25 Anchors = [akLeft, akBottom] @@ -1355,8 +1540,8 @@ object optionsform: Toptionsform Options.AutoDetectLineLimit = 0 Options.Visible = False SQLDialect = sqlMySQL - Left = 432 - Top = 352 + Left = 584 + Top = 392 end object SynSQLSyn_Dark: TSynSQLSyn Options.AutoDetectEnabled = False @@ -1375,8 +1560,8 @@ object optionsform: Toptionsform TableNameAttri.Foreground = 16755327 VariableAttri.Foreground = clPurple SQLDialect = sqlMySQL - Left = 200 - Top = 352 + Left = 592 + Top = 168 end object SynSQLSyn_Light: TSynSQLSyn Options.AutoDetectEnabled = False @@ -1395,8 +1580,8 @@ object optionsform: Toptionsform TableNameAttri.Foreground = clFuchsia VariableAttri.Foreground = clPurple SQLDialect = sqlMySQL - Left = 120 - Top = 352 + Left = 592 + Top = 112 end object SynSQLSyn_Black: TSynSQLSyn Options.AutoDetectEnabled = False @@ -1415,8 +1600,8 @@ object optionsform: Toptionsform TableNameAttri.Foreground = clBlack VariableAttri.Foreground = clBlack SQLDialect = sqlMySQL - Left = 196 - Top = 404 + Left = 588 + Top = 228 end object SynSQLSyn_White: TSynSQLSyn Options.AutoDetectEnabled = False @@ -1435,8 +1620,8 @@ object optionsform: Toptionsform TableNameAttri.Foreground = clWhite VariableAttri.Foreground = clWhite SQLDialect = sqlMySQL - Left = 284 - Top = 404 + Left = 588 + Top = 284 end object SynSQLSyn_Material: TSynSQLSyn Options.AutoDetectEnabled = False @@ -1455,7 +1640,7 @@ object optionsform: Toptionsform TableNameAttri.Foreground = 6911735 VariableAttri.Foreground = 7064575 SQLDialect = sqlMySQL - Left = 320 - Top = 404 + Left = 584 + Top = 340 end end diff --git a/source/options.pas b/source/preferences.pas similarity index 74% rename from source/options.pas rename to source/preferences.pas index f077d91ec..8a6c15f53 100644 --- a/source/options.pas +++ b/source/preferences.pas @@ -1,4 +1,4 @@ -unit options; +unit preferences; // ------------------------------------- @@ -9,11 +9,12 @@ interface uses - Windows, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, - StdCtrls, ComCtrls, ExtCtrls, SynEditHighlighter, SynHighlighterSQL, - SynEdit, SynMemo, VirtualTrees, SynEditKeyCmds, ActnList, StdActns, Menus, - dbstructures, gnugettext, Vcl.Themes, Vcl.Styles, SynRegExpr, Generics.Collections, - Vcl.ImageCollection, extra_controls, theme_preview, Vcl.Buttons; + Winapi.Windows, System.SysUtils, System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, + Vcl.StdCtrls, Vcl.ComCtrls, Vcl.ExtCtrls, SynEditHighlighter, SynHighlighterSQL, + SynEdit, SynMemo, VirtualTrees, SynEditKeyCmds, Vcl.ActnList, Vcl.StdActns, Vcl.Menus, + dbstructures, gnugettext, Vcl.Themes, Vcl.Styles, SynRegExpr, System.Generics.Collections, + Vcl.ImageCollection, extra_controls, theme_preview, reformatter, Vcl.Buttons, System.Actions, + VirtualTrees.BaseAncestorVCL, VirtualTrees.BaseTree, VirtualTrees.AncestorVCL, VirtualTrees.Types; type TShortcutItemData = record @@ -31,7 +32,8 @@ TGridColorsPreset = class end; TGridColorsPresetList = TObjectList; - Toptionsform = class(TExtForm) + TfrmPreferences = class(TExtForm) + editShortcutsFilter: TButtonedEdit; pagecontrolMain: TPageControl; tabMisc: TTabSheet; btnCancel: TButton; @@ -147,7 +149,6 @@ Toptionsform = class(TExtForm) Label3: TLabel; cboxRowHighlightSameText: TColorBox; chkWheelZoom: TCheckBox; - chkQueryWarningsMessage: TCheckBox; chkAutoUppercase: TCheckBox; lblTheme: TLabel; comboTheme: TComboBox; @@ -171,8 +172,29 @@ Toptionsform = class(TExtForm) lblLongSortRowNum: TLabel; editLongSortRowNum: TEdit; updownLongSortRowNum: TUpDown; - HotKey1: THotKey; - HotKey2: THotKey; + chkLowercaseHex: TCheckBox; + chkTabCloseOnDoubleClick: TCheckBox; + lblRealTrailingZeros: TLabel; + editRealTrailingZeros: TEdit; + updownRealTrailingZeros: TUpDown; + lblRealTrailingZerosHint: TLabel; + chkLogTimestamp: TCheckBox; + lblCompletionProposal: TLabel; + editCompletionProposalInterval: TEdit; + updownCompletionProposalInterval: TUpDown; + lblCompletionProposalIntervalUnit: TLabel; + chkColumnHeaderClick: TCheckBox; + chkIncrementalSearch: TCheckBox; + chkShowRowId: TCheckBox; + chkTabCloseOnMiddleClick: TCheckBox; + btnRemoveHotKey1: TButton; + btnRemoveHotKey2: TButton; + comboTabIconsGrayscaleMode: TComboBox; + Label5: TLabel; + lblReformatter: TLabel; + comboReformatter: TComboBox; + procedure editShortcutsFilterRightButtonClick(Sender: TObject); + procedure editShortcutsFilterChange(Sender: TObject); procedure FormShow(Sender: TObject); procedure Modified(Sender: TObject); procedure Apply(Sender: TObject); @@ -213,11 +235,10 @@ Toptionsform = class(TExtForm) procedure FormClose(Sender: TObject; var Action: TCloseAction); procedure comboGridTextColorsPresetSelect(Sender: TObject); procedure comboThemeSelect(Sender: TObject); - procedure FormDestroy(Sender: TObject); procedure chkThemePreviewClick(Sender: TObject); procedure chkCompletionProposalClick(Sender: TObject); - procedure HotKey1Change(Sender: TObject); - procedure HotKey2Change(Sender: TObject); + procedure HotKeyChange(Sender: TObject); + procedure btnRemoveHotKeyClick(Sender: TObject); private { Private declarations } FWasModified: Boolean; @@ -228,13 +249,19 @@ Toptionsform = class(TExtForm) FRestartOptionTouched: Boolean; FRestartOptionApplied: Boolean; FThemePreview: TfrmThemePreview; + FHotKey1: TExtSynHotKey; + FHotKey2: TExtSynHotKey; procedure InitLanguages; procedure SelectDirectory(Sender: TObject; NewFolderButton: Boolean); + function EnsureShortcutIsUnused(RequestShortcut: TShortCut): Boolean; public { Public declarations } end; +var + frmPreferences: TfrmPreferences; + function EnumFixedProc(lpelf: PEnumLogFont; lpntm: PNewTextMetric; FontType: Integer; Data: LPARAM): Integer; stdcall; @@ -243,7 +270,7 @@ implementation {$R *.DFM} -procedure Toptionsform.Modified(Sender: TObject); +procedure TfrmPreferences.Modified(Sender: TObject); begin // Modified btnApply.Enabled := True; @@ -254,7 +281,7 @@ procedure Toptionsform.Modified(Sender: TObject); end; -procedure Toptionsform.pagecontrolMainChanging(Sender: TObject; +procedure TfrmPreferences.pagecontrolMainChanging(Sender: TObject; var AllowChange: Boolean); begin // Remember modification state. First tab switch leads TEdit's with TUpDown @@ -263,17 +290,18 @@ procedure Toptionsform.pagecontrolMainChanging(Sender: TObject; end; -procedure Toptionsform.pagecontrolMainChange(Sender: TObject); +procedure TfrmPreferences.pagecontrolMainChange(Sender: TObject); begin // See OnChanging procedure btnApply.Enabled := FWasModified; + TExtForm.PageControlTabHighlight(pagecontrolMain); end; {** Apply settings to registry and mainform } -procedure Toptionsform.Apply(Sender: TObject); +procedure TfrmPreferences.Apply(Sender: TObject); var i: Integer; Attri: TSynHighlighterAttributes; @@ -287,7 +315,6 @@ procedure Toptionsform.Apply(Sender: TObject); AppSettings.WriteBool(asAutoReconnect, chkAutoReconnect.Checked); AppSettings.WriteBool(asAllowMultipleInstances, chkAllowMultiInstances.Checked); AppSettings.WriteBool(asRestoreLastUsedDB, chkRestoreLastDB.Checked); - AppSettings.WriteBool(asQueryWarningsMessage, chkQueryWarningsMessage.Checked); AppSettings.WriteString(asFontName, comboSQLFontName.Text); AppSettings.WriteInt(asFontSize, updownSQLFontSize.Position); AppSettings.WriteInt(asTabWidth, updownSQLTabWidth.Position); @@ -303,6 +330,7 @@ procedure Toptionsform.Apply(Sender: TObject); AppSettings.WriteBool(asQueryHistoryEnabled, chkQueryHistory.Checked); AppSettings.WriteInt(asQueryHistoryKeepDays, updownQueryHistoryKeepDays.Position); AppSettings.WriteBool(asLogHorizontalScrollbar, chkHorizontalScrollbar.Checked); + AppSettings.WriteBool(asLogTimestamp, chkLogTimestamp.Checked); for i:=0 to SynSQLSynSQLSample.AttrCount - 1 do begin Attri := SynSQLSynSQLSample.Attribute[i]; AppSettings.WriteInt(asHighlighterForeground, Attri.Foreground, Attri.Name); @@ -320,11 +348,9 @@ procedure Toptionsform.Apply(Sender: TObject); AppSettings.WriteString(asDataFontName, comboDataFontName.Text); AppSettings.WriteInt(asDataFontSize, updownDataFontSize.Position); AppSettings.WriteBool(asLogToFile, chkLogToFile.Checked); - if not RunningAsUwp then begin - AppSettings.WriteBool(asUpdatecheck, chkUpdatecheck.Checked); - AppSettings.WriteBool(asUpdatecheckBuilds, chkUpdatecheckBuilds.Checked); - AppSettings.WriteInt(asUpdatecheckInterval, updownUpdatecheckInterval.Position); - end; + AppSettings.WriteBool(asUpdatecheck, chkUpdatecheck.Checked); + AppSettings.WriteBool(asUpdatecheckBuilds, chkUpdatecheckBuilds.Checked); + AppSettings.WriteInt(asUpdatecheckInterval, updownUpdatecheckInterval.Position); AppSettings.WriteBool(asDoUsageStatistics, chkDoStatistics.Checked); AppSettings.WriteBool(asWheelZoom, chkWheelZoom.Checked); AppSettings.WriteBool(asDisplayBars, chkColorBars.Checked); @@ -361,9 +387,12 @@ procedure Toptionsform.Apply(Sender: TObject); AppSettings.WriteInt(asRowBackgroundEven, cboxRowBackgroundEven.Selected); AppSettings.WriteInt(asRowBackgroundOdd, cboxRowBackgroundOdd.Selected); AppSettings.WriteInt(asHightlightSameTextBackground, cboxRowHighlightSameText.Selected); + AppSettings.WriteInt(asRealTrailingZeros, updownRealTrailingZeros.Position); + AppSettings.WriteInt(asQueryGridLongSortRowNum, updownLongSortRowNum.Position); AppSettings.WriteBool(asDataLocalNumberFormat, chkLocalNumberFormat.Checked); + AppSettings.WriteBool(asLowercaseHex, chkLowercaseHex.Checked); AppSettings.WriteBool(asHintsOnResultTabs, chkHintsOnResultTabs.Checked); - AppSettings.WriteInt(asQueryGridLongSortRowNum, updownLongSortRowNum.Position); + AppSettings.WriteBool(asShowRowId, chkShowRowId.Checked); // Editor Configuration AppSettings.WriteBool(asFieldEditorBinary, chkEditorBinary.Checked); @@ -371,8 +400,10 @@ procedure Toptionsform.Apply(Sender: TObject); AppSettings.WriteBool(asFieldEditorDatetimePrefill, chkPrefillDatetime.Checked); AppSettings.WriteBool(asFieldEditorEnum, chkEditorEnum.Checked); AppSettings.WriteBool(asFieldEditorSet, chkEditorSet.Checked); + AppSettings.WriteBool(asColumnHeaderClick, chkColumnHeaderClick.Checked); AppSettings.WriteBool(asReuseEditorConfiguration, chkReuseEditorConfiguration.Checked); AppSettings.WriteBool(asForeignDropDown, chkForeignDropDown.Checked); + AppSettings.WriteBool(asIncrementalSearch, chkIncrementalSearch.Checked); case comboLineBreakStyle.ItemIndex of 1: AppSettings.WriteInt(asLineBreakStyle, Integer(lbsUnix)); 2: AppSettings.WriteInt(asLineBreakStyle, Integer(lbsMac)); @@ -380,6 +411,7 @@ procedure Toptionsform.Apply(Sender: TObject); end; AppSettings.WriteBool(asCompletionProposal, chkCompletionProposal.Checked); + AppSettings.WriteInt(asCompletionProposalInterval, updownCompletionProposalInterval.Position); AppSettings.WriteBool(asCompletionProposalSearchOnMid, chkCompletionProposalSearchOnMid.Checked); AppSettings.WriteBool(asAutoUppercase, chkAutoUppercase.Checked); AppSettings.WriteBool(asTabsToSpaces, chkTabsToSpaces.Checked); @@ -409,14 +441,18 @@ procedure Toptionsform.Apply(Sender: TObject); // Populate SynMemo settings to all instances Mainform.SetupSynEditors; - // Files + // Files and tabs AppSettings.WriteBool(asPromptSaveFileOnTabClose, chkAskFileSave.Checked); AppSettings.WriteBool(asRestoreTabs, chkRestoreTabs.Checked); + AppSettings.WriteBool(asTabCloseOnDoubleClick, chkTabCloseOnDoubleClick.Checked); + AppSettings.WriteBool(asTabCloseOnMiddleClick, chkTabCloseOnMiddleClick.Checked); + AppSettings.WriteInt(asTabIconsGrayscaleMode, comboTabIconsGrayscaleMode.ItemIndex); + AppSettings.WriteInt(asReformatterNoDialog, comboReformatter.ItemIndex); // Set relevant properties in mainform MainForm.ApplyFontToGrids; MainForm.PrepareImageList; - + MainForm.SynCompletionProposal.TimerInterval := updownCompletionProposalInterval.Position; Mainform.LogToFile := chkLogToFile.Checked; MainForm.actLogHorizontalScrollbar.Checked := chkHorizontalScrollbar.Checked; MainForm.actLogHorizontalScrollbar.OnExecute(MainForm.actLogHorizontalScrollbar); @@ -458,17 +494,20 @@ function EnumFixedProc( end; -procedure Toptionsform.FormClose(Sender: TObject; var Action: TCloseAction); +procedure TfrmPreferences.FormClose(Sender: TObject; var Action: TCloseAction); begin if FRestartOptionApplied then begin MessageDialog(f_('You should restart %s to apply changed critical settings, and to prevent unexpected behaviour.', [APPNAME]), mtInformation, [mbOk]); end; + MainForm.ActionList1.State := asNormal; + AppSettings.WriteIntDpiAware(asPreferencesWindowWidth, Self, Width); + AppSettings.WriteIntDpiAware(asPreferencesWindowHeight, Self, Height); end; -procedure Toptionsform.FormCreate(Sender: TObject); +procedure TfrmPreferences.FormCreate(Sender: TObject); const // Define grid colors as constants, for easy assignment GridColorsLight: TGridTextColors = ($00FF0000, $00FF0048, $00008000, $00800080, $00000080, $00808000, $00008080); @@ -483,15 +522,13 @@ procedure Toptionsform.FormCreate(Sender: TObject); Name: String; GridColorsPreset: TGridColorsPreset; IconPack: String; + Reformatter: TfrmReformatter; begin HasSizeGrip := True; - Width := AppSettings.ReadInt(asPreferencesWindowWidth); - Height := AppSettings.ReadInt(asPreferencesWindowHeight); - // Misecllaneous // Hide browse button on Wine, as the browse dialog returns Windows-style paths, while we need a Unix path - if MainForm.IsWine then begin + if IsWine then begin editMySQLBinaries.RightButton.Visible := False; editMySQLBinaries.OnDblClick := nil; end; @@ -499,14 +536,19 @@ procedure Toptionsform.FormCreate(Sender: TObject); InitLanguages; comboAppLanguage.Items.AddStrings(FLanguages); - comboGUIFont.Items.Assign(Screen.Fonts); - comboGUIFont.Items.Insert(0, '<'+_('Default system font')+'>'); + comboGUIFont.Items.Clear; + comboGUIFont.Items.Add('<'+_('Default system font')+'>'); + for i:=0 to Screen.Fonts.Count-1 do begin + if not Screen.Fonts[i].StartsWith('@') then + comboGUIFont.Items.Add(Screen.Fonts[i]); + end; Styles := TStyleManager.StyleNames; for i:=Low(Styles) to High(Styles) do begin comboTheme.Items.Add(Styles[i]); end; comboTheme.ItemIndex := comboTheme.Items.IndexOf(AppSettings.GetDefaultString(asTheme)); + lblTheme.Caption := lblTheme.Caption + ' ('+UpperCase(_('deprecated'))+')'; // Populate icon pack dropdown from image collections on main form comboIconPack.Items.Clear; @@ -526,18 +568,20 @@ procedure Toptionsform.FormCreate(Sender: TObject); // SQL EnumFontFamilies(Canvas.Handle, nil, @EnumFixedProc, LPARAM(Pointer(comboSQLFontName.Items))); comboSQLFontName.Sorted := True; - SynMemoSQLSample.Text := 'SELECT DATE_SUB(NOW(), INTERVAL 1 DAY),' + CRLF + - #9'''String literal'' AS lit' + CRLF + - 'FROM tableA AS ta' + CRLF + - 'WHERE `columnA` IS NULL;' + CRLF + - CRLF + - '-- A comment' + CRLF + - '# Old style comment' + CRLF + - '/* Multi line comment */' + CRLF + - CRLF + - 'CREATE TABLE /*!32312 IF NOT EXISTS*/ tableB (' + CRLF + - #9'id INT,' + CRLF + - #9'name VARCHAR(30) DEFAULT "standard"' + CRLF + + updownCompletionProposalInterval.Min := 0; + updownCompletionProposalInterval.Max := MaxInt; + SynMemoSQLSample.Text := 'SELECT DATE_SUB(NOW(), INTERVAL 1 DAY),' + sLineBreak + + CodeIndent + '''String literal'' AS lit' + sLineBreak + + 'FROM tableA AS ta' + sLineBreak + + 'WHERE `columnA` IS NULL;' + sLineBreak + + sLineBreak + + '-- A comment' + sLineBreak + + '# Old style comment' + sLineBreak + + '/* Multi line comment */' + sLineBreak + + sLineBreak + + 'CREATE TABLE /*!32312 IF NOT EXISTS*/ tableB (' + sLineBreak + + CodeIndent + 'id INT,' + sLineBreak + + CodeIndent + 'name VARCHAR(30) DEFAULT "standard"' + sLineBreak + ')'; SynSQLSynSQLSample.TableNames.CommaText := 'tableA,tableB'; for i:=0 to SynSQLSynSQLSample.AttrCount - 1 do begin @@ -597,6 +641,42 @@ procedure Toptionsform.FormCreate(Sender: TObject); end; // Shortcuts + FHotKey1 := TExtSynHotKey.Create(Self); + FHotKey1.Parent := tabShortcuts; + FHotKey1.Left := lblShortcut1.Left; + FHotKey1.Top := lblShortcut1.Top + lblShortcut1.Height + 4; + FHotKey1.Width := tabShortcuts.Width - FHotKey1.Left - btnRemoveHotKey1.Width - 4 - 4; + FHotKey1.Height := editDataFontSize.Height; + FHotKey1.Anchors := [akLeft, akTop, akRight]; + FHotKey1.HotKey := 0; + FHotKey1.InvalidKeys := []; + FHotKey1.Modifiers := []; + FHotKey1.Enabled := False; + FHotKey1.OnChange := HotKeyChange; + FHotKey1.OnEnter := HotKeyEnter; + FHotKey1.OnExit := HotKeyExit; + btnRemoveHotKey1.Left := FHotKey1.Left + FHotKey1.Width + 4; + btnRemoveHotKey1.Top := FHotKey1.Top; + btnRemoveHotKey1.Enabled := False; + + FHotKey2 := TExtSynHotKey.Create(Self); + FHotKey2.Parent := tabShortcuts; + FHotKey2.Left := lblShortcut2.Left; + FHotKey2.Top := lblShortcut2.Top + lblShortcut2.Height + 4; + FHotKey2.Width := tabShortcuts.Width - FHotKey2.Left - btnRemoveHotKey2.Width - 4 - 4; + FHotKey2.Height := editDataFontSize.Height; + FHotKey2.Anchors := [akLeft, akTop, akRight]; + FHotKey2.HotKey := 0; + FHotKey2.InvalidKeys := []; + FHotKey2.Modifiers := []; + FHotKey2.Enabled := False; + FHotKey2.OnChange := HotKeyChange; + FHotKey2.OnEnter := HotKeyEnter; + FHotKey2.OnExit := HotKeyExit; + btnRemoveHotKey2.Left := FHotKey2.Left + FHotKey2.Width + 4; + btnRemoveHotKey2.Top := FHotKey2.Top; + btnRemoveHotKey2.Enabled := False; + FShortcutCategories := TStringList.Create; for i:=0 to Mainform.ActionList1.ActionCount-1 do begin if FShortcutCategories.IndexOf(Mainform.ActionList1.Actions[i].Category) = -1 then @@ -605,36 +685,32 @@ procedure Toptionsform.FormCreate(Sender: TObject); FShortcutCategories.Add(_('SQL editing')); TreeShortcutItems.RootNodeCount := FShortcutCategories.Count; comboLineBreakStyle.Items := Explode(',', _('Windows linebreaks')+','+_('UNIX linebreaks')+','+_('Mac OS linebreaks')); -end; - -procedure Toptionsform.FormDestroy(Sender: TObject); -begin - AppSettings.WriteInt(asPreferencesWindowWidth, Width); - AppSettings.WriteInt(asPreferencesWindowHeight, Height); + comboReformatter.Items.Add(_('Always ask')); + Reformatter := TfrmReformatter.Create(Self); + comboReformatter.Items.AddStrings(Reformatter.grpReformatter.Items); + Reformatter.Free; end; -procedure Toptionsform.FormShow(Sender: TObject); + +procedure TfrmPreferences.FormShow(Sender: TObject); var LangCode, GUIFont: String; i: Integer; begin - screen.Cursor := crHourGlass; + Screen.Cursor := crHourGlass; + + Width := AppSettings.ReadIntDpiAware(asPreferencesWindowWidth, Self); + Height := AppSettings.ReadIntDpiAware(asPreferencesWindowHeight, Self); // Read and display values chkAutoReconnect.Checked := AppSettings.ReadBool(asAutoReconnect);; chkAllowMultiInstances.Checked := AppSettings.ReadBool(asAllowMultipleInstances); chkRestoreLastDB.Checked := AppSettings.ReadBool(asRestoreLastUsedDB); - if RunningAsUwp then begin - chkUpdatecheck.Enabled := False; - chkUpdatecheckBuilds.Enabled := False; - updownUpdatecheckInterval.Enabled := False; - end else begin - chkUpdatecheck.Checked := AppSettings.ReadBool(asUpdatecheck); - chkUpdatecheckBuilds.Checked := AppSettings.ReadBool(asUpdatecheckBuilds); - updownUpdatecheckInterval.Position := AppSettings.ReadInt(asUpdatecheckInterval); - chkUpdatecheckClick(Sender); - end; + chkUpdatecheck.Checked := AppSettings.ReadBool(asUpdatecheck); + chkUpdatecheckBuilds.Checked := AppSettings.ReadBool(asUpdatecheckBuilds); + updownUpdatecheckInterval.Position := AppSettings.ReadInt(asUpdatecheckInterval); + chkUpdatecheckClick(Sender); chkDoStatistics.Checked := AppSettings.ReadBool(asDoUsageStatistics); chkWheelZoom.Checked := AppSettings.ReadBool(asWheelZoom); chkColorBars.Checked := AppSettings.ReadBool(asDisplayBars); @@ -659,7 +735,6 @@ procedure Toptionsform.FormShow(Sender: TObject); comboTheme.ItemIndex := comboTheme.Items.IndexOf(AppSettings.ReadString(asTheme)); comboIconPack.ItemIndex := comboIconPack.Items.IndexOf(AppSettings.ReadString(asIconPack)); comboWebSearchBaseUrl.Text := AppSettings.ReadString(asWebSearchBaseUrl); - chkQueryWarningsMessage.Checked := AppSettings.ReadBool(asQueryWarningsMessage); // Logging updownLogLines.Position := AppSettings.ReadInt(asLogsqlnum); @@ -675,6 +750,7 @@ procedure Toptionsform.FormShow(Sender: TObject); chkQueryHistory.Checked := AppSettings.ReadBool(asQueryHistoryEnabled); updownQueryHistoryKeepDays.Position := AppSettings.ReadInt(asQueryHistoryKeepDays); chkHorizontalScrollbar.Checked := AppSettings.ReadBool(asLogHorizontalScrollbar); + chkLogTimestamp.Checked := AppSettings.ReadBool(asLogTimestamp); // Default column width in grids: updownMaxColWidth.Position := AppSettings.ReadInt(asMaxColWidth); @@ -683,18 +759,23 @@ procedure Toptionsform.FormShow(Sender: TObject); updownGridRowsLineCount.Position := AppSettings.ReadInt(asGridRowLineCount); // SQL: - Mainform.SetupSynEditors; + Mainform.SetupSynEditor(SynMemoSQLSample); comboSQLFontName.ItemIndex := comboSQLFontName.Items.IndexOf(SynMemoSQLSample.Font.Name); updownSQLFontSize.Position := SynMemoSQLSample.Font.Size; updownSQLTabWidth.Position := SynMemoSQLSample.TabWidth; chkCompletionProposal.Checked := AppSettings.ReadBool(asCompletionProposal); + updownCompletionProposalInterval.Position := AppSettings.ReadInt(asCompletionProposalInterval); chkCompletionProposalSearchOnMid.Checked := AppSettings.ReadBool(asCompletionProposalSearchOnMid); chkAutoUppercase.Checked := AppSettings.ReadBool(asAutoUppercase); chkTabsToSpaces.Checked := AppSettings.ReadBool(asTabsToSpaces); comboSQLColElementChange(Sender); // Grid formatting: - comboDataFontName.Items := Screen.Fonts; + comboDataFontName.Items.Clear; + for i:=0 to Screen.Fonts.Count-1 do begin + if not Screen.Fonts[i].StartsWith('@') then + comboDataFontName.Items.Add(Screen.Fonts[i]); + end; comboDataFontName.ItemIndex := comboDataFontName.Items.IndexOf(AppSettings.ReadString(asDataFontName)); updownDataFontSize.Position := AppSettings.ReadInt(asDataFontSize); updownMaxQueryResults.Position := AppSettings.ReadINt(asMaxQueryResults); @@ -713,9 +794,12 @@ procedure Toptionsform.FormShow(Sender: TObject); cboxRowBackgroundEven.Selected := AppSettings.ReadInt(asRowBackgroundEven); cboxRowBackgroundOdd.Selected := AppSettings.ReadInt(asRowBackgroundOdd); cboxRowHighlightSameText.Selected := AppSettings.ReadInt(asHightlightSameTextBackground); + updownRealTrailingZeros.Position := AppSettings.ReadInt(asRealTrailingZeros); + updownLongSortRowNum.Position := AppSettings.ReadInt(asQueryGridLongSortRowNum); chkLocalNumberFormat.Checked := AppSettings.ReadBool(asDataLocalNumberFormat); + chkLowercaseHex.Checked := AppSettings.ReadBool(asLowercaseHex); chkHintsOnResultTabs.Checked := AppSettings.ReadBool(asHintsOnResultTabs); - updownLongSortRowNum.Position := AppSettings.ReadInt(asQueryGridLongSortRowNum); + chkShowRowId.Checked := AppSettings.ReadBool(asShowRowId); // Editor Configuration chkEditorBinary.Checked := AppSettings.ReadBool(asFieldEditorBinary); @@ -723,8 +807,10 @@ procedure Toptionsform.FormShow(Sender: TObject); chkPrefillDateTime.Checked := AppSettings.ReadBool(asFieldEditorDatetimePrefill); chkEditorEnum.Checked := AppSettings.ReadBool(asFieldEditorEnum); chkEditorSet.Checked := AppSettings.ReadBool(asFieldEditorEnum); + chkColumnHeaderClick.Checked := AppSettings.ReadBool(asColumnHeaderClick); chkReuseEditorConfiguration.Checked := AppSettings.ReadBool(asReuseEditorConfiguration); chkForeignDropDown.Checked := AppSettings.ReadBool(asForeignDropDown); + chkIncrementalSearch.Checked := AppSettings.ReadBool(asIncrementalSearch); case TLineBreaks(AppSettings.ReadInt(asLineBreakStyle)) of lbsNone, lbsWindows: comboLineBreakStyle.ItemIndex := 0; lbsUnix: comboLineBreakStyle.ItemIndex := 1; @@ -735,18 +821,37 @@ procedure Toptionsform.FormShow(Sender: TObject); TreeShortcutItems.ReinitChildren(nil, True); SelectNode(TreeShortcutItems, nil); - // Files + // Files and tabs chkAskFileSave.Checked := AppSettings.ReadBool(asPromptSaveFileOnTabClose); chkRestoreTabs.Checked := AppSettings.ReadBool(asRestoreTabs); + chkTabCloseOnDoubleClick.Checked := AppSettings.ReadBool(asTabCloseOnDoubleClick); + chkTabCloseOnMiddleClick.Checked := AppSettings.ReadBool(asTabCloseOnMiddleClick); + comboTabIconsGrayscaleMode.ItemIndex := AppSettings.ReadInt(asTabIconsGrayscaleMode); + comboReformatter.ItemIndex := AppSettings.ReadInt(asReformatterNoDialog); + + // Disable global shortcuts + MainForm.ActionList1.State := asSuspended; + + TExtForm.PageControlTabHighlight(pagecontrolMain); FRestartOptionTouched := False; btnApply.Enabled := False; screen.Cursor := crdefault; end; +procedure TfrmPreferences.editShortcutsFilterRightButtonClick(Sender: TObject); +begin + editShortcutsFilter.Clear; +end; + +procedure TfrmPreferences.editShortcutsFilterChange(Sender: TObject); +begin + FilterNodesByEdit(editShortcutsFilter, TreeShortcutItems); +end; -procedure Toptionsform.SQLFontChange(Sender: TObject); + +procedure TfrmPreferences.SQLFontChange(Sender: TObject); var AttriIdx: Integer; Attri: TSynHighlighterAttributes; @@ -776,19 +881,19 @@ procedure Toptionsform.SQLFontChange(Sender: TObject); end; -procedure Toptionsform.DataFontsChange(Sender: TObject); +procedure TfrmPreferences.DataFontsChange(Sender: TObject); begin Modified(Sender); end; -procedure Toptionsform.anyUpDownLimitChanging(Sender: TObject; +procedure TfrmPreferences.anyUpDownLimitChanging(Sender: TObject; var AllowChange: Boolean); begin Modified(Sender); end; -procedure Toptionsform.editGridRowCountExit(Sender: TObject); +procedure TfrmPreferences.editGridRowCountExit(Sender: TObject); var Edit: TEdit; begin @@ -800,7 +905,7 @@ procedure Toptionsform.editGridRowCountExit(Sender: TObject); end; -procedure Toptionsform.SelectDirectory(Sender: TObject; NewFolderButton: Boolean); +procedure TfrmPreferences.SelectDirectory(Sender: TObject; NewFolderButton: Boolean); var Browse: TBrowseForFolder; Edit: TButtonedEdit; @@ -821,21 +926,21 @@ procedure Toptionsform.SelectDirectory(Sender: TObject; NewFolderButton: Boolean end; -procedure Toptionsform.editLogDirRightButtonClick(Sender: TObject); +procedure TfrmPreferences.editLogDirRightButtonClick(Sender: TObject); begin // Select folder for session logs SelectDirectory(Sender, True); end; -procedure Toptionsform.editMySQLBinariesRightButtonClick(Sender: TObject); +procedure TfrmPreferences.editMySQLBinariesRightButtonClick(Sender: TObject); begin // Select folder where MySQL binaries reside SelectDirectory(Sender, False); end; -procedure Toptionsform.editCustomSnippetsDirectoryRightButtonClick(Sender: TObject); +procedure TfrmPreferences.editCustomSnippetsDirectoryRightButtonClick(Sender: TObject); begin // Set custom snippets directory SelectDirectory(Sender, True); @@ -845,7 +950,7 @@ procedure Toptionsform.editCustomSnippetsDirectoryRightButtonClick(Sender: TObje {** Updatecheck checkbox was clicked } -procedure Toptionsform.chkUpdatecheckClick(Sender: TObject); +procedure TfrmPreferences.chkUpdatecheckClick(Sender: TObject); begin updownUpdatecheckInterval.Enabled := chkUpdatecheck.Checked; editUpdatecheckInterval.Enabled := chkUpdatecheck.Checked; @@ -854,20 +959,26 @@ procedure Toptionsform.chkUpdatecheckClick(Sender: TObject); end; -procedure Toptionsform.chkCompletionProposalClick(Sender: TObject); +procedure TfrmPreferences.chkCompletionProposalClick(Sender: TObject); +var + Enable: Boolean; begin - chkCompletionProposalSearchOnMid.Enabled := TCheckBox(Sender).Checked; + Enable := TCheckBox(Sender).Checked; + editCompletionProposalInterval.Enabled := Enable; + updownCompletionProposalInterval.Enabled := Enable; + lblCompletionProposalIntervalUnit.Enabled := Enable; + chkCompletionProposalSearchOnMid.Enabled := Enable; Modified(Sender); end; -procedure Toptionsform.chkLogToFileClick(Sender: TObject); +procedure TfrmPreferences.chkLogToFileClick(Sender: TObject); begin editLogDir.Enabled := TCheckBox(Sender).Checked; Modified(Sender); end; -procedure Toptionsform.chkQueryHistoryClick(Sender: TObject); +procedure TfrmPreferences.chkQueryHistoryClick(Sender: TObject); begin editQueryHistoryKeepDays.Enabled := chkQueryHistory.Checked; updownQueryHistoryKeepDays.Enabled := chkQueryHistory.Checked; @@ -876,7 +987,7 @@ procedure Toptionsform.chkQueryHistoryClick(Sender: TObject); end; -procedure Toptionsform.comboEditorColorsPresetChange(Sender: TObject); +procedure TfrmPreferences.comboEditorColorsPresetChange(Sender: TObject); var i, j: Integer; Highlighter: TSynSQLSyn; @@ -892,7 +1003,7 @@ procedure Toptionsform.comboEditorColorsPresetChange(Sender: TObject); if (Components[i] is TSynSQLSyn) and (Components[i] <> SynMemoSQLSample.Highlighter) then begin Highlighter := Components[i] as TSynSQLSyn; - // Translate highlighter postfix after last underscore ... + // Translate highlighter postfix after last underscore: SynSQLSyn_White, SynSQLSyn_Black, ... TranslatedHighlighterName := ''; if rx.Exec(Highlighter.Name) then begin TranslatedHighlighterName := _(rx.Match[1]); @@ -906,8 +1017,13 @@ procedure Toptionsform.comboEditorColorsPresetChange(Sender: TObject); // Use 3 hardcoded default values for additional colors, which are not part // of the highlighter's attributes SynMemoSQLSample.ActiveLineColor := StringToColor(AppSettings.GetDefaultString(asSQLColActiveLine)); - MainForm.MatchingBraceForegroundColor := StringToColor(AppSettings.GetDefaultString(asSQLColMatchingBraceForeground)); - MainForm.MatchingBraceBackgroundColor := StringToColor(AppSettings.GetDefaultString(asSQLColMatchingBraceBackground)); + if ThemeIsDark(comboTheme.Text) then begin + MainForm.MatchingBraceForegroundColor := $0028EFFF; + MainForm.MatchingBraceBackgroundColor := $004D513B; + end else begin + MainForm.MatchingBraceForegroundColor := StringToColor(AppSettings.GetDefaultString(asSQLColMatchingBraceForeground)); + MainForm.MatchingBraceBackgroundColor := StringToColor(AppSettings.GetDefaultString(asSQLColMatchingBraceBackground)); + end; Break; end; end; @@ -922,7 +1038,7 @@ procedure Toptionsform.comboEditorColorsPresetChange(Sender: TObject); end; -procedure Toptionsform.comboGridTextColorsPresetSelect(Sender: TObject); +procedure TfrmPreferences.comboGridTextColorsPresetSelect(Sender: TObject); var Preset: TGridColorsPreset; dtc: TDBDatatypeCategoryIndex; @@ -938,14 +1054,14 @@ procedure Toptionsform.comboGridTextColorsPresetSelect(Sender: TObject); end; -procedure Toptionsform.comboGridTextColorsSelect(Sender: TObject); +procedure TfrmPreferences.comboGridTextColorsSelect(Sender: TObject); begin // Data type category selected colorboxGridTextColors.Selected := FGridTextColors[TDBDatatypeCategoryIndex(comboGridTextColors.ItemIndex)]; end; -procedure Toptionsform.comboGUIFontChange(Sender: TObject); +procedure TfrmPreferences.comboGUIFontChange(Sender: TObject); var UseCustomFont: Boolean; begin @@ -958,7 +1074,7 @@ procedure Toptionsform.comboGUIFontChange(Sender: TObject); end; -procedure Toptionsform.colorBoxGridTextColorsSelect(Sender: TObject); +procedure TfrmPreferences.colorBoxGridTextColorsSelect(Sender: TObject); begin // Color selected FGridTextColors[TDBDatatypeCategoryIndex(comboGridTextColors.ItemIndex)] := colorboxGridTextColors.Selected; @@ -966,7 +1082,7 @@ procedure Toptionsform.colorBoxGridTextColorsSelect(Sender: TObject); end; -procedure Toptionsform.comboSQLColElementChange(Sender: TObject); +procedure TfrmPreferences.comboSQLColElementChange(Sender: TObject); var AttriIdx: Integer; Attri: TSynHighlighterAttributes; @@ -1001,7 +1117,7 @@ procedure Toptionsform.comboSQLColElementChange(Sender: TObject); end; -procedure Toptionsform.comboThemeSelect(Sender: TObject); +procedure TfrmPreferences.comboThemeSelect(Sender: TObject); begin // Select text colors so they fit to the selected theme if ThemeIsDark(comboTheme.Text) then begin @@ -1025,7 +1141,7 @@ procedure Toptionsform.comboThemeSelect(Sender: TObject); end; -procedure Toptionsform.updownSQLFontSizeClick(Sender: TObject; +procedure TfrmPreferences.updownSQLFontSizeClick(Sender: TObject; Button: TUDBtnType); begin SQLFontChange(Sender); @@ -1035,7 +1151,7 @@ procedure Toptionsform.updownSQLFontSizeClick(Sender: TObject; {** Select attribute in pulldown by click into SynMemo } -procedure Toptionsform.SynMemoSQLSampleClick(Sender: TObject); +procedure TfrmPreferences.SynMemoSQLSampleClick(Sender: TObject); var Token: UnicodeString; Attri: TSynHighlighterAttributes; @@ -1054,7 +1170,22 @@ procedure Toptionsform.SynMemoSQLSampleClick(Sender: TObject); end; -procedure Toptionsform.btnRestoreDefaultsClick(Sender: TObject); +procedure TfrmPreferences.btnRemoveHotKeyClick(Sender: TObject); +begin + // Clear current shortcut + if Sender = btnRemoveHotKey1 then begin + FHotKey1.HotKey := 0; + HotKeyChange(FHotKey1); + end + else if Sender = btnRemoveHotKey2 then begin + FHotKey2.HotKey := 0; + HotKeyChange(FHotKey2); + end + else + MessageBeep(MB_ICONASTERISK); +end; + +procedure TfrmPreferences.btnRestoreDefaultsClick(Sender: TObject); var ValueList: TStringlist; i: Integer; @@ -1072,7 +1203,7 @@ procedure Toptionsform.btnRestoreDefaultsClick(Sender: TObject); end; -procedure Toptionsform.chkThemePreviewClick(Sender: TObject); +procedure TfrmPreferences.chkThemePreviewClick(Sender: TObject); begin // Show or hide theme preview window if chkThemePreview.Checked then begin @@ -1086,7 +1217,7 @@ procedure Toptionsform.chkThemePreviewClick(Sender: TObject); end; end; -procedure Toptionsform.TreeShortcutItemsFocusChanged(Sender: TBaseVirtualTree; Node: PVirtualNode; +procedure TfrmPreferences.TreeShortcutItemsFocusChanged(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex); var ShortcutFocused: Boolean; @@ -1097,7 +1228,8 @@ procedure Toptionsform.TreeShortcutItemsFocusChanged(Sender: TBaseVirtualTree; N lblShortcutHint.Enabled := ShortcutFocused; lblShortcut1.Enabled := ShortcutFocused; lblShortcut2.Enabled := ShortcutFocused; - HotKey1.Enabled := lblShortcut1.Enabled; + FHotKey1.Enabled := lblShortcut1.Enabled; + btnRemoveHotKey1.Enabled := lblShortcut1.Enabled; if ShortcutFocused then begin Data := Sender.GetNodeData(Node); lblShortcutHint.Caption := TreeShortcutItems.Text[Node, 0]; @@ -1106,14 +1238,15 @@ procedure Toptionsform.TreeShortcutItemsFocusChanged(Sender: TBaseVirtualTree; N if MainForm.ActionList1DefaultHints[Data.Action.Index] <> '' then lblShortcutHint.Caption := MainForm.ActionList1DefaultHints[Data.Action.Index]; end; - HotKey1.HotKey := Data.ShortCut1; - HotKey2.HotKey := Data.ShortCut2; + FHotKey1.HotKey := Data.ShortCut1; + FHotKey2.HotKey := Data.ShortCut2; end; - HotKey2.Enabled := lblShortcut2.Enabled; + FHotKey2.Enabled := lblShortcut2.Enabled; + btnRemoveHotKey2.Enabled := lblShortcut2.Enabled; end; -procedure Toptionsform.TreeShortcutItemsGetImageIndex(Sender: TBaseVirtualTree; Node: PVirtualNode; +procedure TfrmPreferences.TreeShortcutItemsGetImageIndex(Sender: TBaseVirtualTree; Node: PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex; var Ghosted: Boolean; var ImageIndex: TImageIndex); var Data: PShortcutItemData; @@ -1130,13 +1263,13 @@ procedure Toptionsform.TreeShortcutItemsGetImageIndex(Sender: TBaseVirtualTree; end; -procedure Toptionsform.TreeShortcutItemsGetNodeDataSize(Sender: TBaseVirtualTree; var NodeDataSize: Integer); +procedure TfrmPreferences.TreeShortcutItemsGetNodeDataSize(Sender: TBaseVirtualTree; var NodeDataSize: Integer); begin NodeDataSize := SizeOf(TShortcutItemData); end; -procedure Toptionsform.TreeShortcutItemsGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; +procedure TfrmPreferences.TreeShortcutItemsGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; var CellText: String); var Data: PShortcutItemData; @@ -1160,14 +1293,14 @@ procedure Toptionsform.TreeShortcutItemsGetText(Sender: TBaseVirtualTree; Node: end; CellText := _(CellText); end else if Assigned(Data.Action) then begin - CellText := MainForm.ActionList1DefaultCaptions[Data.Action.Index]; + CellText := StripHotkey(MainForm.ActionList1DefaultCaptions[Data.Action.Index]); end; end; end; end; -procedure Toptionsform.TreeShortcutItemsInitChildren(Sender: TBaseVirtualTree; Node: PVirtualNode; +procedure TfrmPreferences.TreeShortcutItemsInitChildren(Sender: TBaseVirtualTree; Node: PVirtualNode; var ChildCount: Cardinal); var i: Integer; @@ -1189,7 +1322,7 @@ procedure Toptionsform.TreeShortcutItemsInitChildren(Sender: TBaseVirtualTree; N end; -procedure Toptionsform.TreeShortcutItemsInitNode(Sender: TBaseVirtualTree; ParentNode, Node: PVirtualNode; +procedure TfrmPreferences.TreeShortcutItemsInitNode(Sender: TBaseVirtualTree; ParentNode, Node: PVirtualNode; var InitialStates: TVirtualNodeInitStates); var Data: PShortcutItemData; @@ -1222,29 +1355,85 @@ procedure Toptionsform.TreeShortcutItemsInitNode(Sender: TBaseVirtualTree; Paren end; -procedure Toptionsform.HotKey1Change(Sender: TObject); +function TfrmPreferences.EnsureShortcutIsUnused(RequestShortcut: TShortCut): Boolean; var + Node, NodeWantsIt: PVirtualNode; Data: PShortcutItemData; + Tree: TVirtualStringTree; + MsgFormat, Msg: String; begin - // Shortcut 1 changed - Data := TreeShortcutItems.GetNodeData(TreeShortcutItems.FocusedNode); - Data.Shortcut1 := (Sender as THotKey).HotKey; - Modified(Sender); + Result := True; + if RequestShortcut = 0 then + Exit; + MsgFormat := _('Keyboard shortcut [%s] is already assigned to "%s".') + sLineBreak + sLineBreak + + _('Remove it there and assign to "%s" instead?') + sLineBreak + sLineBreak + + _('Press ignore to keep both and ignore all conflicts.'); + Tree := TreeShortcutItems; + NodeWantsIt := Tree.FocusedNode; + Node := GetNextNode(Tree, nil, False); + while Assigned(Node) do begin + if Tree.GetNodeLevel(Node) = 1 then begin + Data := Tree.GetNodeData(Node); + Msg := Format(MsgFormat, [ + ShortCutToText(RequestShortcut), + Tree.Text[Node.Parent, 0] + ' > ' + StripHotkey(Tree.Text[Node, 0]), + Tree.Text[NodeWantsIt.Parent, 0] + ' > ' + StripHotkey(Tree.Text[NodeWantsIt, 0]) + ]); + if Node = NodeWantsIt then begin + // Ignore requesting node + end else begin + if Data.ShortCut1 = RequestShortcut then begin + case MessageDialog(Msg, mtConfirmation, [mbYes, mbNo, mbIgnore]) of + mrYes: Data.ShortCut1 := 0; // Unassign shortcut 1 + mrNo: Result := False; + mrIgnore: Break; // Keep Result=True and exit loop, ignore further conflicts + end; + end; + if Data.ShortCut2 = RequestShortcut then begin + case MessageDialog(Msg, mtConfirmation, [mbYes, mbNo, mbIgnore]) of + mrYes: Data.ShortCut2 := 0; // Unassign shortcut 2 + mrNo: Result := False; + mrIgnore: Break; + end; + end; + end; + end; + if Result = False then + Break; + Node := GetNextNode(Tree, Node, False); + end; + end; -procedure Toptionsform.HotKey2Change(Sender: TObject); +procedure TfrmPreferences.HotKeyChange(Sender: TObject); var Data: PShortcutItemData; + HotKeyEdit: TExtSynHotKey; + EventHandler: TNotifyEvent; begin - // Shortcut 2 changed + // Shortcut 1 or 2 changed + HotKeyEdit := Sender as TExtSynHotKey; Data := TreeShortcutItems.GetNodeData(TreeShortcutItems.FocusedNode); - Data.Shortcut2 := (Sender as THotKey).HotKey; - Modified(Sender); + if EnsureShortcutIsUnused(HotKeyEdit.HotKey) then begin + if HotKeyEdit = FHotKey1 then + Data.Shortcut1 := HotKeyEdit.HotKey + else + Data.Shortcut2 := HotKeyEdit.HotKey; + Modified(Sender); + end else begin + // Undo change in hotkey editor, without triggering OnChange event + EventHandler := HotKeyEdit.OnChange; + if HotKeyEdit = FHotKey1 then + HotKeyEdit.HotKey := Data.ShortCut1 + else + HotKeyEdit.HotKey := Data.ShortCut2; + HotKeyEdit.OnChange := EventHandler; + end; end; -procedure Toptionsform.HotKeyEnter(Sender: TObject); +procedure TfrmPreferences.HotKeyEnter(Sender: TObject); begin // Remove Esc and Enter shortcuts from buttons btnOk.Default := False; @@ -1252,7 +1441,7 @@ procedure Toptionsform.HotKeyEnter(Sender: TObject); end; -procedure Toptionsform.HotKeyExit(Sender: TObject); +procedure TfrmPreferences.HotKeyExit(Sender: TObject); begin // Readd Esc and Enter shortcuts to buttons btnOk.Default := True; @@ -1260,7 +1449,7 @@ procedure Toptionsform.HotKeyExit(Sender: TObject); end; -procedure Toptionsform.InitLanguages; +procedure TfrmPreferences.InitLanguages; var LangNames: String; AvailLangCodes: TStringList; diff --git a/source/printlist.dfm b/source/printlist.dfm index f13ca4754..80f359a0c 100644 --- a/source/printlist.dfm +++ b/source/printlist.dfm @@ -8,14 +8,12 @@ object printlistForm: TprintlistForm Color = clBtnFace Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText - Font.Height = -11 + Font.Height = -12 Font.Name = 'Tahoma' Font.Style = [] - OldCreateOrder = False Position = poMainFormCenter OnShow = FormShow - PixelsPerInch = 96 - TextHeight = 13 + TextHeight = 14 object lblSelect: TLabel Left = 8 Top = 11 diff --git a/source/printlist.pas b/source/printlist.pas index 0df1b8cdd..23a3d255b 100644 --- a/source/printlist.pas +++ b/source/printlist.pas @@ -9,7 +9,7 @@ interface uses - Windows, Classes, Controls, Forms, Dialogs, StdCtrls, Printers, VirtualTrees, gnugettext; + Winapi.Windows, System.Classes, System.SysUtils, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.Printers, VirtualTrees, gnugettext; type TprintlistForm = class(TForm) @@ -43,7 +43,17 @@ procedure TprintlistForm.FormShow(Sender: TObject); // show! Screen.Cursor := crHourGlass; comboPrinters.Items := Printer.printers; - comboPrinters.ItemIndex := Printer.printerIndex; + try + if comboPrinters.Items.Count > 0 then begin + comboPrinters.ItemIndex := Printer.printerIndex; + btnConfigure.Enabled := True; + end; + except + on E:Exception do begin + btnConfigure.Enabled := False; + ErrorDialog(E.Message); + end; + end; Screen.Cursor := crDefault; end; @@ -81,7 +91,12 @@ procedure TprintlistForm.btnPrintClick(Sender: TObject); else list := Mainform.ActiveGrid; end; if Assigned(list) then + try list.Print(Printer, chkPrintHeader.Checked); + except + on E:EPrinter do + ErrorDialog(E.Message); + end; Screen.Cursor := crDefault; end; diff --git a/source/reformatter.dfm b/source/reformatter.dfm new file mode 100644 index 000000000..929707153 --- /dev/null +++ b/source/reformatter.dfm @@ -0,0 +1,82 @@ +object frmReformatter: TfrmReformatter + Left = 0 + Top = 0 + BorderStyle = bsDialog + Caption = 'Reformat SQL' + ClientHeight = 217 + ClientWidth = 503 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -12 + Font.Name = 'Segoe UI' + Font.Style = [] + Position = poOwnerFormCenter + OnCreate = FormCreate + OnDestroy = FormDestroy + DesignSize = ( + 503 + 217) + TextHeight = 15 + object grpReformatter: TRadioGroup + Left = 8 + Top = 8 + Width = 487 + Height = 128 + Anchors = [akLeft, akTop, akRight, akBottom] + Caption = 'Select reformatter' + ItemIndex = 0 + Items.Strings = ( + 'Internal' + 'Online (heidisql.com)' + 'Online (sqlformat.org)') + TabOrder = 0 + OnClick = grpReformatterClick + end + object btnCancel: TButton + Left = 420 + Top = 184 + Width = 75 + Height = 25 + Anchors = [akRight, akBottom] + Cancel = True + Caption = 'Cancel' + ModalResult = 2 + TabOrder = 1 + end + object btnOk: TButton + Left = 339 + Top = 184 + Width = 75 + Height = 25 + Anchors = [akRight, akBottom] + Caption = 'OK' + Default = True + ModalResult = 1 + TabOrder = 2 + OnClick = btnOkClick + end + object lblFormatProviderLink: TLinkLabel + Left = 8 + Top = 142 + Width = 149 + Height = 24 + Anchors = [akLeft, akBottom] + Caption = 'lblFormatProviderLink' + TabOrder = 3 + UseVisualStyle = True + Visible = False + OnLinkClick = lblFormatProviderLinkLinkClick + end + object chkKeepAsking: TCheckBox + Left = 8 + Top = 188 + Width = 257 + Height = 17 + Anchors = [akLeft, akRight, akBottom] + Caption = 'Keep asking this question.' + Checked = True + State = cbChecked + TabOrder = 4 + end +end diff --git a/source/reformatter.pas b/source/reformatter.pas new file mode 100644 index 000000000..fa38613b8 --- /dev/null +++ b/source/reformatter.pas @@ -0,0 +1,298 @@ +unit reformatter; + +interface + +uses + Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, System.Math, Vcl.Graphics, + Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ExtCtrls, IdHTTP, IdSSLOpenSSL, System.JSON, + apphelpers, extra_controls, gnugettext, dbconnection, dbstructures, dbstructures.mysql; + +type + TfrmReformatter = class(TExtForm) + grpReformatter: TRadioGroup; + btnCancel: TButton; + btnOk: TButton; + lblFormatProviderLink: TLinkLabel; + chkKeepAsking: TCheckBox; + procedure btnOkClick(Sender: TObject); + procedure FormCreate(Sender: TObject); + procedure FormDestroy(Sender: TObject); + procedure grpReformatterClick(Sender: TObject); + procedure lblFormatProviderLinkLinkClick(Sender: TObject; + const Link: string; LinkType: TSysLinkType); + private + { Private declarations } + FInputCode, FOutputCode: String; + public + { Public declarations } + function FormatSqlInternal(SQL: String): String; + function FormatSqlOnlineHeidisql(SQL: String): String; + function FormatSqlOnlineSqlformatOrg(SQL: String): String; + property InputCode: String read FInputCode write FInputCode; + property OutputCode: String read FOutputCode; + end; + +var + frmReformatter: TfrmReformatter; + +implementation + +uses main; + +{$R *.dfm} + + +procedure TfrmReformatter.btnOkClick(Sender: TObject); +var + StartTime: UInt64; + TimeElapsed: Double; +begin + Screen.Cursor := crHourGlass; + try + StartTime := GetTickCount64; + case grpReformatter.ItemIndex of + 0: begin + // Internal + FOutputCode := FormatSqlInternal(FInputCode); + end; + 1: begin + // Online + FOutputCode := FormatSqlOnlineHeidisql(FInputCode); + end; + 2: begin + // sqlformat.org + FOutputCode := FormatSqlOnlineSqlformatOrg(FInputCode); + end; + end; + // Unify line breaks, so selection end will be correct: + FOutputCode := fixNewlines(FOutputCode); + TimeElapsed := GetTickCount64 - StartTime; + MainForm.LogSQL(f_('Code reformatted in %s, using formatter %s', [FormatTimeNumber(TimeElapsed/1000, True, 3), '#'+grpReformatter.ItemIndex.ToString])); + except + on E:EIdHTTPProtocolException do begin + ErrorDialog(E.Message + sLineBreak + sLineBreak + E.ErrorMessage); + ModalResult := mrNone; + end; + on E:Exception do begin + ErrorDialog(E.ClassName + ': ' + E.Message); + ModalResult := mrNone; + end; + + end; + + if not chkKeepAsking.Checked then begin + // No dialog next time please + AppSettings.WriteInt(asReformatterNoDialog, grpReformatter.ItemIndex+1); + end; + + Screen.Cursor := crDefault; +end; + +procedure TfrmReformatter.FormCreate(Sender: TObject); +begin + grpReformatter.Items.Clear; + grpReformatter.Items.Add(_('Internal')); + grpReformatter.Items.Add(f_('Online on %s', [APPDOMAIN])); + grpReformatter.Items.Add(f_('Online on %s', ['sqlformat.org'])); + if AppSettings.ReadInt(asReformatterNoDialog) = 0 then begin + grpReformatter.ItemIndex := AppSettings.ReadInt(asReformatter); + end + else begin + // asReformatterNoDialog has the same items with an additional "always ask" item at index 0 + grpReformatter.ItemIndex := AppSettings.ReadInt(asReformatterNoDialog) - 1; + end; +end; + +procedure TfrmReformatter.FormDestroy(Sender: TObject); +begin + AppSettings.WriteInt(asReformatter, grpReformatter.ItemIndex); +end; + + +procedure TfrmReformatter.grpReformatterClick(Sender: TObject); +begin + case grpReformatter.ItemIndex of + 0: lblFormatProviderLink.Visible := False; + 1: begin + lblFormatProviderLink.Caption := 'github.com/doctrine/sql-formatter (Jeremy Dorn)'; + lblFormatProviderLink.Visible := True; + end; + 2: begin + lblFormatProviderLink.Caption := 'SQLFormat.org (Andi Albrecht)'; + lblFormatProviderLink.Visible := True; + end; + end; +end; + +procedure TfrmReformatter.lblFormatProviderLinkLinkClick(Sender: TObject; + const Link: string; LinkType: TSysLinkType); +begin + apphelpers.ShellExec(Link); +end; + +function TfrmReformatter.FormatSqlInternal(SQL: String): String; +var + Conn: TDBConnection; + SQLFunc: TSQLFunction; + AllKeywords, ImportantKeywords, PairKeywords: TStringList; + i, Run, KeywordMaxLen: Integer; + IsEsc, IsQuote, InComment, InBigComment, InString, InKeyword, InIdent, LastWasComment: Boolean; + c, p: Char; + Keyword, PreviousKeyword, TestPair: String; + Datatypes: TDBDataTypeArray; +const + WordChars = ['a'..'z', 'A'..'Z', '0'..'9', '_', '.']; + WhiteSpaces = [#9, #10, #13, #32]; +begin + Conn := MainForm.ActiveConnection; + // Known SQL keywords, get converted to UPPERCASE + AllKeywords := TStringList.Create; + AllKeywords.Text := MySQLKeywords.Text; + + for SQLFunc in Conn.SQLFunctions do begin + // Leave out operator functions like ">>", and the "X()" function so hex values don't get touched + if (SQLFunc.Declaration <> '') and (SQLFunc.Name <> 'X') then + AllKeywords.Add(SQLFunc.Name); + end; + Datatypes := Conn.Datatypes; + for i:=Low(Datatypes) to High(Datatypes) do + AllKeywords.Add(Datatypes[i].Name); + KeywordMaxLen := 0; + for i:=0 to AllKeywords.Count-1 do + KeywordMaxLen := Max(KeywordMaxLen, Length(AllKeywords[i])); + + // A subset of the above list, each of them will get a linebreak left to it + ImportantKeywords := Explode(',', 'SELECT,FROM,LEFT,RIGHT,STRAIGHT,NATURAL,INNER,JOIN,WHERE,GROUP,ORDER,HAVING,LIMIT,CREATE,DROP,UPDATE,INSERT,REPLACE,TRUNCATE,DELETE'); + // Keywords which followers should not get separated into a new line + PairKeywords := Explode(',', 'LEFT,RIGHT,STRAIGHT,NATURAL,INNER,ORDER,GROUP'); + + IsEsc := False; + InComment := False; + InBigComment := False; + LastWasComment := False; + InString := False; + InIdent := False; + Run := 1; + Result := ''; + SQL := SQL + ' '; + SetLength(Result, Length(SQL)*2); + Keyword := ''; + PreviousKeyword := ''; + for i:=1 to Length(SQL) do begin + c := SQL[i]; // Current char + if i > 1 then p := SQL[i-1] else p := #0; // Previous char + + // Detection logic - where are we? + if c = '\' then IsEsc := not IsEsc + else IsEsc := False; + IsQuote := (c = '''') or (c = '"'); + if c = '`' then InIdent := not InIdent; + if (not IsEsc) and IsQuote then InString := not InString; + if (c = '#') or ((c = '-') and (p = '-')) then InComment := True; + if ((c = #10) or (c = #13)) and InComment then begin + LastWasComment := True; + InComment := False; + end; + if (c = '*') and (p = '/') and (not InComment) and (not InString) then InBigComment := True; + if (c = '/') and (p = '*') and (not InComment) and (not InString) then InBigComment := False; + InKeyword := (not InComment) and (not InBigComment) and (not InString) and (not InIdent) and CharInSet(c, WordChars); + + // Creation of returning text + if InKeyword then begin + Keyword := Keyword + c; + end else begin + if Keyword <> '' then begin + if AllKeywords.IndexOf(KeyWord) > -1 then begin + while (Run > 1) and CharInSet(Result[Run-1], WhiteSpaces) do + Dec(Run); + Keyword := UpperCase(Keyword); + if Run > 1 then begin + // SELECT, WHERE, JOIN etc. get a new line, but don't separate LEFT JOIN with linebreaks + if LastWasComment or ((ImportantKeywords.IndexOf(Keyword) > -1) and (PairKeywords.IndexOf(PreviousKeyword) = -1)) then + Keyword := CRLF + Keyword + else if (Result[Run-1] <> '(') then + Keyword := ' ' + Keyword; + end; + LastWasComment := False; + end; + PreviousKeyword := Trim(Keyword); + Insert(Keyword, Result, Run); + Inc(Run, Length(Keyword)); + Keyword := ''; + end; + if (not InComment) and (not InBigComment) and (not InString) and (not InIdent) then begin + TestPair := Result[Run-1] + c; + if (TestPair = ' ') or (TestPair = '( ') then begin + c := Result[Run-1]; + Dec(Run); + end; + if (TestPair = ' )') or (TestPair = ' ,') then + Dec(Run); + end; + Result[Run] := c; + Inc(Run); + end; + + end; + + // Cut overlength + SetLength(Result, Run-2); +end; + + +function TfrmReformatter.FormatSqlOnlineHeidisql(SQL: String): String; +var + HttpReq: TIdHTTP; + SSLio: TIdSSLIOHandlerSocketOpenSSL; + Parameters: TStringList; +begin + HttpReq := TIdHTTP.Create; + SSLio := TIdSSLIOHandlerSocketOpenSSL.Create; + HttpReq.IOHandler := SSLio; + SSLio.SSLOptions.SSLVersions := [sslvTLSv1_1, sslvTLSv1_2]; + //HttpReq.Request.ContentType := 'application/json'; + HttpReq.Request.CharSet := 'utf-8'; + HttpReq.Request.UserAgent := apphelpers.UserAgent(Self); + Parameters := TStringList.Create; + Parameters.AddPair('indent', CodeIndent); + Parameters.AddPair('input', FInputCode); + Result := HttpReq.Post(APPDOMAIN + 'sql-formatter.php', Parameters); + if Result.IsEmpty then + raise Exception.Create(_('Empty result from online reformatter')); + HttpReq.Free; +end; + + +function TfrmReformatter.FormatSqlOnlineSqlformatOrg(SQL: String): String; +var + HttpReq: TIdHTTP; + SSLio: TIdSSLIOHandlerSocketOpenSSL; + Parameters: TStringList; + JsonResponseStr: String; + JsonTmp: TJSONValue; +begin + HttpReq := TIdHTTP.Create; + SSLio := TIdSSLIOHandlerSocketOpenSSL.Create; + HttpReq.IOHandler := SSLio; + SSLio.SSLOptions.SSLVersions := [sslvTLSv1_1, sslvTLSv1_2]; + HttpReq.Request.CharSet := 'utf-8'; + HttpReq.Request.UserAgent := apphelpers.UserAgent(Self); + // Parameter documentation: https://sqlformat.org/api/ + Parameters := TStringList.Create; + Parameters.AddPair('sql', FInputCode); + Parameters.AddPair('reindent', '1'); + if AppSettings.ReadBool(asTabsToSpaces) then + Parameters.AddPair('indent_width', AppSettings.ReadInt(asTabWidth).ToString) + else + Parameters.AddPair('indent_width', '2'); + Parameters.AddPair('keyword_case', 'upper'); + JsonResponseStr := HttpReq.Post('https://sqlformat.org/api/v1/format', Parameters); + if JsonResponseStr.IsEmpty then + raise Exception.Create(_('Empty result from online reformatter')); + JsonTmp := TJSONObject.ParseJSONValue(JsonResponseStr); + Result := JsonTmp.FindValue('result').Value; + JsonTmp.Free; + HttpReq.Free; +end; + +end. diff --git a/source/routine_editor.dfm b/source/routine_editor.dfm index 2915d4ff3..df6917b7a 100644 --- a/source/routine_editor.dfm +++ b/source/routine_editor.dfm @@ -84,6 +84,14 @@ object frmRoutineEditor: TfrmRoutineEditor TabOrder = 1 OnDragDrop = SynMemoBodyDragDrop OnDragOver = SynMemoBodyDragOver + CodeFolding.GutterShapeSize = 11 + CodeFolding.CollapsedLineColor = clGrayText + CodeFolding.FolderBarLinesColor = clGrayText + CodeFolding.IndentGuidesColor = clGray + CodeFolding.IndentGuides = True + CodeFolding.ShowCollapsedLine = False + CodeFolding.ShowHintMark = True + UseCodeFolding = False Gutter.AutoSize = True Gutter.DigitCount = 2 Gutter.Font.Charset = DEFAULT_CHARSET @@ -123,6 +131,7 @@ object frmRoutineEditor: TfrmRoutineEditor Constraints.MinHeight = 166 Images = MainForm.VirtualImageListMain TabOrder = 0 + OnChange = PageControlMainChange object tabOptions: TTabSheet Caption = 'Options' ImageIndex = 39 @@ -230,6 +239,7 @@ object frmRoutineEditor: TfrmRoutineEditor Top = 87 Width = 310 Height = 21 + AutoDropDownWidth = True TabOrder = 4 Text = 'comboReturns' OnChange = Modification @@ -258,6 +268,7 @@ object frmRoutineEditor: TfrmRoutineEditor Top = 8 Width = 194 Height = 21 + AutoDropDownWidth = True Anchors = [akLeft, akTop, akRight] TabOrder = 1 Text = 'comboDefiner' @@ -297,6 +308,8 @@ object frmRoutineEditor: TfrmRoutineEditor OnPaintText = listParametersPaintText OnGetImageIndex = listParametersGetImageIndex OnNewText = listParametersNewText + Touch.InteractiveGestures = [igPan, igPressAndTap] + Touch.InteractiveGestureOptions = [igoPanSingleFingerHorizontal, igoPanSingleFingerVertical, igoPanInertia, igoPanGutter, igoParentPassthrough] Columns = < item Position = 0 @@ -400,6 +413,14 @@ object frmRoutineEditor: TfrmRoutineEditor Font.Name = 'Courier New' Font.Style = [] TabOrder = 0 + CodeFolding.GutterShapeSize = 11 + CodeFolding.CollapsedLineColor = clGrayText + CodeFolding.FolderBarLinesColor = clGrayText + CodeFolding.IndentGuidesColor = clGray + CodeFolding.IndentGuides = True + CodeFolding.ShowCollapsedLine = False + CodeFolding.ShowHintMark = True + UseCodeFolding = False Gutter.Font.Charset = DEFAULT_CHARSET Gutter.Font.Color = clWindowText Gutter.Font.Height = -11 diff --git a/source/routine_editor.pas b/source/routine_editor.pas index 65f9fc153..6b56c94b3 100644 --- a/source/routine_editor.pas +++ b/source/routine_editor.pas @@ -3,9 +3,10 @@ interface uses - Windows, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, SynEdit, SynMemo, StdCtrls, - ComCtrls, ToolWin, VirtualTrees, SynRegExpr, - dbconnection, apphelpers, gnugettext, Vcl.Menus, Vcl.ExtCtrls; + Winapi.Windows, System.SysUtils, System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, SynEdit, SynMemo, Vcl.StdCtrls, + Vcl.ComCtrls, Vcl.ToolWin, VirtualTrees.BaseTree, VirtualTrees.Types, VirtualTrees, VirtualTrees.EditLink, SynRegExpr, extra_controls, + dbconnection, apphelpers, gnugettext, Vcl.Menus, Vcl.ExtCtrls, + VirtualTrees.BaseAncestorVCL, VirtualTrees.AncestorVCL; type TFrame = TDBObjectEditor; @@ -77,6 +78,7 @@ TfrmRoutineEditor = class(TFrame) procedure btnDiscardClick(Sender: TObject); procedure comboDefinerDropDown(Sender: TObject); procedure btnMoveParamClick(Sender: TObject); + procedure PageControlMainChange(Sender: TObject); private { Private declarations } FAlterRoutineType: String; @@ -85,15 +87,15 @@ TfrmRoutineEditor = class(TFrame) { Public declarations } Parameters: TRoutineParamList; constructor Create(AOwner: TComponent); override; - destructor Destroy; override; procedure Init(Obj: TDBObject); override; + function DeInit: TModalResult; override; function ApplyModifications: TModalResult; override; end; implementation -uses main, dbstructures, grideditlinks; +uses main, dbstructures, dbstructures.mysql, grideditlinks; {$R *.dfm} @@ -112,18 +114,11 @@ constructor TfrmRoutineEditor.Create(AOwner: TComponent); comboSecurity.Items.Add('Definer'); comboSecurity.Items.Add('Invoker'); Mainform.SynCompletionProposal.AddEditor(SynMemoBody); - FixVT(listParameters); - Mainform.RestoreListSetup(listParameters); Parameters := TRoutineParamList.Create; editName.MaxLength := NAME_LEN; -end; - - -destructor TfrmRoutineEditor.Destroy; -begin - // Store GUI setup - Mainform.SaveListSetup(listParameters); - inherited; + FMainSynMemo := SynMemoBody; + btnSave.Hint := ShortCutToText(MainForm.actSaveSQL.ShortCut); + FixVT(listParameters); end; @@ -132,6 +127,7 @@ procedure TfrmRoutineEditor.Init(Obj: TDBObject); i: Integer; begin inherited; + TExtForm.RestoreListSetup(listParameters); if Obj.NodeType = lntProcedure then FAlterRoutineType := 'PROCEDURE' else FAlterRoutineType := 'FUNCTION'; editName.Text := DBObject.Name; @@ -147,16 +143,16 @@ procedure TfrmRoutineEditor.Init(Obj: TDBObject); comboDataAccess.ItemIndex := 0; comboSecurity.ItemIndex := 0; editComment.Clear; + case Obj.NodeType of + lntProcedure: comboType.ItemIndex := 0; + lntFunction: comboType.ItemIndex := 1; + end; comboDefiner.Text := ''; comboDefiner.TextHint := f_('Current user (%s)', [Obj.Connection.CurrentUserHostCombination]); comboDefiner.Hint := f_('Leave empty for current user (%s)', [Obj.Connection.CurrentUserHostCombination]); SynMemoBody.Text := 'BEGIN'+CRLF+CRLF+'END'; - if DBObject.Name <> '' then begin + if ObjectExists then begin // Editing existing routine - case Obj.NodeType of - lntProcedure: comboType.ItemIndex := 0; - lntFunction: comboType.ItemIndex := 1; - end; DBObject.Connection.ParseRoutineStructure(Obj, Parameters); comboReturns.Text := Obj.Returns; chkDeterministic.Checked := Obj.Deterministic; @@ -172,6 +168,7 @@ procedure TfrmRoutineEditor.Init(Obj: TDBObject); lblDisabledWhy.Visible := Obj.Body = ''; PageControlMain.Enabled := not lblDisabledWhy.Visible; SynMemoBody.Enabled := PageControlMain.Enabled; + SynMemoBody.TopLine := FMainSynMemoPreviousTopLine; end else begin editName.Text := ''; end; @@ -185,12 +182,21 @@ procedure TfrmRoutineEditor.Init(Obj: TDBObject); btnDiscard.Top := btnSave.Top; btnRunProc.Top := btnSave.Top; btnRunProc.Left := Width - btnRunProc.Width - 3; - Mainform.actRunRoutines.Enabled := DBObject.Name <> ''; + Mainform.actRunRoutines.Enabled := ObjectExists; Mainform.ShowStatusMsg; + TExtForm.PageControlTabHighlight(PageControlMain); Screen.Cursor := crDefault; end; +function TfrmRoutineEditor.DeInit: TModalResult; +begin + // Store GUI setup + TExtForm.SaveListSetup(listParameters); + Result := inherited; +end; + + procedure TfrmRoutineEditor.Modification(Sender: TObject); begin Modified := True; @@ -200,6 +206,11 @@ procedure TfrmRoutineEditor.Modification(Sender: TObject); end; +procedure TfrmRoutineEditor.PageControlMainChange(Sender: TObject); +begin + TExtForm.PageControlTabHighlight(PageControlMain); +end; + procedure TfrmRoutineEditor.comboTypeSelect(Sender: TObject); var isfunc: Boolean; @@ -385,7 +396,7 @@ procedure TfrmRoutineEditor.listParametersCreateEditor(Sender: TBaseVirtualTree; if Column = 1 then EditLink := TStringEditLink.Create else if Column = 2 then begin - EnumEditor := TEnumEditorLink.Create(VT, True); + EnumEditor := TEnumEditorLink.Create(VT, True, nil); EnumEditor.AllowCustomText := True; EnumEditor.ValueList := TStringList.Create; for DBDatatype in DBObject.Connection.Datatypes do begin @@ -396,7 +407,7 @@ procedure TfrmRoutineEditor.listParametersCreateEditor(Sender: TBaseVirtualTree; end; EditLink := EnumEditor; end else if Column = 3 then begin - EnumEditor := TEnumEditorLink.Create(VT, True); + EnumEditor := TEnumEditorLink.Create(VT, True, nil); EnumEditor.ValueList := TStringList.Create; EnumEditor.ValueList.Add('IN'); EnumEditor.ValueList.Add('OUT'); @@ -459,6 +470,8 @@ function TfrmRoutineEditor.ApplyModifications: TModalResult; TargetExists: Boolean; begin // Save changes + btnSave.Enabled := False; + btnDiscard.Enabled := False; Result := mrOk; case comboType.ItemIndex of 0: ProcOrFunc := 'PROCEDURE'; @@ -469,7 +482,7 @@ function TfrmRoutineEditor.ApplyModifications: TModalResult; // Create a temp routine, check for syntax errors, then drop the old routine and create it. // See also: http://dev.mysql.com/doc/refman/5.0/en/alter-procedure.html try - if DBObject.Name <> '' then begin + if ObjectExists then begin // Create temp name i := 0; allRoutineNames := DBObject.Connection.GetCol('SELECT ROUTINE_NAME FROM '+DBObject.Connection.QuoteIdent(DBObject.Connection.InfSch)+'.'+DBObject.Connection.QuoteIdent('ROUTINES')+ @@ -510,8 +523,6 @@ function TfrmRoutineEditor.ApplyModifications: TModalResult; Mainform.UpdateEditorTab; Mainform.RefreshTree(DBObject); Modified := False; - btnSave.Enabled := Modified; - btnDiscard.Enabled := Modified; Mainform.actRunRoutines.Enabled := True; except on E:EDbError do begin @@ -519,6 +530,8 @@ function TfrmRoutineEditor.ApplyModifications: TModalResult; Result := mrAbort; end; end; + btnSave.Enabled := Modified; + btnDiscard.Enabled := Modified; end; @@ -541,11 +554,11 @@ function TfrmRoutineEditor.ComposeCreateStatement(NameOfObject: String): String; tmp := ''; if ProcOrFunc = 'PROCEDURE' then tmp := tmp + Parameters[i].Context + ' '; - tmp := tmp + DBObject.Connection.QuoteIdent(Parameters[i].Name) + ' ' + Parameters[i].Datatype; + tmp := tmp + DBObject.Connection.QuoteIdent(Parameters[i].Name.Trim) + ' ' + Parameters[i].Datatype; Params.Add(tmp); end; if Params.Count > 0 then - Result := Result + CRLF + #9 + implodestr(','+CRLF+#9, Params) + CRLF; + Result := Result + sLineBreak + CodeIndent + Implode(',' + sLineBreak + CodeIndent, Params) + sLineBreak; Result := Result + ')'+CRLF; if comboReturns.Enabled then Result := Result + 'RETURNS '+comboReturns.Text+CRLF; @@ -575,3 +588,4 @@ procedure TfrmRoutineEditor.btnHelpClick(Sender: TObject); end. + diff --git a/source/searchreplace.dfm b/source/searchreplace.dfm index fbb2c567a..6f0ffb194 100644 --- a/source/searchreplace.dfm +++ b/source/searchreplace.dfm @@ -10,19 +10,17 @@ object frmSearchReplace: TfrmSearchReplace Constraints.MinWidth = 400 Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText - Font.Height = -11 + Font.Height = -12 Font.Name = 'Tahoma' Font.Style = [] - OldCreateOrder = False Position = poOwnerFormCenter + OnClose = FormClose OnCreate = FormCreate - OnDestroy = FormDestroy OnShow = FormShow DesignSize = ( 434 311) - PixelsPerInch = 96 - TextHeight = 13 + TextHeight = 14 object lblSearch: TLabel Left = 8 Top = 40 @@ -34,13 +32,11 @@ object frmSearchReplace: TfrmSearchReplace object lblReplaceHint: TLabel Left = 90 Top = 87 - Width = 336 + Width = 259 Height = 13 Anchors = [akLeft, akTop, akRight] - AutoSize = False Caption = 'Replacement can have \n for new lines and \t for tabs' Enabled = False - WordWrap = True end object lblSearchIn: TLabel Left = 8 diff --git a/source/searchreplace.pas b/source/searchreplace.pas index de9a8f817..09e71f8df 100644 --- a/source/searchreplace.pas +++ b/source/searchreplace.pas @@ -3,10 +3,10 @@ interface uses - Windows, Messages, SysUtils, Classes, Controls, Forms, Dialogs, StdCtrls, - ExtCtrls, SynMemo, SynEditTypes, gnugettext, VirtualTrees, SynRegExpr, + Winapi.Windows, Winapi.Messages, System.SysUtils, System.Classes, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, + Vcl.ExtCtrls, SynMemo, SynEditTypes, gnugettext, VirtualTrees, SynRegExpr, SynEditRegexSearch, SynEditMiscClasses, SynEditSearch, extra_controls, - Vcl.Menus; + Vcl.Menus, texteditor; type TfrmSearchReplace = class(TExtForm) @@ -39,10 +39,10 @@ TfrmSearchReplace = class(TExtForm) procedure FormShow(Sender: TObject); procedure comboSearchReplaceExit(Sender: TObject); procedure FormCreate(Sender: TObject); - procedure FormDestroy(Sender: TObject); procedure DoSearchReplace(Sender: TObject); procedure btnWithDropDownClick(Sender: TObject); procedure menuHintClick(Sender: TObject); + procedure FormClose(Sender: TObject; var Action: TCloseAction); private { Private declarations } procedure DoSearchReplaceText; @@ -76,12 +76,8 @@ procedure TfrmSearchReplace.FormCreate(Sender: TObject); end; begin HasSizeGrip := True; - comboSearch.Items.Text := AppSettings.ReadString(asFindDialogSearchHistory); - comboReplace.Items.Text := AppSettings.ReadString(asFindDialogReplaceHistory); comboSearch.Text := ''; comboReplace.Text := ''; - if comboSearch.Items.Count > 0 then comboSearch.Text := comboSearch.Items[0]; - if comboReplace.Items.Count > 0 then comboReplace.Text := comboReplace.Items[0]; AddItem(popupSearchHints, '^', 'Start of line', '', True); AddItem(popupSearchHints, '$', 'End of line', '', True); @@ -110,55 +106,78 @@ procedure TfrmSearchReplace.FormCreate(Sender: TObject); procedure TfrmSearchReplace.FormShow(Sender: TObject); var - SearchText, ObjName: String; - _Editor: TSynMemo; - _Grid: TVirtualStringTree; - IsQueryTab: Boolean; + SearchText, ItemLabel: String; + QueryMemo, AnySynMemo, UsedSynMemo: TSynMemo; + ResultGrid: TVirtualStringTree; + QueryTabOpen, IsGridTextEditor, IsEditorWritable: Boolean; + ActiveQueryTab: TQueryTab; begin // Populate "Search in" pulldown with grid and editor - _Editor := MainForm.ActiveSynMemo(False); - _Grid := MainForm.ActiveGrid; comboSearchIn.Items.Clear; - IsQueryTab := MainForm.IsQueryTab(MainForm.PageControlMain.ActivePageIndex, True); + ActiveQueryTab := MainForm.QueryTabs.ActiveTab; + QueryTabOpen := Assigned(ActiveQueryTab); SearchText := ''; - - if Assigned(_Editor) then begin - ObjName := _('SQL editor'); - if IsQueryTab then - ObjName := ObjName + ': ' + MainForm.ActiveQueryTab.TabSheet.Caption; - comboSearchIn.Items.AddObject(ObjName, _Editor); - if _Editor.Focused then + UsedSynMemo := nil; + + QueryMemo := MainForm.QueryTabs.ActiveMemo; + AnySynMemo := MainForm.ActiveSynMemo(True); + if Assigned(AnySynMemo) then begin + IsEditorWritable := not AnySynMemo.ReadOnly; // Support views and procedure editors + IsGridTextEditor := GetParentForm(AnySynMemo) is TfrmTextEditor; // Support grid text editor, read-only or not + if IsEditorWritable or IsGridTextEditor then + UsedSynMemo := AnySynMemo; + end; + if not Assigned(UsedSynMemo) then begin + UsedSynMemo := QueryMemo; + end; + if Assigned(UsedSynMemo) then begin + if UsedSynMemo = QueryMemo then + ItemLabel := _('SQL editor') + ': ' + ActiveQueryTab.TabSheet.Caption + else + ItemLabel := GetParentForm(UsedSynMemo).Caption; + comboSearchIn.Items.AddObject(ItemLabel, UsedSynMemo); + if UsedSynMemo.Focused then comboSearchIn.ItemIndex := comboSearchIn.Items.Count-1; - if _Editor.SelAvail then - SearchText := _Editor.SelText + if UsedSynMemo.SelAvail then + SearchText := UsedSynMemo.SelText else - SearchText := _Editor.WordAtCursor; + SearchText := UsedSynMemo.WordAtCursor; end; - if Assigned(_Grid) then begin - ObjName := _('Data grid'); - if IsQueryTab then - ObjName := _('Result grid')+': '+MainForm.ActiveQueryTab.tabsetQuery.Tabs[MainForm.ActiveQueryTab.tabsetQuery.TabIndex]; - comboSearchIn.Items.AddObject(ObjName, _Grid); - if _Grid.Focused then + ResultGrid := MainForm.ActiveGrid; + if Assigned(ResultGrid) then begin + if QueryTabOpen then + ItemLabel := _('Result grid')+': '+ActiveQueryTab.tabsetQuery.Tabs[ActiveQueryTab.tabsetQuery.TabIndex] + else + ItemLabel := _('Data Grid'); + comboSearchIn.Items.AddObject(ItemLabel, ResultGrid); + if ResultGrid.Focused then comboSearchIn.ItemIndex := comboSearchIn.Items.Count-1; - if Assigned(_Grid.FocusedNode) then - SearchText := _Grid.Text[_Grid.FocusedNode, _Grid.FocusedColumn]; + if Assigned(ResultGrid.FocusedNode) then + SearchText := ResultGrid.Text[ResultGrid.FocusedNode, ResultGrid.FocusedColumn]; end; - if (comboSearchIn.ItemIndex = -1) and (comboSearchIn.Items.Count > 0) then + if (comboSearchIn.ItemIndex = -1) and (comboSearchIn.Items.Count > 0) then begin comboSearchIn.ItemIndex := 0; + end; + comboSearch.Items.Text := AppSettings.ReadString(asFindDialogSearchHistory); + comboReplace.Items.Text := AppSettings.ReadString(asFindDialogReplaceHistory); // Prefill search editor with selected text if SearchText <> '' then - comboSearch.Text := SearchText; + comboSearch.Text := SearchText + else if comboSearch.Items.Count > 0 then + comboSearch.Text := comboSearch.Items[0]; + if comboReplace.Items.Count > 0 then + comboReplace.Text := comboReplace.Items[0]; ValidateControls(Sender); comboSearch.SetFocus; end; -procedure TfrmSearchReplace.FormDestroy(Sender: TObject); +procedure TfrmSearchReplace.FormClose(Sender: TObject; + var Action: TCloseAction); begin AppSettings.WriteString(asFindDialogSearchHistory, comboSearch.Items.Text); AppSettings.WriteString(asFindDialogReplaceHistory, comboReplace.Items.Text); @@ -175,11 +194,16 @@ function TfrmSearchReplace.GetEditor: TSynMemo; function TfrmSearchReplace.GetGrid: TVirtualStringTree; +var + o: TObject; begin // Return selected target object as grid Result := nil; - if (comboSearchIn.ItemIndex > -1) and (comboSearchIn.Items.Objects[comboSearchIn.ItemIndex] is TVirtualStringTree) then - Result := comboSearchIn.Items.Objects[comboSearchIn.ItemIndex] as TVirtualStringTree; + if comboSearchIn.ItemIndex > -1 then begin + o := comboSearchIn.Items.Objects[comboSearchIn.ItemIndex]; + if (o <> nil) and (o is TVirtualStringTree) then + Result := o as TVirtualStringTree; + end; end; @@ -282,10 +306,12 @@ procedure TfrmSearchReplace.DoSearchReplace(Sender: TObject); Include(Options, ssoBackwards); end; - if Editor <> nil then + if Assigned(Editor) then DoSearchReplaceText + else if Assigned(Grid) then + DoSearchReplaceData else - DoSearchReplaceData; + ErrorDialog(_('No area selected')); end; @@ -308,21 +334,35 @@ procedure TfrmSearchReplace.DoSearchReplaceText; Editor.BeginUpdate; MainForm.ShowStatusMsg(_('Searching ...')); - Occurences := Editor.SearchReplace( - comboSearch.Text, - Replacement, - Options - ); + Occurences := -1; // So we can test whether an exception happened + try + Occurences := Editor.SearchReplace( + comboSearch.Text, + Replacement, + Options + ); + except + on E:Exception do begin + ErrorDialog(E.ClassName + ': ' + E.Message); + ModalResult := mrNone; + end; + end; Editor.EndUpdate; MainForm.ShowStatusMsg; - if ssoReplaceAll in Options then - MessageDialog(f_('Text "%s" replaced %s times.', [comboSearch.Text, FormatNumber(Occurences)]), mtInformation, [mbOk]) - else begin - if (OldCaretXY.Char = Editor.CaretXY.Char) and - (OldCaretXY.Line = Editor.CaretXY.Line) then - MessageDialog(f_('Text "%s" not found.', [comboSearch.Text]), mtInformation, [mbOk]); + if Occurences > -1 then begin + if ssoReplaceAll in Options then begin + MessageDialog(f_('Text "%s" replaced %s times.', [comboSearch.Text, FormatNumber(Occurences)]), mtInformation, [mbOk]); + if Occurences = 0 then + ModalResult := mrNone; + end else begin + if (OldCaretXY.Char = Editor.CaretXY.Char) and + (OldCaretXY.Line = Editor.CaretXY.Line) then begin + MessageDialog(f_('Text "%s" not found.', [comboSearch.Text]), mtInformation, [mbOk]); + ModalResult := mrNone; + end; + end; end; end; @@ -337,6 +377,7 @@ procedure TfrmSearchReplace.DoSearchReplaceData; rx: TRegExpr; Prompt: TModalResult; ReplaceFlags: TReplaceFlags; + NodeSelected: Boolean; begin // Data grid version of DoSearchReplaceText MainForm.ShowStatusMsg(_('Searching ...')); @@ -357,6 +398,7 @@ procedure TfrmSearchReplace.DoSearchReplaceData; ReplaceFlags := [rfReplaceAll]; if not (ssoMatchCase in Options) then Include(ReplaceFlags, rfIgnoreCase); + NodeSelected := True; // Init regular expression rx := TRegExpr.Create; @@ -377,9 +419,9 @@ procedure TfrmSearchReplace.DoSearchReplaceData; end else begin Node := Grid.FocusedNode; if Backwards then - StartAtCol := Grid.Header.Columns.GetPreviousVisibleColumn(Grid.FocusedColumn) + StartAtCol := Grid.Header.Columns.GetPreviousVisibleColumn(Grid.FocusedColumn, True) else - StartAtCol := Grid.Header.Columns.GetNextVisibleColumn(Grid.FocusedColumn); + StartAtCol := Grid.Header.Columns.GetNextVisibleColumn(Grid.FocusedColumn, True); // Advance to next row if focused column is the very last column if StartAtCol = InvalidColumn then begin if Backwards then @@ -398,9 +440,9 @@ procedure TfrmSearchReplace.DoSearchReplaceData; StartAtCol := InvalidColumn; end else begin if Backwards then - Column := Grid.Header.Columns.GetLastVisibleColumn + Column := Grid.Header.Columns.GetLastVisibleColumn(True) else - Column := Grid.Header.Columns.GetFirstVisibleColumn; + Column := Grid.Header.Columns.GetFirstVisibleColumn(True); end; while Column >= 0 do begin @@ -419,7 +461,9 @@ procedure TfrmSearchReplace.DoSearchReplaceData; Inc(MatchCount); // Set focus on node and column - SelectNode(Grid, Node); + NodeSelected := SelectNode(Grid, Node, not SelectedOnly); + if not NodeSelected then + Break; Grid.FocusedColumn := Column; // Replace logic @@ -453,13 +497,15 @@ procedure TfrmSearchReplace.DoSearchReplaceData; // Advance to next column if Backwards then - Column := Grid.Header.Columns.GetPreviousVisibleColumn(Column) + Column := Grid.Header.Columns.GetPreviousVisibleColumn(Column, True) else - Column := Grid.Header.Columns.GetNextVisibleColumn(Column); + Column := Grid.Header.Columns.GetNextVisibleColumn(Column, True); end; if Match and (not (ssoReplaceAll in Options)) then Break; + if not NodeSelected then + Break; if Backwards then Node := GetPreviousNode(Grid, Node, SelectedOnly) @@ -467,13 +513,13 @@ procedure TfrmSearchReplace.DoSearchReplaceData; Node := GetNextNode(Grid, Node, SelectedOnly); end; - if ssoReplaceAll in Options then begin - if MatchCount > 0 then - MessageDialog(f_('Text "%s" %d times replaced.', [Search, ReplaceCount]), mtInformation, [mbOk]) - else - MessageDialog(f_('Text "%s" not found.', [Search]), mtInformation, [mbOk]); - end else if MatchCount = 0 then + if (ssoReplaceAll in Options) and (MatchCount > 0) then begin + MessageDialog(f_('Text "%s" %d times replaced.', [Search, ReplaceCount]), mtInformation, [mbOk]) + end; + if MatchCount = 0 then begin MessageDialog(f_('Text "%s" not found.', [Search]), mtInformation, [mbOk]); + ModalResult := mrNone; + end; MainForm.ShowStatusMsg; end; diff --git a/source/selectdbobject.dfm b/source/selectdbobject.dfm index d95046e82..7dac5573a 100644 --- a/source/selectdbobject.dfm +++ b/source/selectdbobject.dfm @@ -9,10 +9,9 @@ object frmSelectDBObject: TfrmSelectDBObject Constraints.MinWidth = 200 Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText - Font.Height = -11 + Font.Height = -12 Font.Name = 'Tahoma' Font.Style = [] - OldCreateOrder = False Position = poOwnerFormCenter OnCreate = FormCreate OnDestroy = FormDestroy @@ -20,8 +19,7 @@ object frmSelectDBObject: TfrmSelectDBObject DesignSize = ( 232 316) - PixelsPerInch = 96 - TextHeight = 13 + TextHeight = 14 object lblSelect: TLabel Left = 8 Top = 8 @@ -58,6 +56,8 @@ object frmSelectDBObject: TfrmSelectDBObject OnGetNodeDataSize = TreeDBOGetNodeDataSize OnInitChildren = TreeDBOInitChildren OnInitNode = TreeDBOInitNode + Touch.InteractiveGestures = [igPan, igPressAndTap] + Touch.InteractiveGestureOptions = [igoPanSingleFingerHorizontal, igoPanSingleFingerVertical, igoPanInertia, igoPanGutter, igoParentPassthrough] Columns = < item Position = 0 diff --git a/source/selectdbobject.pas b/source/selectdbobject.pas index d8b7314be..9e5564e95 100644 --- a/source/selectdbobject.pas +++ b/source/selectdbobject.pas @@ -3,8 +3,9 @@ interface uses - Windows, Classes, Controls, Forms, StdCtrls, VirtualTrees, Graphics, extra_controls, - dbconnection, gnugettext; + Winapi.Windows, System.Classes, Vcl.Controls, Vcl.Forms, Vcl.StdCtrls, VirtualTrees.BaseTree, VirtualTrees.Types, VirtualTrees, Vcl.Graphics, extra_controls, + dbconnection, gnugettext, VirtualTrees.BaseAncestorVCL, + VirtualTrees.AncestorVCL; type TfrmSelectDBObject = class(TExtForm) @@ -66,8 +67,6 @@ function SelectDBObjects: TDBObjectList; procedure TfrmSelectDBObject.FormCreate(Sender: TObject); begin HasSizeGrip := True; - Width := AppSettings.ReadInt(asSelectDBOWindowWidth); - Height := AppSettings.ReadInt(asSelectDBOWindowHeight); TreeDBO.TreeOptions := MainForm.DBtree.TreeOptions; TreeDBO.TreeOptions.SelectionOptions := TreeDBO.TreeOptions.SelectionOptions + [toMultiSelect]; FixVT(TreeDBO); @@ -76,8 +75,8 @@ procedure TfrmSelectDBObject.FormCreate(Sender: TObject); procedure TfrmSelectDBObject.FormDestroy(Sender: TObject); begin - AppSettings.WriteInt(asSelectDBOWindowWidth, Width); - AppSettings.WriteInt(asSelectDBOWindowHeight, Height); + AppSettings.WriteIntDpiAware(asSelectDBOWindowWidth, Self, Width); + AppSettings.WriteIntDpiAware(asSelectDBOWindowHeight, Self, Height); end; @@ -98,6 +97,8 @@ procedure TfrmSelectDBObject.ValidateControls(Sender: TObject); procedure TfrmSelectDBObject.FormShow(Sender: TObject); begin + Width := AppSettings.ReadIntDpiAware(asSelectDBOWindowWidth, Self); + Height := AppSettings.ReadIntDpiAware(asSelectDBOWindowHeight, Self); TreeDBO.Clear; TreeDBO.RootNodeCount := Mainform.DBtree.RootNodeCount; TreeDBO.OnFocusChanged(TreeDBO, TreeDBO.FocusedNode, 0); diff --git a/source/sizegrip/SizeGrip.pas b/source/sizegrip/SizeGrip.pas index 8ed16059a..d4cdc4e57 100644 --- a/source/sizegrip/SizeGrip.pas +++ b/source/sizegrip/SizeGrip.pas @@ -1,367 +1,367 @@ -{ - SizeGrip.pas - - Delphi component to add a size grip (like if you use a status bar) to the - lower right corner of any TWinControl (like TForm). "SizeGripThemed.pas" - is the themed version using the currently selected visual style. See the - included README.txt for more information and how to use it. - - Version 1.2b - always find the most current version at - http://flocke.vssd.de/prog/code/pascal/sizegrip/ - - Copyright (C) 2005, 2006 Volker Siebert - All rights reserved. - - Permission is hereby granted, free of charge, to any person obtaining a - copy of this software and associated documentation files (the "Software"), - to deal in the Software without restriction, including without limitation - the rights to use, copy, modify, merge, publish, distribute, sublicense, - and/or sell copies of the Software, and to permit persons to whom the - Software is furnished to do so, subject to the following conditions: - - The above copyright notice and this permission notice shall be included in - all copies or substantial portions of the Software. - - THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR - IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, - FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE - AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING - FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER - DEALINGS IN THE SOFTWARE. -} - -unit SizeGrip; - -interface - -uses - Windows, Messages, SysUtils, Classes, Graphics, Controls; - -type - TSizeGripStyle = ( sgsClassic, sgsWinXP ); - - TSizeGrip = class(TComponent) - private - FTargetControl: TWinControl; // Target control - FEnabled: boolean; // Size grip enabled? - FStyle: TSizeGripStyle; // Display style? - FSizeGripRect: TRect; // Current size grip rectangle - FOldWndProc: TWndMethod; // Hooked window procedure - procedure AttachControl; - procedure DetachControl; - procedure SetTargetControl(const Value: TWinControl); - procedure SetEnabled(const Value: boolean); - procedure SetNewStyle(const Value: TSizeGripStyle); - protected - procedure Notification(AComponent: TComponent; Operation: TOperation); override; - procedure GetGripRect(var Rect: TRect); virtual; - procedure PaintIt(DC: HDC; const Rect: TRect); virtual; - procedure NewWndProc(var Msg: TMessage); virtual; - procedure InvalidateGrip; - procedure UpdateGrip; - public - constructor Create(AOwner: TComponent); override; - destructor Destroy; override; - published - property Enabled: boolean read FEnabled write SetEnabled default true; - property TargetControl: TWinControl read FTargetControl write SetTargetControl; - property Style: TSizeGripStyle read FStyle write SetNewStyle default sgsClassic; - end; - - TSizeGripXP = class(TSizeGrip) - public - constructor Create(AOwner: TComponent); override; - published - property Style default sgsWinXP; - end; - -procedure Register; - -implementation - -type - TWinControlAccess = class(TWinControl); - -const - CEmptyRect: TRect = ( Left: 0; Top: 0; Right: 0; Bottom: 0; ); - -{ TSizeGrip } - -constructor TSizeGrip.Create(AOwner: TComponent); -begin - inherited; - - FEnabled := true; - FStyle := sgsClassic; - - if AOwner.ComponentState * [csLoading, csReading] = [] then - begin - // Automatically take the owner as the target control - if AOwner is TWinControl then - TargetControl := TWinControl(AOwner) - else if AOwner is TControl then - TargetControl := TControl(AOwner).Parent; - end; -end; - -destructor TSizeGrip.Destroy; -begin - TargetControl := nil; - inherited; -end; - -procedure TSizeGrip.Notification(AComponent: TComponent; Operation: TOperation); -begin - inherited; - - if Operation = opRemove then - if AComponent = FTargetControl then - TargetControl := nil; -end; - -{ Invalidate the current grip rectangle -} -procedure TSizeGrip.InvalidateGrip; -begin - if (FTargetControl <> nil) and - (FSizeGripRect.Right > FSizeGripRect.Left) and - (FSizeGripRect.Bottom > FSizeGripRect.Top) then - if FTargetControl.HandleAllocated then - InvalidateRect(FTargetControl.Handle, @FSizeGripRect, TRUE); -end; - -{ Update (and invalidate) the current grip rectangle -} -procedure TSizeGrip.UpdateGrip; -begin - GetGripRect(FSizeGripRect); - InvalidateGrip; -end; - -{ Attach to FTargetControl: subclass to catch WM_SIZE, WM_ERASEBKGND and - WM_NCHITTEST. -} -procedure TSizeGrip.AttachControl; -begin - if @FOldWndProc = nil then - if ([csDesigning, csDestroying] * ComponentState = []) and - (FTargetControl <> nil) and - FEnabled and - ([csDesigning, csDestroying] * FTargetControl.ComponentState = []) then - begin - FOldWndProc := FTargetControl.WindowProc; - FTargetControl.WindowProc := NewWndProc; - UpdateGrip; - end; -end; - -{ Detach from FTargetControl: remove subclassing. -} -procedure TSizeGrip.DetachControl; -begin - if @FOldWndProc <> nil then - begin - FTargetControl.WindowProc := FOldWndProc; - FOldWndProc := nil; - - InvalidateGrip; - FSizeGripRect := CEmptyRect; - end; -end; - -{ Set the target control -} -procedure TSizeGrip.SetTargetControl(const Value: TWinControl); -begin - if Value <> FTargetControl then - begin - if FTargetControl <> nil then - FTargetControl.RemoveFreeNotification(Self); - - DetachControl; - FTargetControl := Value; - AttachControl; - - if FTargetControl <> nil then - FTargetControl.FreeNotification(Self); - end; -end; - -{ Toggle enabled / disabled flag -} -procedure TSizeGrip.SetEnabled(const Value: boolean); -begin - if FEnabled <> Value then - begin - DetachControl; - FEnabled := Value; - AttachControl; - end; -end; - -{ Toggle new style flag -} -procedure TSizeGrip.SetNewStyle(const Value: TSizeGripStyle); -begin - if FStyle <> Value then - begin - FStyle := Value; - InvalidateGrip; - end; -end; - -{ The new Window procedure for the attached target control. -} -procedure TSizeGrip.NewWndProc(var Msg: TMessage); -var - pt: TPoint; - dc: HDC; -begin - if (not Assigned(FOldWndProc)) or (FTargetControl = nil) then - exit; - - case Msg.Msg of - WM_PAINT: begin - FOldWndProc(Msg); - if TWMPaint(Msg).DC = 0 then - begin - dc := GetDC(FTargetControl.Handle); - try - PaintIt(dc, FSizeGripRect); - finally - ReleaseDC(FTargetControl.Handle, dc); - end; - end - end; - - WM_NCHITTEST: begin - with TWMNcHitTest(Msg) do - pt := FTargetControl.ScreenToClient(Point(XPos, YPos)); - if not PtInRect(FSizeGripRect, pt) then - FOldWndProc(TMessage(Msg)) - else if TargetControl.UseRightToLeftScrollBar then - Msg.Result := HTBOTTOMLEFT - else - Msg.Result := HTBOTTOMRIGHT; - end; - - WM_SIZE: begin - InvalidateGrip; - FOldWndProc(Msg); - UpdateGrip; - end; - - else - FOldWndProc(Msg); - end; -end; - -{ Calculate the size grip's rectangle -} -procedure TSizeGrip.GetGripRect(var Rect: TRect); -begin - if FTargetControl <> nil then - begin - Rect := FTargetControl.ClientRect; - if TargetControl.UseRightToLeftScrollBar then - Rect.Right := Rect.Left + 15 - else - Rect.Left := Rect.Right - 15; - Rect.Top := Rect.Bottom - 15; - end - else - Rect := CEmptyRect; -end; - -{ Paint the size grip -} -procedure TSizeGrip.PaintIt(DC: HDC; const Rect: TRect); -const - StartX = 4; - StartY = 4; -var - ch, cm, cs: COLORREF; - - procedure Paint3(clr: COLORREF; delta: integer); - var - pen, oldpen: HPen; - begin - pen := CreatePen(PS_SOLID, 0, clr); - try - oldpen := SelectObject(DC, pen); - try - MoveToEx(DC, Rect.Right - delta, Rect.Bottom - 1, nil); - LineTo(DC, Rect.Right, Rect.Bottom - 1 - delta); - inc(delta, 4); - MoveToEx(DC, Rect.Right - delta, Rect.Bottom - 1, nil); - LineTo(DC, Rect.Right, Rect.Bottom - 1 - delta); - inc(delta, 4); - MoveToEx(DC, Rect.Right - delta, Rect.Bottom - 1, nil); - LineTo(DC, Rect.Right, Rect.Bottom - 1 - delta); - finally - SelectObject(DC, oldpen); - end; - finally - DeleteObject(pen); - end; - end; - - procedure PaintBox(x, y: integer); - begin - SetPixel(DC, x, y, cs); - SetPixel(DC, x + 1, y, cs); - SetPixel(DC, x, y + 1, cs); - SetPixel(DC, x + 1, y + 1, cm); - SetPixel(DC, x + 2, y + 1, ch); - SetPixel(DC, x + 1, y + 2, ch); - SetPixel(DC, x + 2, y + 2, ch); - end; - - function MixColors(c1, c2: COLORREF): COLORREF; - begin - Result := RGB((GetRValue(c1) + GetRValue(c2)) div 2, - (GetGValue(c1) + GetGValue(c2)) div 2, - (GetBValue(c1) + GetBValue(c2)) div 2); - end; - -begin - ch := ColorToRgb(clBtnHighlight); - cs := ColorToRgb(clBtnShadow); - // Original look is cm := cs! - cm := MixColors(ColorToRgb(TWinControlAccess(FTargetControl).Color), cs); - - case FStyle of - sgsWinXP: begin - PaintBox(Rect.Right - StartX, Rect.Bottom - StartY - 8); - PaintBox(Rect.Right - StartX - 4, Rect.Bottom - StartY - 4); - PaintBox(Rect.Right - StartX, Rect.Bottom - StartY - 4); - PaintBox(Rect.Right - StartX - 8, Rect.Bottom - StartY); - PaintBox(Rect.Right - StartX - 4, Rect.Bottom - StartY); - PaintBox(Rect.Right - StartX, Rect.Bottom - StartY); - end; - - else begin - Paint3(cs, 2); - Paint3(cm, 3); - Paint3(ch, 4); - end; - end; -end; - -{ TSizeGripXP } - -constructor TSizeGripXP.Create(AOwner: TComponent); -begin - inherited; - FStyle := sgsWinXP; -end; - -{ Register } - -procedure Register; -begin - RegisterComponents('System', [TSizeGrip, TSizeGripXP]); -end; - -end. +{ + SizeGrip.pas + + Delphi component to add a size grip (like if you use a status bar) to the + lower right corner of any TWinControl (like TForm). "SizeGripThemed.pas" + is the themed version using the currently selected visual style. See the + included README.txt for more information and how to use it. + + Version 1.2b - always find the most current version at + http://flocke.vssd.de/prog/code/pascal/sizegrip/ + + Copyright (C) 2005, 2006 Volker Siebert + All rights reserved. + + Permission is hereby granted, free of charge, to any person obtaining a + copy of this software and associated documentation files (the "Software"), + to deal in the Software without restriction, including without limitation + the rights to use, copy, modify, merge, publish, distribute, sublicense, + and/or sell copies of the Software, and to permit persons to whom the + Software is furnished to do so, subject to the following conditions: + + The above copyright notice and this permission notice shall be included in + all copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING + FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER + DEALINGS IN THE SOFTWARE. +} + +unit SizeGrip; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, System.Types; + +type + TSizeGripStyle = ( sgsClassic, sgsWinXP ); + + TSizeGrip = class(TComponent) + private + FTargetControl: TWinControl; // Target control + FEnabled: boolean; // Size grip enabled? + FStyle: TSizeGripStyle; // Display style? + FSizeGripRect: TRect; // Current size grip rectangle + FOldWndProc: TWndMethod; // Hooked window procedure + procedure AttachControl; + procedure DetachControl; + procedure SetTargetControl(const Value: TWinControl); + procedure SetEnabled(const Value: boolean); + procedure SetNewStyle(const Value: TSizeGripStyle); + protected + procedure Notification(AComponent: TComponent; Operation: TOperation); override; + procedure GetGripRect(var Rect: TRect); virtual; + procedure PaintIt(DC: HDC; const Rect: TRect); virtual; + procedure NewWndProc(var Msg: TMessage); virtual; + procedure InvalidateGrip; + procedure UpdateGrip; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + published + property Enabled: boolean read FEnabled write SetEnabled default true; + property TargetControl: TWinControl read FTargetControl write SetTargetControl; + property Style: TSizeGripStyle read FStyle write SetNewStyle default sgsClassic; + end; + + TSizeGripXP = class(TSizeGrip) + public + constructor Create(AOwner: TComponent); override; + published + property Style default sgsWinXP; + end; + +procedure Register; + +implementation + +type + TWinControlAccess = class(TWinControl); + +const + CEmptyRect: TRect = ( Left: 0; Top: 0; Right: 0; Bottom: 0; ); + +{ TSizeGrip } + +constructor TSizeGrip.Create(AOwner: TComponent); +begin + inherited; + + FEnabled := true; + FStyle := sgsClassic; + + if AOwner.ComponentState * [csLoading, csReading] = [] then + begin + // Automatically take the owner as the target control + if AOwner is TWinControl then + TargetControl := TWinControl(AOwner) + else if AOwner is TControl then + TargetControl := TControl(AOwner).Parent; + end; +end; + +destructor TSizeGrip.Destroy; +begin + TargetControl := nil; + inherited; +end; + +procedure TSizeGrip.Notification(AComponent: TComponent; Operation: TOperation); +begin + inherited; + + if Operation = opRemove then + if AComponent = FTargetControl then + TargetControl := nil; +end; + +{ Invalidate the current grip rectangle +} +procedure TSizeGrip.InvalidateGrip; +begin + if (FTargetControl <> nil) and + (FSizeGripRect.Right > FSizeGripRect.Left) and + (FSizeGripRect.Bottom > FSizeGripRect.Top) then + if FTargetControl.HandleAllocated then + InvalidateRect(FTargetControl.Handle, @FSizeGripRect, TRUE); +end; + +{ Update (and invalidate) the current grip rectangle +} +procedure TSizeGrip.UpdateGrip; +begin + GetGripRect(FSizeGripRect); + InvalidateGrip; +end; + +{ Attach to FTargetControl: subclass to catch WM_SIZE, WM_ERASEBKGND and + WM_NCHITTEST. +} +procedure TSizeGrip.AttachControl; +begin + if @FOldWndProc = nil then + if ([csDesigning, csDestroying] * ComponentState = []) and + (FTargetControl <> nil) and + FEnabled and + ([csDesigning, csDestroying] * FTargetControl.ComponentState = []) then + begin + FOldWndProc := FTargetControl.WindowProc; + FTargetControl.WindowProc := NewWndProc; + UpdateGrip; + end; +end; + +{ Detach from FTargetControl: remove subclassing. +} +procedure TSizeGrip.DetachControl; +begin + if @FOldWndProc <> nil then + begin + FTargetControl.WindowProc := FOldWndProc; + FOldWndProc := nil; + + InvalidateGrip; + FSizeGripRect := CEmptyRect; + end; +end; + +{ Set the target control +} +procedure TSizeGrip.SetTargetControl(const Value: TWinControl); +begin + if Value <> FTargetControl then + begin + if FTargetControl <> nil then + FTargetControl.RemoveFreeNotification(Self); + + DetachControl; + FTargetControl := Value; + AttachControl; + + if FTargetControl <> nil then + FTargetControl.FreeNotification(Self); + end; +end; + +{ Toggle enabled / disabled flag +} +procedure TSizeGrip.SetEnabled(const Value: boolean); +begin + if FEnabled <> Value then + begin + DetachControl; + FEnabled := Value; + AttachControl; + end; +end; + +{ Toggle new style flag +} +procedure TSizeGrip.SetNewStyle(const Value: TSizeGripStyle); +begin + if FStyle <> Value then + begin + FStyle := Value; + InvalidateGrip; + end; +end; + +{ The new Window procedure for the attached target control. +} +procedure TSizeGrip.NewWndProc(var Msg: TMessage); +var + pt: TPoint; + dc: HDC; +begin + if (not Assigned(FOldWndProc)) or (FTargetControl = nil) then + exit; + + case Msg.Msg of + WM_PAINT: begin + FOldWndProc(Msg); + if TWMPaint(Msg).DC = 0 then + begin + dc := GetDC(FTargetControl.Handle); + try + PaintIt(dc, FSizeGripRect); + finally + ReleaseDC(FTargetControl.Handle, dc); + end; + end + end; + + WM_NCHITTEST: begin + with TWMNcHitTest(Msg) do + pt := FTargetControl.ScreenToClient(Point(XPos, YPos)); + if not PtInRect(FSizeGripRect, pt) then + FOldWndProc(TMessage(Msg)) + else if TargetControl.UseRightToLeftScrollBar then + Msg.Result := HTBOTTOMLEFT + else + Msg.Result := HTBOTTOMRIGHT; + end; + + WM_SIZE: begin + InvalidateGrip; + FOldWndProc(Msg); + UpdateGrip; + end; + + else + FOldWndProc(Msg); + end; +end; + +{ Calculate the size grip's rectangle +} +procedure TSizeGrip.GetGripRect(var Rect: TRect); +begin + if FTargetControl <> nil then + begin + Rect := FTargetControl.ClientRect; + if TargetControl.UseRightToLeftScrollBar then + Rect.Right := Rect.Left + 15 + else + Rect.Left := Rect.Right - 15; + Rect.Top := Rect.Bottom - 15; + end + else + Rect := CEmptyRect; +end; + +{ Paint the size grip +} +procedure TSizeGrip.PaintIt(DC: HDC; const Rect: TRect); +const + StartX = 4; + StartY = 4; +var + ch, cm, cs: COLORREF; + + procedure Paint3(clr: COLORREF; delta: integer); + var + pen, oldpen: HPen; + begin + pen := CreatePen(PS_SOLID, 0, clr); + try + oldpen := SelectObject(DC, pen); + try + MoveToEx(DC, Rect.Right - delta, Rect.Bottom - 1, nil); + LineTo(DC, Rect.Right, Rect.Bottom - 1 - delta); + inc(delta, 4); + MoveToEx(DC, Rect.Right - delta, Rect.Bottom - 1, nil); + LineTo(DC, Rect.Right, Rect.Bottom - 1 - delta); + inc(delta, 4); + MoveToEx(DC, Rect.Right - delta, Rect.Bottom - 1, nil); + LineTo(DC, Rect.Right, Rect.Bottom - 1 - delta); + finally + SelectObject(DC, oldpen); + end; + finally + DeleteObject(pen); + end; + end; + + procedure PaintBox(x, y: integer); + begin + SetPixel(DC, x, y, cs); + SetPixel(DC, x + 1, y, cs); + SetPixel(DC, x, y + 1, cs); + SetPixel(DC, x + 1, y + 1, cm); + SetPixel(DC, x + 2, y + 1, ch); + SetPixel(DC, x + 1, y + 2, ch); + SetPixel(DC, x + 2, y + 2, ch); + end; + + function MixColors(c1, c2: COLORREF): COLORREF; + begin + Result := RGB((GetRValue(c1) + GetRValue(c2)) div 2, + (GetGValue(c1) + GetGValue(c2)) div 2, + (GetBValue(c1) + GetBValue(c2)) div 2); + end; + +begin + ch := ColorToRgb(clBtnHighlight); + cs := ColorToRgb(clBtnShadow); + // Original look is cm := cs! + cm := MixColors(ColorToRgb(TWinControlAccess(FTargetControl).Color), cs); + + case FStyle of + sgsWinXP: begin + PaintBox(Rect.Right - StartX, Rect.Bottom - StartY - 8); + PaintBox(Rect.Right - StartX - 4, Rect.Bottom - StartY - 4); + PaintBox(Rect.Right - StartX, Rect.Bottom - StartY - 4); + PaintBox(Rect.Right - StartX - 8, Rect.Bottom - StartY); + PaintBox(Rect.Right - StartX - 4, Rect.Bottom - StartY); + PaintBox(Rect.Right - StartX, Rect.Bottom - StartY); + end; + + else begin + Paint3(cs, 2); + Paint3(cm, 3); + Paint3(ch, 4); + end; + end; +end; + +{ TSizeGripXP } + +constructor TSizeGripXP.Create(AOwner: TComponent); +begin + inherited; + FStyle := sgsWinXP; +end; + +{ Register } + +procedure Register; +begin + RegisterComponents('System', [TSizeGrip, TSizeGripXP]); +end; + +end. diff --git a/source/sqlhelp.dfm b/source/sqlhelp.dfm index 338d546a3..52fe0273a 100644 --- a/source/sqlhelp.dfm +++ b/source/sqlhelp.dfm @@ -7,17 +7,14 @@ object frmSQLhelp: TfrmSQLhelp Color = clBtnFace Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText - Font.Height = -11 + Font.Height = -12 Font.Name = 'Tahoma' Font.Style = [] FormStyle = fsStayOnTop - OldCreateOrder = False OnClose = FormClose OnCreate = FormCreate - OnDestroy = FormDestroy OnShow = FormShow - PixelsPerInch = 96 - TextHeight = 13 + TextHeight = 14 object btnSearchOnline: TButton Left = 363 Top = 322 @@ -103,6 +100,7 @@ object frmSQLhelp: TfrmSQLhelp Margins.Right = 0 Margins.Bottom = 0 Align = alClient + Constraints.MinWidth = 30 Header.AutoSizeIndex = 0 Header.MainColumn = -1 Images = MainForm.VirtualImageListMain @@ -115,6 +113,8 @@ object frmSQLhelp: TfrmSQLhelp OnGetNodeDataSize = treeTopicsGetNodeDataSize OnInitChildren = treeTopicsInitChildren OnInitNode = treeTopicsInitNode + Touch.InteractiveGestures = [igPan, igPressAndTap] + Touch.InteractiveGestureOptions = [igoPanSingleFingerHorizontal, igoPanSingleFingerVertical, igoPanInertia, igoPanGutter, igoParentPassthrough] Columns = <> end end @@ -174,6 +174,7 @@ object frmSQLhelp: TfrmSQLhelp Height = 153 SingleLineMode = False Align = alTop + Constraints.MinHeight = 30 Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText Font.Height = -13 @@ -181,6 +182,14 @@ object frmSQLhelp: TfrmSQLhelp Font.Style = [] TabOrder = 0 OnKeyDown = memosKeyDown + CodeFolding.GutterShapeSize = 11 + CodeFolding.CollapsedLineColor = clGrayText + CodeFolding.FolderBarLinesColor = clGrayText + CodeFolding.IndentGuidesColor = clGray + CodeFolding.IndentGuides = True + CodeFolding.ShowCollapsedLine = False + CodeFolding.ShowHintMark = True + UseCodeFolding = False Gutter.Font.Charset = DEFAULT_CHARSET Gutter.Font.Color = clWindowText Gutter.Font.Height = -11 @@ -201,6 +210,7 @@ object frmSQLhelp: TfrmSQLhelp Height = 104 SingleLineMode = False Align = alClient + Constraints.MinHeight = 30 Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText Font.Height = -13 @@ -208,6 +218,14 @@ object frmSQLhelp: TfrmSQLhelp Font.Style = [] TabOrder = 1 OnKeyDown = memosKeyDown + CodeFolding.GutterShapeSize = 11 + CodeFolding.CollapsedLineColor = clGrayText + CodeFolding.FolderBarLinesColor = clGrayText + CodeFolding.IndentGuidesColor = clGray + CodeFolding.IndentGuides = True + CodeFolding.ShowCollapsedLine = False + CodeFolding.ShowHintMark = True + UseCodeFolding = False Gutter.Font.Charset = DEFAULT_CHARSET Gutter.Font.Color = clWindowText Gutter.Font.Height = -11 diff --git a/source/sqlhelp.pas b/source/sqlhelp.pas index df56753ac..103a99031 100644 --- a/source/sqlhelp.pas +++ b/source/sqlhelp.pas @@ -3,10 +3,11 @@ interface uses - Windows, SysUtils, Classes, Controls, Forms, Dialogs, StdCtrls, ComCtrls, ExtCtrls, - Buttons, SynMemo, SynEditHighlighter, SynHighlighterURI, extra_controls, - SynURIOpener, SynEdit, VirtualTrees, Graphics, - dbconnection, gnugettext; + Winapi.Windows, System.SysUtils, System.Classes, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ComCtrls, Vcl.ExtCtrls, + Vcl.Buttons, SynMemo, SynEditHighlighter, SynHighlighterURI, extra_controls, + SynURIOpener, SynEdit, VirtualTrees, Vcl.Graphics, + dbconnection, gnugettext, VirtualTrees.BaseTree, VirtualTrees.Types, + VirtualTrees.BaseAncestorVCL, VirtualTrees.AncestorVCL, dbstructures; type TfrmSQLhelp = class(TExtForm) @@ -29,7 +30,6 @@ TfrmSQLhelp = class(TExtForm) MemoExample: TSynMemo; timerSearch: TTimer; procedure FormCreate(Sender: TObject); - procedure FormDestroy(Sender: TObject); procedure memosKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); procedure ButtonOnlinehelpClick(Sender: TObject); @@ -86,12 +86,6 @@ procedure TfrmSQLhelp.FormCreate(Sender: TObject); begin // Set window-layout lblKeyword.Font.Style := [fsBold]; - Top := AppSettings.ReadInt(asSQLHelpWindowTop); - Left := AppSettings.ReadInt(asSQLHelpWindowLeft); - Width := AppSettings.ReadInt(asSQLHelpWindowWidth); - Height := AppSettings.ReadInt(asSQLHelpWindowHeight); - pnlLeft.Width := AppSettings.ReadInt(asSQLHelpPnlLeftWidth); - memoDescription.Height := AppSettings.ReadInt(asSQLHelpPnlRightTopHeight); Caption := DEFAULT_WINDOW_CAPTION; FixVT(treeTopics); HasSizeGrip := True; @@ -99,14 +93,21 @@ procedure TfrmSQLhelp.FormCreate(Sender: TObject); treeTopics.Clear; FreeAndNil(FRootTopics); FConnection := MainForm.ActiveConnection; - FRootTopics := FConnection.GetResults('HELP '+FConnection.EscapeString('CONTENTS')); + FRootTopics := FConnection.GetResults(FConnection.SqlProvider.GetSql(qHelpKeyword, [FConnection.EscapeString('CONTENTS')])); treeTopics.RootNodeCount := FRootTopics.RecordCount; end; procedure TfrmSQLhelp.FormClose(Sender: TObject; var Action: TCloseAction); begin + AppSettings.WriteInt(asSQLHelpWindowLeft, Left ); + AppSettings.WriteInt(asSQLHelpWindowTop, Top ); + AppSettings.WriteIntDpiAware(asSQLHelpWindowWidth, Self, Width); + AppSettings.WriteIntDpiAware(asSQLHelpWindowHeight, Self, Height); + AppSettings.WriteIntDpiAware(asSQLHelpPnlLeftWidth, Self, pnlLeft.Width); + AppSettings.WriteIntDpiAware(asSQLHelpPnlRightTopHeight, Self, memoDescription.Height); Action := caFree; + SqlHelpDialog := nil; end; @@ -123,14 +124,14 @@ procedure TfrmSQLhelp.treeTopicsFocusChanged(Sender: TBaseVirtualTree; Node: PVi if VT.HasChildren[VT.FocusedNode] then Exit; FKeyword := VT.Text[VT.FocusedNode, VT.FocusedColumn]; - lblKeyword.Caption := Copy(FKeyword, 0, 100); + lblKeyword.Caption := Copy(FKeyword, 1, 100); MemoDescription.Lines.Clear; MemoExample.Lines.Clear; Caption := DEFAULT_WINDOW_CAPTION; if FKeyword <> '' then try Screen.Cursor := crHourglass; - Results := FConnection.GetResults('HELP '+FConnection.EscapeString(FKeyword)); + Results := FConnection.GetResults(FConnection.SqlProvider.GetSql(qHelpKeyword, [FConnection.EscapeString(FKeyword)])); Caption := Caption + ' - ' + FKeyword; MemoDescription.Text := fixNewlines(Results.Col('description', True)); MemoExample.Text := fixNewlines(Results.Col('example', True)); @@ -217,7 +218,7 @@ procedure TfrmSQLhelp.treeTopicsInitChildren(Sender: TBaseVirtualTree; Node: PVi // Return number of children for folder VT := Sender as TVirtualStringTree; Results := VT.GetNodeData(Node); - Results^ := FConnection.GetResults('HELP '+FConnection.EscapeString(VT.Text[Node, VT.Header.MainColumn])); + Results^ := FConnection.GetResults(FConnection.SqlProvider.GetSql(qHelpKeyword, [FConnection.EscapeString(VT.Text[Node, VT.Header.MainColumn])])); ChildCount := Results.RecordCount; end; @@ -262,22 +263,18 @@ procedure TfrmSQLhelp.ButtonCloseClick(Sender: TObject); end; -procedure TfrmSQLhelp.FormDestroy(Sender: TObject); -begin - AppSettings.WriteInt(asSQLHelpWindowLeft, Left ); - AppSettings.WriteInt(asSQLHelpWindowTop, Top ); - AppSettings.WriteInt(asSQLHelpWindowWidth, Width); - AppSettings.WriteInt(asSQLHelpWindowHeight, Height); - AppSettings.WriteInt(asSQLHelpPnlLeftWidth, pnlLeft.Width); - AppSettings.WriteInt(asSQLHelpPnlRightTopHeight, memoDescription.Height); - SqlHelpDialog := nil; -end; - - procedure TfrmSQLhelp.FormShow(Sender: TObject); begin + Top := AppSettings.ReadInt(asSQLHelpWindowTop); + Left := AppSettings.ReadInt(asSQLHelpWindowLeft); + Width := AppSettings.ReadIntDpiAware(asSQLHelpWindowWidth, Self); + Height := AppSettings.ReadIntDpiAware(asSQLHelpWindowHeight, Self); + MakeFullyVisible; + + pnlLeft.Width := AppSettings.ReadIntDpiAware(asSQLHelpPnlLeftWidth, Self); + memoDescription.Height := AppSettings.ReadIntDpiAware(asSQLHelpPnlRightTopHeight, Self); // Apply themed colors in OnShow, not OnCreate, as a check with <> nil returns false otherwise - MainForm.SetupSynEditors; + MainForm.SetupSynEditors(Self); // These SynMemo's don't have any (SQL) highligher, so we have to assign correct colors for basic text memoDescription.Font.Color := GetThemeColor(clWindowText); MemoExample.Font.Color := GetThemeColor(clWindowText); @@ -313,7 +310,7 @@ procedure TfrmSQLhelp.SetKeyword(Value: string); FKeyword := Value; if FKeyword = '' then Exit; - Results := FConnection.GetResults('HELP '+FConnection.EscapeString(FKeyword)); + Results := FConnection.GetResults(FConnection.SqlProvider.GetSql(qHelpKeyword, [FConnection.EscapeString(FKeyword)])); while not Results.Eof do begin if Results.Col('is_it_category', true) = 'N' then begin FKeyword := Results.Col('name'); diff --git a/source/syncdb.dfm b/source/syncdb.dfm index 2aec32f88..84d09a22e 100644 --- a/source/syncdb.dfm +++ b/source/syncdb.dfm @@ -9,18 +9,15 @@ object frmSyncDB: TfrmSyncDB Constraints.MinWidth = 550 Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText - Font.Height = -11 + Font.Height = -12 Font.Name = 'Tahoma' Font.Style = [] - OldCreateOrder = False Position = poMainFormCenter - OnClose = FormClose OnCreate = FormCreate DesignSize = ( 534 362) - PixelsPerInch = 96 - TextHeight = 13 + TextHeight = 14 object lblSource: TLabel Left = 8 Top = 8 @@ -57,6 +54,8 @@ object frmSyncDB: TfrmSyncDB OnGetNodeDataSize = treeSourceGetNodeDataSize OnInitChildren = treeSourceInitChildren OnInitNode = treeSourceInitNode + Touch.InteractiveGestures = [igPan, igPressAndTap] + Touch.InteractiveGestureOptions = [igoPanSingleFingerHorizontal, igoPanSingleFingerVertical, igoPanInertia, igoPanGutter, igoParentPassthrough] Columns = < item Position = 0 @@ -213,6 +212,8 @@ object frmSyncDB: TfrmSyncDB OnGetNodeDataSize = treeDifferencesGetNodeDataSize OnInitChildren = treeDifferencesInitChildren OnInitNode = treeDifferencesInitNode + Touch.InteractiveGestures = [igPan, igPressAndTap] + Touch.InteractiveGestureOptions = [igoPanSingleFingerHorizontal, igoPanSingleFingerVertical, igoPanInertia, igoPanGutter, igoParentPassthrough] Columns = <> end end diff --git a/source/syncdb.pas b/source/syncdb.pas index ddcf4bd6f..28a2a1823 100644 --- a/source/syncdb.pas +++ b/source/syncdb.pas @@ -3,9 +3,10 @@ interface uses - Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, - Dialogs, StdCtrls, Generics.Collections, VirtualTrees, extra_controls, - dbconnection, gnugettext; + Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, + Vcl.Dialogs, Vcl.StdCtrls, System.Generics.Collections, VirtualTrees, extra_controls, + dbconnection, gnugettext, VirtualTrees.BaseTree, VirtualTrees.Types, + VirtualTrees.BaseAncestorVCL, VirtualTrees.AncestorVCL; type TfrmSyncDB = class(TExtForm) @@ -27,7 +28,6 @@ TfrmSyncDB = class(TExtForm) treeDifferences: TVirtualStringTree; lblDifferences: TLabel; procedure FormCreate(Sender: TObject); - procedure FormClose(Sender: TObject; var Action: TCloseAction); procedure treeSourceChange(Sender: TBaseVirtualTree; Node: PVirtualNode); procedure treeSourceChecked(Sender: TBaseVirtualTree; Node: PVirtualNode); procedure treeSourceChecking(Sender: TBaseVirtualTree; Node: PVirtualNode; var NewState: TCheckState; var Allowed: Boolean); @@ -95,18 +95,12 @@ function TDiffObject.AddItem(Title, SQL: String; DiffType: TDiffType): TDiffItem { TfrmSyncDB } -procedure TfrmSyncDB.FormClose(Sender: TObject; var Action: TCloseAction); -begin - Action := caFree; -end; - - procedure TfrmSyncDB.FormCreate(Sender: TObject); var SessNode: PVirtualNode; SessionPaths: TStringList; begin - Caption := MainForm.actSynchronizeDatabase.Caption; + //Caption := MainForm.actSynchronizeDatabase.Caption; HasSizeGrip := True; FixVT(treeSource); FixVT(treeDifferences); diff --git a/source/table_editor.dfm b/source/table_editor.dfm index 9c5ffec0c..2b1427003 100644 --- a/source/table_editor.dfm +++ b/source/table_editor.dfm @@ -37,26 +37,26 @@ object frmTableEditor: TfrmTableEditor ImageName = 'icons8-data-sheet-100' DesignSize = ( 686 - 121) + 120) object lblName: TLabel Left = 4 Top = 6 - Width = 31 - Height = 13 + Width = 35 + Height = 15 Caption = 'Name:' end object lblComment: TLabel Left = 4 Top = 33 - Width = 49 - Height = 13 + Width = 57 + Height = 15 Caption = 'Comment:' end object editName: TEdit Left = 96 Top = 3 Width = 589 - Height = 21 + Height = 23 Anchors = [akLeft, akTop, akRight] TabOrder = 0 Text = 'editName' @@ -81,85 +81,131 @@ object frmTableEditor: TfrmTableEditor Caption = 'Options' ImageIndex = 39 ImageName = 'icons8-support' - DesignSize = ( - 686 - 121) object lblAutoinc: TLabel Left = 4 Top = 6 - Width = 77 - Height = 13 + Width = 86 + Height = 15 Caption = 'Auto increment:' end + object lblCollation: TLabel + Left = 358 + Top = 6 + Width = 90 + Height = 15 + Caption = 'Default collation:' + end object lblAvgRowLen: TLabel Left = 4 Top = 29 - Width = 99 - Height = 13 + Width = 106 + Height = 15 Caption = 'Average row length:' end - object lblInsertMethod: TLabel - Left = 294 - Top = 98 - Width = 79 - Height = 13 - Caption = 'INSERT method:' - end - object lblUnion: TLabel - Left = 294 - Top = 52 - Width = 63 - Height = 13 - Caption = 'Union tables:' + object lblEngine: TLabel + Left = 358 + Top = 29 + Width = 39 + Height = 15 + Caption = 'Engine:' end object lblMaxRows: TLabel Left = 4 Top = 52 - Width = 99 - Height = 13 + Width = 114 + Height = 15 Caption = 'Maximum row count:' end + object lblUnion: TLabel + Left = 358 + Top = 52 + Width = 69 + Height = 15 + Caption = 'Union tables:' + end object lblRowFormat: TLabel Left = 4 Top = 98 - Width = 60 - Height = 13 + Width = 65 + Height = 15 Caption = 'Row format:' end - object lblCollation: TLabel - Left = 294 - Top = 6 - Width = 81 - Height = 13 - Caption = 'Default collation:' + object lblInsertMethod: TLabel + Left = 358 + Top = 98 + Width = 85 + Height = 15 + Caption = 'INSERT method:' end - object lblEngine: TLabel - Left = 294 - Top = 29 - Width = 36 - Height = 13 - Caption = 'Engine:' + object editAutoInc: TEdit + Left = 178 + Top = 3 + Width = 155 + Height = 23 + TabOrder = 0 + OnChange = editNumEditChange + end + object comboCollation: TComboBox + Left = 464 + Top = 3 + Width = 102 + Height = 23 + AutoDropDownWidth = True + Style = csDropDownList + DropDownCount = 16 + Sorted = True + TabOrder = 5 + OnChange = chkCharsetConvertClick + end + object chkCharsetConvert: TCheckBox + Left = 574 + Top = 5 + Width = 107 + Height = 17 + Caption = 'Convert data' + TabOrder = 6 + OnClick = chkCharsetConvertClick end object editAvgRowLen: TEdit Left = 178 Top = 26 - Width = 110 - Height = 21 + Width = 155 + Height = 23 TabOrder = 1 OnChange = editNumEditChange end + object comboEngine: TComboBox + Left = 464 + Top = 26 + Width = 221 + Height = 23 + AutoDropDownWidth = True + Style = csDropDownList + TabOrder = 7 + OnSelect = comboEngineSelect + end object editMaxRows: TEdit Left = 178 Top = 49 - Width = 110 - Height = 21 + Width = 155 + Height = 23 TabOrder = 2 OnChange = editNumEditChange end + object memoUnionTables: TMemo + Left = 464 + Top = 49 + Width = 221 + Height = 44 + Lines.Strings = ( + 'memoUnion') + TabOrder = 8 + OnChange = Modification + end object chkChecksum: TCheckBox Left = 4 Top = 75 - Width = 189 + Width = 190 Height = 17 Alignment = taLeftJustify Caption = 'Checksum for rows:' @@ -169,72 +215,20 @@ object frmTableEditor: TfrmTableEditor object comboRowFormat: TComboBox Left = 178 Top = 95 - Width = 110 - Height = 21 + Width = 155 + Height = 23 Style = csDropDownList TabOrder = 4 OnChange = Modification end - object memoUnionTables: TMemo - Left = 408 - Top = 49 - Width = 277 - Height = 44 - Anchors = [akLeft, akTop, akRight] - Lines.Strings = ( - 'memoUnion') - TabOrder = 7 - OnChange = Modification - end object comboInsertMethod: TComboBox - Left = 408 + Left = 464 Top = 95 - Width = 277 - Height = 21 - Style = csDropDownList - Anchors = [akLeft, akTop, akRight] - TabOrder = 8 - OnClick = Modification - end - object editAutoInc: TEdit - Left = 178 - Top = 3 - Width = 110 - Height = 21 - TabOrder = 0 - OnChange = editNumEditChange - end - object comboCollation: TComboBox - Left = 408 - Top = 3 - Width = 158 - Height = 21 - Style = csDropDownList - Anchors = [akLeft, akTop, akRight] - DropDownCount = 16 - Sorted = True - TabOrder = 5 - OnChange = chkCharsetConvertClick - end - object comboEngine: TComboBox - Left = 408 - Top = 26 - Width = 277 - Height = 21 + Width = 221 + Height = 23 Style = csDropDownList - Anchors = [akLeft, akTop, akRight] - TabOrder = 6 - OnSelect = comboEngineSelect - end - object chkCharsetConvert: TCheckBox - Left = 574 - Top = 5 - Width = 107 - Height = 17 - Anchors = [akTop, akRight] - Caption = 'Convert data' TabOrder = 9 - OnClick = chkCharsetConvertClick + OnClick = Modification end end object tabIndexes: TTabSheet @@ -243,27 +237,30 @@ object frmTableEditor: TfrmTableEditor ImageName = 'icons8-lightning-bolt-100' object treeIndexes: TVirtualStringTree AlignWithMargins = True - Left = 69 + Left = 73 Top = 0 - Width = 614 - Height = 121 + Width = 610 + Height = 120 Margins.Top = 0 Margins.Bottom = 0 Align = alClient + Alignment = taRightJustify + DefaultNodeHeight = 19 DragMode = dmAutomatic EditDelay = 0 - Header.AutoSizeIndex = 0 + Header.AutoSizeIndex = -1 Header.Options = [hoAutoResize, hoColumnResize, hoDrag, hoShowSortGlyphs, hoVisible, hoDisableAnimatedResize, hoAutoResizeInclCaption] Header.PopupMenu = MainForm.popupListHeader Images = MainForm.VirtualImageListMain - PopupMenu = popupIndexes + PopupMenu = popupProperties TabOrder = 1 TreeOptions.AutoOptions = [toAutoDropExpand, toAutoScrollOnExpand, toAutoTristateTracking, toAutoChangeScale] TreeOptions.MiscOptions = [toAcceptOLEDrop, toEditable, toFullRepaintOnResize, toGridExtensions, toInitOnSave, toToggleOnDblClick, toWheelPanning, toEditOnClick] - TreeOptions.PaintOptions = [toHotTrack, toShowButtons, toShowDropmark, toShowRoot, toShowTreeLines, toShowVertGridLines, toThemeAware, toUseBlendedImages, toFullVertGridLines, toUseExplorerTheme, toHideTreeLinesIfThemed] + TreeOptions.PaintOptions = [toHotTrack, toShowButtons, toShowDropmark, toShowRoot, toShowTreeLines, toShowVertGridLines, toThemeAware, toUseBlendedImages, toGhostedIfUnfocused, toFullVertGridLines, toUseExplorerTheme, toHideTreeLinesIfThemed] TreeOptions.SelectionOptions = [toExtendedFocus, toRightClickSelect] + OnBeforeCellPaint = treeIndexesBeforeCellPaint OnBeforePaint = treeIndexesBeforePaint - OnClick = treeIndexesClick + OnClick = AnyTreeClick OnCreateEditor = treeIndexesCreateEditor OnDragOver = treeIndexesDragOver OnDragDrop = treeIndexesDragDrop @@ -274,12 +271,15 @@ object frmTableEditor: TfrmTableEditor OnInitChildren = treeIndexesInitChildren OnInitNode = treeIndexesInitNode OnNewText = treeIndexesNewText + OnStructureChange = AnyTreeStructureChange + Touch.InteractiveGestures = [igPan, igPressAndTap] + Touch.InteractiveGestureOptions = [igoPanSingleFingerHorizontal, igoPanSingleFingerVertical, igoPanInertia, igoPanGutter, igoParentPassthrough] Columns = < item Options = [coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus] Position = 0 Text = 'Name' - Width = 434 + Width = 176 end item Options = [coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus] @@ -291,16 +291,36 @@ object frmTableEditor: TfrmTableEditor Position = 2 Text = 'Algorithm' Width = 80 + end + item + Position = 3 + Text = 'Comment' + Width = 120 + end + item + Position = 4 + Text = 'Direction' + Width = 80 + end + item + Position = 5 + Text = 'Visibility' + end + item + Alignment = taRightJustify + Position = 6 + Text = 'Size' + Width = 10 end> end object tlbIndexes: TToolBar Left = 0 Top = 0 - Width = 66 - Height = 121 + Width = 70 + Height = 120 Align = alLeft AutoSize = True - ButtonWidth = 66 + ButtonWidth = 70 Caption = 'tlbIndexes' Images = MainForm.VirtualImageListMain List = True @@ -361,14 +381,23 @@ object frmTableEditor: TfrmTableEditor Caption = 'Foreign keys' ImageIndex = 136 ImageName = 'icons8-data-grid-relation' + object spltForeignKeyListings: TSplitter + Left = 573 + Top = 0 + Height = 120 + Align = alRight + Visible = False + ExplicitLeft = 494 + ExplicitTop = -3 + end object tlbForeignKeys: TToolBar Left = 0 Top = 0 - Width = 66 - Height = 121 + Width = 70 + Height = 120 Align = alLeft AutoSize = True - ButtonWidth = 66 + ButtonWidth = 70 Caption = 'tlbForeignKeys' Images = MainForm.VirtualImageListMain List = True @@ -400,34 +429,49 @@ object frmTableEditor: TfrmTableEditor Enabled = False ImageIndex = 26 ImageName = 'icons8-close-button' + Wrap = True OnClick = btnClearForeignKeysClick end + object btnShowReverseForeignKeys: TToolButton + Left = 0 + Top = 66 + Hint = 'Show reverse foreign keys' + Caption = 'Reverse' + ImageIndex = 40 + Style = tbsCheck + OnClick = btnShowReverseForeignKeysClick + end end object listForeignKeys: TVirtualStringTree - Left = 66 + Left = 70 Top = 0 - Width = 620 - Height = 121 + Width = 503 + Height = 120 Margins.Top = 0 Margins.Bottom = 0 Align = alClient + DefaultNodeHeight = 19 EditDelay = 0 - Header.AutoSizeIndex = 0 + Header.AutoSizeIndex = -1 Header.Options = [hoAutoResize, hoColumnResize, hoDrag, hoShowSortGlyphs, hoVisible, hoDisableAnimatedResize, hoAutoResizeInclCaption] Header.PopupMenu = MainForm.popupListHeader Images = MainForm.VirtualImageListMain + PopupMenu = popupProperties TabOrder = 1 TreeOptions.MiscOptions = [toAcceptOLEDrop, toEditable, toFullRepaintOnResize, toGridExtensions, toInitOnSave, toToggleOnDblClick, toWheelPanning, toEditOnClick] TreeOptions.PaintOptions = [toShowButtons, toShowDropmark, toShowHorzGridLines, toShowTreeLines, toShowVertGridLines, toThemeAware, toUseBlendedImages, toUseExplorerTheme, toHideTreeLinesIfThemed] TreeOptions.SelectionOptions = [toExtendedFocus] OnBeforePaint = listForeignKeysBeforePaint - OnClick = treeIndexesClick + OnClick = AnyTreeClick OnCreateEditor = listForeignKeysCreateEditor OnEditing = listForeignKeysEditing OnFocusChanged = listForeignKeysFocusChanged OnGetText = listForeignKeysGetText OnGetImageIndex = listForeignKeysGetImageIndex OnNewText = listForeignKeysNewText + OnStructureChange = AnyTreeStructureChange + Touch.InteractiveGestures = [igPan, igPressAndTap] + Touch.InteractiveGestureOptions = [igoPanSingleFingerHorizontal, igoPanSingleFingerVertical, igoPanInertia, igoPanGutter, igoParentPassthrough] Columns = < item Options = [coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus] @@ -463,7 +507,116 @@ object frmTableEditor: TfrmTableEditor Options = [coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus] Position = 5 Text = 'On DELETE' - Width = 80 + Width = 10 + end> + end + object ListViewReverseForeignKeys: TListView + Left = 576 + Top = 0 + Width = 110 + Height = 120 + Align = alRight + Columns = < + item + AutoSize = True + Caption = 'Database' + end + item + AutoSize = True + Caption = 'Table' + end> + ColumnClick = False + HotTrack = True + ReadOnly = True + RowSelect = True + SmallImages = MainForm.VirtualImageListMain + TabOrder = 2 + ViewStyle = vsReport + Visible = False + OnDblClick = ListViewReverseForeignKeysDblClick + end + end + object tabCheckConstraints: TTabSheet + Caption = 'Check constraints' + ImageIndex = 55 + object tlbCheckConstraints: TToolBar + Left = 0 + Top = 0 + Width = 70 + Height = 120 + Align = alLeft + AutoSize = True + ButtonWidth = 70 + Caption = 'tlbCheckConstraints' + Images = MainForm.VirtualImageListMain + List = True + ShowCaptions = True + TabOrder = 0 + object btnAddCheckConstraint: TToolButton + Left = 0 + Top = 0 + Caption = 'Add' + ImageIndex = 45 + Wrap = True + OnClick = btnAddCheckConstraintClick + end + object btnRemoveCheckConstraint: TToolButton + Left = 0 + Top = 22 + Caption = 'Remove' + Enabled = False + ImageIndex = 46 + Wrap = True + OnClick = btnRemoveCheckConstraintClick + end + object btnClearCheckConstraints: TToolButton + Left = 0 + Top = 44 + Caption = 'Clear' + Enabled = False + ImageIndex = 26 + OnClick = btnClearCheckConstraintsClick + end + end + object listCheckConstraints: TVirtualStringTree + Left = 70 + Top = 0 + Width = 616 + Height = 120 + Align = alClient + DefaultNodeHeight = 19 + EditDelay = 0 + Header.AutoSizeIndex = 1 + Header.Options = [hoAutoResize, hoColumnResize, hoDrag, hoShowSortGlyphs, hoVisible, hoDisableAnimatedResize, hoAutoResizeInclCaption] + Header.PopupMenu = MainForm.popupListHeader + Images = MainForm.VirtualImageListMain + PopupMenu = popupProperties + TabOrder = 1 + TreeOptions.MiscOptions = [toAcceptOLEDrop, toEditable, toFullRepaintOnResize, toGridExtensions, toInitOnSave, toToggleOnDblClick, toWheelPanning, toEditOnClick] + TreeOptions.PaintOptions = [toShowButtons, toShowDropmark, toShowHorzGridLines, toShowTreeLines, toShowVertGridLines, toThemeAware, toUseBlendedImages, toUseExplorerTheme, toHideTreeLinesIfThemed] + TreeOptions.SelectionOptions = [toExtendedFocus] + OnBeforePaint = listCheckConstraintsBeforePaint + OnClick = AnyTreeClick + OnCreateEditor = listCheckConstraintsCreateEditor + OnFocusChanged = listCheckConstraintsFocusChanged + OnGetText = listCheckConstraintsGetText + OnGetImageIndex = listCheckConstraintsGetImageIndex + OnNewText = listCheckConstraintsNewText + OnStructureChange = AnyTreeStructureChange + Touch.InteractiveGestures = [igPan, igPressAndTap] + Touch.InteractiveGestureOptions = [igoPanSingleFingerHorizontal, igoPanSingleFingerVertical, igoPanInertia, igoPanGutter, igoParentPassthrough] + Columns = < + item + Options = [coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus, coEditable, coStyleColor] + Position = 0 + Text = 'Name' + Width = 200 + end + item + Options = [coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus, coEditable, coStyleColor] + Position = 1 + Text = 'Check clause' + Width = 412 end> end end @@ -474,8 +627,8 @@ object frmTableEditor: TfrmTableEditor object SynMemoPartitions: TSynMemo Left = 0 Top = 0 - Width = 593 - Height = 121 + Width = 686 + Height = 120 SingleLineMode = False Align = alClient Font.Charset = DEFAULT_CHARSET @@ -484,6 +637,14 @@ object frmTableEditor: TfrmTableEditor Font.Name = 'Courier New' Font.Style = [] TabOrder = 0 + CodeFolding.GutterShapeSize = 11 + CodeFolding.CollapsedLineColor = clGrayText + CodeFolding.FolderBarLinesColor = clGrayText + CodeFolding.IndentGuidesColor = clGray + CodeFolding.IndentGuides = True + CodeFolding.ShowCollapsedLine = False + CodeFolding.ShowHintMark = True + UseCodeFolding = False Gutter.AutoSize = True Gutter.DigitCount = 2 Gutter.Font.Charset = DEFAULT_CHARSET @@ -508,8 +669,8 @@ object frmTableEditor: TfrmTableEditor object SynMemoCREATEcode: TSynMemo Left = 0 Top = 0 - Width = 593 - Height = 121 + Width = 686 + Height = 120 SingleLineMode = False Align = alClient Font.Charset = DEFAULT_CHARSET @@ -518,6 +679,14 @@ object frmTableEditor: TfrmTableEditor Font.Name = 'Courier New' Font.Style = [] TabOrder = 0 + CodeFolding.GutterShapeSize = 11 + CodeFolding.CollapsedLineColor = clGrayText + CodeFolding.FolderBarLinesColor = clGrayText + CodeFolding.IndentGuidesColor = clGray + CodeFolding.IndentGuides = True + CodeFolding.ShowCollapsedLine = False + CodeFolding.ShowHintMark = True + UseCodeFolding = False Gutter.AutoSize = True Gutter.DigitCount = 2 Gutter.Font.Charset = DEFAULT_CHARSET @@ -542,8 +711,8 @@ object frmTableEditor: TfrmTableEditor object SynMemoALTERcode: TSynMemo Left = 0 Top = 0 - Width = 593 - Height = 121 + Width = 686 + Height = 120 SingleLineMode = False Align = alClient Font.Charset = DEFAULT_CHARSET @@ -552,6 +721,14 @@ object frmTableEditor: TfrmTableEditor Font.Name = 'Courier New' Font.Style = [] TabOrder = 0 + CodeFolding.GutterShapeSize = 11 + CodeFolding.CollapsedLineColor = clGrayText + CodeFolding.FolderBarLinesColor = clGrayText + CodeFolding.IndentGuidesColor = clGray + CodeFolding.IndentGuides = True + CodeFolding.ShowCollapsedLine = False + CodeFolding.ShowHintMark = True + UseCodeFolding = False Gutter.AutoSize = True Gutter.DigitCount = 2 Gutter.Font.Charset = DEFAULT_CHARSET @@ -595,7 +772,7 @@ object frmTableEditor: TfrmTableEditor Margins.Bottom = 0 Align = alClient AutoSize = True - ButtonWidth = 66 + ButtonWidth = 70 Caption = 'Columns:' Images = MainForm.VirtualImageListMain List = True @@ -606,21 +783,21 @@ object frmTableEditor: TfrmTableEditor Top = 0 Hint = 'Add column' Caption = 'Add' - ImageIndex = 45 + ImageIndex = 91 ImageName = 'icons8-add' OnClick = btnAddColumnClick end object btnRemoveColumn: TToolButton - Left = 66 + Left = 70 Top = 0 Hint = 'Remove column' Caption = 'Remove' - ImageIndex = 46 + ImageIndex = 92 ImageName = 'icons8-delete-button' OnClick = btnRemoveColumnClick end object btnMoveUpColumn: TToolButton - Left = 132 + Left = 140 Top = 0 Hint = 'Move up' Caption = 'Up' @@ -629,7 +806,7 @@ object frmTableEditor: TfrmTableEditor OnClick = btnMoveUpColumnClick end object btnMoveDownColumn: TToolButton - Left = 198 + Left = 210 Top = 0 Hint = 'Move down' Caption = 'Down' @@ -648,10 +825,11 @@ object frmTableEditor: TfrmTableEditor Margins.Bottom = 32 Align = alClient Constraints.MinHeight = 20 + DefaultNodeHeight = 19 DragMode = dmAutomatic EditDelay = 0 Header.AutoSizeIndex = -1 - Header.Options = [hoColumnResize, hoDblClickResize, hoDrag, hoVisible, hoDisableAnimatedResize, hoAutoResizeInclCaption] + Header.Options = [hoColumnResize, hoDblClickResize, hoDrag, hoHotTrack, hoShowSortGlyphs, hoVisible, hoDisableAnimatedResize, hoAutoResizeInclCaption] Header.PopupMenu = MainForm.popupListHeader Images = MainForm.VirtualImageListMain IncrementalSearch = isAll @@ -674,86 +852,89 @@ object frmTableEditor: TfrmTableEditor OnGetText = listColumnsGetText OnPaintText = listColumnsPaintText OnGetNodeDataSize = listColumnsGetNodeDataSize + OnHeaderClick = listColumnsHeaderClick OnInitNode = listColumnsInitNode OnKeyPress = listColumnsKeyPress OnNewText = listColumnsNewText - OnNodeMoved = listColumnsNodeMoved + Touch.InteractiveGestures = [igPan, igPressAndTap] + Touch.InteractiveGestureOptions = [igoPanSingleFingerHorizontal, igoPanSingleFingerVertical, igoPanInertia, igoPanGutter, igoParentPassthrough] Columns = < item Alignment = taRightJustify MinWidth = 20 - Options = [coDraggable, coEnabled, coParentBidiMode, coParentColor, coShowDropMark, coVisible, coAllowFocus] Position = 0 Text = '#' Width = 20 end item MinWidth = 50 - Options = [coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus] Position = 1 Text = 'Name' Width = 100 end item - Options = [coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus] Position = 2 Text = 'Datatype' Width = 90 end item - Options = [coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus] Position = 3 Text = 'Length/Set' Width = 90 end item - Alignment = taCenter - Options = [coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus] Position = 4 Text = 'Unsigned' Width = 60 end item - Alignment = taCenter - Options = [coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus] Position = 5 Text = 'Allow NULL' Width = 65 end item - Options = [coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus] Position = 6 Text = 'Zerofill' end item - Options = [coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus] Position = 7 Text = 'Default' Width = 100 end item - Options = [coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus] Position = 8 Text = 'Comment' Width = 130 end item - Options = [coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus] Position = 9 Text = 'Collation' Width = 100 end item - Options = [coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus] Position = 10 Text = 'Expression' Width = 100 end item - Options = [coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus] Position = 11 Text = 'Virtuality' Width = 100 + end + item + Hint = 'Spatial reference system' + Position = 12 + Text = 'SRID' + end + item + Hint = 'Hide in certain contexts' + Position = 13 + Text = 'Invisible' + end + item + Hint = 'Storage-Engine Independent Column Compression' + Position = 14 + Text = 'Compressed' end> end object btnSave: TButton @@ -787,16 +968,20 @@ object frmTableEditor: TfrmTableEditor TabOrder = 3 OnClick = btnHelpClick end - object popupIndexes: TPopupMenu + object popupProperties: TPopupMenu Images = MainForm.VirtualImageListMain - Left = 344 + OnPopup = popupPropertiesPopup + Left = 400 Top = 360 - object menuAddIndex: TMenuItem - Caption = 'Add index' + object Copy1: TMenuItem + Action = MainForm.actCopy + end + object menuAddProperty: TMenuItem + Caption = 'Add' ImageIndex = 45 ImageName = 'icons8-add' ShortCut = 16429 - OnClick = btnAddIndexClick + OnClick = menuAddPropertyClick end object menuAddIndexColumn: TMenuItem Caption = 'Add column' @@ -805,19 +990,19 @@ object frmTableEditor: TfrmTableEditor ShortCut = 24621 OnClick = menuAddIndexColumnClick end - object menuRemoveIndex: TMenuItem + object menuRemoveProperty: TMenuItem Caption = 'Remove' ImageIndex = 46 ImageName = 'icons8-delete-button' ShortCut = 16430 - OnClick = btnRemoveIndexClick + OnClick = menuRemovePropertyClick end - object menuClearIndexes: TMenuItem + object menuClearProperties: TMenuItem Caption = 'Clear' ImageIndex = 26 ImageName = 'icons8-close-button' ShortCut = 24622 - OnClick = btnClearIndexesClick + OnClick = menuClearPropertiesClick end object menuMoveUpIndex: TMenuItem Caption = 'Up' @@ -859,14 +1044,14 @@ object frmTableEditor: TfrmTableEditor end object menuAddColumn: TMenuItem Caption = 'Add column' - ImageIndex = 45 + ImageIndex = 91 ImageName = 'icons8-add' ShortCut = 16429 OnClick = btnAddColumnClick end object menuRemoveColumn: TMenuItem Caption = 'Remove column' - ImageIndex = 46 + ImageIndex = 92 ImageName = 'icons8-delete-button' ShortCut = 16430 OnClick = btnRemoveColumnClick diff --git a/source/table_editor.pas b/source/table_editor.pas index 48ca0c177..3e9dfbe1e 100644 --- a/source/table_editor.pas +++ b/source/table_editor.pas @@ -3,10 +3,11 @@ interface uses - Windows, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, - ComCtrls, ToolWin, VirtualTrees, SynRegExpr, ActiveX, ExtCtrls, SynEdit, - SynMemo, Menus, Clipbrd, Math, System.UITypes, - grideditlinks, dbstructures, dbconnection, apphelpers, gnugettext, StrUtils; + Winapi.Windows, System.SysUtils, System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, + Vcl.ComCtrls, Vcl.ToolWin, VirtualTrees, VirtualTrees.Types, SynRegExpr, Winapi.ActiveX, Vcl.ExtCtrls, SynEdit, + SynMemo, Vcl.Menus, Vcl.Clipbrd, System.Math, System.UITypes, System.Generics.Collections, + grideditlinks, dbstructures, dbstructures.mysql, dbconnection, apphelpers, gnugettext, System.StrUtils, extra_controls, + VirtualTrees.BaseAncestorVCL, VirtualTrees.BaseTree, VirtualTrees.AncestorVCL; type TFrame = TDBObjectEditor; @@ -15,7 +16,9 @@ TfrmTableEditor = class(TFrame) btnDiscard: TButton; btnHelp: TButton; listColumns: TVirtualStringTree; + ListViewReverseForeignKeys: TListView; PageControlMain: TPageControl; + spltForeignKeyListings: TSplitter; tabBasic: TTabSheet; tabIndexes: TTabSheet; tabOptions: TTabSheet; @@ -40,6 +43,7 @@ TfrmTableEditor = class(TFrame) comboCollation: TComboBox; lblEngine: TLabel; comboEngine: TComboBox; + btnShowReverseForeignKeys: TToolButton; treeIndexes: TVirtualStringTree; tlbIndexes: TToolBar; btnAddIndex: TToolButton; @@ -58,13 +62,13 @@ TfrmTableEditor = class(TFrame) tabALTERCode: TTabSheet; SynMemoCREATEcode: TSynMemo; SynMemoALTERcode: TSynMemo; - popupIndexes: TPopupMenu; - menuAddIndex: TMenuItem; + popupProperties: TPopupMenu; + menuAddProperty: TMenuItem; menuAddIndexColumn: TMenuItem; - menuRemoveIndex: TMenuItem; + menuRemoveProperty: TMenuItem; menuMoveUpIndex: TMenuItem; menuMoveDownIndex: TMenuItem; - menuClearIndexes: TMenuItem; + menuClearProperties: TMenuItem; popupColumns: TPopupMenu; menuAddColumn: TMenuItem; menuRemoveColumn: TMenuItem; @@ -86,6 +90,15 @@ TfrmTableEditor = class(TFrame) menuPasteColumns: TMenuItem; tabPartitions: TTabSheet; SynMemoPartitions: TSynMemo; + tabCheckConstraints: TTabSheet; + tlbCheckConstraints: TToolBar; + btnAddCheckConstraint: TToolButton; + btnRemoveCheckConstraint: TToolButton; + btnClearCheckConstraints: TToolButton; + listCheckConstraints: TVirtualStringTree; + Copy1: TMenuItem; + procedure btnShowReverseForeignKeysClick(Sender: TObject); + procedure ListViewReverseForeignKeysDblClick(Sender: TObject); procedure Modification(Sender: TObject); procedure btnAddColumnClick(Sender: TObject); procedure btnRemoveColumnClick(Sender: TObject); @@ -99,11 +112,14 @@ TfrmTableEditor = class(TFrame) procedure btnMoveDownColumnClick(Sender: TObject); procedure listColumnsDragOver(Sender: TBaseVirtualTree; Source: TObject; Shift: TShiftState; State: TDragState; Pt: TPoint; Mode: TDropMode; var Effect: Integer; var Accept: Boolean); - procedure listColumnsDragDrop(Sender: TBaseVirtualTree; Source: TObject; DataObject: IDataObject; Formats: TFormatArray; + procedure listColumnsDragDrop(Sender: TBaseVirtualTree; Source: TObject; DataObject: TVTDragDataObject; Formats: TFormatArray; Shift: TShiftState; Pt: TPoint; var Effect: Integer; Mode: TDropMode); procedure listColumnsPaintText(Sender: TBaseVirtualTree; const TargetCanvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType); procedure listColumnsCreateEditor(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; out EditLink: IVTEditLink); + procedure treeIndexesBeforeCellPaint(Sender: TBaseVirtualTree; + TargetCanvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; + CellPaintMode: TVTCellPaintMode; CellRect: TRect; var ContentRect: TRect); procedure treeIndexesInitNode(Sender: TBaseVirtualTree; ParentNode, Node: PVirtualNode; var InitialStates: TVirtualNodeInitStates); procedure treeIndexesGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; var CellText: String); @@ -127,7 +143,7 @@ TfrmTableEditor = class(TFrame) Shift: TShiftState; State: TDragState; Pt: TPoint; Mode: TDropMode; var Effect: Integer; var Accept: Boolean); procedure treeIndexesDragDrop(Sender: TBaseVirtualTree; Source: TObject; - DataObject: IDataObject; Formats: TFormatArray; Shift: TShiftState; + DataObject: TVTDragDataObject; Formats: TFormatArray; Shift: TShiftState; Pt: TPoint; var Effect: Integer; Mode: TDropMode); procedure treeIndexesNewText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; NewText: String); procedure treeIndexesEditing(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; var Allowed: Boolean); @@ -139,7 +155,7 @@ TfrmTableEditor = class(TFrame) procedure menuAddIndexColumnClick(Sender: TObject); procedure PageControlMainChange(Sender: TObject); procedure chkCharsetConvertClick(Sender: TObject); - procedure treeIndexesClick(Sender: TObject); + procedure AnyTreeClick(Sender: TObject); procedure btnDiscardClick(Sender: TObject); procedure popupColumnsPopup(Sender: TObject); procedure AddIndexByColumn(Sender: TObject); @@ -164,21 +180,73 @@ TfrmTableEditor = class(TFrame) procedure listColumnsInitNode(Sender: TBaseVirtualTree; ParentNode, Node: PVirtualNode; var InitialStates: TVirtualNodeInitStates); procedure listColumnsGetNodeDataSize(Sender: TBaseVirtualTree; var NodeDataSize: Integer); - procedure listColumnsNodeMoved(Sender: TBaseVirtualTree; Node: PVirtualNode); procedure listColumnsKeyPress(Sender: TObject; var Key: Char); procedure vtHandleClickOrKeyPress(Sender: TVirtualStringTree; Node: PVirtualNode; Column: TColumnIndex; HitPositions: THitPositions); procedure menuCopyColumnsClick(Sender: TObject); procedure menuPasteColumnsClick(Sender: TObject); procedure listColumnsChange(Sender: TBaseVirtualTree; Node: PVirtualNode); + procedure AnyTreeStructureChange(Sender: TBaseVirtualTree; + Node: PVirtualNode; Reason: TChangeReason); + procedure listCheckConstraintsBeforePaint(Sender: TBaseVirtualTree; + TargetCanvas: TCanvas); + procedure btnAddCheckConstraintClick(Sender: TObject); + procedure listCheckConstraintsGetImageIndex(Sender: TBaseVirtualTree; + Node: PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex; + var Ghosted: Boolean; var ImageIndex: TImageIndex); + procedure listCheckConstraintsFocusChanged(Sender: TBaseVirtualTree; + Node: PVirtualNode; Column: TColumnIndex); + procedure listCheckConstraintsGetText(Sender: TBaseVirtualTree; + Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; + var CellText: string); + procedure listCheckConstraintsCreateEditor(Sender: TBaseVirtualTree; + Node: PVirtualNode; Column: TColumnIndex; out EditLink: IVTEditLink); + procedure listCheckConstraintsNewText(Sender: TBaseVirtualTree; + Node: PVirtualNode; Column: TColumnIndex; NewText: string); + procedure btnClearCheckConstraintsClick(Sender: TObject); + procedure btnRemoveCheckConstraintClick(Sender: TObject); + procedure popupPropertiesPopup(Sender: TObject); + procedure menuRemovePropertyClick(Sender: TObject); + procedure menuClearPropertiesClick(Sender: TObject); + procedure menuAddPropertyClick(Sender: TObject); + procedure listColumnsHeaderClick(Sender: TVTHeader; + HitInfo: TVTHeaderHitInfo); private { Private declarations } FLoaded: Boolean; CreateCodeValid, AlterCodeValid: Boolean; + FReverseForeignKeysLoaded: Boolean; FColumns: TTableColumnList; - FKeys: TTableKeyList; + FKeys, FDeletedKeys: TTableKeyList; FForeignKeys: TForeignKeyList; - DeletedKeys, DeletedForeignKeys: TStringList; + FCheckConstraints: TCheckConstraintList; + FDeletedForeignKeys, + FDeletedCheckConstraints: TStringList; + FAlterRestrictedMessageDisplayed: Boolean; + const ColNumCounter = 0; + const ColNumName = 1; + const ColNumDatatype = 2; + const ColNumLengthSet = 3; + const ColNumUnsigned = 4; + const ColNumAllownull = 5; + const ColNumZerofill = 6; + const ColNumDefault = 7; + const ColNumComment = 8; + const ColNumCollation = 9; + const ColNumExpression = 10; + const ColNumVirtuality = 11; + const ColNumSrid = 12; + const ColNumInvisible = 13; + const ColNumCompressed = 14; + const ColNumsCheckboxes = [ColNumUnsigned, ColNumAllownull, ColNumZerofill, ColNumInvisible, ColNumCompressed]; + // Columns in index tree + const IndexColNumName = 0; + const IndexColNumType = 1; + const IndexColNumAlgorithm = 2; + const IndexColNumComment = 3; + const IndexColNumDirection = 4; + const IndexColNumVisibility = 5; + const IndexColNumSize = 6; procedure ValidateColumnControls; procedure ValidateIndexControls; procedure MoveFocusedIndexPart(NewIdx: Cardinal); @@ -187,12 +255,16 @@ TfrmTableEditor = class(TFrame) function ComposeAlterStatement: TSQLBatch; procedure UpdateSQLcode; function CellEditingAllowed(Node: PVirtualNode; Column: TColumnIndex): Boolean; + function GetKeyImageIndexes(Col: TTableColumn): TList; procedure CalcMinColWidth; + procedure UpdateTabCaptions; + function MoveNodeAllowed(Sender: TVirtualStringTree): Boolean; + procedure LoadReverseForeignKeys(Sender: TObject); public { Public declarations } constructor Create(AOwner: TComponent); override; - destructor Destroy; override; procedure Init(Obj: TDBObject); override; + function DeInit: TModalResult; override; function ApplyModifications: TModalResult; override; end; @@ -206,37 +278,43 @@ implementation constructor TfrmTableEditor.Create(AOwner: TComponent); +var + i: Integer; begin inherited; - FixVT(listColumns); - FixVT(treeIndexes); - FixVT(listForeignKeys); - // Try the best to auto fit various column widths, respecting a custom DPI setting and a pulldown arrow - listColumns.Header.Columns[2].Width := Mainform.Canvas.TextWidth('GEOMETRYCOLLECTION') + 6*listColumns.TextMargin; - listColumns.Header.Columns[7].Width := Mainform.Canvas.TextWidth('AUTO_INCREMENT') + 4*listColumns.TextMargin; - listColumns.Header.Columns[9].Width := Mainform.Canvas.TextWidth('macroman_general_ci') + 6*listColumns.TextMargin; - // Overide column widths by custom values - Mainform.RestoreListSetup(listColumns); - Mainform.RestoreListSetup(treeIndexes); - Mainform.RestoreListSetup(listForeignKeys); comboRowFormat.Items.CommaText := 'DEFAULT,DYNAMIC,FIXED,COMPRESSED,REDUNDANT,COMPACT'; comboInsertMethod.Items.CommaText := 'NO,FIRST,LAST'; FColumns := TTableColumnList.Create; FKeys := TTableKeyList.Create; FForeignKeys := TForeignKeyList.Create; - DeletedKeys := TStringList.Create; - DeletedForeignKeys := TStringList.Create; + FDeletedKeys := TTableKeyList.Create; + FDeletedForeignKeys := TStringList.Create; + FDeletedCheckConstraints := TStringList.Create; + FDeletedCheckConstraints.Duplicates := dupIgnore; editName.MaxLength := NAME_LEN; + FAlterRestrictedMessageDisplayed := False; + btnSave.Hint := ShortCutToText(MainForm.actSaveSQL.ShortCut); + listColumns.OnCompareNodes := MainForm.AnyGridCompareNodes; + //listColumns.OnHeaderClick has its own handler + listColumns.OnAfterPaint := MainForm.AnyGridAfterPaint; + // Hide 0/1 text behind the drawn checkbox, by centering the text like the checkbox. We need the 0/1 text for sorting. + // And we cannot over-draw the cell rect which may have a different background. + for i in ColNumsCheckboxes do begin + listColumns.Header.Columns[i].Alignment := taCenter; + end; + btnShowReverseForeignKeys.Down := AppSettings.ReadBool(asDisplayReverseForeignKeys); + FixVT(listColumns); + FixVT(treeIndexes); + FixVT(listForeignKeys); + FixVT(listCheckConstraints); end; -destructor TfrmTableEditor.Destroy; +procedure TfrmTableEditor.listColumnsHeaderClick(Sender: TVTHeader; + HitInfo: TVTHeaderHitInfo); begin - // Store GUI setup - Mainform.SaveListSetup(listColumns); - Mainform.SaveListSetup(treeIndexes); - Mainform.SaveListSetup(listForeignKeys); - inherited; + MainForm.AnyGridHeaderClick(Sender, HitInfo); + ValidateColumnControls; end; @@ -246,23 +324,46 @@ procedure TfrmTableEditor.Init(Obj: TDBObject); rx: TRegExpr; begin inherited; - FLoaded := False; + + // Try the best to auto fit various column widths, respecting a custom DPI setting and a pulldown arrow + listColumns.Header.Columns[2].Width := Mainform.Canvas.TextWidth('GEOMETRYCOLLECTION') + 6*listColumns.TextMargin; + listColumns.Header.Columns[7].Width := Mainform.Canvas.TextWidth('AUTO_INCREMENT') + 4*listColumns.TextMargin; + listColumns.Header.Columns[9].Width := Mainform.Canvas.TextWidth('macroman_general_ci') + 6*listColumns.TextMargin; + // Overide column widths by custom values + TExtForm.RestoreListSetup(listColumns); + TExtForm.RestoreListSetup(treeIndexes); + TExtForm.RestoreListSetup(listForeignKeys); + TExtForm.RestoreListSetup(listCheckConstraints); + // Fix control width and position, broken when opening a second table. See issue #1959 + comboCollation.Left := lblCollation.Left + TExtForm.ScaleSize(150, Self); + comboCollation.Width := comboRowFormat.Width; + comboCollation.Items := DBObject.Connection.CollationList; + chkCharsetConvert.Left := comboCollation.Left + comboCollation.Width + 10; + comboEngine.Left := comboCollation.Left; + comboEngine.Width := comboCollation.Width; comboEngine.Items := DBObject.Connection.TableEngines; comboEngine.Items.Insert(0, '<'+_('Server default')+'>'); comboEngine.ItemIndex := 0; - comboCollation.Items := DBObject.Connection.CollationList; + memoUnionTables.Left := comboCollation.Left; + memoUnionTables.Width := comboCollation.Width; + comboInsertMethod.Left := comboCollation.Left; + comboInsertMethod.Width := comboCollation.Width; if DBObject.Connection.Parameters.IsMariaDB then begin with listColumns.Header do begin - Columns[10].Options := Columns[10].Options + [coVisible]; - Columns[11].Options := Columns[11].Options + [coVisible]; + Columns[ColNumExpression].Options := Columns[ColNumExpression].Options + [coVisible]; + Columns[ColNumVirtuality].Options := Columns[ColNumVirtuality].Options + [coVisible]; + Columns[ColNumCompressed].Options := Columns[ColNumCompressed].Options + [coVisible]; end; end; listColumns.BeginUpdate; listColumns.Clear; + listColumns.Header.SortColumn := 0; + listColumns.Header.SortDirection := sdAscending; treeIndexes.Clear; listForeignKeys.Clear; - tabALTERcode.TabVisible := DBObject.Name <> ''; + listCheckConstraints.Clear; + tabALTERcode.TabVisible := ObjectExists; // Clear value editors memoComment.Text := ''; if Obj.Connection.ServerVersionInt < 50503 then @@ -279,7 +380,7 @@ procedure TfrmTableEditor.Init(Obj: TDBObject); comboInsertMethod.ItemIndex := -1; SynMemoPartitions.Clear; - if DBObject.Name = '' then begin + if not ObjectExists then begin // Creating new table editName.Text := ''; if DBObject.Connection.Parameters.IsAnyMySQL then @@ -288,6 +389,7 @@ procedure TfrmTableEditor.Init(Obj: TDBObject); FColumns := TTableColumnList.Create; FKeys := TTableKeyList.Create; FForeignKeys := TForeignKeyList.Create; + FCheckConstraints := TCheckConstraintList.Create; end else begin // Editing existing table editName.Text := DBObject.Name; @@ -329,15 +431,17 @@ procedure TfrmTableEditor.Init(Obj: TDBObject); // See issue #196 memoComment.Text := DBObject.Comment; - rx.Expression := '\b(PARTITION\s+.+)(\*/)'; - if rx.Exec(DBObject.CreateCode) then - SynMemoPartitions.Text := rx.Match[1] - else + rx.Expression := '\b(PARTITION\s+BY\s+.+)$'; + if rx.Exec(DBObject.CreateCode) then begin + SynMemoPartitions.Text := Trim(rx.Match[1]); + SynMemoPartitions.Text := ReplaceRegExpr('\*/$', SynMemoPartitions.Text, ''); + end else SynMemoPartitions.Clear; FColumns := DBObject.TableColumns; FKeys := DBObject.TableKeys; FForeignKeys := DBObject.TableForeignKeys; + FCheckConstraints := DBObject.TableCheckConstraints; end; listColumns.RootNodeCount := FColumns.Count; DeInitializeVTNodes(listColumns); @@ -348,6 +452,7 @@ procedure TfrmTableEditor.Init(Obj: TDBObject); // Set root nodes per BeforePaint event: treeIndexes.Invalidate; listForeignKeys.Invalidate; + listCheckConstraints.Invalidate; // Validate controls comboEngineSelect(comboEngine); @@ -356,12 +461,15 @@ procedure TfrmTableEditor.Init(Obj: TDBObject); ResetModificationFlags; CreateCodeValid := False; AlterCodeValid := False; + FReverseForeignKeysLoaded := False; + btnShowReverseForeignKeysClick(Self); PageControlMainChange(Self); // Foreign key editor needs a hit // Buttons are randomly moved, since VirtualTree update, see #440 btnSave.Top := Height - btnSave.Height - 3; btnHelp.Top := btnSave.Top; btnDiscard.Top := btnSave.Top; UpdateSQLCode; + UpdateTabCaptions; CalcMinColWidth; // Indicate change mechanisms can call their events now. See Modification(). FLoaded := True; @@ -371,6 +479,17 @@ procedure TfrmTableEditor.Init(Obj: TDBObject); end; +function TfrmTableEditor.DeInit: TModalResult; +begin + // Store GUI setup + TExtForm.SaveListSetup(listColumns); + TExtForm.SaveListSetup(treeIndexes); + TExtForm.SaveListSetup(listForeignKeys); + TExtForm.SaveListSetup(listCheckConstraints); + Result := inherited; +end; + + procedure TfrmTableEditor.btnDiscardClick(Sender: TObject); begin // Reinit GUI, discarding changes @@ -399,7 +518,7 @@ function TfrmTableEditor.ApplyModifications: TModalResult; Batch: TSQLBatch; Query: TSQLSentence; i: Integer; - Rename: String; + Rename, ErrMessage, ErrMessageAdditional, InnodbStatus: String; begin // Check if all indexes have at least one column // If not, exit early @@ -414,19 +533,25 @@ function TfrmTableEditor.ApplyModifications: TModalResult; // Create or alter table Result := mrOk; - if DBObject.Name = '' then + if not ObjectExists then Batch := ComposeCreateStatement else Batch := ComposeAlterStatement; try - for Query in Batch do + for Query in Batch do begin DBObject.Connection.Query(Query.SQL); + DBObject.Connection.ShowWarnings; + end; // Rename table - if (DBObject.Name <> '') and (editName.Text <> DBObject.Name) then begin - Rename := DBObject.Connection.GetSQLSpecifity(spRenameTable, [DBObject.QuotedName, DBObject.Connection.QuoteIdent(editName.Text)]); + if ObjectExists and (editName.Text <> DBObject.Name) then begin + Rename := DBObject.Connection.SqlProvider.GetSql(qRenameTable, [ + DBObject.QuotedName(True, False), + DBObject.Connection.QuoteIdent(editName.Text) + ]); DBObject.Connection.Query(Rename); + DBObject.Connection.ShowWarnings; end; - tabALTERcode.TabVisible := DBObject.Name <> ''; + tabALTERcode.TabVisible := ObjectExists; if chkCharsetConvert.Checked then begin // Autoadjust column collations for i:=0 to FColumns.Count-1 do begin @@ -437,17 +562,28 @@ function TfrmTableEditor.ApplyModifications: TModalResult; // Set table name for altering if Apply was clicked DBObject.Name := editName.Text; DBObject.UnloadDetails; - tabALTERcode.TabVisible := DBObject.Name <> ''; + tabALTERcode.TabVisible := ObjectExists; Mainform.UpdateEditorTab; MainForm.tabData.TabVisible := True; Mainform.RefreshTree(DBObject); - Mainform.RefreshHelperNode(HELPERNODE_COLUMNS); + Mainform.RefreshHelperNode(TQueryTab.HelperNodeColumns); ResetModificationFlags; AlterCodeValid := False; CreateCodeValid := False; except on E:EDbError do begin - ErrorDialog(E.Message); + ErrMessage := E.Message; + // Help user with a cryptic error message, by getting details from INNODB STATUS + // See https://stackoverflow.com/questions/8434518/mysql-foreign-key-constraint-is-incorrectly-formed-error/64251639 + if DBObject.Connection.Parameters.IsAnyMySQL + and ContainsText(ErrMessage, 'constraint is incorrectly formed') then + begin + InnodbStatus := DBObject.Connection.GetVar('SHOW ENGINE INNODB STATUS', 'Status'); + ErrMessageAdditional := RegExprGetMatch('\n([^\n]+ constraint failed\.[^\n]+)\n', InnodbStatus, 1, False, True); + if not ErrMessageAdditional.IsEmpty then + ErrMessage := ErrMessage + sLineBreak + sLineBreak + 'INNODB STATUS:' + sLineBreak + ErrMessageAdditional; + end; + ErrorDialog(ErrMessage); Result := mrAbort; end; end; @@ -474,19 +610,25 @@ procedure TfrmTableEditor.ResetModificationFlags; FColumns[i].Status := esUntouched; end; end; - DeletedKeys.Clear; + FDeletedKeys.Clear; for i:=0 to FKeys.Count-1 do begin FKeys[i].OldName := FKeys[i].Name; FKeys[i].OldIndexType := FKeys[i].IndexType; FKeys[i].Added := False; FKeys[i].Modified := False; end; - DeletedForeignKeys.Clear; + FDeletedForeignKeys.Clear; for i:=0 to FForeignKeys.Count-1 do begin FForeignKeys[i].OldKeyName := FForeignKeys[i].KeyName; FForeignKeys[i].Added := False; FForeignKeys[i].Modified := False; end; + FDeletedCheckConstraints.Clear; + for i:=0 to FCheckConstraints.Count-1 do begin + FCheckConstraints[i].Added := False; + FCheckConstraints[i].Modified := False; + end; + Modified := False; btnSave.Enabled := Modified; btnDiscard.Enabled := Modified; @@ -500,14 +642,18 @@ function TfrmTableEditor.ComposeAlterStatement: TSQLBatch; AlterColBase, AddColBase: String; i: Integer; Results: TDBQuery; - Col, PreviousCol: PTableColumn; + Col, PreviousCol: TTableColumn; + TblKey: TTableKey; + Constraint: TCheckConstraint; Node: PVirtualNode; Conn: TDBConnection; + Params: TStringMap; procedure FinishSpecs; begin if Specs.Count > 0 then begin - SQL := SQL + Trim('ALTER TABLE '+DBObject.QuotedName + CRLF + #9 + ImplodeStr(',' + CRLF + #9, Specs)) + ';' + CRLF; + SQL := SQL + Trim('ALTER TABLE '+DBObject.QuotedName + sLineBreak + + CodeIndent + Implode(',' + sLineBreak + CodeIndent, Specs)) + ';' + sLineBreak; Specs.Clear; end; end; @@ -515,7 +661,7 @@ function TfrmTableEditor.ComposeAlterStatement: TSQLBatch; procedure AddQuery(Query: String); begin FinishSpecs; - SQL := SQL + Format(Query, [DBObject.QuotedName]) + ';' + CRLF; + SQL := SQL + Format(Query, [DBObject.QuotedName]) + ';' + sLineBreak; end; begin // Compose ALTER query, called by buttons and for SQL code tab @@ -532,7 +678,7 @@ function TfrmTableEditor.ComposeAlterStatement: TSQLBatch; // ALTER TABLE statement. Separate statements are required." for i:=0 to FForeignKeys.Count-1 do begin if FForeignKeys[i].Modified and (not FForeignKeys[i].Added) then - Specs.Add('DROP FOREIGN KEY '+Conn.QuoteIdent(FForeignKeys[i].OldKeyName)); + Specs.Add(Conn.SqlProvider.GetSql(qForeignKeyDrop, [Conn.QuoteIdent(FForeignKeys[i].OldKeyName)])); end; FinishSpecs; @@ -542,7 +688,7 @@ function TfrmTableEditor.ComposeAlterStatement: TSQLBatch; // Also, do this after the data type was altered, if from TEXT > VARCHAR e.g. for i:=0 to FColumns.Count-1 do begin if (Conn.Parameters.IsAnyMySQL or Conn.Parameters.IsAnyPostgreSQL) - and (FColumns[i].FStatus = esModified) + and (FColumns[i].Status = esModified) and (FColumns[i].DefaultType = cdtNothing) and (FColumns[i].OldDataType.HasDefault) then @@ -586,7 +732,7 @@ function TfrmTableEditor.ComposeAlterStatement: TSQLBatch; Results := Conn.CollationTable; if Assigned(Results) then while not Results.Eof do begin if Results.Col('Collation') = comboCollation.Text then begin - Specs.Add('CONVERT TO CHARSET '+Results.Col('Charset')); + Specs.Add('CONVERT TO CHARSET '+Results.Col('Charset')+' COLLATE '+Conn.EscapeString(comboCollation.Text)); break; end; Results.Next; @@ -594,20 +740,17 @@ function TfrmTableEditor.ComposeAlterStatement: TSQLBatch; end; // Update columns - MainForm.EnableProgress(FColumns.Count + DeletedKeys.Count + FKeys.Count); Node := listColumns.GetFirst; PreviousCol := nil; - while Assigned(Node) do begin - Mainform.ProgressStep; - Col := listColumns.GetNodeData(Node); + for Col in FColumns do begin if Col.Status <> esUntouched then begin OverrideCollation := IfThen(chkCharsetConvert.Checked, comboCollation.Text); - AlterColBase := Conn.GetSQLSpecifity(spChangeColumn); - AddColBase := Conn.GetSQLSpecifity(spAddColumn); + AlterColBase := Conn.SqlProvider.GetSql(qChangeColumn); + AddColBase := Conn.SqlProvider.GetSql(qAddColumn); case Conn.Parameters.NetTypeGroup of - ngMySQL, ngSQLite: begin + ngMySQL: begin ColSpec := Col.SQLCode(OverrideCollation); // Server version requirement, see http://dev.mysql.com/doc/refman/4.1/en/alter-table.html if Conn.ServerVersionInt >= 40001 then begin @@ -630,18 +773,16 @@ function TfrmTableEditor.ComposeAlterStatement: TSQLBatch; ColSpec := Col.SQLCode(OverrideCollation); case Col.Status of esModified: begin - Specs.Add(Format(AlterColBase, [Conn.QuoteIdent(Col.OldName), ColSpec])); + Specs.Add(Format(AlterColBase, ['', ColSpec])); end; esAddedUntouched, esAddedModified: begin Specs.Add(Format(AddColBase, [ColSpec])); end; end; - AddQuery('EXECUTE sp_addextendedproperty '+Conn.EscapeString('MS_Description')+', '+ - Conn.EscapeString(Col.Comment)+', '+ - Conn.EscapeString('Schema')+', '+Conn.EscapeString(DBObject.Schema)+', '+ - Conn.EscapeString('table')+', '+Conn.EscapeString(DBObject.Name)+', '+ - Conn.EscapeString('column')+', '+Conn.EscapeString(Col.Name) - ); + Params := DBObject.AsStringMap; + Params.Add('NewComment', Conn.EscapeString(Col.Comment)); + Params.Add('TargetColumn', Conn.EscapeString(Col.Name)); + AddQuery(Conn.SqlProvider.GetSql(qSetColumnComment, Params)); end; ngPgSQL: begin @@ -653,7 +794,9 @@ function TfrmTableEditor.ComposeAlterStatement: TSQLBatch; // Rename if Col.Name <> Col.OldName then begin FinishSpecs; - Specs.Add(Format('RENAME COLUMN %s TO %s', [Conn.QuoteIdent(Col.OldName), Conn.QuoteIdent(Col.Name)])); + Specs.Add( + Conn.SqlProvider.GetSql(qRenameColumn, [Conn.QuoteIdent(Col.OldName), Conn.QuoteIdent(Col.Name)]) + ); FinishSpecs; end; // Type @@ -681,137 +824,241 @@ function TfrmTableEditor.ComposeAlterStatement: TSQLBatch; AddQuery('COMMENT ON COLUMN %s.'+Conn.QuoteIdent(Col.Name)+' IS '+Conn.EscapeString(Col.Comment)); end; + ngSQLite: begin + ColSpec := Col.SQLCode; + case Col.Status of + esModified: begin + // Rename + if Col.Name <> Col.OldName then begin + Specs.Add( + Conn.SqlProvider.GetSql(qRenameColumn, [Conn.QuoteIdent(Col.OldName), Conn.QuoteIdent(Col.Name)]) + ); + end; + end; + esAddedUntouched, esAddedModified: begin + Specs.Add(Format(AddColBase, [ColSpec])); + end; + end; + FinishSpecs; + end; + end; end; PreviousCol := Col; - Node := listColumns.GetNextSibling(Node); end; - // Deleted columns, not available as Node in above loop - for i:=0 to FColumns.Count-1 do begin - if FColumns[i].Status = esDeleted then begin - Specs.Add('DROP COLUMN '+Conn.QuoteIdent(FColumns[i].OldName)); - // MSSQL wants one ALTER TABLE query per DROP COLUMN - if Conn.Parameters.IsAnyMSSQL then + // Deleted columns + for Col in FColumns do begin + if Col.Status = esDeleted then begin + Specs.Add('DROP COLUMN '+Conn.QuoteIdent(Col.OldName)); + // MSSQL + SQLite want one ALTER TABLE query per DROP COLUMN + if Conn.Parameters.NetTypeGroup in [ngMSSQL, ngSQLite] then FinishSpecs; end; end; + // Drop indexes + for TblKey in FDeletedKeys do begin + if not TblKey.InsideCreateCode then + Continue; + if Conn.Parameters.IsAnyPostgreSQL then begin + if TblKey.IsPrimary or TblKey.IsUnique then + IndexSQL := 'CONSTRAINT ' + TblKey.OldName + else // wrong: + IndexSQL := 'INDEX ' + Conn.QuoteIdent(TblKey.OldName); + end + else begin + if TblKey.IsPrimary then + IndexSQL := 'PRIMARY KEY' + else + IndexSQL := 'INDEX ' + Conn.QuoteIdent(TblKey.OldName); + end; + Specs.Add('DROP '+IndexSQL); + end; + + // Drop changed indexes, and add changed or added indexes + for TblKey in FKeys do begin + if not TblKey.InsideCreateCode then + Continue; + if TblKey.Modified and (not TblKey.Added) then begin + if Conn.Parameters.IsAnyPostgreSQL then begin + if (TblKey.OldIndexType = TTableKey.PRIMARY) or (TblKey.OldIndexType = TTableKey.UNIQUE) then + IndexSQL := 'CONSTRAINT ' + TblKey.OldName + else // wrong: + IndexSQL := 'INDEX ' + Conn.QuoteIdent(TblKey.OldName); + end + else begin + if TblKey.OldIndexType = TTableKey.PRIMARY then + IndexSQL := 'PRIMARY KEY' + else + IndexSQL := 'INDEX ' + Conn.QuoteIdent(TblKey.OldName); + end; + Specs.Add('DROP '+IndexSQL); + end; + if TblKey.Added or TblKey.Modified then + Specs.Add('ADD '+TblKey.SQLCode); + end; + + for i:=0 to FDeletedForeignKeys.Count-1 do begin + Specs.Add(Conn.SqlProvider.GetSql(qForeignKeyDrop, [Conn.QuoteIdent(FDeletedForeignKeys[i])])); + end; + for i:=0 to FForeignKeys.Count-1 do begin + if FForeignKeys[i].Added or FForeignKeys[i].Modified then + Specs.Add('ADD '+FForeignKeys[i].SQLCode(True)); + end; + + // Check constraints + for i:=0 to FDeletedCheckConstraints.Count-1 do begin + Specs.Add('DROP CONSTRAINT ' + Conn.QuoteIdent(FDeletedCheckConstraints[i])); + end; + for Constraint in FCheckConstraints do begin + if Constraint.Added or Constraint.Modified then + Specs.Add('ADD ' + Constraint.SQLCode); + end; + + FinishSpecs; + + // Separate ALTER TABLE .. ALTER INDEX query for visible/invisible indexes features, which gets otherwise + // ignored in MySQL and MariaDB when done by a drop + add combined query. See issue #1388 + if Conn.SqlProvider.Has(qIndexInvisible) then begin + for i:=0 to FKeys.Count-1 do begin + if FKeys[i].Modified then begin + Specs.Add('ALTER INDEX ' + Conn.QuoteIdent(FKeys[i].Name) + ' ' + + IfThen( + FKeys[i].Visible, + Conn.SqlProvider.GetSql(qIndexVisible), + Conn.SqlProvider.GetSql(qIndexInvisible) + ) + ); + end; + end; + FinishSpecs; + end; + + + // *** Separate queries from here on + // Drop indexes, also changed indexes, which will be readded below - for i:=0 to DeletedKeys.Count-1 do begin - Mainform.ProgressStep; - if DeletedKeys[i] = TTableKey.PRIMARY then + for i:=0 to FDeletedKeys.Count-1 do begin + if FDeletedKeys[i].InsideCreateCode then + Continue; + if FDeletedKeys[i].IsPrimary then IndexSQL := 'PRIMARY KEY' else - IndexSQL := 'INDEX ' + Conn.QuoteIdent(DeletedKeys[i]); - Specs.Add('DROP '+IndexSQL); + IndexSQL := 'INDEX ' + Conn.QuoteIdent(FDeletedKeys[i].OldName); + AddQuery('DROP '+IndexSQL); end; // Add changed or added indexes for i:=0 to FKeys.Count-1 do begin - Mainform.ProgressStep; + if FKeys[i].InsideCreateCode then + Continue; if FKeys[i].Modified and (not FKeys[i].Added) then begin if FKeys[i].OldIndexType = TTableKey.PRIMARY then IndexSQL := 'PRIMARY KEY' else IndexSQL := 'INDEX ' + Conn.QuoteIdent(FKeys[i].OldName); - Specs.Add('DROP '+IndexSQL); + AddQuery('DROP '+IndexSQL); end; if FKeys[i].Added or FKeys[i].Modified then - Specs.Add('ADD '+FKeys[i].SQLCode); + AddQuery(FKeys[i].SQLCode(DBObject.Name)); end; - for i:=0 to DeletedForeignKeys.Count-1 do - Specs.Add('DROP FOREIGN KEY '+Conn.QuoteIdent(DeletedForeignKeys[i])); - for i:=0 to FForeignKeys.Count-1 do begin - if FForeignKeys[i].Added or FForeignKeys[i].Modified then - Specs.Add('ADD '+FForeignKeys[i].SQLCode(True)); - end; - - FinishSpecs; - - Result := TSQLBatch.Create; + Result := TSQLBatch.Create(DBObject.Connection.Parameters.NetTypeGroup); Result.SQL := SQL; FreeAndNil(Specs); Mainform.ShowStatusMsg; - MainForm.DisableProgress; Screen.Cursor := crDefault; end; function TfrmTableEditor.ComposeCreateStatement: TSQLBatch; var - i, IndexCount: Integer; - Col: PTableColumn; - Node: PVirtualNode; + i: Integer; + Col: TTableColumn; + Constraint: TCheckConstraint; tmp, SQL: String; + CreateLines: TStringList; begin // Compose CREATE query, called by buttons and for SQL code tab - SQL := 'CREATE TABLE '+DBObject.Connection.QuoteIdent(editName.Text)+' ('+CRLF; - Node := listColumns.GetFirst; - while Assigned(Node) do begin - Col := listColumns.GetNodeData(Node); - SQL := SQL + #9 + Col.SQLCode + ','+CRLF; - Node := listColumns.GetNextSibling(Node); + SQL := 'CREATE TABLE '+DBObject.Connection.QuoteIdent(editName.Text)+' ('+ sLineBreak; + CreateLines := TStringList.Create; + // Lines with columns, indexes, foreign keys and check constraints + for Col in FColumns do begin + if not (Col.Status in [esDeleted, esAddedDeleted]) then + CreateLines.Add(Col.SQLCode); end; - - IndexCount := 0; for i:=0 to FKeys.Count-1 do begin + if not FKeys[i].InsideCreateCode then + Continue; tmp := FKeys[i].SQLCode; if tmp <> '' then begin - SQL := SQL + #9 + tmp + ','+CRLF; - Inc(IndexCount); + CreateLines.Add(tmp); end; end; + for i:=0 to FForeignKeys.Count-1 do begin + CreateLines.Add(FForeignKeys[i].SQLCode(True)); + end; + for Constraint in FCheckConstraints do begin + CreateLines.Add(Constraint.SQLCode); + end; + SQL := SQL + CodeIndent + Implode(',' + sLineBreak + CodeIndent, CreateLines) + sLineBreak + + ')' + sLineBreak; + CreateLines.Free; - for i:=0 to FForeignKeys.Count-1 do - SQL := SQL + #9 + FForeignKeys[i].SQLCode(True) + ','+CRLF; - - if Integer(listColumns.RootNodeCount) + IndexCount + FForeignKeys.Count > 0 then - Delete(SQL, Length(SQL)-2, 3); - - SQL := SQL + CRLF + ')' + CRLF; - if memoComment.Text <> '' then - SQL := SQL + 'COMMENT='+DBObject.Connection.EscapeString(memoComment.Text) + CRLF; + if (memoComment.Text <> '') and (not DBObject.Connection.Parameters.IsAnyPostgreSQL) then + SQL := SQL + 'COMMENT='+DBObject.Connection.EscapeString(memoComment.Text) + sLineBreak; if comboCollation.Text <> '' then - SQL := SQL + 'COLLATE='+DBObject.Connection.EscapeString(comboCollation.Text) + CRLF; + SQL := SQL + 'COLLATE='+DBObject.Connection.EscapeString(comboCollation.Text) + sLineBreak; if (comboEngine.Text <> '') and (comboEngine.ItemIndex > 0) then begin if DBObject.Connection.ServerVersionInt < 40018 then - SQL := SQL + 'TYPE='+comboEngine.Text + CRLF + SQL := SQL + 'TYPE='+comboEngine.Text + sLineBreak else - SQL := SQL + 'ENGINE='+comboEngine.Text + CRLF; + SQL := SQL + 'ENGINE='+comboEngine.Text + sLineBreak; end; if comboRowFormat.Text <> 'DEFAULT' then - SQL := SQL + 'ROW_FORMAT='+comboRowFormat.Text + CRLF; + SQL := SQL + 'ROW_FORMAT='+comboRowFormat.Text + sLineBreak; if chkChecksum.Checked then - SQL := SQL + 'CHECKSUM='+IntToStr(Integer(chkChecksum.Checked)) + CRLF; + SQL := SQL + 'CHECKSUM='+IntToStr(Integer(chkChecksum.Checked)) + sLineBreak; if editAutoInc.Text <> '' then - SQL := SQL + 'AUTO_INCREMENT='+editAutoInc.Text + CRLF; + SQL := SQL + 'AUTO_INCREMENT='+editAutoInc.Text + sLineBreak; if editAvgRowLen.Text <> '' then - SQL := SQL + 'AVG_ROW_LENGTH='+editAvgRowLen.Text + CRLF; + SQL := SQL + 'AVG_ROW_LENGTH='+editAvgRowLen.Text + sLineBreak; if editMaxRows.Text <> '' then - SQL := SQL + 'MAX_ROWS='+editMaxRows.Text + CRLF; + SQL := SQL + 'MAX_ROWS='+editMaxRows.Text + sLineBreak; if memoUnionTables.Enabled and (memoUnionTables.Text <> '') then - SQL := SQL + 'UNION=('+memoUnionTables.Text+')' + CRLF; + SQL := SQL + 'UNION=('+memoUnionTables.Text+')' + sLineBreak; if comboInsertMethod.Enabled and (comboInsertMethod.Text <> '') then - SQL := SQL + 'INSERT_METHOD='+comboInsertMethod.Text + CRLF; + SQL := SQL + 'INSERT_METHOD='+comboInsertMethod.Text + sLineBreak; if SynMemoPartitions.GetTextLen > 0 then SQL := SQL + '/*!50100 ' + SynMemoPartitions.Text + ' */'; - SQL := SQL + ';' + CRLF; + SQL := SQL + ';' + sLineBreak; + + // Separate queries from here on if DBObject.Connection.Parameters.IsAnyPostgreSQL then begin - Node := listColumns.GetFirst; - while Assigned(Node) do begin - Col := listColumns.GetNodeData(Node); + if memoComment.Text <> '' then begin + SQL := SQL + 'COMMENT ON TABLE '+DBObject.Connection.QuoteIdent(editName.Text)+ + ' IS '+DBObject.Connection.EscapeString(memoComment.Text) + ';' + sLineBreak; + end; + for Col in FColumns do begin SQL := SQL + 'COMMENT ON COLUMN '+ DBObject.Connection.QuoteIdent(editName.Text)+'.'+DBObject.Connection.QuoteIdent(Col.Name)+ - ' IS '+DBObject.Connection.EscapeString(Col.Comment) + ';' + CRLF; - Node := listColumns.GetNextSibling(Node); + ' IS '+DBObject.Connection.EscapeString(Col.Comment) + ';' + sLineBreak; + end; + end; + + for i:=0 to FKeys.Count-1 do begin + if FKeys[i].InsideCreateCode then + Continue; + tmp := FKeys[i].SQLCode(editName.Text); + if tmp <> '' then begin + SQL := SQL + tmp + ';' + sLineBreak; end; end; - Result := TSQLBatch.Create; + Result := TSQLBatch.Create(DBObject.Connection.Parameters.NetTypeGroup); Result.SQL := Trim(SQL); end; @@ -832,6 +1079,43 @@ procedure TfrmTableEditor.Modification(Sender: TObject); end; end; +procedure TfrmTableEditor.ListViewReverseForeignKeysDblClick(Sender: TObject); +var + ClickItem: TListItem; + Obj: TDBObject; +begin + // Create virtual object and let mainform search for it in the tree + ClickItem := ListViewReverseForeignKeys.Selected; + if not Assigned(ClickItem) then + Exit; + Obj := TDBObject.Create(DBObject.Connection); + Obj.NodeType := lntTable; + Obj.Database := ClickItem.Caption; + Obj.Name := ClickItem.SubItems[0]; + MainForm.ActiveDbObj := Obj; +end; + +procedure TfrmTableEditor.btnShowReverseForeignKeysClick(Sender: TObject); +var + DoShow: Boolean; +begin + DoShow := btnShowReverseForeignKeys.Down; + if DoShow then begin + spltForeignKeyListings.Visible := True; + ListViewReverseForeignKeys.Visible := True; + spltForeignKeyListings.BringToFront; + spltForeignKeyListings.Left := ListViewReverseForeignKeys.Left - spltForeignKeyListings.Width; + ListViewReverseForeignKeys.BringToFront; + LoadReverseForeignKeys(Sender); + end + else begin + ListViewReverseForeignKeys.Visible := False; + spltForeignKeyListings.Visible := False; + listForeignKeys.Width := listForeignKeys.Parent.Width - tlbForeignKeys.Width; + end; + AppSettings.WriteBool(asDisplayReverseForeignKeys, DoShow); +end; + procedure TfrmTableEditor.btnAddColumnClick(Sender: TObject); var @@ -847,9 +1131,9 @@ procedure TfrmTableEditor.btnAddColumnClick(Sender: TObject); fn := listColumns.FocusedNode; NewCol := TTableColumn.Create(DBObject.Connection); if Assigned(fn) then begin - idx := fn.Index+1; // Copy properties from focused node FocusedCol := listColumns.GetNodeData(fn); + idx := FColumns.IndexOf(FocusedCol^) + 1; NewCol.DataType := FocusedCol.DataType; NewCol.LengthSet := FocusedCol.LengthSet; NewCol.Unsigned := FocusedCol.Unsigned; @@ -859,8 +1143,8 @@ procedure TfrmTableEditor.btnAddColumnClick(Sender: TObject); NewCol.DefaultType := cdtText; NewCol.DefaultText := '0'; end else begin - NewCol.DefaultType := FocusedCol.DefaultType; - NewCol.DefaultText := FocusedCol.DefaultText; + NewCol.DefaultType := cdtNothing; + NewCol.DefaultText := ''; end; NewCol.Collation := ''; end else begin @@ -871,9 +1155,9 @@ procedure TfrmTableEditor.btnAddColumnClick(Sender: TObject); NewCol.AllowNull := True; NewCol.DefaultType := cdtNothing; NewCol.DefaultText := ''; - NewCol.Comment := ''; - NewCol.Collation := ''; end; + NewCol.Comment := ''; + NewCol.Collation := ''; NewCol.Name := _('Column')+' '+IntToStr(idx+1); FColumns.Insert(idx, NewCol); NewNode := listColumns.InsertNode(fn, amInsertAfter, @NewCol); @@ -918,6 +1202,7 @@ procedure TfrmTableEditor.btnRemoveColumnClick(Sender: TObject); NodeFocus := listColumns.GetLast; if Assigned(NodeFocus) then SelectNode(listColumns, NodeFocus.Index); + listColumns.Repaint; // .Invalidate does not remove nodes immediately Modification(Sender); ValidateColumnControls; end; @@ -926,13 +1211,22 @@ procedure TfrmTableEditor.btnRemoveColumnClick(Sender: TObject); procedure TfrmTableEditor.btnMoveUpColumnClick(Sender: TObject); var Node: PVirtualNode; + Col: PTableColumn; + ColId: NativeInt; begin // Move up selected columns listColumns.EndEditNode; Node := GetNextNode(listColumns, nil, true); while Assigned(Node) do begin + // Move column within FColumns list... + Col := listColumns.GetNodeData(Node); + ColId := FColumns.IndexOf(Col^); + FColumns.Move(ColId, ColId-1); + // ... and the tree node as well listColumns.MoveTo(Node, listColumns.GetPreviousSibling(Node), amInsertBefore, False); + Col.Status := esModified; + Modification(Sender); Node := GetNextNode(listColumns, Node, true); end; @@ -943,6 +1237,8 @@ procedure TfrmTableEditor.btnMoveUpColumnClick(Sender: TObject); procedure TfrmTableEditor.btnMoveDownColumnClick(Sender: TObject); var Node: PVirtualNode; + Col: PTableColumn; + ColId: NativeInt; begin // Move down selected columns listColumns.EndEditNode; @@ -950,7 +1246,12 @@ procedure TfrmTableEditor.btnMoveDownColumnClick(Sender: TObject); Node := listColumns.GetLast; while Assigned(Node) do begin if listColumns.Selected[Node] then begin + Col := listColumns.GetNodeData(Node); + ColId := FColumns.IndexOf(Col^); + FColumns.Move(ColId, ColId+1); listColumns.MoveTo(Node, listColumns.GetNextSibling(Node), amInsertAfter, False); + Col.Status := esModified; + Modification(Sender); end; Node := listColumns.GetPrevious(Node); end; @@ -959,30 +1260,44 @@ procedure TfrmTableEditor.btnMoveDownColumnClick(Sender: TObject); end; +function TfrmTableEditor.MoveNodeAllowed(Sender: TVirtualStringTree): Boolean; +begin + // Allow moving nodes per button or per drag'n drop only if list is sorted by first column + Result := (Sender.Header.SortColumn = 0) + and (Sender.Header.SortDirection = sdAscending); +end; + procedure TfrmTableEditor.listColumnsDragOver(Sender: TBaseVirtualTree; Source: TObject; Shift: TShiftState; State: TDragState; Pt: TPoint; Mode: TDropMode; var Effect: Integer; var Accept: Boolean); begin - Accept := (Source = Sender) and (Mode <> dmNowhere); + Accept := (Source = Sender) and MoveNodeAllowed(listColumns) and (Mode <> dmNowhere); // Not sure what this effect does, probably show a specific mouse cursor? Effect := DROPEFFECT_MOVE; end; procedure TfrmTableEditor.listColumnsDragDrop(Sender: TBaseVirtualTree; - Source: TObject; DataObject: IDataObject; Formats: TFormatArray; + Source: TObject; DataObject: TVTDragDataObject; Formats: TFormatArray; Shift: TShiftState; Pt: TPoint; var Effect: Integer; Mode: TDropMode); var - Node: PVirtualNode; - AttachMode: TVTNodeAttachMode; -begin - Node := Sender.GetNodeAt(Pt.X, Pt.Y); - if Assigned(Node) then begin - case Mode of - dmAbove, dmOnNode: AttachMode := amInsertBefore; - else AttachMode := amInsertAfter; - end; - listColumns.MoveTo(listColumns.FocusedNode, Node, AttachMode, False); + ToNode: PVirtualNode; + ToCol, FocusedCol: PTableColumn; + NewIndex: NativeInt; +begin + ToNode := Sender.GetNodeAt(Pt.X, Pt.Y); + if Assigned(ToNode) then begin + FocusedCol := Sender.GetNodeData(Sender.FocusedNode); + ToCol := Sender.GetNodeData(ToNode); + NewIndex := FColumns.IndexOf(ToCol^); + if Mode = dmBelow then + Inc(NewIndex); + // Fix crash when moving to very bottom + NewIndex := Min(NewIndex, FColumns.Count-1); + FColumns.Move(FColumns.IndexOf(FocusedCol^), NewIndex); + FocusedCol.Status := esModified; + Modification(Sender); + Sender.SortTree(Sender.Header.SortColumn, Sender.Header.SortDirection); ValidateColumnControls; end; end; @@ -991,36 +1306,62 @@ procedure TfrmTableEditor.listColumnsDragDrop(Sender: TBaseVirtualTree; procedure TfrmTableEditor.listColumnsBeforeCellPaint(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; CellPaintMode: TVTCellPaintMode; CellRect: TRect; var ContentRect: TRect); +var + BgColor: TColor; begin + BgColor := MainForm.GetAlternatingRowBackground(Node); + // Darken cell background to signalize it doesn't allow length/set // Exclude non editable checkbox columns - grey looks ugly there. - if (not CellEditingAllowed(Node, Column)) and (not (Column in [4, 5, 6])) then begin - TargetCanvas.Brush.Color := GetThemeColor(clBtnFace); + if (not CellEditingAllowed(Node, Column)) and (Column <> ColNumCounter) then begin + BgColor := clBtnFace; + end; + + // Apply color + if BgColor <> clNone then begin + TargetCanvas.Brush.Color := BgColor; TargetCanvas.FillRect(CellRect); end; end; +function TfrmTableEditor.GetKeyImageIndexes(Col: TTableColumn): TList; +var + idx, i: Integer; +begin + Result := TList.Create; + for i:=0 to FKeys.Count-1 do begin + if FKeys[i].Columns.IndexOf(Col.Name) > -1 then begin + idx := FKeys[i].ImageIndex; + if not Result.Contains(idx) then + Result.Add(idx); + end; + end; + for i:=0 to FForeignKeys.Count-1 do begin + if FForeignKeys[i].Columns.IndexOf(Col.Name) > -1 then begin + idx := ICONINDEX_FOREIGNKEY; + if not Result.Contains(idx) then + Result.Add(idx); + end; + end; +end; + + procedure TfrmTableEditor.CalcMinColWidth; var - i, j, MinWidthThisCol, MinWidthAllCols: Integer; + i, MinWidthThisCol, MinWidthAllCols: Integer; + ImageIndexes: TList; begin - // Find maximum column widths so the index icons have enough room after auto-fitting + // Find maximum width for first column so both the index icons and the text have enough room MinWidthAllCols := 0; for i:=0 to FColumns.Count-1 do begin - MinWidthThisCol := 0; - for j:=0 to FKeys.Count-1 do begin - if FKeys[j].Columns.IndexOf(FColumns[i].Name) > -1 then - Inc(MinWidthThisCol, listColumns.Images.Width); - end; - for j:=0 to FForeignKeys.Count-1 do begin - if FForeignKeys[j].Columns.IndexOf(FColumns[i].Name) > -1 then - Inc(MinWidthThisCol, listColumns.Images.Width); - end; + ImageIndexes := GetKeyImageIndexes(FColumns[i]); + MinWidthThisCol := ImageIndexes.Count * listColumns.Images.Width; MinWidthAllCols := Max(MinWidthAllCols, MinWidthThisCol); end; - // Add space for number - Inc(MinWidthAllCols, listColumns.Canvas.TextWidth(IntToStr(FColumns.Count+1)) + listColumns.TextMargin*4); + // Add room for text and extra spacing + Inc(MinWidthAllCols, listColumns.GetMaxColumnWidth(0)); + Inc(MinWidthAllCols, listColumns.TextMargin); listColumns.Header.Columns[0].Width := MinWidthAllCols; end; @@ -1033,34 +1374,32 @@ procedure TfrmTableEditor.listColumnsAfterCellPaint(Sender: TBaseVirtualTree; ImageIndex, X, Y, i: Integer; VT: TVirtualStringTree; Checked: Boolean; + ImageIndexes: TList; begin VT := TVirtualStringTree(Sender); Col := Sender.GetNodeData(Node); Y := CellRect.Top + Integer(VT.NodeHeight[Node] div 2) - (VT.Images.Height div 2); - // Paint one icon per index of which this column is part of - if Column = 0 then begin + // Paint one icon per index type of which this column is part of + if Column = ColNumCounter then begin X := 0; - for i:=0 to FKeys.Count-1 do begin - if FKeys[i].Columns.IndexOf(Col.Name) > -1 then begin - ImageIndex := FKeys[i].ImageIndex; - VT.Images.Draw(TargetCanvas, X, Y, ImageIndex); - Inc(X, VT.Images.Width); - end; - end; - for i:=0 to FForeignKeys.Count-1 do begin - if FForeignKeys[i].Columns.IndexOf(Col.Name) > -1 then begin - ImageIndex := ICONINDEX_FOREIGNKEY; - VT.Images.Draw(TargetCanvas, X, Y, ImageIndex); - Inc(X, VT.Images.Width); - end; + ImageIndexes := GetKeyImageIndexes(Col^); + for i in ImageIndexes do begin + VT.Images.Draw(TargetCanvas, X, Y, i); + Inc(X, VT.Images.Width); end; + ImageIndexes.Free; end; // Paint checkbox image in certain columns // while restricting "Allow NULL" checkbox to numeric datatypes - if (Column in [4, 5, 6]) then begin - Checked := (Col.Unsigned and (Column=4)) or (Col.AllowNull and (Column=5)) or (Col.ZeroFill and (Column = 6)); + if (Column in ColNumsCheckboxes) then begin + Checked := (Col.Unsigned and (Column=ColNumUnsigned)) + or (Col.AllowNull and (Column=ColNumAllownull)) + or (Col.ZeroFill and (Column = ColNumZerofill)) + or (Col.Invisible and (Column = ColNumInvisible)) + or (Col.Compressed and (Column = ColNumCompressed)) + ; if CellEditingAllowed(Node, Column) then begin if Checked then ImageIndex := 128 else ImageIndex := 127; @@ -1097,14 +1436,17 @@ procedure TfrmTableEditor.ValidateColumnControls; btnMoveUpColumn.Enabled := (listColumns.SelectedCount > 0) and (listColumns.GetFirstSelected <> listColumns.GetFirst) - and (DBObject.Connection.Parameters.NetTypeGroup = ngMySQL); + and (DBObject.Connection.Parameters.NetTypeGroup = ngMySQL) + and MoveNodeAllowed(listColumns); btnMoveDownColumn.Enabled := (listColumns.SelectedCount > 0) and (LastSelected <> listColumns.GetLast) - and (DBObject.Connection.Parameters.NetTypeGroup = ngMySQL); + and (DBObject.Connection.Parameters.NetTypeGroup = ngMySQL) + and MoveNodeAllowed(listColumns); menuRemoveColumn.Enabled := btnRemoveColumn.Enabled; menuMoveUpColumn.Enabled := btnMoveUpColumn.Enabled; menuMoveDownColumn.Enabled := btnMoveDownColumn.Enabled; + listColumns.Invalidate; end; @@ -1112,7 +1454,7 @@ procedure TfrmTableEditor.listColumnsEditing(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; var Allowed: Boolean); begin // Allow text editing? Explicitely block that in checkbox columns - Allowed := CellEditingAllowed(Node, Column) and (not (Column in [4,5,6])); + Allowed := CellEditingAllowed(Node, Column) and (not (Column in ColNumsCheckboxes)); end; @@ -1124,22 +1466,25 @@ function TfrmTableEditor.CellEditingAllowed(Node: PVirtualNode; Column: TColumnI Col := listColumns.GetNodeData(Node); case Column of // No editor for very first column and checkbox columns - 0: Result := False; - 3: Result := Col.DataType.HasLength; - 4: begin + ColNumCounter: Result := False; + + ColNumLengthSet: Result := Col.DataType.HasLength; + + ColNumUnsigned: begin Result := (Col.DataType.Category in [dtcInteger, dtcReal]) - and (Col.DataType.Index <> dtBit) + and (Col.DataType.Index <> dbdtBit) and (DBObject.Connection.Parameters.IsAnyMySQL); if (not Result) and Col.Unsigned then begin Col.Unsigned := False; Col.Status := esModified; end; end; - 5: begin + + ColNumAllownull: begin // Do not allow NULL, and force NOT NULL, on primary key columns Result := True; for i:=0 to FKeys.Count-1 do begin - if (FKeys[i].IndexType = TTableKey.PRIMARY) and (FKeys[i].Columns.IndexOf(Col.Name) > -1) then begin + if FKeys[i].IsPrimary and (FKeys[i].Columns.IndexOf(Col.Name) > -1) then begin if Col.AllowNull then begin Col.AllowNull := False; Col.Status := esModified; @@ -1149,19 +1494,42 @@ function TfrmTableEditor.CellEditingAllowed(Node: PVirtualNode; Column: TColumnI end; end; end; - 6: begin + + ColNumZerofill: begin Result := (Col.DataType.Category in [dtcInteger, dtcReal]) - and (Col.DataType.Index <> dtBit) + and (Col.DataType.Index <> dbdtBit) and (DBObject.Connection.Parameters.IsAnyMySQL); if (not Result) and Col.ZeroFill then begin Col.ZeroFill := False; Col.Status := esModified; end; end; + // No editing of collation allowed if "Convert data" was checked - 9: Result := not chkCharsetConvert.Checked; + ColNumCollation: Result := not chkCharsetConvert.Checked; + + ColNumSrid: Result := (Col.DataType.Category = dtcSpatial) and DBObject.Connection.Has(frSrid); + + ColNumInvisible: Result := DBObject.Connection.Has(frInvisibleColumns); + + ColNumCompressed: Result := DBObject.Connection.Has(frCompressedColumns); + else Result := True; end; + + // SQLite does not support altering existing columns, except renaming. See issue #1256 + if ObjectExists and DBObject.Connection.Parameters.IsAnySQLite then begin + if Col.Status in [esUntouched, esModified, esDeleted] then begin + Result := Result and (Column = ColNumName); + if (not Result) and (not FAlterRestrictedMessageDisplayed) then begin + MainForm.LogSQL( + f_('Altering tables restricted. For details see %s', ['https://www.sqlite.org/lang_altertable.html#making_other_kinds_of_table_schema_changes']), + lcInfo + ); + FAlterRestrictedMessageDisplayed := True; + end; + end; + end; end; @@ -1175,18 +1543,27 @@ procedure TfrmTableEditor.listColumnsGetText(Sender: TBaseVirtualTree; Col := Sender.GetNodeData(Node); CellText := ''; case Column of - 0: CellText := IntToStr(Node.Index+1); - 1: CellText := Col.Name; - 2: CellText := Col.DataType.Name; - 3: CellText := Col.LengthSet; - 4, 5, 6: CellText := ''; // Checkbox - 7: begin + ColNumCounter: CellText := IntToStr(FColumns.IndexOf(Col^)+1); + + ColNumName: CellText := Col.Name; + + ColNumDatatype: CellText := Col.DataType.Name; + + ColNumLengthSet: CellText := Col.LengthSet; + + ColNumUnsigned: CellText := Col.Unsigned.ToInteger.ToString; + + ColNumAllownull: CellText := Col.AllowNull.ToInteger.ToString; + + ColNumZerofill: CellText := Col.ZeroFill.ToInteger.ToString; + + ColNumDefault: begin case Col.DefaultType of cdtNothing: CellText := _('No default'); cdtText: CellText := Col.Connection.EscapeString(Col.DefaultText); cdtNull: CellText := 'NULL'; cdtExpression: CellText := Col.DefaultText; - cdtAutoInc: CellText := 'AUTO_INCREMENT'; + cdtAutoInc: CellText := Col.Connection.SqlProvider.GetSql(qAutoInc); end; case Col.OnUpdateType of // cdtNothing: leave clause away @@ -1196,14 +1573,28 @@ procedure TfrmTableEditor.listColumnsGetText(Sender: TBaseVirtualTree; // cdtAutoInc: invalid here end; end; - 8: CellText := Col.Comment; - 9: begin + + ColNumComment: CellText := Col.Comment; + + ColNumCollation: begin CellText := Col.Collation; if (CellText <> '') and (chkCharsetConvert.Checked) then CellText := comboCollation.Text; end; - 10: CellText := Col.Expression; - 11: CellText := Col.Virtuality; + + ColNumExpression: CellText := Col.GenerationExpression; + + ColNumVirtuality: CellText := Col.Virtuality; + + ColNumSrid: begin + if (Col.DataType.Category = dtcSpatial) and (Col.Connection.Has(frSrid)) then + CellText := Col.SRID.ToString; + end; + + ColNumInvisible: CellText := Col.Invisible.ToInteger.ToString; + + ColNumCompressed: CellText := Col.Compressed.ToInteger.ToString; + end; end; @@ -1229,37 +1620,36 @@ procedure TfrmTableEditor.listColumnsPaintText(Sender: TBaseVirtualTree; const TargetCanvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType); var - TextColor: TColor; i: Integer; Col: PTableColumn; begin Col := Sender.GetNodeData(Node); // Bold font for primary key columns for i:=0 to FKeys.Count-1 do begin - if (FKeys[i].IndexType = TTableKey.PRIMARY) and (FKeys[i].Columns.IndexOf(Col.Name) > -1) then begin + if FKeys[i].IsPrimary and (FKeys[i].Columns.IndexOf(Col.Name) > -1) then begin TargetCanvas.Font.Style := TargetCanvas.Font.Style + [fsBold]; break; end; end; // No specific colors for selected nodes, would interfere with blue selection background - if vsSelected in Node.States then Exit; - // Break early if nothing to do - if not (Column in [2, 7]) then Exit; + // Disabled in Oct 2023, probably works better than expected + //if vsSelected in Node.States then Exit; // Give datatype column specific color, as set in preferences - TextColor := TargetCanvas.Font.Color; case Column of - 2: TextColor := DatatypeCategories[Col.DataType.Category].Color; + ColNumCounter: TargetCanvas.Font.Color := clGrayText; + + ColNumDatatype: TargetCanvas.Font.Color := DatatypeCategories[Col.DataType.Category].Color; - 7: case Col.DefaultType of + ColNumDefault: case Col.DefaultType of cdtNothing, cdtNull: - TextColor := DatatypeCategories[Col.DataType.Category].NullColor; + TargetCanvas.Font.Color := DatatypeCategories[Col.DataType.Category].NullColor; else - TextColor := DatatypeCategories[Col.DataType.Category].Color; + TargetCanvas.Font.Color := DatatypeCategories[Col.DataType.Category].Color; end; end; - TargetCanvas.Font.Color := TextColor; + end; @@ -1270,12 +1660,13 @@ procedure TfrmTableEditor.listColumnsNewText(Sender: TBaseVirtualTree; Col: PTableColumn; Key: TTableKey; WasModified: Boolean; + OldDatatype: TDBDatatype; begin // Column property edited Col := Sender.GetNodeData(Node); WasModified := True; case Column of - 1: begin // Name of column + ColNumName: begin for i:=0 to FColumns.Count-1 do begin if (FColumns[i].Name = NewText) and (not (FColumns[i].Status in [esDeleted, esAddedDeleted])) then begin ErrorDialog(f_('Column "%s" already exists.', [NewText])); @@ -1291,43 +1682,63 @@ procedure TfrmTableEditor.listColumnsNewText(Sender: TBaseVirtualTree; treeIndexes.Invalidate; Col.Name := NewText; end; - 2: begin // Data type + + ColNumDatatype: begin + OldDatatype := Col.DataType; Col.DataType := DBObject.Connection.GetDatatypeByName(NewText, False, Col.Name); // Reset length/set for column types which don't support that if not Col.DataType.HasLength then Col.LengthSet := ''; + // Remove subpart from indexes where this column is a part of + if Col.DataType.Category <> dtcText then begin + for Key in FKeys do begin + for i:=0 to Key.Columns.Count-1 do begin + if Key.Columns[i] = Col.Name then + Key.SubParts[i] := ''; + end; + end; + treeIndexes.Invalidate; + end; // Suggest length/set if required if (not Col.LengthCustomized) or (Col.DataType.RequiresLength and (Col.LengthSet = '')) then Col.LengthSet := Col.DataType.DefLengthSet; - // Auto-fix user selected default type which can be invalid now - case Col.DataType.Category of - dtcInteger: begin - Col.DefaultType := cdtExpression; - if Col.AllowNull then - Col.DefaultType := cdtNull - else - Col.DefaultText := IntToStr(MakeInt(Col.DefaultText)); - end; - dtcReal: begin - Col.DefaultType := cdtExpression; - if Col.AllowNull then - Col.DefaultType := cdtNull - else - Col.DefaultText := FloatToStr(MakeFloat(Col.DefaultText)); - end; - dtcText, dtcBinary, dtcSpatial, dtcOther: begin - Col.DefaultType := cdtText; - if Col.AllowNull then - Col.DefaultType := cdtNull; - end; - dtcTemporal: begin - if Col.DefaultType = cdtAutoinc then - Col.DefaultType := cdtNothing; + // Auto-change default type and text + if Col.DataType.Category <> OldDatatype.Category then begin + if not Col.DataType.HasDefault then begin + Col.DefaultType := cdtNothing; + Col.DefaultText := ''; + end else begin + // Auto-fix user selected default type which can be invalid now + case Col.DataType.Category of + dtcInteger: begin + Col.DefaultType := cdtExpression; + if Col.AllowNull then + Col.DefaultType := cdtNull + else + Col.DefaultText := IntToStr(MakeInt(Col.DefaultText)); + end; + dtcReal: begin + Col.DefaultType := cdtExpression; + if Col.AllowNull then + Col.DefaultType := cdtNull + else + Col.DefaultText := FloatToStr(MakeFloat(Col.DefaultText)); + end; + dtcText, dtcBinary, dtcSpatial, dtcOther: begin + Col.DefaultType := cdtText; + if Col.AllowNull then + Col.DefaultType := cdtNull; + end; + dtcTemporal: begin + if Col.DefaultType = cdtAutoinc then + Col.DefaultType := cdtNothing; + end; + end; end; end; + end; - end; // Length / Set - 3: begin + ColNumLengthSet: begin if Col.DataType.RequiresLength and (NewText='') then begin WasModified := False; ErrorDialog(f_('Column data type %s requires a length/set', [Col.DataType.Name])); @@ -1336,16 +1747,24 @@ procedure TfrmTableEditor.listColumnsNewText(Sender: TBaseVirtualTree; Col.LengthCustomized := True; end; end; - // 4 + 5 are checkboxes - handled in OnClick - 7: begin // Default value + + // 4, 5, 6, 13 are checkboxes - handled in OnClick + + ColNumDefault: begin // DefaultText/Type and OnUpdateText/Type are set in TColumnDefaultEditorLink.EndEdit if Col.DefaultType = cdtNull then Col.AllowNull := True; end; - 8: Col.Comment := NewText; - 9: Col.Collation := NewText; - 10: Col.Expression := NewText; - 11: Col.Virtuality := NewText; + + ColNumComment: Col.Comment := NewText; + + ColNumCollation: Col.Collation := NewText; + + ColNumExpression: Col.GenerationExpression := NewText; + + ColNumVirtuality: Col.Virtuality := NewText; + + ColNumSrid: Col.SRID := StrToUIntDef(NewText, 0); end; if WasModified then begin Col.Status := esModified; @@ -1354,16 +1773,6 @@ procedure TfrmTableEditor.listColumnsNewText(Sender: TBaseVirtualTree; end; -procedure TfrmTableEditor.listColumnsNodeMoved(Sender: TBaseVirtualTree; Node: PVirtualNode); -var - Col: PTableColumn; -begin - Col := Sender.GetNodeData(Node); - Col.Status := esModified; - Modification(Sender); -end; - - procedure TfrmTableEditor.listColumnsChange(Sender: TBaseVirtualTree; Node: PVirtualNode); begin @@ -1391,7 +1800,7 @@ procedure TfrmTableEditor.listColumnsKeyPress(Sender: TObject; var Key: Char); begin // Space/click on checkbox column VT := Sender as TVirtualStringTree; - if (Ord(Key) = VK_SPACE) and (VT.FocusedColumn in [4, 5, 6]) then + if (Ord(Key) = VK_SPACE) and (VT.FocusedColumn in ColNumsCheckboxes) then vtHandleClickOrKeyPress(VT, VT.FocusedNode, VT.FocusedColumn, []); end; @@ -1409,13 +1818,14 @@ procedure TfrmTableEditor.vtHandleClickOrKeyPress(Sender: TVirtualStringTree; if CellEditingAllowed(Node, Column) then begin Col := VT.GetNodeData(Node); case Column of - 4: begin + ColNumUnsigned: begin Col.Unsigned := not Col.Unsigned; Col.Status := esModified; Modification(Sender); VT.InvalidateNode(Node); end; - 5: begin + + ColNumAllownull: begin Col.AllowNull := not Col.AllowNull; // Switch default value from NULL to Text if Allow Null is off if (not Col.AllowNull) and (Col.DefaultType = cdtNull) then begin @@ -1426,12 +1836,28 @@ procedure TfrmTableEditor.vtHandleClickOrKeyPress(Sender: TVirtualStringTree; Modification(Sender); VT.InvalidateNode(Node); end; - 6: begin + + ColNumZerofill: begin Col.ZeroFill := not Col.ZeroFill; Col.Status := esModified; Modification(Sender); VT.InvalidateNode(Node); end; + + ColNumInvisible: begin + Col.Invisible := not Col.Invisible; + Col.Status := esModified; + Modification(Sender); + VT.InvalidateNode(Node); + end; + + ColNumCompressed: begin + Col.Compressed := not Col.Compressed; + Col.Status := esModified; + Modification(Sender); + VT.InvalidateNode(Node); + end; + else begin // All other cells go into edit mode please // Explicitely done on OnClick, not in OnFocusChanged which seemed annoying for keyboard users @@ -1456,27 +1882,44 @@ procedure TfrmTableEditor.listColumnsCreateEditor(Sender: TBaseVirtualTree; VT := Sender as TVirtualStringTree; Col := Sender.GetNodeData(Node); case Column of - 2: begin // Datatype pulldown - DatatypeEditor := TDatatypeEditorLink.Create(VT, True); + ColNumDatatype: begin // Datatype pulldown + DatatypeEditor := TDatatypeEditorLink.Create(VT, True, Col^); EditLink := DataTypeEditor; end; - 9: begin // Collation pulldown - EnumEditor := TEnumEditorLink.Create(VT, True); + + ColNumLengthSet: begin + if DBObject.Connection.Parameters.IsAnyPostgreSQL and (Col.DataType.Index = dbdtEnum) then begin + EnumEditor := TEnumEditorLink.Create(VT, True, Col^); + EnumEditor.AllowCustomText := True; + EnumEditor.ItemMustExist := False; + EnumEditor.ValueList := Explode('|', Col.DataType.Names); + EnumEditor.ValueList.Insert(0, ''); + EditLink := EnumEditor; + end; + end; + + ColNumCollation: begin // Collation pulldown + EnumEditor := TEnumEditorLink.Create(VT, True, Col^); + EnumEditor.AllowCustomText := True; + EnumEditor.ItemMustExist := True; EnumEditor.ValueList := TStringList.Create; EnumEditor.ValueList.Text := DBObject.Connection.CollationList.Text; + EnumEditor.ValueList.Sort; EnumEditor.ValueList.Insert(0, ''); EditLink := EnumEditor; end; - 7: begin - DefaultEditor := TColumnDefaultEditorLink.Create(VT, True); + + ColNumDefault: begin + DefaultEditor := TColumnDefaultEditorLink.Create(VT, True, Col^); DefaultEditor.DefaultType := Col.DefaultType; DefaultEditor.DefaultText := Col.DefaultText; DefaultEditor.OnUpdateType := Col.OnUpdateType; DefaultEditor.OnUpdateText := Col.OnUpdateText; EditLink := DefaultEditor; end; - 11: begin // Virtuality pulldown - EnumEditor := TEnumEditorLink.Create(VT, True); + + ColNumVirtuality: begin // Virtuality pulldown + EnumEditor := TEnumEditorLink.Create(VT, True, Col^); EnumEditor.ValueList := TStringList.Create; if DBObject.Connection.Parameters.IsMariaDB then EnumEditor.ValueList.CommaText := ',VIRTUAL,PERSISTENT' @@ -1484,14 +1927,32 @@ procedure TfrmTableEditor.listColumnsCreateEditor(Sender: TBaseVirtualTree; EnumEditor.ValueList.CommaText := ',VIRTUAL,STORED'; EditLink := EnumEditor; end - else begin - Edit := TInplaceEditorLink.Create(VT, True); - Edit.TitleText := VT.Header.Columns[Column].Text; - Edit.ButtonVisible := True; - EditLink := Edit; + + end; + + if (not Assigned(EditLink)) then begin + Edit := TInplaceEditorLink.Create(VT, True, Col^); + Edit.TitleText := VT.Header.Columns[Column].Text; + Edit.ButtonVisible := True; + EditLink := Edit; + end; +end; + +procedure TfrmTableEditor.treeIndexesBeforeCellPaint(Sender: TBaseVirtualTree; + TargetCanvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; + CellPaintMode: TVTCellPaintMode; CellRect: TRect; var ContentRect: TRect); +var + Key: TTableKey; +begin + if Sender.GetNodeLevel(Node) <> 0 then + Exit; + case Column of + IndexColNumSize: begin + // Paint "progress" bar in size column + Key := FKeys[Node.Index]; + MainForm.PaintColorBar(Key.Size, FKeys.MaxSize, TargetCanvas, CellRect); end; end; - TBaseGridEditorLink(EditLink).TableColumn := Col^; end; @@ -1576,7 +2037,7 @@ procedure TfrmTableEditor.menuAddIndexColumnClick(Sender: TObject); end; if not ColExists then begin NewCol := Column.Name; - if (TblKey.IndexType <> TTableKey.FULLTEXT) and (Column.DataType.Index in [dtTinyText, dtText, dtMediumText, dtLongText, dtTinyBlob, dtBlob, dtMediumBlob, dtLongBlob]) then + if (not TblKey.IsFulltext) and (Column.DataType.Index in [dbdtTinyText, dbdtText, dbdtMediumText, dbdtLongText, dbdtTinyBlob, dbdtBlob, dbdtMediumBlob, dbdtLongBlob]) then PartLength := '100'; break; end; @@ -1584,6 +2045,7 @@ procedure TfrmTableEditor.menuAddIndexColumnClick(Sender: TObject); treeIndexes.AddChild(Node); TblKey.Columns.Add(NewCol); TblKey.SubParts.Add(PartLength); + TblKey.Collations.Add('A'); Modification(Sender); treeIndexes.Invalidate; SelectNode(treeIndexes, FKeys.Count-1, Node); @@ -1594,6 +2056,7 @@ procedure TfrmTableEditor.btnRemoveIndexClick(Sender: TObject); var idx: Integer; NewSelectNode: PVirtualNode; + DeleteTblKey: TTableKey; begin // Remove index or part if treeIndexes.IsEditing then @@ -1601,8 +2064,11 @@ procedure TfrmTableEditor.btnRemoveIndexClick(Sender: TObject); case treeIndexes.GetNodeLevel(treeIndexes.FocusedNode) of 0: begin idx := treeIndexes.FocusedNode.Index; - if not FKeys[idx].Added then - DeletedKeys.Add(FKeys[idx].OldName); + if not FKeys[idx].Added then begin + DeleteTblKey := TTableKey.Create(DBObject.Connection); + DeleteTblKey.Assign(FKeys[idx]); + FDeletedKeys.Add(DeleteTblKey); + end; FKeys.Delete(idx); // Delete node although ReinitChildren would do the same, but the Repaint before // creates AVs in certain cases. See issue #2557 @@ -1612,6 +2078,7 @@ procedure TfrmTableEditor.btnRemoveIndexClick(Sender: TObject); idx := treeIndexes.FocusedNode.Parent.Index; FKeys[idx].Columns.Delete(treeIndexes.FocusedNode.Index); FKeys[idx].SubParts.Delete(treeIndexes.FocusedNode.Index); + FKeys[idx].Collations.Delete(treeIndexes.FocusedNode.Index); treeIndexes.DeleteNode(treeIndexes.FocusedNode); end; end; @@ -1626,7 +2093,7 @@ procedure TfrmTableEditor.btnRemoveIndexClick(Sender: TObject); procedure TfrmTableEditor.btnClearIndexesClick(Sender: TObject); var - TblKey: TTableKey; + TblKey, DeleteTblKey: TTableKey; begin // Clear all indexes // Column data gets freed below - end any editor which could cause AV's @@ -1635,8 +2102,11 @@ procedure TfrmTableEditor.btnClearIndexesClick(Sender: TObject); // Trigger ValidateIndexControls SelectNode(treeIndexes, nil); for TblKey in FKeys do begin - if not TblKey.Added then - DeletedKeys.Add(TblKey.OldName); + if not TblKey.Added then begin + DeleteTblKey := TTableKey.Create(DBObject.Connection); + DeleteTblKey.Assign(TblKey); + FDeletedKeys.Add(DeleteTblKey); + end; end; FKeys.Clear; Modification(Sender); @@ -1649,14 +2119,26 @@ procedure TfrmTableEditor.treeIndexesGetImageIndex(Sender: TBaseVirtualTree; var Ghosted: Boolean; var ImageIndex: TImageIndex); var VT: TVirtualStringTree; + TblKey: TTableKey; begin // Icon image showing type of index VT := Sender as TVirtualStringTree; - if Column <> 0 then Exit; - if not (Kind in [ikNormal, ikSelected]) then Exit; + if Column <> IndexColNumName then + Exit; + if not (Kind in [ikNormal, ikSelected]) then + Exit; case VT.GetNodeLevel(Node) of - 0: ImageIndex := FKeys[Node.Index].ImageIndex; - 1: ImageIndex := 42; + 0: begin + ImageIndex := FKeys[Node.Index].ImageIndex; + Ghosted := not FKeys[Node.Index].Visible; + end; + 1: begin + TblKey := FKeys[Node.Parent.Index]; + if TblKey.IsExpression(Node.Index) then + ImageIndex := 13 + else + ImageIndex := ICONINDEX_FIELD; + end; end; end; @@ -1668,24 +2150,40 @@ procedure TfrmTableEditor.treeIndexesGetText(Sender: TBaseVirtualTree; TblKey: TTableKey; begin // Index tree showing cell text + CellText := ''; case Sender.GetNodeLevel(Node) of 0: begin TblKey := FKeys[Node.Index]; case Column of - 0: if TblKey.IndexType = TTableKey.PRIMARY then - CellText := TblKey.IndexType + ' KEY' // Fixed name "PRIMARY KEY", cannot be changed - else - CellText := TblKey.Name; - 1: CellText := TblKey.IndexType; - 2: CellText := TblKey.Algorithm; + IndexColNumName: begin + if TblKey.IsPrimary then + CellText := TblKey.IndexType + ' KEY' // Fixed name "PRIMARY KEY", cannot be changed + else + CellText := TblKey.Name; + end; + IndexColNumType: CellText := TblKey.IndexType; + IndexColNumAlgorithm: CellText := TblKey.Algorithm; + IndexColNumComment: CellText := TblKey.Comment; + IndexColNumVisibility: CellText := IfThen( + TblKey.Visible, + DBObject.Connection.SqlProvider.GetSql(qIndexVisible), + DBObject.Connection.SqlProvider.GetSql(qIndexInvisible) + ); + IndexColNumSize: begin + if TblKey.Size >= 0 then + CellText := FormatByteNumber(TblKey.Size); + end; end; end; 1: begin TblKey := FKeys[Node.Parent.Index]; case Column of - 0: CellText := TblKey.Columns[Node.Index]; - 1: CellText := TblKey.SubParts[Node.Index]; - 2: CellText := ''; + IndexColNumName: CellText := TblKey.Columns[Node.Index]; + IndexColNumType: CellText := TblKey.SubParts[Node.Index]; + IndexColNumDirection: begin + CellText := TblKey.Collations[Node.Index]; + CellText := IfThen(CellText.ToLower = 'a', 'ASC', 'DESC'); + end; end; end; end; @@ -1717,7 +2215,7 @@ procedure TfrmTableEditor.treeIndexesFocusChanged(Sender: TBaseVirtualTree; end; -procedure TfrmTableEditor.treeIndexesClick(Sender: TObject); +procedure TfrmTableEditor.AnyTreeClick(Sender: TObject); var VT: TVirtualStringTree; Click: THitInfo; @@ -1747,14 +2245,152 @@ procedure TfrmTableEditor.ValidateIndexControls; btnMoveUpIndex.Enabled := HasNode and (Level = 1) and (Node <> treeIndexes.GetFirstChild(Node.Parent)); btnMoveDownIndex.Enabled := HasNode and (Level = 1) and (Node <> treeIndexes.GetLastChild(Node.Parent)); - menuAddIndexColumn.Enabled := HasNode; - menuRemoveIndex.Enabled := btnRemoveIndex.Enabled; - menuClearIndexes.Enabled := btnClearIndexes.Enabled; menuMoveUpIndex.Enabled := btnMoveUpIndex.Enabled; menuMoveDownIndex.Enabled := btnMoveDownIndex.Enabled; end; +procedure TfrmTableEditor.btnAddCheckConstraintClick(Sender: TObject); +var + CheckConstraint: TCheckConstraint; + idx: Integer; +begin + // Add new check constraint + CheckConstraint := TCheckConstraint.Create(DBObject.Connection); + idx := FCheckConstraints.Add(CheckConstraint); + CheckConstraint.Name := 'CC'+IntToStr(idx+1); + CheckConstraint.CheckClause := ''; + CheckConstraint.Added := True; + Modification(Sender); + listCheckConstraints.Repaint; + SelectNode(listCheckConstraints, idx); + listCheckConstraints.EditNode(listCheckConstraints.FocusedNode, listCheckConstraints.Header.MainColumn); +end; + + +procedure TfrmTableEditor.btnRemoveCheckConstraintClick(Sender: TObject); +var + Constraint: TCheckConstraint; +begin + // Remove a foreign key + listCheckConstraints.CancelEditNode; + Constraint := FCheckConstraints[listCheckConstraints.FocusedNode.Index]; + if (not Constraint.Added) and (not Constraint.Modified) then + FDeletedCheckConstraints.Add(Constraint.Name); + FCheckConstraints.Delete(listCheckConstraints.FocusedNode.Index); + Modification(Sender); + listCheckConstraints.Repaint; +end; + + +procedure TfrmTableEditor.btnClearCheckConstraintsClick(Sender: TObject); +var + i: Integer; +begin + // Clear all check constraints + listCheckConstraints.CancelEditNode; + for i:=FCheckConstraints.Count-1 downto 0 do begin + if (not FCheckConstraints[i].Added) and (not FCheckConstraints[i].Modified) then + FDeletedCheckConstraints.Add(FCheckConstraints[i].Name); + FCheckConstraints.Delete(i); + end; + Modification(Sender); + listCheckConstraints.Repaint; +end; + + +procedure TfrmTableEditor.listCheckConstraintsBeforePaint( + Sender: TBaseVirtualTree; TargetCanvas: TCanvas); +begin + // Set RootNodeCount + listCheckConstraints.RootNodeCount := FCheckConstraints.Count; + btnClearCheckConstraints.Enabled := listCheckConstraints.RootNodeCount > 0; +end; + + +procedure TfrmTableEditor.listCheckConstraintsCreateEditor( + Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; + out EditLink: IVTEditLink); +var + VT: TVirtualStringTree; + Edit: TInplaceEditorLink; + EnumEditor: TEnumEditorLink; + SQLFunc: TSQLFunction; +begin + // Edit check constraint + VT := Sender as TVirtualStringTree; + case Column of + 0: begin + Edit := TInplaceEditorLink.Create(VT, True, nil); + Edit.TitleText := VT.Header.Columns[Column].Text; + Edit.ButtonVisible := True; + EditLink := Edit; + end; + 1: begin + EnumEditor := TEnumEditorLink.Create(VT, True, nil); + for SQLFunc in DBObject.Connection.SQLFunctions do + EnumEditor.ValueList.Add(SQLFunc.Name + SQLFunc.Declaration); + EnumEditor.AllowCustomText := True; + EditLink := EnumEditor; + end; + end; +end; + + +procedure TfrmTableEditor.listCheckConstraintsFocusChanged( + Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex); +begin + // Focus on list changed + btnRemoveCheckConstraint.Enabled := Assigned(Node); +end; + + +procedure TfrmTableEditor.listCheckConstraintsGetImageIndex( + Sender: TBaseVirtualTree; Node: PVirtualNode; Kind: TVTImageKind; + Column: TColumnIndex; var Ghosted: Boolean; var ImageIndex: TImageIndex); +begin + // Return image index for node cell in list + if not (Kind in [ikNormal, ikSelected]) then Exit; + case Column of + 0: ImageIndex := tabCheckConstraints.ImageIndex; + else ImageIndex := -1; + end; +end; + + +procedure TfrmTableEditor.listCheckConstraintsGetText(Sender: TBaseVirtualTree; + Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; + var CellText: string); +var + CheckConstraint: TCheckConstraint; +begin + // Return cell text in list + CheckConstraint := FCheckConstraints[Node.Index]; + case Column of + 0: CellText := CheckConstraint.Name; + 1: CellText := CheckConstraint.CheckClause; + end; +end; + + +procedure TfrmTableEditor.listCheckConstraintsNewText(Sender: TBaseVirtualTree; + Node: PVirtualNode; Column: TColumnIndex; NewText: string); +var + Constraint: TCheckConstraint; +begin + // Check constraint edited + Constraint := FCheckConstraints[Node.Index]; + if (not Constraint.Added) and (not Constraint.Modified) then + FDeletedCheckConstraints.Add(Constraint.Name); + case Column of + 0: Constraint.Name := NewText; + 1: Constraint.CheckClause := NewText; + end; + Constraint.Modified := True; + Modification(Sender); +end; + + procedure TfrmTableEditor.treeIndexesEditing(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; var Allowed: Boolean); var @@ -1765,21 +2401,28 @@ procedure TfrmTableEditor.treeIndexesEditing(Sender: TBaseVirtualTree; VT := Sender as TVirtualStringtree; Allowed := False; if VT.GetNodeLevel(Node) = 0 then begin - // Disallow renaming primary key - if (Column <> 0) or (VT.Text[Node, 1] <> TTableKey.PRIMARY) then - Allowed := True - end else case Column of - 0: Allowed := True; - 1: begin + // Disallow renaming primary key, and direction/collation of key node level + case Column of + IndexColNumName: Allowed := (VT.Text[Node, 1] <> TTableKey.PRIMARY); + IndexColNumType: Allowed := True; + IndexColNumAlgorithm: Allowed := True; + IndexColNumComment: Allowed := True; + IndexColNumVisibility: Allowed := DBObject.Connection.SqlProvider.Has(qIndexInvisible); + end; + end + else case Column of + IndexColNumName: Allowed := True; + IndexColNumType: begin // Column length is allowed for (var)char/text types only, even mandantory for text and blobs IndexedColName := VT.Text[Node, 0]; for i:=0 to FColumns.Count-1 do begin if FColumns[i].Name = IndexedColName then begin - Allowed := FColumns[i].DataType.Category = dtcText; + Allowed := FColumns[i].DataType.Category in [dtcText, dtcBinary]; break; end; end; end; + IndexColNumDirection: Allowed := True; // Collation end; end; @@ -1796,20 +2439,27 @@ procedure TfrmTableEditor.treeIndexesCreateEditor(Sender: TBaseVirtualTree; // Start cell editor VT := Sender as TVirtualStringTree; Level := (Sender as TVirtualStringtree).GetNodeLevel(Node); - if (Level = 0) and (Column = 1) then begin + if (Level = 0) and (Column = IndexColNumType) then begin // Index type pulldown - EnumEditor := TEnumEditorLink.Create(VT, True); + EnumEditor := TEnumEditorLink.Create(VT, True, nil); EnumEditor.ValueList := TStringList.Create; EnumEditor.ValueList.CommaText := TTableKey.PRIMARY +','+ TTableKey.KEY +','+ TTableKey.UNIQUE +','+ TTableKey.FULLTEXT +','+ TTableKey.SPATIAL; EditLink := EnumEditor; - end else if (Level = 0) and (Column = 2) then begin + end else if (Level = 0) and (Column = IndexColNumAlgorithm) then begin // Algorithm pulldown - EnumEditor := TEnumEditorLink.Create(VT, True); + EnumEditor := TEnumEditorLink.Create(VT, True, nil); EnumEditor.ValueList := Explode(',', ',BTREE,HASH,RTREE'); EditLink := EnumEditor; - end else if (Level = 1) and (Column = 0) then begin + end else if (Level = 0) and (Column = IndexColNumVisibility) then begin + // Visibility pulldown + EnumEditor := TEnumEditorLink.Create(VT, True, nil); + EnumEditor.ValueList.Add(''); + EnumEditor.ValueList.Add(DBObject.Connection.SqlProvider.GetSql(qIndexVisible)); + EnumEditor.ValueList.Add(DBObject.Connection.SqlProvider.GetSql(qIndexInvisible)); + EditLink := EnumEditor; + end else if (Level = 1) and (Column = IndexColNumName) then begin // Column names pulldown - EnumEditor := TEnumEditorLink.Create(VT, True); + EnumEditor := TEnumEditorLink.Create(VT, True, nil); ColNode := listColumns.GetFirst; while Assigned(ColNode) do begin Col := listColumns.GetNodeData(ColNode); @@ -1818,8 +2468,12 @@ procedure TfrmTableEditor.treeIndexesCreateEditor(Sender: TBaseVirtualTree; end; EnumEditor.AllowCustomText := True; // Allows adding a subpart in index parts: "TextCol(20)" EditLink := EnumEditor; + end else if (Level = 1) and (Column = IndexColNumDirection) then begin + EnumEditor := TEnumEditorLink.Create(VT, True, nil); + EnumEditor.ValueList := Explode(',', ',ASC,DESC'); + EditLink := EnumEditor; end else - EditLink := TInplaceEditorLink.Create(VT, True); + EditLink := TInplaceEditorLink.Create(VT, True, nil); end; @@ -1836,13 +2490,15 @@ procedure TfrmTableEditor.treeIndexesNewText(Sender: TBaseVirtualTree; 0: begin TblKey := FKeys[Node.Index]; case Column of - 0: TblKey.Name := NewText; - 1: begin + IndexColNumName: TblKey.Name := NewText; + IndexColNumType: begin TblKey.IndexType := NewText; if NewText = TTableKey.PRIMARY then TblKey.Name := TTableKey.PRIMARY; end; - 2: TblKey.Algorithm := NewText; + IndexColNumAlgorithm: TblKey.Algorithm := NewText; + IndexColNumComment: TblKey.Comment := NewText; + IndexColNumVisibility: TblKey.Visible := SameText(NewText, DBObject.Connection.SqlProvider.GetSql(qIndexVisible)); end; // Needs to be called manually for Name and IndexType properties: TblKey.Modification(Sender); @@ -1850,7 +2506,7 @@ procedure TfrmTableEditor.treeIndexesNewText(Sender: TBaseVirtualTree; 1: begin TblKey := FKeys[Node.Parent.Index]; case Column of - 0: begin + IndexColNumName: begin // Detect input of "col(123)" and move "123" into subpart rx := TRegExpr.Create; rx.Expression := '.+\((\d+)\)'; @@ -1860,7 +2516,13 @@ procedure TfrmTableEditor.treeIndexesNewText(Sender: TBaseVirtualTree; end else TblKey.Columns[Node.Index] := NewText; end; - 1: TblKey.SubParts[Node.Index] := NewText; + IndexColNumType: TblKey.SubParts[Node.Index] := NewText; + IndexColNumDirection: begin + if NewText.ToLower = 'asc' then + TblKey.Collations[Node.Index] := 'A' + else + TblKey.Collations[Node.Index] := 'D'; + end; end; TblKey.Modified := True; end; @@ -1902,7 +2564,7 @@ procedure TfrmTableEditor.treeIndexesDragOver(Sender: TBaseVirtualTree; procedure TfrmTableEditor.treeIndexesDragDrop(Sender: TBaseVirtualTree; - Source: TObject; DataObject: IDataObject; Formats: TFormatArray; + Source: TObject; DataObject: TVTDragDataObject; Formats: TFormatArray; Shift: TShiftState; Pt: TPoint; var Effect: Integer; Mode: TDropMode); var FocusedNode, TargetNode, IndexNode: PVirtualNode; @@ -1968,9 +2630,10 @@ procedure TfrmTableEditor.treeIndexesDragDrop(Sender: TBaseVirtualTree; TblKey.Columns.Insert(ColPos, ColName); PartLength := ''; - if (TblKey.IndexType <> TTableKey.FULLTEXT) and (Col.DataType.Index in [dtTinyText, dtText, dtMediumText, dtLongText, dtTinyBlob, dtBlob, dtMediumBlob, dtLongBlob]) then + if (not TblKey.IsFulltext) and (Col.DataType.Index in [dbdtTinyText, dbdtText, dbdtMediumText, dbdtLongText, dbdtTinyBlob, dbdtBlob, dbdtMediumBlob, dbdtLongBlob]) then PartLength := '100'; TblKey.Subparts.Insert(ColPos, PartLength); + TblKey.Collations.Insert(ColPos, 'A'); IndexNode.States := IndexNode.States + [vsHasChildren, vsExpanded]; end; Modification(Sender); @@ -2008,6 +2671,7 @@ procedure TfrmTableEditor.MoveFocusedIndexPart(NewIdx: Cardinal); end; TblKey.Columns.Move(treeIndexes.FocusedNode.Index, NewIdx); TblKey.SubParts.Move(treeIndexes.FocusedNode.Index, NewIdx); + TblKey.Collations.Move(treeIndexes.FocusedNode.Index, NewIdx); Modification(treeIndexes); SelectNode(treeIndexes, NewIdx, treeIndexes.FocusedNode.Parent); end; @@ -2017,16 +2681,19 @@ procedure TfrmTableEditor.PageControlMainChange(Sender: TObject); begin treeIndexes.EndEditNode; listForeignKeys.EndEditNode; + listCheckConstraints.EndEditNode; // Ensure SynMemo's have focus, otherwise Select-All and Copy actions may fail - if PageControlMain.ActivePage = tabCREATEcode then begin - if SynMemoCreateCode.CanFocus then - SynMemoCreateCode.SetFocus; + if PageControlMain.ActivePage = tabForeignKeys then begin + LoadReverseForeignKeys(Sender); + end + else if PageControlMain.ActivePage = tabCREATEcode then begin + SynMemoCreateCode.TrySetFocus; end else if PageControlMain.ActivePage = tabALTERcode then begin - if SynMemoALTERcode.CanFocus then - SynMemoAlterCode.SetFocus; + SynMemoAlterCode.TrySetFocus; end; UpdateSQLcode; + TExtForm.PageControlTabHighlight(PageControlMain); end; @@ -2040,7 +2707,7 @@ procedure TfrmTableEditor.UpdateSQLcode; OldTopLine := SynMemoALTERcode.TopLine; SynMemoALTERcode.Clear; for Query in ComposeAlterStatement do - SynMemoALTERcode.Text := SynMemoALTERcode.Text + Query.SQL + ';' + CRLF; + SynMemoALTERcode.Text := SynMemoALTERcode.Text + Query.SQL + ';' + sLineBreak; SynMemoALTERcode.TopLine := OldTopLine; SynMemoALTERcode.EndUpdate; AlterCodeValid := True; @@ -2049,7 +2716,7 @@ procedure TfrmTableEditor.UpdateSQLcode; OldTopLine := SynMemoCREATEcode.TopLine; SynMemoCREATEcode.Clear; for Query in ComposeCreateStatement do - SynMemoCREATEcode.Text := SynMemoCREATEcode.Text + Query.SQL + ';' + CRLF; + SynMemoCREATEcode.Text := SynMemoCREATEcode.Text + Query.SQL + ';' + sLineBreak; SynMemoCREATEcode.TopLine := OldTopLine; SynMemoCREATEcode.EndUpdate; CreateCodeValid := True; @@ -2059,7 +2726,7 @@ procedure TfrmTableEditor.UpdateSQLcode; procedure TfrmTableEditor.chkCharsetConvertClick(Sender: TObject); begin - chkCharsetConvert.Enabled := (DBObject.Name <> '') and (comboCollation.ItemIndex > -1); + chkCharsetConvert.Enabled := ObjectExists and (comboCollation.ItemIndex > -1); listColumns.Repaint; Modification(Sender); end; @@ -2096,7 +2763,7 @@ procedure TfrmTableEditor.popupColumnsPopup(Sender: TObject); // Auto create submenu items for "Add to index" ... PrimaryKeyExists := False; for i:=0 to FKeys.Count-1 do begin - if FKeys[i].IndexType = TTableKey.PRIMARY then begin + if FKeys[i].IsPrimary then begin PrimaryKeyExists := True; IndexName := TTableKey.PRIMARY; end else @@ -2127,6 +2794,69 @@ procedure TfrmTableEditor.popupColumnsPopup(Sender: TObject); end; +procedure TfrmTableEditor.menuAddPropertyClick(Sender: TObject); +var + Comp: TComponent; +begin + Comp := PopupComponent(Sender); + if Comp = treeIndexes then + btnAddIndex.OnClick(Sender) + else if Comp = listForeignKeys then + btnAddForeignKey.OnClick(Sender) + else if Comp = listCheckConstraints then + btnAddCheckConstraint.OnClick(Sender); +end; + + +procedure TfrmTableEditor.menuRemovePropertyClick(Sender: TObject); +var + Comp: TComponent; +begin + Comp := PopupComponent(Sender); + if Comp = treeIndexes then + btnRemoveIndex.OnClick(Sender) + else if Comp = listForeignKeys then + btnRemoveForeignKey.OnClick(Sender) + else if Comp = listCheckConstraints then + btnRemoveCheckConstraint.OnClick(Sender); +end; + + +procedure TfrmTableEditor.menuClearPropertiesClick(Sender: TObject); +var + Comp: TComponent; +begin + Comp := PopupComponent(Sender); + if Comp = treeIndexes then + btnClearIndexes.OnClick(Sender) + else if Comp = listForeignKeys then + btnClearForeignKeys.OnClick(Sender) + else if Comp = listCheckConstraints then + btnClearCheckConstraints.OnClick(Sender); +end; + + +procedure TfrmTableEditor.popupPropertiesPopup(Sender: TObject); +var + Comp: TComponent; +begin + Comp := PopupComponent(Sender); + if Comp = treeIndexes then begin + menuRemoveProperty.Enabled := btnRemoveIndex.Enabled; + menuClearProperties.Enabled := btnClearIndexes.Enabled; + menuAddIndexColumn.Enabled := Assigned(treeIndexes.FocusedNode); + end else if Comp = listForeignKeys then begin + menuRemoveProperty.Enabled := btnRemoveForeignKey.Enabled; + menuClearProperties.Enabled := btnClearForeignKeys.Enabled; + menuAddIndexColumn.Enabled := False; + end else if Comp = listCheckConstraints then begin + menuRemoveProperty.Enabled := btnRemoveCheckConstraint.Enabled; + menuClearProperties.Enabled := btnClearCheckConstraints.Enabled; + menuAddIndexColumn.Enabled := False; + end; +end; + + procedure TfrmTableEditor.AddIndexByColumn(Sender: TObject); var Item: TMenuItem; @@ -2158,12 +2888,14 @@ procedure TfrmTableEditor.AddIndexByColumn(Sender: TObject); end; end; TblKey := TTableKey.Create(DBObject.Connection); - TblKey.Name := ImplodeStr('_', NewParts); + TblKey.Name := Implode('_', NewParts); TblKey.IndexType := NewType; TblKey.Added := True; TblKey.Columns := NewParts; - for i:=0 to TblKey.Columns.Count do + for i:=0 to TblKey.Columns.Count-1 do begin TblKey.SubParts.Add(''); + TblKey.Collations.Add('A'); + end; FKeys.Add(TblKey); PageControlMain.ActivePage := tabIndexes; treeIndexes.Repaint; @@ -2176,6 +2908,7 @@ procedure TfrmTableEditor.AddIndexByColumn(Sender: TObject); if TblKey.Columns.IndexOf(NewParts[i]) = -1 then begin TblKey.Columns.Add(NewParts[i]); TblKey.Subparts.Add(''); + TblKey.Collations.Add('A'); end; end; SelectNode(treeIndexes, Item.MenuIndex); @@ -2195,8 +2928,6 @@ procedure TfrmTableEditor.btnAddForeignKeyClick(Sender: TObject); Key := TForeignKey.Create(DBObject.Connection); idx := FForeignKeys.Add(Key); Key.KeyName := 'FK'+IntToStr(idx+1); - Key.OnUpdate := ''; - Key.OnDelete := ''; Key.Added := True; Modification(Sender); listForeignKeys.Repaint; @@ -2214,7 +2945,7 @@ procedure TfrmTableEditor.btnRemoveForeignKeyClick(Sender: TObject); listForeignKeys.CancelEditNode; Key := FForeignKeys[listForeignKeys.FocusedNode.Index]; if not Key.Added then - DeletedForeignKeys.Add(Key.OldKeyName); + FDeletedForeignKeys.Add(Key.OldKeyName); FForeignKeys.Delete(listForeignKeys.FocusedNode.Index); Modification(Sender); listForeignKeys.Repaint; @@ -2230,7 +2961,7 @@ procedure TfrmTableEditor.btnClearForeignKeysClick(Sender: TObject); listForeignKeys.CancelEditNode; for i:=FForeignKeys.Count-1 downto 0 do begin if not FForeignKeys[i].Added then - DeletedForeignKeys.Add(FForeignKeys[i].OldKeyName); + FDeletedForeignKeys.Add(FForeignKeys[i].OldKeyName); FForeignKeys.Delete(i); end; Modification(Sender); @@ -2250,7 +2981,6 @@ procedure TfrmTableEditor.listForeignKeysEditing(Sender: TBaseVirtualTree; Node: Column: TColumnIndex; var Allowed: Boolean); var Key: TForeignKey; - ExistsQuery: String; begin // Disallow editing foreign columns when no reference table was selected. // Also, check for existance of reference table and warn if it's missing. @@ -2260,16 +2990,11 @@ procedure TfrmTableEditor.listForeignKeysEditing(Sender: TBaseVirtualTree; Node: if Key.ReferenceTable = '' then ErrorDialog(_('Please select a reference table before selecting foreign columns.')) else begin - try - ExistsQuery := DBObject.Connection.ApplyLimitClause( - 'SELECT', - '1 FROM '+DBObject.Connection.QuoteIdent(Key.ReferenceTable, True, '.'), - 1, 0); - DBObject.Connection.GetVar(ExistsQuery); - Allowed := True; - except + if Key.ReferenceTableObj = nil then begin // Leave Allowed = False - ErrorDialog(f_('Reference table "%s" seems to be missing, broken or non-accessible.', [Key.ReferenceTable])) + ErrorDialog(f_('Reference table "%s" seems to be missing, broken or non-accessible.', [Key.ReferenceTable])); + end else begin + Allowed := True; end; end; end else @@ -2295,9 +3020,9 @@ procedure TfrmTableEditor.listForeignKeysCreateEditor( // Init grid editor in foreign key list VT := Sender as TVirtualStringTree; case Column of - 0: EditLink := TInplaceEditorLink.Create(VT, True); + 0: EditLink := TInplaceEditorLink.Create(VT, True, nil); 1: begin - SetEditor := TSetEditorLink.Create(VT, True); + SetEditor := TSetEditorLink.Create(VT, True, nil); ColNode := listColumns.GetFirst; while Assigned(ColNode) do begin PCol := listColumns.GetNodeData(ColNode); @@ -2307,7 +3032,7 @@ procedure TfrmTableEditor.listForeignKeysCreateEditor( EditLink := SetEditor; end; 2: begin - EnumEditor := TEnumEditorLink.Create(VT, True); + EnumEditor := TEnumEditorLink.Create(VT, True, nil); EnumEditor.AllowCustomText := True; DBObjects := DBObject.Connection.GetDBObjects(DBObject.Connection.Database); for Obj in DBObjects do begin @@ -2318,7 +3043,7 @@ procedure TfrmTableEditor.listForeignKeysCreateEditor( end; 3: begin Key := FForeignKeys[Node.Index]; - SetEditor := TSetEditorLink.Create(VT, True); + SetEditor := TSetEditorLink.Create(VT, True, nil); Obj := Key.ReferenceTableObj; if Obj <> nil then begin Columns := Obj.TableColumns; @@ -2329,8 +3054,8 @@ procedure TfrmTableEditor.listForeignKeysCreateEditor( EditLink := SetEditor; end; 4, 5: begin - EnumEditor := TEnumEditorLink.Create(VT, True); - EnumEditor.ValueList.Text := 'RESTRICT'+CRLF+'CASCADE'+CRLF+'SET NULL'+CRLF+'NO ACTION'; + EnumEditor := TEnumEditorLink.Create(VT, True, nil); + EnumEditor.ValueList := Explode(',', DBObject.Connection.SqlProvider.GetSql(qForeignKeyEventAction)); EditLink := EnumEditor; end; end; @@ -2368,20 +3093,15 @@ procedure TfrmTableEditor.listForeignKeysGetText(Sender: TBaseVirtualTree; Key := FForeignKeys[Node.Index]; case Column of 0: CellText := Key.KeyName; - 1: CellText := ImplodeStr(',', Key.Columns); + 1: CellText := Implode(',', Key.Columns); 2: CellText := Key.ReferenceTable; - 3: CellText := ImplodeStr(',', Key.ForeignColumns); + 3: CellText := Implode(',', Key.ForeignColumns); 4: begin CellText := Key.OnUpdate; // Both ON UPDATE + DELETE default to "RESTRICT", see http://dev.mysql.com/doc/refman/5.1/en/innodb-foreign-key-constraints.html - if CellText = '' then - CellText := 'RESTRICT'; - end; - 5: begin - CellText := Key.OnDelete; - if CellText = '' then - CellText := 'RESTRICT'; + // MySQL 8 has a "NO ACTION" default here, which makes any fallback wrong here end; + 5: CellText := Key.OnDelete; end; end; @@ -2412,7 +3132,7 @@ procedure TfrmTableEditor.listForeignKeysNewText(Sender: TBaseVirtualTree; 2: begin Key.ReferenceTable := NewText; if not Key.KeyNameWasCustomized then begin - Key.KeyName := 'FK_'+DBObject.Name+'_'+Key.ReferenceTable; + Key.KeyName := 'FK_'+editName.Text+'_'+Key.ReferenceTable; i := 1; NameInUse := True; while NameInUse do begin @@ -2422,7 +3142,7 @@ procedure TfrmTableEditor.listForeignKeysNewText(Sender: TBaseVirtualTree; end; if NameInUse then begin Inc(i); - Key.KeyName := 'FK_'+DBObject.Name+'_'+Key.ReferenceTable+'_'+IntToStr(i); + Key.KeyName := 'FK_'+editName.Text+'_'+Key.ReferenceTable+'_'+IntToStr(i); end; end; @@ -2454,10 +3174,10 @@ procedure TfrmTableEditor.listForeignKeysNewText(Sender: TBaseVirtualTree; for i:=0 to Key.Columns.Count-1 do begin for j:=0 to FColumns.Count-1 do begin if FColumns[j].Name = Key.Columns[i] then begin - KeyColumnsSQLCode := KeyColumnsSQLCode + FColumns[j].SQLCode + CRLF; + KeyColumnsSQLCode := KeyColumnsSQLCode + FColumns[j].SQLCode + sLineBreak; for k:=0 to RefColumns.Count-1 do begin if RefColumns[k].Name = Key.ForeignColumns[i] then begin - RefColumnsSQLCode := RefColumnsSQLCode + RefColumns[k].SQLCode + CRLF; + RefColumnsSQLCode := RefColumnsSQLCode + RefColumns[k].SQLCode + sLineBreak; TypesMatch := TypesMatch and (RefColumns[k].DataType.Index = FColumns[j].DataType.Index) and (RefColumns[k].Unsigned = FColumns[j].Unsigned); @@ -2468,7 +3188,7 @@ procedure TfrmTableEditor.listForeignKeysNewText(Sender: TBaseVirtualTree; end; if not TypesMatch then begin Err := _('The selected foreign column do not match the source columns data type and unsigned flag. This will give you an error message when trying to save this change. Please compare yourself:'); - Err := Err + CRLF + CRLF + KeyColumnsSQLCode + CRLF + Trim(RefColumnsSQLCode); + Err := Err + sLineBreak + sLineBreak + KeyColumnsSQLCode + sLineBreak + Trim(RefColumnsSQLCode); end; end; if Err <> '' then @@ -2480,6 +3200,40 @@ procedure TfrmTableEditor.listForeignKeysNewText(Sender: TBaseVirtualTree; end; end; +procedure TfrmTableEditor.LoadReverseForeignKeys(Sender: TObject); +var + SqlGet: String; + Results: TDBQuery; + ListItem: TListItem; +begin + if FReverseForeignKeysLoaded then + Exit; + if not ListViewReverseForeignKeys.Visible then + Exit; + if not ObjectExists then // Jump out early when creating a new table + Exit; + SqlGet := DBObject.Connection.SqlProvider.GetSql(qGetReverseForeignKeys, DBObject.AsStringMap); + if SqlGet.IsEmpty then begin + MainForm.LogSQL(_('Database does not provide reverse foreign key listing')); + Exit; + end; + ListViewReverseForeignKeys.Items.BeginUpdate; + ListViewReverseForeignKeys.Clear; + try + Results := DBObject.Connection.GetResults(SqlGet); + while not Results.Eof do begin + ListItem := ListViewReverseForeignKeys.Items.Add; + ListItem.ImageIndex := ICONINDEX_TABLE; + ListItem.Caption := Results.Col(0); + ListItem.SubItems.Add(Results.Col(1)); + Results.Next; + end; + except + on EDbError do; + end; + ListViewReverseForeignKeys.Items.EndUpdate; + FReverseForeignKeysLoaded := True; +end; procedure TfrmTableEditor.btnHelpClick(Sender: TObject); begin @@ -2502,7 +3256,7 @@ procedure TfrmTableEditor.menuCopyColumnsClick(Sender: TObject); Cols.Add(Col.Serialize); Node := GetNextNode(listColumns, Node, True); end; - Clipboard.AsText := Cols.Text; + Clipboard.TryAsText := Cols.Text; Cols.Free; end; @@ -2516,7 +3270,7 @@ procedure TfrmTableEditor.menuPasteColumnsClick(Sender: TObject); begin // Complement to "copy columns" ColsFromClp := TStringList.Create; - ColsFromClp.Text := Clipboard.AsText; + ColsFromClp.Text := Clipboard.TryAsText; Node := listColumns.FocusedNode; if not Assigned(Node) then Node := listColumns.GetLast; @@ -2538,10 +3292,26 @@ procedure TfrmTableEditor.menuPasteColumnsClick(Sender: TObject); finally listcolumns.EndUpdate; end; - listColumns.Invalidate; + listColumns.Repaint; Modification(Sender); ColsFromClp.Free; end; +procedure TfrmTableEditor.AnyTreeStructureChange(Sender: TBaseVirtualTree; + Node: PVirtualNode; Reason: TChangeReason); +begin + UpdateTabCaptions; +end; + + +procedure TfrmTableEditor.UpdateTabCaptions; +begin + // Append number of listed keys (or whatever) to the tab caption + tabIndexes.Caption := _('Indexes') + ' (' + FKeys.Count.ToString + ')'; + tabForeignKeys.Caption := _('Foreign keys') + ' (' + FForeignKeys.Count.ToString + ')'; + tabCheckConstraints.Caption := _('Check constraints') + ' (' + FCheckConstraints.Count.ToString + ')'; +end; + + end. diff --git a/source/tabletools.dfm b/source/tabletools.dfm index f06128ee8..5b7f32a27 100644 --- a/source/tabletools.dfm +++ b/source/tabletools.dfm @@ -8,25 +8,22 @@ object frmTableTools: TfrmTableTools Color = clBtnFace Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText - Font.Height = -11 + Font.Height = -12 Font.Name = 'Tahoma' Font.Style = [] - OldCreateOrder = False Position = poMainFormCenter OnClose = FormClose OnCreate = FormCreate - OnDestroy = FormDestroy OnShow = FormShow DesignSize = ( 764 383) - PixelsPerInch = 96 - TextHeight = 13 + TextHeight = 14 object lblCheckedSize: TLabel Left = 8 Top = 355 - Width = 70 - Height = 13 + Width = 79 + Height = 14 Anchors = [akLeft, akBottom] Caption = 'lblCheckedSize' end @@ -57,66 +54,30 @@ object frmTableTools: TfrmTableTools BevelOuter = bvNone TabOrder = 0 object spltHorizontally: TSplitter - Left = 144 + Left = 185 Top = 0 Width = 4 Height = 336 Cursor = crSizeWE ResizeStyle = rsUpdate - end - object TreeObjects: TVirtualStringTree - Left = 0 - Top = 0 - Width = 144 - Height = 336 - Align = alLeft - Header.AutoSizeIndex = 0 - Header.Options = [hoAutoResize, hoColumnResize, hoDrag, hoShowSortGlyphs] - Images = MainForm.VirtualImageListMain - IncrementalSearch = isInitializedOnly - PopupMenu = popupTree - TabOrder = 0 - TreeOptions.MiscOptions = [toAcceptOLEDrop, toCheckSupport, toFullRepaintOnResize, toInitOnSave, toToggleOnDblClick, toWheelPanning, toEditOnClick] - TreeOptions.PaintOptions = [toHotTrack, toShowButtons, toShowDropmark, toShowRoot, toShowTreeLines, toThemeAware, toUseBlendedImages, toGhostedIfUnfocused, toUseExplorerTheme, toHideTreeLinesIfThemed] - TreeOptions.SelectionOptions = [toFullRowSelect, toRightClickSelect] - OnBeforeCellPaint = TreeObjectsBeforeCellPaint - OnChange = TreeObjectsChange - OnChecked = TreeObjectsChecked - OnChecking = TreeObjectsChecking - OnExpanded = TreeObjectsExpanded - OnGetText = TreeObjectsGetText - OnPaintText = TreeObjectsPaintText - OnGetImageIndex = TreeObjectsGetImageIndex - OnGetNodeDataSize = TreeObjectsGetNodeDataSize - OnInitChildren = TreeObjectsInitChildren - OnInitNode = TreeObjectsInitNode - Columns = < - item - Position = 0 - Text = 'Dummy, keeps compatibility to mainform.dbtree' - Width = 90 - end - item - Alignment = taRightJustify - Position = 1 - Text = 'Size' - end> + OnMoved = spltHorizontallyMoved end object pnlRight: TPanel - Left = 148 + Left = 189 Top = 0 - Width = 600 + Width = 559 Height = 336 Align = alClient BevelOuter = bvNone - TabOrder = 1 + TabOrder = 0 object ResultGrid: TVirtualStringTree Left = 0 - Top = 180 - Width = 600 - Height = 156 + Top = 193 + Width = 559 + Height = 143 Align = alClient Header.AutoSizeIndex = -1 + Header.Height = 14 Header.Images = MainForm.VirtualImageListMain Header.MainColumn = -1 Header.Options = [hoColumnResize, hoDblClickResize, hoDrag, hoHotTrack, hoShowSortGlyphs, hoVisible, hoDisableAnimatedResize, hoAutoResizeInclCaption] @@ -132,13 +93,15 @@ object frmTableTools: TfrmTableTools OnGetNodeDataSize = ResultGridGetNodeDataSize OnHeaderClick = ResultGridHeaderClick OnInitNode = ResultGridInitNode + Touch.InteractiveGestures = [igPan, igPressAndTap] + Touch.InteractiveGestureOptions = [igoPanSingleFingerHorizontal, igoPanSingleFingerVertical, igoPanInertia, igoPanGutter, igoParentPassthrough] Columns = <> end object tabsTools: TPageControl Left = 0 Top = 0 - Width = 600 - Height = 180 + Width = 559 + Height = 193 ActivePage = tabSQLexport Align = alTop Images = MainForm.VirtualImageListMain @@ -149,27 +112,27 @@ object frmTableTools: TfrmTableTools ImageIndex = 39 ImageName = 'icons8-support' DesignSize = ( - 592 - 151) + 551 + 164) object lblOperation: TLabel Left = 3 Top = 14 - Width = 52 - Height = 13 + Width = 58 + Height = 14 Caption = 'Operation:' end object lblOptions: TLabel Left = 3 Top = 39 - Width = 41 - Height = 13 + Width = 46 + Height = 14 Caption = 'Options:' end object comboOperation: TComboBox Left = 80 Top = 11 - Width = 508 - Height = 21 + Width = 467 + Height = 22 Style = csDropDownList Anchors = [akLeft, akTop, akRight] TabOrder = 0 @@ -230,7 +193,7 @@ object frmTableTools: TfrmTableTools OnClick = ValidateControls end object btnHelpMaintenance: TButton - Left = 514 + Left = 473 Top = 38 Width = 75 Height = 25 @@ -254,67 +217,58 @@ object frmTableTools: TfrmTableTools ImageIndex = 30 ImageName = 'icons8-find' DesignSize = ( - 592 - 151) + 551 + 164) object lblFindText: TLabel Left = 3 - Top = 14 - Width = 60 - Height = 13 + Top = 27 + Width = 70 + Height = 14 Caption = 'Text to find:' end object lblDataTypes: TLabel Left = 3 - Top = 83 - Width = 114 - Height = 13 + Top = 90 + Width = 131 + Height = 14 Anchors = [akLeft, akBottom] Caption = 'Search in column types:' end object lblMatchType: TLabel Left = 3 - Top = 129 - Width = 58 - Height = 13 + Top = 140 + Width = 66 + Height = 14 + Anchors = [akLeft, akBottom] Caption = 'Match type:' end - object memoFindText: TMemo - Left = 208 - Top = 11 - Width = 381 - Height = 59 - Anchors = [akLeft, akTop, akRight, akBottom] - ScrollBars = ssVertical - TabOrder = 0 - OnChange = ValidateControls - end object comboDataTypes: TComboBox Left = 208 - Top = 76 - Width = 381 - Height = 21 + Top = 87 + Width = 340 + Height = 22 Style = csDropDownList Anchors = [akLeft, akRight, akBottom] - TabOrder = 1 + TabOrder = 0 end object chkCaseSensitive: TCheckBox Left = 208 - Top = 103 - Width = 381 + Top = 114 + Width = 340 Height = 17 Anchors = [akLeft, akRight, akBottom] Caption = 'Case sensitive' - TabOrder = 2 + TabOrder = 1 end object comboMatchType: TComboBox Left = 208 - Top = 126 - Width = 381 - Height = 21 + Top = 137 + Width = 340 + Height = 22 Style = csDropDownList Anchors = [akLeft, akRight, akBottom] ItemIndex = 0 - TabOrder = 3 + TabOrder = 2 Text = 'Left and right wildcard' Items.Strings = ( 'Left and right wildcard' @@ -323,65 +277,126 @@ object frmTableTools: TfrmTableTools 'Right wildcard' 'Regular expression') end + object tabsTextType: TPageControl + Left = 208 + Top = 3 + Width = 340 + Height = 78 + ActivePage = tabSimpleText + Anchors = [akLeft, akTop, akRight, akBottom] + TabOrder = 3 + OnChange = ValidateControls + object tabSimpleText: TTabSheet + Caption = 'Simple text' + object memoFindText: TMemo + Left = 0 + Top = 0 + Width = 332 + Height = 49 + Align = alClient + ScrollBars = ssVertical + TabOrder = 0 + OnChange = ValidateControls + end + end + object tabSQL: TTabSheet + Caption = 'SQL' + ImageIndex = 1 + object SynMemoFindText: TSynMemo + Left = 0 + Top = 0 + Width = 332 + Height = 49 + SingleLineMode = False + Align = alClient + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -13 + Font.Name = 'Courier New' + Font.Style = [] + TabOrder = 0 + CodeFolding.GutterShapeSize = 11 + CodeFolding.CollapsedLineColor = clGrayText + CodeFolding.FolderBarLinesColor = clGrayText + CodeFolding.IndentGuidesColor = clGray + CodeFolding.IndentGuides = True + CodeFolding.ShowCollapsedLine = False + CodeFolding.ShowHintMark = True + UseCodeFolding = False + Gutter.Font.Charset = DEFAULT_CHARSET + Gutter.Font.Color = clWindowText + Gutter.Font.Height = -11 + Gutter.Font.Name = 'Courier New' + Gutter.Font.Style = [] + Gutter.Visible = False + Gutter.Width = 0 + Highlighter = MainForm.SynSQLSynUsed + Lines.Strings = ( + '> NOW()') + Options = [eoAutoIndent, eoDragDropEditing, eoEnhanceEndKey, eoGroupUndo, eoHideShowScrollbars, eoShowScrollHint, eoSmartTabDelete, eoSmartTabs, eoTabsToSpaces] + FontSmoothing = fsmNone + end + end + end end object tabSQLexport: TTabSheet Caption = 'SQL export' ImageIndex = 9 ImageName = 'icons8-outgoing-data-100' DesignSize = ( - 592 - 151) + 551 + 164) object lblExportData: TLabel Left = 3 Top = 50 - Width = 27 - Height = 13 + Width = 29 + Height = 14 Caption = 'Data:' end object lblExportOutputType: TLabel Left = 3 Top = 104 - Width = 38 - Height = 13 + Width = 44 + Height = 14 Caption = 'Output:' end object lblExportDatabases: TLabel Left = 3 Top = 4 - Width = 63 - Height = 13 + Width = 69 + Height = 14 Caption = 'Database(s):' end object lblExportTables: TLabel Left = 3 Top = 25 - Width = 43 - Height = 13 + Width = 49 + Height = 14 Caption = 'Table(s):' end object lblExportOutputTarget: TLabel Left = 2 Top = 130 - Width = 46 - Height = 13 + Width = 51 + Height = 14 Caption = 'Filename:' end object lblInsertSize: TLabel Left = 3 Top = 77 - Width = 84 - Height = 13 + Width = 93 + Height = 14 Caption = 'Max INSERT size:' end object lblInsertSizeUnit: TLabel Left = 242 Top = 77 - Width = 115 - Height = 13 + Width = 134 + Height = 14 Caption = 'KB (0 = Single INSERTs)' end object btnExportOutputTargetSelect: TButton - Left = 566 + Left = 525 Top = 127 Width = 23 Height = 21 @@ -432,8 +447,8 @@ object frmTableTools: TfrmTableTools object comboExportData: TComboBox Left = 100 Top = 47 - Width = 489 - Height = 21 + Width = 448 + Height = 22 Style = csDropDownList Anchors = [akLeft, akTop, akRight] TabOrder = 4 @@ -442,19 +457,22 @@ object frmTableTools: TfrmTableTools object comboExportOutputType: TComboBox Left = 100 Top = 101 - Width = 489 - Height = 21 - Style = csDropDownList + Width = 448 + Height = 22 + Style = csOwnerDrawVariable Anchors = [akLeft, akTop, akRight] DropDownCount = 16 TabOrder = 7 OnChange = comboExportOutputTypeChange + OnDrawItem = comboExportOutputTypeDrawItem + OnMeasureItem = comboExportOutputTypeMeasureItem end object comboExportOutputTarget: TComboBox Left = 100 Top = 127 - Width = 463 - Height = 21 + Width = 422 + Height = 22 + AutoDropDownWidth = True Anchors = [akLeft, akTop, akRight] DropDownCount = 16 ParentShowHint = False @@ -467,7 +485,7 @@ object frmTableTools: TfrmTableTools Left = 100 Top = 74 Width = 120 - Height = 21 + Height = 22 TabOrder = 5 Text = '0' end @@ -475,14 +493,14 @@ object frmTableTools: TfrmTableTools Left = 220 Top = 74 Width = 16 - Height = 21 + Height = 22 Associate = editInsertSize Max = 2147483647 TabOrder = 6 Wrap = True end object btnExportOptions: TButton - Left = 464 + Left = 423 Top = 72 Width = 125 Height = 25 @@ -499,8 +517,8 @@ object frmTableTools: TfrmTableTools ImageIndex = 19 ImageName = 'icons8-sheets-100' DesignSize = ( - 592 - 151) + 551 + 164) object chkBulkTableEditDatabase: TCheckBox Left = 3 Top = 5 @@ -513,8 +531,9 @@ object frmTableTools: TfrmTableTools object comboBulkTableEditDatabase: TComboBox Left = 208 Top = 3 - Width = 380 - Height = 21 + Width = 339 + Height = 22 + AutoDropDownWidth = True Style = csDropDownList Anchors = [akLeft, akTop, akRight] Enabled = False @@ -541,8 +560,9 @@ object frmTableTools: TfrmTableTools object comboBulkTableEditCollation: TComboBox Left = 208 Top = 49 - Width = 380 - Height = 21 + Width = 339 + Height = 22 + AutoDropDownWidth = True Style = csDropDownList Anchors = [akLeft, akTop, akRight] DropDownCount = 16 @@ -562,8 +582,9 @@ object frmTableTools: TfrmTableTools object comboBulkTableEditEngine: TComboBox Left = 208 Top = 26 - Width = 380 - Height = 21 + Width = 339 + Height = 22 + AutoDropDownWidth = True Style = csDropDownList Anchors = [akLeft, akTop, akRight] Enabled = False @@ -581,8 +602,9 @@ object frmTableTools: TfrmTableTools object comboBulkTableEditCharset: TComboBox Left = 208 Top = 72 - Width = 380 - Height = 21 + Width = 339 + Height = 22 + AutoDropDownWidth = True Style = csDropDownList Anchors = [akLeft, akTop, akRight] DropDownCount = 16 @@ -590,6 +612,159 @@ object frmTableTools: TfrmTableTools TabOrder = 8 end end + object tabGenerateData: TTabSheet + Caption = 'Generate data' + ImageIndex = 130 + object lblGenerateDataNumRows: TLabel + Left = 3 + Top = 6 + Width = 92 + Height = 14 + Caption = 'Number of rows:' + end + object lblGenerateDataNullAmount: TLabel + Left = 2 + Top = 34 + Width = 126 + Height = 14 + Caption = 'Amount of NULLs [percent]:' + end + object editGenerateDataNumRows: TEdit + Left = 200 + Top = 3 + Width = 121 + Height = 22 + TabOrder = 0 + Text = '1.000' + end + object updownGenerateDataNumRows: TUpDown + Left = 321 + Top = 3 + Width = 20 + Height = 22 + Associate = editGenerateDataNumRows + Min = 1 + Max = 2147483647 + Position = 1000 + TabOrder = 1 + end + object editGenerateDataNullAmount: TEdit + Left = 200 + Top = 31 + Width = 121 + Height = 22 + TabOrder = 2 + Text = '10' + end + object updownGenerateDataNullAmount: TUpDown + Left = 321 + Top = 31 + Width = 20 + Height = 22 + Associate = editGenerateDataNullAmount + Position = 10 + TabOrder = 3 + end + end + end + end + object pnlLeft: TPanel + Left = 0 + Top = 0 + Width = 185 + Height = 336 + Align = alLeft + BevelOuter = bvNone + Caption = 'pnlLeft' + ShowCaption = False + TabOrder = 1 + object pnlLeftTop: TPanel + Left = 0 + Top = 0 + Width = 185 + Height = 29 + Align = alTop + BevelOuter = bvNone + Caption = 'pnlLeftTop' + ShowCaption = False + TabOrder = 0 + object editDatabaseFilter: TButtonedEdit + Left = 6 + Top = 1 + Width = 49 + Height = 22 + Hint = + 'Database filter|A list of databases, separated by semicolon. Can' + + ' contain regular expressions, e.g. "mydb;test.*;project\d+".' + Images = MainForm.VirtualImageListMain + LeftButton.ImageIndex = 53 + LeftButton.Visible = True + RightButton.ImageIndex = 193 + TabOrder = 0 + Text = 'editDatabaseFilter' + TextHint = 'Database filter' + OnChange = editDatabaseTableFilterChange + OnKeyPress = editDatabaseTableFilterKeyPress + OnRightButtonClick = editDatabaseTableFilterRightButtonClick + end + object editTableFilter: TButtonedEdit + Left = 61 + Top = 1 + Width = 68 + Height = 22 + Hint = 'Table filter|Can contain regular expressions, e.g. "phpbb_\d"' + Images = MainForm.VirtualImageListMain + LeftButton.ImageIndex = 53 + LeftButton.Visible = True + RightButton.ImageIndex = 193 + TabOrder = 1 + Text = 'editTableFilter' + TextHint = 'Table filter' + OnChange = editDatabaseTableFilterChange + OnKeyPress = editDatabaseTableFilterKeyPress + OnRightButtonClick = editDatabaseTableFilterRightButtonClick + end + end + object TreeObjects: TVirtualStringTree + Left = 0 + Top = 29 + Width = 185 + Height = 307 + Align = alClient + Header.AutoSizeIndex = 0 + Header.Height = 18 + Header.Options = [hoAutoResize, hoColumnResize, hoDrag, hoShowSortGlyphs] + Images = MainForm.VirtualImageListMain + IncrementalSearch = isInitializedOnly + PopupMenu = popupTree + TabOrder = 1 + TreeOptions.MiscOptions = [toAcceptOLEDrop, toCheckSupport, toFullRepaintOnResize, toInitOnSave, toToggleOnDblClick, toWheelPanning, toEditOnClick] + TreeOptions.PaintOptions = [toHotTrack, toShowButtons, toShowDropmark, toShowRoot, toShowTreeLines, toThemeAware, toUseBlendedImages, toGhostedIfUnfocused, toUseExplorerTheme, toHideTreeLinesIfThemed] + TreeOptions.SelectionOptions = [toFullRowSelect, toRightClickSelect] + OnBeforeCellPaint = TreeObjectsBeforeCellPaint + OnChange = TreeObjectsChange + OnChecked = TreeObjectsChecked + OnChecking = TreeObjectsChecking + OnExpanded = TreeObjectsExpanded + OnGetText = TreeObjectsGetText + OnPaintText = TreeObjectsPaintText + OnGetImageIndex = TreeObjectsGetImageIndex + OnGetNodeDataSize = TreeObjectsGetNodeDataSize + OnInitChildren = TreeObjectsInitChildren + OnInitNode = TreeObjectsInitNode + Touch.InteractiveGestures = [igPan, igPressAndTap] + Touch.InteractiveGestureOptions = [igoPanSingleFingerHorizontal, igoPanSingleFingerVertical, igoPanInertia, igoPanGutter, igoParentPassthrough] + Columns = < + item + Position = 0 + Text = 'Dummy, keeps compatibility to mainform.dbtree' + Width = 131 + end + item + Alignment = taRightJustify + Position = 1 + Text = 'Size' + end> end end end @@ -621,10 +796,17 @@ object frmTableTools: TfrmTableTools Top = 352 object menuCheckNone: TMenuItem Caption = 'Check none' + ImageIndex = 65 OnClick = CheckAllClick end object menuCheckAll: TMenuItem Caption = 'Check all' + ImageIndex = 64 + OnClick = CheckAllClick + end + object menuInvertCheck: TMenuItem + Caption = 'Invert Check' + ImageIndex = 138 OnClick = CheckAllClick end object menuCheckByType: TMenuItem @@ -637,14 +819,33 @@ object frmTableTools: TfrmTableTools object menuExportAddComments: TMenuItem AutoCheck = True Caption = 'Add comments' + OnClick = menuExportOptionClick + end + object menuExportTransactions: TMenuItem + AutoCheck = True + Caption = 'Wrap data DML in transactions' + OnClick = menuExportOptionClick end object menuExportRemoveAutoIncrement: TMenuItem AutoCheck = True Caption = 'Remove AUTO_INCREMENT clauses' + OnClick = menuExportOptionClick end object menuExportRemoveDefiner: TMenuItem AutoCheck = True Caption = 'Remove DEFINER clauses' + OnClick = menuExportOptionClick + end + object menuCopyMysqldumpCommand: TMenuItem + Caption = 'Copy mysqldump command' + OnClick = menuCopyMysqldumpCommandClick end end + object timerCalcSize: TTimer + Enabled = False + Interval = 200 + OnTimer = timerCalcSizeTimer + Left = 264 + Top = 352 + end end diff --git a/source/tabletools.pas b/source/tabletools.pas index ccdf71f42..a2a6c11d6 100644 --- a/source/tabletools.pas +++ b/source/tabletools.pas @@ -9,16 +9,17 @@ interface uses - Windows, SysUtils, Classes, Controls, Forms, StdCtrls, ComCtrls, Buttons, Dialogs, StdActns, - VirtualTrees, ExtCtrls, Graphics, SynRegExpr, Math, Generics.Collections, extra_controls, - dbconnection, apphelpers, Menus, gnugettext, DateUtils, System.Zip, System.UITypes, StrUtils, Messages; + Winapi.Windows, System.SysUtils, System.Classes, Vcl.Controls, Vcl.Forms, Vcl.StdCtrls, Vcl.ComCtrls, Vcl.Buttons, Vcl.Dialogs, Vcl.StdActns, + VirtualTrees, Vcl.ExtCtrls, Vcl.Graphics, SynRegExpr, System.Math, System.Generics.Collections, extra_controls, + dbconnection, apphelpers, Vcl.Menus, gnugettext, System.DateUtils, System.Zip, System.UITypes, System.StrUtils, Winapi.Messages, + SynEdit, SynMemo, Vcl.ClipBrd, generic_types, VirtualTrees.Types, VirtualTrees.BaseAncestorVCL, + VirtualTrees.BaseTree, VirtualTrees.AncestorVCL, System.JSON, System.Variants; type - TToolMode = (tmMaintenance, tmFind, tmSQLExport, tmBulkTableEdit); + TToolMode = (tmMaintenance, tmFind, tmSQLExport, tmBulkTableEdit, tmGenerateData); TfrmTableTools = class(TExtForm) btnCloseOrCancel: TButton; pnlTop: TPanel; - TreeObjects: TVirtualStringTree; spltHorizontally: TSplitter; pnlRight: TPanel; ResultGrid: TVirtualStringTree; @@ -36,7 +37,6 @@ TfrmTableTools = class(TExtForm) btnHelpMaintenance: TButton; tabFind: TTabSheet; lblFindText: TLabel; - memoFindText: TMemo; comboDataTypes: TComboBox; lblDataTypes: TLabel; tabSQLexport: TTabSheet; @@ -83,10 +83,31 @@ TfrmTableTools = class(TExtForm) comboMatchType: TComboBox; lblMatchType: TLabel; menuExportRemoveDefiner: TMenuItem; - procedure FormDestroy(Sender: TObject); + tabsTextType: TPageControl; + tabSimpleText: TTabSheet; + tabSQL: TTabSheet; + memoFindText: TMemo; + SynMemoFindText: TSynMemo; + menuCopyMysqldumpCommand: TMenuItem; + pnlLeft: TPanel; + pnlLeftTop: TPanel; + editDatabaseFilter: TButtonedEdit; + editTableFilter: TButtonedEdit; + TreeObjects: TVirtualStringTree; + timerCalcSize: TTimer; + tabGenerateData: TTabSheet; + lblGenerateDataNumRows: TLabel; + editGenerateDataNumRows: TEdit; + updownGenerateDataNumRows: TUpDown; + lblGenerateDataNullAmount: TLabel; + editGenerateDataNullAmount: TEdit; + updownGenerateDataNullAmount: TUpDown; + menuInvertCheck: TMenuItem; + menuExportTransactions: TMenuItem; procedure FormCreate(Sender: TObject); procedure FormShow(Sender: TObject); procedure btnHelpMaintenanceClick(Sender: TObject); + function GetCheckedObjects(DBNode: PVirtualNode): TDBObjectList; procedure TreeObjectsGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; var CellText: String); procedure TreeObjectsInitNode(Sender: TBaseVirtualTree; ParentNode, Node: PVirtualNode; @@ -108,7 +129,7 @@ TfrmTableTools = class(TExtForm) procedure ResultGridPaintText(Sender: TBaseVirtualTree; const TargetCanvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType); procedure ValidateControls(Sender: TObject); - procedure SaveSettings(Sender: TObject); + procedure SaveSettings; procedure chkExportOptionClick(Sender: TObject); procedure btnExportOutputTargetSelectClick(Sender: TObject); procedure comboExportOutputTargetChange(Sender: TObject); @@ -129,6 +150,19 @@ TfrmTableTools = class(TExtForm) procedure CheckAllClick(Sender: TObject); procedure TreeObjectsExpanded(Sender: TBaseVirtualTree; Node: PVirtualNode); procedure btnExportOptionsClick(Sender: TObject); + procedure menuCopyMysqldumpCommandClick(Sender: TObject); + procedure spltHorizontallyMoved(Sender: TObject); + procedure editDatabaseTableFilterChange(Sender: TObject); + procedure editDatabaseTableFilterKeyPress(Sender: TObject; var Key: Char); + procedure editDatabaseTableFilterRightButtonClick(Sender: TObject); + procedure timerCalcSizeTimer(Sender: TObject); + procedure comboExportOutputTypeDrawItem(Control: TWinControl; + Index: Integer; Rect: TRect; State: TOwnerDrawState); + procedure comboExportOutputTypeMeasureItem(Control: TWinControl; + Index: Integer; var Height: Integer); + procedure menuExportOptionClick(Sender: TObject); + const + StatusMsg = '%s %s ...'; private { Private declarations } FResults: TObjectList; @@ -145,7 +179,8 @@ TfrmTableTools = class(TExtForm) FHeaderCreated: Boolean; FFindSeeResultSQL: TStringList; ToFile, ToDir, ToClipboard, ToDb, ToServer: Boolean; - FObjectSizes, FObjectSizesDone, FObjectSizesDoneExact: Int64; + FObjectCount, FObjectSizes, FObjectSizesDone, FObjectSizesDoneExact: Int64; + FStartTimeAll: Cardinal; procedure WMNCLBUTTONDOWN(var Msg: TWMNCLButtonDown) ; message WM_NCLBUTTONDOWN; procedure WMNCLBUTTONUP(var Msg: TWMNCLButtonUp) ; message WM_NCLBUTTONUP; procedure SetToolMode(Value: TToolMode); @@ -159,6 +194,9 @@ TfrmTableTools = class(TExtForm) procedure DoFind(DBObj: TDBObject); procedure DoExport(DBObj: TDBObject); procedure DoBulkTableEdit(DBObj: TDBObject); + procedure DoBeforeGenerateData(Sender: TObject); + procedure DoGenerateData(DBObj: TDBObject); + procedure DoAfterGenerateData(Sender: TObject); public { Public declarations } PreSelectObjects: TDBObjectList; @@ -172,9 +210,12 @@ implementation const STRSKIPPED: String = 'Skipped - '; - EXPORT_FILE_FOOTER = '/*!40101 SET SQL_MODE=IFNULL(@OLD_SQL_MODE, '''') */;'+CRLF+ - '/*!40014 SET FOREIGN_KEY_CHECKS=IF(@OLD_FOREIGN_KEY_CHECKS IS NULL, 1, @OLD_FOREIGN_KEY_CHECKS) */;'+CRLF+ - '/*!40101 SET CHARACTER_SET_CLIENT=@OLD_CHARACTER_SET_CLIENT */;'+CRLF; + EXPORT_FILE_FOOTER = + '/*!40103 SET TIME_ZONE=IFNULL(@OLD_TIME_ZONE, ''system'') */;'+CRLF+ + '/*!40101 SET SQL_MODE=IFNULL(@OLD_SQL_MODE, '''') */;'+CRLF+ + '/*!40014 SET FOREIGN_KEY_CHECKS=IFNULL(@OLD_FOREIGN_KEY_CHECKS, 1) */;'+CRLF+ + '/*!40101 SET CHARACTER_SET_CLIENT=@OLD_CHARACTER_SET_CLIENT */;'+CRLF+ + '/*!40111 SET SQL_NOTES=IFNULL(@OLD_SQL_NOTES, 1) */;'+CRLF; var OUTPUT_FILE, @@ -222,6 +263,7 @@ procedure TfrmTableTools.FormCreate(Sender: TObject); MenuItem: TMenuItem; dt: TListNodeType; Obj: TDBObject; + Params: TConnectionParameters; begin HasSizeGrip := True; OUTPUT_FILE := _('Single .sql file'); @@ -230,19 +272,17 @@ procedure TfrmTableTools.FormCreate(Sender: TObject); OUTPUT_DIR := _('Directory - one file per object in database subdirectories'); OUTPUT_DB := _('Database'); OUTPUT_SERVER := _('Server')+': '; + // Todo: sanitize misleading names DATA_NO := _('No data'); DATA_REPLACE := _('Delete + insert (truncate existing data)'); DATA_INSERT := _('Insert'); DATA_INSERTNEW := _('Insert ignore (do not update existing)'); DATA_UPDATE := _('Replace existing data'); - // Restore GUI setup - Width := AppSettings.ReadInt(asTableToolsWindowWidth); - Height := AppSettings.ReadInt(asTableToolsWindowHeight); - TreeObjects.Width := AppSettings.ReadInt(asTableToolsTreeWidth); - // Find text tab memoFindText.Text := AppSettings.ReadString(asTableToolsFindText); + SynMemoFindText.Text := AppSettings.ReadString(asTableToolsFindSQL); + tabsTextType.ActivePageIndex := AppSettings.ReadInt(asTableToolsFindTextTab); comboDatatypes.Items.Add(_('All data types')); for dtc:=Low(DatatypeCategories) to High(DatatypeCategories) do comboDatatypes.Items.Add(DatatypeCategories[dtc].Name); @@ -257,6 +297,7 @@ procedure TfrmTableTools.FormCreate(Sender: TObject); comboExportData.ItemIndex := AppSettings.ReadInt(asExportSQLDataHow); updownInsertSize.Position := AppSettings.ReadInt(asExportSQLDataInsertSize); menuExportAddComments.Checked := AppSettings.ReadBool(asExportSQLAddComments); + menuExportTransactions.Checked := AppSettings.ReadBool(asExportSQLTransactions); menuExportRemoveAutoIncrement.Checked := AppSettings.ReadBool(asExportSQLRemoveAutoIncrement); menuExportRemoveDefiner.Checked := AppSettings.ReadBool(asExportSQLRemoveDefiner); // Add hardcoded output options and session names from registry @@ -269,12 +310,18 @@ procedure TfrmTableTools.FormCreate(Sender: TObject); SessionPaths := TStringList.Create; AppSettings.GetSessionPaths('', SessionPaths); for i:=0 to SessionPaths.Count-1 do begin - if SessionPaths[i] <> Mainform.ActiveConnection.Parameters.SessionPath then - comboExportOutputType.Items.Add(OUTPUT_SERVER+SessionPaths[i]); + if SessionPaths[i] = Mainform.ActiveConnection.Parameters.SessionPath then + Continue; + Params := TConnectionParameters.Create(SessionPaths[i]); + comboExportOutputType.Items.AddObject(OUTPUT_SERVER+SessionPaths[i], Params); end; SessionPaths.Free; comboExportOutputTarget.Text := ''; + // Generate data tab + updownGenerateDataNumRows.Position := AppSettings.ReadInt(asGenerateDataNumRows); + updownGenerateDataNullAmount.Position := AppSettings.ReadInt(asGenerateDataNullAmount); + // Various FixVT(TreeObjects); FixVT(ResultGrid); @@ -298,12 +345,45 @@ procedure TfrmTableTools.FormCreate(Sender: TObject); end; -procedure TfrmTableTools.FormDestroy(Sender: TObject); +procedure TfrmTableTools.comboExportOutputTypeDrawItem(Control: TWinControl; + Index: Integer; Rect: TRect; State: TOwnerDrawState); +var + Params: TConnectionParameters; + Canv: TCanvas; + ItemImageIndex: Integer; begin - // Save GUI setup - AppSettings.WriteInt(asTableToolsWindowWidth, Width); - AppSettings.WriteInt(asTableToolsWindowHeight, Height); - AppSettings.WriteInt(asTableToolsTreeWidth, TreeObjects.Width); + Canv := comboExportOutputType.Canvas; + if odSelected in State then begin + Canv.Brush.Color := clHighlight; + Canv.Pen.Color := clHighlightText; + end + else begin + Canv.Brush.Color := clWindow; + Canv.Pen.Color := clWindowText; + end; + + Params := comboExportOutputType.Items.Objects[Index] as TConnectionParameters; + if Assigned(Params) then begin + if (Params.SessionColor <> clNone) and (not (odSelected in State)) then begin + Canv.Brush.Color := Params.SessionColor; + Canv.Pen.Color := clWindowText; + end; + ItemImageIndex := Params.ImageIndex; + end + else begin + ItemImageIndex := MainForm.actExportTables.ImageIndex; + end; + + Canv.FillRect(Rect); + Canv.TextRect(Rect, Rect.Left + MainForm.VirtualImageListMain.Width + 4, Rect.Top, comboExportOutputType.Items[Index]); + MainForm.VirtualImageListMain.Draw(Canv, Rect.Left + 2, Rect.Top + 2, ItemImageIndex); +end; + + +procedure TfrmTableTools.comboExportOutputTypeMeasureItem(Control: TWinControl; + Index: Integer; var Height: Integer); +begin + Height := MainForm.VirtualImageListMain.Height + 2; end; @@ -313,12 +393,18 @@ procedure TfrmTableTools.FormShow(Sender: TObject); idx: Integer; DBObj: TDBObject; begin + // Restore GUI setup + Width := AppSettings.ReadIntDpiAware(asTableToolsWindowWidth, Self); + Height := AppSettings.ReadIntDpiAware(asTableToolsWindowHeight, Self); + pnlLeft.Width := AppSettings.ReadIntDpiAware(asTableToolsTreeWidth, Self); + // When this form is displayed the second time, databases may be deleted or filtered. // Also, checked nodes must be unchecked and unchecked nodes may need to be checked. TreeObjects.Clear; TreeObjects.RootNodeCount := Mainform.DBtree.RootNodeCount; FObjectSizes := 0; + FObjectCount := 0; // Init all objects in active database, so the tree does not just check the db node // if we want the first child only. See issue #2267. @@ -370,27 +456,130 @@ procedure TfrmTableTools.FormShow(Sender: TObject); if comboBulkTableEditCharset.Items.Count > 0 then comboBulkTableEditCharset.ItemIndex := 0; + MainForm.SetupSynEditors(Self); + MainForm.SynCompletionProposal.AddEditor(SynMemoFindText); + + pnlLeftTop.Height := editDatabaseFilter.Height + 2; + // Fixes width of filter edits: + spltHorizontallyMoved(Self); + // Apply filters: + editDatabaseFilter.Text := MainForm.editDatabaseFilter.Text; + editTableFilter.Text := MainForm.editTableFilter.Text; + ValidateControls(Sender); end; +procedure TfrmTableTools.menuCopyMysqldumpCommandClick(Sender: TObject); +var + BinPath, ConnectionArguments, FullCommand: String; + Arguments, DatabaseNames: TStringList; + Conn: TDBConnection; + SessionNode, DBNode: PVirtualNode; + DBObj: PDBObject; +begin + // Copy command line for use with mysqldump + Screen.Cursor := crHourGlass; + Conn := MainForm.ActiveConnection; + + BinPath := AppSettings.ReadString(asMySQLBinaries); + if (not BinPath.IsEmpty) and (BinPath[Length(BinPath)] <> DirSep) then + BinPath := BinPath + DirSep; + BinPath := BinPath + IfThen(IsWine, 'mysqldump', 'mysqldump.exe'); + + ConnectionArguments := Conn.Parameters.GetExternalCliArguments(nil, nbUnset); + + Arguments := TStringList.Create; + + if chkExportDatabasesDrop.Checked then + Arguments.Add('--add-drop-database'); + if not chkExportDatabasesCreate.Checked then + Arguments.Add('--no-create-db'); + if chkExportTablesDrop.Checked then + Arguments.Add('--add-drop-table'); + if not chkExportTablesCreate.Checked then + Arguments.Add('--no-create-info'); + // Data output. No support for delete+insert - will just use inserts. + if comboExportData.Text = DATA_NO then + Arguments.Add('--no-data') + else if comboExportData.Text = DATA_UPDATE then + Arguments.Add('--replace') + else if comboExportData.Text = DATA_INSERTNEW then + Arguments.Add('--insert-ignore'); + // Output file. No support for server, database and clipboard + if comboExportOutputType.Text = OUTPUT_FILE then + Arguments.Add('--result-file="'+comboExportOutputTarget.Text+'"') + else if comboExportOutputType.Text = OUTPUT_DIR then + Arguments.Add('--tab="'+comboExportOutputTarget.Text+'"'); + + // Use checked database names + DatabaseNames := TStringList.Create; + SessionNode := TreeObjects.GetFirstChild(nil); + while Assigned(SessionNode) do begin + DBNode := TreeObjects.GetFirstChild(SessionNode); + while Assigned(DBNode) do begin + if not (DBNode.CheckState in [csUncheckedNormal, csUncheckedPressed]) then begin + DBObj := TreeObjects.GetNodeData(DBNode); + DatabaseNames.Add(DBObj.Database); + // Todo: loop through tables? + // CheckedObjects := GetCheckedObjects(DBNode); + end; + DBNode := TreeObjects.GetNextSibling(DBNode); + end; + SessionNode := TreeObjects.GetNextSibling(SessionNode); + end; + // --databases or --all-databases can't be used with --tab + if comboExportOutputType.Text <> OUTPUT_DIR then + Arguments.Add('--databases ' + Implode(' ', DatabaseNames)) + else + Arguments.Add(Implode(' ', DatabaseNames)); + DatabaseNames.Free; + + FullCommand := BinPath + ConnectionArguments + ' ' + Implode(' ', Arguments); + Arguments.Free; + + Clipboard.TryAsText := FullCommand; + Screen.Cursor := crDefault; +end; + + +procedure TfrmTableTools.menuExportOptionClick(Sender: TObject); +var + i: Integer; + MenuItem: TMenuItem; +begin + // Display number of checked options in button caption + i := 0; + for MenuItem in popupExportOptions.Items do begin + if MenuItem.Checked then + Inc(i); + end; + btnExportOptions.Caption := _('Options') + ' (' + i.ToString + ')'; +end; + procedure TfrmTableTools.FormClose(Sender: TObject; var Action: TCloseAction); begin // Auto close temorary connection if Assigned(FTargetConnection) then FreeAndNil(FTargetConnection); - Action := caFree; + SaveSettings; + // Save GUI setup + AppSettings.WriteIntDpiAware(asTableToolsWindowWidth, Self, Width); + AppSettings.WriteIntDpiAware(asTableToolsWindowHeight, Self, Height); + AppSettings.WriteIntDpiAware(asTableToolsTreeWidth, Self, pnlLeft.Width); end; -procedure TfrmTableTools.SaveSettings(Sender: TObject); +procedure TfrmTableTools.SaveSettings; var i: Integer; Items: TStringList; begin case ToolMode of tmFind: begin + AppSettings.WriteInt(asTableToolsFindTextTab, tabsTextType.ActivePageIndex); AppSettings.WriteString(asTableToolsFindText, memoFindText.Text); + AppSettings.WriteString(asTableToolsFindSQL, SynMemoFindText.Text); AppSettings.WriteInt(asTableToolsDatatype, comboDatatypes.ItemIndex); AppSettings.WriteBool(asTableToolsFindCaseSensitive, chkCaseSensitive.Checked); AppSettings.WriteInt(asTableToolsFindMatchType, comboMatchType.ItemIndex); @@ -403,6 +592,7 @@ procedure TfrmTableTools.SaveSettings(Sender: TObject); if comboExportData.ItemIndex > 0 then AppSettings.WriteInt(asExportSQLDataInsertSize, updownInsertSize.Position); AppSettings.WriteBool(asExportSQLAddComments, menuExportAddComments.Checked); + AppSettings.WriteBool(asExportSQLTransactions, menuExportTransactions.Checked); AppSettings.WriteBool(asExportSQLRemoveAutoIncrement, menuExportRemoveAutoIncrement.Checked); AppSettings.WriteBool(asExportSQLRemoveDefiner, menuExportRemoveDefiner.Checked); @@ -438,6 +628,11 @@ procedure TfrmTableTools.SaveSettings(Sender: TObject); end; end; + tmGenerateData: begin + AppSettings.WriteInt(asGenerateDataNumRows, updownGenerateDataNumRows.Position); + AppSettings.WriteInt(asGenerateDataNullAmount, updownGenerateDataNullAmount.Position); + end; + end; end; @@ -445,14 +640,16 @@ procedure TfrmTableTools.SaveSettings(Sender: TObject); procedure TfrmTableTools.ValidateControls(Sender: TObject); var - SomeChecked, OptionChecked: Boolean; + SomeChecked, OptionChecked, FindModeSQL: Boolean; op: String; i: Integer; begin // Fired after various user clicks, and also on implicit child node checking SomeChecked := TreeObjects.CheckedCount > 0; + TExtForm.PageControlTabHighlight(tabsTools); btnSeeResults.Visible := tabsTools.ActivePage = tabFind; - lblCheckedSize.Caption := f_('Selected objects size: %s', [FormatByteNumber(FObjectSizes)]); + lblCheckedSize.Caption := f_('%s selected objects, size: %s', [FObjectCount.ToString, FormatByteNumber(FObjectSizes)]); + menuExportOptionClick(Sender); if tabsTools.ActivePage = tabMaintenance then begin btnExecute.Caption := _('Execute'); btnExecute.Enabled := (Pos(_(SUnsupported), comboOperation.Text) = 0) and SomeChecked; @@ -472,7 +669,11 @@ procedure TfrmTableTools.ValidateControls(Sender: TObject); end; end else if tabsTools.ActivePage = tabFind then begin btnExecute.Caption := _('Find'); - btnExecute.Enabled := SomeChecked and (memoFindText.Text <> ''); + btnExecute.Enabled := SomeChecked; + FindModeSQL := tabsTextType.ActivePage = tabSQL; + chkCaseSensitive.Enabled := not FindModeSQL; + lblMatchType.Enabled := not FindModeSQL; + comboMatchType.Enabled := not FindModeSQL; // Enable "See results" button if there were results btnSeeResults.Enabled := False; if Assigned(FResults) then for i:=0 to FResults.Count-1 do begin @@ -495,7 +696,11 @@ procedure TfrmTableTools.ValidateControls(Sender: TObject); OptionChecked := chkBulkTableEditDatabase.Checked or chkBulkTableEditEngine.Checked or chkBulkTableEditCollation.Checked or chkBulkTableEditCharset.Checked or chkBulkTableEditResetAutoinc.Checked; btnExecute.Enabled := SomeChecked and OptionChecked; + end else if tabsTools.ActivePage = tabGenerateData then begin + btnExecute.Caption := _('Generate'); + btnExecute.Enabled := SomeChecked; end; + end; @@ -515,18 +720,13 @@ procedure TfrmTableTools.TreeObjectsChange(Sender: TBaseVirtualTree; Node: PVirt procedure TfrmTableTools.TreeObjectsChecked(Sender: TBaseVirtualTree; Node: PVirtualNode); var Obj: PDBObject; - ObjSize: Int64; begin // Track sum of checked objects size Obj := Sender.GetNodeData(Node); - ObjSize := Max(Obj.Size, 0); - if Node.CheckState in CheckedStates then - Inc(FObjectSizes, ObjSize) - else - Dec(FObjectSizes, ObjSize); if Obj.NodeType = lntDb then FillTargetDatabases; - ValidateControls(Sender); + timerCalcSize.Enabled := False; + timerCalcSize.Enabled := True; end; @@ -624,6 +824,43 @@ procedure TfrmTableTools.btnHelpMaintenanceClick(Sender: TObject); end; +function TfrmTableTools.GetCheckedObjects(DBNode: PVirtualNode): TDBObjectList; +var + Child, GrandChild: PVirtualNode; + ChildObj, GrandChildObj: PDBObject; +begin + // Return list with checked objects from database node + // The caller doesn't need to care whether type grouping in tree is activated + Result := TDBObjectList.Create(False); + Child := TreeObjects.GetFirstChild(DBNode); + while Assigned(Child) do begin + if Child.CheckState in CheckedStates then begin + ChildObj := TreeObjects.GetNodeData(Child); + + case ChildObj.NodeType of + + lntGroup: begin + GrandChild := TreeObjects.GetFirstChild(Child); + while Assigned(GrandChild) do begin + if GrandChild.CheckState in CheckedStates then begin + GrandChildObj := TreeObjects.GetNodeData(GrandChild); + Result.Add(GrandChildObj^); + end; + GrandChild := TreeObjects.GetNextSibling(GrandChild); + end; + end + + else begin + Result.Add(ChildObj^); + end; + + end; + end; + Child := TreeObjects.GetNextSibling(Child); + end; +end; + + procedure TfrmTableTools.Execute(Sender: TObject); var SessionNode, DBNode: PVirtualNode; @@ -644,6 +881,7 @@ procedure TfrmTableTools.Execute(Sender: TObject); tmFind: DoFind(DBObj); tmSQLExport: DoExport(DBObj); tmBulkTableEdit: DoBulkTableEdit(DBObj); + tmGenerateData: DoGenerateData(DBObj); end; except on E:EDbError do begin @@ -661,40 +899,11 @@ procedure TfrmTableTools.Execute(Sender: TObject); ErrorDialog(E.Message); FCancelled := True; end; - end; - end; - - procedure SetCheckedObjects(DBNode: PVirtualNode); - var - Child, GrandChild: PVirtualNode; - ChildObj, GrandChildObj: PDBObject; - begin - CheckedObjects.Clear; - Child := TreeObjects.GetFirstChild(DBNode); - while Assigned(Child) do begin - if Child.CheckState in CheckedStates then begin - ChildObj := TreeObjects.GetNodeData(Child); - - case ChildObj.NodeType of - - lntGroup: begin - GrandChild := TreeObjects.GetFirstChild(Child); - while Assigned(GrandChild) do begin - if GrandChild.CheckState in CheckedStates then begin - GrandChildObj := TreeObjects.GetNodeData(GrandChild); - CheckedObjects.Add(GrandChildObj^); - end; - GrandChild := TreeObjects.GetNextSibling(GrandChild); - end; - end - - else begin - CheckedObjects.Add(ChildObj^); - end; - - end; + on E:EInOutError do begin + // ForceDirectories failed with "Unable to create directory." + ErrorDialog(E.Message); + FCancelled := True; end; - Child := TreeObjects.GetNextSibling(Child); end; end; @@ -713,18 +922,25 @@ procedure TfrmTableTools.Execute(Sender: TObject); else if tabsTools.ActivePage = tabSQLExport then FToolMode := tmSQLExport else if tabsTools.ActivePage = tabBulkTableEdit then - FToolMode := tmBulkTableEdit; + FToolMode := tmBulkTableEdit + else if tabsTools.ActivePage = tabGenerateData then + FToolMode := tmGenerateData; ResultGrid.Clear; + ResultGrid.TrySetFocus; FResults.Clear; FFindSeeResultSQL.Clear; - CheckedObjects := TDBObjectList.Create(False); Triggers := TDBObjectList.Create(False); // False, so we can .Free that object afterwards without loosing the contained objects Views := TDBObjectList.Create(False); FHeaderCreated := False; FCancelled := False; + FObjectSizesDone := 0; FObjectSizesDoneExact := 0; MainForm.EnableProgress(100); + FStartTimeAll := GetTickCount; + + DoBeforeGenerateData(Sender); + SessionNode := TreeObjects.GetFirstChild(nil); while Assigned(SessionNode) do begin DBNode := TreeObjects.GetFirstChild(SessionNode); @@ -733,7 +949,7 @@ procedure TfrmTableTools.Execute(Sender: TObject); Triggers.Clear; Views.Clear; FSecondExportPass := False; - SetCheckedObjects(DBNode); + CheckedObjects := GetCheckedObjects(DBNode); for DBObj in CheckedObjects do begin // Triggers have to be exported at the very end if (FToolMode = tmSQLExport) and (DBObj.NodeType = lntTrigger) then @@ -772,12 +988,18 @@ procedure TfrmTableTools.Execute(Sender: TObject); Conn := Mainform.ActiveConnection; + DoAfterGenerateData(Sender); + if Assigned(ExportStream) then begin + // For output to file or directory: Output(EXPORT_FILE_FOOTER, False, True, False, False, False); + // For direct output to database or server: + Output('/*!40111 SET SQL_NOTES=IFNULL(@OLD_SQL_NOTES, 1) */', True, False, False, True, True); Output('/*!40101 SET SQL_MODE=IFNULL(@OLD_SQL_MODE, '''') */', True, False, False, True, True); - Output('/*!40014 SET FOREIGN_KEY_CHECKS=IF(@OLD_FOREIGN_KEY_CHECKS IS NULL, 1, @OLD_FOREIGN_KEY_CHECKS) */', True, False, False, True, True); + Output('/*!40014 SET FOREIGN_KEY_CHECKS=IFNULL(@OLD_FOREIGN_KEY_CHECKS, 1) */', True, False, False, True, True); + Output('/*!40103 SET TIME_ZONE=IFNULL(@OLD_TIME_ZONE, ''system'') */', True, False, False, True, True); if comboExportOutputType.Text = OUTPUT_CLIPBOARD then - StreamToClipboard(ExportStream, nil, false); + StreamToClipboard(ExportStream, nil); if comboExportOutputType.Text = OUTPUT_FILE_COMPRESSED then FileName := TFileStream(ExportStream).FileName; @@ -788,7 +1010,7 @@ procedure TfrmTableTools.Execute(Sender: TObject); StartTime := GetTickCount; FileNameZip := FExportFileName; if FileExists(FileNameZip) then - DeleteFile(FileNameZip); + DeleteFileWithUndo(FileNameZip); Zip := TZipFile.Create; Zip.Open(FileNameZip, zmWrite); FileNameInZip := ExtractFileName(ChangeFileExt(FileNameZip, '.sql')); @@ -798,11 +1020,13 @@ procedure TfrmTableTools.Execute(Sender: TObject); LogRow := FResults.Last; LogRow[2] := _('Compressing done.'); LogRow[3] := FormatTimeNumber((GetTickCount-StartTime) / 1000, True); - ResultGrid.Repaint; + UpdateResultGrid; end; // Activate ansi mode or whatever again, locally Conn.Query('/*!40101 SET SQL_MODE=IFNULL(@OLD_LOCAL_SQL_MODE, '''') */'); + // Reset timezone for reading to previous value + Conn.Query('/*!40103 SET TIME_ZONE=IFNULL(@OLD_TIME_ZONE, ''system'') */'); end; ExportLastDatabase := ''; @@ -814,13 +1038,14 @@ procedure TfrmTableTools.Execute(Sender: TObject); end; FModifiedDbs.Clear; + AddNotes('', '', f_('%s finished', [tabsTools.ActivePage.Caption]), ''); btnCloseOrCancel.Caption := _('Close'); btnCloseOrCancel.ModalResult := mrCancel; + MainForm.ShowStatusMsg; MainForm.DisableProgress; tabsTools.Enabled := True; treeObjects.Enabled := True; ValidateControls(Sender); - SaveSettings(Sender); Screen.Cursor := crDefault; end; @@ -845,6 +1070,93 @@ procedure TfrmTableTools.DoMaintenance(DBObj: TDBObject); end; +procedure TfrmTableTools.editDatabaseTableFilterKeyPress(Sender: TObject; + var Key: Char); +begin + if Key = #27 then + (Sender as TButtonedEdit).OnRightButtonClick(Sender); +end; + +procedure TfrmTableTools.editDatabaseTableFilterRightButtonClick(Sender: TObject); +begin + // Click on "clear" button of any TButtonedEdit control + TButtonedEdit(Sender).Clear; +end; + +procedure TfrmTableTools.editDatabaseTableFilterChange(Sender: TObject); +var + Node: PVirtualNode; + Obj: PDBObject; + rxdb, rxtable: TRegExpr; + NodeMatches, SomeHidden: Boolean; + Errors: TStringList; +begin + // Immediately apply database filter + MainForm.LogSQL('editDatabaseTableFilterChange', lcDebug); + + rxdb := TRegExpr.Create; + rxdb.ModifierI := True; + rxdb.Expression := '('+StringReplace(editDatabaseFilter.Text, ';', '|', [rfReplaceAll])+')'; + rxtable := TRegExpr.Create; + rxtable.ModifierI := True; + rxtable.Expression := '('+StringReplace(editTableFilter.Text, ';', '|', [rfReplaceAll])+')'; + + Errors := TStringList.Create; + SomeHidden := False; + + TreeObjects.BeginUpdate; + Node := TreeObjects.GetFirst; + while Assigned(Node) do begin + Obj := TreeObjects.GetNodeData(Node); + NodeMatches := True; + try + case Obj.NodeType of + lntDb: begin + // Match against database filter + if editDatabaseFilter.Text <> '' then + NodeMatches := rxdb.Exec(TreeObjects.Text[Node, 0]); + end; + lntTable..lntEvent: begin + // Match against table filter + if editTableFilter.Text <> '' then + NodeMatches := rxtable.Exec(TreeObjects.Text[Node, 0]); + // no favorites supported on table tools dialog + //if actFavoriteObjectsOnly.Checked then + // Hide non-favorite object path + //NodeMatches := NodeMatches and (Obj.Connection.Favorites.IndexOf(Obj.Path) > -1); + end; + end; + except + on E:Exception do begin + // Log regex errors, but avoid duplicate messages + if Errors.IndexOf(E.Message) = -1 then begin + MainForm.LogSQL(E.Message); + Errors.Add(E.Message); + end; + end; + end; + TreeObjects.IsVisible[Node] := NodeMatches; + if not NodeMatches then + SomeHidden := True; + + Node := TreeObjects.GetNextInitialized(Node); + end; + TreeObjects.EndUpdate; + + rxdb.Free; + rxtable.Free; + + editDatabaseFilter.RightButton.Visible := editDatabaseFilter.Text <> ''; + editTableFilter.RightButton.Visible := editTableFilter.Text <> ''; + if SomeHidden then + menuCheckAll.Caption := _('Check all visible') + else + menuCheckAll.Caption := _('Check all'); + timerCalcSize.Enabled := False; + timerCalcSize.Enabled := True; +end; + + procedure TfrmTableTools.DoFind(DBObj: TDBObject); var Columns: TTableColumnList; @@ -900,7 +1212,10 @@ procedure TfrmTableTools.DoFind(DBObj: TDBObject); Column := DBObj.Connection.QuoteIdent(Col.Name); if (comboDatatypes.ItemIndex = 0) or (Integer(Col.DataType.Category) = comboDatatypes.ItemIndex-1) then begin - if (Col.DataType.Category in [dtcInteger, dtcReal]) and (comboMatchType.ItemIndex=1) then begin + if tabsTextType.ActivePage = tabSQL then begin + SQL := SQL + Column + ' ' + SynMemoFindText.Text + ' OR '; + + end else if (Col.DataType.Category in [dtcInteger, dtcReal]) and (comboMatchType.ItemIndex=1) then begin // Search numbers SQL := SQL + Column + '=' + UnformatNumber(FindText) + ' OR '; @@ -977,8 +1292,11 @@ procedure TfrmTableTools.DoFind(DBObj: TDBObject); + SQL; end; AddResults(SQL, DBObj.Connection); - end else - AddNotes(DBObj, f_('%s%s doesn''t have columns of selected type (%s).', [STRSKIPPED, DBObj.ObjType, comboDatatypes.Text]), ''); + end else begin + // Prefer a normal log line, so the "Found rows" column has a number, to fix wrong sorting + //AddNotes(DBObj, f_('%s%s doesn''t have columns of selected type (%s).', [STRSKIPPED, DBObj.ObjType, comboDatatypes.Text]), ''); + AddNotes(DBObj.Database, DBObj.Name, '0', '0%'); + end; end; end; @@ -986,7 +1304,7 @@ procedure TfrmTableTools.DoFind(DBObj: TDBObject); SQL := 'SELECT '+ esc(DBObj.Database)+' AS '+DBObj.Connection.QuoteIdent('Database')+', '+ esc(DBObj.Name)+' AS '+DBObj.Connection.QuoteIdent('Table')+', '+ - DBObj.Connection.GetSQLSpecifity(spFuncCeil)+'(('+DBObj.Connection.GetSQLSpecifity(spFuncLength)+'('+RoutineDefinitionColumn+') - '+DBObj.Connection.GetSQLSpecifity(spFuncLength)+'(REPLACE('+RoutineDefinitionColumn+', '+esc(FindText)+', '+esc('')+'))) / '+DBObj.Connection.GetSQLSpecifity(spFuncLength)+'('+esc(FindText)+')) AS '+DBObj.Connection.QuoteIdent('Found rows')+', '+ + DBObj.Connection.SqlProvider.GetSql(qFuncCeil)+'(('+DBObj.Connection.SqlProvider.GetSql(qFuncLength)+'('+RoutineDefinitionColumn+') - '+DBObj.Connection.SqlProvider.GetSql(qFuncLength)+'(REPLACE('+RoutineDefinitionColumn+', '+esc(FindText)+', '+esc('')+'))) / '+DBObj.Connection.SqlProvider.GetSql(qFuncLength)+'('+esc(FindText)+')) AS '+DBObj.Connection.QuoteIdent('Found rows')+', '+ '0 AS '+DBObj.Connection.QuoteIdent('Relevance')+ 'FROM '+DBObj.Connection.QuoteIdent(DBObj.Connection.InfSch)+'.'+DBObj.Connection.QuoteIdent('routines')+' '+ 'WHERE '+DBObj.Connection.QuoteIdent(RoutineSchemaColumn)+'='+esc(DBObj.Database)+' AND '+DBObj.Connection.QuoteIdent('routine_name')+'='+esc(DBObj.Name); @@ -1029,6 +1347,7 @@ procedure TfrmTableTools.AddResults(SQL: String; Connection: TDBConnection); begin // Execute query and append results into grid Results := Connection.GetResults(SQL); + Connection.ShowWarnings; if Results = nil then Exit; @@ -1115,6 +1434,42 @@ procedure TfrmTableTools.SetupResultGrid(Results: TDBQuery=nil); end; +procedure TfrmTableTools.spltHorizontallyMoved(Sender: TObject); +begin + editDatabaseFilter.Left := 0; + editDatabaseFilter.Width := (pnlLeftTop.Width div 2) - 1; + editTableFilter.Width := editDatabaseFilter.Width; + editTableFilter.Left := editDatabaseFilter.Width + 1; +end; + +procedure TfrmTableTools.timerCalcSizeTimer(Sender: TObject); +var + SessionNode, DBNode: PVirtualNode; + CheckedObjects: TDBObjectList; + DBObj: TDBObject; +begin + // Calculate object sizes and display on label + timerCalcSize.Enabled := False; + SessionNode := TreeObjects.GetFirstChild(nil); + FObjectSizes := 0; + FObjectCount := 0; + while Assigned(SessionNode) do begin + DBNode := TreeObjects.GetFirstChild(SessionNode); + while Assigned(DBNode) do begin + if not (DBNode.CheckState in [csUncheckedNormal, csUncheckedPressed]) then begin + CheckedObjects := GetCheckedObjects(DBNode); + for DBObj in CheckedObjects do begin + Inc(FObjectSizes, DBObj.Size); + Inc(FObjectCount); + end; + end; + DBNode := TreeObjects.GetNextSibling(DBNode); + end; + SessionNode := TreeObjects.GetNextSibling(SessionNode); + end; + ValidateControls(Sender); +end; + procedure TfrmTableTools.UpdateResultGrid; var Percent: Double; @@ -1128,6 +1483,8 @@ procedure TfrmTableTools.UpdateResultGrid; lblCheckedSize.Caption := f_('Selected objects size: %s', [FormatByteNumber(FObjectSizes)]) + '. ' + f_('%s%% done', [FormatNumber(Percent, 1)]) + '.'; MainForm.SetProgressPosition(Round(Percent)); + MainForm.ShowStatusMsg(Format(StatusMsg, [tabsTools.ActivePage.Caption, FormatTimeNumber((GetTickCount-FStartTimeAll)/1000, True)])); + ResultGrid.Header.AutoFitColumns(False); Application.ProcessMessages; end; @@ -1225,8 +1582,13 @@ procedure TfrmTableTools.comboExportOutputTypeChange(Sender: TObject); comboExportOutputTarget.Items.Text := AppSettings.ReadString(asExportSQLFilenames, '') else comboExportOutputTarget.Items.Text := AppSettings.ReadString(asExportZIPFilenames, ''); - if comboExportOutputTarget.Items.Count > 0 then + if comboExportOutputTarget.Items.Count > 0 then begin comboExportOutputTarget.ItemIndex := 0; + // Cut long file list down to 20 latest items + for i:=comboExportOutputTarget.Items.Count-1 downto 20 do begin + comboExportOutputTarget.Items.Delete(i); + end; + end; lblExportOutputTarget.Caption := _('Filename')+':'; btnExportOutputTargetSelect.Enabled := True; btnExportOutputTargetSelect.ImageIndex := 51; @@ -1356,7 +1718,8 @@ procedure TfrmTableTools.btnExportOutputTargetSelectClick(Sender: TObject); SaveDialog.Filter := _('SQL files')+' (*.sql)|*.sql|'+_('All files')+' (*.*)|*.*' else SaveDialog.Filter := _('ZIP files')+' (*.zip)|*.zip|'+_('All files')+' (*.*)|*.*'; - SaveDialog.Options := SaveDialog.Options + [ofOverwritePrompt]; + // Don't prompt here if file exists, but later when exporting starts. See issue #835 + // SaveDialog.Options := SaveDialog.Options + [ofOverwritePrompt]; if SaveDialog.Execute then comboExportOutputTarget.Text := SaveDialog.FileName; SaveDialog.Free; @@ -1381,6 +1744,7 @@ procedure TfrmTableTools.SetToolMode(Value: TToolMode); tmFind: tabsTools.ActivePage := tabFind; tmSQLExport: tabsTools.ActivePage := tabSQLExport; tmBulkTableEdit: tabsTools.ActivePage := tabBulkTableEdit; + tmGenerateData: tabsTools.ActivePage := tabGenerateData; end; end; @@ -1418,19 +1782,23 @@ procedure TfrmTableTools.Output(SQL: String; IsEndOfQuery, ForFile, ForDir, ForD procedure TfrmTableTools.DoExport(DBObj: TDBObject); var - IsFirstRowInChunk, NeedsDBStructure: Boolean; + NeedsDBStructure: Boolean; + InsertSizeExceeded, RowLimitExceeded: Boolean; Struc, Header, DbDir, FinalDbName, BaseInsert, Row, TargetDbAndObject, BinContent, tmp: String; i: Integer; - RowCount, Limit, Offset, ResultCount: Int64; + RowCount, RowCountInChunk: Int64; + Limit, Offset, ResultCount, MaxInsertSize: Int64; StartTime: Cardinal; StrucResult, Data: TDBQuery; - rx: TRegExpr; - ColumnList: TTableColumnList; + ColumnList, KeyColumns: TTableColumnList; + KeyList: TTableKeyList; Column: TTableColumn; Quoter: TDBConnection; - TargetFileName, SetCharsetCode: String; + TargetFileName, SetCharsetCode, ColumnsForSelect: String; + OrderBy: String; const TempDelim = '//'; + AssumedAvgRowLen = 10000; procedure LogStatistic(RowsDone: Int64); var @@ -1464,6 +1832,9 @@ procedure TfrmTableTools.DoExport(DBObj: TDBObject); if not Assigned(ExportStream) then begin // Very first round here. Prevent "SHOW CREATE db|table" from using double quotes DBObj.Connection.Query('/*!40101 SET @OLD_LOCAL_SQL_MODE=@@SQL_MODE, SQL_MODE='''' */'); + // Set same timezone for reading date/time values as for the output + DBObj.Connection.Query('/*!40103 SET @OLD_TIME_ZONE=@@TIME_ZONE */'); + DBObj.Connection.Query('/*!40103 SET TIME_ZONE=''+00:00'' */'); end; if ToServer then @@ -1473,22 +1844,34 @@ procedure TfrmTableTools.DoExport(DBObj: TDBObject); StartTime := GetTickCount; ExportStreamStartOfQueryPos := 0; + MaxInsertSize := Trunc(updownInsertSize.Position * SIZE_KB * 0.9); + if ToDir then begin FreeAndNil(ExportStream); - DbDir := IncludeTrailingPathDelimiter(GetOutputFilename(comboExportOutputTarget.Text, DBObj)) + DBObj.Database + '\'; + DbDir := IncludeTrailingPathDelimiter(GetOutputFilename(comboExportOutputTarget.Text, DBObj)) + DBObj.Database + PathDelim; if not DirectoryExists(DbDir) then ForceDirectories(DbDir); - ExportStream := TFileStream.Create(DbDir + DBObj.Name+'.sql', fmCreate or fmOpenWrite); + ExportStream := TFileStream.Create(DbDir + DBObj.ObjType.ToLower + '-' + DBObj.Name+'.sql', fmCreate or fmOpenWrite); FHeaderCreated := False; end; if not Assigned(ExportStream) then begin if ToFile then begin TargetFileName := GetOutputFilename(comboExportOutputTarget.Text, DBObj); + if FileExists(TargetFileName) then begin + case MessageDialog(f_('File already exists: %s'+sLineBreak+sLineBreak+'Overwrite it?', [TargetFileName]), mtConfirmation, [mbYes, mbCancel]) of + mrYes:; + mrCancel: + raise EFCreateError.CreateFmt(_('Export cancelled, file not overwritten: %s'), [TargetFileName]); + end; + end; + FExportFileName := TargetFileName; if comboExportOutputType.Text = OUTPUT_FILE_COMPRESSED then TargetFileName := ChangeFileExt(TargetFileName, '_temp.sql'); if not IsValidFilePath(TargetFileName) then raise EFCreateError.CreateFmt(_('Filename or path contains illegal characters: "%s"'), [TargetFilename]); + if not DirectoryExists(ExtractFilePath(FExportFileName)) then + ForceDirectories(ExtractFilePath(FExportFileName)); ExportStream := TFileStream.Create(TargetFileName, fmCreate or fmOpenWrite); end; // ToDir handled above @@ -1498,6 +1881,7 @@ procedure TfrmTableTools.DoExport(DBObj: TDBObject); ExportStream := TMemoryStream.Create; end; if not FHeaderCreated then begin + // For output to file or directory: if DBObj.Connection.CharacterSet = 'utf8mb4' then SetCharsetCode := '/*!40101 SET NAMES utf8 */;' + CRLF + '/*!50503 SET NAMES '+DBObj.Connection.CharacterSet+' */;' + CRLF @@ -1516,12 +1900,21 @@ procedure TfrmTableTools.DoExport(DBObj: TDBObject); Header := Header + '/*!40101 SET @OLD_CHARACTER_SET_CLIENT=@@CHARACTER_SET_CLIENT */;' + CRLF + SetCharsetCode + + '/*!40103 SET @OLD_TIME_ZONE=@@TIME_ZONE */;' + CRLF + + '/*!40103 SET TIME_ZONE=''+00:00'' */;' + CRLF + '/*!40014 SET @OLD_FOREIGN_KEY_CHECKS=@@FOREIGN_KEY_CHECKS, FOREIGN_KEY_CHECKS=0 */;' + CRLF + - '/*!40101 SET @OLD_SQL_MODE=@@SQL_MODE, SQL_MODE=''NO_AUTO_VALUE_ON_ZERO'' */;' + CRLF; + '/*!40101 SET @OLD_SQL_MODE=@@SQL_MODE, SQL_MODE=''NO_AUTO_VALUE_ON_ZERO'' */;' + CRLF + + '/*!40111 SET @OLD_SQL_NOTES=@@SQL_NOTES, SQL_NOTES=0 */;' + CRLF; Output(Header, False, DBObj.Database<>ExportLastDatabase, True, False, False); + Output(CRLF, False, True, True, False, False); + + // For direct output to database or server: + Output('/*!40103 SET @OLD_TIME_ZONE=@@TIME_ZONE */', True, False, False, True, True); + Output('/*!40103 SET TIME_ZONE=''+00:00'' */', True, False, False, True, True); Output('/*!40014 SET @OLD_FOREIGN_KEY_CHECKS=@@FOREIGN_KEY_CHECKS, FOREIGN_KEY_CHECKS=0 */', True, False, False, True, True); Output('/*!40101 SET @OLD_SQL_MODE=@@SQL_MODE, SQL_MODE=''NO_AUTO_VALUE_ON_ZERO'' */', True, False, False, True, True); - Output(CRLF, False, True, True, False, False); + Output('/*!40111 SET @OLD_SQL_NOTES=@@SQL_NOTES, SQL_NOTES=0 */', True, False, False, True, True); + FHeaderCreated := True; end; @@ -1545,20 +1938,20 @@ procedure TfrmTableTools.DoExport(DBObj: TDBObject); end else Struc := 'CREATE DATABASE IF NOT EXISTS '+Quoter.QuoteIdent(FinalDbName); Output(Struc, True, NeedsDBStructure, False, False, NeedsDBStructure); - Output('USE '+Quoter.QuoteIdent(FinalDbName), True, NeedsDBStructure, False, False, NeedsDBStructure); + Output(Quoter.SqlProvider.GetSql(qUSEQuery, [Quoter.QuoteIdent(FinalDbName)]), True, NeedsDBStructure, False, False, NeedsDBStructure); Output(CRLF, False, NeedsDBStructure, False, False, NeedsDBStructure); end; end; if ToServer and (not chkExportDatabasesCreate.Checked) then begin // Export to server without "CREATE/USE dbname" and "Same dbs as on source server" - needs a "USE dbname" - Output('USE '+Quoter.QuoteIdent(FinalDbName), True, False, False, False, NeedsDBStructure); + Output(Quoter.SqlProvider.GetSql(qUSEQuery, [Quoter.QuoteIdent(FinalDbName)]), True, False, False, False, NeedsDBStructure); end; // Table structure if chkExportTablesDrop.Checked or chkExportTablesCreate.Checked then begin - if menuExportAddComments.Checked then + if menuExportAddComments.Checked and (not FSecondExportPass) then Output('-- '+f_('Dumping structure for %s %s.%s', [_(LowerCase(DBObj.ObjType)), DBObj.Database, DBObj.Name])+CRLF, False, True, True, False, False); - if chkExportTablesDrop.Checked then begin + if chkExportTablesDrop.Checked and (not FSecondExportPass) then begin Struc := 'DROP '+UpperCase(DBObj.ObjType)+' IF EXISTS '; if ToDb then Struc := Struc + Quoter.QuoteIdent(FinalDbName)+'.'; @@ -1573,16 +1966,8 @@ procedure TfrmTableTools.DoExport(DBObj: TDBObject); Insert('IF NOT EXISTS ', Struc, Pos('TABLE', Struc) + 6); if ToDb then Insert(Quoter.QuoteIdent(FinalDbName)+'.', Struc, Pos('EXISTS', Struc) + 7 ); - if ToServer then begin - rx := TRegExpr.Create; - rx.ModifierI := True; - rx.Expression := '(\s)(TYPE|ENGINE)(\=|\s+)(\w+)'; - if FTargetConnection.ServerVersionInt < 40018 then - Struc := rx.Replace(Struc, '${1}TYPE${3}${4}', true) - else - Struc := rx.Replace(Struc, '${1}ENGINE${3}${4}', true); - rx.Free; - end; + if ToServer then + Struc := TSqlTranspiler.CreateTable(Struc, DBObj.Connection, FTargetConnection); end; lntView: begin @@ -1600,10 +1985,12 @@ procedure TfrmTableTools.DoExport(DBObj: TDBObject); // Prevent DEFAULT value from coming in, to fix errors due to multiple CURRENT_TIMESTAMP values // See issue #2748 Column.DefaultType := cdtNothing; - Struc := Struc + CRLF + #9 + Column.SQLCode + ','; + if Column.DataType.Index = dbdtVarchar then + Column.LengthSet := '1'; + Struc := Struc + sLineBreak + CodeIndent + Column.SQLCode + ','; end; Delete(Struc, Length(Struc), 1); - Struc := Struc + CRLF + ') ENGINE=MyISAM'; + Struc := Struc + CRLF + ')'; ColumnList.Free; end else begin Struc := ''; @@ -1617,14 +2004,23 @@ procedure TfrmTableTools.DoExport(DBObj: TDBObject); Struc := DBObj.GetCreateCode(False, menuExportRemoveDefiner.Checked); if ToDb then Insert(Quoter.QuoteIdent(FinalDbName)+'.', Struc, Pos('VIEW', Struc) + 5 ); + // Issue #2050: Add new line at end to support comments at the end of a view definition + Struc := Struc + sLineBreak; end; end; lntTrigger: begin StrucResult := DBObj.Connection.GetResults('SHOW TRIGGERS FROM '+DBObj.QuotedDatabase+' WHERE `Trigger`='+DBObj.Connection.EscapeString(DBObj.Name)); Struc := DBObj.GetCreateCode(False, menuExportRemoveDefiner.Checked); - if ToDb then - Insert(Quoter.QuoteIdent(FinalDbName)+'.', Struc, Pos('TRIGGER', Struc) + 8 ); + if ToDb then begin + // Prepend target database to trigger name + Struc := ReplaceRegExpr( + 'TRIGGER(\s+IF\s+NOT\s+EXISTS)?\s+', + Struc, + '$0' + Quoter.QuoteIdent(FinalDbName)+'.', + [rroModifierI, rroUseSubstitution, rroModifierG] // Greedy is required to catch group 1 + ); + end; if ToFile or ToClipboard or ToDir then begin Struc := 'SET @OLDTMP_SQL_MODE=@@SQL_MODE, SQL_MODE=' + DBObj.Connection.EscapeString(StrucResult.Col('sql_mode')) + ';' + CRLF + 'DELIMITER ' + TempDelim + CRLF + @@ -1675,34 +2071,58 @@ procedure TfrmTableTools.DoExport(DBObj: TDBObject); Output('-- '+_('Data exporting was unselected.')+CRLF+CRLF, False, True, True, False, False); end else if MatchText(DBObj.Engine, ['MRG_MYISAM', 'FEDERATED']) then begin if menuExportAddComments.Checked then - Output('-- '+f_('Table data not exported because this is %s table which holds its data in separate tables.', [DBObj.Engine])+CRLF+CRLF, False, True, True, False, False); + Output('-- '+f_('Table data not exported because this is a %s table which holds its data in separate tables.', [DBObj.Engine])+CRLF+CRLF, False, True, True, False, False); end else begin tmp := FormatNumber(DBObj.Rows)+' rows'; if LowerCase(DBObj.Engine) = 'innodb' then tmp := '~'+tmp+' ('+_('approximately')+')'; if menuExportAddComments.Checked then Output('-- '+f_('Dumping data for table %s.%s: %s', [DBObj.Database, DBObj.Name, tmp])+CRLF, False, True, True, False, False); + if menuExportTransactions.Checked then + Output('BEGIN', True, True, True, True, True); TargetDbAndObject := Quoter.QuoteIdent(DBObj.Name); if ToDb then TargetDbAndObject := Quoter.QuoteIdent(FinalDbName) + '.' + TargetDbAndObject; Offset := 0; RowCount := 0; + // Examine columns + ColumnList := DBObj.TableColumns; + if not ColumnList.HasInvisibleColumns then + ColumnsForSelect := '*' + else + ColumnsForSelect := ColumnList.QuoteIdents; + // Sort by primary key if one exists, see issue #2168 + KeyList := DBObj.TableKeys; + KeyColumns := DBObj.Connection.GetKeyColumns(ColumnList, KeyList); + OrderBy := ''; + for i:=0 to KeyColumns.Count-1 do begin + if i>0 then + OrderBy := OrderBy + ', '; + OrderBy := OrderBy + DBObj.Connection.QuoteIdent(KeyColumns[i].Name); + end; + if not OrderBy.IsEmpty then + OrderBy := ' ORDER BY ' + OrderBy; // Calculate limit so we select ~100MB per loop - Limit := Round(100 * SIZE_MB / Max(DBObj.AvgRowLen,1)); - if comboExportData.Text = DATA_REPLACE then + // Take care of disabled "Get full table status" session setting, where AvgRowLen is 0 + Limit := Round(100 * SIZE_MB / IfThen(DBObj.AvgRowLen>0, DBObj.AvgRowLen, AssumedAvgRowLen)); + if comboExportData.Text = DATA_REPLACE then begin Output('DELETE FROM '+TargetDbAndObject, True, True, True, True, True); - Output('/*!40000 ALTER TABLE '+TargetDbAndObject+' DISABLE KEYS */', True, True, True, True, True); + if menuExportRemoveAutoIncrement.Checked then + Output('/*!50000 ALTER TABLE '+TargetDbAndObject+' AUTO_INCREMENT = 1 */', True, True, True, True, True); + end; while true do begin Data := DBObj.Connection.GetResults( DBObj.Connection.ApplyLimitClause( 'SELECT', - '* FROM '+DBObj.QuotedDbAndTableName, + '/* '+APPNAME+' '+MainForm.AppVersion+' */ ' + ColumnsForSelect + ' FROM '+DBObj.QuotedDbAndTableName + OrderBy, Limit, Offset) ); Inc(Offset, Limit); if Data.RecordCount = 0 then break; + if FCancelled then + Break; Data.PrepareColumnAttributes; BaseInsert := 'INSERT INTO '; if comboExportData.Text = DATA_INSERTNEW then @@ -1715,27 +2135,21 @@ procedure TfrmTableTools.DoExport(DBObj: TDBObject); BaseInsert := BaseInsert + Quoter.QuoteIdent(Data.ColumnNames[i]) + ', '; end; Delete(BaseInsert, Length(BaseInsert)-1, 2); - BaseInsert := BaseInsert + ') VALUES'+CRLF+#9+'('; + BaseInsert := BaseInsert + ') VALUES' + sLineBreak + CodeIndent + '('; while true do begin Output(BaseInsert, False, True, True, True, True); - IsFirstRowInChunk := True; + RowCountInChunk := 0; while not Data.Eof do begin Row := ''; - if not IsFirstRowInChunk then - Row := Row + ','+CRLF+#9+'('; + if RowCountInChunk > 0 then + Row := Row + ',' + sLineBreak + CodeIndent + '('; for i:=0 to Data.ColumnCount-1 do begin if Data.ColIsVirtual(i) then Continue; if Data.IsNull(i) then Row := Row + 'NULL' else case Data.DataType(i).Category of - dtcInteger, dtcReal: begin - if Data.DataType(i).Index = dtBit then - Row := Row + 'b' + Quoter.EscapeString(Data.Col(i)) - else - Row := Row + Data.Col(i); - end; dtcBinary, dtcSpatial: begin BinContent := Data.HexValue(i); if Length(BinContent) > 0 then @@ -1743,25 +2157,26 @@ procedure TfrmTableTools.DoExport(DBObj: TDBObject); else Row := Row + Quoter.EscapeString(''); end; - else Row := Row + Quoter.EscapeString(Data.Col(i)); + else Row := Row + Quoter.EscapeString(Data.Col(i), Data.DataType(i)); end; Row := Row + ', '; end; Delete(Row, Length(Row)-1, 2); Row := Row + ')'; // Break if stream would increase over the barrier of 1MB, and throw away current row - if (not IsFirstRowInChunk) - and (ExportStream.Size - ExportStreamStartOfQueryPos + Length(Row) > updownInsertSize.Position*SIZE_KB*0.9) - then - break; + InsertSizeExceeded := ExportStream.Size - ExportStreamStartOfQueryPos + Length(Row) > MaxInsertSize; + // Same with MSSQL which is limited to 1000 rows per INSERT + RowLimitExceeded := RowCountInChunk >= Quoter.MaxRowsPerInsert; + if (RowCountInChunk > 0) and (InsertSizeExceeded or RowLimitExceeded or FCancelled) then + Break; Inc(RowCount); - IsFirstRowInChunk := False; + Inc(RowCountInChunk); Output(Row, False, True, True, True, True); Data.Next; end; Output('', True, True, True, True, True); LogStatistic(RowCount); - if Data.Eof then + if Data.Eof or FCancelled then break; end; @@ -1772,7 +2187,8 @@ procedure TfrmTableTools.DoExport(DBObj: TDBObject); break; end; - Output('/*!40000 ALTER TABLE '+TargetDbAndObject+' ENABLE KEYS */', True, True, True, True, True); + if menuExportTransactions.Checked then + Output('COMMIT', True, True, True, True, True); Output(CRLF, False, True, True, True, True); // Cosmetic fix for estimated InnoDB row count DBObj.Rows := RowCount; @@ -1867,7 +2283,7 @@ procedure TfrmTableTools.DoBulkTableEdit(DBObj: TDBObject); LogRow := FResults.Last; if Specs.Count > 0 then begin - DBObj.Connection.Query('ALTER TABLE ' + DBObj.QuotedDatabase + '.' + DBObj.QuotedName + ' ' + ImplodeStr(', ', Specs)); + DBObj.Connection.Query('ALTER TABLE ' + DBObj.QuotedDatabase + '.' + DBObj.QuotedName + ' ' + Implode(', ', Specs)); LogRow[2] := _('Done'); LogRow[3] := _('Success'); end else begin @@ -1878,17 +2294,251 @@ procedure TfrmTableTools.DoBulkTableEdit(DBObj: TDBObject); end; +procedure TfrmTableTools.DoBeforeGenerateData(Sender: TObject); +var + Conn: TDBConnection; +begin + // Disable foreign key checks + if ToolMode <> tmGenerateData then + Exit; + Conn := MainForm.ActiveConnection; + if Conn.SqlProvider.Has(qDisableForeignKeyChecks) then + Conn.Query(qDisableForeignKeyChecks); +end; + + +procedure TfrmTableTools.DoAfterGenerateData(Sender: TObject); +var + Conn: TDBConnection; +begin + // Disable foreign key checks + if ToolMode <> tmGenerateData then + Exit; + Conn := MainForm.ActiveConnection; + if Conn.SqlProvider.Has(qEnableForeignKeyChecks) then + Conn.Query(qEnableForeignKeyChecks); +end; + + +procedure TfrmTableTools.DoGenerateData(DBObj: TDBObject); +var + Columns: TTableColumnList; + Col: TTableColumn; + InsertSqlBase, InsertSql: String; + ColumnNamesSkipped, ColumnNamesQuoted, Values: TStringList; + i, j: Integer; + IntVal, MaxLen, MinLen: Integer; + FloatVal: Extended; + JsonText: TJSONString; + EnumValues: TStringList; + TextVal: String; + BinVal: String; + + function RS: String; + begin + // return a Random integer as String + Result := RandomRange(1, 100).ToString; + end; +begin + // Generate rows + if not (DBObj.NodeType in [lntTable, lntView]) then begin + AddNotes(DBObj, STRSKIPPED+'cannot insert rows in a '+LowerCase(DBObj.ObjType), ''); + Exit; + end; + AddNotes(DBObj, 'Inserting '+FormatNumber(updownGenerateDataNumRows.Position)+' rows into '+DBObj.Name, ''); + UpdateResultGrid; + + Columns := DBObj.TableColumns; + + InsertSqlBase := 'INSERT INTO ' + DBObj.QuotedDbAndTableName + ' '; + ColumnNamesQuoted := TStringList.Create; + ColumnNamesSkipped := TStringList.Create; + Values := TStringList.Create; + for Col in Columns do begin + if Col.DefaultType = cdtAutoInc then begin + ColumnNamesSkipped.Add(Col.Name); + Continue; + end; + if (Col.DefaultType = cdtExpression) and ExecRegExprI('^(NOW()|CURRENT_TIMESTAMP)', Col.DefaultText) then begin + ColumnNamesSkipped.Add(Col.Name); + Continue; + end; + + ColumnNamesQuoted.Add(Col.Connection.QuoteIdent(Col.Name)); + end; + InsertSqlBase := InsertSqlBase + '(' + Implode(', ', ColumnNamesQuoted) + ') VALUES '; + + Randomize; + + for i:=1 to updownGenerateDataNumRows.Position do begin + Values.Clear; + // Generate random values. Include some NULLs for columns which allow that. + for Col in Columns do begin + if ColumnNamesSkipped.Contains(Col.Name) then + Continue; + + // https://www.delphipraxis.net/31059-warscheinlichkeit-random.html + if Col.AllowNull + and (updownGenerateDataNullAmount.Position > 0) // prevent division by zero + and (Random < (updownGenerateDataNullAmount.Position / 100)) + then begin + Values.Add('NULL'); + Continue; + end; + + case Col.DataType.Category of + dtcInteger: begin + // Take care of overflow in RandomRange with signed integers + IntVal := 0; + case Col.DataType.Index of + dbdtTinyint: + IntVal := IfThen(Col.Unsigned, RandomRange(0, 256), RandomRange(-128, 128)); + dbdtSmallint: + IntVal := IfThen(Col.Unsigned, RandomRange(0, 65535), RandomRange(-32768, 32768)); + dbdtMediumint: + IntVal := IfThen(Col.Unsigned, RandomRange(0, 16777215), RandomRange(-8388608, 8388608)); + dbdtUint: + IntVal := RandomRange(0, MaxInt); + dbdtInt, dbdtBigint: + IntVal := IfThen(Col.Unsigned, RandomRange(0, MaxInt), RandomRange(0 - MaxInt, MaxInt)); + end; + Values.Add(IntVal.ToString); + end; + + dtcReal: begin + FloatVal := 0; + case Col.DataType.Index of + dbdtFloat, dbdtDouble, dbdtDecimal, dbdtNumeric, dbdtReal, dbdtDoublePrecision, dbdtMoney, dbdtSmallmoney: + FloatVal := IfThen(Col.Unsigned, RandomRange(0, 100000), RandomRange(-100000, 100000)) + Random; + end; + Values.Add(FloatToStr(FloatVal, MainForm.FormatSettings)); + end; + + dtcText: begin + MaxLen := 0; + case Col.DataType.Index of + dbdtChar, dbdtVarchar: + MaxLen := StrToIntDef(Col.LengthSet, 1); + dbdtTinytext: + MaxLen := Trunc(Power(2, 8)) -1; + dbdtText, dbdtMediumtext, dbdtLongtext, dbdtJson, dbdtJsonB: + MaxLen := Trunc(Power(2, 16)) -1; + end; + TextVal := ''; + MaxLen := Min(MaxLen, SIZE_KB); + MaxLen := RandomRange(1, MaxLen+1); + for j:=1 to MaxLen do begin + if Random < 0.01 then + TextVal := TextVal + #10 // New line + else if Random < 0.05 then + TextVal := TextVal + ' ' // Space + else if Random < 0.1 then + TextVal := TextVal + Chr(RandomRange(65, 90)) // Uppercase letters + else + TextVal := TextVal + Chr(RandomRange(97, 122)); // Lowercase letters + end; + TextVal := Trim(TextVal); + if Col.DataType.Index in [dbdtJson, dbdtJsonB] then begin + JsonText := TJSONString.Create(TextVal); + TextVal := JsonText.ToJSON; + JsonText.Free; + end; + Values.Add(Col.Connection.EscapeString(TextVal)); + end; + + dtcBinary: begin + MaxLen := 0; + case Col.DataType.Index of + dbdtBinary, dbdtVarbinary: + MaxLen := StrToIntDef(Col.LengthSet, 1); + dbdtTinyblob: + MaxLen := Trunc(Power(2, 8)) -1; + dbdtBlob, dbdtMediumblob, dbdtLongblob: + MaxLen := Trunc(Power(2, 16)) -1; + end; + BinVal := ''; + MinLen := Min(16, MaxLen); + MaxLen := RandomRange(MinLen, MaxLen+1); + for j:=1 to MaxLen do begin + BinVal := BinVal + Chr(RandomRange(1, 256)); + end; + Values.Add(Col.Connection.EscapeBin(BinVal)); + end; + + dtcTemporal: begin + TextVal := ''; + case Col.DataType.Index of + dbdtDate, dbdtTime, dbdtYear, dbdtDatetime, dbdtDatetime2, dbdtTimestamp, dbdtInterval: begin + MinLen := Trunc(VarToDateTime('1971-01-01')); + MaxLen := Trunc(VarToDateTime('2035-01-01')); + FloatVal := RandomRange(MinLen, MaxLen) + Random; + TextVal := FormatDateTime(Col.DataType.Format, FloatVal, MainForm.FormatSettings); + end; + + dbdtDatetimeOffset: ; + dbdtSmalldatetime: ; + end; + Values.Add(Col.Connection.EscapeString(TextVal)); + end; + + dtcSpatial: begin + TextVal := Col.Connection.EscapeString(''); + case Col.DataType.Index of + dbdtPoint: TextVal := 'POINT('+RS+', '+RS+')'; + dbdtMultipoint: TextVal := 'MULTIPOINT(POINT('+RS+', '+RS+'), POINT('+RS+', '+RS+'))'; + dbdtLinestring: TextVal := 'LINESTRING(POINT('+RS+', '+RS+'), POINT('+RS+', '+RS+'))'; + dbdtMultilinestring: TextVal := 'MULTILINESTRING(LINESTRING(POINT('+RS+', '+RS+'), POINT('+RS+', '+RS+')), LINESTRING(POINT('+RS+', '+RS+'), POINT('+RS+', '+RS+')))'; + dbdtPolygon: TextVal := 'POLYGON(LINESTRING(POINT('+RS+', '+RS+'), POINT('+RS+', '+RS+')), LINESTRING(POINT('+RS+', '+RS+'), POINT('+RS+', '+RS+')))'; + dbdtMultipolygon: TextVal := 'MULTIPOLYGON(POLYGON(LINESTRING(POINT('+RS+', '+RS+'), POINT('+RS+', '+RS+')), LINESTRING(POINT('+RS+', '+RS+'), POINT('+RS+', '+RS+'))))'; + dbdtGeometry: TextVal := 'POINT('+RS+', '+RS+')'; + dbdtGeometrycollection: TextVal := 'GEOMETRYCOLLECTION(POINT('+RS+', '+RS+'), LINESTRING(POINT('+RS+', '+RS+'), POINT('+RS+', '+RS+')))'; + end; + Values.Add(TextVal); + end; + + dtcOther: begin + case Col.DataType.Index of + dbdtEnum, dbdtSet: begin + EnumValues := Col.ValueList; + IntVal := RandomRange(0, EnumValues.Count); + TextVal := EnumValues[IntVal]; + EnumValues.Free; + Values.Add(Col.Connection.EscapeString(TextVal)); + end; + dbdtBool: begin + IntVal := RandomRange(0, 2); + TextVal := IfThen(IntVal=0, 'true', 'false'); + Values.Add(Col.Connection.EscapeString(TextVal)); + end; + else + Values.Add('0'); + end; + end; + end; + end; + InsertSql := InsertSqlBase + '(' + Implode(', ', Values) + ')'; + DBObj.Connection.Query(InsertSql, False, lcScript); + end; + + ColumnNamesQuoted.Free; + ColumnNamesSkipped.Free; + Values.Free; +end; + + procedure TfrmTableTools.CheckAllClick(Sender: TObject); var DBNode, ObjNode: PVirtualNode; WantedType: TListNodeType; DBObj: PDBObject; - CheckNone: Boolean; + CheckNone, DoCheck: Boolean; + InvertCheck: Boolean; CheckedNodes: Int64; begin // Check all/none/by type via context menu WantedType := TListNodeType((Sender as TMenuItem).Tag); CheckNone := Sender = menuCheckNone; + InvertCheck := Sender = menuInvertCheck; case TreeObjects.GetNodeLevel(TreeObjects.FocusedNode) of 1: DBNode := TreeObjects.FocusedNode; 2: DBNode := TreeObjects.FocusedNode.Parent; @@ -1899,19 +2549,29 @@ procedure TfrmTableTools.CheckAllClick(Sender: TObject); CheckedNodes := 0; while Assigned(ObjNode) do begin DBObj := TreeObjects.GetNodeData(ObjNode); + if CheckNone then - TreeObjects.CheckState[ObjNode] := csUncheckedNormal + DoCheck := False + else if not TreeObjects.IsVisible[ObjNode] then + DoCheck := False + else if InvertCheck then + DoCheck := not (ObjNode.CheckState in CheckedStates) + else + DoCheck := (WantedType = lntNone) or (DBObj.NodeType = WantedType) or (DBObj.GroupType = WantedType); + + if DoCheck then begin + TreeObjects.CheckState[ObjNode] := csCheckedNormal; + Inc(CheckedNodes); + end else begin - if (WantedType = lntNone) or (DBObj.NodeType = WantedType) or (DBObj.GroupType = WantedType) then - TreeObjects.CheckState[ObjNode] := csCheckedNormal - else - TreeObjects.CheckState[ObjNode] := csUncheckedNormal; + TreeObjects.CheckState[ObjNode] := csUncheckedNormal; end; - if ObjNode.CheckState = csCheckedNormal then - Inc(CheckedNodes); + TreeObjects.RepaintNode(ObjNode); ObjNode := TreeObjects.GetNextSibling(ObjNode); end; + + // Update parent node's checkbox if CheckedNodes = 0 then TreeObjects.CheckState[DBNode] := csUncheckedNormal else if CheckedNodes = TreeObjects.ChildCount[DBNode] then diff --git a/source/texteditor.dfm b/source/texteditor.dfm index a4d886bd1..803211e9d 100644 --- a/source/texteditor.dfm +++ b/source/texteditor.dfm @@ -2,29 +2,27 @@ object frmTextEditor: TfrmTextEditor Left = 0 Top = 0 Caption = 'Text editor' - ClientHeight = 104 - ClientWidth = 332 + ClientHeight = 153 + ClientWidth = 482 Color = clBtnFace - Constraints.MinHeight = 100 - Constraints.MinWidth = 130 + Constraints.MinHeight = 200 + Constraints.MinWidth = 500 Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText - Font.Height = -11 + Font.Height = -12 Font.Name = 'Tahoma' Font.Style = [] - OldCreateOrder = False Position = poMainFormCenter OnClose = FormClose OnCreate = FormCreate OnDestroy = FormDestroy OnShow = FormShow - PixelsPerInch = 96 - TextHeight = 13 + TextHeight = 14 object Panel1: TPanel AlignWithMargins = True Left = 0 - Top = 82 - Width = 322 + Top = 131 + Width = 472 Height = 22 Margins.Left = 0 Margins.Top = 0 @@ -37,9 +35,9 @@ object frmTextEditor: TfrmTextEditor TabOrder = 0 object lblTextLength: TLabel AlignWithMargins = True - Left = 210 + Left = 409 Top = 3 - Width = 65 + Width = 76 Height = 16 Align = alLeft BiDiMode = bdLeftToRight @@ -50,7 +48,7 @@ object frmTextEditor: TfrmTextEditor object tlbStandard: TToolBar Left = 0 Top = 0 - Width = 207 + Width = 261 Height = 22 Align = alLeft AutoSize = True @@ -79,7 +77,7 @@ object frmTextEditor: TfrmTextEditor Style = tbsDropDown end object btnLoadText: TToolButton - Left = 61 + Left = 65 Top = 0 Hint = 'Load textfile' Caption = 'Load textfile' @@ -88,7 +86,7 @@ object frmTextEditor: TfrmTextEditor OnClick = btnLoadTextClick end object btnCancel: TToolButton - Left = 84 + Left = 88 Top = 0 Hint = 'Cancel' Caption = 'Cancel' @@ -97,7 +95,7 @@ object frmTextEditor: TfrmTextEditor OnClick = btnCancelClick end object btnApply: TToolButton - Left = 107 + Left = 111 Top = 0 Hint = 'Apply changes' Caption = 'Apply changes' @@ -106,7 +104,7 @@ object frmTextEditor: TfrmTextEditor OnClick = btnApplyClick end object btnSeparator1: TToolButton - Left = 130 + Left = 134 Top = 0 Width = 8 Caption = 'btnSeparator1' @@ -115,21 +113,90 @@ object frmTextEditor: TfrmTextEditor Style = tbsSeparator end object btnSearchFind: TToolButton - Left = 138 + Left = 142 Top = 0 - Action = actSearchFind + Action = MainForm.actQueryFind end object btnSearchFindNext: TToolButton - Left = 161 + Left = 165 Top = 0 - Action = actSearchFindNext + Action = MainForm.actQueryFindAgain end object btnSearchReplace: TToolButton - Left = 184 + Left = 188 Top = 0 - Action = actSearchReplace + Action = MainForm.actQueryReplace + end + object ToolButton1: TToolButton + Left = 211 + Top = 0 + Width = 8 + Caption = 'ToolButton1' + ImageIndex = 60 + Style = tbsSeparator + end + object btnCustomizeHighlighter: TToolButton + Left = 219 + Top = 0 + Caption = 'Customize highlighter' + DropdownMenu = popupHighlighter + ImageIndex = 39 + Style = tbsDropDown + OnClick = btnCustomizeHighlighterClick end end + object comboHighlighter: TComboBox + Left = 261 + Top = 0 + Width = 145 + Height = 22 + Align = alLeft + AutoDropDownWidth = True + Style = csDropDownList + Sorted = True + TabOrder = 1 + OnSelect = comboHighlighterSelect + end + end + object MemoText: TSynMemo + Left = 0 + Top = 0 + Width = 482 + Height = 131 + SingleLineMode = False + Align = alClient + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -13 + Font.Name = 'Courier New' + Font.Style = [] + PopupMenu = popupEditor + TabOrder = 1 + OnClick = MemoTextClick + OnKeyDown = MemoTextKeyDown + CodeFolding.GutterShapeSize = 11 + CodeFolding.CollapsedLineColor = clGrayText + CodeFolding.FolderBarLinesColor = clGrayText + CodeFolding.IndentGuidesColor = clGray + CodeFolding.IndentGuides = True + CodeFolding.ShowCollapsedLine = False + CodeFolding.ShowHintMark = True + UseCodeFolding = False + Gutter.AutoSize = True + Gutter.Font.Charset = DEFAULT_CHARSET + Gutter.Font.Color = clWindowText + Gutter.Font.Height = -11 + Gutter.Font.Name = 'Courier New' + Gutter.Font.Style = [] + Gutter.ShowLineNumbers = True + Gutter.ShowModification = True + Lines.Strings = ( + 'MemoText') + Options = [eoAutoIndent, eoAutoSizeMaxScrollWidth, eoDragDropEditing, eoEnhanceEndKey, eoGroupUndo, eoShowScrollHint, eoSmartTabDelete, eoSmartTabs, eoTabIndent, eoTabsToSpaces] + RightEdge = 0 + WantTabs = True + OnChange = MemoTextChange + FontSmoothing = fsmNone end object popupLinebreaks: TPopupMenu Images = MainForm.VirtualImageListMain @@ -166,41 +233,58 @@ object frmTextEditor: TfrmTextEditor OnClick = SelectLinebreaks end end - object ActionList1: TActionList - Images = MainForm.VirtualImageListMain - Left = 64 - Top = 16 - object actSearchFind: TSearchFind - Category = 'Search' - Caption = '&Find...' - Dialog.OnClose = actSearchFindFindDialogClose - Dialog.OnShow = actSearchFindFindDialogShow - Dialog.Options = [frDown, frFindNext] - Hint = 'Find|Finds the specified text' - ImageIndex = 30 - ShortCut = 16454 - end - object actSearchFindNext: TSearchFindNext - Category = 'Search' - Caption = 'Find &Next' - Hint = 'Find Next|Repeats the last find' - ImageIndex = 142 - ShortCut = 114 - end - object actSearchReplace: TSearchReplace - Category = 'Search' - Caption = '&Replace' - Dialog.OnClose = actSearchReplaceReplaceDialogClose - Dialog.OnShow = actSearchReplaceReplaceDialogShow - Dialog.Options = [frDown, frFindNext, frReplace, frReplaceAll] - Hint = 'Replace|Replaces specific text with different text' - ImageIndex = 59 - end - end object TimerMemoChange: TTimer Interval = 200 OnTimer = TimerMemoChangeTimer Left = 120 Top = 16 end + object popupEditor: TPopupMenu + Images = MainForm.VirtualImageListMain + Left = 240 + Top = 16 + object Selectall1: TMenuItem + Action = MainForm.actSelectAll + end + object Copy1: TMenuItem + Action = MainForm.actCopy + end + object Paste1: TMenuItem + Action = MainForm.actPaste + end + object Undo1: TMenuItem + Action = MainForm.actUndo + end + object N1: TMenuItem + Caption = '-' + end + object Findtext1: TMenuItem + Action = MainForm.actQueryFind + end + object Findorreplaceagain1: TMenuItem + Action = MainForm.actQueryFindAgain + end + object Replacetext1: TMenuItem + Action = MainForm.actQueryReplace + end + end + object popupHighlighter: TPopupMenu + Images = MainForm.VirtualImageListMain + Left = 352 + Top = 32 + object menuCustomizeHighlighter: TMenuItem + Caption = 'Customize highlighter' + ImageIndex = 39 + OnClick = btnCustomizeHighlighterClick + end + object menuFormatCodeOnce: TMenuItem + Caption = 'Format code once' + OnClick = menuFormatCodeOnceClick + end + object menuAlwaysFormatCode: TMenuItem + AutoCheck = True + Caption = 'Always format code' + OnClick = menuAlwaysFormatCodeClick + end + end end diff --git a/source/texteditor.pas b/source/texteditor.pas index db143efdb..6f06f4fa1 100644 --- a/source/texteditor.pas +++ b/source/texteditor.pas @@ -3,10 +3,28 @@ interface uses - Windows, Classes, Graphics, Forms, Controls, StdCtrls, VirtualTrees, - ComCtrls, ToolWin, Dialogs, SysUtils, Menus, ExtDlgs, - apphelpers, gnugettext, ActnList, StdActns, extra_controls, System.Actions, - Vcl.ExtCtrls; + Winapi.Windows, System.Classes, Vcl.Graphics, Vcl.Forms, Vcl.Controls, Vcl.StdCtrls, VirtualTrees, + Vcl.ComCtrls, Vcl.ToolWin, Vcl.Dialogs, System.SysUtils, Vcl.Menus, Vcl.ExtDlgs, + apphelpers, gnugettext, Vcl.ActnList, Vcl.StdActns, extra_controls, System.Actions, + Vcl.ExtCtrls, dbconnection, SynEdit, SynMemo, SynEditHighlighter, customize_highlighter, + System.JSON, Rest.Json, Xml.VerySimple, reformatter, + + SynHighlighterADSP21xx, SynHighlighterAWK, SynHighlighterAsm, + SynHighlighterBaan, SynHighlighterBat, SynHighlighterCAC, SynHighlighterCPM, SynHighlighterCS, + SynHighlighterCache, SynHighlighterCobol, SynHighlighterCpp, SynHighlighterCss, SynHighlighterDOT, + SynHighlighterDWS, SynHighlighterDfm, SynHighlighterDml, SynHighlighterEiffel, + SynHighlighterFortran, SynHighlighterFoxpro, SynHighlighterGLSL, SynHighlighterGWS, + SynHighlighterGalaxy, SynHighlighterGeneral, SynHighlighterGo, SynHighlighterHC11, + SynHighlighterHP48, SynHighlighterHashEntries, SynHighlighterHaskell, SynHighlighterHtml, + SynHighlighterIDL, SynHighlighterIni, SynHighlighterInno, SynHighlighterJSON, SynHighlighterJScript, + SynHighlighterJava, SynHighlighterKix, SynHighlighterLDraw, SynHighlighterLLVM, SynHighlighterM3, + SynHighlighterModelica, SynHighlighterMsg, SynHighlighterPHP, SynHighlighterPas, SynHighlighterPerl, + SynHighlighterProgress, SynHighlighterPython, SynHighlighterRC, SynHighlighterRexx, + SynHighlighterRuby, SynHighlighterSDD, SynHighlighterSQL, SynHighlighterST, SynHighlighterSml, + SynHighlighterTclTk, SynHighlighterTeX, SynHighlighterUNIXShellScript, SynHighlighterURI, + SynHighlighterUnreal, SynHighlighterVB, SynHighlighterVBScript, SynHighlighterVrml97, + SynHighlighterWebIDL, SynHighlighterXML, SynHighlighterZPL + ; {$I const.inc} @@ -26,41 +44,58 @@ TfrmTextEditor = class(TExtForm) menuMacLB: TMenuItem; menuMixedLB: TMenuItem; menuWideLB: TMenuItem; - ActionList1: TActionList; - actSearchFind: TSearchFind; btnSearchFind: TToolButton; - actSearchFindNext: TSearchFindNext; - actSearchReplace: TSearchReplace; btnSearchReplace: TToolButton; btnSearchFindNext: TToolButton; btnSeparator1: TToolButton; TimerMemoChange: TTimer; + comboHighlighter: TComboBox; + MemoText: TSynMemo; + popupEditor: TPopupMenu; + Copy1: TMenuItem; + Paste1: TMenuItem; + Selectall1: TMenuItem; + Undo1: TMenuItem; + Findtext1: TMenuItem; + Findorreplaceagain1: TMenuItem; + Replacetext1: TMenuItem; + N1: TMenuItem; + ToolButton1: TToolButton; + btnCustomizeHighlighter: TToolButton; + popupHighlighter: TPopupMenu; + menuCustomizeHighlighter: TMenuItem; + menuFormatCodeOnce: TMenuItem; + menuAlwaysFormatCode: TMenuItem; procedure btnApplyClick(Sender: TObject); procedure btnCancelClick(Sender: TObject); procedure btnLoadTextClick(Sender: TObject); procedure btnWrapClick(Sender: TObject); procedure FormDestroy(Sender: TObject); procedure FormShow(Sender: TObject); - procedure memoTextChange(Sender: TObject); - procedure memoTextKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); - procedure memoTextClick(Sender: TObject); + procedure MemoTextChange(Sender: TObject); + procedure MemoTextKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); + procedure MemoTextClick(Sender: TObject); procedure FormCreate(Sender: TObject); procedure FormClose(Sender: TObject; var Action: TCloseAction); procedure SelectLinebreaks(Sender: TObject); procedure TimerMemoChangeTimer(Sender: TObject); - procedure actSearchFindFindDialogShow(Sender: TObject); - procedure actSearchFindFindDialogClose(Sender: TObject); - procedure actSearchReplaceReplaceDialogShow(Sender: TObject); - procedure actSearchReplaceReplaceDialogClose(Sender: TObject); + procedure comboHighlighterSelect(Sender: TObject); + procedure btnCustomizeHighlighterClick(Sender: TObject); + procedure menuFormatCodeOnceClick(Sender: TObject); + procedure menuAlwaysFormatCodeClick(Sender: TObject); private { Private declarations } FModified: Boolean; - FStopping: Boolean; + FClosingByApplyButton: Boolean; + FClosingByCancelButton: Boolean; FDetectedLineBreaks, FSelectedLineBreaks: TLineBreaks; - FmemoText: TLineNormalizingMemo; - FFindDialogActive, FReplaceDialogActive: Boolean; + FMaxLength: Integer; + FTableColumn: TTableColumn; + FHighlighter: TSynCustomHighlighter; + FHighlighterFormatters: TStringList; procedure SetModified(NewVal: Boolean); + procedure CustomizeHighlighterChanged(Sender: TObject); public function GetText: String; procedure SetText(text: String); @@ -68,7 +103,7 @@ TfrmTextEditor = class(TExtForm) procedure SetMaxLength(len: integer); procedure SetFont(font: TFont); property Modified: Boolean read FModified write SetModified; - property memoText: TLineNormalizingMemo read FmemoText; + property TableColumn: TTableColumn read FTableColumn write FTableColumn; end; @@ -83,15 +118,10 @@ function TfrmTextEditor.GetText: String; var LB: String; begin - Result := FmemoText.Text; + Result := MemoText.Text; // Convert linebreaks back to selected - LB := ''; - case FSelectedLineBreaks of - lbsUnix: LB := LB_UNIX; - lbsMac: LB := LB_MAC; - lbsWide: LB := LB_WIDE; - end; - if LB <> '' then + LB := GetLineBreak(FSelectedLineBreaks); + if LB <> CRLF then Result := StringReplace(Result, CRLF, LB, [rfReplaceAll]); end; @@ -112,8 +142,19 @@ procedure TfrmTextEditor.SetText(text: String); end; if Assigned(Detected) then SelectLineBreaks(Detected); - FmemoText.Text := text; - FmemoText.SelectAll; + if (Length(text) > SIZE_KB*10) then begin + MainForm.LogSQL(_('Auto-disabling wordwrap and syntax highlighter for large text')); + btnWrap.Enabled := False; + comboHighlighter.Enabled := False; + btnCustomizeHighlighter.Enabled := False; + end else begin + btnWrap.Enabled := True; + comboHighlighter.Enabled := True; + btnCustomizeHighlighter.Enabled := True; + end; + + MemoText.Text := text; + MemoText.SelectAll; Modified := False; end; @@ -128,26 +169,42 @@ procedure TfrmTextEditor.SetTitleText(Title: String); procedure TfrmTextEditor.TimerMemoChangeTimer(Sender: TObject); var - Lines: Cardinal; - TextLen: Integer; MaxLen, CursorPos: String; begin // Timer based onchange handler, so we don't scan the whole text on every typed character TimerMemoChange.Enabled := False; - TextLen := Length(FmemoText.Text); - if FmemoText.MaxLength = 0 then + if FMaxLength = 0 then MaxLen := '?' else - MaxLen := FormatNumber(FmemoText.MaxLength); - if TextLen = 0 then - Lines := 0 - else - Lines := CountLineBreaks(FmemoText.Text) + 1; - CursorPos := FormatNumber(FmemoText.CaretPos.Y+1) + ' : ' + FormatNumber(FmemoText.CaretPos.X+1); - lblTextLength.Caption := f_('%s characters (max: %s), %s lines, cursor at %s', [FormatNumber(TextLen), MaxLen, FormatNumber(Lines), CursorPos]); + MaxLen := FormatNumber(FMaxLength); + CursorPos := FormatNumber(MemoText.CaretY) + ':' + FormatNumber(MemoText.CaretX); + lblTextLength.Caption := f_('%s characters (max: %s), %s lines, cursor at %s', [FormatNumber(MemoText.GetTextLen), MaxLen, FormatNumber(MemoText.Lines.Count), CursorPos]); + if MemoText.ReadOnly then + lblTextLength.Caption := lblTextLength.Caption + ', read-only'; end; +procedure TfrmTextEditor.btnCustomizeHighlighterClick(Sender: TObject); +var + Dialog: TfrmCustomizeHighlighter; +begin + // let user customize highlighter colors + Dialog := TfrmCustomizeHighlighter.Create(Self); + Dialog.FriendlyLanguageName := MemoText.Highlighter.FriendlyLanguageName; + Dialog.OnChange := CustomizeHighlighterChanged; + Dialog.ShowModal; + Dialog.Free; +end; + +procedure TfrmTextEditor.CustomizeHighlighterChanged(Sender: TObject); +var + Dialog: TfrmCustomizeHighlighter; +begin + Dialog := Sender as TfrmCustomizeHighlighter; + comboHighlighter.ItemIndex := comboHighlighter.Items.IndexOf(Dialog.FriendlyLanguageName); + comboHighlighter.OnSelect(comboHighlighter); +end; + procedure TfrmTextEditor.SelectLinebreaks(Sender: TObject); var Selected, Item: TMenuItem; @@ -175,72 +232,110 @@ procedure TfrmTextEditor.SelectLinebreaks(Sender: TObject); procedure TfrmTextEditor.SetMaxLength(len: integer); begin // Input: Length in number of bytes. - FmemoText.MaxLength := len; + FMaxLength := len; end; procedure TfrmTextEditor.SetFont(font: TFont); begin - FmemoText.Font.Name := font.Name; - FmemoText.Font.Size := font.Size; + MemoText.Font.Name := font.Name; + MemoText.Font.Size := font.Size; end; procedure TfrmTextEditor.FormCreate(Sender: TObject); +var + Highlighters: TSynHighlighterList; + i: Integer; begin HasSizeGrip := True; - FmemoText := TLineNormalizingMemo.Create(Self); - FmemoText.Parent := Self; - FmemoText.Align := alClient; - FmemoText.ScrollBars := ssBoth; - FmemoText.WantTabs := True; - FmemoText.OnChange := memoTextChange; - FmemoText.OnKeyDown := memoTextKeyDown; - FmemoText.OnClick := memoTextClick; - FmemoText.HideSelection := False; // Make found text visible when find dialog has focus - // Use same text properties as in query/find/replace actions - actSearchFind.Caption := MainForm.actQueryFind.Caption; - actSearchFind.Hint := MainForm.actQueryFind.Hint; - actSearchFindNext.Caption := MainForm.actQueryFindAgain.Caption; - actSearchFindNext.Hint := MainForm.actQueryFindAgain.Hint; - actSearchReplace.Caption := MainForm.actQueryReplace.Caption; - actSearchReplace.Hint := MainForm.actQueryReplace.Hint; + FClosingByApplyButton := False; // Assign linebreak values to their menu item tags, to write less code later menuWindowsLB.Tag := Integer(lbsWindows); menuUnixLB.Tag := Integer(lbsUnix); menuMacLB.Tag := Integer(lbsMac); menuWideLB.Tag := Integer(lbsWide); menuMixedLB.Tag := Integer(lbsMixed); - // Restore form dimensions - Width := AppSettings.ReadInt(asMemoEditorWidth); - Height := AppSettings.ReadInt(asMemoEditorHeight); - if AppSettings.ReadBool(asMemoEditorMaximized) then - WindowState := wsMaximized; - if AppSettings.ReadBool(asMemoEditorWrap) then - btnWrap.Click; + + Highlighters := SynEditHighlighter.GetPlaceableHighlighters; + for i:=0 to Highlighters.Count-1 do begin + comboHighlighter.Items.Add(Highlighters[i].GetFriendlyLanguageName); + end; + + FTableColumn := nil; + // Fix label position: lblTextLength.Top := tlbStandard.Top + (tlbStandard.Height-lblTextLength.Height) div 2; + + // Define highlighters for which we have a reformatter + FHighlighterFormatters := TStringList.Create; + FHighlighterFormatters.Add(TSynJSONSyn.ClassName); + FHighlighterFormatters.Add(TSynSQLSyn.ClassName); + FHighlighterFormatters.Add(TSynXMLSyn.ClassName); + + MemoText.OnMouseWheel := MainForm.AnySynMemoMouseWheel; + MemoText.OnPaintTransient := MainForm.SynMemoQuery.OnPaintTransient; + if AppSettings.ReadBool(asMemoEditorMaximized) then + WindowState := wsMaximized; end; procedure TfrmTextEditor.FormDestroy(Sender: TObject); begin if WindowState <> wsMaximized then begin - AppSettings.WriteInt(asMemoEditorWidth, Width); - AppSettings.WriteInt(asMemoEditorHeight, Height); + AppSettings.WriteIntDpiAware(asMemoEditorWidth, Self, Width); + AppSettings.WriteIntDpiAware(asMemoEditorHeight, Self, Height); end; AppSettings.WriteBool(asMemoEditorMaximized, WindowState=wsMaximized); - AppSettings.WriteBool(asMemoEditorWrap, btnWrap.Down); + if btnWrap.Enabled then begin + AppSettings.WriteBool(asMemoEditorWrap, btnWrap.Down); + end; + if Assigned(FTableColumn) then begin + AppSettings.SessionPath := MainForm.GetRegKeyTable; + if comboHighlighter.Text <> AppSettings.GetDefaultString(asMemoEditorHighlighter) then + AppSettings.WriteString(asMemoEditorHighlighter, comboHighlighter.Text, FTableColumn.Name) + else + AppSettings.DeleteValue(asMemoEditorHighlighter, FTableColumn.Name); + end; + // Fixes EAccessViolation under 64-bit when using non-default themes + if Assigned(Panel1) then + Panel1.Parent := nil; end; procedure TfrmTextEditor.FormShow(Sender: TObject); +var + HighlighterName: String; begin + // Restore form dimensions + if WindowState <> wsMaximized then begin + Width := AppSettings.ReadIntDpiAware(asMemoEditorWidth, Self); + Height := AppSettings.ReadIntDpiAware(asMemoEditorHeight, Self); + end; + + if AppSettings.ReadBool(asMemoEditorWrap) and btnWrap.Enabled then begin + btnWrap.Click; + end; + menuAlwaysFormatCode.Checked := AppSettings.ReadBool(asMemoEditorAlwaysFormatCode); + + // Select previously used highlighter + HighlighterName := AppSettings.GetDefaultString(asMemoEditorHighlighter); + if Assigned(FTableColumn) then begin + AppSettings.SessionPath := MainForm.GetRegKeyTable; + HighlighterName := AppSettings.ReadString(asMemoEditorHighlighter, FTableColumn.Name, HighlighterName); + end; + + if MemoText.ReadOnly then begin + MemoText.Color := clBtnFace; + end; + + comboHighlighter.ItemIndex := comboHighlighter.Items.IndexOf(HighlighterName); + comboHighlighter.OnSelect(comboHighlighter); // Trigger change event, which is not fired when text is empty. See #132. TimerMemoChangeTimer(Self); - FmemoText.SetFocus; + MemoText.SetFocus; end; -procedure TfrmTextEditor.memoTextKeyDown(Sender: TObject; var Key: Word; Shift: +procedure TfrmTextEditor.MemoTextKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); begin TimerMemoChange.Enabled := False; @@ -248,12 +343,7 @@ procedure TfrmTextEditor.memoTextKeyDown(Sender: TObject; var Key: Word; Shift: case Key of // Cancel active dialog by Escape VK_ESCAPE: begin - if FFindDialogActive then - actSearchFind.Dialog.CloseDialog - else if FReplaceDialogActive then - actSearchReplace.Dialog.CloseDialog - else - btnCancelClick(Sender); + btnCancelClick(Sender); end; // Apply changes and end editing by Ctrl + Enter VK_RETURN: if ssCtrl in Shift then btnApplyClick(Sender); @@ -261,7 +351,7 @@ procedure TfrmTextEditor.memoTextKeyDown(Sender: TObject; var Key: Word; Shift: end; end; -procedure TfrmTextEditor.memoTextClick(Sender: TObject); +procedure TfrmTextEditor.MemoTextClick(Sender: TObject); begin TimerMemoChange.Enabled := False; TimerMemoChange.Enabled := True; @@ -274,31 +364,75 @@ procedure TfrmTextEditor.btnWrapClick(Sender: TObject); Screen.Cursor := crHourglass; // Changing the scrollbars invoke the OnChange event. We avoid thinking the text was really modified. WasModified := Modified; - if FmemoText.ScrollBars = ssBoth then - FmemoText.ScrollBars := ssVertical - else - FmemoText.ScrollBars := ssBoth; - TToolbutton(Sender).Down := FmemoText.ScrollBars = ssVertical; + if MemoText.ScrollBars = ssBoth then begin + MemoText.ScrollBars := ssVertical; + MemoText.WordWrap := True; + end else begin + MemoText.ScrollBars := ssBoth; + MemoText.WordWrap := False; + end; + btnWrap.Down := MemoText.ScrollBars = ssVertical; Modified := WasModified; Screen.Cursor := crDefault; end; +procedure TfrmTextEditor.comboHighlighterSelect(Sender: TObject); +var + Highlighters: TSynHighlighterList; + i: Integer; + SelStart, SelLength: Integer; +begin + // Code highlighter selected + if not comboHighlighter.Enabled then + Exit; + SelStart := MemoText.SelStart; + SelLength := MemoText.SelLength; + MemoText.Highlighter := nil; + FHighlighter.Free; + Highlighters := SynEditHighlighter.GetPlaceableHighlighters; + for i:=0 to Highlighters.Count-1 do begin + if comboHighlighter.Text = Highlighters[i].GetFriendlyLanguageName then begin + FHighlighter := Highlighters[i].Create(Self); + MemoText.Highlighter := FHighlighter; + Break; + end; + end; + // In case the combobox is empty: + if MemoText.Highlighter = nil then begin + FHighlighter := TSynGeneralSyn.Create(Self); + MemoText.Highlighter := FHighlighter; + end; + + menuFormatCodeOnce.Enabled := FHighlighterFormatters.IndexOf(FHighlighter.ClassName) > -1; + if menuAlwaysFormatCode.Checked and menuFormatCodeOnce.Enabled then begin + menuFormatCodeOnce.OnClick(Sender); + SelStart := 0; + SelLength := 0; + end; + + // Load custom highlighter settings from ini file, if exists: + MemoText.Highlighter.LoadFromFile(AppSettings.DirnameHighlighters + MemoText.Highlighter.LanguageName + '.ini'); + + MemoText.SelStart := SelStart; + MemoText.SelLength := SelLength; +end; + procedure TfrmTextEditor.btnLoadTextClick(Sender: TObject); var - d: TOpenTextFileDialog; + d: TExtFileOpenDialog; begin AppSettings.ResetPath; - d := TOpenTextFileDialog.Create(Self); - d.Filter := _('Text files')+' (*.txt)|*.txt|'+_('All files')+' (*.*)|*.*'; - d.FilterIndex := 0; + d := TExtFileOpenDialog.Create(Self); + d.AddFileType('*.txt', _('Text files')); + d.AddFileType('*.*', _('All files')); d.Encodings.Assign(MainForm.FileEncodings); d.EncodingIndex := AppSettings.ReadInt(asFileDialogEncoding, Self.Name); if d.Execute then try Screen.Cursor := crHourglass; - FmemoText.Text := ReadTextFile(d.FileName, MainForm.GetEncodingByName(d.Encodings[d.EncodingIndex])); - if (FmemoText.MaxLength > 0) and (Length(FmemoText.Text) > FmemoText.MaxLength) then - FmemoText.Text := copy(FmemoText.Text, 0, FmemoText.MaxLength); + MemoText.Text := ReadTextFile(d.FileName, MainForm.GetEncodingByName(d.Encodings[d.EncodingIndex])); + if (FMaxLength > 0) and (Length(MemoText.Text) > FMaxLength) then + MemoText.Text := Copy(MemoText.Text, 1, FMaxLength); AppSettings.WriteInt(asFileDialogEncoding, d.EncodingIndex, Self.Name); finally Screen.Cursor := crDefault; @@ -309,39 +443,96 @@ procedure TfrmTextEditor.btnLoadTextClick(Sender: TObject); procedure TfrmTextEditor.btnCancelClick(Sender: TObject); begin - if FStopping then - Exit; - FStopping := True; - TCustomVirtualStringTree(Owner).CancelEditNode; + FClosingByCancelButton := True; + Close; end; -procedure TfrmTextEditor.FormClose(Sender: TObject; var Action: TCloseAction); +procedure TfrmTextEditor.menuAlwaysFormatCodeClick(Sender: TObject); +begin + // Change setting for "always reformat" + AppSettings.WriteBool(asMemoEditorAlwaysFormatCode, menuAlwaysFormatCode.Checked); + if menuAlwaysFormatCode.Checked and menuFormatCodeOnce.Enabled then begin + menuFormatCodeOnce.OnClick(Sender); + end; +end; + + +procedure TfrmTextEditor.menuFormatCodeOnceClick(Sender: TObject); var - DoPost: Boolean; + JsonTmp: TJSONValue; + Xml: TXmlVerySimple; + //XmlTmp: IXMLDocument; begin - if FStopping then - Exit; - FStopping := True; - if Modified then - DoPost := MessageDialog(_('Apply modifications?'), mtConfirmation, [mbYes, mbNo]) = mrYes - else - DoPost := False; - if DoPost then - TCustomVirtualStringTree(Owner).EndEditNode + // Reformat code if possible + try + if FHighlighter is TSynJSONSyn then begin + JsonTmp := TJSONObject.ParseJSONValue(MemoText.Text); + MemoText.Text := JsonTmp.Format; + JsonTmp.Free; + MemoText.SelStart := 0; + MemoText.SelLength := 0; + end + else if FHighlighter is TSynSQLSyn then begin + // Prefer old internal formatter here, so the user does not run into request limits + frmReformatter := TfrmReformatter.Create(Self); + MemoText.Text := frmReformatter.FormatSqlInternal(MemoText.Text); + MemoText.SelStart := 0; + MemoText.SelLength := 0; + frmReformatter.Free; + end + else if FHighlighter is TSynXMLSyn then begin + {XmlTmp := TXMLDocument.Create(nil); + XmlTmp.LoadFromXML(MemoText.Text); + MemoText.BeginUpdate; + MemoText.Text := XMLDoc.FormatXMLData(MemoText.Text); + MemoText.EndUpdate;} + Xml := TXmlVerySimple.Create; + //Xml.Options := [doNodeAutoIndent, doParseProcessingInstr, doCaseInsensitive, doWriteBOM, doSimplifyTextNodes]; + Xml.Clear; + Xml.Text := MemoText.Lines.Text.Trim; + MemoText.BeginUpdate; + MemoText.Lines.Text := Xml.Text; + MemoText.EndUpdate; + Xml.Free; + MemoText.SelStart := 0; + MemoText.SelLength := 0; + end + else begin + MessageBeep(MB_ICONEXCLAMATION); + end; + except + on E:Exception do begin + MessageBeep(MB_ICONERROR); + MainForm.LogSQL(f_('Error in code formatting: %s', [E.Message])); + end; + end; +end; + + +procedure TfrmTextEditor.FormClose(Sender: TObject; var Action: TCloseAction); +begin + if Modified then begin + if FClosingByCancelButton then + ModalResult := mrCancel + else if FClosingByApplyButton then + ModalResult := mrYes + else + ModalResult := MessageDialog(_('Apply modifications?'), mtConfirmation, [mbYes, mbNo]); + end else - TCustomVirtualStringTree(Owner).CancelEditNode; + ModalResult := mrCancel; end; procedure TfrmTextEditor.btnApplyClick(Sender: TObject); begin - FStopping := True; - TCustomVirtualStringTree(Owner).EndEditNode; + FClosingByApplyButton := True; + Close; end; -procedure TfrmTextEditor.memoTextChange(Sender: TObject); +procedure TfrmTextEditor.MemoTextChange(Sender: TObject); begin Modified := True; TimerMemoChange.Enabled := False; @@ -351,35 +542,14 @@ procedure TfrmTextEditor.memoTextChange(Sender: TObject); procedure TfrmTextEditor.SetModified(NewVal: Boolean); begin + // Enables or disables "apply" button, and resets SynEdit's modification marker in its gutter if FModified <> NewVal then begin FModified := NewVal; + if not FModified then + MemoText.ResetModificationIndicator; btnApply.Enabled := FModified; end; end; -procedure TfrmTextEditor.actSearchFindFindDialogShow(Sender: TObject); -begin - FFindDialogActive := True; -end; - - -procedure TfrmTextEditor.actSearchFindFindDialogClose(Sender: TObject); -begin - FFindDialogActive := False; -end; - - -procedure TfrmTextEditor.actSearchReplaceReplaceDialogShow(Sender: TObject); -begin - FReplaceDialogActive := True; -end; - - -procedure TfrmTextEditor.actSearchReplaceReplaceDialogClose(Sender: TObject); -begin - FReplaceDialogActive := False; -end; - - end. diff --git a/source/theme_preview.dfm b/source/theme_preview.dfm index 36484646d..2d5387328 100644 --- a/source/theme_preview.dfm +++ b/source/theme_preview.dfm @@ -1,46 +1,44 @@ -object frmThemePreview: TfrmThemePreview - Left = 0 - Top = 0 - BorderIcons = [biSystemMenu] - Caption = 'Theme preview' - ClientHeight = 118 - ClientWidth = 229 - Color = clBtnFace - Font.Charset = DEFAULT_CHARSET - Font.Color = clWindowText - Font.Height = -11 - Font.Name = 'Tahoma' - Font.Style = [] - OldCreateOrder = False - OnClose = FormClose - OnCreate = FormCreate - OnShow = FormShow - PixelsPerInch = 96 - TextHeight = 13 - object StatusBarMain: TStatusBar - Left = 0 - Top = 99 - Width = 229 - Height = 19 - Panels = <> - SimplePanel = True - end - object ScrollBoxImage: TScrollBox - Left = 0 - Top = 0 - Width = 229 - Height = 99 - HorzScrollBar.Tracking = True - VertScrollBar.Tracking = True - Align = alClient - TabOrder = 1 - OnMouseWheel = ScrollBoxImageMouseWheel - object imagePreview: TImage - Left = 0 - Top = 0 - Width = 100 - Height = 100 - AutoSize = True - end - end -end +object frmThemePreview: TfrmThemePreview + Left = 0 + Top = 0 + BorderIcons = [biSystemMenu] + Caption = 'Theme preview' + ClientHeight = 118 + ClientWidth = 229 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -12 + Font.Name = 'Tahoma' + Font.Style = [] + OnClose = FormClose + OnCreate = FormCreate + OnShow = FormShow + TextHeight = 14 + object StatusBarMain: TStatusBar + Left = 0 + Top = 99 + Width = 229 + Height = 19 + Panels = <> + SimplePanel = True + end + object ScrollBoxImage: TScrollBox + Left = 0 + Top = 0 + Width = 229 + Height = 99 + HorzScrollBar.Tracking = True + VertScrollBar.Tracking = True + Align = alClient + TabOrder = 1 + OnMouseWheel = ScrollBoxImageMouseWheel + object imagePreview: TImage + Left = 0 + Top = 0 + Width = 100 + Height = 100 + AutoSize = True + end + end +end diff --git a/source/theme_preview.pas b/source/theme_preview.pas index 3795d7e96..0ee317f3b 100644 --- a/source/theme_preview.pas +++ b/source/theme_preview.pas @@ -43,8 +43,8 @@ procedure TfrmThemePreview.FormCreate(Sender: TObject); procedure TfrmThemePreview.FormShow(Sender: TObject); begin - Width := AppSettings.ReadInt(asThemePreviewWidth); - Height := AppSettings.ReadInt(asThemePreviewHeight); + Width := AppSettings.ReadIntDpiAware(asThemePreviewWidth, Self); + Height := AppSettings.ReadIntDpiAware(asThemePreviewHeight, Self); Top := AppSettings.ReadInt(asThemePreviewTop); Left := AppSettings.ReadInt(asThemePreviewLeft); ToggleCheckBoxWithoutClick(FToggleCheckbox, True); @@ -53,8 +53,8 @@ procedure TfrmThemePreview.FormShow(Sender: TObject); procedure TfrmThemePreview.FormClose(Sender: TObject; var Action: TCloseAction); begin - AppSettings.WriteInt(asThemePreviewWidth, Width); - AppSettings.WriteInt(asThemePreviewHeight, Height); + AppSettings.WriteIntDpiAware(asThemePreviewWidth, Self, Width); + AppSettings.WriteIntDpiAware(asThemePreviewHeight, Self, Height); AppSettings.WriteInt(asThemePreviewTop, Top); AppSettings.WriteInt(asThemePreviewLeft, Left); ToggleCheckBoxWithoutClick(FToggleCheckbox, False); @@ -107,7 +107,7 @@ procedure TfrmThemePreview.DownloadProgress(Sender: TObject); if FLastStatusUpdate > GetTickCount-200 then Exit; Download := Sender as THttpDownload; - StatusBarMain.SimpleText := f_('Downloading: %s / %s', [FormatByteNumber(Download.BytesRead), FormatByteNumber(Download.ContentLength)]) + ' ...'; + StatusBarMain.SimpleText := f_('Downloading: %s', [FormatByteNumber(Download.BytesRead)]) + ' ...'; FLastStatusUpdate := GetTickCount; end; diff --git a/source/trigger_editor.dfm b/source/trigger_editor.dfm index 9f50e9a11..b29829d3e 100644 --- a/source/trigger_editor.dfm +++ b/source/trigger_editor.dfm @@ -26,6 +26,7 @@ object frmTriggerEditor: TfrmTriggerEditor Align = alTop Images = MainForm.VirtualImageListMain TabOrder = 4 + OnChange = PageControlMainChange object tabOptions: TTabSheet Caption = 'Options' ImageIndex = 39 @@ -67,6 +68,7 @@ object frmTriggerEditor: TfrmTriggerEditor Top = 3 Width = 379 Height = 21 + AutoDropDownWidth = True Anchors = [akLeft, akTop, akRight] TabOrder = 0 Text = 'comboDefiner' @@ -88,6 +90,7 @@ object frmTriggerEditor: TfrmTriggerEditor Top = 30 Width = 599 Height = 21 + AutoDropDownWidth = True Style = csDropDownList Anchors = [akLeft, akTop, akRight] TabOrder = 2 diff --git a/source/trigger_editor.pas b/source/trigger_editor.pas index bd660618b..19d57f8b4 100644 --- a/source/trigger_editor.pas +++ b/source/trigger_editor.pas @@ -3,9 +3,9 @@ interface uses - Windows, SysUtils, Classes, Controls, Forms, Dialogs, StdCtrls, SynEdit, SynMemo, + Winapi.Windows, System.SysUtils, System.Classes, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.Menus, SynEdit, SynMemo, SynCompletionProposal, SynRegExpr, - dbconnection, dbstructures, apphelpers, gnugettext, ComCtrls; + dbconnection, dbstructures, dbstructures.mysql, apphelpers, gnugettext, Vcl.ComCtrls, extra_controls; type TFrame = TDBObjectEditor; @@ -37,6 +37,7 @@ TfrmTriggerEditor = class(TFrame) var CurrentInput: String; var x, y: Integer; var CanExecute: Boolean); procedure comboDefinerDropDown(Sender: TObject); procedure comboChange(Sender: TObject); + procedure PageControlMainChange(Sender: TObject); private { Private declarations } function ComposeCreateStatement: String; @@ -65,8 +66,6 @@ constructor TfrmTriggerEditor.Create(AOwner: TComponent); inherited; SynMemoBody.Highlighter := Mainform.SynSQLSynUsed; editName.MaxLength := NAME_LEN; - comboTiming.Items.Text := 'BEFORE'+CRLF+'AFTER'; - comboEvent.Items.Text := 'INSERT'+CRLF+'UPDATE'+CRLF+'DELETE'; for i:=0 to Mainform.SynCompletionProposal.Columns.Count-1 do begin col := SynCompletionProposalStatement.Columns.Add; col.ColumnWidth := Mainform.SynCompletionProposal.Columns[i].ColumnWidth; @@ -75,9 +74,9 @@ constructor TfrmTriggerEditor.Create(AOwner: TComponent); SynCompletionProposalStatement.Width := Mainform.SynCompletionProposal.Width; SynCompletionProposalStatement.Options := Mainform.SynCompletionProposal.Options; SynCompletionProposalStatement.TimerInterval := Mainform.SynCompletionProposal.TimerInterval; - SynCompletionProposalStatement.ItemHeight := Mainform.SynCompletionProposal.ItemHeight; SynCompletionProposalStatement.Margin := Mainform.SynCompletionProposal.Margin; - SynCompletionProposalStatement.Font := Font; + FMainSynMemo := SynMemoBody; + btnSave.Hint := ShortCutToText(MainForm.actSaveSQL.ShortCut); end; @@ -87,7 +86,7 @@ procedure TfrmTriggerEditor.Init(Obj: TDBObject); DBObjects: TDBObjectList; i: Integer; Found: Boolean; - Body: String; + Body, QuoteCharsRx, QuotedWordRx: String; rx: TRegExpr; begin inherited; @@ -96,7 +95,14 @@ procedure TfrmTriggerEditor.Init(Obj: TDBObject); comboDefiner.TextHint := f_('Current user (%s)', [Obj.Connection.CurrentUserHostCombination]); comboDefiner.Hint := f_('Leave empty for current user (%s)', [Obj.Connection.CurrentUserHostCombination]); SynMemoBody.Text := 'BEGIN'+CRLF+CRLF+'END'; + comboEvent.Items.Text := 'INSERT'+CRLF+'UPDATE'+CRLF+'DELETE'; comboEvent.ItemIndex := 0; + case Obj.Connection.Parameters.NetTypeGroup of + ngSQLite: + comboTiming.Items.Text := 'BEFORE' + sLineBreak + 'AFTER' + sLineBreak + 'INSTEAD OF'; + else + comboTiming.Items.Text := 'BEFORE' + sLineBreak + 'AFTER'; + end; comboTiming.ItemIndex := 0; DBObjects := MainForm.ActiveConnection.GetDBObjects(Mainform.ActiveDatabase); comboTable.Items.Clear; @@ -106,50 +112,44 @@ procedure TfrmTriggerEditor.Init(Obj: TDBObject); end; if comboTable.Items.Count > 0 then comboTable.ItemIndex := 0; - if DBObject.Name <> '' then begin + + if ObjectExists then begin // Edit mode editName.Text := DBObject.Name; - Definitions := MainForm.ActiveConnection.GetResults('SHOW TRIGGERS FROM '+Obj.Connection.QuoteIdent(Mainform.ActiveDatabase)); - Found := False; - while not Definitions.Eof do begin - if Definitions.Col('Trigger') = DBObject.Name then begin - // "Definer" column available since MySQL 5.0.17 - comboDefiner.Text := Definitions.Col('Definer', True); - comboTable.ItemIndex := comboTable.Items.IndexOf(Definitions.Col('Table')); - comboTiming.ItemIndex := comboTiming.Items.IndexOf(UpperCase(Definitions.Col('Timing'))); - comboEvent.ItemIndex := comboEvent.Items.IndexOf(UpperCase(Definitions.Col('Event'))); - // "Statement" column from SHOW TRIGGERS does not escape single quotes where required. - // See http://www.heidisql.com/forum.php?t=16501 - // But SHOW CREATE TRIGGER was introduced in MySQL 5.1.21 - // See http://www.heidisql.com/forum.php?t=16662 - if DBObject.Connection.ServerVersionInt < 50121 then begin - Body := Definitions.Col('Statement'); - end else begin - rx := TRegExpr.Create; - rx.ModifierI := True; - rx.Expression := 'FOR\s+EACH\s+ROW\s+(.+)$'; - try - Body := DBObject.Connection.GetCreateCode(DBObject); - if rx.Exec(Body) then - Body := rx.Match[1] - else - raise EDbError.CreateFmt(_('Result from previous query does not contain expected pattern: %s'), [rx.Expression]); - except - on E:EDbError do begin - DBObject.Connection.Log(lcError, E.Message); - Body := Definitions.Col('Statement'); - end; - end; - end; - SynMemoBody.Text := Body; - Found := True; - break; + + // MariaDB: CREATE DEFINER=`root`@`localhost` TRIGGER `trg` BEFORE INSERT ON `tbl` FOR EACH ROW BEGIN .. END + // SQLite: CREATE TRIGGER "test_delete" AFTER INSERT ON "albums" FOR EACH ROW BEGIN .. END + rx := TRegExpr.Create; + rx.ModifierI := True; + QuoteCharsRx := QuoteRegExprMetaChars(DBObject.Connection.QuoteChars); + QuotedWordRx := '['+QuoteCharsRx+']?[^'+QuoteCharsRx+']+['+QuoteCharsRx+']?'; + rx.Expression := '(\sDEFINER=('+QuotedWordRx+'@'+QuotedWordRx+'))?' + + '\s+TRIGGER\s+(IF\s+NOT\s+EXISTS\s+)?'+QuotedWordRx + + '\s+('+Implode('|', comboTiming.Items)+')' + + '\s+('+Implode('|', comboEvent.Items)+')' + + '\s+ON\s+('+QuotedWordRx+')' + + '\s+FOR\s+EACH\s+ROW\s+(.+)$'; + try + Body := DBObject.Connection.GetCreateCode(DBObject); + if rx.Exec(Body) then begin + comboDefiner.Text := DBObject.Connection.DeQuoteIdent(rx.Match[2], '@'); + comboTiming.ItemIndex := comboTiming.Items.IndexOf(UpperCase(rx.Match[4])); + comboEvent.ItemIndex := comboEvent.Items.IndexOf(UpperCase(rx.Match[5])); + comboTable.ItemIndex := comboTable.Items.IndexOf(DBObject.Connection.DeQuoteIdent(Trim(rx.Match[6]))); + Body := rx.Match[7]; + end + else + raise EDbError.CreateFmt(_('Result from previous query does not contain expected pattern: %s'), [rx.Expression]); + except + on E:EDbError do begin + DBObject.Connection.Log(lcError, E.Message); + Body := ''; end; - Definitions.Next; end; - FreeAndNil(Definitions); - if not Found then - Raise Exception.Create(_('Trigger definition not found!')); + + SynMemoBody.Text := Body; + SynMemoBody.TopLine := FMainSynMemoPreviousTopLine; + end else begin editName.Text := ''; if MainForm.FocusedTables.Count > 0 then begin @@ -162,6 +162,7 @@ procedure TfrmTriggerEditor.Init(Obj: TDBObject); end; end; end; + // Buttons are randomly moved, since VirtualTree update, see #440 btnSave.Top := Height - btnSave.Height - 3; btnHelp.Top := btnSave.Top; @@ -171,6 +172,7 @@ procedure TfrmTriggerEditor.Init(Obj: TDBObject); btnSave.Enabled := Modified; btnDiscard.Enabled := Modified; Mainform.ShowStatusMsg; + TExtForm.PageControlTabHighlight(PageControlMain); Screen.Cursor := crDefault; end; @@ -188,6 +190,11 @@ procedure TfrmTriggerEditor.Modification(Sender: TObject); end; +procedure TfrmTriggerEditor.PageControlMainChange(Sender: TObject); +begin + TExtForm.PageControlTabHighlight(PageControlMain); +end; + procedure TfrmTriggerEditor.btnDiscardClick(Sender: TObject); begin // Reinit editor, discarding changes @@ -205,7 +212,7 @@ procedure TfrmTriggerEditor.btnSaveClick(Sender: TObject); procedure TfrmTriggerEditor.comboChange(Sender: TObject); begin // Auto generate trigger name as long as it was not user-edited. See issue #3477. - if (DBObject.Name = '') and (not editName.Modified) then + if (not ObjectExists) and (not editName.Modified) then editName.Text := comboTable.Text+'_'+LowerCase(comboTiming.Text)+'_'+LowerCase(comboEvent.Text); Modification(Sender); end; @@ -219,6 +226,8 @@ procedure TfrmTriggerEditor.comboDefinerDropDown(Sender: TObject); function TfrmTriggerEditor.ApplyModifications: TModalResult; +var + OldCreateCode: String; begin // Edit mode means we drop the trigger and recreate it, as there is no ALTER TRIGGER. Result := mrOk; @@ -228,7 +237,9 @@ function TfrmTriggerEditor.ApplyModifications: TModalResult; // So, we take the risk of loosing the trigger for cases in which the user has SQL errors in // his statement. The user must fix such errors and re-press "Save" while we have them in memory, // otherwise the trigger attributes are lost forever. - if DBObject.Name <> '' then try + OldCreateCode := ''; + if ObjectExists then try + OldCreateCode := DBObject.CreateCode; DBObject.Connection.Query('DROP TRIGGER '+DBObject.Connection.QuoteIdent(DBObject.Name)); except end; @@ -244,6 +255,8 @@ function TfrmTriggerEditor.ApplyModifications: TModalResult; on E:EDbError do begin ErrorDialog(E.Message); Result := mrAbort; + if not OldCreateCode.IsEmpty then + DBObject.Connection.Query(OldCreateCode); end; end; end; @@ -253,11 +266,13 @@ procedure TfrmTriggerEditor.SynCompletionProposalStatementExecute(Kind: SynCompl var CurrentInput: String; var x, y: Integer; var CanExecute: Boolean); var Proposal: TSynCompletionProposal; - Token: String; + Token, DisplayText: String; Columns: TDBQuery; begin // Propose column names from referencing table Proposal := Sender as TSynCompletionProposal; + Proposal.Font.Assign(Font); + Proposal.ItemHeight := TExtForm.ScaleSize(PROPOSAL_ITEM_HEIGHT, Self); Token := UpperCase(Proposal.PreviousToken); Proposal.InsertList.Clear; Proposal.ItemList.Clear; @@ -267,8 +282,8 @@ procedure TfrmTriggerEditor.SynCompletionProposalStatementExecute(Kind: SynCompl else try Columns := DBObject.Connection.GetResults('SHOW COLUMNS FROM '+DBObject.Connection.QuoteIdent(comboTable.Text)); while not Columns.Eof do begin - Proposal.InsertList.Add(Columns.Col('Field')); - Proposal.ItemList.Add(Format(SYNCOMPLETION_PATTERN, [ICONINDEX_FIELD, GetFirstWord(Columns.Col('Type')), Columns.Col('Field'), '']) ); + DisplayText := SynCompletionProposalPrettyText(ICONINDEX_FIELD, GetFirstWord(Columns.Col('Type')), Columns.Col('Field'), ''); + Proposal.AddItem(DisplayText, Columns.Col('Field')); Columns.Next; end; except @@ -301,3 +316,4 @@ function TfrmTriggerEditor.ComposeCreateStatement: String; end. + diff --git a/source/updatecheck.dfm b/source/updatecheck.dfm index 357b26a11..ff90b5f32 100644 --- a/source/updatecheck.dfm +++ b/source/updatecheck.dfm @@ -2,29 +2,28 @@ object frmUpdateCheck: TfrmUpdateCheck Left = 0 Top = 0 Caption = 'Check for updates ...' - ClientHeight = 415 - ClientWidth = 374 + ClientHeight = 404 + ClientWidth = 360 Color = clBtnFace Constraints.MinHeight = 400 Constraints.MinWidth = 300 Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText - Font.Height = -11 + Font.Height = -12 Font.Name = 'Tahoma' Font.Style = [] - OldCreateOrder = False + Position = poOwnerFormCenter + OnClose = FormClose OnCreate = FormCreate - OnDestroy = FormDestroy OnShow = FormShow DesignSize = ( - 374 - 415) - PixelsPerInch = 96 - TextHeight = 13 + 360 + 404) + TextHeight = 14 object lblStatus: TLabel Left = 8 - Top = 375 - Width = 246 + Top = 364 + Width = 210 Height = 38 Anchors = [akLeft, akRight, akBottom] AutoSize = False @@ -32,1082 +31,9 @@ object frmUpdateCheck: TfrmUpdateCheck Layout = tlCenter WordWrap = True end - object imgDonate: TImage - Left = 0 - Top = 0 - Width = 374 - Height = 70 - Cursor = crHandPoint - Hint = - 'Send an arbitrary amount as donation to the author - per PayPal ' + - '(also supports credit cards)' - Align = alTop - Center = True - Picture.Data = { - 07544269746D617066840000424D66840000000000003600000028000000FA00 - 00002D000000010018000000000030840000C40E0000C40E0000000000000000 - 0000FFFFFFD2E4D92B583D082111071C0E071C0E071C0E071C0E071C0E071C0E - 071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C - 0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E07 - 1C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E - 071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C - 0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E07 - 1C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E - 071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C - 0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E07 - 1C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E - 071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C - 0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E07 - 1C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E - 071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C - 0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E07 - 1C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E - 071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C - 0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E07 - 1C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E - 071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C - 0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E07 - 1C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E - 071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C0E071C - 0E071C0E092413376649E8F1EBFFFFFF70FFC6DDCF0216090000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000072612E8F1EB - 43FF1E4B2F000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000003666484EFF000D050000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000092614 - B4FF000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000000000071C0EB5FF0000000000000000000000000017 - 0900A44100A44100A44100A44100A44100A44100A44100A44100A44100A44100 - A44100A44100A44100A44100A44100A44100A44100A44100A44100A44100A441 - 00A44100A44100A44100A44100A44100A44100A44100A44100A44100A44100A4 - 4100A44100A44100A44100A44100A44100A44100A44100A44100A44100A44100 - A44100A44100A44100A44100A44100A44100A44100A44100A44100A44100A441 - 00A44100A44100A44100A44100A44100A44100A44100A44100A44100A44100A4 - 4100A44100A44100A44100A44100A44100A44100A44100A44100A44100A44100 - A44100A44100A44100A44100A44100A44100A44100A44100A44100A44100A441 - 00A44100A44100A44100A44100A44100A44100A44100A44100A44100A44100A4 - 4100A44100A44100A44100A44100A44100A44100A44100A44100A44100A44100 - A44100A44100A44100A44100A44100A44100A44100A44100A44100A44100A441 - 00A44100A44100A44100A44100A44100A44100A44100A44100A44100A44100A4 - 4100A44100A44100A44100A44100A44100A44100A44100A44100A44100A44100 - A44100A44100A44100A44100A44100A44100A44100A44100A44100A44100A441 - 00A44100A44100A44100A44100A44100A44100A44100A44100A44100A44100A4 - 4100A44100A44100A44100A44100A44100A44100A44100A44100A44100A44100 - A44100A44100A44100A44100A44100A44100A44100A44100A44100A44100A441 - 00A44100A44100A44100A44100A44100A44100A44100A44100A44100A44100A4 - 4100A44100A44100A44100A44100A44100A44100A44100A44100A44100A44100 - A44100A44100A44100A44100A44100A44100A44100A44100A44100A44100A441 - 00A44100A44100A44100A44100A44100A44100A44100A44100A44100A44100A4 - 4100A44100A44100A44100A44100A44100A44100A44100A44100A44100A44100 - A44100A44100A44100A44100A44100A13F000000000000000000000000071C0E - 43FF00000000000000000000000000170900A44200A44200A44200A44200A442 - 00A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200A4 - 4200A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200 - A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200A442 - 00A44200A4429EDCB73AB86C00A44200A44200A44236B76AA3DEBA00A44200A4 - 4200A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200 - A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200A442 - 00A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200A4 - 4200A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200 - A44214AB508CD5A9B3E3C69BDBB42EB46400A44200A44200A44200A44200A442 - 00A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200A4 - 4200A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200 - A44200A44200A44200A44200A44200A44200A44200A44200A44200A44207A647 - 01A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200A4 - 4200A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200 - A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200A442 - 00A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200A4 - 4200A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200 - A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200A442 - 00A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200A4 - 4200A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200 - A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200A442 - 00A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200A1 - 40000000000000000000000000071C0F44FF0000000000000000000000000017 - 0900A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200 - A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200A442 - 00A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200A4 - 4200A44200A44200A44200A44200A44200A44200A442E6F6EC58C38300A44200 - A44200A44253C17FECF8F000A44200A44200A44200A44200A44200A44200A442 - 00A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200A4 - 4200A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200 - A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200A442 - 00A44200A44200A44200A44200A44200A44276CE99D3EFDE20AF5979CF9BE2F4 - E902A44300A44200A44200A44200A44200A44200A44200A44200A44200A44200 - A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200A442 - 00A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200A4 - 4200A44200A44201A4426DCA92EBF7F017AC5300A44200A44200A44200A44200 - A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200A442 - 00A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200A4 - 4200A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200 - A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200A442 - 00A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200A4 - 4200A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200 - A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200A442 - 00A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200A4 - 4200A44200A44200A44200A44200A44200A44200A44200A44200A44200A44200 - A44200A44200A44200A44200A44200A140000000000000000000000000071C0F - 44FF00000000000000000000000000170900A54200A54200A54200A54200A542 - 00A54200A54200A54200A54200A54200A54200A54200A54200A54200A54200A5 - 4200A54200A54200A54200A54200A54200A54200A54200A54200A54200A54200 - A54200A54255C381D7F0E1E7F6EDA2DEBA0DA94B18AD53CAECD7DEF3E67ED19F - A1DDB900A542E6F6ECB7E5C9E6F6ECB5E4C80EA94C53C27FF3FAF6B5E4C8E5F5 - EB69CA8F00A54245BD75D2EFDDEAF7EFA9E0BF11AB4E24B15CC0E8D00BA84A00 - A54211AB4EC9EBD6E3F5EA19AD5400A54200A54275CE987AD09C00A5427DD19E - 71CC9500A54286D4A568C98F1DAF57CAECD7E0F4E897DAB184D3A30AA849C2E9 - D122B15B4DC07BBDE7CE17AD53C3E9D21EAF5865C88C8AD5A800A5425FC68890 - D7AC2AB361F1FAF4A1DDB9CCEDD9D6F0E001A54200A54200A5427FD1A07DD19E - 00A54200A542AFE2C34EC07B02A54391D8ADE5F5EBE3F5EA80D2A000A542BDE7 - CE31B6661CAE56C7EBD5E2F4E988D5A6A5DFBC00A542ACE1C143BC7354C280D7 - F0E1E8F6EDA2DEBA0EA94C01A54275CE98D9F1E2EBF7F0CEEDDAE7F6ED49BE78 - 2AB361C5EAD4C5EAD4C5EAD440BB7100A54200A54275CE9893D8AED7F0E1D5F0 - DF33B76700A54279CF9BE0F4E8E7F6ED9BDBB400A54257C382E6F6EC98DAB22F - B564DCF2E5C7EBD506A7469ADBB4E7F6EDE1F4E874CD9707A747C2E9D126B25E - 00A54200A54200A5420CA94AB9E6CBE6F6EC97DAB1A0DDB801A542AFE2C33EBA - 6F00A542A9E0BF46BD7510AA4DBBE7CCE6F6EC89D5A7B8E5CA00A54200A54200 - A54254C2809BDBB4C8EBD6E0F4E851C17E00A5425AC484D8F1E2EBF7F0B9E6CB - 06A74636B86ADEF3E6C0E8D016AC52CDEDD9DFF3E710AA4D7DD19EE1F4E8E6F6 - EC97DAB100A542A7DFBD47BE7600A54200A54200A54200A54200A54200A54200 - A54200A54200A54200A54200A54200A54200A54200A54200A54200A54200A542 - 00A54200A54200A54200A54200A54200A54200A54200A54200A54200A54200A2 - 40000000000000000000000000071C0F44FF0000000000000000000000000018 - 0900A64200A64200A64200A64200A64200A64200A64200A64200A64200A64200 - A64200A64200A64200A64200A64200A64200A64200A64200A64200A64200A642 - 00A64200A64200A64200A64200A64200A64200A64264C88C4BC07940BC71E8F6 - ED7ED19F6DCC92ECF8F043BD73C6EBD4D5F0DF00A642E6F6ECB4E4C744BD74EE - F9F272CD9653C27FFCFDFC64C88C86D4A5F6FBF811AB4EE3F5EA8BD6A915AD51 - CDEDD98DD7AA32B767FBFDFC10AB4D00A6424ABF78FBFDFC42BD720AA94900A6 - 4200A6429CDCB5A3DEBA00A642A7E0BD98DBB200A642B2E4C58BD6A96ACA90DE - F3E614AC50B6E5C8AFE3C30FAB4DFFFFFF42BD72E5F5EB7FD2A014AC50FFFFFF - 2BB56187D5A6B7E5C900A64280D2A0BFE8CF43BD73E9F7EE7BD09D56C48110AB - 4D00A64200A64200A642ABE1C0A9E0BF00A64200A642E8F6ED6CCB924FC17CF2 - FAF52AB46113AC5033B76700A642FAFDFB45BE758BD6A9DDF3E53EBB6FC2E9D1 - DAF2E300A642E3F5EA5CC68663C88B4BC07940BC71E8F6ED7ED19F54C380FEFE - FE70CD9536B86A9EDDB7F1FAF419AE543DBB6FFEFEFE6ACA905AC5841BAF5600 - A64200A6429ADBB4E1F4E845BE75BEE8CEBDE7CE2EB664FBFDFC41BC720FAB4D - 38B96B00A642B3E4C6B2E4C52AB4617ED19FDBF2E436B86A5EC687EAF7EF24B2 - 5C15AD5130B6650AA949FFFFFF36B86A00A64200A64200A64245BE75F5FBF71D - B05797DAB1D4EFDF02A643E6F6EC55C38100A642DFF3E75FC78872CD96ECF8F0 - 42BD72B1E3C5F3FAF600A64200A64200A64271CD95F4FBF653C27F9DDCB6E3F5 - EA13AC50F4FBF667C98E0CAA4A39B96C04A74488D5A6D3EFDE34B86853C27FF5 - FBF741BC723ABA6CFCFDFC3BBA6D0FAB4D37B96A00A642DCF2E561C78900A642 - 00A64200A64200A64200A64200A64200A64200A64200A64200A64200A64200A6 - 4200A64200A64200A64200A64200A64200A64200A64200A64200A64200A64200 - A64200A64200A64200A64200A64200A340000000000000000000000000071C0F - 44FF00000000000000000000000000180900A64200A64200A64200A64200A642 - 00A64200A64200A64200A64200A64200A64200A64200A64200A64200A64200A6 - 4200A64200A64200A64200A64200A64200A64200A64200A64200A64200A64200 - A64200A64200A64201A64239B96CECF8F08ED7AB7DD19ECDEDD900A64273CE97 - D5F0DF00A642E6F6EC58C48300A642B7E5C99BDCB453C27FECF8F000A64223B2 - 5BFFFFFF42BD72FDFEFD45BE7500A6428DD7AABDE7CE32B767FBFDFC10AB4D00 - A64250C17DF5FBF704A74400A64200A64200A6429CDCB5A3DEBA00A642A7E0BD - 98DBB200A642B2E4C58BD6A926B35EDCF2E5B9E6CBDBF2E4AFE3C30FAB4DFFFF - FFCAECD7CFEEDB07A84714AC50FFFFFF2BB56187D5A6B7E5C900A64280D2A0BF - E8CF0EAA4CF3FAF6B7E5C9E5F5EB39B96C00A64200A64200A642ABE1C0ACE2C1 - 08A84708A847E9F7EE6CCB9276CF99F1FAF4ADE2C2ADE2C29CDCB502A643FAFD - FB45BE75ABE1C09FDDB700A6426FCC94DAF2E300A642E3F5EA5CC68600A64201 - A64238B96BECF8F08FD7AB9DDCB6CDEDD900A64200A6420CAA4AF4FBF666C98D - 3DBB6FFDFEFD18AE5300A64200A64200A64200A6429ADBB4A3DEBA00A6426BCB - 91E7F6ED55C381FBFDFCAEE2C2ADE2C2AAE1C00AA949B9E6CB8FD7AB00A64287 - D5A6C0E9D000A64285D4A4ECF8F0ADE2C2ADE2C294D9AF0AA949FFFFFF36B86A - 00A64200A64200A64212AC4FCDEDD9C3EAD2CFEEDBD4EFDF02A643E6F6EC55C3 - 8100A642DFF3E75FC78892D8AEB8E6CA00A64256C481F3FAF600A64200A64200 - A64271CD95CEEDDA00A64240BC71FEFEFE3FBB70FFFFFFB7E5C9ADE2C2ACE2C1 - 26B35E8ED7ABBAE6CB00A6425DC686EDF8F100A6425AC584F9FCFAADE2C2ADE2 - C2A8E0BE0AA949DCF2E561C78900A64200A64200A64200A64200A64200A64200 - A64200A64200A64200A64200A64200A64200A64200A64200A64200A64200A642 - 00A64200A64200A64200A64200A64200A64200A64200A64200A64200A64200A3 - 40000000000000000000000000071C0F5CFF0000000000000000000000000018 - 0900A64300A64300A64300A64300A64300A64300A64300A64300A64300A64300 - A64300A64300A64300A64300A64300A64300A64300A64300A64300A64300A643 - 00A64300A64300A64300A64300A64300A64300A64311AB4FB5E5C8FEFEFECCED - D91DB0587DD19FCDEDDA00A64373CE97D5F0E000A643E6F6EC86D4A508A848D7 - F1E18CD6AA53C280F6FBF824B25D49BF78FFFFFF24B25DEDF8F166C98E00A643 - ADE2C2ADE2C232B767FEFEFE49BF7804A74550C17DF5FBF704A74500A64300A6 - 4300A6439CDCB6C7EBD509A949BFE8CFBDE7CE09A949CAECD789D5A806A84716 - AD531CAF57A4DFBBADE2C20FAB4EFFFFFFA8E0BED1EEDD11AB4F14AC51FFFFFF - 2BB56287D5A6D6F0E00EAA4D9ADBB4BBE7CC2EB664EBF8F004A74599DBB382D3 - A200A64300A64300A643ABE1C1FFFFFFFFFFFFFFFFFFFFFFFF6CCB9259C584E9 - F7EE25B25E6DCC93E4F5EB02A644FAFDFB45BE7597DAB2C5EAD406A84796DAB1 - DAF2E300A643E3F5EA5CC68611AB4FB4E4C7FEFEFECCEDD91DB058ADE2C2B9E6 - CB00A64300A64300A643E2F4E97ED19F3DBB6FFDFEFD18AE5400A64300A64300 - A64300A6439ADBB4C7EBD50AA94A93D9AFD6F0E038B96CF9FCFA32B76751C27E - FBFDFC0CAA4BB9E6CB8FD7AC00A64387D5A6C0E9D000A64368CA8FDEF3E624B2 - 5D7AD09CD7F1E10AA94AFFFFFF71CD9604A74500A64300A64301A64319AE5518 - AE5484D4A4D2EFDD02A644E6F6EC82D3A20CAA4BEFF9F35CC6867ED19FDAF2E3 - 0AA94A7DD19FF3FAF600A64300A64300A64371CD96E6F6EC16AD5368CA8FF5FB - F71FB059F9FCFA51C27E2FB665FBFDFC33B7688ED7ABBAE6CC00A6435DC687ED - F8F100A6433EBB70F9FCFA2DB56455C381F6FBF80CAA4BDCF2E59BDCB505A746 - 00A64300A64300A64300A64300A64300A64300A64300A64300A64300A64300A6 - 4300A64300A64300A64300A64300A64300A64300A64300A64300A64300A64300 - A64300A64300A64300A64300A64300A341000000000000000000000000071C0F - A5FF00000000000000000000000000180900A74300A74300A74300A74300A743 - 00A74300A74300A74300A74300A74300A74300A74300A74300A74300A74300A7 - 4300A74300A74300A74300A74300A74300A74300A74300A74300A74300A74300 - A74300A7437AD19CF2FAF550C27D03A84500A74379D09CCAECD700A74370CD95 - D2EFDD00A743E3F5EAC5EAD4EEF9F2F3FAF630B76650C27DDBF2E4DFF3E7F7FC - F9B7E6C902A74467CA8EEEF9F2C8ECD6EFF9F33FBC7130B766ECF8F0DCF2E5AA - E1C0E6F6ECFEFEFEE6F6EC1DB15800A74300A7439ADCB4CCEDD9EBF8F0FBFDFC - A8E0BEECF8F0FBFDFC46BF761DB158DFF3E7C2E9D2F3FAF668CA8F0FAC4EFFFF - FF33B868B1E4C5B6E5C914AD51FDFEFD29B56185D4A5D0EEDCE8F7EEFCFDFC73 - CE9709AA49D1EFDDA8E0BEEBF8F0EBF8F00BAA4B00A74300A743ABE2C1B1E4C5 - 19AF5519AF55EAF7EF6CCC920AAA4AC9ECD7D2EFDDE9F7EE7AD19C00A743F7FC - F942BD7333B868F2FAF5EEF9F2E9F7EEDAF2E300A743E0F4E859C5847AD19CF3 - FAF64FC27D03A84500A74390D8ADD7F1E101A74300A7430DAB4CF5FBF76BCB91 - 3DBC6FFDFEFD18AF5400A74300A74300A74300A7439ADCB4E6F6ECEAF7EFFCFD - FC70CD9502A744AFE3C4DAF2E3E2F4E999DBB363C98BF8FCF9F4FBF6E6F6ECF3 - FAF6F9FCFAD1EFDD10AC4ED1EFDDCFEEDBEBF8F06CCC9209AA49F8FCF9D1EFDD - C5EAD400A74300A74307A948D5F0E0C4EAD3ECF8F08CD7AA02A744E4F5EBC6EB - D4EFF9F3F1FAF421B25B21B25BEAF7EFEFF9F3E8F7EEF3FAF600A74300A74300 - A74371CD96EEF9F2E6F6ECFAFDFB9ADCB400A74388D5A7E4F5EBD7F1E1BFE8CF - 41BD72F4FBF6F8FCF9E6F6ECEFF9F3FDFEFDE5F6EB16AE53B3E4C6D9F1E2E3F5 - EA94DAB000A743DAF2E3CFEEDBE7F6ED07A94800A74300A74300A74300A74300 - A74300A74300A74300A74300A74300A74300A74300A74300A74300A74300A743 - 00A74300A74300A74300A74300A74300A74300A74300A74300A74300A74300A4 - 41000000000000000000000000071C0F74FF0000000000000000000000000018 - 0900A74300A74300A74300A74300A74300A74300A74300A74300A74300A74300 - A74300A74300A74300A74300A74300A74300A74300A74300A74300A74300A743 - 00A74300A74300A74300A74300A74300A74300A74374CF98E6F6EC2DB66458C5 - 8320B25A06A9470BAA4B00A74305A8460CAB4B00A7430DAB4C03A8452DB66419 - AF5500A74304A8450BAA4B0FAC4E33B86806A94700A74300A74319AF5537B96B - 11AC4F00A74302A7440DAB4C15AE5220B25A5AC685F6FBF814AD5101A74300A7 - 4300A74308A94806A94720B25A24B35D00A74323B35C22B25C00A74300A7430C - AB4B35B96A22B25C00A7430FAC4EFFFFFF30B76604A8450EAB4D05A84653C380 - 09AA4907A94807A9481BB0562BB56201A74300A74308A94834B86919AF5510AC - 4E00A74300A74300A743ABE2C1A9E1BF00A74300A743E8F7EE6CCC9200A74305 - A84630B76622B25C00A74301A7434FC27D11AC4F00A74316AE532FB76571CD96 - DAF2E300A74348BF7818AF5473CE97E6F6EC2CB66357C58320B25A31B767F9FC - FA95DAB04EC17CA9E1BFF4FBF61FB1593DBC6FFDFEFD18AF5400A74300A74300 - A74300A7439ADCB4A3DFBB20B25A29B56101A74300A74302A7442BB56229B561 - 02A74406A947BEE8CF96DAB110AC4E8ED8ABC4EAD30EAB4D00A74306A94732B8 - 671FB15900A74300A7430EAB4D0CAB4B28B46000A74300A74300A74307A94831 - B76729B56102A74400A7430DAB4C03A8452EB66416AE5300A74300A74311AC4F - 32B8675AC685F3FAF600A74300A74300A74371CD96CEEEDA16AE5330B76603A8 - 4500A74301A74323B35C30B76605A84604A84595DAB0BFE8CF10AC4E68CA8FEE - F9F210AC4E01A74303A8452CB66328B46001A74300A7430DAB4C07A9482FB765 - 00A74300A74300A74300A74300A74300A74300A74300A74300A74300A74300A7 - 4300A74300A74300A74300A74300A74300A74300A74300A74300A74300A74300 - A74300A74300A74300A74300A74300A441000000000000000000000000071C0F - 44FF00000000000000000000000000180900A84300A84300A84300A84300A843 - 00A84300A84300A84300A84300A84300A84300A84300A84300A84300A84300A8 - 4300A84300A84300A84300A84300A84300A84300A84300A84300A84300A84300 - A84300A8430BAB4B96DBB1D1EFDDB0E4C416AF5300A84300A84300A84300A843 - 00A84300A84300A84300A84300A84300A84300A84300A84300A84300A84300A8 - 4300A84300A84300A84300A84300A84300A84300A84300A84300A84300A84300 - A84317AF5352C37F01A84300A84300A84300A84300A84300A84300A84300A843 - 00A84300A84300A84300A84300A84300A84300A84300A84300A8430FAD4EFFFF - FF30B86600A84300A84324B45DF8FCF933B96800A84300A84300A84300A84300 - A84300A84300A84300A84300A84300A84300A84300A84300A8436FCD946DCD93 - 00A84300A84398DBB344BF7500A84300A84300A84300A84300A8430FAD4EF4FB - F64DC27B00A84300A84300A8436ECD94DAF2E306AA47E7F6ED63C98B0BAB4B95 - DAB0D2EFDDB0E4C416AF5300A84341BE72B5E5C8D4F0DFB3E5C63DBC6F00A843 - 25B45EA8E1BE0EAC4D00A84300A84300A84300A8439ADCB4A3DFBB00A84300A8 - 4300A84300A84300A84300A84300A84300A84300A8433CBC6F2DB76400A84354 - C4807DD29F00A84300A84300A84300A84300A84300A84300A84300A84300A843 - 00A84300A84300A84300A84300A84300A84300A84300A84300A84300A84300A8 - 4300A84300A84300A84300A84300A84300A84355C581F3FAF600A84300A84300 - A84371CE96CEEEDA00A84300A84300A84300A84300A84300A84300A84300A843 - 00A8432DB7643CBC6F00A84338BB6C9BDCB500A84300A84300A84300A84300A8 - 4300A84300A84300A84300A84300A84300A84300A84300A84300A84300A84300 - A84300A84300A84300A84300A84300A84300A84300A84300A84300A84300A843 - 00A84300A84300A84300A84300A84300A84300A84300A84300A84300A84300A5 - 41000000000000000000000000071D0FD3FF0000000000000000000000000018 - 0900A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400 - A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A944 - 00A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A9 - 4400A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400 - A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A944 - 00A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A9 - 4400A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400 - A94400A94400A94400A94401A94425B55F04AA4600A94400A94400A94400A944 - 00A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A9 - 4400A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400 - A94400A94400A94400A94400A94400A94400A94400A94400A94400A9440CAD4C - 1DB25900A94400A94400A94400A94400A94400A94400A94400A94400A94400A9 - 4400A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400 - A94400A94414AF5216B05400A94400A94400A94400A94400A94400A94400A944 - 00A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A9 - 4400A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400 - A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A944 - 00A94408AB4921B45C00A94400A94400A9440DAD4D1CB25800A94400A94400A9 - 4400A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400 - A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A944 - 00A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A9 - 4400A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400 - A94400A94400A94400A94400A94400A642000000000000000000000000071D0F - FFFF00000000000000000000000000180900A94400A94400A94400A94400A944 - 00A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A9 - 4400A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400 - A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A944 - 00A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A9 - 4400A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400 - A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A944 - 00A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A9 - 4400A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400 - A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A944 - 00A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A9 - 4400A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400 - A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A944 - 00A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A9 - 4400A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400 - A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A944 - 00A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A9 - 4400A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400 - A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A944 - 00A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A9 - 4400A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400 - A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A944 - 00A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A6 - 42000000000000000000000000071D0F75FF0000000000000000000000000018 - 0900A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400 - A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A944 - 00A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A9 - 4400A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400 - A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A944 - 00A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A9 - 4400A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400 - A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A944 - 00A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A9 - 4400A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400 - A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A944 - 00A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A9 - 4400A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400 - A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A944 - 00A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A9 - 4400A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400 - A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A944 - 00A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A9 - 4400A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400 - A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A944 - 00A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400A9 - 4400A94400A94400A94400A94400A94400A94400A94400A94400A94400A94400 - A94400A94400A94400A94400A94400A642000000000000000000000000071D0F - 45FF00000000000000000000000000180900AA4400AA4400AA4400AA4400AA44 - 00AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA - 4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400 - AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA44 - 00AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA - 4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400 - AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA44 - 00AA4400AA4400AA4403AB461FB45A21B55C21B55C21B55C21B55C21B55C16B1 - 5406AC4800AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400 - AA4400AA4400AA4400AA4402AA4531BA675EC98872D0976DCE9351C57F1BB357 - 00AA4400AA4400AA4400AA4400AA4400AA4400AA4415B15344C07549C2792CB8 - 6400AA4400AA4400AA4400AA4400AA440FAF4F41BF734AC27A32BA6801AA4400 - AA4400AA4400AA4400AA4409AD4A46C1776DCE936ECE9448C2780AAD4B00AA44 - 1BB35748C27844C0750EAE4E00AA4400AA4400AA4400AA4400AA4406AC4844C0 - 756DCE936FCF954EC47D10AF5004AB4708AC490CAE4C0EAE4E10AF4F16B15447 - C1776DCE937FD4A17ED4A06ACD9248C27925B55E20B45B20B45B21B55C23B55D - 23B55D23B55D23B55D23B55D23B55D23B55D22B55C20B45B20B45B20B45B1FB4 - 5A1EB45A1CB3581AB25718B25516B15414B05212B05110AF4F0EAE4E0AAD4B06 - AC4905AB4702AA4500AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA44 - 00AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA - 4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400 - AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA44 - 00AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400A7 - 42000000000000000000000000071D0F45FF0000000000000000000000000018 - 0900AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400 - AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA44 - 00AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA - 4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400 - AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA44 - 00AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA - 4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA449ADDB4FFFFFFFF - FFFFFFFFFFFFFFFFFFFFFFFFFFFFFCFEFCF6FCF8D3F0DE95DBB13CBE7000AA44 - 00AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4458C784DAF2E3FFFF - FFFFFFFFFFFFFFFFFFFFFFFFFFFCFEFCB3E5C729B76200AA4400AA4400AA4400 - AA4400AA44B5E6C8FFFFFFFFFFFFFDFEFD18B25500AA4400AA4400AA4400AA44 - 99DDB4FFFFFFFFFFFFFFFFFF32BA6800AA4400AA4400AA4452C580E7F7EDFFFF - FFFFFFFFFFFFFFFFFFFFE9F7EE5FC989AEE3C3FFFFFFFFFFFF85D6A519B2561E - B45A23B55D28B7614DC37CE0F4E8FFFFFFFFFFFFFFFFFFFFFFFFDDF3E642BF74 - 42C07442C07444C07698DCB3EDF9F1FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF - FFF2FAF5B4E6C847C17742C07442C07442C07442C07442C07442C07442C07442 - C07442C07442C07442C07442C07442C07442C07442C07442C07442C07442C074 - 42C07442C07442C07442C07442C07442C07441BF7340BF723EBE713BBD6F37BC - 6C34BB6A30BA672BB86326B65F21B55C1CB35817B15412B0510DAE4D07AC4902 - AA4500AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA44 - 00AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA - 4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400AA4400 - AA4400AA4400AA4400AA4400AA4400A742000000000000000000000000071D0F - EEFF00000000000000000000000000180900AB4400AB4400AB4400AB4400AB44 - 00AB4400AB4400AB4400AB4400AB4400AB4400AB4400AB4400AB4400AB4400AB - 4400AB4400AB4400AB4400AB4400AB4400AB4400AB4400AB4400AB4400AB4400 - AB4400AB4400AB4400AB4400AB4400AB4400AB4400AB4400AB4400AB4400AB44 - 00AB4400AB4400AB4400AB4400AB4400AB4400AB4400AB4400AB4400AB4400AB - 4400AB4400AB4400AB4400AB4400AB4400AB4400AB4400AB4400AB4400AB4400 - AB4400AB4400AB4400AB4400AB4400AB4400AB4400AB4400AB4400AB4400AB44 - 00AB4400AB4400AB44C4EBD3FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF - FFFFFFFFFFFFFFFFFFFFFFFFFFBCE8CD21B55C00AB4400AB4400AB4400AB4400 - AB4400AB4481D5A2FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF - FFFFFFF3FBF644C17500AB4400AB4400AB4400AB44BBE8CDFFFFFFFFFFFFFEFE - FE1CB45800AB4400AB4400AB4400AB449FDFB8FFFFFFFFFFFFFFFFFF36BC6B01 - AB4403AB4641C073FAFDFBFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF - F4FBF7FFFFFFFFFFFFA0DFB942C07442C07442C07443C075D6F1E1FFFFFFFFFF - FFFFFFFFFFFFFFFFFFFFF6FCF848C27842C07444C075C2EAD2FFFFFFFFFFFFFF - FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF6ACD9142C07442C074 - 42C07442C07442C07442C07442C07442C07442C07442C07442C07442C07442C0 - 7442C07442C07442C07442C07442C07442C07442C07442C07442C07442C07442 - C07442C07442C07442C07442C07442C07442C07442C07442C07442C07442C074 - 42C07442C07442C07442C07442C07442C0743DBF7037BD6C30BA672AB86223B6 - 5D1DB45917B2540FAF4F07AD4901AB4500AB4400AB4400AB4400AB4400AB4400 - AB4400AB4400AB4400AB4400AB4400AB4400AB4400AB4400AB4400AB4400AB44 - 00AB4400AB4400AB4400AB4400AB4400AB4400AB4400AB4400AB4400AB4400A8 - 42000000000000000000000000071D0F75FF0000000000000000000000000018 - 0A00AB4500AB4500AB4500AB4500AB4500AB4500AB4500AB4500AB4500AB4500 - AB4500AB4500AB4500AB4500AB4500AB4500AB4500AB4500AB4500AB4500AB45 - 00AB4500AB4500AB4500AB4500AB4500AB4500AB4500AB4500AB4500AB4500AB - 4500AB4500AB4500AB4500AB4500AB4500AB4500AB4500AB4500AB4500AB4500 - AB4500AB4500AB4500AB4500AB4500AB4500AB4500AB4500AB4500AB4500AB45 - 00AB4500AB4500AB4500AB4500AB4500AB4500AB4500AB4500AB4500AB4500AB - 4500AB4500AB4500AB4500AB4500AB4500AB4500AB4500AB45C4EBD3FFFFFFFF - FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF - E8F7EE2DB96500AB4500AB4500AB4500AB453FBF72FDFEFDFFFFFFFFFFFFFFFF - FFE1F5E9A4E1BCA6E1BEE6F6ECFFFFFFFFFFFFFFFFFFECF8F11AB35700AB4500 - AB4500AB45BBE8CDFFFFFFFFFFFFFEFEFE1CB45900AB4500AB4502AB4709AD4B - A6E1BDFFFFFFFFFFFFFFFFFF5ECA893BBE7041C074C2EAD2FFFFFFFFFFFFFFFF - FFC7ECD67FD4A187D7A7D4F0E0FFFFFFFFFFFFFFFFFFFFFFFFA0DFB942C07542 - C07542C0755EC989FFFFFFFFFFFFFFFFFFFFFFFFE4F6EBDCF3E6EDF9F245C177 - 42C07592DAAFFFFFFFFFFFFFFFFFFFFCFEFDC9EDD89EDEB897DCB3A6E1BECBED - D9F6FCF9FFFFFF6CCE9342C07542C07542C07542C07542C07542C07542C07542 - C07542C07542C07542C07542C07542C07542C07542C07542C07542C07542C075 - 42C07542C07542C07542C07542C07542C07542C07542C07542C07542C07542C0 - 7542C07542C07542C07542C07542C07542C07542C07542C07542C07542C07542 - C07542C07542C07542C07542C07542C07542C07542C07542C07542C0753FBF72 - 39BD6E31BB6829B86221B55D19B35710B05006AC4901AB4500AB4500AB4500AB - 4500AB4500AB4500AB4500AB4500AB4500AB4500AB4500AB4500AB4500AB4500 - AB4500AB4500AB4500AB4500AB4500A843000000000000000000000000071D0F - 46FF00000000000000000000000000180A00AC4500AC4500AC4500AC4500AC45 - 00AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC - 4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500 - AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC45 - 00AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC - 4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500 - AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC45 - 00AC4500AC4500AC45C4EBD3FFFFFFFFFFFFFFFFFF43C17519B45719B4572BB9 - 645AC986B8E7CBFEFEFEFFFFFFFFFFFFFFFFFFDAF2E40CAF4D00AC4500AC4500 - AC45B3E6C7FFFFFFFFFFFFFFFFFFAFE4C409AE4B00AC4500AC450CAF4DB8E7CB - FFFFFFFFFFFFFFFFFF8EDAAC00AC4500AC4500AC45BBE8CDFFFFFFFFFFFFFEFE - FE3DBF712FBB6738BE6D3FC07242C175B7E7CBFFFFFFFFFFFFFFFFFF6ACE9242 - C17542C175E3F6EAFFFFFFFFFFFFF0FAF447C27842C17542C17545C277BAE8CC - FFFFFFFFFFFFFFFFFFA0DFB942C17542C17542C1757BD39EFFFFFFFFFFFFFFFF - FFCEEFDB44C17642C1754DC47D42C17542C175E6F6EDFFFFFFFFFFFFFDFEFD81 - D5A342C17542C17542C17542C17542C1754DC47D83D6A44AC37B42C17542C175 - 42C17542C17542C17542C17542C17542C17542C17542C17542C17542C17542C1 - 7542C17542C17542C17542C17542C17542C17542C17542C17542C17542C17542 - C17542C17542C17542C17542C17542C17542C17542C17542C17542C17542C175 - 42C17542C17542C17542C17542C17542C17542C17542C17542C17542C17542C1 - 7542C17542C17542C17542C17542C17542C17542C17542C17542C17542C17542 - C17542C1753DBF7135BD6B2CBA6522B75D19B4570FB04F05AD4800AC4500AC45 - 00AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500A9 - 43000000000000000000000000071D0F46FF0000000000000000000000000018 - 0A00AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500 - AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC45 - 00AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC - 4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500 - AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC45 - 00AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC - 4500AC4500AC4500AC4500AC4500AC4500AC4500AC4500AC45C4EBD3FFFFFFFF - FFFFFFFFFF2FBB6700AC4500AC4500AC4500AC4501AC4565CC8EFDFEFDFFFFFF - FFFFFFFFFFFF79D39D00AC4500AC4509AE4BF4FBF6FFFFFFFFFFFFFCFEFC1DB5 - 5A00AC4500AC4500AC4500AC4520B65CFCFEFCFFFFFFFFFFFFE5F6EC20B55B29 - B96234BC6ACBEED9FFFFFFFFFFFFFEFEFE56C78442C17542C17542C17542C175 - B7E7CBFFFFFFFFFFFFFFFFFF6ACE9242C17542C175E2F5E9FFFFFFFFFFFFEBF8 - F043C17642C17542C17542C17571D097FFFFFFFFFFFFFFFFFFA0DFB942C17542 - C17542C17584D6A5FFFFFFFFFFFFFFFFFF9EDFB842C17542C17542C17542C175 - 5FCA8AFEFEFEFFFFFFFFFFFFCEEEDB42C17542C17542C17542C17542C17542C1 - 7542C17542C17542C17542C17542C17542C17542C17542C17542C17542C17542 - C17542C17542C17542C17542C17542C17542C17542C17542C17542C17542C175 - 42C17542C17542C17542C17542C17542C17542C17542C17542C17542C17542C1 - 7542C17542C17542C17542C17542C17542C17542C17542C17542C17542C17542 - C17542C17542C17542C17542C17542C17542C17542C17542C17542C17542C175 - 42C17542C17542C17542C17542C17542C17542C17542C17542C17542C17542C1 - 7542C17542C17541C1743BBF7030BB6825B85F1AB4570FB04F04AD4800AC4500 - AC4500AC4500AC4500AC4500AC4500A943000000000000000000000000071D0F - 75FF00000000000000000000000000190A00AD4500AD4500AD4500AD4500AD45 - 00AD4500AD4500AD4500AD4500AD4500AD4500AD4500AD4500AD4500AD4500AD - 4500AD4500AD4500AD4500AD4500AD4500AD4500AD4500AD4500AD4500AD4500 - AD4500AD4500AD4500AD4500AD4500AD4500AD4500AD4500AD4500AD4500AD45 - 00AD4500AD4500AD4500AD4500AD4500AD4500AD4500AD4500AD4500AD4500AD - 4500AD4500AD4500AD4500AD4500AD4500AD4500AD4500AD4500AD4500AD4500 - AD4500AD4500AD4500AD4500AD4500AD4500AD4500AD4500AD4500AD4500AD45 - 00AD4500AD4500AD45C4ECD3FFFFFFFFFFFFFFFFFF2FBC6700AD4500AD4500AD - 4500AD4500AD4500AD4593DCB0FFFFFFFFFFFFFFFFFFDFF4E703AD4700AD4528 - B962FFFFFFFFFFFFFFFFFFD2F0DE00AD4500AD4501AD450CB04D18B45625B85F - D9F2E3FFFFFFFFFFFFFFFFFF58C98542C27542C275CCEEDAFFFFFFFFFFFFFEFE - FE56C88442C27542C27542C27542C275B7E8CBFFFFFFFFFFFFFFFFFF6ACE9242 - C27542C275B9E8CCFFFFFFFFFFFFFFFFFFA3E1BC4AC47B42C27542C27571D197 - FFFFFFFFFFFFFFFFFFA0E0B942C27542C27542C27587D8A7FFFFFFFFFFFFFFFF - FF9ADEB542C27542C27542C27542C2757DD5A0FFFFFFFFFFFFFFFFFFA4E1BC42 - C27542C27542C27542C27542C27542C27542C27542C27542C27542C27542C275 - 42C27542C27542C27542C27542C27542C27542C27542C27542C27542C27542C2 - 7542C27542C27542C27542C27542C27542C27542C27542C27542C27542C27542 - C27542C27542C27542C27542C27542C27542C27542C27542C27542C27542C275 - 42C27542C27542C27542C27542C27542C27542C27542C27542C27542C27542C2 - 7542C27542C27542C27542C27542C27542C27542C27542C27542C27542C27542 - C27542C27542C27542C27542C27542C27542C27542C27542C27542C27542C275 - 42C27542C27542C27541C1743ABF6F2DBB6521B75D14B35307AF4A00AD4500AA - 43000000000000000000000000071D0F75FF0000000000000000000000000019 - 0A00AD4600AD4600AD4600AD4600AD4600AD4600AD4600AD4600AD4600AD4600 - AD4600AD4600AD4600AD4600AD4600AD4600AD4600AD4600AD4600AD4600AD46 - 00AD4600AD4600AD4600AD4600AD4600AD4600AD4600AD4600AD4600AD4600AD - 4600AD4600AD4600AD4600AD4600AD4600AD4600AD4600AD4600AD4600AD4600 - AD4600AD4600AD4600AD4600AD4600AD4600AD4600AD4600AD4600AD4600AD46 - 00AD4600AD4600AD4600AD4600AD4600AD4600AD4600AD4600AD4600AD4600AD - 4600AD4600AD4600AD4600AD4600AD4600AD4600AD4600AD46C4ECD4FFFFFFFF - FFFFFFFFFF2FBC6800AD4600AD4600AD4600AD4600AD4600AD461BB559FCFEFC - FFFFFFFFFFFFFFFFFF2DBB6600AD463CC071FFFFFFFFFFFFFFFFFFBBE9CD28B9 - 6335BE6C40C17442C27542C27542C275C6ECD5FFFFFFFFFFFFFFFFFF6CCF9342 - C27542C275CCEEDAFFFFFFFFFFFFFEFEFE56C88442C27542C27542C27542C275 - B7E8CBFFFFFFFFFFFFFFFFFF6ACE9242C27542C2755ECB8AF2FAF5FFFFFFFFFF - FFFFFFFFFBFDFCE5F6ECE0F5E8E8F7EEFFFFFFFFFFFFFFFFFFA0E0B942C27542 - C27542C27587D8A7FFFFFFFFFFFFFFFFFF9ADEB542C27542C27542C27542C275 - 89D9A9FFFFFFFFFFFFFFFFFFEFF9F3E0F5E8E0F5E8E0F5E8E0F5E8E0F5E8E0F5 - E8E0F5E8E0F5E89DDFB842C27542C27542C27542C27542C27542C27542C27542 - C27542C27542C27542C27542C27542C27542C27542C27542C27542C27542C275 - 42C27542C27542C27542C27542C27542C27542C27542C27542C27542C27542C2 - 7542C27542C27542C27542C27542C27542C27542C27542C27542C27542C27542 - C27542C27542C27542C27542C27542C27542C27542C27542C27542C27542C275 - 42C27542C27542C27542C27542C27542C27542C27542C27542C27542C27542C2 - 7542C27542C27542C27542C27542C27542C27542C27542C27542C27542C27542 - C27542C27542C27542C2753DC0722FB966000000000000000000000000071D0F - 46FF00000000000000000000000000190A00AE4600AE4600AE4600AE4600AE46 - 00AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE - 4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600 - AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE46 - 00AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE - 4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600 - AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE46 - 00AE4600AE4600AE46C4ECD4FFFFFFFFFFFFFFFFFF2FBC6800AE4600AE4600AE - 4600AE4600AE4600AE4600AE46CEEFDBFFFFFFFFFFFFFFFFFF61CC8C14B45456 - C984FFFFFFFFFFFFFFFFFFC4ECD442C27542C27542C27542C27542C27542C275 - C4ECD4FFFFFFFFFFFFFFFFFF6DD09442C27542C275CCEEDAFFFFFFFFFFFFFEFE - FE56C88442C27542C27542C27542C275B7E8CBFFFFFFFFFFFFFFFFFF6ACE9242 - C27542C27542C27562CC8CCDEEDAFCFEFDFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF - FFFFFFFFFFFFFFFFFFA0E0B942C27542C27542C27587D8A7FFFFFFFFFFFFFFFF - FF9ADEB542C27542C27542C27542C27589D8A8FFFFFFFFFFFFFFFFFFFFFFFFFF - FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFE6F7ED42C27542C275 - 42C27542C27542C27542C27542C27542C27542C27542C27542C27542C27542C2 - 7542C27542C27542C27542C27542C27542C27542C27542C27542C27542C27542 - C27542C27542C27542C27542C27542C27542C27542C27542C27542C27542C275 - 42C27542C27542C27542C27542C27542C27542C27542C27542C27542C27542C2 - 7542C27542C27542C27542C27542C27542C27542C27542C27542C27542C27542 - C27542C27542C27542C27542C27542C27542C27542C27542C27542C27542C275 - 42C27542C27542C27542C27542C27542C27542C27542C27542C27542C27540BE - 730000000000000000000000000B1F1346FF0000000000000000000000000019 - 0A00AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600 - AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE46 - 00AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE - 4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600 - AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE46 - 00AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE - 4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE46C4ECD4FFFFFFFF - FFFFFFFFFF2FBC6800AE4600AE4600AE4600AE4600AE4600AE4600AE46ABE4C1 - FFFFFFFFFFFFFFFFFF9BDFB742C2755DCA89FFFFFFFFFFFFFFFFFFD6F1E142C2 - 7542C27542C27542C27542C27542C275D4F1DFFFFFFFFFFFFFFFFFFF67CD9042 - C27542C275CCEEDAFFFFFFFFFFFFFEFEFE56C88442C27542C27542C27542C275 - B8E8CBFFFFFFFFFFFFFFFFFF6ACE9242C27542C27542C27542C27542C2755AC9 - 8683D7A59DDFB8ABE4C2AFE5C5C3EBD3FFFFFFFFFFFFFFFFFFA0E0B942C27542 - C27542C27587D8A7FFFFFFFFFFFFFFFFFF9ADEB542C27542C27542C27542C275 - 7AD49EFFFFFFFFFFFFFFFFFFD6F2E1AFE5C5AFE5C5AFE5C5AFE5C5AFE5C5EEF9 - F3FFFFFFFFFFFFE6F7ED42C27542C27542C27542C27542C27542C27542C27542 - C27542C27542C27542C27542C27542C27542C27542C27542C27542C27542C275 - 42C27542C27542C27542C27542C27542C27542C27542C27542C27542C27542C2 - 7542C27542C27542C27542C27542C27542C27542C27542C27542C27542C27542 - C27542C27542C27542C27542C27542C27542C27542C27542C27542C27542C275 - 42C27542C27542C27542C27542C27542C27542C27542C27542C27542C27542C2 - 7542C27542C27542C27542C27542C27542C27542C27542C27542C27542C27542 - C27542C27542C27542C27542C27540BE730000000000000000000000000E2015 - FFFF00000000000000000000000000190A00AE4600AE4600AE4600AE4600AE46 - 00AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE - 4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600 - AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE46 - 00AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE - 4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600 - AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE4600AE46 - 00AE4600AE4600AE46C4ECD4FFFFFFFFFFFFFFFFFF2FBC6800AE4600AE4600AE - 4609B04C1AB6582ABB643AC070B1E6C6FFFFFFFFFFFFFFFFFFA6E2BE42C27546 - C378F2FAF5FFFFFFFFFFFFF9FDFB4EC67E42C27542C27542C27542C2754AC47A - F6FCF8FFFFFFFFFFFFFCFEFD4DC57D42C27542C275CCEEDAFFFFFFFFFFFFFFFF - FF81D6A342C27542C27542C27542C275D1F0DDFFFFFFFFFFFFFFFFFF63CC8D42 - C27542C27542C27542C27542C27542C27542C27542C27542C27542C27574D299 - FFFFFFFFFFFFFFFFFF9BDEB642C27542C27542C27587D8A7FFFFFFFFFFFFFFFF - FF9ADEB542C27542C27542C27542C27558C985FEFEFEFFFFFFFFFFFFB4E7C842 - C27542C27542C27542C27542C275E4F6EBFFFFFFFFFFFFD7F2E242C27542C275 - 42C27542C27542C27542C27542C27542C27542C27542C27542C27542C27542C2 - 7542C27542C27542C27542C27542C27542C27542C27542C27542C27542C27542 - C27542C27542C27542C27542C27542C27542C27542C27542C27542C27542C275 - 42C27542C27542C27542C27542C27542C27542C27542C27542C27542C27542C2 - 7542C27542C27542C27542C27542C27542C27542C27542C27542C27542C27542 - C27542C27542C27542C27542C27542C27542C27542C27542C27542C27542C275 - 42C27542C27542C27542C27542C27542C27542C27542C27542C27542C27540BE - 730000000000000000000000000E201576FF0000000000000000000000000019 - 0A00AF4600AF4600AF4600AF4600AF4600AF4600AF4600AF4600AF4600AF4600 - AF4600AF4600AF4600AF4600AF4600AF4600AF4600AF4600AF4600AF4600AF46 - 00AF4600AF4600AF4600AF4600AF4600AF4600AF4600AF4600AF4600AF4600AF - 4600AF4600AF4600AF4600AF4600AF4600AF4600AF4600AF4600AF4600AF4600 - AF4600AF4600AF4600AF4600AF4600AF4600AF4600AF4600AF4600AF4600AF46 - 00AF4600AF4600AF4600AF4600AF4600AF4600AF4600AF4600AF4600AF4600AF - 4600AF4600AF4600AF4600AF4600AF4600AF4600AF4600AF46C4ECD4FFFFFFFF - FFFFFFFFFF32BE6915B55527BB6239C06F41C37542C37542C37542C375B4E7C8 - FFFFFFFFFFFFFFFFFFA4E2BC42C37542C375BCE9CEFFFFFFFFFFFFFFFFFFACE4 - C242C37542C37542C37542C375A0E0B9FFFFFFFFFFFFFFFFFFD9F3E342C37542 - C37542C375CCEFDAFFFFFFFFFFFFFFFFFFF7FCF980D6A242C37542C3756CD094 - FCFEFDFFFFFFFFFFFFFDFEFD51C78042C37542C37542C3758ADAAA5CCB8842C3 - 7542C37542C37542C37542C37593DCB0FFFFFFFFFFFFFFFFFF90DBAE42C37542 - C37542C37587D9A7FFFFFFFFFFFFFFFFFF9ADFB542C37542C37542C37542C375 - 42C375DCF4E6FFFFFFFFFFFFEDF9F24DC67D42C37542C37542C3755ECC8AFCFE - FCFFFFFFFFFFFFB1E6C642C37542C37542C37542C37542C37542C37542C37542 - C37542C37542C37542C37542C37542C37542C37542C37542C37542C37542C375 - 42C37542C37542C37542C37542C37542C37542C37542C37542C37542C37542C3 - 7542C37542C37542C37542C37542C37542C37542C37542C37542C37542C37542 - C37542C37542C37542C37542C37542C37542C37542C37542C37542C37542C375 - 42C37542C37542C37542C37542C37542C37542C37542C37542C37542C37542C3 - 7542C37542C37542C37542C37542C37542C37542C37542C37542C37542C37542 - C37542C37542C37542C37542C37540BF730000000000000000000000000E2015 - 47FF00000000000000000000000000190A00B04600B04600B04600B04600B046 - 00B04600B04600B04600B04600B04600B04600B04600B04600B04600B04600B0 - 4600B04600B04600B04600B04600B04600B04600B04600B04600B04600B04600 - B04600B04600B04600B04600B04600B04600B04600B04600B04600B04600B046 - 00B04600B04600B04600B04600B04600B04600B04600B04600B04600B04600B0 - 4600B04600B04600B04600B04600B04600B04600B04600B04600B04600B04600 - B04600B04600B04600B04600B04600B04600B04600B04600B04600B04600B046 - 00B04600B04600B046C4ECD4FFFFFFFFFFFFFFFFFF64CE8E42C47542C47542C4 - 7542C47542C47542C47542C475C9EED8FFFFFFFFFFFFFFFFFF96DEB242C47542 - C47565CF8EFBFDFCFFFFFFFFFFFFFFFFFFC7EDD68CDBAB8ADAAABEEACFFEFEFE - FFFFFFFFFFFFFFFFFF8CDBAB42C47542C47542C475CCEFDAFFFFFFFFFFFFFFFF - FFFFFFFFFFFFFFD7F2E2CAEED8F9FDFBFFFFFFFFFFFFFFFFFFE1F5E942C47542 - C47542C47554C982FEFEFEFCFEFCC6EDD58BDAAA6CD19369D0918CDBABF0FAF4 - FFFFFFFFFFFFFFFFFF6CD19342C47571D297C2ECD2D8F2E2FFFFFFFFFFFFFFFF - FFDEF4E7C2ECD2C2ECD2ABE4C142C47542C47586D9A6FFFFFFFFFFFFFFFFFFCE - EFDB63CE8D4AC67A6AD092D9F3E3FFFFFFFFFFFFFEFEFE6DD19442C47542C475 - 42C47542C47542C47542C47542C47542C47542C47542C47542C47542C47542C4 - 7542C47542C47542C47542C47542C47542C47542C47542C47542C47542C47542 - C47542C47542C47542C47542C47542C47542C47542C47542C47542C47542C475 - 42C47542C47542C47542C47542C47542C47542C47542C47542C47542C47542C4 - 7542C47542C47542C47542C47542C47542C47542C47542C47542C47542C47542 - C47542C47542C47542C47542C47542C47542C47542C47542C47542C47542C475 - 42C47542C47542C47542C47542C47542C47542C47542C47542C47542C47540C0 - 730000000000000000000000000E201559FF0000000000000000000000000019 - 0A00B04700B04700B04700B04700B04700B04700B04700B04700B04700B04700 - B04700B04700B04700B04700B04700B04700B04700B04700B04700B04700B047 - 00B04700B04700B04700B04700B04700B04700B04700B04700B04700B04700B0 - 4700B04700B04700B04700B04700B04700B04700B04700B04700B04700B04700 - B04700B04700B04700B04700B04700B04700B04700B04700B04700B04700B047 - 00B04700B04700B04700B04700B04700B04700B04700B04700B04700B04700B0 - 4700B04700B04700B04700B04700B04702B04914B65528BC63D1F0DEFFFFFFFF - FFFFFFFFFF64CE8F42C47642C47642C47642C47642C47642C47644C478F0FAF4 - FFFFFFFFFFFFFFFFFF79D59E42C47642C47642C47697DEB3FEFEFEFFFFFFFFFF - FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFCDEFDB45C57842C47642 - C47642C476CCEFDAFFFFFFFFFFFFDCF4E6FAFDFBFFFFFFFFFFFFFFFFFFFFFFFF - FFFFFFFFFFFFFFFFFF91DCAF42C47642C47642C47653C982FCFEFDFFFFFFFFFF - FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFDAF3E444C47742C476A8 - E3C0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF5FBF847C57A - 42C47643C477C0EBD1FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF - FFFFFFFFBAE9CD42C47642C47642C47642C47642C47642C47642C47642C47642 - C47642C47642C47642C47642C47642C47642C47642C47642C47642C47642C476 - 42C47642C47642C47642C47642C47642C47642C47642C47642C47642C47642C4 - 7642C47642C47642C47642C47642C47642C47642C47642C47642C47642C47642 - C47642C47642C47642C47642C47642C47642C47642C47642C47642C47642C476 - 42C47642C47642C47642C47642C47642C47642C47642C47642C47642C47642C4 - 7642C47642C47642C47642C47642C47642C47642C47642C47642C47642C47642 - C47642C47642C47642C47642C47640C0740000000000000000000000000E2015 - 76FF00000000000000000000000000190A00B14700B14700B14700B14700B147 - 00B14700B14700B14700B14700B14700B14700B14700B14700B14700B14700B1 - 4700B14700B14700B14700B14700B14700B14700B14700B14700B14700B14700 - B14700B14700B14700B14700B14700B14700B14700B14700B14700B14700B147 - 00B14700B14700B14700B14700B14700B14700B14700B14700B14700B14700B1 - 4700B14700B14700B14700B14700B14700B14700B14700B14700B14700B14700 - B14700B14700B14700B14700B14700B14700B14700B14705B24A1AB8592EBF68 - 3FC47442C57642C576D3F1DFFFFFFFFFFFFFFFFFFF64CF8F42C57642C57642C5 - 7642C57642C57642C57681D8A4FFFFFFFFFFFFFFFFFFF9FDFB50C98042C57642 - C57642C57642C57686DAA7EDF9F2FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF - FCFEFDB8E9CB4BC77C42C57642C57642C57642C576CBEFD9FFFFFFFFFFFFA8E4 - C074D49AE9F8EFFFFFFFFFFFFFFFFFFFFFFFFFFEFEFEB7E9CB44C57842C57642 - C57642C57642C5768CDBABEAF8EFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF - FFFFFFDFF5E75CCD8942C57642C576A3E3BCFFFFFFFFFFFFFFFFFFFFFFFFFFFF - FFFFFFFFFFFFFFFFFFFFF3FBF646C67942C57642C57647C679ADE5C3FBFDFCFF - FFFFFFFFFFFFFFFFFFFFFFFFFFFFFCFEFDB4E8C947C67942C57642C57642C576 - 42C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642C5 - 7642C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642 - C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642C576 - 42C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642C5 - 7642C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642 - C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642C576 - 42C57642C57642C57642C57642C57642C57642C57642C57642C57642C57640C1 - 740000000000000000000000000E201576FF0000000000000000000000000019 - 0A00B14700B14700B14700B14700B14700B14700B14700B14700B14700B14700 - B14700B14700B14700B14700B14700B14700B14700B14700B14700B14700B147 - 00B14700B14700B14700B14700B14700B14700B14700B14700B14700B14700B1 - 4700B14700B14700B14700B14700B14700B14700B14700B14700B14700B14700 - B14700B14700B14700B14700B14700B14700B14700B14700B14700B14700B147 - 00B14700B14700B14700B14700B14700B14700B14700B14700B14700B14705B2 - 4A19B8592FBF6840C47542C57642C57642C57642C57642C576D3F1DFFFFFFFFF - FFFFFFFFFF64CF8F42C57642C57642C57642C57642C57656CB85EAF8EFFFFFFF - FFFFFFFFFFFFC2ECD242C57642C57642C57642C57642C57642C5764AC77C83D9 - A5AEE6C4C3ECD4C7EDD6B8E9CB98DFB45ECD8A42C57642C57642C57642C57642 - C57642C57673D499A6E3BFA4E3BD64CF8E42C5764BC77C8DDCACBCEACEC6EDD6 - B1E7C675D49B42C57642C57642C57642C57642C57642C57642C57647C67974D4 - 9AA1E2BBBDEACFC8EED7C0EBD1AAE5C17BD69F46C67942C57642C57642C57658 - CC868BDBABB5E8C9FFFFFFFFFFFFFFFFFFC1ECD28BDBAB8BDBAB79D69E42C576 - 42C57642C57642C57642C5765CCD8999DFB5BCEACEC8EED7BDEACF9EE1B962CF - 8D42C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642 - C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642C576 - 42C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642C5 - 7642C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642 - C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642C576 - 42C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642C5 - 7642C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642 - C57642C57642C57642C57642C57640C1740000000000000000000000000E2015 - 47FF00000000000000000000000000190A00B14700B14700B14700B14700B147 - 00B14700B14700B14700B14700B14700B14700B14700B14700B14700B14700B1 - 4700B14700B14700B14700B14700B14700B14700B14700B14700B14700B14700 - B14700B14700B14700B14700B14700B14700B14700B14700B14700B14700B147 - 00B14700B14700B14700B14700B14700B14700B14700B14700B14700B14700B1 - 4700B14700B14700B14700B14700B14700B14700B14700B14700B14700B14700 - B14700B14703B24919B85930BF6940C47542C57642C57642C57642C57642C576 - 42C57642C57642C576D3F1DFFFFFFFFFFFFFFFFFFF64CF8F42C57642C57642C5 - 7644C5777ED7A2E9F8EFFFFFFFFFFFFFFFFFFFF9FDFB64CF8E42C57642C57642 - C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642C576 - 42C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642C5 - 7642C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642 - C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642C576 - 42C57642C57642C57642C57642C57642C57642C57687DAA8FFFFFFFFFFFFFFFF - FF9AE0B642C57642C57642C57642C57642C57642C57642C57642C57642C57642 - C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642C576 - 42C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642C5 - 7642C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642 - C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642C576 - 42C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642C5 - 7642C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642 - C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642C576 - 42C57642C57642C57642C57642C57642C57642C57642C57642C57642C57640C1 - 740000000000000000000000000E201577FF0000000000000000000000000019 - 0A00B24700B24700B24700B24700B24700B24700B24700B24700B24700B24700 - B24700B24700B24700B24700B24700B24700B24700B24700B24700B24700B247 - 00B24700B24700B24700B24700B24700B24700B24700B24700B24700B24700B2 - 4700B24700B24700B24700B24700B24700B24700B24700B24700B24700B24700 - B24700B24700B24700B24700B24700B24700B24700B24700B24700B24700B247 - 00B24700B24700B24700B24701B24815B8562DBF6740C57542C57642C57642C5 - 7642C57642C57642C57642C57642C57642C57642C57642C576D3F1DFFFFFFFFF - FFFFFFFFFFCDEFDBC2ECD2C2ECD2CFF0DCF0FAF4FFFFFFFFFFFFFFFFFFFFFFFF - FDFEFD90DDAE42C57642C57642C57642C57642C57642C57642C57642C57642C5 - 7642C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642 - C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642C576 - 42C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642C5 - 7642C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642 - C57642C57687DAA8FFFFFFFFFFFFFFFFFF9AE0B642C57642C57642C57642C576 - 42C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642C5 - 7642C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642 - C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642C576 - 42C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642C5 - 7642C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642 - C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642C576 - 42C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642C5 - 7642C57642C57642C57642C57642C57642C57642C57642C57642C57642C57642 - C57642C57642C57642C57642C57640C1740000000000000000000000000E2015 - 77FF00000000000000000000000000190A00B34800B34800B34800B34800B348 - 00B34800B34800B34800B34800B34800B34800B34800B34800B34800B34800B3 - 4800B34800B34800B34800B34800B34800B34800B34800B34800B34800B34800 - B34800B34800B34800B34800B34800B34800B34800B34800B34800B34800B348 - 00B34800B34800B34800B34800B34800B34800B34800B34800B34800B34800B3 - 4800B34800B34800B34800B34800B34800B34800B3480CB65025BE623CC47342 - C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742C677 - 42C67742C67742C677D3F1DFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF - FFFFFFFFFFFFFFFFFFFFFFFFFFF4FBF789DBAA42C67742C67742C67742C67742 - C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742C677 - 42C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742C6 - 7742C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742 - C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742C677 - 42C67742C67742C67742C67742C67742C67742C67777D69DF9FDFAFFFFFFFBFD - FC8ADBAB42C67742C67742C67742C67742C67742C67742C67742C67742C67742 - C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742C677 - 42C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742C6 - 7742C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742 - C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742C677 - 42C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742C6 - 7742C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742 - C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742C677 - 42C67742C67742C67742C67742C67742C67742C67742C67742C67742C67740C2 - 750000000000000000000000000E201677FF0000000000000000000000000019 - 0A00B34800B34800B34800B34800B34800B34800B34800B34800B34800B34800 - B34800B34800B34800B34800B34800B34800B34800B34800B34800B34800B348 - 00B34800B34800B34800B34800B34800B34800B34800B34800B34800B34800B3 - 4800B34800B34800B34800B34800B34800B34800B34800B34800B34800B34800 - B34800B34800B34800B34800B34800B34800B34800B34800B34800B34804B44A - 1ABA5A34C26D42C67742C67742C67742C67742C67742C67742C67742C67742C6 - 7742C67742C67742C67742C67742C67742C67742C67742C677C7EED7FFFFFFFF - FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEFEFEE8F8EEA9E5C156CC85 - 42C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742C6 - 7742C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742 - C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742C677 - 42C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742C6 - 7742C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742 - C67742C67742C6774CC97E54CB844EC98042C67742C67742C67742C67742C677 - 42C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742C6 - 7742C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742 - C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742C677 - 42C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742C6 - 7742C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742 - C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742C677 - 42C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742C6 - 7742C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742 - C67742C67742C67742C67742C67740C2750000000000000000000000000E2016 - 00FF00000000000000000000000000190A00B34800B34800B34800B34800B348 - 00B34800B34800B34800B34800B34800B34800B34800B34800B34800B34800B3 - 4800B34800B34800B34800B34800B34800B34800B34800B34800B34800B34800 - B34800B34800B34800B34800B34800B34800B34800B34800B34800B34800B348 - 00B34800B34800B34800B34800B34800B34800B34800B34800B34800B34800B3 - 4800B34800B3480CB65027BE633EC57442C67742C67742C67742C67742C67742 - C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742C677 - 42C67742C67742C67756CC8589DBAA8BDCAB8BDCAB8BDCAB8BDCAB8BDCAB85DA - A775D59C5ACD8844C67842C67742C67742C67742C67742C67742C67742C67742 - C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742C677 - 42C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742C6 - 7742C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742 - C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742C677 - 42C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742C6 - 7742C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742 - C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742C677 - 42C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742C6 - 7742C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742 - C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742C677 - 42C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742C6 - 7742C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742 - C67742C67742C67742C67742C67742C67742C67742C67742C67742C67742C677 - 42C67742C67742C67742C67742C67742C67742C67742C67742C67742C67740C2 - 750000000000000000000000000E201677FF000000000000000000000000001A - 0A00B44800B44800B44800B44800B44800B44800B44800B44800B44800B44800 - B44800B44800B44800B44800B44800B44800B44800B44800B44800B44800B448 - 00B44800B44800B44800B44800B44800B44800B44800B44800B44800B44800B4 - 4800B44800B44800B44800B44800B44800B44800B44800B44800B44800B44800 - B44800B44800B44800B44800B44800B44815BA5732C26B41C77642C77742C777 - 42C77742C77742C77742C77742C77742C77742C77742C77742C77742C77742C7 - 7742C77742C77742C77742C77742C77742C77742C77742C77742C77742C77742 - C77742C77742C77742C77742C77742C77742C77742C77742C77742C77742C777 - 42C77742C77742C77742C77742C77742C77742C77742C77742C77742C77742C7 - 7742C77742C77742C77742C77742C77742C77742C77742C77742C77742C77742 - C77742C77742C77742C77742C77742C77742C77742C77742C77742C77742C777 - 42C77742C77742C77742C77742C77742C77742C77742C77742C77742C77742C7 - 7742C77742C77742C77742C77742C77742C77742C77742C77742C77742C77742 - C77742C77742C77742C77742C77742C77742C77742C77742C77742C77742C777 - 42C77742C77742C77742C77742C77742C77742C77742C77742C77742C77742C7 - 7742C77742C77742C77742C77742C77742C77742C77742C77742C77742C77742 - C77742C77742C77742C77742C77742C77742C77742C77742C77742C77742C777 - 42C77742C77742C77742C77742C77742C77742C77742C77742C77742C77742C7 - 7742C77742C77742C77742C77742C77742C77742C77742C77742C77742C77742 - C77742C77742C77742C77742C77742C77742C77742C77742C77742C77742C777 - 42C77742C77742C77742C77742C77742C77742C77742C77742C77742C77742C7 - 7742C77742C77742C77742C77742C77742C77742C77742C77742C77742C77742 - C77742C77742C77742C77742C77740C3750000000000000000000000000E2116 - 13FF000000000000000000000000000401001C0B001C0B001C0B001C0B001C0B - 001C0B001C0B001C0B001C0B001C0B001C0B001C0B001C0B001C0B001C0B001C - 0B001C0B001C0B001C0B001C0B001C0B001C0B001C0B001C0B001C0B001C0B00 - 1C0B001C0B001C0B001C0B001C0B001C0B001C0B001C0B001C0B001C0B001C0B - 001C0B001C0B001C0B001C0B001C0B001C0B001C0B001C0B001D0C041E0F091F - 120A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A - 1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F13 - 0A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F - 130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A - 1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F13 - 0A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F - 130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A - 1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F13 - 0A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F - 130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A - 1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F13 - 0A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F - 130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A - 1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F13 - 0A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F - 130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A - 1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F13 - 0A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F130A1F - 120000000000000000000000000E211600FF000B040000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000000000000000000000000012291B - 00FF144327000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000003E654E00FFB7D4C2000D050000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000000000000000000000000000000000000A1C12DCEBE2 - 00FFFFFFFFB7D4C219472B000C05000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000006120B345A43D7E6DDFFFFFF00FF} - end object btnCancel: TButton - Left = 260 - Top = 382 + Left = 246 + Top = 371 Width = 106 Height = 25 Anchors = [akRight, akBottom] @@ -1115,36 +41,36 @@ object frmUpdateCheck: TfrmUpdateCheck Caption = 'Cancel' Default = True ModalResult = 2 - TabOrder = 0 + TabOrder = 3 end object groupBuild: TGroupBox Left = 8 Top = 192 - Width = 358 - Height = 183 + Width = 344 + Height = 172 Anchors = [akLeft, akTop, akRight, akBottom] Caption = 'Nightly build' - TabOrder = 1 + TabOrder = 2 DesignSize = ( - 358 - 183) + 344 + 172) object btnBuild: TButton Left = 6 - Top = 151 - Width = 345 + Top = 140 + Width = 331 Height = 25 Anchors = [akLeft, akRight, akBottom] Caption = 'Download nightly build' ElevationRequired = True ModalResult = 1 - TabOrder = 0 + TabOrder = 2 OnClick = btnBuildClick end object memoBuild: TMemo Left = 6 Top = 16 - Width = 345 - Height = 103 + Width = 331 + Height = 92 Anchors = [akLeft, akTop, akRight, akBottom] BorderStyle = bsNone Color = clBtnFace @@ -1158,47 +84,36 @@ object frmUpdateCheck: TfrmUpdateCheck ParentFont = False ReadOnly = True ScrollBars = ssVertical - TabOrder = 1 + TabOrder = 0 end object btnChangelog: TButton Left = 6 - Top = 120 - Width = 345 + Top = 109 + Width = 331 Height = 25 Anchors = [akLeft, akRight, akBottom] Caption = 'View changelog' - TabOrder = 2 + TabOrder = 1 OnClick = btnChangelogClick end end object groupRelease: TGroupBox Left = 8 - Top = 76 - Width = 358 - Height = 110 + Top = 88 + Width = 344 + Height = 98 Anchors = [akLeft, akTop, akRight] Caption = 'Official release' Enabled = False - TabOrder = 2 + TabOrder = 1 DesignSize = ( - 358 - 110) - object btnRelease: TButton - Left = 6 - Top = 78 - Width = 345 - Height = 25 - Anchors = [akLeft, akRight, akBottom] - Caption = 'Download new release' - ModalResult = 1 - TabOrder = 0 - OnClick = btnReleaseClick - end + 344 + 98) object memoRelease: TMemo Left = 6 Top = 16 - Width = 345 - Height = 60 + Width = 331 + Height = 53 Anchors = [akLeft, akTop, akRight, akBottom] BorderStyle = bsNone Color = clBtnFace @@ -1206,7 +121,43 @@ object frmUpdateCheck: TfrmUpdateCheck 'memoRelease') ReadOnly = True ScrollBars = ssVertical + TabOrder = 0 + end + object LinkLabelRelease: TLinkLabel + Left = 6 + Top = 75 + Width = 122 + Height = 19 + Cursor = crHandPoint + Anchors = [akLeft, akBottom] + Caption = 'Download new release' + PopupMenu = popupDownloadRelease TabOrder = 1 + UseVisualStyle = True + OnLinkClick = LinkLabelReleaseLinkClick + end + end + object btnDonate: TButton + Left = 8 + Top = 8 + Width = 344 + Height = 74 + Anchors = [akLeft, akTop, akRight] + Caption = 'Donate' + CommandLinkHint = + 'Send an arbitrary amount as donation to the author - per PayPal ' + + '(also supports credit cards)' + Style = bsCommandLink + TabOrder = 0 + end + object popupDownloadRelease: TPopupMenu + Images = MainForm.VirtualImageListMain + Left = 32 + Top = 116 + object CopydownloadURL1: TMenuItem + Caption = 'Copy to clipboard' + ImageIndex = 3 + OnClick = CopydownloadURL1Click end end end diff --git a/source/updatecheck.pas b/source/updatecheck.pas index dbc430a6c..8da84a78d 100644 --- a/source/updatecheck.pas +++ b/source/updatecheck.pas @@ -3,8 +3,9 @@ interface uses - Windows, Messages, SysUtils, Classes, Forms, StdCtrls, IniFiles, Controls, Graphics, - apphelpers, gnugettext, ExtCtrls, extra_controls; + Winapi.Windows, Winapi.Messages, System.SysUtils, System.Classes, Vcl.Forms, Vcl.StdCtrls, System.IniFiles, Vcl.Controls, Vcl.Graphics, + apphelpers, gnugettext, Vcl.ExtCtrls, extra_controls, System.StrUtils, Vcl.Dialogs, + Vcl.Menus, Vcl.Clipbrd, generic_types, System.DateUtils, System.IOUtils; type TfrmUpdateCheck = class(TExtForm) @@ -12,30 +13,45 @@ TfrmUpdateCheck = class(TExtForm) groupBuild: TGroupBox; btnBuild: TButton; groupRelease: TGroupBox; - btnRelease: TButton; + LinkLabelRelease: TLinkLabel; lblStatus: TLabel; memoRelease: TMemo; memoBuild: TMemo; - imgDonate: TImage; btnChangelog: TButton; + popupDownloadRelease: TPopupMenu; + CopydownloadURL1: TMenuItem; + btnDonate: TButton; procedure FormCreate(Sender: TObject); procedure btnBuildClick(Sender: TObject); - procedure btnReleaseClick(Sender: TObject); + procedure LinkLabelReleaseLinkClick(Sender: TObject; const Link: string; + LinkType: TSysLinkType); procedure FormShow(Sender: TObject); procedure btnChangelogClick(Sender: TObject); - procedure FormDestroy(Sender: TObject); + procedure FormClose(Sender: TObject; var Action: TCloseAction); + procedure CopydownloadURL1Click(Sender: TObject); + const + SLinkDownloadRelease= 'download-release'; + SLinkInstructionsPortable = 'instructions-portable'; + SLinkChangelog = 'changelog'; private { Private declarations } - ReleaseURL, BuildURL : String; + BuildURL: String; FLastStatusUpdate: Cardinal; + FRestartTaskName: String; procedure Status(txt: String); procedure DownloadProgress(Sender: TObject); + function GetLinkUrl(Sender: TObject; LinkType: String): String; + function GetTaskXmlFileContents: String; + function AppDirIsWritable: Boolean; public { Public declarations } BuildRevision: Integer; procedure ReadCheckFile; end; +procedure DeleteRestartTask; + + implementation uses main; @@ -52,17 +68,20 @@ implementation procedure TfrmUpdateCheck.FormCreate(Sender: TObject); begin // Should be false by default. Callers can set this to True after Create() - imgDonate.OnClick := MainForm.DonateClick; - imgDonate.Visible := MainForm.HasDonated(False) = nbFalse; + btnDonate.OnClick := MainForm.DonateClick; + btnDonate.Visible := MainForm.HasDonated(False) = nbFalse; + btnDonate.Caption := f_('Donate to the %s project', [APPNAME]); HasSizeGrip := True; - Width := AppSettings.ReadInt(asUpdateCheckWindowWidth); - Height := AppSettings.ReadInt(asUpdateCheckWindowHeight); + FRestartTaskName := 'yet_invalid'; end; -procedure TfrmUpdateCheck.FormDestroy(Sender: TObject); +procedure TfrmUpdateCheck.FormClose(Sender: TObject; var Action: TCloseAction); begin - AppSettings.WriteInt(asUpdateCheckWindowWidth, Width); - AppSettings.WriteInt(asUpdateCheckWindowHeight, Height); + AppSettings.WriteIntDpiAware(asUpdateCheckWindowWidth, Self, Width); + AppSettings.WriteIntDpiAware(asUpdateCheckWindowHeight, Self, Height); + if ModalResult <> btnBuild.ModalResult then begin + DeleteRestartTask; + end; end; {** @@ -80,6 +99,8 @@ procedure TfrmUpdateCheck.Status(txt: String); } procedure TfrmUpdateCheck.FormShow(Sender: TObject); begin + Width := AppSettings.ReadIntDpiAware(asUpdateCheckWindowWidth, Self); + Height := AppSettings.ReadIntDpiAware(asUpdateCheckWindowHeight, Self); Caption := f_('Check for %s updates', [APPNAME]) + ' ...'; Screen.Cursor := crHourglass; try @@ -99,6 +120,7 @@ procedure TfrmUpdateCheck.FormShow(Sender: TObject); Status(E.Message); end; Screen.Cursor := crDefault; + btnCancel.TrySetFocus; end; @@ -108,9 +130,9 @@ procedure TfrmUpdateCheck.FormShow(Sender: TObject); procedure TfrmUpdateCheck.ReadCheckFile; var CheckfileDownload: THttpDownLoad; - CheckFilename: String; + CheckFilename, TaskXmlFile: String; Ini: TIniFile; - ReleaseVersion: String; + ReleaseVersion, ReleasePackage: String; ReleaseRevision: Integer; Note: String; Compiled: TDateTime; @@ -119,17 +141,11 @@ procedure TfrmUpdateCheck.ReadCheckFile; INISECT_BUILD = 'Build'; begin // Init GUI controls - btnRelease.Enabled := False; + LinkLabelRelease.Enabled := False; btnBuild.Enabled := False; memoRelease.Clear; memoBuild.Clear; - if RunningAsUwp then begin - raise Exception.Create( - f_('Please update %s through the Microsoft Store.', [APPNAME]) - ); - end; - // Prepare download CheckfileDownload := THttpDownload.Create(Self); CheckfileDownload.TimeOut := 5; @@ -146,16 +162,25 @@ procedure TfrmUpdateCheck.ReadCheckFile; if Ini.SectionExists(INISECT_RELEASE) then begin ReleaseVersion := Ini.ReadString(INISECT_RELEASE, 'Version', 'unknown'); ReleaseRevision := Ini.ReadInteger(INISECT_RELEASE, 'Revision', 0); - ReleaseURL := Ini.ReadString(INISECT_RELEASE, 'URL', ''); + ReleasePackage := IfThen(AppSettings.PortableMode, 'portable', 'installer'); memoRelease.Lines.Add(f_('Version %s (yours: %s)', [ReleaseVersion, Mainform.AppVersion])); memoRelease.Lines.Add(f_('Released: %s', [Ini.ReadString(INISECT_RELEASE, 'Date', '')])); - Note := Ini.ReadString(INISECT_RELEASE, 'Note', ''); + if IsWine then + Note := _('Wine support is deprecated. Future versions will not work reliably. Use the native Linux or macOS releases instead.') + else + Note := Ini.ReadString(INISECT_RELEASE, 'Note', ''); if Note <> '' then memoRelease.Lines.Add(_('Notes') + ': ' + Note); - btnRelease.Caption := f_('Download version %s', [ReleaseVersion]); + + LinkLabelRelease.Caption := f_('Download version %s (%s)', [ReleaseVersion, ReleasePackage]); + LinkLabelRelease.Caption := '' + LinkLabelRelease.Caption + ''; + if AppSettings.PortableMode then begin + LinkLabelRelease.Caption := LinkLabelRelease.Caption + ' '+_('Update instructions')+''; + end; + // Enable the download button if the current version is outdated groupRelease.Enabled := ReleaseRevision > Mainform.AppVerRevision; - btnRelease.Enabled := groupRelease.Enabled; + LinkLabelRelease.Enabled := groupRelease.Enabled; memoRelease.Enabled := groupRelease.Enabled; if not memoRelease.Enabled then memoRelease.Font.Color := GetThemeColor(cl3DDkShadow) @@ -173,11 +198,25 @@ procedure TfrmUpdateCheck.ReadCheckFile; Note := Ini.ReadString(INISECT_BUILD, 'Note', ''); if Note <> '' then memoBuild.Lines.Add(_('Notes') + ': * ' + StringReplace(Note, '%||%', CRLF+'* ', [rfReplaceAll] ) ); - btnBuild.Caption := f_('Download and install build %d', [BuildRevision]); - // A new release should have priority over a new nightly build. - // So the user should not be able to download a newer build here - // before having installed the new release. - btnBuild.Enabled := (Mainform.AppVerRevision = 0) or ((BuildRevision > Mainform.AppVerRevision) and (not btnRelease.Enabled)); + if GetExecutableBits = 64 then begin + btnBuild.Caption := f_('Download and install build %d', [BuildRevision]); + // A new release should have priority over a new nightly build. + // So the user should not be able to download a newer build here + // before having installed the new release. + btnBuild.Enabled := (Mainform.AppVerRevision = 0) or ((BuildRevision > Mainform.AppVerRevision) and (not LinkLabelRelease.Enabled)); + end + else begin + btnBuild.Caption := _('No build updates for 32 bit version'); + end; + + if btnBuild.Enabled then begin + TaskXmlFile := GetTempDir + APPNAME + '_task_restart.xml'; + SaveUnicodeFile(TaskXmlFile, GetTaskXmlFileContents, UTF8NoBOMEncoding); + FRestartTaskName := ValidFilename(ParamStr(0)); + ShellExec('schtasks', '', '/Create /TN "'+FRestartTaskName+'" /xml '+TaskXmlFile, True); + btnBuild.ElevationRequired := not AppDirIsWritable; + end; + end; if FileExists(CheckFilename) then @@ -187,20 +226,40 @@ procedure TfrmUpdateCheck.ReadCheckFile; {** - Download release installer via web browser + Download release package via web browser } -procedure TfrmUpdateCheck.btnReleaseClick(Sender: TObject); +procedure TfrmUpdateCheck.LinkLabelReleaseLinkClick(Sender: TObject; + const Link: string; LinkType: TSysLinkType); begin - ShellExec(APPDOMAIN+'download.php?download=installer'); + case LinkType of + + sltURL: ShellExec(Link); + + sltID: begin + if Link = SLinkDownloadRelease then begin + ShellExec(GetLinkUrl(Sender, Link)); + Close; + end + else if Link = SLinkInstructionsPortable then begin + MessageDialog(f_('Download the portable package and extract it in %s', [GetAppDir]), mtInformation, [mbOK]); + end; + end; + + end; end; procedure TfrmUpdateCheck.btnChangelogClick(Sender: TObject); begin - ShellExec(APPDOMAIN+'download.php?place='+EncodeURLParam(TButton(Sender).Name)+'#nightlybuilds'); + ShellExec(GetLinkUrl(Sender, SLinkChangelog)); end; +procedure TfrmUpdateCheck.CopydownloadURL1Click(Sender: TObject); +begin + Clipboard.TryAsText := GetLinkUrl(LinkLabelRelease, SLinkDownloadRelease); +end; + {** Download latest build and replace running exe } @@ -213,6 +272,8 @@ procedure TfrmUpdateCheck.btnBuildClick(Sender: TObject); ResPointer: PChar; Stream: TMemoryStream; BuildSizeDownloaded: Int64; + DoOverwrite: Boolean; + UpdaterAge: TDateTime; begin Download := THttpDownload.Create(Self); Download.URL := BuildURL; @@ -234,8 +295,8 @@ procedure TfrmUpdateCheck.btnBuildClick(Sender: TObject); if not FileExists(DownloadFilename) then Raise Exception.CreateFmt(_('Downloaded file not found: %s'), [DownloadFilename]); BuildSizeDownloaded := _GetFileSize(DownloadFilename); - if (Download.ContentLength > 0) and (BuildSizeDownloaded < Download.ContentLength) then - Raise Exception.CreateFmt(_('Downloaded file corrupted: %s (Size is %d and should be %d)'), [DownloadFilename, BuildSizeDownloaded, Download.ContentLength]); + if BuildSizeDownloaded < SIZE_MB then + Raise Exception.CreateFmt(_('Downloaded file corrupted: %s (Size is %d / too small)'), [DownloadFilename, BuildSizeDownloaded]); Status(_('Update in progress')+' ...'); ResInfoblockHandle := FindResource(HInstance, 'UPDATER', 'EXE'); @@ -247,13 +308,22 @@ procedure TfrmUpdateCheck.btnBuildClick(Sender: TObject); Stream.WriteBuffer(ResPointer[0], SizeOfResource(HInstance, ResInfoblockHandle)); Stream.Position := 0; UpdaterFilename := GetTempDir + AppName+'_updater.exe'; - if FileExists(UpdaterFilename) and (Stream.Size = _GetFileSize(UpdaterFilename)) then + + DoOverwrite := True; + if FileExists(UpdaterFilename) and (Stream.Size = _GetFileSize(UpdaterFilename)) then begin // Do not replace old updater if it's still valid. Avoids annoyance for cases in which // user has whitelisted this .exe in his antivirus or whatever software. - else + FileAge(UpdaterFilename, UpdaterAge); + if Abs(DaysBetween(Now, UpdaterAge)) < 30 then + DoOverwrite := False; + end; + + if DoOverwrite then begin Stream.SaveToFile(UpdaterFilename); + end; + // Calling the script will now post a WM_CLOSE this running exe... - ShellExec(UpdaterFilename, '', '"'+ParamStr(0)+'" "'+DownloadFilename+'"'); + ShellExec(UpdaterFilename, '', '"'+ParamStr(0)+'" "'+DownloadFilename+'" "'+FRestartTaskName+'"'); finally UnlockResource(ResHandle); FreeResource(ResHandle); @@ -277,9 +347,108 @@ procedure TfrmUpdateCheck.DownloadProgress(Sender: TObject); if FLastStatusUpdate > GetTickCount-200 then Exit; Download := Sender as THttpDownload; - Status(f_('Downloading: %s / %s', [FormatByteNumber(Download.BytesRead), FormatByteNumber(Download.ContentLength)]) + ' ...'); + Status(f_('Downloading: %s', [FormatByteNumber(Download.BytesRead)]) + ' ...'); FLastStatusUpdate := GetTickCount; end; +function TfrmUpdateCheck.GetLinkUrl(Sender: TObject; LinkType: String): String; +var + DownloadParam, PlaceParam: String; +begin + PlaceParam := 'place='+EncodeURLParam(TWinControl(Sender).Name); + + if LinkType = SLinkDownloadRelease then begin + if AppSettings.PortableMode then begin + if GetExecutableBits = 64 then + DownloadParam := 'download=portable-64' + else + DownloadParam := 'download=portable'; + end else begin + DownloadParam := 'download=installer'; + end; + Result := 'download.php?'+DownloadParam+'&'+PlaceParam; + end + + else if LinkType = SLinkChangelog then begin + Result := 'download.php?'+PlaceParam+'#nightlybuilds'; + end; + + Result := APPDOMAIN + Result; +end; + + +function TfrmUpdateCheck.GetTaskXmlFileContents: String; +begin + Result := '' + sLineBreak + + '' + sLineBreak + + ' ' + sLineBreak + + ' 2022-12-24T12:39:17.5068755' + sLineBreak + + ' ' + APPNAME + ' ' + MainForm.AppVersion + '' + sLineBreak + + ' \' + APPNAME + '_restart' + sLineBreak + + ' ' + sLineBreak + + ' ' + sLineBreak + + ' ' + sLineBreak + + ' 2022-12-24T12:42:36' + sLineBreak + + ' true' + sLineBreak + + ' ' + sLineBreak + + ' ' + sLineBreak + + ' ' + sLineBreak + + ' ' + sLineBreak + + // Note: no with the current users SID + ' InteractiveToken' + sLineBreak + + ' LeastPrivilege' + sLineBreak + + ' ' + sLineBreak + + ' ' + sLineBreak + + ' ' + sLineBreak + + ' IgnoreNew' + sLineBreak + + ' true' + sLineBreak + + ' true' + sLineBreak + + ' true' + sLineBreak + + ' false' + sLineBreak + + ' false' + sLineBreak + + ' ' + sLineBreak + + ' true' + sLineBreak + + ' false' + sLineBreak + + ' ' + sLineBreak + + ' true' + sLineBreak + + ' true' + sLineBreak + + ' false' + sLineBreak + + ' false' + sLineBreak + + ' false' + sLineBreak + + ' PT72H' + sLineBreak + + ' 7' + sLineBreak + + ' ' + sLineBreak + + ' ' + sLineBreak + + ' ' + sLineBreak + + ' "' + ParamStr(0) + '"' + sLineBreak + + ' --runfrom=scheduler' + sLineBreak + + ' ' + sLineBreak + + ' ' + sLineBreak + + ''; +end; + + +function TfrmUpdateCheck.AppDirIsWritable: Boolean; +var + TestFile: string; + H: THandle; +begin + TestFile := IncludeTrailingPathDelimiter(GetAppDir) + 'chk.tmp'; + H := CreateFile(PChar(TestFile), GENERIC_READ or GENERIC_WRITE, 0, nil, + CREATE_NEW, FILE_ATTRIBUTE_TEMPORARY or FILE_FLAG_DELETE_ON_CLOSE, 0); + Result := H <> INVALID_HANDLE_VALUE; + if Result then + CloseHandle(H); + DeleteFile(TestFile); +end; + + +procedure DeleteRestartTask; +begin + // TN = Task Name + // F = Force, suppress prompt + ShellExec('schtasks', '', '/Delete /TN "'+ValidFilename(ParamStr(0))+'" /F', True); +end; + end. diff --git a/source/usermanager.dfm b/source/usermanager.dfm index 92fc2f99d..26a43acd0 100644 --- a/source/usermanager.dfm +++ b/source/usermanager.dfm @@ -10,22 +10,18 @@ object UserManagerForm: TUserManagerForm Constraints.MinWidth = 450 Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText - Font.Height = -11 + Font.Height = -12 Font.Name = 'Tahoma' Font.Style = [] - OldCreateOrder = False Position = poMainFormCenter OnClose = FormClose OnCloseQuery = FormCloseQuery OnCreate = FormCreate - OnDestroy = FormDestroy - OnResize = FormResize OnShow = FormShow DesignSize = ( 484 364) - PixelsPerInch = 96 - TextHeight = 13 + TextHeight = 14 object Splitter1: TSplitter AlignWithMargins = True Left = 185 @@ -38,7 +34,6 @@ object UserManagerForm: TUserManagerForm Margins.Right = 0 Margins.Bottom = 40 ResizeStyle = rsUpdate - OnMoved = FormResize end object lblWarning: TLabel Left = 8 @@ -97,18 +92,20 @@ object UserManagerForm: TUserManagerForm Left = 3 Top = 3 Width = 171 - Height = 13 + Height = 14 Align = alTop Caption = '&Select user account:' FocusControl = listUsers + ExplicitWidth = 113 end object listUsers: TVirtualStringTree Left = 0 - Top = 41 + Top = 64 Width = 177 - Height = 275 + Height = 252 Align = alClient Header.AutoSizeIndex = 0 + Header.Height = 18 Header.Options = [hoAutoResize, hoColumnResize, hoDblClickResize, hoDrag, hoHotTrack, hoShowSortGlyphs, hoVisible, hoDisableAnimatedResize, hoAutoResizeInclCaption] Header.PopupMenu = MainForm.popupListHeader Header.SortColumn = 0 @@ -128,25 +125,31 @@ object UserManagerForm: TUserManagerForm OnHeaderClick = listUsersHeaderClick OnHotChange = listUsersHotChange OnInitNode = listUsersInitNode + Touch.InteractiveGestures = [igPan, igPressAndTap] + Touch.InteractiveGestureOptions = [igoPanSingleFingerHorizontal, igoPanSingleFingerVertical, igoPanInertia, igoPanGutter, igoParentPassthrough] Columns = < item Position = 0 Text = 'Username' - Width = 93 + Width = 43 end item Position = 1 Text = 'Host' Width = 80 + end + item + Position = 2 + Text = 'Plugin' end> end object ToolBar1: TToolBar Left = 0 - Top = 19 + Top = 20 Width = 177 Height = 22 AutoSize = True - ButtonWidth = 58 + ButtonWidth = 63 Caption = 'ToolBar1' Images = MainForm.VirtualImageListMain List = True @@ -157,20 +160,21 @@ object UserManagerForm: TUserManagerForm Left = 0 Top = 0 Caption = 'Add' + DropdownMenu = menuAdd ImageIndex = 45 ImageName = 'icons8-add' - OnClick = btnAddUserClick + Style = tbsWholeDropDown end object btnCloneUser: TToolButton - Left = 58 + Left = 72 Top = 0 Caption = 'Clone' ImageIndex = 3 ImageName = 'icons8-copy-100' - OnClick = btnAddUserClick + OnClick = menuItemUserClick end object btnDeleteUser: TToolButton - Left = 116 + Left = 135 Top = 0 Caption = 'Delete' ImageIndex = 46 @@ -178,6 +182,21 @@ object UserManagerForm: TUserManagerForm OnClick = btnDeleteUserClick end end + object editFilterUsers: TButtonedEdit + Left = 0 + Top = 42 + Width = 177 + Height = 22 + Align = alTop + Images = MainForm.VirtualImageListMain + LeftButton.ImageIndex = 30 + LeftButton.Visible = True + RightButton.ImageIndex = 193 + TabOrder = 2 + TextHint = 'Filter ...' + OnChange = editFilterUsersChange + OnRightButtonClick = editFilterUsersRightButtonClick + end end object pnlRight: TPanel AlignWithMargins = True @@ -193,69 +212,11 @@ object UserManagerForm: TUserManagerForm BevelOuter = bvNone Constraints.MinWidth = 20 TabOrder = 1 - object tlbObjects: TToolBar - Left = 0 - Top = 145 - Width = 283 - Height = 22 - AutoSize = True - ButtonWidth = 79 - Caption = 'tlbObjects' - Images = MainForm.VirtualImageListMain - List = True - ParentShowHint = False - ShowCaptions = True - ShowHint = True - TabOrder = 1 - Wrapable = False - object lblAllowAccessTo: TLabel - Left = 0 - Top = 0 - Width = 121 - Height = 22 - AutoSize = False - Caption = 'Allow access to:' - Transparent = False - Layout = tlCenter - end - object btnAddObject: TToolButton - Left = 121 - Top = 0 - Hint = 'Add object ...' - Caption = 'Add object' - ImageIndex = 45 - ImageName = 'icons8-add' - OnClick = btnAddObjectClick - end - end - object treePrivs: TVirtualStringTree - Left = 0 - Top = 167 - Width = 283 - Height = 149 - Align = alClient - Header.AutoSizeIndex = 0 - Header.MainColumn = -1 - Images = MainForm.VirtualImageListMain - IncrementalSearch = isAll - TabOrder = 2 - TreeOptions.AutoOptions = [toAutoDropExpand, toAutoTristateTracking, toAutoDeleteMovedNodes, toAutoChangeScale] - TreeOptions.MiscOptions = [toAcceptOLEDrop, toCheckSupport, toFullRepaintOnResize, toInitOnSave, toToggleOnDblClick, toWheelPanning, toEditOnClick] - TreeOptions.PaintOptions = [toShowButtons, toShowDropmark, toShowRoot, toShowTreeLines, toThemeAware, toUseBlendedImages, toUseExplorerTheme, toHideTreeLinesIfThemed] - OnChecked = treePrivsChecked - OnExpanded = treePrivsExpanded - OnGetText = treePrivsGetText - OnPaintText = treePrivsPaintText - OnGetImageIndex = treePrivsGetImageIndex - OnInitChildren = treePrivsInitChildren - OnInitNode = treePrivsInitNode - Columns = <> - end object PageControlSettings: TPageControl Left = 0 Top = 0 Width = 283 - Height = 145 + Height = 219 ActivePage = tabCredentials Align = alTop TabOrder = 0 @@ -263,43 +224,70 @@ object UserManagerForm: TUserManagerForm Caption = 'Credentials' DesignSize = ( 275 - 117) + 190) object lblUsername: TLabel Left = 3 Top = 10 - Width = 55 - Height = 13 + Width = 62 + Height = 14 Caption = 'User &name:' end object lblFromHost: TLabel Left = 3 Top = 37 - Width = 52 - Height = 13 + Width = 59 + Height = 14 Caption = 'From &host:' FocusControl = editFromHost end object lblPassword: TLabel Left = 3 Top = 64 - Width = 50 - Height = 13 + Width = 55 + Height = 14 Caption = '&Password:' FocusControl = editPassword end object lblRepeatPassword: TLabel Left = 3 - Top = 91 - Width = 88 - Height = 13 + Top = 110 + Width = 98 + Height = 14 Caption = 'Repeat password:' FocusControl = editRepeatPassword end - object editRepeatPassword: TEdit + object lblDefaultRole: TLabel + Left = 3 + Top = 166 + Width = 67 + Height = 14 + Caption = 'Default role:' + end + object lblPlugin: TLabel + Left = 3 + Top = 139 + Width = 36 + Height = 14 + Caption = 'Plugin:' + end + object lblPasswordHint: TLabel Left = 176 Top = 88 + Width = 204 + Height = 14 + Hint = + 'You changed the authentication plugin. This will reset the passw' + + 'ord, so please specify a new one.' + Caption = 'Empty password after plugin change!' + ParentShowHint = False + ShowHint = True + Visible = False + end + object editRepeatPassword: TEdit + Left = 176 + Top = 107 Width = 96 - Height = 21 + Height = 22 Anchors = [akLeft, akTop, akRight] PasswordChar = '*' TabOrder = 3 @@ -309,7 +297,7 @@ object UserManagerForm: TUserManagerForm Left = 176 Top = 61 Width = 96 - Height = 21 + Height = 22 Anchors = [akLeft, akTop, akRight] Images = MainForm.VirtualImageListMain PasswordChar = '*' @@ -324,7 +312,7 @@ object UserManagerForm: TUserManagerForm Left = 176 Top = 34 Width = 96 - Height = 21 + Height = 22 Anchors = [akLeft, akTop, akRight] Images = MainForm.VirtualImageListMain RightButton.DropDownMenu = menuHost @@ -337,51 +325,71 @@ object UserManagerForm: TUserManagerForm Left = 176 Top = 7 Width = 96 - Height = 21 + Height = 22 Anchors = [akLeft, akTop, akRight] TabOrder = 0 OnChange = Modification end + object comboDefaultRole: TComboBox + Left = 176 + Top = 163 + Width = 96 + Height = 22 + Style = csDropDownList + Anchors = [akLeft, akTop, akRight] + TabOrder = 5 + OnChange = Modification + end + object comboPlugins: TComboBox + Left = 176 + Top = 135 + Width = 96 + Height = 22 + Style = csDropDownList + Anchors = [akLeft, akTop, akRight] + TabOrder = 4 + OnChange = comboPluginsChange + end end object tabLimitations: TTabSheet Caption = 'Limitations' ImageIndex = 1 DesignSize = ( 275 - 117) + 190) object lblMaxQueries: TLabel Left = 3 Top = 10 - Width = 85 - Height = 13 + Width = 96 + Height = 14 Caption = 'Queries per hour:' end object lblMaxUpdates: TLabel Left = 3 Top = 37 - Width = 88 - Height = 13 + Width = 100 + Height = 14 Caption = 'Updates per hour:' end object lblMaxConnections: TLabel Left = 3 Top = 64 - Width = 107 - Height = 13 + Width = 122 + Height = 14 Caption = 'Connections per hour:' end object lblMaxUserConnections: TLabel Left = 3 Top = 91 - Width = 127 - Height = 13 + Width = 146 + Height = 14 Caption = 'Simultaneous connections:' end object editMaxQueries: TEdit Left = 176 Top = 7 Width = 80 - Height = 21 + Height = 22 Anchors = [akLeft, akTop, akRight] NumbersOnly = True TabOrder = 0 @@ -392,7 +400,7 @@ object UserManagerForm: TUserManagerForm Left = 176 Top = 34 Width = 80 - Height = 21 + Height = 22 Anchors = [akLeft, akTop, akRight] NumbersOnly = True TabOrder = 2 @@ -403,7 +411,7 @@ object UserManagerForm: TUserManagerForm Left = 176 Top = 61 Width = 80 - Height = 21 + Height = 22 Anchors = [akLeft, akTop, akRight] NumbersOnly = True TabOrder = 4 @@ -414,7 +422,7 @@ object UserManagerForm: TUserManagerForm Left = 176 Top = 88 Width = 80 - Height = 21 + Height = 22 Anchors = [akLeft, akTop, akRight] NumbersOnly = True TabOrder = 6 @@ -425,7 +433,7 @@ object UserManagerForm: TUserManagerForm Left = 256 Top = 7 Width = 17 - Height = 21 + Height = 22 Anchors = [akTop, akRight] Associate = editMaxQueries Max = 2147483647 @@ -437,7 +445,7 @@ object UserManagerForm: TUserManagerForm Left = 256 Top = 34 Width = 17 - Height = 21 + Height = 22 Anchors = [akTop, akRight] Associate = editMaxUpdates Max = 2147483647 @@ -448,7 +456,7 @@ object UserManagerForm: TUserManagerForm Left = 256 Top = 61 Width = 17 - Height = 21 + Height = 22 Anchors = [akTop, akRight] Associate = editMaxConnections Max = 2147483647 @@ -459,7 +467,7 @@ object UserManagerForm: TUserManagerForm Left = 256 Top = 88 Width = 17 - Height = 21 + Height = 22 Anchors = [akTop, akRight] Associate = editMaxUserConnections Max = 2147483647 @@ -472,43 +480,43 @@ object UserManagerForm: TUserManagerForm ImageIndex = 2 DesignSize = ( 275 - 117) + 190) object lblCipher: TLabel Left = 3 Top = 36 - Width = 35 - Height = 13 + Width = 38 + Height = 14 Caption = '&Cipher:' FocusControl = editCipher end object lblIssuer: TLabel Left = 3 Top = 62 - Width = 34 - Height = 13 + Width = 36 + Height = 14 Caption = '&Issuer:' FocusControl = editIssuer end object lblSubject: TLabel Left = 3 Top = 89 - Width = 40 - Height = 13 + Width = 46 + Height = 14 Caption = '&Subject:' FocusControl = editSubject end object lblSSL: TLabel Left = 3 Top = 9 - Width = 61 - Height = 13 + Width = 69 + Height = 14 Caption = '&Require SSL:' end object editCipher: TEdit Left = 176 Top = 33 Width = 96 - Height = 21 + Height = 22 Anchors = [akLeft, akTop, akRight] TabOrder = 1 Text = 'editCipher' @@ -518,7 +526,7 @@ object UserManagerForm: TUserManagerForm Left = 176 Top = 59 Width = 96 - Height = 21 + Height = 22 Anchors = [akLeft, akTop, akRight] TabOrder = 2 Text = 'editIssuer' @@ -528,7 +536,7 @@ object UserManagerForm: TUserManagerForm Left = 176 Top = 86 Width = 96 - Height = 21 + Height = 22 Anchors = [akLeft, akTop, akRight] TabOrder = 3 Text = 'editSubject' @@ -538,7 +546,7 @@ object UserManagerForm: TUserManagerForm Left = 176 Top = 6 Width = 96 - Height = 21 + Height = 22 Style = csDropDownList Anchors = [akLeft, akTop, akRight] TabOrder = 0 @@ -551,6 +559,91 @@ object UserManagerForm: TUserManagerForm end end end + object PageControlAccess: TPageControl + Left = 0 + Top = 219 + Width = 283 + Height = 97 + ActivePage = tabPrivileges + Align = alClient + TabOrder = 1 + object tabPrivileges: TTabSheet + Caption = 'Privileges' + object treePrivs: TVirtualStringTree + Left = 0 + Top = 22 + Width = 275 + Height = 46 + Align = alClient + Header.AutoSizeIndex = 0 + Header.Height = 14 + Header.MainColumn = -1 + Images = MainForm.VirtualImageListMain + IncrementalSearch = isAll + TabOrder = 0 + TreeOptions.AutoOptions = [toAutoDropExpand, toAutoTristateTracking, toAutoDeleteMovedNodes, toAutoChangeScale] + TreeOptions.MiscOptions = [toAcceptOLEDrop, toCheckSupport, toFullRepaintOnResize, toInitOnSave, toToggleOnDblClick, toWheelPanning, toEditOnClick] + TreeOptions.PaintOptions = [toShowButtons, toShowDropmark, toShowRoot, toShowTreeLines, toThemeAware, toUseBlendedImages, toUseExplorerTheme, toHideTreeLinesIfThemed] + OnChecked = treePrivsChecked + OnExpanded = treePrivsExpanded + OnGetText = treePrivsGetText + OnPaintText = treePrivsPaintText + OnGetImageIndex = treePrivsGetImageIndex + OnInitChildren = treePrivsInitChildren + OnInitNode = treePrivsInitNode + Touch.InteractiveGestures = [igPan, igPressAndTap] + Touch.InteractiveGestureOptions = [igoPanSingleFingerHorizontal, igoPanSingleFingerVertical, igoPanInertia, igoPanGutter, igoParentPassthrough] + Columns = <> + end + object tlbObjects: TToolBar + Left = 0 + Top = 0 + Width = 275 + Height = 22 + AutoSize = True + ButtonWidth = 88 + Caption = 'tlbObjects' + Images = MainForm.VirtualImageListMain + List = True + ParentShowHint = False + ShowCaptions = True + ShowHint = True + TabOrder = 1 + Wrapable = False + object btnAddObject: TToolButton + Left = 0 + Top = 0 + Hint = 'Add object ...' + Caption = 'Add object' + ImageIndex = 45 + ImageName = 'icons8-add' + OnClick = btnAddObjectClick + end + end + end + object tabRoles: TTabSheet + Caption = 'Roles' + ImageIndex = 1 + object ValueListEditorRoles: TValueListEditor + Left = 0 + Top = 0 + Width = 275 + Height = 68 + Align = alClient + Strings.Strings = ( + 'Roll=off') + TabOrder = 0 + TitleCaptions.Strings = ( + 'Role name' + 'Assigned') + OnGetPickList = ValueListEditorRolesGetPickList + OnSetEditText = ValueListEditorRolesSetEditText + ColWidths = ( + 150 + 119) + end + end + end end object btnDiscard: TButton Left = 280 @@ -638,4 +731,18 @@ object UserManagerForm: TUserManagerForm end end end + object menuAdd: TPopupMenu + Images = MainForm.VirtualImageListMain + OnPopup = menuAddPopup + Left = 80 + Top = 280 + object menuItemUser: TMenuItem + Caption = 'User' + OnClick = menuItemUserClick + end + object menuItemRole: TMenuItem + Caption = 'Role' + OnClick = menuItemRoleClick + end + end end diff --git a/source/usermanager.pas b/source/usermanager.pas index 8c908ccfa..878e5f405 100644 --- a/source/usermanager.pas +++ b/source/usermanager.pas @@ -4,25 +4,16 @@ interface uses - Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ComCtrls, StdCtrls, - ExtCtrls, ToolWin, ClipBrd, Generics.Collections, Generics.Defaults, SynRegExpr, extra_controls, - dbconnection, dbstructures, apphelpers, VirtualTrees, Menus, gnugettext; + Winapi.Windows, Winapi.Messages, System.SysUtils, System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ComCtrls, Vcl.StdCtrls, + Vcl.ExtCtrls, Vcl.ToolWin, Vcl.ClipBrd, System.Generics.Collections, System.Generics.Defaults, SynRegExpr, extra_controls, + dbconnection, dbstructures, dbstructures.mysql, apphelpers, VirtualTrees.BaseTree, VirtualTrees.Types, VirtualTrees, VirtualTrees.EditLink, Vcl.Menus, gnugettext, + VirtualTrees.BaseAncestorVCL, VirtualTrees.AncestorVCL, StrUtils, Vcl.Grids, + Vcl.ValEdit; {$I const.inc} type - TUserProblem = (upNone, upEmptyPassword, upInvalidPasswordLen, upSkipNameResolve, upUnknown); - - TUser = class(TObject) - Username, Host, Password, Cipher, Issuer, Subject: String; - MaxQueries, MaxUpdates, MaxConnections, MaxUserConnections, SSL: Integer; - Problem: TUserProblem; - function HostRequiresNameResolve: Boolean; - end; - PUser = ^TUser; - TUserList = TObjectList; - TPrivObj = class(TObject) GrantCode: String; DBObj: TDBObject; @@ -38,18 +29,45 @@ TPrivComparer = class(TComparer) function Compare(const Left, Right: TPrivObj): Integer; override; end; + TUserProblem = (upNone, upEmptyPassword, upInvalidPasswordLen, upSkipNameResolve, upUnknown); + + TUser = class(TObject) + Username, Host, Password, Cipher, Issuer, Subject, DefaultRole, Plugin: String; + MaxQueries, MaxUpdates, MaxConnections, MaxUserConnections, SSL: Integer; + Problem: TUserProblem; + IsRole: Boolean; + Roles: TStringList; + public + class var RoleNo: String; + class var RoleYes: String; + class var RoleYesAdmin: String; + constructor Create; + destructor Destroy; override; + function HostRequiresNameResolve: Boolean; + procedure ParseSettings(GrantOrCreate: String; Priv: TPrivObj); + function IsUser: Boolean; + function AssignedRolesCount: Integer; + end; + PUser = ^TUser; + TUserList = class(TObjectList) + public + function GetRoleNames: TStringList; overload; + procedure GetRoleNames(Strings: TStrings); overload; + function GetDefaultRoles(ExcludeRole: TUser): TStringList; + end; + EInputError = class(Exception); TUserManagerForm = class(TExtForm) btnCancel: TButton; btnSave: TButton; + comboPlugins: TComboBox; + lblPasswordHint: TLabel; + lblPlugin: TLabel; pnlLeft: TPanel; listUsers: TVirtualStringTree; Splitter1: TSplitter; pnlRight: TPanel; - tlbObjects: TToolBar; - btnAddObject: TToolButton; - treePrivs: TVirtualStringTree; btnDiscard: TButton; lblUsers: TLabel; ToolBar1: TToolBar; @@ -57,7 +75,6 @@ TUserManagerForm = class(TExtForm) btnDeleteUser: TToolButton; btnCloneUser: TToolButton; lblWarning: TLabel; - lblAllowAccessTo: TLabel; menuHost: TPopupMenu; menuHost1: TMenuItem; menuHostLocal4: TMenuItem; @@ -107,10 +124,23 @@ TUserManagerForm = class(TExtForm) editSubject: TEdit; comboSSL: TComboBox; lblSSL: TLabel; + editFilterUsers: TButtonedEdit; + menuAdd: TPopupMenu; + menuItemUser: TMenuItem; + menuItemRole: TMenuItem; + PageControlAccess: TPageControl; + tabPrivileges: TTabSheet; + tabRoles: TTabSheet; + treePrivs: TVirtualStringTree; + tlbObjects: TToolBar; + btnAddObject: TToolButton; + ValueListEditorRoles: TValueListEditor; + lblDefaultRole: TLabel; + comboDefaultRole: TComboBox; + procedure comboPluginsChange(Sender: TObject); procedure FormCreate(Sender: TObject); - procedure FormDestroy(Sender: TObject); procedure FormShow(Sender: TObject); - procedure btnAddUserClick(Sender: TObject); + procedure menuItemUserClick(Sender: TObject); procedure btnDeleteUserClick(Sender: TObject); procedure listUsersFocusChanged(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex); @@ -153,18 +183,33 @@ TUserManagerForm = class(TExtForm) procedure listUsersHotChange(Sender: TBaseVirtualTree; OldNode, NewNode: PVirtualNode); procedure udMaxQueriesClick(Sender: TObject; Button: TUDBtnType); procedure comboSSLChange(Sender: TObject); - procedure FormResize(Sender: TObject); + procedure editFilterUsersRightButtonClick(Sender: TObject); + procedure editFilterUsersChange(Sender: TObject); + procedure menuItemRoleClick(Sender: TObject); + procedure menuAddPopup(Sender: TObject); + procedure ValueListEditorRolesGetPickList(Sender: TObject; + const KeyName: string; Values: TStrings); + procedure ValueListEditorRolesSetEditText(Sender: TObject; ACol, + ARow: LongInt; const Value: string); private { Private declarations } FUsers: TUserList; - FModified, FAdded: Boolean; + FModified, FAdded, FPluginModified: Boolean; + FHasIsRole, FHasDefaultRole: Boolean; + FHasPlugin: Boolean; + FPlugins: TStringList; FCloneGrants: TStringList; FPrivObjects: TPrivObjList; FPrivsGlobal, FPrivsDb, FPrivsTable, FPrivsRoutine, FPrivsColumn: TStringList; FConnection: TDBConnection; + FColorReadPriv, FColorWritePriv, FColorAdminPriv: TColor; + FSQLPluginPrefix, FSQLPluginPassPrefix: String; procedure SetModified(Value: Boolean); + procedure SetPluginModified(Value: Boolean); property Modified: Boolean read FModified write SetModified; + property PluginModified: Boolean read FPluginModified write SetPluginModified; function GetPrivByNode(Node: PVirtualNode): TPrivObj; + function SelectUserNode(User: TUser): Boolean; public { Public declarations } end; @@ -209,55 +254,59 @@ procedure TUserManagerForm.FormCreate(Sender: TObject); // Restore GUI setup HasSizeGrip := True; lblWarning.Font.Color := clRed; - Width := AppSettings.ReadInt(asUsermanagerWindowWidth); - Height := AppSettings.ReadInt(asUsermanagerWindowHeight); - pnlLeft.Width := AppSettings.ReadInt(asUsermanagerListWidth); + PrivsRead := Explode(',', 'SELECT,SHOW VIEW,SHOW DATABASES,PROCESS,EXECUTE'); + PrivsWrite := Explode(',', 'ALTER,CREATE,DROP,DELETE,UPDATE,INSERT,ALTER ROUTINE,CREATE ROUTINE,CREATE TEMPORARY TABLES,'+ + 'CREATE VIEW,INDEX,TRIGGER,EVENT,REFERENCES,CREATE TABLESPACE,DELETE HISTORY'); + PrivsAdmin := Explode(',', 'RELOAD,SHUTDOWN,REPLICATION CLIENT,REPLICATION SLAVE,SUPER,LOCK TABLES,GRANT,FILE,CREATE USER,'+ + 'BINLOG ADMIN,BINLOG REPLAY,CONNECTION ADMIN,FEDERATED ADMIN,READ_ONLY ADMIN,REPLICATION MASTER ADMIN,'+ + 'REPLICATION SLAVE ADMIN,SET USER,SLAVE MONITOR'); FixVT(listUsers); FixVT(treePrivs); - Mainform.RestoreListSetup(listUsers); - PrivsRead := Explode(',', 'SELECT,SHOW VIEW,SHOW DATABASES,PROCESS,EXECUTE'); - PrivsWrite := Explode(',', 'ALTER,CREATE,DROP,DELETE,UPDATE,INSERT,ALTER ROUTINE,CREATE ROUTINE,CREATE TEMPORARY TABLES,CREATE VIEW,INDEX,TRIGGER,EVENT,REFERENCES,CREATE TABLESPACE'); - PrivsAdmin := Explode(',', 'RELOAD,SHUTDOWN,REPLICATION CLIENT,REPLICATION SLAVE,SUPER,LOCK TABLES,GRANT,FILE,CREATE USER'); + FHasIsRole := False; + FHasDefaultRole := False; + menuItemUser.ImageIndex := ICONINDEX_USER; + menuItemRole.ImageIndex := ICONINDEX_ROLE; end; - -procedure TUserManagerForm.FormDestroy(Sender: TObject); -begin - // FormDestroy: Save GUI setup - AppSettings.WriteInt(asUsermanagerWindowWidth, Width); - AppSettings.WriteInt(asUsermanagerWindowHeight, Height); - AppSettings.WriteInt(asUsermanagerListWidth, pnlLeft.Width); - Mainform.SaveListSetup(listUsers); -end; - - -procedure TUserManagerForm.FormResize(Sender: TObject); +procedure TUserManagerForm.comboPluginsChange(Sender: TObject); begin - // Manually right align "Add object" button - lblAllowAccessTo.Width := pnlRight.Width - btnAddObject.Width; + PluginModified := True; + Modification(Sender); end; procedure TUserManagerForm.FormShow(Sender: TObject); var - Version: Integer; + Version, i: Integer; Users: TDBQuery; U: TUser; - tmp, PasswordExpr: String; + tmp, PasswordExpr, IsRoleExpr, DefaultRoleExpr, PluginExpr: String; SkipNameResolve, - HasPassword, - HasAuthString, - PasswordLengthMatters: Boolean; + HasPassword, HasAuthString: Boolean; + PasswordLengthMatters, PasswordLengthValid: Boolean; UserTableColumns: TStringList; -function InitPrivList(Values: String): TStringList; -begin - Result := Explode(',', Values); - Result.Sorted := True; - Result.Duplicates := dupIgnore; -end; + function InitPrivList(Values: String): TStringList; + begin + Result := Explode(',', Values); + Result.Sorted := True; // ensures dupIgnore works + Result.Duplicates := dupIgnore; + end; begin + Width := AppSettings.ReadIntDpiAware(asUsermanagerWindowWidth, Self); + Height := AppSettings.ReadIntDpiAware(asUsermanagerWindowHeight, Self); + pnlLeft.Width := AppSettings.ReadIntDpiAware(asUsermanagerListWidth, Self); + RestoreListSetup(listUsers); + FColorReadPriv := clGreen; + FColorWritePriv := clMaroon; + FColorAdminPriv := clNavy; + if ThemeIsDark then begin + FColorReadPriv := ColorAdjustBrightness(FColorReadPriv, 128); + FColorWritePriv := ColorAdjustBrightness(FColorWritePriv, 128); + FColorAdminPriv := ColorAdjustBrightness(FColorAdminPriv, 128); + end; + FConnection := Mainform.ActiveConnection; Version := FConnection.ServerVersionInt; FPrivsGlobal := InitPrivList('FILE,PROCESS,RELOAD,SHUTDOWN'); @@ -265,7 +314,8 @@ function InitPrivList(Values: String): TStringList; FPrivsTable := InitPrivList('ALTER,CREATE,DELETE,DROP,GRANT,INDEX'); FPrivsRoutine := InitPrivList('GRANT'); FPrivsColumn := InitPrivList('INSERT,SELECT,UPDATE,REFERENCES'); - PasswordLengthMatters := True; + FSQLPluginPrefix := IfThen(FConnection.Parameters.IsMariaDB, 'VIA', 'WITH'); + FSQLPluginPassPrefix := IfThen(FConnection.Parameters.IsMariaDB, 'USING', 'BY'); if Version >= 40002 then begin FPrivsGlobal.Add('REPLICATION CLIENT'); @@ -298,10 +348,29 @@ function InitPrivList(Values: String): TStringList; PrivsDb.Add('PROXY'); end; } - if Version >= 80000 then begin - // MySQL 8 has predefined length of hashed passwords only with - // mysql_native_password plugin enabled users - PasswordLengthMatters := False; + // See https://mariadb.com/kb/en/changes-improvements-in-mariadb-105/#privileges-made-more-granular + if FConnection.Parameters.IsMariaDB then begin + if Version > 100502 then begin + i := FPrivsGlobal.IndexOf('REPLICATION CLIENT'); + if i > -1 then + FPrivsGlobal.Delete(i); + FPrivsGlobal.Add('BINLOG ADMIN'); // replaces REPLICATION CLIENT + FPrivsGlobal.Add('BINLOG REPLAY'); + FPrivsGlobal.Add('CONNECTION ADMIN'); + FPrivsGlobal.Add('FEDERATED ADMIN'); + FPrivsGlobal.Add('READ_ONLY ADMIN'); + FPrivsGlobal.Add('REPLICATION MASTER ADMIN'); + FPrivsGlobal.Add('REPLICATION SLAVE ADMIN'); + FPrivsGlobal.Add('SET USER'); + end; + if Version >= 100509 then begin + FPrivsGlobal.Add('SLAVE MONITOR'); + end; + if Version >= 100304 then begin + FPrivsGlobal.Add('DELETE HISTORY'); + end; + + end; FPrivsTable.AddStrings(FPrivsColumn); @@ -327,12 +396,13 @@ function InitPrivList(Values: String): TStringList; tmp := FConnection.GetSessionVariable('skip_name_resolve'); SkipNameResolve := LowerCase(tmp) = 'on'; - FConnection.Query('FLUSH PRIVILEGES'); - // Peek into user table structure, and find out where the password hash is stored UserTableColumns := FConnection.GetCol('SHOW COLUMNS FROM '+FConnection.QuoteIdent('mysql')+'.'+FConnection.QuoteIdent('user')); HasPassword := UserTableColumns.IndexOf('password') > -1; HasAuthString := UserTableColumns.IndexOf('authentication_string') > -1; + FHasIsRole := UserTableColumns.IndexOf('is_role') > -1; + FHasDefaultRole := UserTableColumns.IndexOf('default_role') > -1; + FHasPlugin := UserTableColumns.IndexOf('plugin') > -1; if HasPassword and (not HasAuthString) then PasswordExpr := 'password' else if (not HasPassword) and HasAuthString then @@ -342,32 +412,56 @@ function InitPrivList(Values: String): TStringList; else Raise Exception.Create(_('No password hash column available')); PasswordExpr := PasswordExpr + ' AS ' + FConnection.QuoteIdent('password'); + IsRoleExpr := IfThen(FHasIsRole, 'is_role', FConnection.EscapeString('N')+' AS is_role'); + DefaultRoleExpr := IfThen(FHasDefaultRole, 'default_role', FConnection.EscapeString('')+' AS default_role'); + PluginExpr := IfThen(FHasPlugin, 'plugin', FConnection.EscapeString('')+' AS plugin'); + if FConnection.SqlProvider.Has(qGetAuthPlugins) then + FPlugins := FConnection.GetCol(FConnection.SqlProvider.GetSql(qGetAuthPlugins)) + else + FPlugins := TStringList.Create; Users := FConnection.GetResults( - 'SELECT '+FConnection.QuoteIdent('user')+', '+FConnection.QuoteIdent('host')+', '+PasswordExpr+' '+ + 'SELECT '+ + FConnection.QuoteIdent('user') + ', ' + + FConnection.QuoteIdent('host') + ', ' + + PasswordExpr + ', ' + + IsRoleExpr + ', ' + + DefaultRoleExpr + ', ' + + PluginExpr + ' ' + 'FROM '+FConnection.QuoteIdent('mysql')+'.'+FConnection.QuoteIdent('user') ); FUsers := TUserList.Create(True); + ValueListEditorRoles.Strings.Clear; while not Users.Eof do begin U := TUser.Create; U.Username := Users.Col('user'); U.Host := Users.Col('host'); U.Password := Users.Col('password'); + U.IsRole := UpperCase(Users.Col('is_role')) = 'Y'; + U.DefaultRole := Users.Col('default_role'); + U.Plugin := Users.Col('plugin'); U.Problem := upNone; - if Length(U.Password) = 0 then - U.Problem := upEmptyPassword; - if PasswordLengthMatters and (not (Length(U.Password) in [0, 16, 41])) then - U.Problem := upInvalidPasswordLen - else if SkipNameResolve and U.HostRequiresNameResolve then - U.Problem := upSkipNameResolve; + if U.IsUser then begin + if Length(U.Password) = 0 then + U.Problem := upEmptyPassword; + PasswordLengthMatters := ExecRegExpr('(mysql_native_password|mysql_old_password)', U.Plugin) or (not FHasPlugin); + PasswordLengthValid := Byte(Length(U.Password)) in [0, 16, 41]; + if PasswordLengthMatters and (not PasswordLengthValid) then + U.Problem := upInvalidPasswordLen + else if SkipNameResolve and U.HostRequiresNameResolve then + U.Problem := upSkipNameResolve; + end; FUsers.Add(U); Users.Next; end; + listUsers.Clear; InvalidateVT(listUsers, VTREE_NOTLOADED, False); FPrivObjects := TPrivObjList.Create(TPrivComparer.Create, True); Modified := False; + PluginModified := False; FAdded := False; + tabRoles.TabVisible := FHasIsRole; listUsers.OnFocusChanged(listUsers, listUsers.FocusedNode, listUsers.FocusedColumn); except on E:EDbError do begin @@ -396,7 +490,11 @@ procedure TUserManagerForm.FormClose(Sender: TObject; var Action: TCloseAction); FreeAndNil(FPrivsTable); FreeAndNil(FPrivsRoutine); FreeAndNil(FPrivsColumn); - Action := caFree; + // Save GUI setup + AppSettings.WriteIntDpiAware(asUsermanagerWindowWidth, Self, Width); + AppSettings.WriteIntDpiAware(asUsermanagerWindowHeight, Self, Height); + AppSettings.WriteIntDpiAware(asUsermanagerListWidth, Self, pnlLeft.Width); + SaveListSetup(listUsers); end; @@ -408,6 +506,23 @@ procedure TUserManagerForm.SetModified(Value: Boolean); listUsers.Invalidate; end; +procedure TUserManagerForm.SetPluginModified(Value: Boolean); +var + User: PUser; +begin + if not Assigned(listUsers.FocusedNode) then + Exit; + FPluginModified := Value; + if not FAdded then begin + lblPasswordHint.Visible := FPluginModified; + if Value then begin + User := listUsers.GetNodeData(listUsers.FocusedNode); + User.Password := ''; + editPassword.TextHint := ''; + end; + end; +end; + procedure TUserManagerForm.Modification(Sender: TObject); var @@ -435,6 +550,20 @@ procedure TUserManagerForm.udMaxQueriesClick(Sender: TObject; Button: TUDBtnType end; +procedure TUserManagerForm.ValueListEditorRolesGetPickList(Sender: TObject; + const KeyName: string; Values: TStrings); +begin + Values.Add(TUser.RoleNo); + Values.Add(TUser.RoleYes); + Values.Add(TUser.RoleYesAdmin); +end; + +procedure TUserManagerForm.ValueListEditorRolesSetEditText(Sender: TObject; + ACol, ARow: LongInt; const Value: string); +begin + Modification(Sender); +end; + procedure TUserManagerForm.listUsersAfterPaint(Sender: TBaseVirtualTree; TargetCanvas: TCanvas); begin // Background painting for sorted column @@ -476,6 +605,8 @@ procedure TUserManagerForm.listUsersFocusChanging(Sender: TBaseVirtualTree; OldN end; mrNo: begin Allowed := True; + Modified := False; + PluginModified := False; if FAdded then btnDeleteUser.Click; end; @@ -490,37 +621,68 @@ procedure TUserManagerForm.listUsersFocusChanged(Sender: TBaseVirtualTree; Node: var P, Ptmp, PCol: TPrivObj; User: PUser; - UserHost, RequireClause, WithClause, Msg: String; - Grants, AllPNames, Cols: TStringList; + UserHost, UserHostRx, Msg, CreateUser, RxQuotes: String; + Grants, AllPNames, Cols, RoleNames, DefaultRoles: TStringList; rxTemp, rxGrant: TRegExpr; i, j: Integer; UserSelected: Boolean; Obj: TDBObject; begin // Parse and display privileges of focused user + listUsers.TrySetFocus; // Steal focus from roles, prevents empty cell bug UserSelected := Assigned(Node); + User := nil; FPrivObjects.Clear; Caption := MainForm.actUserManager.Caption; + // Credentials tab editUsername.Clear; editFromHost.Clear; editPassword.Clear; editPassword.TextHint := ''; editRepeatPassword.Clear; + comboPlugins.Items.Clear; + comboPlugins.Items.Add(_('None')); + comboPlugins.Items.AddStrings(FPlugins); + comboPlugins.ItemIndex := 0; + comboDefaultRole.Items.Clear; + comboDefaultRole.Items.Add(_('None')); + FUsers.GetRoleNames(comboDefaultRole.Items); + comboDefaultRole.ItemIndex := 0; + // Limitations tab udMaxQueries.Position := 0; udMaxUpdates.Position := 0; udMaxConnections.Position := 0; udMaxUserConnections.Position := 0; + // SSL tab comboSSL.ItemIndex := 0; comboSSL.OnChange(Sender); editCipher.Clear; editIssuer.Clear; editSubject.Clear; + // Page control + tabPrivileges.Caption := _('Privileges'); + tabRoles.Caption := _('Roles'); + + // All possible quote chars, escaped for RegExpr. Todo: use in all relevant expressions. + RxQuotes := '['+QuoteRegExprMetaChars(FConnection.QuoteChars + FConnection.StringQuoteChar)+']'; if UserSelected then begin User := Sender.GetNodeData(Node); - UserHost := FConnection.EscapeString(User.Username)+'@'+FConnection.EscapeString(User.Host); + UserHost := FConnection.EscapeString(User.Username); + UserHostRx := RxQuotes + '?' + QuoteRegExprMetaChars(User.Username) + RxQuotes + '?'; + if User.IsUser then begin + UserHost := UserHost + '@' + FConnection.EscapeString(User.Host); + UserHostRx := UserHostRx + '@' + RxQuotes + '?' + QuoteRegExprMetaChars(User.Host) + RxQuotes + '?'; + end; editUsername.Text := User.Username; editFromHost.Text := User.Host; + i := comboPlugins.Items.IndexOf(User.Plugin); + if i > -1 then + comboPlugins.ItemIndex := i; + i := comboDefaultRole.Items.IndexOf(User.DefaultRole); + if i > -1 then + comboDefaultRole.ItemIndex := i; + Caption := Caption + ' - ' + User.Username; AllPNames := TStringList.Create; @@ -540,11 +702,11 @@ procedure TUserManagerForm.listUsersFocusChanged(Sender: TBaseVirtualTree; Node: Grants.Add('GRANT USAGE ON *.* TO '+UserHost); end; end else try - Grants := FConnection.GetCol('SHOW GRANTS FOR '+FConnection.EscapeString(User.Username)+'@'+FConnection.EscapeString(User.Host)); + Grants := FConnection.GetCol('SHOW GRANTS FOR '+UserHost); except on E:EDbError do begin Msg := E.Message; - if FConnection.LastErrorCode = 1141 then begin + if FConnection.LastErrorCode = ER_NONEXISTING_GRANT then begin // Disable this user node lately, for old server which do not show skip-name-resolve variable Msg := Msg + CRLF + CRLF + f_('Starting the server without %s may solve this issue.', ['--skip-name-resolve']); User.Problem := upUnknown; @@ -552,6 +714,7 @@ procedure TUserManagerForm.listUsersFocusChanged(Sender: TBaseVirtualTree; Node: end; MessageDialog(Msg, mtError, [mbOK]); FModified := False; + FPluginModified := False; SelectNode(listUsers, nil); Exit; end; @@ -581,8 +744,8 @@ procedure TUserManagerForm.listUsersFocusChanged(Sender: TBaseVirtualTree; Node: // http://dev.mysql.com/doc/refman/5.7/en/show-grants.html // As of MySQL 5.7.6, SHOW GRANTS output does not include IDENTIFIED BY PASSWORD clauses. // Use the SHOW CREATE USER statement instead. See Section 14.7.5.12, "SHOW CREATE USER Syntax". - if (FConnection.Parameters.IsMySQL and (FConnection.ServerVersionInt < 50706)) - or (not FConnection.Parameters.IsMySQL) then begin + if (FConnection.Parameters.IsMySQL(False) and (FConnection.ServerVersionInt < 50706)) + or (not FConnection.Parameters.IsMySQL(False)) then begin if not FAdded then begin editPassword.TextHint := FConnection.UnescapeString(rxGrant.Match[10]); // Set password for changed user, to silence the error message about invalid length @@ -626,7 +789,7 @@ procedure TUserManagerForm.listUsersFocusChanged(Sender: TBaseVirtualTree; Node: P.OrgPrivs.AddStrings(P.AllPrivileges); P.OrgPrivs.Delete(P.OrgPrivs.IndexOf('GRANT')); end else begin - rxTemp.Expression := '\b('+ImplodeStr('|', AllPnames)+')(\s+\(([^\)]+)\))?,'; + rxTemp.Expression := '\b('+Implode('|', AllPnames)+')(\s+\(([^\)]+)\))?,'; if rxTemp.Exec(rxGrant.Match[1]+',') then while True do begin if rxTemp.Match[3] = '' then P.OrgPrivs.Add(rxTemp.Match[1]) @@ -649,7 +812,7 @@ procedure TUserManagerForm.listUsersFocusChanged(Sender: TBaseVirtualTree; Node: PCol.DBObj.NodeType := lntColumn; PCol.DBObj.Database := P.DBObj.Database; PCol.DBObj.Name := P.DBObj.Name; - PCol.DBObj.Column := Trim(Cols[j]); + PCol.DBObj.Column := FConnection.DeQuoteIdent(Trim(Cols[j])); PCol.AllPrivileges := FPrivsColumn; FPrivObjects.Add(PCol); end; @@ -665,68 +828,65 @@ procedure TUserManagerForm.listUsersFocusChanged(Sender: TBaseVirtualTree; Node: end; - // REQUIRE SSL X509 ISSUER '456' SUBJECT '789' CIPHER '123' NONE - rxTemp.Expression := '\sREQUIRE\s+(.+)'; - if rxTemp.Exec(rxGrant.Match[11]) then begin - RequireClause := rxTemp.Match[1]; - User.SSL := 0; - User.Cipher := ''; - User.Issuer := ''; - User.Subject := ''; - rxTemp.Expression := '\bSSL\b'; - if rxTemp.Exec(RequireClause) then - User.SSL := 1; - rxTemp.Expression := '\bX509\b'; - if rxTemp.Exec(RequireClause) then - User.SSL := 2; - rxTemp.Expression := '\bCIPHER\s+''([^'']+)'; - if rxTemp.Exec(RequireClause) then - User.Cipher := rxTemp.Match[1]; - rxTemp.Expression := '\bISSUER\s+''([^'']+)'; - if rxTemp.Exec(RequireClause) then - User.Issuer := rxTemp.Match[1]; - rxTemp.Expression := '\bSUBJECT\s+''([^'']+)'; - if rxTemp.Exec(RequireClause) then - User.Subject := rxTemp.Match[1]; - if IsNotEmpty(User.Cipher) or IsNotEmpty(User.Issuer) or IsNotEmpty(User.Subject) then - User.SSL := 3; - comboSSL.ItemIndex := User.SSL; - comboSSL.OnChange(Sender); - editCipher.Text := User.Cipher; - editIssuer.Text := User.Issuer; - editSubject.Text := User.Subject; - end; - - // WITH .. GRANT OPTION - // MAX_QUERIES_PER_HOUR 20 MAX_UPDATES_PER_HOUR 10 MAX_CONNECTIONS_PER_HOUR 5 MAX_USER_CONNECTIONS 2 - rxTemp.Expression := '\sWITH\s+(.+)'; - if rxTemp.Exec(rxGrant.Match[11]) then begin - WithClause := rxTemp.Match[1]; - if ExecRegExpr('\bGRANT\s+OPTION\b', WithClause) then - P.OrgPrivs.Add('GRANT'); - rxTemp.Expression := '\bMAX_QUERIES_PER_HOUR\s+(\d+)\b'; - if rxTemp.Exec(WithClause) then - User.MaxQueries := MakeInt(rxTemp.Match[1]); - rxTemp.Expression := '\bMAX_UPDATES_PER_HOUR\s+(\d+)\b'; - if rxTemp.Exec(WithClause) then - User.MaxUpdates := MakeInt(rxTemp.Match[1]); - rxTemp.Expression := '\bMAX_CONNECTIONS_PER_HOUR\s+(\d+)\b'; - if rxTemp.Exec(WithClause) then - User.MaxConnections := MakeInt(rxTemp.Match[1]); - rxTemp.Expression := '\bMAX_USER_CONNECTIONS\s+(\d+)\b'; - if rxTemp.Exec(WithClause) then - User.MaxUserConnections := MakeInt(rxTemp.Match[1]); - udMaxQueries.Position := User.MaxQueries; - udMaxUpdates.Position := User.MaxUpdates; - udMaxConnections.Position := User.MaxConnections; - udMaxUserConnections.Position := User.MaxUserConnections; - end; + User.ParseSettings(rxGrant.Match[11], P); if (P.OrgPrivs.Count = 0) and (P.DBObj.NodeType = lntTable) then FPrivObjects.Remove(P); end; end; + // Find roles assigned to user or role: + // GRANT role_admin TO 'root'@'127.0.0.1'; + // GRANT 'role space' TO 'root'@'127.0.0.1'; + // GRANT role_space to 'role_admin' WITH ADMIN OPTION; + DefaultRoles := FUsers.GetDefaultRoles(User^); + User.Roles.Assign(DefaultRoles); + RoleNames := FUsers.GetRoleNames; + for i:=0 to RoleNames.Count-1 do begin + RoleNames[i] := QuoteRegExprMetaChars(RoleNames[i]); + end; + rxGrant.Expression := '^GRANT\s+'+RxQuotes+'?('+Implode('|', RoleNames)+')'+RxQuotes+'?\s+'+ + 'TO\s+'+UserHostRx+'(\s+WITH ADMIN OPTION)?$'; + for i:=0 to Grants.Count-1 do begin + // Find selected priv objects via regular expression + if not rxGrant.Exec(Grants[i]) then begin + Continue; + end; + j := User.Roles.IndexOfName(rxGrant.Match[1]); + if j > -1 then begin + if rxGrant.MatchLen[2] > 0 then + User.Roles.ValueFromIndex[j] := User.RoleYesAdmin + else + User.Roles.ValueFromIndex[j] := User.RoleYes; + end; + end; + ValueListEditorRoles.BeginUpdate; + ValueListEditorRoles.Strings.Assign(User.Roles); + ValueListEditorRoles.EndUpdate; + DefaultRoles.Free; + + // Parse general user options + CreateUser := ''; + if User.IsUser then try + CreateUser := FConnection.GetVar('SHOW CREATE USER '+UserHost); + User.ParseSettings(CreateUser, nil); + except + on E:EDbError do; + end; + + udMaxQueries.Position := User.MaxQueries; + udMaxUpdates.Position := User.MaxUpdates; + udMaxConnections.Position := User.MaxConnections; + udMaxUserConnections.Position := User.MaxUserConnections; + comboSSL.ItemIndex := User.SSL; + comboSSL.OnChange(comboSSL); + editCipher.Text := User.Cipher; + editIssuer.Text := User.Issuer; + editSubject.Text := User.Subject; + tabPrivileges.Caption := _('Privileges') + ' (' + FPrivObjects.Count.ToString + ')'; + tabRoles.Caption := _('Roles') + ' (' + User.AssignedRolesCount.ToString + ')'; + + // Generate grant code for column privs by hand for Ptmp in FPrivObjects do begin if Ptmp.DBObj.NodeType = lntColumn then begin @@ -750,25 +910,30 @@ procedure TUserManagerForm.listUsersFocusChanged(Sender: TBaseVirtualTree; Node: // Populate privilege tree Modified := False; + PluginModified := False; treePrivs.FocusedNode := nil; treePrivs.Clear; treePrivs.RootNodeCount := FPrivObjects.Count; - treePrivs.ReinitNode(nil, True); + treePrivs.InvalidateChildren(nil, True); treePrivs.Invalidate; // Enable input boxes - lblUsername.Enabled := UserSelected; - editUsername.Enabled := UserSelected; - lblFromHost.Enabled := UserSelected; - editFromHost.Enabled := UserSelected; - lblPassword.Enabled := UserSelected; - editPassword.Enabled := UserSelected; - lblRepeatPassword.Enabled := UserSelected; - editRepeatPassword.Enabled := UserSelected; + lblUsername.Enabled := UserSelected and User.IsUser; + editUsername.Enabled := UserSelected and User.IsUser; + lblFromHost.Enabled := UserSelected and User.IsUser; + editFromHost.Enabled := UserSelected and User.IsUser; + lblPassword.Enabled := UserSelected and User.IsUser; + editPassword.Enabled := UserSelected and User.IsUser; + lblRepeatPassword.Enabled := UserSelected and User.IsUser; + editRepeatPassword.Enabled := UserSelected and User.IsUser; + comboPlugins.Enabled := UserSelected and User.IsUser and FHasPlugin; + lblPlugin.Enabled := comboPlugins.Enabled; + comboDefaultRole.Enabled := UserSelected and User.IsUser and FHasDefaultRole; + lblDefaultRole.Enabled := comboDefaultRole.Enabled; tabCredentials.Enabled := UserSelected; - lblMaxQueries.Enabled := UserSelected and (FConnection.ServerVersionInt >= 40002); + lblMaxQueries.Enabled := UserSelected and User.IsUser and (FConnection.ServerVersionInt >= 40002); - tabLimitations.Enabled := UserSelected; + tabLimitations.Enabled := UserSelected and User.IsUser; editMaxQueries.Enabled := lblMaxQueries.Enabled; udMaxQueries.Enabled := lblMaxQueries.Enabled; lblMaxUpdates.Enabled := lblMaxQueries.Enabled; @@ -777,16 +942,16 @@ procedure TUserManagerForm.listUsersFocusChanged(Sender: TBaseVirtualTree; Node: lblMaxConnections.Enabled := lblMaxQueries.Enabled; editMaxConnections.Enabled := lblMaxQueries.Enabled; udMaxConnections.Enabled := lblMaxQueries.Enabled; - lblMaxUserConnections.Enabled := UserSelected and (FConnection.ServerVersionInt >= 50003); + lblMaxUserConnections.Enabled := UserSelected and User.IsUser and (FConnection.ServerVersionInt >= 50003); editMaxUserConnections.Enabled := lblMaxUserConnections.Enabled; udMaxUserConnections.Enabled := lblMaxUserConnections.Enabled; - tabSSL.Enabled := UserSelected; - comboSSL.Enabled := UserSelected; + tabSSL.Enabled := UserSelected and User.IsUser; + comboSSL.Enabled := UserSelected and User.IsUser; btnAddObject.Enabled := UserSelected; btnDeleteUser.Enabled := UserSelected; - btnCloneUser.Enabled := UserSelected and (not FAdded); + btnCloneUser.Enabled := UserSelected and (not FAdded) and User.IsUser; // Ensure the warning hint is displayed or cleared. This is not done when the dialog shows up. listUsers.OnHotChange(Sender, nil, Node); @@ -800,10 +965,15 @@ procedure TUserManagerForm.listUsersGetImageIndex(Sender: TBaseVirtualTree; Node begin if Column <> 0 then Exit; + User := Sender.GetNodeData(Node); case Kind of - ikNormal, ikSelected: ImageIndex := 43; + ikNormal, ikSelected: begin + if User.IsUser then + ImageIndex := ICONINDEX_USER + else + ImageIndex := ICONINDEX_ROLE; + end; ikOverlay: begin - User := Sender.GetNodeData(Node); if User.Password = '' then ImageIndex := 161; if FModified and (Node = Sender.FocusedNode) then @@ -831,6 +1001,7 @@ procedure TUserManagerForm.listUsersGetText(Sender: TBaseVirtualTree; Node: PVir case Column of 0: CellText := User.Username; 1: CellText := User.Host; + 2: CellText := User.Plugin; end; end; @@ -942,6 +1113,9 @@ procedure TUserManagerForm.treePrivsExpanded(Sender: TBaseVirtualTree; Node: PVi Sender.Expanded[n] := n = Node; n := Sender.GetNextSibling(n); end; + // Init out-of-view children of expanded node, to keep checked state in sync. + // Note that ReinitChildren is limited to visible nodes only, which we don't want here. + Sender.InitRecursive(Node, 1, False); end; @@ -1034,21 +1208,20 @@ procedure TUserManagerForm.treePrivsPaintText(Sender: TBaseVirtualTree; const Ta if (Sender.GetNodeLevel(Node) = 1) and (not (vsSelected in Node.States)) then begin PrivName := FPrivObjects[Node.Parent.Index].AllPrivileges[Node.Index]; if PrivsRead.IndexOf(PrivName) > -1 then - TargetCanvas.Font.Color := clGreen + TargetCanvas.Font.Color := FColorReadPriv else if PrivsWrite.IndexOf(PrivName) > -1 then - TargetCanvas.Font.Color := clMaroon + TargetCanvas.Font.Color := FColorWritePriv else if PrivsAdmin.IndexOf(PrivName) > -1 then - TargetCanvas.Font.Color := clNavy; + TargetCanvas.Font.Color := FColorAdminPriv; end; end; -procedure TUserManagerForm.btnAddUserClick(Sender: TObject); +procedure TUserManagerForm.menuItemUserClick(Sender: TObject); var P: TPrivObj; User: TUser; - OldUser, NodeUser: PUser; - Node: PVirtualNode; + OldUser: PUser; NewHost, NewPassword, NewUsername: String; begin // Create new or clone existing user @@ -1076,20 +1249,63 @@ procedure TUserManagerForm.btnAddUserClick(Sender: TObject); FUsers.Add(User); FAdded := True; InvalidateVT(listUsers, VTREE_NOTLOADED, True); - // Select newly added item. + SelectUserNode(User); + Modified := True; + // Focus the user name entry box. + PageControlSettings.ActivePage := tabCredentials; + editUserName.SetFocus; +end; + + +procedure TUserManagerForm.menuItemRoleClick(Sender: TObject); +var + RoleName, CreateRole: String; + User: TUser; +begin + // Try to unfocus current user which triggers saving modifications. + listUsers.FocusedNode := nil; + if Assigned(listUsers.FocusedNode) then + Exit; + + // Add role + RoleName := ''; + if not InputQuery(_('Create role'), _('Role name'), RoleName) then + Exit; + + try + CreateRole := FConnection.SqlProvider.GetSql(qCreateRole, [FConnection.EscapeString(RoleName)]); + FConnection.Query(CreateRole); + User := TUser.Create; + User.Username := RoleName; + User.IsRole := True; + FUsers.Add(User); + InvalidateVT(listUsers, VTREE_NOTLOADED, True); + SelectUserNode(User); + Modified := True; + except + on E:Exception do + ErrorDialog(E.Message); + end; +end; + + +function TUserManagerForm.SelectUserNode(User: TUser): Boolean; +var + NodeUser: PUser; + Node: PVirtualNode; +begin + // Select a user node in the listing + Result := False; Node := listUsers.GetFirst; while Assigned(Node) do begin NodeUser := listUsers.GetNodeData(Node); if User = NodeUser^ then begin SelectNode(listUsers, Node); + Result := True; break; end; Node := listUsers.GetNextSibling(Node); end; - Modified := True; - // Focus the user name entry box. - PageControlSettings.ActivePage := tabCredentials; - editUserName.SetFocus; end; @@ -1158,8 +1374,9 @@ procedure TUserManagerForm.btnSaveClick(Sender: TObject); FocusedUser: PUser; Tables, WithClauses: TStringList; P: TPrivObj; - i: Integer; - PasswordSet: Boolean; + i, j: Integer; + PasswordSet, WithGrant: Boolean; + RoleName, RoleAssigned: String; function GetObjectType(ObjType: String): String; begin @@ -1172,10 +1389,11 @@ procedure TUserManagerForm.btnSaveClick(Sender: TObject); begin // Save changes FocusedUser := listUsers.GetNodeData(listUsers.FocusedNode); + FocusedUser.Problem := upNone; if FAdded then begin FocusedUser.Username := editUsername.Text; FocusedUser.Host := editFromHost.Text; - if IsEmpty(editPassword.Text) then + if IsEmpty(editPassword.Text) and FocusedUser.IsUser then FocusedUser.Problem := upEmptyPassword; end else begin if (FocusedUser.Problem=upNone) @@ -1185,8 +1403,14 @@ procedure TUserManagerForm.btnSaveClick(Sender: TObject); FocusedUser.Problem := upEmptyPassword end; - OrgUserHost := FConnection.EscapeString(FocusedUser.Username)+'@'+FConnection.EscapeString(FocusedUser.Host); - UserHost := FConnection.EscapeString(editUsername.Text)+'@'+FConnection.EscapeString(editFromHost.Text); + if FocusedUser.IsUser then begin + OrgUserHost := FConnection.EscapeString(FocusedUser.Username)+'@'+FConnection.EscapeString(FocusedUser.Host); + UserHost := FConnection.EscapeString(editUsername.Text)+'@'+FConnection.EscapeString(editFromHost.Text); + end + else begin + OrgUserHost := FConnection.EscapeString(FocusedUser.Username); + UserHost := FConnection.EscapeString(editUsername.Text); + end; try // Ensure we have a unique user@host combination @@ -1194,7 +1418,7 @@ procedure TUserManagerForm.btnSaveClick(Sender: TObject); if User = FocusedUser^ then Continue; if (User.Username = editUsername.Text) and (User.Host = editFromHost.Text) then - raise EInputError.CreateFmt('User <%s@%s> already exists.', [editUsername.Text, editFromHost.Text]); + raise EInputError.CreateFmt('User or role <%s@%s> already exists.', [editUsername.Text, editFromHost.Text]); end; // Check input: Ensure we have a unique user@host combination @@ -1204,15 +1428,21 @@ procedure TUserManagerForm.btnSaveClick(Sender: TObject); // Create added user PasswordSet := False; if FAdded and (FConnection.ServerVersionInt >= 50002) then begin - Create := 'CREATE USER '+UserHost; + Create := 'CREATE USER '+UserHost+' '; if editPassword.Modified then begin + // Insert authentication plugin with minor MariaDB/MySQL difference + if comboPlugins.ItemIndex > 0 then + Create := Create + 'IDENTIFIED ' + FSQLPluginPrefix + ' ' + comboPlugins.Text+' ' + FSQLPluginPassPrefix + ' ' + else + Create := Create + 'IDENTIFIED BY '; // Add "PASSWORD" clause when it's a hash already if (Copy(editPassword.Text, 1, 1) = '*') and (Length(editPassword.Text) = 41) then - Create := Create + ' IDENTIFIED BY PASSWORD '+FConnection.EscapeString(editPassword.Text) + Create := Create + 'PASSWORD '+FConnection.EscapeString(editPassword.Text) else - Create := Create + ' IDENTIFIED BY '+FConnection.EscapeString(editPassword.Text); + Create := Create + FConnection.EscapeString(editPassword.Text); end; FConnection.Query(Create); + FConnection.ShowWarnings; PasswordSet := True; end; @@ -1248,6 +1478,7 @@ procedure TUserManagerForm.btnSaveClick(Sender: TObject); Delete(Revoke, Length(Revoke)-1, 1); Revoke := 'REVOKE ' + Revoke + ' ON ' + OnObj + ' FROM ' + OrgUserHost; FConnection.Query(Revoke); + FConnection.ShowWarnings; end; // Grant privileges. Must be applied with USAGE for added users without specific privs. @@ -1265,45 +1496,44 @@ procedure TUserManagerForm.btnSaveClick(Sender: TObject); Grant := 'USAGE'; Grant := 'GRANT ' + Grant + ' ON ' + OnObj + ' TO ' + OrgUserHost; - // SSL options - if P.DBObj.NodeType = lntNone then begin - RequireClause := ' REQUIRE '; - case comboSSL.ItemIndex of - 0: RequireClause := RequireClause + 'NONE'; - 1: RequireClause := RequireClause + 'SSL'; - 2: RequireClause := RequireClause + 'X509'; - 3: RequireClause := RequireClause + 'CIPHER '+FConnection.EscapeString(editCipher.Text)+' ISSUER '+FConnection.EscapeString(editIssuer.Text)+' SUBJECT '+FConnection.EscapeString(editSubject.Text); - end; - if (FocusedUser.SSL = comboSSL.ItemIndex) - and (FocusedUser.Cipher = editCipher.Text) - and (FocusedUser.Issuer = editIssuer.Text) - and (FocusedUser.Subject = editSubject.Text) - then - RequireClause := ''; - Grant := Grant + RequireClause; - end; + WithGrant := P.AddedPrivs.IndexOf('GRANT') > -1; + if WithGrant then + Grant := Grant + ' WITH GRANT OPTION'; - WithClauses := TStringList.Create; - if P.AddedPrivs.IndexOf('GRANT') > -1 then - WithClauses.Add('GRANT OPTION'); - if P.DBObj.NodeType = lntNone then begin - // Apply resource limits only to global privilege - if udMaxQueries.Position <> FocusedUser.MaxQueries then - WithClauses.Add('MAX_QUERIES_PER_HOUR '+IntToStr(udMaxQueries.Position)); - if udMaxUpdates.Position <> FocusedUser.MaxUpdates then - WithClauses.Add('MAX_UPDATES_PER_HOUR '+IntToStr(udMaxUpdates.Position)); - if udMaxConnections.Position <> FocusedUser.MaxConnections then - WithClauses.Add('MAX_CONNECTIONS_PER_HOUR '+IntToStr(udMaxConnections.Position)); - if udMaxUserConnections.Position <> FocusedUser.MaxUserConnections then - WithClauses.Add('MAX_USER_CONNECTIONS '+IntToStr(udMaxUserConnections.Position)); + if P.Added or (P.AddedPrivs.Count > 0) or WithGrant then begin + FConnection.Query(Grant); + FConnection.ShowWarnings; end; - if WithClauses.Count > 0 then - Grant := Grant + ' WITH ' + ImplodeStr(' ', WithClauses); - if P.Added or (P.AddedPrivs.Count > 0) or (WithClauses.Count > 0) or (RequireClause <> '') then - FConnection.Query(Grant); + // General user options + if (P.DBObj.NodeType = lntNone) and FocusedUser.IsUser then begin + // Plugin + if FPluginModified and (comboPlugins.ItemIndex > 0) then begin + FConnection.Query('ALTER USER ' + UserHost + ' IDENTIFIED ' + FSQLPluginPrefix + ' ' + comboPlugins.Text); + FConnection.ShowWarnings; + end; + + // SSL + case comboSSL.ItemIndex of + 1: RequireClause := 'SSL'; + 2: RequireClause := 'X509'; + 3: RequireClause := 'CIPHER '+FConnection.EscapeString(editCipher.Text)+' AND ISSUER '+FConnection.EscapeString(editIssuer.Text)+' AND SUBJECT '+FConnection.EscapeString(editSubject.Text); + else RequireClause := 'NONE'; + end; + FConnection.Query('ALTER USER ' + UserHost + ' REQUIRE ' + RequireClause); + FConnection.ShowWarnings; + + // Resource limits, with 0 by default + WithClauses := TStringList.Create; + WithClauses.Add('MAX_QUERIES_PER_HOUR '+IntToStr(udMaxQueries.Position)); + WithClauses.Add('MAX_UPDATES_PER_HOUR '+IntToStr(udMaxUpdates.Position)); + WithClauses.Add('MAX_CONNECTIONS_PER_HOUR '+IntToStr(udMaxConnections.Position)); + WithClauses.Add('MAX_USER_CONNECTIONS '+IntToStr(udMaxUserConnections.Position)); + FConnection.Query('ALTER USER ' + UserHost + ' WITH ' + Implode(' ', WithClauses)); + FConnection.ShowWarnings; + WithClauses.Free; + end; - WithClauses.Free; end; // Set password @@ -1312,35 +1542,82 @@ procedure TUserManagerForm.btnSaveClick(Sender: TObject); FConnection.Query('SET PASSWORD FOR ' + OrgUserHost + ' = '+FConnection.EscapeString(editPassword.Text)) else FConnection.Query('SET PASSWORD FOR ' + OrgUserHost + ' = PASSWORD('+FConnection.EscapeString(editPassword.Text)+')'); + FConnection.ShowWarnings; end; + // Add or remove roles + for i:=0 to ValueListEditorRoles.Strings.Count-1 do begin + j := FocusedUser.Roles.IndexOf(ValueListEditorRoles.Strings[i]); + if j = -1 then begin + RoleName := ValueListEditorRoles.Strings.Names[i]; + RoleAssigned := ValueListEditorRoles.Strings.ValueFromIndex[i]; + if RoleAssigned = TUser.RoleNo then + FConnection.Query(qRevokeRole, [FConnection.EscapeString(RoleName), OrgUserHost]) + else if RoleAssigned = TUser.RoleYes then + FConnection.Query(qGrantRole, [FConnection.EscapeString(RoleName), OrgUserHost, '']) + else if RoleAssigned = TUser.RoleYesAdmin then + FConnection.Query(qGrantRole, [FConnection.EscapeString(RoleName), OrgUserHost, ' WITH ADMIN OPTION']); + FConnection.ShowWarnings; + end; + end; + + // Set default role + if comboDefaultRole.Enabled and (comboDefaultRole.ItemIndex > -1) then begin + if comboDefaultRole.ItemIndex = 0 then begin + FConnection.Query(qSetDefaultRole, ['NONE', OrgUserHost]); + end + else try + RoleName := comboDefaultRole.Text; + RoleAssigned := ValueListEditorRoles.Strings.Values[RoleName]; + if (RoleAssigned = TUser.RoleYes) or (RoleAssigned = TUser.RoleYesAdmin) then + FConnection.Query(qSetDefaultRole, [FConnection.EscapeString(RoleName), OrgUserHost]); + except + on E:EDbError do; // Happens when this role was not granted before + end; + FConnection.ShowWarnings; + end; + + // Rename user if (FocusedUser.Username <> editUsername.Text) or (FocusedUser.Host <> editFromHost.Text) then begin - if FConnection.ServerVersionInt >= 50002 then - FConnection.Query('RENAME USER '+OrgUserHost+' TO '+UserHost) - else begin - Tables := Explode(',', 'user,db,tables_priv,columns_priv'); - for Table in Tables do begin - FConnection.Query('UPDATE '+FConnection.QuoteIdent('mysql')+'.'+FConnection.QuoteIdent(Table)+ - ' SET User='+FConnection.EscapeString(editUsername.Text)+', Host='+FConnection.EscapeString(editFromHost.Text)+ - ' WHERE User='+FConnection.EscapeString(FocusedUser.Username)+' AND Host='+FConnection.EscapeString(FocusedUser.Host) - ); + + if FocusedUser.IsUser then begin + if FConnection.ServerVersionInt >= 50002 then + FConnection.Query('RENAME USER '+OrgUserHost+' TO '+UserHost) + else begin + Tables := Explode(',', 'user,db,tables_priv,columns_priv'); + for Table in Tables do begin + FConnection.Query('UPDATE '+FConnection.QuoteIdent('mysql')+'.'+FConnection.QuoteIdent(Table)+ + ' SET User='+FConnection.EscapeString(editUsername.Text)+', Host='+FConnection.EscapeString(editFromHost.Text)+ + ' WHERE User='+FConnection.EscapeString(FocusedUser.Username)+' AND Host='+FConnection.EscapeString(FocusedUser.Host) + ); + end; + FreeAndNil(Tables); end; - FreeAndNil(Tables); + end + + else begin + // todo: Rename role end; + + FConnection.ShowWarnings; end; - FConnection.Query('FLUSH PRIVILEGES'); + FConnection.Query(qReloadPrivileges); Modified := False; + PluginModified := False; FAdded := False; FocusedUser.Username := editUsername.Text; FocusedUser.Host := editFromHost.Text; if editPassword.Modified then FocusedUser.Password := editPassword.Text; + FocusedUser.Plugin := IfThen(comboPlugins.ItemIndex=0, '', comboPlugins.Text); + FocusedUser.DefaultRole := IfThen(comboDefaultRole.ItemIndex=0, '', comboDefaultRole.Text); FocusedUser.SSL := comboSSL.ItemIndex; FocusedUser.Cipher := editCipher.Text; FocusedUser.Issuer := editIssuer.Text; FocusedUser.Subject := editSubject.Text; + FocusedUser.Roles.Assign(ValueListEditorRoles.Strings); listUsers.OnFocusChanged(listUsers, listUsers.FocusedNode, listUsers.FocusedColumn); except on E:EDbError do @@ -1376,24 +1653,40 @@ procedure TUserManagerForm.btnDeleteUserClick(Sender: TObject); FUsers.Remove(User^); listUsers.DeleteNode(listUsers.FocusedNode); FAdded := False; - end else if MessageDialog(f_('Delete user %s@%s?', [User.Username, User.Host]), mtConfirmation, [mbYes, mbCancel]) = mrYes then begin - UserHost := FConnection.EscapeString(User.Username)+'@'+FConnection.EscapeString(User.Host); - try - // Revoke privs explicitly, required on old servers. - // Newer servers only require one DROP USER query - if FConnection.ServerVersionInt < 50002 then begin - FConnection.Query('REVOKE ALL PRIVILEGES ON *.* FROM '+UserHost); - FConnection.Query('REVOKE GRANT OPTION ON *.* FROM '+UserHost); + end else begin + UserHost := IfThen( + User.IsUser, + FConnection.EscapeString(User.Username)+'@'+FConnection.EscapeString(User.Host), + FConnection.EscapeString(User.Username) + ); + if MessageDialog(f_('Delete user or role %s?', [UserHost]), mtConfirmation, [mbYes, mbCancel]) = mrYes then begin + try + // Revoke privs explicitly, required on old servers. + // Newer servers only require one DROP USER query + if FConnection.ServerVersionInt < 50002 then begin + FConnection.Query('REVOKE ALL PRIVILEGES ON *.* FROM '+UserHost); + FConnection.Query('REVOKE GRANT OPTION ON *.* FROM '+UserHost); + end; + + // Actual deletion + if User.IsUser then begin + FConnection.Query(qDropUser, [ + FConnection.EscapeString(User.Username), + FConnection.EscapeString(User.Host) + ]); + end + else begin + FConnection.Query(qDropRole, [ + FConnection.EscapeString(User.Username) + ]); + end; + FConnection.Query(qReloadPrivileges); + + FUsers.Remove(User^); + listUsers.DeleteNode(listUsers.FocusedNode); + except on E:EDbError do + ErrorDialog(E.Message); end; - if FConnection.ServerVersionInt < 40101 then - FConnection.Query('DELETE FROM mysql.user WHERE User='+FConnection.EscapeString(User.Username)+' AND Host='+FConnection.EscapeString(User.Host)) - else - FConnection.Query('DROP USER '+UserHost); - FConnection.Query('FLUSH PRIVILEGES'); - FUsers.Remove(User^); - listUsers.DeleteNode(listUsers.FocusedNode); - except on E:EDbError do - ErrorDialog(E.Message); end; end; end; @@ -1403,10 +1696,16 @@ procedure TUserManagerForm.btnDiscardClick(Sender: TObject); begin // Reset modifications Modified := False; + PluginModified := False; listUsers.OnFocusChanged(listUsers, listUsers.FocusedNode, listUsers.FocusedColumn); end; +procedure TUserManagerForm.menuAddPopup(Sender: TObject); +begin + menuItemRole.Enabled := FHasIsRole; +end; + procedure TUserManagerForm.menuHostClick(Sender: TObject); begin // Insert predefined host @@ -1451,6 +1750,17 @@ procedure TUserManagerForm.menuHostPopup(Sender: TObject); end; +procedure TUserManagerForm.editFilterUsersChange(Sender: TObject); +begin + // Filter nodes in query helpers + FilterNodesByEdit(Sender as TButtonedEdit, listUsers); +end; + +procedure TUserManagerForm.editFilterUsersRightButtonClick(Sender: TObject); +begin + MainForm.buttonedEditClear(Sender); +end; + procedure TUserManagerForm.editPasswordChange(Sender: TObject); begin // Password manually edited @@ -1497,10 +1807,40 @@ procedure TUserManagerForm.menuPasswordClick(Sender: TObject); end; +{ TUser } + +constructor TUser.Create; +begin + Username := ''; + Host := ''; + Password := ''; + DefaultRole := ''; + Cipher := ''; + Issuer := ''; + Subject := ''; + MaxQueries := 0; + MaxUpdates := 0; + MaxConnections := 0; + MaxUserConnections := 0; + SSL := 0; + Problem := upNone; + IsRole := False; + Roles := TStringList.Create; +end; + +destructor TUser.Destroy; +begin + Roles.Free; + inherited; +end; + function TUser.HostRequiresNameResolve: Boolean; var rx: TRegExpr; begin + Result := False; + if IsRole then + Exit; rx := TRegExpr.Create; // Valid ips or wildcards which do not need name resolving: rx.Expression := '^(localhost|[\d\.\/\:_]+|.*%.*|[\w\d_]{4}\:.*)$'; @@ -1508,7 +1848,121 @@ function TUser.HostRequiresNameResolve: Boolean; rx.Free; end; +procedure TUser.ParseSettings(GrantOrCreate: String; Priv: TPrivObj); +var + rx: TRegExpr; + RequireClause, WithClause: String; +begin + // CREATE USER ... + // mysql: IDENTIFIED WITH 'mysql_native_password' AS '*23AE809DDACAF96AF0FD78ED04B6A265E05AA257' REQUIRE SSL X509 ISSUER '456' SUBJECT '789' CIPHER '123' NONE + // mariadb: IDENTIFIED BY PASSWORD '23AE809DDACAF96A'; + rx := TRegExpr.Create; + rx.ModifierI := True; + rx.Expression := '\sREQUIRE\s+(.+)'; + if rx.Exec(GrantOrCreate) then begin + RequireClause := rx.Match[1]; + SSL := 0; + Cipher := ''; + Issuer := ''; + Subject := ''; + rx.Expression := '\bSSL\b'; + if rx.Exec(RequireClause) then + SSL := 1; + rx.Expression := '\bX509\b'; + if rx.Exec(RequireClause) then + SSL := 2; + rx.Expression := '\bCIPHER\s+''([^'']+)'; + if rx.Exec(RequireClause) then + Cipher := rx.Match[1]; + rx.Expression := '\bISSUER\s+''([^'']+)'; + if rx.Exec(RequireClause) then + Issuer := rx.Match[1]; + rx.Expression := '\bSUBJECT\s+''([^'']+)'; + if rx.Exec(RequireClause) then + Subject := rx.Match[1]; + if IsNotEmpty(Cipher) or IsNotEmpty(Issuer) or IsNotEmpty(Subject) then + SSL := 3; + end; + // WITH .. GRANT OPTION + // MAX_QUERIES_PER_HOUR 20 MAX_UPDATES_PER_HOUR 10 MAX_CONNECTIONS_PER_HOUR 5 MAX_USER_CONNECTIONS 2 + rx.Expression := '\sWITH\s+(.+)'; + if rx.Exec(GrantOrCreate) then begin + WithClause := rx.Match[1]; + if ExecRegExpr('\bGRANT\s+OPTION\b', WithClause) and Assigned(Priv) then + Priv.OrgPrivs.Add('GRANT'); + rx.Expression := '\bMAX_QUERIES_PER_HOUR\s+(\d+)\b'; + if rx.Exec(WithClause) then + MaxQueries := MakeInt(rx.Match[1]); + rx.Expression := '\bMAX_UPDATES_PER_HOUR\s+(\d+)\b'; + if rx.Exec(WithClause) then + MaxUpdates := MakeInt(rx.Match[1]); + rx.Expression := '\bMAX_CONNECTIONS_PER_HOUR\s+(\d+)\b'; + if rx.Exec(WithClause) then + MaxConnections := MakeInt(rx.Match[1]); + rx.Expression := '\bMAX_USER_CONNECTIONS\s+(\d+)\b'; + if rx.Exec(WithClause) then + MaxUserConnections := MakeInt(rx.Match[1]); + end; +end; + + +function TUser.IsUser: Boolean; +begin + Result := not IsRole; +end; + + +function TUser.AssignedRolesCount: Integer; +var + i: Integer; + Val: String; +begin + Result := 0; + for i:=0 to Roles.Count-1 do begin + Val := Roles.ValueFromIndex[i]; + if (Val = RoleYes) or (Val = RoleYesAdmin) then + Inc(Result); + end; +end; + + +{ TUserList } + +function TUserList.GetRoleNames: TStringList; +var + u: TUser; +begin + Result := TStringList.Create; + for u in Self do begin + if u.IsRole then + Result.Add(u.Username); + end; +end; + +procedure TUserList.GetRoleNames(Strings: TStrings); +var + RoleNames: TStringList; +begin + RoleNames := GetRoleNames; + Strings.AddStrings(RoleNames); + RoleNames.Free; +end; +function TUserList.GetDefaultRoles(ExcludeRole: TUser): TStringList; +var + RoleNames: TStringList; + i: Integer; +begin + // Default role assignments with "no" value for all roles + Result := TStringList.Create; + RoleNames := GetRoleNames; + for i:=0 to RoleNames.Count-1 do begin + if ExcludeRole.IsRole and SameText(RoleNames[i], ExcludeRole.Username) then + Continue; + Result.AddPair(RoleNames[i], TUser.RoleNo); + end; + RoleNames.Free; +end; { TPrivObj } @@ -1552,4 +2006,10 @@ function TPrivComparer.Compare(const Left, Right: TPrivObj): Integer; end; +initialization + +TUser.RoleNo := _('No'); +TUser.RoleYes := _('Yes'); +TUser.RoleYesAdmin := _('Yes, with admin option'); + end. diff --git a/source/vcl-styles-utils/CompileResources.bat b/source/vcl-styles-utils/CompileResources.bat index c75054339..c89a9c4f7 100644 --- a/source/vcl-styles-utils/CompileResources.bat +++ b/source/vcl-styles-utils/CompileResources.bat @@ -1,2 +1,2 @@ -"C:\Program Files (x86)\Embarcadero\Studio\18.0\bin\brcc32.exe" AwesomeFont.rc +"C:\Program Files (x86)\Embarcadero\Studio\18.0\bin\brcc32.exe" AwesomeFont.rc Pause \ No newline at end of file diff --git a/source/vcl-styles-utils/CompileResources_zip.bat b/source/vcl-styles-utils/CompileResources_zip.bat index da1ce148f..fd3d1871d 100644 --- a/source/vcl-styles-utils/CompileResources_zip.bat +++ b/source/vcl-styles-utils/CompileResources_zip.bat @@ -1,2 +1,2 @@ -"C:\Program Files (x86)\Embarcadero\Studio\18.0\bin\brcc32.exe" AwesomeFont_zip.rc +"C:\Program Files (x86)\Embarcadero\Studio\18.0\bin\brcc32.exe" AwesomeFont_zip.rc Pause \ No newline at end of file diff --git a/source/vcl-styles-utils/VCL.Styles.Utils.inc b/source/vcl-styles-utils/VCL.Styles.Utils.inc index 1b301fb83..ebd3ab6d0 100644 --- a/source/vcl-styles-utils/VCL.Styles.Utils.inc +++ b/source/vcl-styles-utils/VCL.Styles.Utils.inc @@ -14,45 +14,44 @@ // // // Portions created by Mahdi Safsafi [SMP3] e-mail SMP@LIVE.FR -// Portions created by Rodrigo Ruz V. are Copyright (C) 2013-2017 Rodrigo Ruz V. +// Portions created by Rodrigo Ruz V. are Copyright (C) 2013-2023 Rodrigo Ruz V. // All Rights Reserved. // //************************************************************************************************ - {$DEFINE USE_Vcl.Styles.Hooks} {$DEFINE HOOK_UXTHEME} {$DEFINE HOOK_TDateTimePicker} {$DEFINE HOOK_TProgressBar} {$DEFINE LimitStylesToMainApplicationThread} - +{.$DEFINE HOOK_VirtualShell} +{.$DEFINE HOOK_ExplorerStatusBar} { Feature toggles for supported UxThemes - see Vcl.Styles.UxTheme } - {$DEFINE HOOK_Button} -{$DEFINE HOOK_AllButtons} -{$DEFINE HOOK_Scrollbar} -{$DEFINE HOOK_TaskDialog} -{$DEFINE HOOK_ProgressBar} -{$DEFINE HOOK_DateTimePicker} -{$DEFINE HOOK_TreeView} -{$DEFINE HOOK_ListView} -{$DEFINE HOOK_ListBox} -{$DEFINE HOOK_ComboBox} - -{$DEFINE HOOK_Spin} -{$DEFINE HOOK_EDIT} -{$DEFINE HOOK_Rebar} -{$DEFINE HOOK_ToolBar} -{$DEFINE HOOK_Menu} -{$DEFINE HOOK_TrackBar} -{$DEFINE HOOK_ToolTip} -{$DEFINE HOOK_Tab} -// Introduced in Windows Vista -{$DEFINE HOOK_CommandModule} -{$DEFINE HOOK_SearchBox} -{$DEFINE HOOK_AddressBand} -{$DEFINE HOOK_PreviewPane} -{$DEFINE HOOK_TRYHARDER} -{$DEFINE HOOK_BREADCRUMBAR} -{$DEFINE HOOK_InfoBar} -// Introduced in Windows 8 +{$DEFINE HOOK_AllButtons} +{$DEFINE HOOK_Scrollbar} +{$DEFINE HOOK_TaskDialog} +{$DEFINE HOOK_ProgressBar} +{$DEFINE HOOK_DateTimePicker} +{$DEFINE HOOK_TreeView} +{$DEFINE HOOK_ListView} +{$DEFINE HOOK_ListBox} +{$DEFINE HOOK_ComboBox} + +{$DEFINE HOOK_Spin} +{$DEFINE HOOK_EDIT} +{$DEFINE HOOK_Rebar} +{$DEFINE HOOK_ToolBar} +{$DEFINE HOOK_Menu} +{$DEFINE HOOK_TrackBar} +{$DEFINE HOOK_ToolTip} +{$DEFINE HOOK_Tab} +// Introduced in Windows Vista +{$DEFINE HOOK_CommandModule} +{$DEFINE HOOK_SearchBox} +{$DEFINE HOOK_AddressBand} +{$DEFINE HOOK_PreviewPane} +{$DEFINE HOOK_TRYHARDER} +{$DEFINE HOOK_BREADCRUMBAR} +{$DEFINE HOOK_InfoBar} +// Introduced in Windows 8 {$DEFINE HOOK_Navigation} diff --git a/source/vcl-styles-utils/Vcl.PlatformVclStylesActnCtrls.pas b/source/vcl-styles-utils/Vcl.PlatformVclStylesActnCtrls.pas index 3b0dece4a..ea76e5a7b 100644 --- a/source/vcl-styles-utils/Vcl.PlatformVclStylesActnCtrls.pas +++ b/source/vcl-styles-utils/Vcl.PlatformVclStylesActnCtrls.pas @@ -15,7 +15,7 @@ // The Original Code is Vcl.PlatformVclStylesActnCtrls // // The Initial Developer of the Original Code is Rodrigo Ruz V. -// Portions created by Rodrigo Ruz V. are Copyright (C) 2012-2020 Rodrigo Ruz V. +// Portions created by Rodrigo Ruz V. are Copyright (C) 2012-2023 Rodrigo Ruz V. // All Rights Reserved. // //************************************************************************************************** @@ -409,7 +409,7 @@ procedure TThemedDropDownButtonEx.DrawBackground(var PaintRect: TRect); const CheckedState: array[Boolean] of TThemedToolBar = (ttbButtonHot, ttbButtonCheckedHot); var - LIndex : Integer; + LIndex: Integer; begin LIndex := SaveDC(Canvas.Handle); try diff --git a/source/vcl-styles-utils/Vcl.Styles.ColorTabs.pas b/source/vcl-styles-utils/Vcl.Styles.ColorTabs.pas index d8472affb..46a405b4b 100644 --- a/source/vcl-styles-utils/Vcl.Styles.ColorTabs.pas +++ b/source/vcl-styles-utils/Vcl.Styles.ColorTabs.pas @@ -15,7 +15,7 @@ // The Original Code is Vcl.Styles.ColorTabs // // The Initial Developer of the Original Code is Rodrigo Ruz V. -// Portions created by Rodrigo Ruz V. are Copyright (C) 2012-2020 Rodrigo Ruz V. +// Portions created by Rodrigo Ruz V. are Copyright (C) 2012-2023 Rodrigo Ruz V. // All Rights Reserved. // // ************************************************************************************************** @@ -84,7 +84,7 @@ TTabControlStyleHookHelper = class helper for TTabControlStyleHook End; class function TCustomStyleEngineHelper.GetRegisteredStyleHooks - : TStyleHookDictionary; +: TStyleHookDictionary; {$IF (CompilerVersion >=31)} var p: Pointer; diff --git a/source/vcl-styles-utils/Vcl.Styles.ControlColor.pas b/source/vcl-styles-utils/Vcl.Styles.ControlColor.pas index ed05ce0f8..6aa1d4f6d 100644 --- a/source/vcl-styles-utils/Vcl.Styles.ControlColor.pas +++ b/source/vcl-styles-utils/Vcl.Styles.ControlColor.pas @@ -1,174 +1,174 @@ -//************************************************************************************************** -// -// Unit Vcl.Styles.ControlColor -// unit for the VCL Styles Utils -// https://github.com/RRUZ/vcl-styles-utils/ -// -// 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. -// -// The Original Code is Vcl.Styles.ControlColor -// -// The Initial Developer of the Original Code is Rodrigo Ruz V. -// Portions created by Rodrigo Ruz V. are Copyright (C) 2012-2019 Rodrigo Ruz V. -// All Rights Reserved. -// -//************************************************************************************************** -unit Vcl.Styles.ControlColor; - -interface - -uses - Vcl.StdCtrls, - Vcl.Controls, - Winapi.Messages; - -type - /// The TEditStyleHookColor vcl style hook allows you to use custom colors in the TCustomEdit descendent components - /// - /// - /// You can use this hook on these components - /// TEdit, TButtonedEdit, TMaskEdit, TEditStyleHookColor - /// - /// TStyleManager.Engine.RegisterStyleHook(TEdit, TEditStyleHookColor); - /// - /// - TEditStyleHookColor = class(TEditStyleHook) - strict private - procedure UpdateColors; - protected - procedure WndProc(var Message: TMessage); override; - public - constructor Create(AControl: TWinControl); override; - end; - - /// The TMemoStyleHookColor vcl style hook allows you to use custom colors in the TCustomMemo descendent components - /// - /// - /// You can use this hook on these components - /// TMemo, TMemoStyleHookColor - /// - /// TStyleManager.Engine.RegisterStyleHook(TMemo, TMemoStyleHookColor); - /// - /// - TMemoStyleHookColor = class(TMemoStyleHook) - strict private - procedure UpdateColors; - protected - procedure WndProc(var Message: TMessage); override; - public - constructor Create(AControl: TWinControl); override; - end; - -implementation - -Uses - System.UITypes, - Winapi.Windows, - Vcl.Graphics, - Vcl.Themes, - Vcl.Styles; - - -type - TWinControlClass= class(TWinControl); - - -constructor TEditStyleHookColor.Create(AControl: TWinControl); -begin - inherited; - UpdateColors; -end; - -procedure TEditStyleHookColor.UpdateColors; -var - LStyle: TCustomStyleServices; -begin - if Control.Enabled then - begin - Brush.Color := TWinControlClass(Control).Color; - FontColor := TWinControlClass(Control).Font.Color; - end - else - begin - LStyle := StyleServices; - Brush.Color := LStyle.GetStyleColor(scEditDisabled); - FontColor := LStyle.GetStyleFontColor(sfEditBoxTextDisabled); - end; -end; - -procedure TEditStyleHookColor.WndProc(var Message: TMessage); -begin - case Message.Msg of - CN_CTLCOLORMSGBOX..CN_CTLCOLORSTATIC: - begin - UpdateColors; - SetTextColor(Message.WParam, ColorToRGB(FontColor)); - SetBkColor(Message.WParam, ColorToRGB(Brush.Color)); - Message.Result := LRESULT(Brush.Handle); - Handled := True; - end; - CM_ENABLEDCHANGED: - begin - UpdateColors; - Handled := False; - end - else - inherited WndProc(Message); - end; -end; - -{ TMemoStyleHookColor } - -constructor TMemoStyleHookColor.Create(AControl: TWinControl); -begin - inherited; - UpdateColors; -end; - -procedure TMemoStyleHookColor.UpdateColors; -var - LStyle: TCustomStyleServices; -begin - if Control.Enabled then - begin - Brush.Color := TWinControlClass(Control).Color; - FontColor := TWinControlClass(Control).Font.Color; - end - else - begin - LStyle := StyleServices; - Brush.Color := LStyle.GetStyleColor(scEditDisabled); - FontColor := LStyle.GetStyleFontColor(sfEditBoxTextDisabled); - end; -end; - -procedure TMemoStyleHookColor.WndProc(var Message: TMessage); -begin - case Message.Msg of - CN_CTLCOLORMSGBOX..CN_CTLCOLORSTATIC: - begin - UpdateColors; - SetTextColor(Message.WParam, ColorToRGB(FontColor)); - SetBkColor(Message.WParam, ColorToRGB(Brush.Color)); - Message.Result := LRESULT(Brush.Handle); - Handled := True; - end; - - CM_COLORCHANGED, - CM_ENABLEDCHANGED: - begin - UpdateColors; - Handled := False; - end - else - inherited WndProc(Message); - end; -end; - -end. +//************************************************************************************************** +// +// Unit Vcl.Styles.ControlColor +// unit for the VCL Styles Utils +// https://github.com/RRUZ/vcl-styles-utils/ +// +// 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. +// +// The Original Code is Vcl.Styles.ControlColor +// +// The Initial Developer of the Original Code is Rodrigo Ruz V. +// Portions created by Rodrigo Ruz V. are Copyright (C) 2012-2023 Rodrigo Ruz V. +// All Rights Reserved. +// +//************************************************************************************************** +unit Vcl.Styles.ControlColor; + +interface + +uses + Vcl.StdCtrls, + Vcl.Controls, + Winapi.Messages; + +type + /// The TEditStyleHookColor vcl style hook allows you to use custom colors in the TCustomEdit descendent components + /// + /// + /// You can use this hook on these components + /// TEdit, TButtonedEdit, TMaskEdit, TEditStyleHookColor + /// + /// TStyleManager.Engine.RegisterStyleHook(TEdit, TEditStyleHookColor); + /// + /// + TEditStyleHookColor = class(TEditStyleHook) + strict private + procedure UpdateColors; + protected + procedure WndProc(var Message: TMessage); override; + public + constructor Create(AControl: TWinControl); override; + end; + + /// The TMemoStyleHookColor vcl style hook allows you to use custom colors in the TCustomMemo descendent components + /// + /// + /// You can use this hook on these components + /// TMemo, TMemoStyleHookColor + /// + /// TStyleManager.Engine.RegisterStyleHook(TMemo, TMemoStyleHookColor); + /// + /// + TMemoStyleHookColor = class(TMemoStyleHook) + strict private + procedure UpdateColors; + protected + procedure WndProc(var Message: TMessage); override; + public + constructor Create(AControl: TWinControl); override; + end; + +implementation + +Uses + System.UITypes, + Winapi.Windows, + Vcl.Graphics, + Vcl.Themes, + Vcl.Styles; + + +type + TWinControlClass= class(TWinControl); + + +constructor TEditStyleHookColor.Create(AControl: TWinControl); +begin + inherited; + UpdateColors; +end; + +procedure TEditStyleHookColor.UpdateColors; +var + LStyle: TCustomStyleServices; +begin + if Control.Enabled then + begin + Brush.Color := TWinControlClass(Control).Color; + FontColor := TWinControlClass(Control).Font.Color; + end + else + begin + LStyle := StyleServices; + Brush.Color := LStyle.GetStyleColor(scEditDisabled); + FontColor := LStyle.GetStyleFontColor(sfEditBoxTextDisabled); + end; +end; + +procedure TEditStyleHookColor.WndProc(var Message: TMessage); +begin + case Message.Msg of + CN_CTLCOLORMSGBOX..CN_CTLCOLORSTATIC: + begin + UpdateColors; + SetTextColor(Message.WParam, ColorToRGB(FontColor)); + SetBkColor(Message.WParam, ColorToRGB(Brush.Color)); + Message.Result := LRESULT(Brush.Handle); + Handled := True; + end; + CM_ENABLEDCHANGED: + begin + UpdateColors; + Handled := False; + end + else + inherited WndProc(Message); + end; +end; + +{ TMemoStyleHookColor } + +constructor TMemoStyleHookColor.Create(AControl: TWinControl); +begin + inherited; + UpdateColors; +end; + +procedure TMemoStyleHookColor.UpdateColors; +var + LStyle: TCustomStyleServices; +begin + if Control.Enabled then + begin + Brush.Color := TWinControlClass(Control).Color; + FontColor := TWinControlClass(Control).Font.Color; + end + else + begin + LStyle := StyleServices; + Brush.Color := LStyle.GetStyleColor(scEditDisabled); + FontColor := LStyle.GetStyleFontColor(sfEditBoxTextDisabled); + end; +end; + +procedure TMemoStyleHookColor.WndProc(var Message: TMessage); +begin + case Message.Msg of + CN_CTLCOLORMSGBOX..CN_CTLCOLORSTATIC: + begin + UpdateColors; + SetTextColor(Message.WParam, ColorToRGB(FontColor)); + SetBkColor(Message.WParam, ColorToRGB(Brush.Color)); + Message.Result := LRESULT(Brush.Handle); + Handled := True; + end; + + CM_COLORCHANGED, + CM_ENABLEDCHANGED: + begin + UpdateColors; + Handled := False; + end + else + inherited WndProc(Message); + end; +end; + +end. diff --git a/source/vcl-styles-utils/Vcl.Styles.DPIAware.pas b/source/vcl-styles-utils/Vcl.Styles.DPIAware.pas index c81abf515..cde091880 100644 --- a/source/vcl-styles-utils/Vcl.Styles.DPIAware.pas +++ b/source/vcl-styles-utils/Vcl.Styles.DPIAware.pas @@ -1,366 +1,366 @@ -{ - Modified 20-Mar-2019 by Rickard Johansson (www.rj-texted.se). - Purpose: Add per-monitor DPI awareness - Usage: Add the unit to the interface uses statement of the main form and add code below: - - TMyForm = class(TForm) - private - FStyleDPIAwareness : TStyleDPIAwareness; - - procedure TFrmMain.FormCreate(Sender: TObject); - begin - FStyleDPIAwareness := TStyleDPIAwareness.Create(Self); - FStyleDPIAwareness.Parent := Self; - - procedure TFrmMain.FormDestroy(Sender: TObject); - begin - FStyleDPIAwareness.Free; - - procedure TFrmMain.FormAfterMonitorDpiChanged(Sender: TObject; OldDPI, NewDPI: Integer); - begin - FStyleDPIAwareness.AfterDPIChange(OldDPI, NewDPI); - end; - - procedure TFrmMain.FormBeforeMonitorDpiChanged(Sender: TObject; OldDPI, NewDPI: Integer); - begin - FStyleDPIAwareness.BeforeDPIChange(OldDPI, NewDPI); - end; -} - -{----------------------------------------------------------------------------- - Unit Name: VCL.Styles.DPIAware - Author: PyScripter (https://github.com/pyscripter) - Date: 13-Nov-2017 - Purpose: Use VCL Styles in DPI Aware applications by scaling styles - History: ------------------------------------------------------------------------------} -{ - To use the unit just add it to the implementation uses statement of the main form and add - the following code to the FormCreate handler. - - procedure TFrmMain.FormCreate(Sender: TObject); - Var - StyleDPIAwareness : TStyleDPIAwareness; - begin - StyleDPIAwareness := TStyleDPIAwareness.Create(Self); - StyleDPIAwareness.Parent := Self; - - By default the component scales the styles at multiples of 100%. You can change that, - by adding the line: - - StyleDPIAwareness.RoundScalingFactor := False; - - With this statement styles are scaled to whatever scaling factor results for Screen.PixelsPerInch. - Most of the styles would work fine, but a few may show some visual defects. - - Limitations: - Does not support perMonitor DPI Awareness. - You need to set DPI Awareness to System. -} - -unit VCL.Styles.DPIAware; - -interface -uses - Winapi.Windows, WinAPI.Messages, System.SysUtils, System.Classes, Vcl.Graphics, - Vcl.Controls, Vcl.Forms, Vcl.Themes, Vcl.Styles; - -Type - TStyleDPI = class(TObject) - private - FCurrentDPI: Integer; - public - property CurrentDPI: Integer read FCurrentDPI write FCurrentDPI; - end; - - TStyleDPIAwareness = class(TControl) - private - FScaledStyles : TStringList; - FRoundScalingFactor : Boolean; - FUseCustomScalingFactor : Boolean; - FCustomPPI : integer; - FOldDPI: Integer; - protected - procedure CMStyleChanged(var Message: TMessage); message CM_STYLECHANGED; - procedure RecreateForms; - public - constructor Create(AOwner: TComponent); override; - destructor Destroy; override; - procedure AfterDPIChange(OldDPI, NewDPI: Integer); - procedure BeforeDPIChange(OldDPI, NewDPI: Integer); - procedure ScaleStyle(Style : TCustomStyleServices); - property OldDPI: Integer read FOldDPI write FOldDPI; - published - property RoundScalingFactor : Boolean read FRoundScalingFactor - write FRoundScalingFactor default True; - property UseCustomScalingFactor : Boolean read FUseCustomScalingFactor - write FUseCustomScalingFactor default False; - property CustomPPI : integer read FCustomPPI write FCustomPPI default 96; - end; - -implementation - -Uses - System.Rtti, DDetours, System.Math; - -{ TStyleDPIAwareness } - -procedure ResizeBitmap(Bitmap: TBitmap; const NewWidth, NewHeight: integer); -var - buffer: TBitmap; -begin - buffer := TBitmap.Create; - try - buffer.SetSize(NewWidth, NewHeight); - buffer.Canvas.StretchDraw(Rect(0, 0, NewWidth, NewHeight), Bitmap); - Bitmap.SetSize(NewWidth, NewHeight); - Bitmap.Canvas.Draw(0, 0, buffer); - finally - buffer.Free; - end; -end; - -procedure TStyleDPIAwareness.CMStyleChanged(var Message: TMessage); -begin - ScaleStyle(TStyleManager.ActiveStyle); -end; - -constructor TStyleDPIAwareness.Create(AOwner: TComponent); -begin - inherited; - FRoundScalingFactor := True; - FUseCustomScalingFactor := False; - FCustomPPI := 96; - FOldDPI := 96; - - FScaledStyles := TStringList.Create; - FScaledStyles.Sorted := False; - - ScaleStyle(TStyleManager.ActiveStyle); -end; - -destructor TStyleDPIAwareness.Destroy; -var - i : Integer; -begin - for i := 0 to FScaledStyles.Count - 1 do - TStyleDPI(FScaledStyles.Objects[i]).Free; - FScaledStyles.Free; - inherited; -end; - -procedure TStyleDPIAwareness.AfterDPIChange(OldDPI, NewDPI: Integer); -begin - ScaleStyle(TStyleManager.ActiveStyle); -end; - -procedure TStyleDPIAwareness.BeforeDPIChange(OldDPI, NewDPI: Integer); -begin - FOldDPI := OldDPI; -end; - -procedure TStyleDPIAwareness.RecreateForms; -Var - i : Integer; -begin - for i := 0 to Screen.FormCount - 1 do - begin - if Screen.Forms[i] <> TForm(Owner) then - Screen.Forms[i].Perform(CM_RECREATEWND, 0, 0); - end; -end; - -procedure TStyleDPIAwareness.ScaleStyle(Style: TCustomStyleServices); -Var - NewDPI : integer; - SeStyle : TObject; - SeStyleSource : TObject; - BitmapList : TList; - BitMap : TBitmap; - StyleObjectList : Tlist; - i,n: integer; - StyleObject : TComponent; - obj: TStyleDPI; - - procedure ProcessBitmapLink(BL : TObject); - Var - BLType : TRTTIType; - begin - BLType := TRttiContext.Create.GetType(BL.ClassType); - BLType.GetProperty('Bottom').SetValue(BL, Round((BLType.GetProperty('Bottom').GetValue(BL).AsInteger * NewDPI - 1) / OldDPI)); - BLType.GetProperty('Right').SetValue(BL, Round(BLType.GetProperty('Right').GetValue(BL).AsInteger * NewDPI / OldDPI)); - BLType.GetProperty('Left').SetValue(BL, Round(BLType.GetProperty('Left').GetValue(BL).AsInteger * NewDPI / OldDPI)); - BLType.GetProperty('Top').SetValue(BL, Round(BLType.GetProperty('Top').GetValue(BL).AsInteger * NewDPI / OldDPI)); - end; - - procedure ProcessSO(aSO : TComponent; aSOType : TRTTIType); - begin - aSOType.GetProperty('Top').SetValue(aSO, Round(aSOType.GetProperty('Top').GetValue(aSO).AsInteger * NewDPI / OldDPI)); - aSOType.GetProperty('Left').SetValue(aSO, Round(aSOType.GetProperty('Left').GetValue(aSO).AsInteger * NewDPI / OldDPI)); - aSOType.GetProperty('Width').SetValue(aSO, Round(aSOType.GetProperty('Width').GetValue(aSO).AsInteger * NewDPI / OldDPI)); - aSOType.GetProperty('Height').SetValue(aSO, Round(aSOType.GetProperty('Height').GetValue(aSO).AsInteger * NewDPI / OldDPI)); - aSOType.GetProperty('MarginTop').SetValue(aSO, Round(aSOType.GetProperty('MarginTop').GetValue(aSO).AsInteger * NewDPI / OldDPI)); - aSOType.GetProperty('MarginLeft').SetValue(aSO, Round(aSOType.GetProperty('MarginLeft').GetValue(aSO).AsInteger * NewDPI / OldDPI)); - aSOType.GetProperty('MarginBottom').SetValue(aSO, Round(aSOType.GetProperty('MarginBottom').GetValue(aSO).AsInteger * NewDPI / OldDPI)); - aSOType.GetProperty('MarginRight').SetValue(aSO, Round(aSOType.GetProperty('MarginRight').GetValue(aSO).AsInteger * NewDPI / OldDPI)); - aSOType.GetProperty('TextMarginTop').SetValue(aSO, Round(aSOType.GetProperty('TextMarginTop').GetValue(aSO).AsInteger * NewDPI / OldDPI)); - aSOType.GetProperty('TextMarginLeft').SetValue(aSO, Round(aSOType.GetProperty('TextMarginLeft').GetValue(aSO).AsInteger * NewDPI / OldDPI)); - aSOType.GetProperty('TextMarginRight').SetValue(aSO, Round(aSOType.GetProperty('TextMarginRight').GetValue(aSO).AsInteger * NewDPI / OldDPI)); - end; - - procedure ProcessStyleObject(SO : TComponent); - var - i: integer; - ChildSo : TComponent; - SOType : TRTTIType; - BitmapLink : TObject; - begin - SOType := TRttiContext.Create.GetType(SO.ClassType); - ProcessSO(SO, SOType); - - if So.ClassName = 'TSeBitmapObject' then begin - BitmapLink := TRttiContext.Create.GetType(SO.ClassType).GetField('FBitmap').GetValue(SO).AsObject;; - ProcessBitmapLink(BitmapLink); - end; - - if So.ClassName = 'TSeActiveBitmap' then begin - BitmapLink := TRttiContext.Create.GetType(SO.ClassType).GetField('FBitmap').GetValue(SO).AsObject;; - ProcessBitmapLink(BitmapLink); - BitmapLink := TRttiContext.Create.GetType(SO.ClassType).GetField('FActiveBitmap').GetValue(SO).AsObject;; - ProcessBitmapLink(BitmapLink); - end; - - if So.ClassName = 'TSeSystemButton' then begin - // Shift the form title to the right - if SO.Name = 'btnSysMenu' then - SOType.GetProperty('Width').SetValue(SO, MulDiv(28, NewDPI, OldDPI)); - BitmapLink := TRttiContext.Create.GetType(SO.ClassType).GetField('FBitmap').GetValue(SO).AsObject;; - ProcessBitmapLink(BitmapLink); - BitmapLink := TRttiContext.Create.GetType(SO.ClassType).GetField('FActiveBitmap').GetValue(SO).AsObject;; - ProcessBitmapLink(BitmapLink); - BitmapLink := TRttiContext.Create.GetType(SO.ClassType).GetField('FBitmapPressed').GetValue(SO).AsObject;; - ProcessBitmapLink(BitmapLink); - BitmapLink := TRttiContext.Create.GetType(SO.ClassType).GetField('FBitmapHot').GetValue(SO).AsObject;; - ProcessBitmapLink(BitmapLink); - end; - - if So.ClassName = 'TSeButtonObject' then begin - BitmapLink := TRttiContext.Create.GetType(SO.ClassType).GetField('FBitmap').GetValue(SO).AsObject;; - ProcessBitmapLink(BitmapLink); - BitmapLink := TRttiContext.Create.GetType(SO.ClassType).GetField('FBitmapFocused').GetValue(SO).AsObject;; - ProcessBitmapLink(BitmapLink); - BitmapLink := TRttiContext.Create.GetType(SO.ClassType).GetField('FBitmapHot').GetValue(SO).AsObject;; - ProcessBitmapLink(BitmapLink); - BitmapLink := TRttiContext.Create.GetType(SO.ClassType).GetField('FBitmapPressed').GetValue(SO).AsObject;; - ProcessBitmapLink(BitmapLink); - BitmapLink := TRttiContext.Create.GetType(SO.ClassType).GetField('FBitmapDisabled').GetValue(SO).AsObject;; - ProcessBitmapLink(BitmapLink); - end; - - for i := 0 to SO.ComponentCount - 1 do begin - ChildSo := SO.Components[i]; - ProcessStyleObject(ChildSo); - end; - end; - -begin - n := FScaledStyles.IndexOf(TStyleManager.ActiveStyle.Name); - if n >= 0 then - begin - obj := TStyleDPI(FScaledStyles.Objects[n]); - OldDPI := obj.FCurrentDPI; - end; - - if UseCustomScalingFactor then - NewDPI := CustomPPI - else - NewDPI := TForm(Owner).Monitor.PixelsPerInch; - - if (Style = TStyleManager.SystemStyle) then - Exit; - - SeStyle := TRttiContext.Create.GetType(Style.ClassType).GetField('FSource').GetValue(Style).AsObject; - SeStyleSource := TRttiContext.Create.GetType(SeStyle.ClassType).GetField('FCleanCopy').GetValue(SeStyle).AsObject; - BitMapList := TRttiContext.Create.GetType(SeStyleSource.ClassType).GetField('FBitmaps').GetValue(SeStyleSource).AsObject as TList; - - if BitMapList.Count = 1 then - begin - Bitmap := TObject(BitmapList[0]) as TBitmap; - ResizeBitmap(Bitmap, Round(Bitmap.Width * NewDPI / OldDPI), Round(Bitmap.Height * NewDPI / OldDPI)); - - StyleObjectList := TRttiContext.Create.GetType(SeStyleSource.ClassType).GetField('FObjects').GetValue(SeStyleSource).AsObject as TList; - for i := 0 to StyleObjectList.Count -1 do begin - StyleObject := TObject(StyleObjectList[i]) as TComponent; - ProcessStyleObject(StyleObject); - end; - TRttiContext.Create.GetType(SeStyle.ClassType).GetMethod('ResetStyle').Invoke(SeStyle, []); - - end; - - n := FScaledStyles.IndexOf(Style.Name); - if n >= 0 then - begin - obj := TStyleDPI(FScaledStyles.Objects[n]); - obj.FCurrentDPI := NewDPI; - end - else - begin - obj := TStyleDPI.Create; - obj.FCurrentDPI := NewDPI; - FScaledStyles.AddObject(Style.Name, obj); - end; - - if Style = TStyleManager.ActiveStyle then - RecreateForms; -end; -{$IFDEF VER330} // RAD Studio 10.3 - type - TGetBorderSize = function: TRect of object; - - TFormStyleHookFix = class helper for TFormStyleHook - procedure SetStretchedCaptionInc(Value : Integer); - function GetBorderSizeAddr: Pointer; - function Detour_GetBorderSize: TRect; - end; - -var - Trampoline_TFormStyleHook_GetBorderSize : TGetBorderSize; - Detour_TFormStyleHook_GetBorderSize : TGetBorderSize; - - -{ TFormStyleHookFix } - -function TFormStyleHookFix.GetBorderSizeAddr: Pointer; -var - MethodPtr: TGetBorderSize; -begin - with Self do MethodPtr := GetBorderSize; - Result := TMethod(MethodPtr).Code; -end; - -procedure TFormStyleHookFix.SetStretchedCaptionInc(Value: Integer); -begin - with Self do FStretchedCaptionInc := Value; -end; - -function TFormStyleHookFix.Detour_GetBorderSize: TRect; -var - MethodPtr: TGetBorderSize; -begin - TMethod(MethodPtr).Code := TMethod(Trampoline_TFormStyleHook_GetBorderSize).Code; - TMethod(MethodPtr).Data := Pointer(Self); - Result := MethodPtr; - Self.SetStretchedCaptionInc(1); - if (Form.Monitor.PixelsPerInch > 96) then - Result.Top := MulDiv(Result.Top, 96, Form.Monitor.PixelsPerInch); -end; - -initialization - Detour_TFormStyleHook_GetBorderSize := TFormStyleHook(nil).Detour_GetBorderSize; - TMethod(Trampoline_TFormStyleHook_GetBorderSize).Code := - InterceptCreate(TFormStyleHook(nil).GetBorderSizeAddr, - TMethod(Detour_TFormStyleHook_GetBorderSize).Code) -finalization - InterceptRemove(TMethod(Trampoline_TFormStyleHook_GetBorderSize).Code); -{$ENDIF VER330} -end. +{ + Modified 20-Mar-2019 by Rickard Johansson (www.rj-texted.se). + Purpose: Add per-monitor DPI awareness + Usage: Add the unit to the interface uses statement of the main form and add code below: + + TMyForm = class(TForm) + private + FStyleDPIAwareness: TStyleDPIAwareness; + + procedure TFrmMain.FormCreate(Sender: TObject); + begin + FStyleDPIAwareness := TStyleDPIAwareness.Create(Self); + FStyleDPIAwareness.Parent := Self; + + procedure TFrmMain.FormDestroy(Sender: TObject); + begin + FStyleDPIAwareness.Free; + + procedure TFrmMain.FormAfterMonitorDpiChanged(Sender: TObject; OldDPI, NewDPI: Integer); + begin + FStyleDPIAwareness.AfterDPIChange(OldDPI, NewDPI); + end; + + procedure TFrmMain.FormBeforeMonitorDpiChanged(Sender: TObject; OldDPI, NewDPI: Integer); + begin + FStyleDPIAwareness.BeforeDPIChange(OldDPI, NewDPI); + end; +} + +{----------------------------------------------------------------------------- + Unit Name: VCL.Styles.DPIAware + Author: PyScripter (https://github.com/pyscripter) + Date: 13-Nov-2017 + Purpose: Use VCL Styles in DPI Aware applications by scaling styles + History: +-----------------------------------------------------------------------------} +{ + To use the unit just add it to the implementation uses statement of the main form and add + the following code to the FormCreate handler. + + procedure TFrmMain.FormCreate(Sender: TObject); + Var + StyleDPIAwareness: TStyleDPIAwareness; + begin + StyleDPIAwareness := TStyleDPIAwareness.Create(Self); + StyleDPIAwareness.Parent := Self; + + By default the component scales the styles at multiples of 100%. You can change that, + by adding the line: + + StyleDPIAwareness.RoundScalingFactor := False; + + With this statement styles are scaled to whatever scaling factor results for Screen.PixelsPerInch. + Most of the styles would work fine, but a few may show some visual defects. + + Limitations: + Does not support perMonitor DPI Awareness. + You need to set DPI Awareness to System. +} + +unit VCL.Styles.DPIAware; + +interface +uses + Winapi.Windows, WinAPI.Messages, System.SysUtils, System.Classes, Vcl.Graphics, + Vcl.Controls, Vcl.Forms, Vcl.Themes, Vcl.Styles; + +Type + TStyleDPI = class(TObject) + private + FCurrentDPI: Integer; + public + property CurrentDPI: Integer read FCurrentDPI write FCurrentDPI; + end; + + TStyleDPIAwareness = class(TControl) + private + FScaledStyles: TStringList; + FRoundScalingFactor: Boolean; + FUseCustomScalingFactor: Boolean; + FCustomPPI: integer; + FOldDPI: Integer; + protected + procedure CMStyleChanged(var Message: TMessage); message CM_STYLECHANGED; + procedure RecreateForms; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure AfterDPIChange(OldDPI, NewDPI: Integer); + procedure BeforeDPIChange(OldDPI, NewDPI: Integer); + procedure ScaleStyle(Style: TCustomStyleServices); + property OldDPI: Integer read FOldDPI write FOldDPI; + published + property RoundScalingFactor: Boolean read FRoundScalingFactor + write FRoundScalingFactor default True; + property UseCustomScalingFactor: Boolean read FUseCustomScalingFactor + write FUseCustomScalingFactor default False; + property CustomPPI: integer read FCustomPPI write FCustomPPI default 96; + end; + +implementation + +Uses + System.Rtti, DDetours, System.Math; + +{ TStyleDPIAwareness } + +procedure ResizeBitmap(Bitmap: TBitmap; const NewWidth, NewHeight: integer); +var + buffer: TBitmap; +begin + buffer := TBitmap.Create; + try + buffer.SetSize(NewWidth, NewHeight); + buffer.Canvas.StretchDraw(Rect(0, 0, NewWidth, NewHeight), Bitmap); + Bitmap.SetSize(NewWidth, NewHeight); + Bitmap.Canvas.Draw(0, 0, buffer); + finally + buffer.Free; + end; +end; + +procedure TStyleDPIAwareness.CMStyleChanged(var Message: TMessage); +begin + ScaleStyle(TStyleManager.ActiveStyle); +end; + +constructor TStyleDPIAwareness.Create(AOwner: TComponent); +begin + inherited; + FRoundScalingFactor := True; + FUseCustomScalingFactor := False; + FCustomPPI := 96; + FOldDPI := 96; + + FScaledStyles := TStringList.Create; + FScaledStyles.Sorted := False; + + ScaleStyle(TStyleManager.ActiveStyle); +end; + +destructor TStyleDPIAwareness.Destroy; +var + i: Integer; +begin + for i := 0 to FScaledStyles.Count - 1 do + TStyleDPI(FScaledStyles.Objects[i]).Free; + FScaledStyles.Free; + inherited; +end; + +procedure TStyleDPIAwareness.AfterDPIChange(OldDPI, NewDPI: Integer); +begin + ScaleStyle(TStyleManager.ActiveStyle); +end; + +procedure TStyleDPIAwareness.BeforeDPIChange(OldDPI, NewDPI: Integer); +begin + FOldDPI := OldDPI; +end; + +procedure TStyleDPIAwareness.RecreateForms; +Var + i: Integer; +begin + for i := 0 to Screen.FormCount - 1 do + begin + if Screen.Forms[i] <> TForm(Owner) then + Screen.Forms[i].Perform(CM_RECREATEWND, 0, 0); + end; +end; + +procedure TStyleDPIAwareness.ScaleStyle(Style: TCustomStyleServices); +Var + NewDPI: integer; + SeStyle: TObject; + SeStyleSource: TObject; + BitmapList: TList; + BitMap: TBitmap; + StyleObjectList: Tlist; + i,n: integer; + StyleObject: TComponent; + obj: TStyleDPI; + + procedure ProcessBitmapLink(BL: TObject); + Var + BLType: TRTTIType; + begin + BLType := TRttiContext.Create.GetType(BL.ClassType); + BLType.GetProperty('Bottom').SetValue(BL, Round((BLType.GetProperty('Bottom').GetValue(BL).AsInteger * NewDPI - 1) / OldDPI)); + BLType.GetProperty('Right').SetValue(BL, Round(BLType.GetProperty('Right').GetValue(BL).AsInteger * NewDPI / OldDPI)); + BLType.GetProperty('Left').SetValue(BL, Round(BLType.GetProperty('Left').GetValue(BL).AsInteger * NewDPI / OldDPI)); + BLType.GetProperty('Top').SetValue(BL, Round(BLType.GetProperty('Top').GetValue(BL).AsInteger * NewDPI / OldDPI)); + end; + + procedure ProcessSO(aSO: TComponent; aSOType: TRTTIType); + begin + aSOType.GetProperty('Top').SetValue(aSO, Round(aSOType.GetProperty('Top').GetValue(aSO).AsInteger * NewDPI / OldDPI)); + aSOType.GetProperty('Left').SetValue(aSO, Round(aSOType.GetProperty('Left').GetValue(aSO).AsInteger * NewDPI / OldDPI)); + aSOType.GetProperty('Width').SetValue(aSO, Round(aSOType.GetProperty('Width').GetValue(aSO).AsInteger * NewDPI / OldDPI)); + aSOType.GetProperty('Height').SetValue(aSO, Round(aSOType.GetProperty('Height').GetValue(aSO).AsInteger * NewDPI / OldDPI)); + aSOType.GetProperty('MarginTop').SetValue(aSO, Round(aSOType.GetProperty('MarginTop').GetValue(aSO).AsInteger * NewDPI / OldDPI)); + aSOType.GetProperty('MarginLeft').SetValue(aSO, Round(aSOType.GetProperty('MarginLeft').GetValue(aSO).AsInteger * NewDPI / OldDPI)); + aSOType.GetProperty('MarginBottom').SetValue(aSO, Round(aSOType.GetProperty('MarginBottom').GetValue(aSO).AsInteger * NewDPI / OldDPI)); + aSOType.GetProperty('MarginRight').SetValue(aSO, Round(aSOType.GetProperty('MarginRight').GetValue(aSO).AsInteger * NewDPI / OldDPI)); + aSOType.GetProperty('TextMarginTop').SetValue(aSO, Round(aSOType.GetProperty('TextMarginTop').GetValue(aSO).AsInteger * NewDPI / OldDPI)); + aSOType.GetProperty('TextMarginLeft').SetValue(aSO, Round(aSOType.GetProperty('TextMarginLeft').GetValue(aSO).AsInteger * NewDPI / OldDPI)); + aSOType.GetProperty('TextMarginRight').SetValue(aSO, Round(aSOType.GetProperty('TextMarginRight').GetValue(aSO).AsInteger * NewDPI / OldDPI)); + end; + + procedure ProcessStyleObject(SO: TComponent); + var + i: integer; + ChildSo: TComponent; + SOType: TRTTIType; + BitmapLink: TObject; + begin + SOType := TRttiContext.Create.GetType(SO.ClassType); + ProcessSO(SO, SOType); + + if So.ClassName = 'TSeBitmapObject' then begin + BitmapLink := TRttiContext.Create.GetType(SO.ClassType).GetField('FBitmap').GetValue(SO).AsObject;; + ProcessBitmapLink(BitmapLink); + end; + + if So.ClassName = 'TSeActiveBitmap' then begin + BitmapLink := TRttiContext.Create.GetType(SO.ClassType).GetField('FBitmap').GetValue(SO).AsObject;; + ProcessBitmapLink(BitmapLink); + BitmapLink := TRttiContext.Create.GetType(SO.ClassType).GetField('FActiveBitmap').GetValue(SO).AsObject;; + ProcessBitmapLink(BitmapLink); + end; + + if So.ClassName = 'TSeSystemButton' then begin + // Shift the form title to the right + if SO.Name = 'btnSysMenu' then + SOType.GetProperty('Width').SetValue(SO, MulDiv(28, NewDPI, OldDPI)); + BitmapLink := TRttiContext.Create.GetType(SO.ClassType).GetField('FBitmap').GetValue(SO).AsObject;; + ProcessBitmapLink(BitmapLink); + BitmapLink := TRttiContext.Create.GetType(SO.ClassType).GetField('FActiveBitmap').GetValue(SO).AsObject;; + ProcessBitmapLink(BitmapLink); + BitmapLink := TRttiContext.Create.GetType(SO.ClassType).GetField('FBitmapPressed').GetValue(SO).AsObject;; + ProcessBitmapLink(BitmapLink); + BitmapLink := TRttiContext.Create.GetType(SO.ClassType).GetField('FBitmapHot').GetValue(SO).AsObject;; + ProcessBitmapLink(BitmapLink); + end; + + if So.ClassName = 'TSeButtonObject' then begin + BitmapLink := TRttiContext.Create.GetType(SO.ClassType).GetField('FBitmap').GetValue(SO).AsObject;; + ProcessBitmapLink(BitmapLink); + BitmapLink := TRttiContext.Create.GetType(SO.ClassType).GetField('FBitmapFocused').GetValue(SO).AsObject;; + ProcessBitmapLink(BitmapLink); + BitmapLink := TRttiContext.Create.GetType(SO.ClassType).GetField('FBitmapHot').GetValue(SO).AsObject;; + ProcessBitmapLink(BitmapLink); + BitmapLink := TRttiContext.Create.GetType(SO.ClassType).GetField('FBitmapPressed').GetValue(SO).AsObject;; + ProcessBitmapLink(BitmapLink); + BitmapLink := TRttiContext.Create.GetType(SO.ClassType).GetField('FBitmapDisabled').GetValue(SO).AsObject;; + ProcessBitmapLink(BitmapLink); + end; + + for i := 0 to SO.ComponentCount - 1 do begin + ChildSo := SO.Components[i]; + ProcessStyleObject(ChildSo); + end; + end; + +begin + n := FScaledStyles.IndexOf(TStyleManager.ActiveStyle.Name); + if n >= 0 then + begin + obj := TStyleDPI(FScaledStyles.Objects[n]); + OldDPI := obj.FCurrentDPI; + end; + + if UseCustomScalingFactor then + NewDPI := CustomPPI + else + NewDPI := TForm(Owner).Monitor.PixelsPerInch; + + if (Style = TStyleManager.SystemStyle) then + Exit; + + SeStyle := TRttiContext.Create.GetType(Style.ClassType).GetField('FSource').GetValue(Style).AsObject; + SeStyleSource := TRttiContext.Create.GetType(SeStyle.ClassType).GetField('FCleanCopy').GetValue(SeStyle).AsObject; + BitMapList := TRttiContext.Create.GetType(SeStyleSource.ClassType).GetField('FBitmaps').GetValue(SeStyleSource).AsObject as TList; + + if BitMapList.Count = 1 then + begin + Bitmap := TObject(BitmapList[0]) as TBitmap; + ResizeBitmap(Bitmap, Round(Bitmap.Width * NewDPI / OldDPI), Round(Bitmap.Height * NewDPI / OldDPI)); + + StyleObjectList := TRttiContext.Create.GetType(SeStyleSource.ClassType).GetField('FObjects').GetValue(SeStyleSource).AsObject as TList; + for i := 0 to StyleObjectList.Count -1 do begin + StyleObject := TObject(StyleObjectList[i]) as TComponent; + ProcessStyleObject(StyleObject); + end; + TRttiContext.Create.GetType(SeStyle.ClassType).GetMethod('ResetStyle').Invoke(SeStyle, []); + + end; + + n := FScaledStyles.IndexOf(Style.Name); + if n >= 0 then + begin + obj := TStyleDPI(FScaledStyles.Objects[n]); + obj.FCurrentDPI := NewDPI; + end + else + begin + obj := TStyleDPI.Create; + obj.FCurrentDPI := NewDPI; + FScaledStyles.AddObject(Style.Name, obj); + end; + + if Style = TStyleManager.ActiveStyle then + RecreateForms; +end; +{$IFDEF VER330} // RAD Studio 10.3 + type + TGetBorderSize = function: TRect of object; + + TFormStyleHookFix = class helper for TFormStyleHook + procedure SetStretchedCaptionInc(Value: Integer); + function GetBorderSizeAddr: Pointer; + function Detour_GetBorderSize: TRect; + end; + +var + Trampoline_TFormStyleHook_GetBorderSize: TGetBorderSize; + Detour_TFormStyleHook_GetBorderSize: TGetBorderSize; + + +{ TFormStyleHookFix } + +function TFormStyleHookFix.GetBorderSizeAddr: Pointer; +var + MethodPtr: TGetBorderSize; +begin + with Self do MethodPtr := GetBorderSize; + Result := TMethod(MethodPtr).Code; +end; + +procedure TFormStyleHookFix.SetStretchedCaptionInc(Value: Integer); +begin + with Self do FStretchedCaptionInc := Value; +end; + +function TFormStyleHookFix.Detour_GetBorderSize: TRect; +var + MethodPtr: TGetBorderSize; +begin + TMethod(MethodPtr).Code := TMethod(Trampoline_TFormStyleHook_GetBorderSize).Code; + TMethod(MethodPtr).Data := Pointer(Self); + Result := MethodPtr; + Self.SetStretchedCaptionInc(1); + if (Form.Monitor.PixelsPerInch > 96) then + Result.Top := MulDiv(Result.Top, 96, Form.Monitor.PixelsPerInch); +end; + +initialization + Detour_TFormStyleHook_GetBorderSize := TFormStyleHook(nil).Detour_GetBorderSize; + TMethod(Trampoline_TFormStyleHook_GetBorderSize).Code := + InterceptCreate(TFormStyleHook(nil).GetBorderSizeAddr, + TMethod(Detour_TFormStyleHook_GetBorderSize).Code) +finalization + InterceptRemove(TMethod(Trampoline_TFormStyleHook_GetBorderSize).Code); +{$ENDIF VER330} +end. diff --git a/source/vcl-styles-utils/Vcl.Styles.DateTimePickers.pas b/source/vcl-styles-utils/Vcl.Styles.DateTimePickers.pas index bdc57bd62..08914a834 100644 --- a/source/vcl-styles-utils/Vcl.Styles.DateTimePickers.pas +++ b/source/vcl-styles-utils/Vcl.Styles.DateTimePickers.pas @@ -1,227 +1,227 @@ -//************************************************************************************************** -// -// Unit Vcl.Styles.DateTimePickers -// unit for the VCL Styles Utils -// https://github.com/RRUZ/vcl-styles-utils/ -// -// 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. -// -// The Original Code is Vcl.Styles.DateTimePickers -// -// The Initial Developer of the Original Code is Rodrigo Ruz V. -// Portions created by Rodrigo Ruz V. are Copyright (C) 2012-2016 Rodrigo Ruz V. -// All Rights Reserved. -// -//************************************************************************************************** -unit Vcl.Styles.DateTimePickers; - -interface - -{$IF RTLVersion>=24} - {$LEGACYIFEND ON} -{$IFEND} -{$IF (CompilerVersion >= 31)} - {$MESSAGE ERROR 'This unit is deprecated, Use the Vcl.Styles.Hooks unit Instead'} -{$ELSE} -uses - Winapi.CommCtrl, - Winapi.Messages, - Winapi.uxTheme, - Vcl.Graphics, - Vcl.ComCtrls, - Vcl.Controls; - -type - TDateTimePickerStyleHookFix = class(TDateTimePickerStyleHook) - private - procedure CNNotify(var Message: TWMNotify); message CN_NOTIFY; - procedure WMPaint(var Message: TMessage); message WM_PAINT; - procedure SetColorsCalendar; - public - procedure PaintBackground(Canvas: TCanvas); override; - constructor Create(AControl: TWinControl); override; - end deprecated 'Use the Vcl.Styles.Hooks unit Instead'; - -implementation - -uses - System.SysUtils, - System.Classes, - WinApi.Windows, - Vcl.Styles, - Vcl.Themes; - -type - TDateTimePickerStyleHookHelper = class helper for TDateTimePickerStyleHook - private - function GetDroppedDown: Boolean; - procedure SetDroppedDown(const Value: Boolean); - function GetMouseOnButton: Boolean; - procedure SetMouseOnButton(const Value: Boolean); - public - function GetButtonRect_: TRect; - property _FDroppedDown : Boolean read GetDroppedDown Write SetDroppedDown; - property _FMouseOnButton : Boolean read GetMouseOnButton Write SetMouseOnButton; - end; - -{ TDateTimePickerStyleHookHelper } -function TDateTimePickerStyleHookHelper.GetButtonRect_: TRect; -begin - Result:=Self.GetButtonRect; -end; - -function TDateTimePickerStyleHookHelper.GetDroppedDown: Boolean; -begin - Result:=Self.FDroppedDown; -end; - -function TDateTimePickerStyleHookHelper.GetMouseOnButton: Boolean; -begin - Result:=Self.FMouseOnButton; -end; - -procedure TDateTimePickerStyleHookHelper.SetDroppedDown(const Value: Boolean); -begin - Self.FDroppedDown:=Value; -end; - -procedure TDateTimePickerStyleHookHelper.SetMouseOnButton(const Value: Boolean); -begin - Self.FMouseOnButton:=Value; -end; - -{ TDateTimePickerStyleHookFix } -procedure TDateTimePickerStyleHookFix.SetColorsCalendar; -Var - LTextColor, LBackColor : TColor; - LDateTimePicker : TDateTimePicker; -begin - LDateTimePicker:=TDateTimePicker(Control); - //get the vcl styles colors - LTextColor:=StyleServices.GetSystemColor(clWindowText); - LBackColor:=StyleServices.GetSystemColor(clWindow); - - LDateTimePicker.Color:=LBackColor; - //set the colors of the calendar - LDateTimePicker.CalColors.BackColor:=LBackColor; - LDateTimePicker.CalColors.MonthBackColor:=LBackColor; - LDateTimePicker.CalColors.TextColor:=LTextColor; - LDateTimePicker.CalColors.TitleBackColor:=LBackColor; - LDateTimePicker.CalColors.TitleTextColor:=LTextColor; - LDateTimePicker.CalColors.TrailingTextColor:=LTextColor; -end; - -procedure TDateTimePickerStyleHookFix.CNNotify(var Message: TWMNotify); -var - hwnd: WinAPi.Windows.HWND; -begin - CallDefaultProc(TMessage(Message)); - if Kind = dtkDate then - with Message, NMHdr^ do - begin - Result := 0; - case code of - - DTN_DROPDOWN: - begin - SetColorsCalendar; - hwnd := SendMessage(TDateTimePicker(Control).Handle, DTM_GETMONTHCAL, 0,0); - if (Winapi.uxTheme.GetWindowTheme(hwnd)<>0) then - Winapi.uxTheme.SetWindowTheme(hwnd, '', '');//disable themes in the drop down window - - _FDroppedDown := True; - RedrawWindow(Handle, nil, 0, RDW_ERASE or RDW_INVALIDATE or RDW_UPDATENOW); - if not TStyleManager.SystemStyle.Enabled then - begin - SetRedraw(False); - SetTimer(Handle, 1, 300, nil); - end; - end; - - DTN_CLOSEUP: - begin - _FDroppedDown := False; - _FMouseOnButton := False; - RedrawWindow(Handle, nil, 0, RDW_ERASE or RDW_INVALIDATE or RDW_UPDATENOW); - end; - end; - end; - Handled := True; -end; - - -constructor TDateTimePickerStyleHookFix.Create(AControl: TWinControl); -begin - inherited; - OverrideEraseBkgnd:=True;//this indicates which this style hook will call the PaintBackground method when the WM_ERASEBKGND message is sent. -end; - -procedure TDateTimePickerStyleHookFix.PaintBackground(Canvas: TCanvas); -begin - //use the proper style color to paint the background - Canvas.Brush.Color := StyleServices.GetStyleColor(scEdit); - Canvas.FillRect(Control.ClientRect); -end; - -procedure TDateTimePickerStyleHookFix.WMPaint(var Message: TMessage); -var - DC: HDC; - LCanvas: TCanvas; - LPaintStruct: TPaintStruct; - LRect: TRect; - LDetails: TThemedElementDetails; - sDateTime : string; -begin - DC := Message.WParam; - LCanvas := TCanvas.Create; - try - if DC <> 0 then - LCanvas.Handle := DC - else - LCanvas.Handle := BeginPaint(Control.Handle, LPaintStruct); - - if not TStyleManager.ActiveStyle.IsSystemStyle and (Winapi.uxTheme.GetWindowTheme(Control.Handle )<>0) then - Winapi.uxTheme.SetWindowTheme(Control.Handle, '', '');//disable themes in the calendar - - PaintNC(LCanvas); - Paint(LCanvas); - - if DateMode = dmUpDown then - LRect := Rect(2, 2, Control.Width - 2, Control.Height - 2) - else - LRect := Rect(2, 2, GetButtonRect_.Left, Control.Height - 2); - - if ShowCheckBox then LRect.Left := LRect.Height + 2; - IntersectClipRect(LCanvas.Handle, LRect.Left, LRect.Top, LRect.Right, LRect.Bottom); - Message.wParam := WPARAM(LCanvas.Handle); - - //only works for DateFormat = dfShort - case TDateTimePicker(Control).Kind of - dtkDate : sDateTime:=DateToStr(TDateTimePicker(Control).DateTime); - dtkTime : sDateTime:=TimeToStr(TDateTimePicker(Control).DateTime); - end; - - //draw the current date/time value - LDetails := StyleServices.GetElementDetails(teEditTextNormal); - DrawControlText(LCanvas, LDetails, sDateTime, LRect, DT_VCENTER or DT_LEFT); - - if not TStyleManager.SystemStyle.Enabled then - Paint(LCanvas); - - Message.WParam := DC; - if DC = 0 then - EndPaint(Control.Handle, LPaintStruct); - finally - LCanvas.Handle := 0; - LCanvas.Free; - end; - Handled := True; -end; -{$IFEND} -end. +//************************************************************************************************** +// +// Unit Vcl.Styles.DateTimePickers +// unit for the VCL Styles Utils +// https://github.com/RRUZ/vcl-styles-utils/ +// +// 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. +// +// The Original Code is Vcl.Styles.DateTimePickers +// +// The Initial Developer of the Original Code is Rodrigo Ruz V. +// Portions created by Rodrigo Ruz V. are Copyright (C) 2012-2023 Rodrigo Ruz V. +// All Rights Reserved. +// +//************************************************************************************************** +unit Vcl.Styles.DateTimePickers; + +interface + +{$IF RTLVersion>=24} + {$LEGACYIFEND ON} +{$IFEND} +{$IF (CompilerVersion >= 31)} + {$MESSAGE ERROR 'This unit is deprecated, Use the Vcl.Styles.Hooks unit Instead'} +{$ELSE} +uses + Winapi.CommCtrl, + Winapi.Messages, + Winapi.uxTheme, + Vcl.Graphics, + Vcl.ComCtrls, + Vcl.Controls; + +type + TDateTimePickerStyleHookFix = class(TDateTimePickerStyleHook) + private + procedure CNNotify(var Message: TWMNotify); message CN_NOTIFY; + procedure WMPaint(var Message: TMessage); message WM_PAINT; + procedure SetColorsCalendar; + public + procedure PaintBackground(Canvas: TCanvas); override; + constructor Create(AControl: TWinControl); override; + end deprecated 'Use the Vcl.Styles.Hooks unit Instead'; + +implementation + +uses + System.SysUtils, + System.Classes, + WinApi.Windows, + Vcl.Styles, + Vcl.Themes; + +type + TDateTimePickerStyleHookHelper = class helper for TDateTimePickerStyleHook + private + function GetDroppedDown: Boolean; + procedure SetDroppedDown(const Value: Boolean); + function GetMouseOnButton: Boolean; + procedure SetMouseOnButton(const Value: Boolean); + public + function GetButtonRect_: TRect; + property _FDroppedDown: Boolean read GetDroppedDown Write SetDroppedDown; + property _FMouseOnButton: Boolean read GetMouseOnButton Write SetMouseOnButton; + end; + +{ TDateTimePickerStyleHookHelper } +function TDateTimePickerStyleHookHelper.GetButtonRect_: TRect; +begin + Result:=Self.GetButtonRect; +end; + +function TDateTimePickerStyleHookHelper.GetDroppedDown: Boolean; +begin + Result:=Self.FDroppedDown; +end; + +function TDateTimePickerStyleHookHelper.GetMouseOnButton: Boolean; +begin + Result:=Self.FMouseOnButton; +end; + +procedure TDateTimePickerStyleHookHelper.SetDroppedDown(const Value: Boolean); +begin + Self.FDroppedDown:=Value; +end; + +procedure TDateTimePickerStyleHookHelper.SetMouseOnButton(const Value: Boolean); +begin + Self.FMouseOnButton:=Value; +end; + +{ TDateTimePickerStyleHookFix } +procedure TDateTimePickerStyleHookFix.SetColorsCalendar; +Var + LTextColor, LBackColor: TColor; + LDateTimePicker: TDateTimePicker; +begin + LDateTimePicker:=TDateTimePicker(Control); + //get the vcl styles colors + LTextColor:=StyleServices.GetSystemColor(clWindowText); + LBackColor:=StyleServices.GetSystemColor(clWindow); + + LDateTimePicker.Color:=LBackColor; + //set the colors of the calendar + LDateTimePicker.CalColors.BackColor:=LBackColor; + LDateTimePicker.CalColors.MonthBackColor:=LBackColor; + LDateTimePicker.CalColors.TextColor:=LTextColor; + LDateTimePicker.CalColors.TitleBackColor:=LBackColor; + LDateTimePicker.CalColors.TitleTextColor:=LTextColor; + LDateTimePicker.CalColors.TrailingTextColor:=LTextColor; +end; + +procedure TDateTimePickerStyleHookFix.CNNotify(var Message: TWMNotify); +var + hwnd: WinAPi.Windows.HWND; +begin + CallDefaultProc(TMessage(Message)); + if Kind = dtkDate then + with Message, NMHdr^ do + begin + Result := 0; + case code of + + DTN_DROPDOWN: + begin + SetColorsCalendar; + hwnd := SendMessage(TDateTimePicker(Control).Handle, DTM_GETMONTHCAL, 0,0); + if (Winapi.uxTheme.GetWindowTheme(hwnd)<>0) then + Winapi.uxTheme.SetWindowTheme(hwnd, '', '');//disable themes in the drop down window + + _FDroppedDown := True; + RedrawWindow(Handle, nil, 0, RDW_ERASE or RDW_INVALIDATE or RDW_UPDATENOW); + if not TStyleManager.SystemStyle.Enabled then + begin + SetRedraw(False); + SetTimer(Handle, 1, 300, nil); + end; + end; + + DTN_CLOSEUP: + begin + _FDroppedDown := False; + _FMouseOnButton := False; + RedrawWindow(Handle, nil, 0, RDW_ERASE or RDW_INVALIDATE or RDW_UPDATENOW); + end; + end; + end; + Handled := True; +end; + + +constructor TDateTimePickerStyleHookFix.Create(AControl: TWinControl); +begin + inherited; + OverrideEraseBkgnd:=True;//this indicates which this style hook will call the PaintBackground method when the WM_ERASEBKGND message is sent. +end; + +procedure TDateTimePickerStyleHookFix.PaintBackground(Canvas: TCanvas); +begin + //use the proper style color to paint the background + Canvas.Brush.Color := StyleServices.GetStyleColor(scEdit); + Canvas.FillRect(Control.ClientRect); +end; + +procedure TDateTimePickerStyleHookFix.WMPaint(var Message: TMessage); +var + DC: HDC; + LCanvas: TCanvas; + LPaintStruct: TPaintStruct; + LRect: TRect; + LDetails: TThemedElementDetails; + sDateTime: string; +begin + DC := Message.WParam; + LCanvas := TCanvas.Create; + try + if DC <> 0 then + LCanvas.Handle := DC + else + LCanvas.Handle := BeginPaint(Control.Handle, LPaintStruct); + + if not TStyleManager.ActiveStyle.IsSystemStyle and (Winapi.uxTheme.GetWindowTheme(Control.Handle )<>0) then + Winapi.uxTheme.SetWindowTheme(Control.Handle, '', '');//disable themes in the calendar + + PaintNC(LCanvas); + Paint(LCanvas); + + if DateMode = dmUpDown then + LRect := Rect(2, 2, Control.Width - 2, Control.Height - 2) + else + LRect := Rect(2, 2, GetButtonRect_.Left, Control.Height - 2); + + if ShowCheckBox then LRect.Left := LRect.Height + 2; + IntersectClipRect(LCanvas.Handle, LRect.Left, LRect.Top, LRect.Right, LRect.Bottom); + Message.wParam := WPARAM(LCanvas.Handle); + + //only works for DateFormat = dfShort + case TDateTimePicker(Control).Kind of + dtkDate: sDateTime:=DateToStr(TDateTimePicker(Control).DateTime); + dtkTime: sDateTime:=TimeToStr(TDateTimePicker(Control).DateTime); + end; + + //draw the current date/time value + LDetails := StyleServices.GetElementDetails(teEditTextNormal); + DrawControlText(LCanvas, LDetails, sDateTime, LRect, DT_VCENTER or DT_LEFT); + + if not TStyleManager.SystemStyle.Enabled then + Paint(LCanvas); + + Message.WParam := DC; + if DC = 0 then + EndPaint(Control.Handle, LPaintStruct); + finally + LCanvas.Handle := 0; + LCanvas.Free; + end; + Handled := True; +end; +{$IFEND} +end. diff --git a/source/vcl-styles-utils/Vcl.Styles.DbGrid.pas b/source/vcl-styles-utils/Vcl.Styles.DbGrid.pas index 75bbb126f..a5fe42920 100644 --- a/source/vcl-styles-utils/Vcl.Styles.DbGrid.pas +++ b/source/vcl-styles-utils/Vcl.Styles.DbGrid.pas @@ -1,253 +1,253 @@ -//************************************************************************************************** -// -// Unit Vcl.Styles.DbGrid -// unit for the VCL Styles Utils -// https://github.com/RRUZ/vcl-styles-utils/ -// -// 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. -// -// The Original Code is Vcl.Styles.DbGrid.pas. -// -// The Initial Developer of the Original Code is Rodrigo Ruz V. -// Portions created by Rodrigo Ruz V. are Copyright (C) 2012-2019 Rodrigo Ruz V. -// All Rights Reserved. -// -//************************************************************************************************** -unit Vcl.Styles.DbGrid; - -interface - -uses - Winapi.Windows, - Vcl.Grids, - Vcl.Graphics, - Vcl.DBGrids; - -type - TDBGrid = class(Vcl.DBGrids.TDBGrid) - protected - procedure DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState); override; - end; - -implementation - -uses - Data.DB, - System.SysUtils, - System.Classes, - System.UITypes, - Vcl.Forms, - Vcl.Styles, - Vcl.Themes, - Vcl.Controls; - -type - TCustomGridClass = class(TCustomGrid); - TDbGridHelper = class helper for TCustomDBGrid - private - function GetTitleOffset: Byte; - function GetIndicators: TImageList; - function GetSelRow: Integer; - procedure SetSelRow(const Value: Integer); - public - property TitleOffset : Byte read GetTitleOffset; - property Indicators: TImageList read GetIndicators; - property SelRow: Integer read GetSelRow write SetSelRow; - end; - -{ TDbGridHelper } - -function TDbGridHelper.GetIndicators: TImageList; -begin - with Self do - Result := FIndicators; -end; - -function TDbGridHelper.GetSelRow: Integer; -begin - with Self do - Result := FSelRow; -end; - -function TDbGridHelper.GetTitleOffset: Byte; -begin - with Self do - Result := FTitleOffset; -end; - -procedure TDbGridHelper.SetSelRow(const Value: Integer); -begin - with Self do - FSelRow := Value; -end; - -procedure _WriteText(ACanvas: TCanvas; ARect: TRect; DX, DY: Integer; const AText: string; Alignment: TAlignment; ARightToLeft: Boolean); -var - X: Integer; -begin - if (ACanvas.CanvasOrientation = coRightToLeft) and (not ARightToLeft) then - ChangeBiDiModeAlignment(Alignment); - case Alignment of - taLeftJustify : X := ARect.Left + DX; - taRightJustify: X := ARect.Right - ACanvas.TextWidth(AText) - 3; - else - X := ARect.Left + (ARect.Right - ARect.Left) shr 1 - (ACanvas.TextWidth(AText) shr 1); - end; - ACanvas.TextRect(ARect, X, ARect.Top + DY, AText); -end; - - -{ TDBGrid } - -procedure TDBGrid.DrawCell(ACol, ARow: Integer; ARect: TRect; AState: TGridDrawState); -var - OldActive: Integer; - Indicator: TThemedGrid; - Value: string; - CurrentColumn: TColumn; - MultiSelected: Boolean; - X: Integer; - LStyleServices: TCustomStyleServices; - DeltaX: Byte; - Index: Integer; -begin - LStyleServices := StyleServices; - if not TStyleManager.IsCustomStyleActive or (ARow-TitleOffset<0) then - begin - inherited DrawCell(ACol, ARow, ARect, AState); - exit; - end; - - if csLoading in ComponentState then - begin - Canvas.Brush.Color := LStyleServices.GetStyleColor(scGrid); - Canvas.FillRect(ARect); - Exit; - end; - - Dec(ARow, TitleOffset); - Dec(ACol, IndicatorOffset); - - if (gdFixed in AState) and ([dgRowLines, dgColLines] * Options = - [dgRowLines, dgColLines]) then - begin - Winapi.Windows.InflateRect(ARect, -1, -1); - DeltaX := 1; - end - else - DeltaX := 2; - - if (gdFixed in AState) and (ACol < 0) then - begin - DrawCellBackground(ARect, FixedColor, AState, ACol, ARow); - if Assigned(DataLink) and DataLink.Active then - begin - MultiSelected := False; - - if ARow >= 0 then - begin - OldActive := DataLink.ActiveRecord; - try - DataLink.ActiveRecord := ARow; - MultiSelected := (dgMultiSelect in Options) and Datalink.Active and SelectedRows.Find(Datalink.Datasource.Dataset.Bookmark, Index);; - finally - DataLink.ActiveRecord := OldActive; - end; - end; - - if (ARow = DataLink.ActiveRecord) or MultiSelected then - begin - Indicator := tgIndicatorArrow; - if DataLink.DataSet <> nil then - case DataLink.DataSet.State of - dsEdit: Indicator := tgIndicatorEdit; - dsInsert: Indicator := tgIndicatorInsert; - dsBrowse: - if MultiSelected then - if (ARow <> DataLink.ActiveRecord) then - Indicator := tgIndicatorMultiDot - else - Indicator := tgIndicatorMultiArrow; - end; - Indicators.BkColor := FixedColor; - X := ARect.Right - Indicators.Width - DeltaX; - if Canvas.CanvasOrientation = coRightToLeft then - Inc(X); - - if LStyleServices.Enabled and not LStyleServices.IsSystemStyle then - LStyleServices.DrawElement(Canvas.Handle, LStyleServices.GetElementDetails(Indicator), ARect) - else - Indicators.Draw(Canvas, X, (ARect.Top + ARect.Bottom - Indicators.Height) shr 1, Integer(Indicator) - Integer(tgIndicatorArrow), True); - - if ARow = Datalink.ActiveRecord then - SelRow := ARow + TitleOffset; - end; - end; - end - else - with Canvas do - begin - CurrentColumn := Columns[ACol]; - if not CurrentColumn.Showing then Exit; - if not (gdFixed in AState) then - begin - Font := CurrentColumn.Font; - Brush.Color := CurrentColumn.Color; - - if (Brush.Color=LStyleServices.GetStyleColor(scGrid)) then - begin - Font.Color := LStyleServices.GetStyleFontColor(sfGridItemNormal); - Brush.Color := LStyleServices.GetStyleColor(scGrid); - end; - - end; - - if (DataLink = nil) or not DataLink.Active then - FillRect(ARect) - else - begin - Value := ''; - OldActive := DataLink.ActiveRecord; - try - DataLink.ActiveRecord := ARow; - if Assigned(CurrentColumn.Field) then - Value := CurrentColumn.Field.DisplayText; - if HighlightCell(ACol, ARow, Value, AState) and DefaultDrawing then - DrawCellHighlight(ARect, AState, ACol, ARow); - if not Enabled then - Font.Color := clGrayText; - - if DefaultDrawing then - _WriteText(Canvas, ARect, 3, 2, Value, CurrentColumn.Alignment, UseRightToLeftAlignmentForField(CurrentColumn.Field, CurrentColumn.Alignment)); - - if Columns.State = csDefault then - DrawDataCell(ARect, CurrentColumn.Field, AState); - DrawColumnCell(ARect, ACol, CurrentColumn, AState); - finally - DataLink.ActiveRecord := OldActive; - end; - Canvas.Brush.Style := bsSolid; - - if DefaultDrawing and (gdSelected in AState) and ((dgAlwaysShowSelection in Options) or Focused) - and not (csDesigning in ComponentState) and not (dgRowSelect in Options) - and (UpdateLock = 0) and (ValidParentForm(Self).ActiveControl = Self) and - (FInternalDrawingStyle = gdsThemed) and (Win32MajorVersion >= 6) then - Winapi.Windows.InflateRect(ARect, -1, -1); - - end; - end; - - if (gdFixed in AState) and ([dgRowLines, dgColLines] * Options = - [dgRowLines, dgColLines]) and (FInternalDrawingStyle = gdsClassic) and - not (gdPressed in AState) then - Winapi.Windows.InflateRect(ARect, 1, 1); -end; - - -end. +//************************************************************************************************** +// +// Unit Vcl.Styles.DbGrid +// unit for the VCL Styles Utils +// https://github.com/RRUZ/vcl-styles-utils/ +// +// 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. +// +// The Original Code is Vcl.Styles.DbGrid.pas. +// +// The Initial Developer of the Original Code is Rodrigo Ruz V. +// Portions created by Rodrigo Ruz V. are Copyright (C) 2012-2023 Rodrigo Ruz V. +// All Rights Reserved. +// +//************************************************************************************************** +unit Vcl.Styles.DbGrid; + +interface + +uses + Winapi.Windows, + Vcl.Grids, + Vcl.Graphics, + Vcl.DBGrids; + +type + TDBGrid = class(Vcl.DBGrids.TDBGrid) + protected + procedure DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState); override; + end; + +implementation + +uses + Data.DB, + System.SysUtils, + System.Classes, + System.UITypes, + Vcl.Forms, + Vcl.Styles, + Vcl.Themes, + Vcl.Controls; + +type + TCustomGridClass = class(TCustomGrid); + TDbGridHelper = class helper for TCustomDBGrid + private + function GetTitleOffset: Byte; + function GetIndicators: TImageList; + function GetSelRow: Integer; + procedure SetSelRow(const Value: Integer); + public + property TitleOffset: Byte read GetTitleOffset; + property Indicators: TImageList read GetIndicators; + property SelRow: Integer read GetSelRow write SetSelRow; + end; + +{ TDbGridHelper } + +function TDbGridHelper.GetIndicators: TImageList; +begin + with Self do + Result := FIndicators; +end; + +function TDbGridHelper.GetSelRow: Integer; +begin + with Self do + Result := FSelRow; +end; + +function TDbGridHelper.GetTitleOffset: Byte; +begin + with Self do + Result := FTitleOffset; +end; + +procedure TDbGridHelper.SetSelRow(const Value: Integer); +begin + with Self do + FSelRow := Value; +end; + +procedure _WriteText(ACanvas: TCanvas; ARect: TRect; DX, DY: Integer; const AText: string; Alignment: TAlignment; ARightToLeft: Boolean); +var + X: Integer; +begin + if (ACanvas.CanvasOrientation = coRightToLeft) and (not ARightToLeft) then + ChangeBiDiModeAlignment(Alignment); + case Alignment of + taLeftJustify: X := ARect.Left + DX; + taRightJustify: X := ARect.Right - ACanvas.TextWidth(AText) - 3; + else + X := ARect.Left + (ARect.Right - ARect.Left) shr 1 - (ACanvas.TextWidth(AText) shr 1); + end; + ACanvas.TextRect(ARect, X, ARect.Top + DY, AText); +end; + + +{ TDBGrid } + +procedure TDBGrid.DrawCell(ACol, ARow: Integer; ARect: TRect; AState: TGridDrawState); +var + OldActive: Integer; + Indicator: TThemedGrid; + Value: string; + CurrentColumn: TColumn; + MultiSelected: Boolean; + X: Integer; + LStyleServices: TCustomStyleServices; + DeltaX: Byte; + Index: Integer; +begin + LStyleServices := StyleServices; + if not TStyleManager.IsCustomStyleActive or (ARow-TitleOffset<0) then + begin + inherited DrawCell(ACol, ARow, ARect, AState); + exit; + end; + + if csLoading in ComponentState then + begin + Canvas.Brush.Color := LStyleServices.GetStyleColor(scGrid); + Canvas.FillRect(ARect); + Exit; + end; + + Dec(ARow, TitleOffset); + Dec(ACol, IndicatorOffset); + + if (gdFixed in AState) and ([dgRowLines, dgColLines] * Options = + [dgRowLines, dgColLines]) then + begin + Winapi.Windows.InflateRect(ARect, -1, -1); + DeltaX := 1; + end + else + DeltaX := 2; + + if (gdFixed in AState) and (ACol < 0) then + begin + DrawCellBackground(ARect, FixedColor, AState, ACol, ARow); + if Assigned(DataLink) and DataLink.Active then + begin + MultiSelected := False; + + if ARow >= 0 then + begin + OldActive := DataLink.ActiveRecord; + try + DataLink.ActiveRecord := ARow; + MultiSelected := (dgMultiSelect in Options) and Datalink.Active and SelectedRows.Find(Datalink.Datasource.Dataset.Bookmark, Index);; + finally + DataLink.ActiveRecord := OldActive; + end; + end; + + if (ARow = DataLink.ActiveRecord) or MultiSelected then + begin + Indicator := tgIndicatorArrow; + if DataLink.DataSet <> nil then + case DataLink.DataSet.State of + dsEdit: Indicator := tgIndicatorEdit; + dsInsert: Indicator := tgIndicatorInsert; + dsBrowse: + if MultiSelected then + if (ARow <> DataLink.ActiveRecord) then + Indicator := tgIndicatorMultiDot + else + Indicator := tgIndicatorMultiArrow; + end; + Indicators.BkColor := FixedColor; + X := ARect.Right - Indicators.Width - DeltaX; + if Canvas.CanvasOrientation = coRightToLeft then + Inc(X); + + if LStyleServices.Enabled and not LStyleServices.IsSystemStyle then + LStyleServices.DrawElement(Canvas.Handle, LStyleServices.GetElementDetails(Indicator), ARect) + else + Indicators.Draw(Canvas, X, (ARect.Top + ARect.Bottom - Indicators.Height) shr 1, Integer(Indicator) - Integer(tgIndicatorArrow), True); + + if ARow = Datalink.ActiveRecord then + SelRow := ARow + TitleOffset; + end; + end; + end + else + with Canvas do + begin + CurrentColumn := Columns[ACol]; + if not CurrentColumn.Showing then Exit; + if not (gdFixed in AState) then + begin + Font := CurrentColumn.Font; + Brush.Color := CurrentColumn.Color; + + if (Brush.Color=LStyleServices.GetStyleColor(scGrid)) then + begin + Font.Color := LStyleServices.GetStyleFontColor(sfGridItemNormal); + Brush.Color := LStyleServices.GetStyleColor(scGrid); + end; + + end; + + if (DataLink = nil) or not DataLink.Active then + FillRect(ARect) + else + begin + Value := ''; + OldActive := DataLink.ActiveRecord; + try + DataLink.ActiveRecord := ARow; + if Assigned(CurrentColumn.Field) then + Value := CurrentColumn.Field.DisplayText; + if HighlightCell(ACol, ARow, Value, AState) and DefaultDrawing then + DrawCellHighlight(ARect, AState, ACol, ARow); + if not Enabled then + Font.Color := clGrayText; + + if DefaultDrawing then + _WriteText(Canvas, ARect, 3, 2, Value, CurrentColumn.Alignment, UseRightToLeftAlignmentForField(CurrentColumn.Field, CurrentColumn.Alignment)); + + if Columns.State = csDefault then + DrawDataCell(ARect, CurrentColumn.Field, AState); + DrawColumnCell(ARect, ACol, CurrentColumn, AState); + finally + DataLink.ActiveRecord := OldActive; + end; + Canvas.Brush.Style := bsSolid; + + if DefaultDrawing and (gdSelected in AState) and ((dgAlwaysShowSelection in Options) or Focused) + and not (csDesigning in ComponentState) and not (dgRowSelect in Options) + and (UpdateLock = 0) and (ValidParentForm(Self).ActiveControl = Self) and + (FInternalDrawingStyle = gdsThemed) and (Win32MajorVersion >= 6) then + Winapi.Windows.InflateRect(ARect, -1, -1); + + end; + end; + + if (gdFixed in AState) and ([dgRowLines, dgColLines] * Options = + [dgRowLines, dgColLines]) and (FInternalDrawingStyle = gdsClassic) and + not (gdPressed in AState) then + Winapi.Windows.InflateRect(ARect, 1, 1); +end; + + +end. diff --git a/source/vcl-styles-utils/Vcl.Styles.Ext.pas b/source/vcl-styles-utils/Vcl.Styles.Ext.pas index 8ad1e0ccd..bfdbf792e 100644 --- a/source/vcl-styles-utils/Vcl.Styles.Ext.pas +++ b/source/vcl-styles-utils/Vcl.Styles.Ext.pas @@ -15,7 +15,7 @@ // The Original Code is Vcl.Styles.Ext.pas. // // The Initial Developer of the Original Code is Rodrigo Ruz V. -// Portions created by Rodrigo Ruz V. are Copyright (C) 2012-2020 Rodrigo Ruz V. +// Portions created by Rodrigo Ruz V. are Copyright (C) 2012-2023 Rodrigo Ruz V. // All Rights Reserved. // // ************************************************************************************************** @@ -93,6 +93,7 @@ TVclStylesPreview = class(TCustomControl) TSourceInfo = record Data: TStyleServicesHandle; StyleClass: TCustomStyleServicesClass; + {$IF CompilerVersion >= 35}DesigningState: Boolean;{$IFEND} end; {$REGION 'Documentation'} @@ -256,12 +257,17 @@ implementation Vcl.Direct2D, System.StrUtils, Winapi.D2D1, -{$IFEND} +{$IFEND} +{$IF CompilerVersion >= 36} + Vcl.StyleBitmap, + Vcl.StyleAPI, +{$IFEND} Winapi.Messages, {$ENDIF} - Vcl.Dialogs; + Vcl.Dialogs, Vcl.Styles.Utils.Misc, + Vcl.Styles.Utils.Graphics; -{$IF (DEFINED (USE_VCL_STYLESAPI) AND (CompilerVersion >= 23))} +{$IF (DEFINED (USE_VCL_STYLESAPI) AND (CompilerVersion >= 23) AND (CompilerVersion <= 35))} {$I '..\source\vcl\StyleUtils.inc'} {$I '..\source\vcl\StyleAPI.inc'} {$IFEND} @@ -411,6 +417,12 @@ class function TStyleManagerHelper.RegisteredStyles: TDictionary= 35)} //Alexandria. + with Self do + p := Pointer(@FRegisteredStyles); +{$IFEND} + LRegisteredStyles := TDictionary(p^); {$IFEND} for t in LRegisteredStyles do @@ -582,6 +594,20 @@ procedure RemoveEmptyVCLStyleHook(ControlClass: TClass); end; {$IFDEF USE_VCL_STYLESAPI} +type + TseStyleHelper = class Helper for TseStyle + strict private + function GetCleanCopy: TSeStyleSource; + public + property CleanCopy: TSeStyleSource read GetCleanCopy; + end; + +function TseStyleHelper.GetCleanCopy: TSeStyleSource; +begin + with Self do + Result := FCleanCopy; +end; + { TVCLStyleExt } constructor TCustomStyleExt.Create(const FileName: string); @@ -603,22 +629,22 @@ procedure TCustomStyleExt.CopyToStream(Stream: TStream); Stream.Size := 0; Stream.Position := 0; - TseStyle(Source).FCleanCopy.Name := TseStyle(Source).StyleSource.Name; - TseStyle(Source).FCleanCopy.Author := TseStyle(Source).StyleSource.Author; - TseStyle(Source).FCleanCopy.AuthorEMail := TseStyle(Source).StyleSource.AuthorEMail; - TseStyle(Source).FCleanCopy.AuthorURL := TseStyle(Source).StyleSource.AuthorURL; - TseStyle(Source).FCleanCopy.Version := TseStyle(Source).StyleSource.Version; + TseStyle(Source).CleanCopy.Name := TseStyle(Source).StyleSource.Name; + TseStyle(Source).CleanCopy.Author := TseStyle(Source).StyleSource.Author; + TseStyle(Source).CleanCopy.AuthorEMail := TseStyle(Source).StyleSource.AuthorEMail; + TseStyle(Source).CleanCopy.AuthorURL := TseStyle(Source).StyleSource.AuthorURL; + TseStyle(Source).CleanCopy.Version := TseStyle(Source).StyleSource.Version; // Replace the modified bitmaps - for I := 0 to TseStyle(Source).FCleanCopy.Bitmaps.Count - 1 do - TseStyle(Source).FCleanCopy.Bitmaps[I].Assign(TseStyle(Source).StyleSource.Bitmaps[I]); + for I := 0 to TseStyle(Source).CleanCopy.Bitmaps.Count - 1 do + TseStyle(Source).CleanCopy.Bitmaps[I].Assign(TseStyle(Source).StyleSource.Bitmaps[I]); // TseStyle(Source).StyleSource.SysColors.Assign(TseStyle(Source).SysColors); // Replace the modified colors - TseStyle(Source).FCleanCopy.SysColors.Assign(TseStyle(Source).SysColors); - TseStyle(Source).FCleanCopy.Colors.Assign(TseStyle(Source).Colors); - TseStyle(Source).FCleanCopy.Fonts.Assign(TseStyle(Source).Fonts); + TseStyle(Source).CleanCopy.SysColors.Assign(TseStyle(Source).SysColors); + TseStyle(Source).CleanCopy.Colors.Assign(TseStyle(Source).Colors); + TseStyle(Source).CleanCopy.Fonts.Assign(TseStyle(Source).Fonts); // ShowMessage(ColorToString(TseStyle(Source).SysColors[clWindow])); TseStyle(Source).SaveToStream(Stream); @@ -1603,7 +1629,7 @@ procedure TVclStylesPreview.Paint; // Draw background LDetails.Element := teWindow; LDetails.Part := 0; - Style.DrawElement(FBitmap.Canvas.Handle, LDetails, ARect); + DrawStyleElement(FBitmap.Canvas.Handle, LDetails, ARect, True, FStyle); // Draw caption border CaptionRect := Rect(0, 0, CaptionBitmap.Width, CaptionBitmap.Height); @@ -1623,7 +1649,7 @@ procedure TVclStylesPreview.Paint; SetWindowRgn(Handle, Region, True); } - Style.DrawElement(CaptionBitmap.Canvas.Handle, LDetails, CaptionRect); + DrawStyleElement(CaptionBitmap.Canvas.Handle, LDetails, CaptionRect, True, FStyle); TextRect := CaptionRect; CaptionDetails := LDetails; @@ -1631,7 +1657,7 @@ procedure TVclStylesPreview.Paint; IconDetails := Style.GetElementDetails(twSysButtonNormal); if not Style.GetElementContentRect(0, IconDetails, CaptionRect, ButtonRect) then ButtonRect := Rect(0, 0, 0, 0); - IconRect := Rect(0, 0, GetSystemMetrics(SM_CXSMICON), GetSystemMetrics(SM_CYSMICON)); + IconRect := Rect(0, 0, GetSysMetrics(SM_CXSMICON), GetSysMetrics(SM_CYSMICON)); RectVCenter(IconRect, ButtonRect); if (ButtonRect.Width > 0) and (FIcon <> 0) then @@ -1643,28 +1669,34 @@ procedure TVclStylesPreview.Paint; // Close button LDetails := Style.GetElementDetails(twCloseButtonNormal); if Style.GetElementContentRect(0, LDetails, CaptionRect, ButtonRect) then - Style.DrawElement(CaptionBitmap.Canvas.Handle, LDetails, ButtonRect); + DrawStyleElement(CaptionBitmap.Canvas.Handle, LDetails, ButtonRect, True, FStyle); // Maximize button LDetails := Style.GetElementDetails(twMaxButtonNormal); if Style.GetElementContentRect(0, LDetails, CaptionRect, ButtonRect) then - Style.DrawElement(CaptionBitmap.Canvas.Handle, LDetails, ButtonRect); + DrawStyleElement(CaptionBitmap.Canvas.Handle, LDetails, ButtonRect, True, FStyle); // Minimize button LDetails := Style.GetElementDetails(twMinButtonNormal); if Style.GetElementContentRect(0, LDetails, CaptionRect, ButtonRect) then - Style.DrawElement(CaptionBitmap.Canvas.Handle, LDetails, ButtonRect); + DrawStyleElement(CaptionBitmap.Canvas.Handle, LDetails, ButtonRect, True, FStyle); // Help button LDetails := Style.GetElementDetails(twHelpButtonNormal); if Style.GetElementContentRect(0, LDetails, CaptionRect, ButtonRect) then - Style.DrawElement(CaptionBitmap.Canvas.Handle, LDetails, ButtonRect); + DrawStyleElement(CaptionBitmap.Canvas.Handle, LDetails, ButtonRect, True, FStyle); if ButtonRect.Left > 0 then TextRect.Right := ButtonRect.Left; // Draw text + {$IF RTLVersion > 28} + if Assigned(Application.Mainform) then + CaptionBitmap.Canvas.Font.Size := Round(8*Application.MainForm.Monitor.PixelsPerInch / 96) + else + {$IFEND} + CaptionBitmap.Canvas.Font.Size := Round(8*Screen.PixelsPerInch / 96); Style.DrawText(CaptionBitmap.Canvas.Handle, CaptionDetails, FCaption, TextRect, [tfLeft, tfSingleLine, tfVerticalCenter]); @@ -1678,62 +1710,105 @@ procedure TVclStylesPreview.Paint; CaptionRect := Rect(0, BorderRect.Top, BorderRect.Left, ARect.Height - BorderRect.Bottom); LDetails := Style.GetElementDetails(twFrameLeftActive); if CaptionRect.Bottom - CaptionRect.Top > 0 then - Style.DrawElement(FBitmap.Canvas.Handle, LDetails, CaptionRect); + DrawStyleElement(FBitmap.Canvas.Handle, LDetails, CaptionRect, True, FStyle); // Draw right border CaptionRect := Rect(ARect.Width - BorderRect.Right, BorderRect.Top, ARect.Width, ARect.Height - BorderRect.Bottom); LDetails := Style.GetElementDetails(twFrameRightActive); - Style.DrawElement(FBitmap.Canvas.Handle, LDetails, CaptionRect); + DrawStyleElement(FBitmap.Canvas.Handle, LDetails, CaptionRect, True, FStyle); // Draw Bottom border CaptionRect := Rect(0, ARect.Height - BorderRect.Bottom, ARect.Width, ARect.Height); LDetails := Style.GetElementDetails(twFrameBottomActive); - Style.DrawElement(FBitmap.Canvas.Handle, LDetails, CaptionRect); + DrawStyleElement(FBitmap.Canvas.Handle, LDetails, CaptionRect, True, FStyle); + + {$IF RTLVersion > 28} + if Assigned(Application.Mainform) then + FBitmap.Canvas.Font.Size := Round(8 * Application.MainForm.Monitor.PixelsPerInch / Screen.PixelsPerInch) + else + {$IFEND} + FBitmap.Canvas.Font.Size := 8; // Draw Main Menu LDetails := Style.GetElementDetails(tmMenuBarBackgroundActive); - LRect := Rect(BorderRect.Left, BorderRect.Top + 1, ARect.Width - BorderRect.Left, BorderRect.Top + 1 + 20); - Style.DrawElement(FBitmap.Canvas.Handle, LDetails, LRect); + LRect := Rect(BorderRect.Left, BorderRect.Top + 1, ARect.Width - BorderRect.Left,BorderRect.Top + FBitmap.Canvas.TextHeight('Tq')+4); + DrawStyleElement(FBitmap.Canvas.Handle, LDetails, LRect, True, FStyle); LDetails := Style.GetElementDetails(tmMenuBarItemNormal); Style.GetElementColor(LDetails, ecTextColor, ThemeTextColor); + CaptionRect := Rect(LRect.Left+10,LRect.Top+3, LRect.Left+10+FBitmap.Canvas.TextWidth('File') + 8 ,LRect.Bottom); + DrawStyleElement(FBitmap.Canvas.Handle, LDetails, CaptionRect, True, FStyle); + FBitmap.Canvas.Font.Color := ThemeTextColor; + DrawText(FBitmap.Canvas, 'File', CaptionRect, DT_CENTER); + CaptionRect.Left := CaptionRect.Right + 2; + + CaptionRect.Right := CaptionRect.Left + FBitmap.Canvas.TextWidth('Edit') + 8; + LDetails := Style.GetElementDetails(tmMenuBarItemHot); + Style.GetElementColor(LDetails, ecTextColor, ThemeTextColor); + DrawStyleElement(FBitmap.Canvas.Handle, LDetails, CaptionRect, True, FStyle); + FBitmap.Canvas.Font.Color := ThemeTextColor; + DrawText(FBitmap.Canvas, 'Edit', CaptionRect, DT_CENTER); + CaptionRect.Left := CaptionRect.Right + 2; - // function DrawText(DC: HDC; Details: TThemedElementDetails; - // const S: string; var R: TRect; Flags: TTextFormat; Color: TColor = clNone): Boolean; overload; - // function DrawText(DC: HDC; Details: TThemedElementDetails; - // const S: string; var R: TRect; Flags: TTextFormat; Options: TStyleTextOptions): Boolean; overload; + CaptionRect.Right := CaptionRect.Left + FBitmap.Canvas.TextWidth('View') + 8; + LDetails := Style.GetElementDetails(tmMenuBarItemNormal); + Style.GetElementColor(LDetails, ecTextColor, ThemeTextColor); + DrawStyleElement(FBitmap.Canvas.Handle, LDetails, CaptionRect, True, FStyle); + FBitmap.Canvas.Font.Color := ThemeTextColor; + DrawText(FBitmap.Canvas, 'View', CaptionRect, DT_CENTER); + CaptionRect.Left := CaptionRect.Right + 2; - CaptionRect := Rect(LRect.Left + 10, LRect.Top + 3, LRect.Right, LRect.Bottom); - Style.DrawText(FBitmap.Canvas.Handle, LDetails, 'File', CaptionRect, [tfLeft], ThemeTextColor); - CaptionRect := Rect(LRect.Left + 40, LRect.Top + 3, LRect.Right, LRect.Bottom); - Style.DrawText(FBitmap.Canvas.Handle, LDetails, 'Edit', CaptionRect, [tfLeft], ThemeTextColor); - CaptionRect := Rect(LRect.Left + 70, LRect.Top + 3, LRect.Right, LRect.Bottom); - Style.DrawText(FBitmap.Canvas.Handle, LDetails, 'View', CaptionRect, [tfLeft], ThemeTextColor); - CaptionRect := Rect(LRect.Left + 110, LRect.Top + 3, LRect.Right, LRect.Bottom); - Style.DrawText(FBitmap.Canvas.Handle, LDetails, 'Help', CaptionRect, [tfLeft], ThemeTextColor); + CaptionRect.Right := CaptionRect.Left + FBitmap.Canvas.TextWidth('Help') + 8; + LDetails := Style.GetElementDetails(tmMenuBarItemDisabled); + Style.GetElementColor(LDetails, ecTextColor, ThemeTextColor); + DrawStyleElement(FBitmap.Canvas.Handle, LDetails, CaptionRect, True, FStyle); + FBitmap.Canvas.Font.Color := ThemeTextColor; + DrawText(FBitmap.Canvas, 'Help', CaptionRect, DT_CENTER); // Draw ToolButtons - for I := 1 to 3 do + LDetails := Style.GetElementDetails(ttbButtonNormal); + Style.GetElementColor(LDetails, ecTextColor, ThemeTextColor); + ButtonRect.Left := BorderRect.Left + 2; + for i := 1 to 3 do begin - LDetails := Style.GetElementDetails(ttbButtonNormal); - ButtonRect.Left := BorderRect.Left + 5 + ((I - 1) * 76); ButtonRect.Top := LRect.Top + 30; - ButtonRect.Width := 75; - ButtonRect.Height := 25; - Style.DrawElement(FBitmap.Canvas.Handle, LDetails, ButtonRect); + {$IF RTLVersion > 28} + if Assigned(Application.Mainform) then + begin + ButtonRect.Width := Round(65 * Application.MainForm.Monitor.PixelsPerInch / 96); + ButtonRect.Height := Round(25 * Application.MainForm.Monitor.PixelsPerInch / 96); + end + else + {$IFEND} + begin + ButtonRect.Width := Round(65 * Screen.PixelsPerInch / 96); + ButtonRect.Height := Round(25 * Screen.PixelsPerInch / 96); + end; - Style.GetElementColor(LDetails, ecTextColor, ThemeTextColor); + DrawStyleElement(FBitmap.Canvas.Handle, LDetails, ButtonRect, True, FStyle); Style.DrawText(FBitmap.Canvas.Handle, LDetails, 'ToolButton' + IntToStr(I), ButtonRect, TTextFormatFlags(DT_VCENTER or DT_CENTER), ThemeTextColor); + + ButtonRect.Left := ButtonRect.Right + 2; end; // Draw Normal LDetails := Style.GetElementDetails(tbPushButtonNormal); - ButtonRect.Left := BorderRect.Left + 5; + ButtonRect.Left := BorderRect.Left + 2; ButtonRect.Top := ARect.Height - 45; - ButtonRect.Width := 75; - ButtonRect.Height := 25; - Style.DrawElement(FBitmap.Canvas.Handle, LDetails, ButtonRect); + {$IF RTLVersion > 28} + if Assigned(Application.Mainform) then + begin + ButtonRect.Width := Round(65 * Application.MainForm.Monitor.PixelsPerInch / 96); + ButtonRect.Height := Round(25 * Application.MainForm.Monitor.PixelsPerInch / 96); + end + else + {$IFEND} + begin + ButtonRect.Width := Round(65 * Screen.PixelsPerInch / 96); + ButtonRect.Height := Round(25 * Screen.PixelsPerInch / 96); + end; + DrawStyleElement(FBitmap.Canvas.Handle, LDetails, ButtonRect, True, FStyle); Style.GetElementColor(LDetails, ecTextColor, ThemeTextColor); Style.DrawText(FBitmap.Canvas.Handle, LDetails, 'Normal', ButtonRect, TTextFormatFlags(DT_VCENTER or DT_CENTER), @@ -1741,11 +1816,21 @@ procedure TVclStylesPreview.Paint; // Draw Hot LDetails := Style.GetElementDetails(tbPushButtonHot); - ButtonRect.Left := BorderRect.Left + 85; + ButtonRect.Left := ButtonRect.Right + 2; ButtonRect.Top := ARect.Height - 45; - ButtonRect.Width := 75; - ButtonRect.Height := 25; - Style.DrawElement(FBitmap.Canvas.Handle, LDetails, ButtonRect); + {$IF RTLVersion > 28} + if Assigned(Application.Mainform) then + begin + ButtonRect.Width := Round(65 * Application.MainForm.Monitor.PixelsPerInch / 96); + ButtonRect.Height := Round(25 * Application.MainForm.Monitor.PixelsPerInch / 96); + end + else + {$IFEND} + begin + ButtonRect.Width := Round(65 * Screen.PixelsPerInch / 96); + ButtonRect.Height := Round(25 * Screen.PixelsPerInch / 96); + end; + DrawStyleElement(FBitmap.Canvas.Handle, LDetails, ButtonRect, True, FStyle); Style.GetElementColor(LDetails, ecTextColor, ThemeTextColor); Style.DrawText(FBitmap.Canvas.Handle, LDetails, 'Hot', ButtonRect, TTextFormatFlags(DT_VCENTER or DT_CENTER), @@ -1753,11 +1838,21 @@ procedure TVclStylesPreview.Paint; // Draw Pressed LDetails := Style.GetElementDetails(tbPushButtonPressed); - ButtonRect.Left := BorderRect.Left + 165; + ButtonRect.Left := ButtonRect.Right + 2; ButtonRect.Top := ARect.Height - 45; - ButtonRect.Width := 75; - ButtonRect.Height := 25; - Style.DrawElement(FBitmap.Canvas.Handle, LDetails, ButtonRect); + {$IF RTLVersion > 28} + if Assigned(Application.Mainform) then + begin + ButtonRect.Width := Round(65 * Application.MainForm.Monitor.PixelsPerInch / 96); + ButtonRect.Height := Round(25 * Application.MainForm.Monitor.PixelsPerInch / 96); + end + else + {$IFEND} + begin + ButtonRect.Width := Round(65 * Screen.PixelsPerInch / 96); + ButtonRect.Height := Round(25 * Screen.PixelsPerInch / 96); + end; + DrawStyleElement(FBitmap.Canvas.Handle, LDetails, ButtonRect, True, FStyle); Style.GetElementColor(LDetails, ecTextColor, ThemeTextColor); Style.DrawText(FBitmap.Canvas.Handle, LDetails, 'Pressed', ButtonRect, TTextFormatFlags(DT_VCENTER or DT_CENTER), @@ -1765,11 +1860,21 @@ procedure TVclStylesPreview.Paint; // Draw Disabled LDetails := Style.GetElementDetails(tbPushButtonDisabled); - ButtonRect.Left := BorderRect.Left + 245; + ButtonRect.Left := ButtonRect.Right + 2; ButtonRect.Top := ARect.Height - 45; - ButtonRect.Width := 75; - ButtonRect.Height := 25; - Style.DrawElement(FBitmap.Canvas.Handle, LDetails, ButtonRect); + {$IF RTLVersion > 28} + if Assigned(Application.Mainform) then + begin + ButtonRect.Width := Round(65 * Application.MainForm.Monitor.PixelsPerInch / 96); + ButtonRect.Height := Round(25 * Application.MainForm.Monitor.PixelsPerInch / 96); + end + else + {$IFEND} + begin + ButtonRect.Width := Round(65 * Screen.PixelsPerInch / 96); + ButtonRect.Height := Round(25 * Screen.PixelsPerInch / 96); + end; + DrawStyleElement(FBitmap.Canvas.Handle, LDetails, ButtonRect, True, FStyle); Style.GetElementColor(LDetails, ecTextColor, ThemeTextColor); Style.DrawText(FBitmap.Canvas.Handle, LDetails, 'Disabled', ButtonRect, TTextFormatFlags(DT_VCENTER or DT_CENTER), @@ -1781,13 +1886,17 @@ procedure TVclStylesPreview.Paint; initialization {$IFDEF USE_VCL_STYLESAPI} + {$IF CompilerVersion <= 35} InitStyleAPI; + {$IFEND} {$ENDIF} finalization {$IFDEF USE_VCL_STYLESAPI} + {$IF CompilerVersion <= 35} FinalizeStyleAPI; + {$IFEND} {$ENDIF} end. diff --git a/source/vcl-styles-utils/Vcl.Styles.Fixes.pas b/source/vcl-styles-utils/Vcl.Styles.Fixes.pas index ea9b096b7..f4c870ee6 100644 --- a/source/vcl-styles-utils/Vcl.Styles.Fixes.pas +++ b/source/vcl-styles-utils/Vcl.Styles.Fixes.pas @@ -1,826 +1,826 @@ -// ************************************************************************************************** -// -// Unit Vcl.Styles.Fixes -// unit for the VCL Styles Utils -// https://github.com/RRUZ/vcl-styles-utils/ -// -// 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. -// -// The Original Code is Vcl.Styles.Fixes -// -// The Initial Developer of the Original Code is Rodrigo Ruz V. -// Portions created by Rodrigo Ruz V. are Copyright (C) 2012-2019 Rodrigo Ruz V. -// All Rights Reserved. -// -// Contributors -// -// Leonardo Cechet -// -// ************************************************************************************************** - -unit Vcl.Styles.Fixes; - -interface - -uses - Winapi.Windows, - Winapi.Messages, - Vcl.Controls, - Vcl.ComCtrls, - Vcl.StdCtrls, - Vcl.ExtCtrls, - Vcl.Graphics; - -{$IF CompilerVersion >= 23.0} -type - /// The TButtonStyleHookFix vcl style hook fix these QC #103708, #107764 for Delphi XE2 - /// and the https://quality.embarcadero.com/browse/RSP-11619 issue present in X2-XE8 - /// - /// - /// Use this hook in this way - /// - /// TStyleManager.Engine.RegisterStyleHook(TButton, TButtonStyleHookFix); - /// - /// - TButtonStyleHookFix = class(TButtonStyleHook) - protected - procedure Paint(Canvas: TCanvas); override; - end; -{$IFEND} - -{$IF CompilerVersion <= 27.0} -type - /// The TListViewStyleHookFix vcl style hook fix these QC #108678, #108875 for Delphi XE2-XE6 - /// - /// - /// Use this hook in this way - /// - /// TStyleManager.Engine.RegisterStyleHook(TListView, TListViewStyleHookFix); - /// - /// - TListViewStyleHookFix = class(TListViewStyleHook) - procedure DrawHeaderSection(Canvas: TCanvas; R: TRect; Index: Integer; - const Text: string; IsPressed, IsBackground: Boolean); override; - end; -{$IFEND} - -{$IF CompilerVersion <= 24.0} -type - /// This interposer class fix the QC #114032 for Delphi XE2 and Delphi XE3 - /// - /// - /// To use this class add the Vcl.Styles.Fixes unit to your uses list after of the Vcl.ExtCtrls unit - /// - TColorBox = class(Vcl.ExtCtrls.TColorBox) - private - procedure CNDrawItem(var Message: TWMDrawItem); message CN_DRAWITEM; - end; - - /// The TComboBoxExStyleHookFix vcl style hook fix the QC #108678 for Delphi XE2 and Delphi XE3 - /// - /// - /// Use this hook in this way - /// - /// TStyleManager.Engine.RegisterStyleHook(TComboBoxEx, TComboBoxExStyleHookFix); - /// - /// - TComboBoxExStyleHookFix = class(TComboBoxExStyleHook) - strict protected - procedure DrawListBoxItem(ADC: HDC; ARect: TRect; AIndex: Integer; - ASelected: Boolean); - procedure ComboBoxWndProc(var Msg: TMessage); override; - procedure DrawComboBox(DC: HDC); override; - end; -{$IFEND} - -{$IF CompilerVersion <= 26.0} - /// The TComboBoxStyleHookFix vcl style hook fix the QC #114632 for Delphi XE5 and earlier - /// - /// - /// Use this hook in this way - /// - /// TStyleManager.Engine.RegisterStyleHook(TComboBox, TComboBoxStyleHookFix); - /// - /// - TComboBoxStyleHookFix = class(TComboBoxStyleHook) - strict private - FTempItemIndex: Integer; - procedure WMCommand(var Message: TWMCommand); message WM_COMMAND; - procedure CNCommand(var Message: TWMCommand); message CN_COMMAND; - strict protected - procedure DrawItem(Canvas: TCanvas; Index: Integer; - const R: TRect; Selected: Boolean); override; - public - constructor Create(AControl: TWinControl); override; - end; -{$IFEND} - -implementation - -uses - Winapi.CommCtrl, - Vcl.Themes, - Vcl.Forms, - System.SysUtils, - System.Classes, - System.UITypes, - System.Types; - -type - TCustomButtonClass = class(TCustomButton); - TWinControlClass = class(TWinControl); - -{$IF CompilerVersion >= 23.0} - - // we need this helper to access some strict private fields - TButtonStyleHookHelper = class Helper for TButtonStyleHook - protected - function Pressed: Boolean; - function DropDown: Boolean; - end; -{$IFEND} - -{$IF CompilerVersion <= 27.0} - TListViewStyleHookHelper = class helper for TListViewStyleHook - function HeaderHandle: HWnd; - end; -{$IFEND} - -{$IF CompilerVersion <= 24.0} - TComboBoxExStyleHookHelper = class helper for TComboBoxExStyleHook - function DroppedDown: Boolean; - end; -{$IFEND} - -{$IF CompilerVersion <= 26.0} - TComboBoxStyleHookHelper = class helper for TComboBoxStyleHook - strict private - function _getDroppedDown: Boolean; - private - property _DroppedDown : Boolean read _getDroppedDown; - end; -{$IFEND} - -{$IF CompilerVersion >= 23.0} - -procedure TButtonStyleHookFix.Paint(Canvas: TCanvas); -const - PBS_NORMAL = 0; - PBS_HOT = 1; - PBS_PRESSED = 2; - PBS_DISABLED = 3; - PBS_DEFAULTED = 4; - PBS_STYLUSHOT = 5; -var - LDetails: TThemedElementDetails; - DrawRect: TRect; - pbuttonImagelist: BUTTON_IMAGELIST; - IW, IH, IY: Integer; - LTextFormatFlags: TTextFormatFlags; - ThemeTextColor: TColor; - Buffer: string; - BufferLength: Integer; - SaveIndex: Integer; - X, Y, I: Integer; - IsDefault: Boolean; - BCaption: String; - LImageIndex: Integer; -begin - LImageIndex:=PBS_NORMAL; - IsDefault := (Control is TCustomButton) and (TCustomButton(Control).Default); - - if StyleServices.Available then - begin - BCaption := Text; - - if not Control.Enabled then - begin - LDetails := StyleServices.GetElementDetails(tbPushButtonDisabled); - LImageIndex := PBS_DISABLED; - end - else - if Pressed then - begin - LDetails := StyleServices.GetElementDetails(tbPushButtonPressed); - LImageIndex := PBS_PRESSED; - end - else - if MouseInControl then - begin - LDetails := StyleServices.GetElementDetails(tbPushButtonHot); - LImageIndex := PBS_HOT; - end - else - if Control.Focused or (IsDefault and (Screen.ActiveControl<>nil) and not (Screen.ActiveControl is TCustomButton) ) then - begin - LDetails := StyleServices.GetElementDetails(tbPushButtonDefaulted); - LImageIndex := PBS_DEFAULTED; - end - else if Control.Enabled then - LDetails := StyleServices.GetElementDetails(tbPushButtonNormal); - - DrawRect := Control.ClientRect; - StyleServices.DrawElement(Canvas.Handle, LDetails, DrawRect); - - if Button_GetImageList(Handle, pbuttonImagelist) and - (pbuttonImagelist.himl <> 0) and - ImageList_GetIconSize(pbuttonImagelist.himl, IW, IH) then - begin - - if (GetWindowLong(Handle, GWL_STYLE) and BS_COMMANDLINK) = BS_COMMANDLINK - then - IY := DrawRect.Top + 15 - else - IY := DrawRect.Top + (DrawRect.Height - IH) div 2; - - // here the image is drawn properly according to the ImageAlignment value - case TCustomButton(Control).ImageAlignment of - TImageAlignment.iaLeft: - begin - ImageList_Draw(pbuttonImagelist.himl, LImageIndex, Canvas.Handle, - DrawRect.Left + 3 + TCustomButton(Control).ImageMargins.Left, IY, ILD_NORMAL); - Inc(DrawRect.Left, IW + 3 + TCustomButton(Control).ImageMargins.Left); - end; - - TImageAlignment.iaRight: - begin - ImageList_Draw(pbuttonImagelist.himl, LImageIndex, Canvas.Handle, - DrawRect.Right - IW - 3 - TCustomButton(Control).ImageMargins.Right, IY, ILD_NORMAL); - Dec(DrawRect.Right, IW - 3 + TCustomButton(Control).ImageMargins.Right); - end; - - TImageAlignment.iaCenter: - begin - ImageList_Draw(pbuttonImagelist.himl, LImageIndex, Canvas.Handle, - (DrawRect.Right - IW) div 2, IY + TCustomButton(Control).ImageMargins.Top - TCustomButton(Control).ImageMargins.Bottom, ILD_NORMAL); - end; - - TImageAlignment.iaTop: - begin - ImageList_Draw(pbuttonImagelist.himl, LImageIndex, Canvas.Handle, - (DrawRect.Right - IW) div 2, 3 + TCustomButton(Control).ImageMargins.Top - TCustomButton(Control).ImageMargins.Bottom, ILD_NORMAL); - end; - - TImageAlignment.iaBottom: - begin - ImageList_Draw(pbuttonImagelist.himl, LImageIndex, Canvas.Handle, - (DrawRect.Right - IW) div 2, (DrawRect.Height - IH) - 3 + TCustomButton(Control).ImageMargins.Top - TCustomButton(Control).ImageMargins.Bottom, - ILD_NORMAL); - end; - - end; - - end; - - if (GetWindowLong(Handle, GWL_STYLE) and BS_COMMANDLINK) = BS_COMMANDLINK then - begin - if pbuttonImagelist.himl = 0 then - Inc(DrawRect.Left, 35); - - Inc(DrawRect.Top, 15); - Inc(DrawRect.Left, 5); - Canvas.Font := TCustomButtonClass(Control).Font; - Canvas.Font.Style := []; - Canvas.Font.Size := 12; - LTextFormatFlags := TTextFormatFlags(DT_LEFT); - if StyleServices.GetElementColor(LDetails, ecTextColor, ThemeTextColor) - then - Canvas.Font.Color := ThemeTextColor; - StyleServices.DrawText(Canvas.Handle, LDetails, BCaption, DrawRect, - LTextFormatFlags, Canvas.Font.Color); - SetLength(Buffer, Button_GetNoteLength(Handle) + 1); - if Length(Buffer) <> 0 then - begin - BufferLength := Length(Buffer); - if Button_GetNote(Handle, PChar(Buffer), BufferLength) then - begin - LTextFormatFlags := TTextFormatFlags(DT_LEFT or DT_WORDBREAK); - Inc(DrawRect.Top, Canvas.TextHeight('Wq') + 2); - Canvas.Font.Size := 8; - StyleServices.DrawText(Canvas.Handle, LDetails, Buffer, DrawRect, - LTextFormatFlags, Canvas.Font.Color); - end; - end; - - if pbuttonImagelist.himl = 0 then - begin - if Pressed then - LDetails := StyleServices.GetElementDetails(tbCommandLinkGlyphPressed) - else if MouseInControl then - LDetails := StyleServices.GetElementDetails(tbCommandLinkGlyphHot) - else if Control.Enabled then - LDetails := StyleServices.GetElementDetails(tbCommandLinkGlyphNormal) - else - LDetails := StyleServices.GetElementDetails - (tbCommandLinkGlyphDisabled); - DrawRect.Right := 35; - DrawRect.Left := 3; - DrawRect.Top := 10; - DrawRect.Bottom := DrawRect.Top + 32; - StyleServices.DrawElement(Canvas.Handle, LDetails, DrawRect); - end; - - end - else if (GetWindowLong(Handle, GWL_STYLE) and BS_SPLITBUTTON) = BS_SPLITBUTTON - then - begin - Dec(DrawRect.Right, 15); - DrawControlText(Canvas, LDetails, Text, DrawRect, DT_VCENTER or - DT_CENTER); - if DropDown then - begin - LDetails := StyleServices.GetElementDetails(tbPushButtonPressed); - SaveIndex := SaveDC(Canvas.Handle); - try - IntersectClipRect(Canvas.Handle, Control.Width - 15, 0, Control.Width, - Control.Height); - DrawRect := Rect(Control.Width - 30, 0, Control.Width, - Control.Height); - StyleServices.DrawElement(Canvas.Handle, LDetails, DrawRect); - finally - RestoreDC(Canvas.Handle, SaveIndex); - end; - end; - - with Canvas do - begin - Pen.Color := StyleServices.GetSystemColor(clBtnShadow); - MoveTo(Control.Width - 15, 3); - LineTo(Control.Width - 15, Control.Height - 3); - if Control.Enabled then - Pen.Color := StyleServices.GetSystemColor(clBtnHighLight) - else - Pen.Color := Font.Color; - MoveTo(Control.Width - 14, 3); - LineTo(Control.Width - 14, Control.Height - 3); - Pen.Color := Font.Color; - X := Control.Width - 8; - Y := Control.Height div 2 + 1; - for I := 3 downto 0 do - begin - MoveTo(X - I, Y - I); - LineTo(X + I + 1, Y - I); - end; - end; - - end - else - begin - // finally the text is aligned and drawn depending of the value of the ImageAlignment property - case TCustomButton(Control).ImageAlignment of - TImageAlignment.iaLeft, - TImageAlignment.iaRight, - TImageAlignment.iaCenter: if (Control is TCustomButton) and TCustomButtonClass(Control).WordWrap then - DrawControlText(Canvas, LDetails, BCaption, DrawRect, DT_VCENTER or DT_CENTER or DT_WORDBREAK or Control.DrawTextBiDiModeFlags(0)) - else - DrawControlText(Canvas, LDetails, BCaption, DrawRect, DT_VCENTER or DT_CENTER or Control.DrawTextBiDiModeFlags(0)); - - TImageAlignment.iaBottom: if (Control is TCustomButton) and TCustomButtonClass(Control).WordWrap then - DrawControlText(Canvas, LDetails, BCaption, DrawRect, DT_TOP or DT_CENTER or DT_WORDBREAK or Control.DrawTextBiDiModeFlags(0)) - else - DrawControlText(Canvas, LDetails, BCaption, DrawRect, DT_TOP or DT_CENTER or Control.DrawTextBiDiModeFlags(0)); - - TImageAlignment.iaTop: if (Control is TCustomButton) and TCustomButtonClass(Control).WordWrap then - DrawControlText(Canvas, LDetails, BCaption, DrawRect, DT_BOTTOM or DT_CENTER or DT_WORDBREAK or Control.DrawTextBiDiModeFlags(0)) - else - DrawControlText(Canvas, LDetails, BCaption, DrawRect, DT_BOTTOM or DT_CENTER or Control.DrawTextBiDiModeFlags(0)); - end; - end; - end; -end; - -{ TButtonStyleHookHelper } - -function TButtonStyleHookHelper.DropDown: Boolean; -begin - Result := Self.FDropDown; -end; - -function TButtonStyleHookHelper.Pressed: Boolean; -begin - Result := Self.FPressed; -end; -{$IFEND} - - -{$IF CompilerVersion <= 27.0} -{ TListViewStyleHookHelper } -function TListViewStyleHookHelper.HeaderHandle: HWnd; -begin - Result := Self.FHeaderHandle; -end; -{$IFEND} - -{$IF CompilerVersion <= 24.0} -{ TComboBoxExStyleHookHelper } -function TComboBoxExStyleHookHelper.DroppedDown: Boolean; -begin - Exit(Self.FDroppedDown); -end; -{$IFEND} - -{$IF CompilerVersion <= 27.0} - -{ TListViewStyleHookFix } - -procedure TListViewStyleHookFix.DrawHeaderSection(Canvas: TCanvas; R: TRect; - Index: Integer; const Text: string; IsPressed, IsBackground: Boolean); -var - Item: THDItem; - ImageList: HIMAGELIST; - DrawState: TThemedHeader; - IconWidth, IconHeight: Integer; - Details: TThemedElementDetails; -begin - FillChar(Item, SizeOf(Item), 0); - Item.Mask := HDI_FORMAT; - Header_GetItem(HeaderHandle, Index, Item); - if IsBackground then - DrawState := thHeaderItemNormal - else if IsPressed then - DrawState := thHeaderItemPressed - else - DrawState := thHeaderItemNormal; - - Details := StyleServices.GetElementDetails(DrawState); - StyleServices.DrawElement(Canvas.Handle, Details, R); - - ImageList := SendMessage(HeaderHandle, HDM_GETIMAGELIST, 0, 0); - Item.Mask := HDI_FORMAT or HDI_IMAGE; - InflateRect(R, -2, -2); - IconWidth := 0; - if (ImageList <> 0) and Header_GetItem(HeaderHandle, Index, Item) then - begin - if Item.fmt and HDF_IMAGE = HDF_IMAGE then - ImageList_Draw(ImageList, Item.iImage, Canvas.Handle, R.Left, R.Top, - ILD_TRANSPARENT); - ImageList_GetIconSize(ImageList, IconWidth, IconHeight); - Inc(R.Left, IconWidth + 5); - end; - - if IconWidth = 0 then Inc(R.Left, 2); - DrawControlText(Canvas, Details, Text, R, DT_VCENTER or DT_LEFT or - DT_SINGLELINE or DT_END_ELLIPSIS); -end; -{$IFEND} - -{$IF CompilerVersion <= 24.0} -{ TColorBox } - -procedure TColorBox.CNDrawItem(var Message: TWMDrawItem); -const - ColorStates: array [Boolean] of TStyleColor = (scComboBoxDisabled, - scComboBox); - FontStates: array [Boolean] of TStyleFont = (sfComboBoxItemDisabled, - sfComboBoxItemNormal); -var - LState: TOwnerDrawState; -begin - LState := TOwnerDrawState(LoWord(Message.DrawItemStruct^.itemState)); - if Message.DrawItemStruct^.itemState and ODS_COMBOBOXEDIT <> 0 then - Include(LState, odComboBoxEdit); - if Message.DrawItemStruct^.itemState and ODS_DEFAULT <> 0 then - Include(LState, odDefault); - Canvas.Handle := Message.DrawItemStruct^.HDC; - Canvas.Font := Font; - if TStyleManager.IsCustomStyleActive then - begin -{$IF CompilerVersion<=23} //XE2 - Canvas.Brush.Color := StyleServices.GetStyleColor(ColorStates[Enabled]); - Canvas.Font.Color := StyleServices.GetStyleFontColor(FontStates[Enabled]); -{$ELSE} - if seClient in StyleElements then - Canvas.Brush.Color := StyleServices.GetStyleColor(ColorStates[Enabled]) - else - Canvas.Brush := Brush; - if seFont in StyleElements then - Canvas.Font.Color := StyleServices.GetStyleFontColor(FontStates[Enabled]); -{$IFEND} - end - else - Canvas.Brush := Brush; - if (Integer(Message.DrawItemStruct^.itemID) >= 0) and - (odSelected in LState){$IF CompilerVersion>23} and (seClient in StyleElements) {$IFEND} then - begin - if TStyleManager.IsCustomStyleActive then - begin - Canvas.Brush.Color := StyleServices.GetSystemColor(clHighlight); - Canvas.Font.Color := StyleServices.GetSystemColor(clHighlightText); - end - else - begin - Canvas.Brush.Color := clHighlight; - Canvas.Font.Color := clHighlightText - end; - end; - - if Integer(Message.DrawItemStruct^.itemID) >= 0 then - DrawItem(Message.DrawItemStruct^.itemID, - Message.DrawItemStruct^.rcItem, LState) - else - Canvas.FillRect(Message.DrawItemStruct^.rcItem); - - if (odFocused in LState) and (TStyleManager.ActiveStyle.IsSystemStyle) then - DrawFocusRect(Message.DrawItemStruct^.HDC, Message.DrawItemStruct^.rcItem); - Canvas.Handle := 0; -end; - -{ TComboBoxExStyleHookFix } - -procedure TComboBoxExStyleHookFix.ComboBoxWndProc(var Msg: TMessage); -begin - case Msg.Msg of - WM_DRAWITEM: - begin - DrawListBoxItem(TWMDrawItem(Msg).DrawItemStruct.HDC, - TWMDrawItem(Msg).DrawItemStruct.rcItem, - TWMDrawItem(Msg).DrawItemStruct.itemID, - TWMDrawItem(Msg).DrawItemStruct.itemState and ODS_SELECTED <> 0); - end - else - inherited; - end; -end; - -procedure TComboBoxExStyleHookFix.DrawComboBox(DC: HDC); -var - DX, DY: Integer; - LCanvas: TCanvas; - LDetails: TThemedElementDetails; - LRect: TRect; - LThemedComboBox: TThemedComboBox; - LCaption: string; - LBitmap: TBitmap; - LDrawState: TThemedComboBox; -begin - if not StyleServices.Available or (Control.Width = 0) or (Control.Height = 0) - then - Exit; - - LCanvas := TCanvas.Create; - try - LCanvas.Handle := DC; - LBitmap := TBitmap.Create; - try - LBitmap.Width := Control.Width; - LBitmap.Height := Control.Height; - if not Control.Enabled then - LDrawState := tcBorderDisabled - else if Control.Focused then - LDrawState := tcBorderFocused - else if MouseInControl then - LDrawState := tcBorderHot - else - LDrawState := tcBorderNormal; - - LRect := Rect(0, 0, Control.Width, Control.Height); - LDetails := StyleServices.GetElementDetails(LDrawState); - StyleServices.DrawElement(LBitmap.Canvas.Handle, LDetails, LRect); - -{$IF CompilerVersion > 23.0} - if not(seClient in Control.StyleElements) then - begin - LRect := Control.ClientRect; - InflateRect(LRect, -3, -3); - LRect.Right := ButtonRect.Left - 2; - LBitmap.Canvas.Brush.Color := TWinControlClass(Control).Color; - LBitmap.Canvas.FillRect(LRect); - end; -{$IFEND} - if not Control.Enabled then - LThemedComboBox := tcDropDownButtonDisabled - else if DroppedDown then - LThemedComboBox := tcDropDownButtonPressed - else if MouseOnButton then - LThemedComboBox := tcDropDownButtonHot - else - LThemedComboBox := tcDropDownButtonNormal; - - if TCustomComboBoxEx(Control).Style <> csExSimple then - begin - LDetails := StyleServices.GetElementDetails(LThemedComboBox); - StyleServices.DrawElement(LBitmap.Canvas.Handle, LDetails, ButtonRect); - end; - - LRect := Control.ClientRect; - InflateRect(LRect, -3, -3); - LRect.Right := ButtonRect.Left - 2; - LBitmap.Canvas.Font.Assign(TComboBoxEx(Control).Font); -{$IF CompilerVersion > 23.0} - if seFont in Control.StyleElements then -{$IFEND} - if Control.Enabled then - LBitmap.Canvas.Font.Color := StyleServices.GetStyleFontColor - (sfComboBoxItemNormal) - else - LBitmap.Canvas.Font.Color := StyleServices.GetStyleFontColor - (sfComboBoxItemDisabled); - - if TComboBoxEx(Control).Style = csExDropDownList then - begin - if TComboBoxEx(Control).Focused then - begin - if TComboBoxEx(Control).ItemIndex <> -1 then - begin - LBitmap.Canvas.Brush.Color := StyleServices.GetSystemColor - (clHighlight); - LBitmap.Canvas.Brush.Style := bsSolid; - LBitmap.Canvas.FillRect(LRect); - LBitmap.Canvas.Font.Color := StyleServices.GetSystemColor - (clHighlightText); - end; - LBitmap.Canvas.DrawFocusRect(LRect); - end - else - begin - LBitmap.Canvas.Brush.Color := Self.Brush.Color; - LBitmap.Canvas.Brush.Style := bsSolid; - LBitmap.Canvas.FillRect(LRect); - end; - end; - - if TComboBoxEx(Control).Style <> csExSimple then - begin - { image } - if (TComboBoxEx(Control).Images <> nil) and - (TComboBoxEx(Control).ItemIndex <> -1) then - begin - DX := 5; - DY := LRect.Top + LRect.Height div 2 - TComboBoxEx(Control) - .Images.Height div 2; - if DY < LRect.Top then - DY := LRect.Top; - if (TComboBoxEx(Control).ItemsEx[TComboBoxEx(Control).ItemIndex] - .ImageIndex >= 0) and - (TComboBoxEx(Control).ItemsEx[TComboBoxEx(Control).ItemIndex] - .ImageIndex < TComboBoxEx(Control).Images.Count) then - TComboBoxEx(Control).Images.Draw(LBitmap.Canvas, DX, DY, - TComboBoxEx(Control).ItemsEx[TComboBoxEx(Control).ItemIndex] - .ImageIndex, Control.Enabled); - - LRect.Left := DX + TComboBoxEx(Control).Images.Width + 5; - end - else - Inc(LRect.Left, 5); - { text } - if (TComboBoxEx(Control).ItemIndex <> -1) then - begin - LBitmap.Canvas.Brush.Style := bsClear; - LCaption := TComboBoxEx(Control).ItemsEx - [TComboBoxEx(Control).ItemIndex].Caption; - if LCaption <> '' then - DrawText(LBitmap.Canvas.Handle, PWideChar(LCaption), - Length(LCaption), LRect, DT_LEFT OR DT_VCENTER or DT_SINGLELINE); - end; - end; - - LCanvas.Draw(0, 0, LBitmap); - finally - LBitmap.Free; - end; - finally - LCanvas.Handle := 0; - LCanvas.Free; - end; - Handled := True; -end; - -procedure TComboBoxExStyleHookFix.DrawListBoxItem(ADC: HDC; ARect: TRect; - AIndex: Integer; ASelected: Boolean); -var - LCanvas: TCanvas; - Offset: Integer; - DX, DY: Integer; - Buffer: TBitmap; - LCaption: String; - LRect: TRect; -begin - if (AIndex < 0) or (AIndex >= TComboBoxEx(Control).ItemsEx.Count) then - Exit; - LCanvas := TCanvas.Create; - LCanvas.Handle := ADC; - Buffer := TBitmap.Create; - Buffer.Width := ARect.Width; - Buffer.Height := ARect.Height; - try - Buffer.Canvas.Font.Assign(TComboBoxEx(Control).Font); - begin - { background } - Buffer.Canvas.Brush.Style := bsSolid; - if ASelected then - begin - Buffer.Canvas.Brush.Color := StyleServices.GetSystemColor(clHighlight); - Buffer.Canvas.Font.Color := StyleServices.GetSystemColor - (clHighlightText); - end - else - begin -{$IF CompilerVersion > 23.0} - if seClient in Control.StyleElements then - Buffer.Canvas.Brush.Color := StyleServices.GetStyleColor(scComboBox) - else - Buffer.Canvas.Brush.Color := TWinControlClass(Control).Color; -{$ELSE} - Buffer.Canvas.Brush.Color := StyleServices.GetStyleColor(scComboBox); -{$IFEND} -{$IF CompilerVersion > 23.0} - if seFont in Control.StyleElements then - Buffer.Canvas.Font.Color := StyleServices.GetStyleFontColor - (sfComboBoxItemNormal) - else - Buffer.Canvas.Font.Color := TWinControlClass(Control).Font.Color; -{$ELSE} - Buffer.Canvas.Font.Color := StyleServices.GetStyleFontColor - (sfComboBoxItemNormal); -{$IFEND} - end; - Buffer.Canvas.FillRect(Rect(0, 0, Buffer.Width, Buffer.Height)); - Offset := TComboExItem(TComboBoxEx(Control).ItemsEx[AIndex]).Indent; - if Offset > 0 then - Offset := (Offset * 10) + 5 - else - Offset := 5; - { image } - if (TComboBoxEx(Control).Images <> nil) then - begin - DX := Offset; - DY := Buffer.Height div 2 - TComboBoxEx(Control).Images.Height div 2; - if DY < 0 then - DY := 0; - if (TComboBoxEx(Control).ItemsEx[AIndex].ImageIndex >= 0) and - (TComboBoxEx(Control).ItemsEx[AIndex].ImageIndex < - TComboBoxEx(Control).Images.Count) then - TComboBoxEx(Control).Images.Draw(Buffer.Canvas, DX, DY, - TComboBoxEx(Control).ItemsEx[AIndex].ImageIndex, True); - Offset := Offset + TComboBoxEx(Control).Images.Width + 5; - end; - { text } - LRect := Rect(Offset, 0, Buffer.Width, Buffer.Height); - Buffer.Canvas.Brush.Style := bsClear; - LCaption := TComboBoxEx(Control).ItemsEx[AIndex].Caption; - if LCaption <> '' then - DrawText(Buffer.Canvas.Handle, PWideChar(LCaption), Length(LCaption), - LRect, DT_LEFT OR DT_VCENTER or DT_SINGLELINE); - end; - LCanvas.Draw(ARect.Left, ARect.Top, Buffer); - finally - Buffer.Free; - LCanvas.Handle := 0; - LCanvas.Free; - end; -end; -{$IFEND} - -{$IF CompilerVersion <= 26.0} -constructor TComboBoxStyleHookFix.Create(AControl: TWinControl); -begin - inherited; - FTempItemIndex := -1; -end; - -procedure TComboBoxStyleHookFix.WMCommand(var Message: TWMCommand); -begin - if (Message.NotifyCode = CBN_SELENDCANCEL) or (Message.NotifyCode = CBN_SELENDOK) or - (Message.NotifyCode = CBN_CLOSEUP) or (Message.NotifyCode = CBN_DROPDOWN) or - (Message.NotifyCode = CBN_SELCHANGE) then - begin - if (Message.NotifyCode = CBN_DROPDOWN) or (Message.NotifyCode = CBN_SELCHANGE) then - FTempItemIndex := TComboBox(Control).ItemIndex; - end; - inherited; -end; - -procedure TComboBoxStyleHookFix.CNCommand(var Message: TWMCommand); -begin - if (Message.NotifyCode = CBN_SELENDCANCEL) or (Message.NotifyCode = CBN_SELENDOK) or - (Message.NotifyCode = CBN_CLOSEUP) or (Message.NotifyCode = CBN_DROPDOWN) or - (Message.NotifyCode = CBN_SELCHANGE) then - begin - if (Message.NotifyCode = CBN_DROPDOWN) or (Message.NotifyCode = CBN_SELCHANGE) then - FTempItemIndex := TComboBox(Control).ItemIndex; - end; - inherited; -end; - -procedure TComboBoxStyleHookFix.DrawItem(Canvas: TCanvas; Index: Integer; - const R: TRect; Selected: Boolean); -begin - if _DroppedDown then - inherited DrawItem(Canvas, FTempItemIndex, R, Selected) - else - inherited; -end; - -function TComboBoxStyleHookHelper._getDroppedDown: Boolean; -begin - Result := Self.DroppedDown; -end; -{$IFEND} - -end. +// ************************************************************************************************** +// +// Unit Vcl.Styles.Fixes +// unit for the VCL Styles Utils +// https://github.com/RRUZ/vcl-styles-utils/ +// +// 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. +// +// The Original Code is Vcl.Styles.Fixes +// +// The Initial Developer of the Original Code is Rodrigo Ruz V. +// Portions created by Rodrigo Ruz V. are Copyright (C) 2012-2023 Rodrigo Ruz V. +// All Rights Reserved. +// +// Contributors +// +// Leonardo Cechet +// +// ************************************************************************************************** + +unit Vcl.Styles.Fixes; + +interface + +uses + Winapi.Windows, + Winapi.Messages, + Vcl.Controls, + Vcl.ComCtrls, + Vcl.StdCtrls, + Vcl.ExtCtrls, + Vcl.Graphics; + +{$IF CompilerVersion >= 23.0} +type + /// The TButtonStyleHookFix vcl style hook fix these QC #103708, #107764 for Delphi XE2 + /// and the https://quality.embarcadero.com/browse/RSP-11619 issue present in X2-XE8 + /// + /// + /// Use this hook in this way + /// + /// TStyleManager.Engine.RegisterStyleHook(TButton, TButtonStyleHookFix); + /// + /// + TButtonStyleHookFix = class(TButtonStyleHook) + protected + procedure Paint(Canvas: TCanvas); override; + end; +{$IFEND} + +{$IF CompilerVersion <= 27.0} +type + /// The TListViewStyleHookFix vcl style hook fix these QC #108678, #108875 for Delphi XE2-XE6 + /// + /// + /// Use this hook in this way + /// + /// TStyleManager.Engine.RegisterStyleHook(TListView, TListViewStyleHookFix); + /// + /// + TListViewStyleHookFix = class(TListViewStyleHook) + procedure DrawHeaderSection(Canvas: TCanvas; R: TRect; Index: Integer; + const Text: string; IsPressed, IsBackground: Boolean); override; + end; +{$IFEND} + +{$IF CompilerVersion <= 24.0} +type + /// This interposer class fix the QC #114032 for Delphi XE2 and Delphi XE3 + /// + /// + /// To use this class add the Vcl.Styles.Fixes unit to your uses list after of the Vcl.ExtCtrls unit + /// + TColorBox = class(Vcl.ExtCtrls.TColorBox) + private + procedure CNDrawItem(var Message: TWMDrawItem); message CN_DRAWITEM; + end; + + /// The TComboBoxExStyleHookFix vcl style hook fix the QC #108678 for Delphi XE2 and Delphi XE3 + /// + /// + /// Use this hook in this way + /// + /// TStyleManager.Engine.RegisterStyleHook(TComboBoxEx, TComboBoxExStyleHookFix); + /// + /// + TComboBoxExStyleHookFix = class(TComboBoxExStyleHook) + strict protected + procedure DrawListBoxItem(ADC: HDC; ARect: TRect; AIndex: Integer; + ASelected: Boolean); + procedure ComboBoxWndProc(var Msg: TMessage); override; + procedure DrawComboBox(DC: HDC); override; + end; +{$IFEND} + +{$IF CompilerVersion <= 26.0} + /// The TComboBoxStyleHookFix vcl style hook fix the QC #114632 for Delphi XE5 and earlier + /// + /// + /// Use this hook in this way + /// + /// TStyleManager.Engine.RegisterStyleHook(TComboBox, TComboBoxStyleHookFix); + /// + /// + TComboBoxStyleHookFix = class(TComboBoxStyleHook) + strict private + FTempItemIndex: Integer; + procedure WMCommand(var Message: TWMCommand); message WM_COMMAND; + procedure CNCommand(var Message: TWMCommand); message CN_COMMAND; + strict protected + procedure DrawItem(Canvas: TCanvas; Index: Integer; + const R: TRect; Selected: Boolean); override; + public + constructor Create(AControl: TWinControl); override; + end; +{$IFEND} + +implementation + +uses + Winapi.CommCtrl, + Vcl.Themes, + Vcl.Forms, + System.SysUtils, + System.Classes, + System.UITypes, + System.Types; + +type + TCustomButtonClass = class(TCustomButton); + TWinControlClass = class(TWinControl); + +{$IF CompilerVersion >= 23.0} + + // we need this helper to access some strict private fields + TButtonStyleHookHelper = class Helper for TButtonStyleHook + protected + function Pressed: Boolean; + function DropDown: Boolean; + end; +{$IFEND} + +{$IF CompilerVersion <= 27.0} + TListViewStyleHookHelper = class helper for TListViewStyleHook + function HeaderHandle: HWnd; + end; +{$IFEND} + +{$IF CompilerVersion <= 24.0} + TComboBoxExStyleHookHelper = class helper for TComboBoxExStyleHook + function DroppedDown: Boolean; + end; +{$IFEND} + +{$IF CompilerVersion <= 26.0} + TComboBoxStyleHookHelper = class helper for TComboBoxStyleHook + strict private + function _getDroppedDown: Boolean; + private + property _DroppedDown: Boolean read _getDroppedDown; + end; +{$IFEND} + +{$IF CompilerVersion >= 23.0} + +procedure TButtonStyleHookFix.Paint(Canvas: TCanvas); +const + PBS_NORMAL = 0; + PBS_HOT = 1; + PBS_PRESSED = 2; + PBS_DISABLED = 3; + PBS_DEFAULTED = 4; + PBS_STYLUSHOT = 5; +var + LDetails: TThemedElementDetails; + DrawRect: TRect; + pbuttonImagelist: BUTTON_IMAGELIST; + IW, IH, IY: Integer; + LTextFormatFlags: TTextFormatFlags; + ThemeTextColor: TColor; + Buffer: string; + BufferLength: Integer; + SaveIndex: Integer; + X, Y, I: Integer; + IsDefault: Boolean; + BCaption: String; + LImageIndex: Integer; +begin + LImageIndex:=PBS_NORMAL; + IsDefault := (Control is TCustomButton) and (TCustomButton(Control).Default); + + if StyleServices.Available then + begin + BCaption := Text; + + if not Control.Enabled then + begin + LDetails := StyleServices.GetElementDetails(tbPushButtonDisabled); + LImageIndex := PBS_DISABLED; + end + else + if Pressed then + begin + LDetails := StyleServices.GetElementDetails(tbPushButtonPressed); + LImageIndex := PBS_PRESSED; + end + else + if MouseInControl then + begin + LDetails := StyleServices.GetElementDetails(tbPushButtonHot); + LImageIndex := PBS_HOT; + end + else + if Control.Focused or (IsDefault and (Screen.ActiveControl<>nil) and not (Screen.ActiveControl is TCustomButton) ) then + begin + LDetails := StyleServices.GetElementDetails(tbPushButtonDefaulted); + LImageIndex := PBS_DEFAULTED; + end + else if Control.Enabled then + LDetails := StyleServices.GetElementDetails(tbPushButtonNormal); + + DrawRect := Control.ClientRect; + StyleServices.DrawElement(Canvas.Handle, LDetails, DrawRect); + + if Button_GetImageList(Handle, pbuttonImagelist) and + (pbuttonImagelist.himl <> 0) and + ImageList_GetIconSize(pbuttonImagelist.himl, IW, IH) then + begin + + if (GetWindowLong(Handle, GWL_STYLE) and BS_COMMANDLINK) = BS_COMMANDLINK + then + IY := DrawRect.Top + 15 + else + IY := DrawRect.Top + (DrawRect.Height - IH) div 2; + + // here the image is drawn properly according to the ImageAlignment value + case TCustomButton(Control).ImageAlignment of + TImageAlignment.iaLeft: + begin + ImageList_Draw(pbuttonImagelist.himl, LImageIndex, Canvas.Handle, + DrawRect.Left + 3 + TCustomButton(Control).ImageMargins.Left, IY, ILD_NORMAL); + Inc(DrawRect.Left, IW + 3 + TCustomButton(Control).ImageMargins.Left); + end; + + TImageAlignment.iaRight: + begin + ImageList_Draw(pbuttonImagelist.himl, LImageIndex, Canvas.Handle, + DrawRect.Right - IW - 3 - TCustomButton(Control).ImageMargins.Right, IY, ILD_NORMAL); + Dec(DrawRect.Right, IW - 3 + TCustomButton(Control).ImageMargins.Right); + end; + + TImageAlignment.iaCenter: + begin + ImageList_Draw(pbuttonImagelist.himl, LImageIndex, Canvas.Handle, + (DrawRect.Right - IW) div 2, IY + TCustomButton(Control).ImageMargins.Top - TCustomButton(Control).ImageMargins.Bottom, ILD_NORMAL); + end; + + TImageAlignment.iaTop: + begin + ImageList_Draw(pbuttonImagelist.himl, LImageIndex, Canvas.Handle, + (DrawRect.Right - IW) div 2, 3 + TCustomButton(Control).ImageMargins.Top - TCustomButton(Control).ImageMargins.Bottom, ILD_NORMAL); + end; + + TImageAlignment.iaBottom: + begin + ImageList_Draw(pbuttonImagelist.himl, LImageIndex, Canvas.Handle, + (DrawRect.Right - IW) div 2, (DrawRect.Height - IH) - 3 + TCustomButton(Control).ImageMargins.Top - TCustomButton(Control).ImageMargins.Bottom, + ILD_NORMAL); + end; + + end; + + end; + + if (GetWindowLong(Handle, GWL_STYLE) and BS_COMMANDLINK) = BS_COMMANDLINK then + begin + if pbuttonImagelist.himl = 0 then + Inc(DrawRect.Left, 35); + + Inc(DrawRect.Top, 15); + Inc(DrawRect.Left, 5); + Canvas.Font := TCustomButtonClass(Control).Font; + Canvas.Font.Style := []; + Canvas.Font.Size := 12; + LTextFormatFlags := TTextFormatFlags(DT_LEFT); + if StyleServices.GetElementColor(LDetails, ecTextColor, ThemeTextColor) + then + Canvas.Font.Color := ThemeTextColor; + StyleServices.DrawText(Canvas.Handle, LDetails, BCaption, DrawRect, + LTextFormatFlags, Canvas.Font.Color); + SetLength(Buffer, Button_GetNoteLength(Handle) + 1); + if Length(Buffer) <> 0 then + begin + BufferLength := Length(Buffer); + if Button_GetNote(Handle, PChar(Buffer), BufferLength) then + begin + LTextFormatFlags := TTextFormatFlags(DT_LEFT or DT_WORDBREAK); + Inc(DrawRect.Top, Canvas.TextHeight('Wq') + 2); + Canvas.Font.Size := 8; + StyleServices.DrawText(Canvas.Handle, LDetails, Buffer, DrawRect, + LTextFormatFlags, Canvas.Font.Color); + end; + end; + + if pbuttonImagelist.himl = 0 then + begin + if Pressed then + LDetails := StyleServices.GetElementDetails(tbCommandLinkGlyphPressed) + else if MouseInControl then + LDetails := StyleServices.GetElementDetails(tbCommandLinkGlyphHot) + else if Control.Enabled then + LDetails := StyleServices.GetElementDetails(tbCommandLinkGlyphNormal) + else + LDetails := StyleServices.GetElementDetails + (tbCommandLinkGlyphDisabled); + DrawRect.Right := 35; + DrawRect.Left := 3; + DrawRect.Top := 10; + DrawRect.Bottom := DrawRect.Top + 32; + StyleServices.DrawElement(Canvas.Handle, LDetails, DrawRect); + end; + + end + else if (GetWindowLong(Handle, GWL_STYLE) and BS_SPLITBUTTON) = BS_SPLITBUTTON + then + begin + Dec(DrawRect.Right, 15); + DrawControlText(Canvas, LDetails, Text, DrawRect, DT_VCENTER or + DT_CENTER); + if DropDown then + begin + LDetails := StyleServices.GetElementDetails(tbPushButtonPressed); + SaveIndex := SaveDC(Canvas.Handle); + try + IntersectClipRect(Canvas.Handle, Control.Width - 15, 0, Control.Width, + Control.Height); + DrawRect := Rect(Control.Width - 30, 0, Control.Width, + Control.Height); + StyleServices.DrawElement(Canvas.Handle, LDetails, DrawRect); + finally + RestoreDC(Canvas.Handle, SaveIndex); + end; + end; + + with Canvas do + begin + Pen.Color := StyleServices.GetSystemColor(clBtnShadow); + MoveTo(Control.Width - 15, 3); + LineTo(Control.Width - 15, Control.Height - 3); + if Control.Enabled then + Pen.Color := StyleServices.GetSystemColor(clBtnHighLight) + else + Pen.Color := Font.Color; + MoveTo(Control.Width - 14, 3); + LineTo(Control.Width - 14, Control.Height - 3); + Pen.Color := Font.Color; + X := Control.Width - 8; + Y := Control.Height div 2 + 1; + for I := 3 downto 0 do + begin + MoveTo(X - I, Y - I); + LineTo(X + I + 1, Y - I); + end; + end; + + end + else + begin + // finally the text is aligned and drawn depending of the value of the ImageAlignment property + case TCustomButton(Control).ImageAlignment of + TImageAlignment.iaLeft, + TImageAlignment.iaRight, + TImageAlignment.iaCenter: if (Control is TCustomButton) and TCustomButtonClass(Control).WordWrap then + DrawControlText(Canvas, LDetails, BCaption, DrawRect, DT_VCENTER or DT_CENTER or DT_WORDBREAK or Control.DrawTextBiDiModeFlags(0)) + else + DrawControlText(Canvas, LDetails, BCaption, DrawRect, DT_VCENTER or DT_CENTER or Control.DrawTextBiDiModeFlags(0)); + + TImageAlignment.iaBottom: if (Control is TCustomButton) and TCustomButtonClass(Control).WordWrap then + DrawControlText(Canvas, LDetails, BCaption, DrawRect, DT_TOP or DT_CENTER or DT_WORDBREAK or Control.DrawTextBiDiModeFlags(0)) + else + DrawControlText(Canvas, LDetails, BCaption, DrawRect, DT_TOP or DT_CENTER or Control.DrawTextBiDiModeFlags(0)); + + TImageAlignment.iaTop: if (Control is TCustomButton) and TCustomButtonClass(Control).WordWrap then + DrawControlText(Canvas, LDetails, BCaption, DrawRect, DT_BOTTOM or DT_CENTER or DT_WORDBREAK or Control.DrawTextBiDiModeFlags(0)) + else + DrawControlText(Canvas, LDetails, BCaption, DrawRect, DT_BOTTOM or DT_CENTER or Control.DrawTextBiDiModeFlags(0)); + end; + end; + end; +end; + +{ TButtonStyleHookHelper } + +function TButtonStyleHookHelper.DropDown: Boolean; +begin + Result := Self.FDropDown; +end; + +function TButtonStyleHookHelper.Pressed: Boolean; +begin + Result := Self.FPressed; +end; +{$IFEND} + + +{$IF CompilerVersion <= 27.0} +{ TListViewStyleHookHelper } +function TListViewStyleHookHelper.HeaderHandle: HWnd; +begin + Result := Self.FHeaderHandle; +end; +{$IFEND} + +{$IF CompilerVersion <= 24.0} +{ TComboBoxExStyleHookHelper } +function TComboBoxExStyleHookHelper.DroppedDown: Boolean; +begin + Exit(Self.FDroppedDown); +end; +{$IFEND} + +{$IF CompilerVersion <= 27.0} + +{ TListViewStyleHookFix } + +procedure TListViewStyleHookFix.DrawHeaderSection(Canvas: TCanvas; R: TRect; + Index: Integer; const Text: string; IsPressed, IsBackground: Boolean); +var + Item: THDItem; + ImageList: HIMAGELIST; + DrawState: TThemedHeader; + IconWidth, IconHeight: Integer; + Details: TThemedElementDetails; +begin + FillChar(Item, SizeOf(Item), 0); + Item.Mask := HDI_FORMAT; + Header_GetItem(HeaderHandle, Index, Item); + if IsBackground then + DrawState := thHeaderItemNormal + else if IsPressed then + DrawState := thHeaderItemPressed + else + DrawState := thHeaderItemNormal; + + Details := StyleServices.GetElementDetails(DrawState); + StyleServices.DrawElement(Canvas.Handle, Details, R); + + ImageList := SendMessage(HeaderHandle, HDM_GETIMAGELIST, 0, 0); + Item.Mask := HDI_FORMAT or HDI_IMAGE; + InflateRect(R, -2, -2); + IconWidth := 0; + if (ImageList <> 0) and Header_GetItem(HeaderHandle, Index, Item) then + begin + if Item.fmt and HDF_IMAGE = HDF_IMAGE then + ImageList_Draw(ImageList, Item.iImage, Canvas.Handle, R.Left, R.Top, + ILD_TRANSPARENT); + ImageList_GetIconSize(ImageList, IconWidth, IconHeight); + Inc(R.Left, IconWidth + 5); + end; + + if IconWidth = 0 then Inc(R.Left, 2); + DrawControlText(Canvas, Details, Text, R, DT_VCENTER or DT_LEFT or + DT_SINGLELINE or DT_END_ELLIPSIS); +end; +{$IFEND} + +{$IF CompilerVersion <= 24.0} +{ TColorBox } + +procedure TColorBox.CNDrawItem(var Message: TWMDrawItem); +const + ColorStates: array [Boolean] of TStyleColor = (scComboBoxDisabled, + scComboBox); + FontStates: array [Boolean] of TStyleFont = (sfComboBoxItemDisabled, + sfComboBoxItemNormal); +var + LState: TOwnerDrawState; +begin + LState := TOwnerDrawState(LoWord(Message.DrawItemStruct^.itemState)); + if Message.DrawItemStruct^.itemState and ODS_COMBOBOXEDIT <> 0 then + Include(LState, odComboBoxEdit); + if Message.DrawItemStruct^.itemState and ODS_DEFAULT <> 0 then + Include(LState, odDefault); + Canvas.Handle := Message.DrawItemStruct^.HDC; + Canvas.Font := Font; + if TStyleManager.IsCustomStyleActive then + begin +{$IF CompilerVersion<=23} //XE2 + Canvas.Brush.Color := StyleServices.GetStyleColor(ColorStates[Enabled]); + Canvas.Font.Color := StyleServices.GetStyleFontColor(FontStates[Enabled]); +{$ELSE} + if seClient in StyleElements then + Canvas.Brush.Color := StyleServices.GetStyleColor(ColorStates[Enabled]) + else + Canvas.Brush := Brush; + if seFont in StyleElements then + Canvas.Font.Color := StyleServices.GetStyleFontColor(FontStates[Enabled]); +{$IFEND} + end + else + Canvas.Brush := Brush; + if (Integer(Message.DrawItemStruct^.itemID) >= 0) and + (odSelected in LState){$IF CompilerVersion>23} and (seClient in StyleElements) {$IFEND} then + begin + if TStyleManager.IsCustomStyleActive then + begin + Canvas.Brush.Color := StyleServices.GetSystemColor(clHighlight); + Canvas.Font.Color := StyleServices.GetSystemColor(clHighlightText); + end + else + begin + Canvas.Brush.Color := clHighlight; + Canvas.Font.Color := clHighlightText + end; + end; + + if Integer(Message.DrawItemStruct^.itemID) >= 0 then + DrawItem(Message.DrawItemStruct^.itemID, + Message.DrawItemStruct^.rcItem, LState) + else + Canvas.FillRect(Message.DrawItemStruct^.rcItem); + + if (odFocused in LState) and (TStyleManager.ActiveStyle.IsSystemStyle) then + DrawFocusRect(Message.DrawItemStruct^.HDC, Message.DrawItemStruct^.rcItem); + Canvas.Handle := 0; +end; + +{ TComboBoxExStyleHookFix } + +procedure TComboBoxExStyleHookFix.ComboBoxWndProc(var Msg: TMessage); +begin + case Msg.Msg of + WM_DRAWITEM: + begin + DrawListBoxItem(TWMDrawItem(Msg).DrawItemStruct.HDC, + TWMDrawItem(Msg).DrawItemStruct.rcItem, + TWMDrawItem(Msg).DrawItemStruct.itemID, + TWMDrawItem(Msg).DrawItemStruct.itemState and ODS_SELECTED <> 0); + end + else + inherited; + end; +end; + +procedure TComboBoxExStyleHookFix.DrawComboBox(DC: HDC); +var + DX, DY: Integer; + LCanvas: TCanvas; + LDetails: TThemedElementDetails; + LRect: TRect; + LThemedComboBox: TThemedComboBox; + LCaption: string; + LBitmap: TBitmap; + LDrawState: TThemedComboBox; +begin + if not StyleServices.Available or (Control.Width = 0) or (Control.Height = 0) + then + Exit; + + LCanvas := TCanvas.Create; + try + LCanvas.Handle := DC; + LBitmap := TBitmap.Create; + try + LBitmap.Width := Control.Width; + LBitmap.Height := Control.Height; + if not Control.Enabled then + LDrawState := tcBorderDisabled + else if Control.Focused then + LDrawState := tcBorderFocused + else if MouseInControl then + LDrawState := tcBorderHot + else + LDrawState := tcBorderNormal; + + LRect := Rect(0, 0, Control.Width, Control.Height); + LDetails := StyleServices.GetElementDetails(LDrawState); + StyleServices.DrawElement(LBitmap.Canvas.Handle, LDetails, LRect); + +{$IF CompilerVersion > 23.0} + if not(seClient in Control.StyleElements) then + begin + LRect := Control.ClientRect; + InflateRect(LRect, -3, -3); + LRect.Right := ButtonRect.Left - 2; + LBitmap.Canvas.Brush.Color := TWinControlClass(Control).Color; + LBitmap.Canvas.FillRect(LRect); + end; +{$IFEND} + if not Control.Enabled then + LThemedComboBox := tcDropDownButtonDisabled + else if DroppedDown then + LThemedComboBox := tcDropDownButtonPressed + else if MouseOnButton then + LThemedComboBox := tcDropDownButtonHot + else + LThemedComboBox := tcDropDownButtonNormal; + + if TCustomComboBoxEx(Control).Style <> csExSimple then + begin + LDetails := StyleServices.GetElementDetails(LThemedComboBox); + StyleServices.DrawElement(LBitmap.Canvas.Handle, LDetails, ButtonRect); + end; + + LRect := Control.ClientRect; + InflateRect(LRect, -3, -3); + LRect.Right := ButtonRect.Left - 2; + LBitmap.Canvas.Font.Assign(TComboBoxEx(Control).Font); +{$IF CompilerVersion > 23.0} + if seFont in Control.StyleElements then +{$IFEND} + if Control.Enabled then + LBitmap.Canvas.Font.Color := StyleServices.GetStyleFontColor + (sfComboBoxItemNormal) + else + LBitmap.Canvas.Font.Color := StyleServices.GetStyleFontColor + (sfComboBoxItemDisabled); + + if TComboBoxEx(Control).Style = csExDropDownList then + begin + if TComboBoxEx(Control).Focused then + begin + if TComboBoxEx(Control).ItemIndex <> -1 then + begin + LBitmap.Canvas.Brush.Color := StyleServices.GetSystemColor + (clHighlight); + LBitmap.Canvas.Brush.Style := bsSolid; + LBitmap.Canvas.FillRect(LRect); + LBitmap.Canvas.Font.Color := StyleServices.GetSystemColor + (clHighlightText); + end; + LBitmap.Canvas.DrawFocusRect(LRect); + end + else + begin + LBitmap.Canvas.Brush.Color := Self.Brush.Color; + LBitmap.Canvas.Brush.Style := bsSolid; + LBitmap.Canvas.FillRect(LRect); + end; + end; + + if TComboBoxEx(Control).Style <> csExSimple then + begin + { image } + if (TComboBoxEx(Control).Images <> nil) and + (TComboBoxEx(Control).ItemIndex <> -1) then + begin + DX := 5; + DY := LRect.Top + LRect.Height div 2 - TComboBoxEx(Control) + .Images.Height div 2; + if DY < LRect.Top then + DY := LRect.Top; + if (TComboBoxEx(Control).ItemsEx[TComboBoxEx(Control).ItemIndex] + .ImageIndex >= 0) and + (TComboBoxEx(Control).ItemsEx[TComboBoxEx(Control).ItemIndex] + .ImageIndex < TComboBoxEx(Control).Images.Count) then + TComboBoxEx(Control).Images.Draw(LBitmap.Canvas, DX, DY, + TComboBoxEx(Control).ItemsEx[TComboBoxEx(Control).ItemIndex] + .ImageIndex, Control.Enabled); + + LRect.Left := DX + TComboBoxEx(Control).Images.Width + 5; + end + else + Inc(LRect.Left, 5); + { text } + if (TComboBoxEx(Control).ItemIndex <> -1) then + begin + LBitmap.Canvas.Brush.Style := bsClear; + LCaption := TComboBoxEx(Control).ItemsEx + [TComboBoxEx(Control).ItemIndex].Caption; + if LCaption <> '' then + DrawText(LBitmap.Canvas.Handle, PWideChar(LCaption), + Length(LCaption), LRect, DT_LEFT OR DT_VCENTER or DT_SINGLELINE); + end; + end; + + LCanvas.Draw(0, 0, LBitmap); + finally + LBitmap.Free; + end; + finally + LCanvas.Handle := 0; + LCanvas.Free; + end; + Handled := True; +end; + +procedure TComboBoxExStyleHookFix.DrawListBoxItem(ADC: HDC; ARect: TRect; + AIndex: Integer; ASelected: Boolean); +var + LCanvas: TCanvas; + Offset: Integer; + DX, DY: Integer; + Buffer: TBitmap; + LCaption: String; + LRect: TRect; +begin + if (AIndex < 0) or (AIndex >= TComboBoxEx(Control).ItemsEx.Count) then + Exit; + LCanvas := TCanvas.Create; + LCanvas.Handle := ADC; + Buffer := TBitmap.Create; + Buffer.Width := ARect.Width; + Buffer.Height := ARect.Height; + try + Buffer.Canvas.Font.Assign(TComboBoxEx(Control).Font); + begin + { background } + Buffer.Canvas.Brush.Style := bsSolid; + if ASelected then + begin + Buffer.Canvas.Brush.Color := StyleServices.GetSystemColor(clHighlight); + Buffer.Canvas.Font.Color := StyleServices.GetSystemColor + (clHighlightText); + end + else + begin +{$IF CompilerVersion > 23.0} + if seClient in Control.StyleElements then + Buffer.Canvas.Brush.Color := StyleServices.GetStyleColor(scComboBox) + else + Buffer.Canvas.Brush.Color := TWinControlClass(Control).Color; +{$ELSE} + Buffer.Canvas.Brush.Color := StyleServices.GetStyleColor(scComboBox); +{$IFEND} +{$IF CompilerVersion > 23.0} + if seFont in Control.StyleElements then + Buffer.Canvas.Font.Color := StyleServices.GetStyleFontColor + (sfComboBoxItemNormal) + else + Buffer.Canvas.Font.Color := TWinControlClass(Control).Font.Color; +{$ELSE} + Buffer.Canvas.Font.Color := StyleServices.GetStyleFontColor + (sfComboBoxItemNormal); +{$IFEND} + end; + Buffer.Canvas.FillRect(Rect(0, 0, Buffer.Width, Buffer.Height)); + Offset := TComboExItem(TComboBoxEx(Control).ItemsEx[AIndex]).Indent; + if Offset > 0 then + Offset := (Offset * 10) + 5 + else + Offset := 5; + { image } + if (TComboBoxEx(Control).Images <> nil) then + begin + DX := Offset; + DY := Buffer.Height div 2 - TComboBoxEx(Control).Images.Height div 2; + if DY < 0 then + DY := 0; + if (TComboBoxEx(Control).ItemsEx[AIndex].ImageIndex >= 0) and + (TComboBoxEx(Control).ItemsEx[AIndex].ImageIndex < + TComboBoxEx(Control).Images.Count) then + TComboBoxEx(Control).Images.Draw(Buffer.Canvas, DX, DY, + TComboBoxEx(Control).ItemsEx[AIndex].ImageIndex, True); + Offset := Offset + TComboBoxEx(Control).Images.Width + 5; + end; + { text } + LRect := Rect(Offset, 0, Buffer.Width, Buffer.Height); + Buffer.Canvas.Brush.Style := bsClear; + LCaption := TComboBoxEx(Control).ItemsEx[AIndex].Caption; + if LCaption <> '' then + DrawText(Buffer.Canvas.Handle, PWideChar(LCaption), Length(LCaption), + LRect, DT_LEFT OR DT_VCENTER or DT_SINGLELINE); + end; + LCanvas.Draw(ARect.Left, ARect.Top, Buffer); + finally + Buffer.Free; + LCanvas.Handle := 0; + LCanvas.Free; + end; +end; +{$IFEND} + +{$IF CompilerVersion <= 26.0} +constructor TComboBoxStyleHookFix.Create(AControl: TWinControl); +begin + inherited; + FTempItemIndex := -1; +end; + +procedure TComboBoxStyleHookFix.WMCommand(var Message: TWMCommand); +begin + if (Message.NotifyCode = CBN_SELENDCANCEL) or (Message.NotifyCode = CBN_SELENDOK) or + (Message.NotifyCode = CBN_CLOSEUP) or (Message.NotifyCode = CBN_DROPDOWN) or + (Message.NotifyCode = CBN_SELCHANGE) then + begin + if (Message.NotifyCode = CBN_DROPDOWN) or (Message.NotifyCode = CBN_SELCHANGE) then + FTempItemIndex := TComboBox(Control).ItemIndex; + end; + inherited; +end; + +procedure TComboBoxStyleHookFix.CNCommand(var Message: TWMCommand); +begin + if (Message.NotifyCode = CBN_SELENDCANCEL) or (Message.NotifyCode = CBN_SELENDOK) or + (Message.NotifyCode = CBN_CLOSEUP) or (Message.NotifyCode = CBN_DROPDOWN) or + (Message.NotifyCode = CBN_SELCHANGE) then + begin + if (Message.NotifyCode = CBN_DROPDOWN) or (Message.NotifyCode = CBN_SELCHANGE) then + FTempItemIndex := TComboBox(Control).ItemIndex; + end; + inherited; +end; + +procedure TComboBoxStyleHookFix.DrawItem(Canvas: TCanvas; Index: Integer; + const R: TRect; Selected: Boolean); +begin + if _DroppedDown then + inherited DrawItem(Canvas, FTempItemIndex, R, Selected) + else + inherited; +end; + +function TComboBoxStyleHookHelper._getDroppedDown: Boolean; +begin + Result := Self.DroppedDown; +end; +{$IFEND} + +end. diff --git a/source/vcl-styles-utils/Vcl.Styles.FontAwesome.pas b/source/vcl-styles-utils/Vcl.Styles.FontAwesome.pas index e5c75e562..171df859d 100644 --- a/source/vcl-styles-utils/Vcl.Styles.FontAwesome.pas +++ b/source/vcl-styles-utils/Vcl.Styles.FontAwesome.pas @@ -1,1032 +1,1032 @@ -//************************************************************************************************** -// -// Unit Vcl.Styles.FontAwesome -// unit for the VCL Styles Utils -// https://github.com/RRUZ/vcl-styles-utils/ -// -// 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. -// -// The Original Code is Vcl.Styles.FontAwesome.pas. -// -// The Initial Developer of the Original Code is Rodrigo Ruz V. -// Portions created by Rodrigo Ruz V. are Copyright (C) 2012-2019 Rodrigo Ruz V. -// All Rights Reserved. -// -//************************************************************************************************** -unit Vcl.Styles.FontAwesome; - -interface - -{$IF CompilerVersion >= 30.0} - - {$DEFINE WinXCtrls} -{$ENDIF} - -uses - Winapi.GDIPOBJ, - Winapi.GDIPAPI, - Winapi.Windows, - System.Classes, - {$IFDEF WinXCtrls} - Vcl.WinXCtrls, - {$ENDIF} - Vcl.Controls, - Vcl.StdCtrls, - Vcl.Graphics; - - -{$R AwesomeFont.RES} - -//http://fortawesome.github.io/Font-Awesome/cheatsheet/ -//http://prettyprinter.de/index.php - -//version 4.7.0 -const - fa_glass = $F000; - fa_music = $F001; - fa_search = $F002; - fa_envelope_o = $F003; - fa_heart = $F004; - fa_star = $F005; - fa_star_o = $F006; - fa_user = $F007; - fa_film = $F008; - fa_th_large = $F009; - fa_th = $F00A; - fa_th_list = $F00B; - fa_check = $F00C; - fa_remove = $F00D; - fa_search_plus = $F00E; - fa_search_minus = $F010; - fa_power_off = $F011; - fa_signal = $F012; - fa_gear = $F013; - fa_trash_o = $F014; - fa_home = $F015; - fa_file_o = $F016; - fa_clock_o = $F017; - fa_road = $F018; - fa_download = $F019; - fa_arrow_circle_o_down = $F01A; - fa_arrow_circle_o_up = $F01B; - fa_inbox = $F01C; - fa_play_circle_o = $F01D; - fa_rotate_right = $F01E; - fa_refresh = $F021; - fa_list_alt = $F022; - fa_lock = $F023; - fa_flag = $F024; - fa_headphones = $F025; - fa_volume_off = $F026; - fa_volume_down = $F027; - fa_volume_up = $F028; - fa_qrcode = $F029; - fa_barcode = $F02A; - fa_tag = $F02B; - fa_tags = $F02C; - fa_book = $F02D; - fa_bookmark = $F02E; - fa_print = $F02F; - fa_camera = $F030; - fa_font = $F031; - fa_bold = $F032; - fa_italic = $F033; - fa_text_height = $F034; - fa_text_width = $F035; - fa_align_left = $F036; - fa_align_center = $F037; - fa_align_right = $F038; - fa_align_justify = $F039; - fa_list = $F03A; - fa_dedent = $F03B; - fa_indent = $F03C; - fa_video_camera = $F03D; - fa_photo = $F03E; - fa_pencil = $F040; - fa_map_marker = $F041; - fa_adjust = $F042; - fa_tint = $F043; - fa_edit = $F044; - fa_share_square_o = $F045; - fa_check_square_o = $F046; - fa_arrows = $F047; - fa_step_backward = $F048; - fa_fast_backward = $F049; - fa_backward = $F04A; - fa_play = $F04B; - fa_pause = $F04C; - fa_stop = $F04D; - fa_forward = $F04E; - fa_fast_forward = $F050; - fa_step_forward = $F051; - fa_eject = $F052; - fa_chevron_left = $F053; - fa_chevron_right = $F054; - fa_plus_circle = $F055; - fa_minus_circle = $F056; - fa_times_circle = $F057; - fa_check_circle = $F058; - fa_question_circle = $F059; - fa_info_circle = $F05A; - fa_crosshairs = $F05B; - fa_times_circle_o = $F05C; - fa_check_circle_o = $F05D; - fa_ban = $F05E; - fa_arrow_left = $F060; - fa_arrow_right = $F061; - fa_arrow_up = $F062; - fa_arrow_down = $F063; - fa_mail_forward = $F064; - fa_expand = $F065; - fa_compress = $F066; - fa_plus = $F067; - fa_minus = $F068; - fa_asterisk = $F069; - fa_exclamation_circle = $F06A; - fa_gift = $F06B; - fa_leaf = $F06C; - fa_fire = $F06D; - fa_eye = $F06E; - fa_eye_slash = $F070; - fa_warning = $F071; - fa_plane = $F072; - fa_calendar = $F073; - fa_random = $F074; - fa_comment = $F075; - fa_magnet = $F076; - fa_chevron_up = $F077; - fa_chevron_down = $F078; - fa_retweet = $F079; - fa_shopping_cart = $F07A; - fa_folder = $F07B; - fa_folder_open = $F07C; - fa_arrows_v = $F07D; - fa_arrows_h = $F07E; - fa_bar_chart_o = $F080; - fa_twitter_square = $F081; - fa_facebook_square = $F082; - fa_camera_retro = $F083; - fa_key = $F084; - fa_gears = $F085; - fa_comments = $F086; - fa_commenting = $F27a; - fa_commenting_o = $f27b; - fa_thumbs_o_up = $F087; - fa_thumbs_o_down = $F088; - fa_star_half = $F089; - fa_heart_o = $F08A; - fa_sign_out = $F08B; - fa_linkedin_square = $F08C; - fa_thumb_tack = $F08D; - fa_external_link = $F08E; - fa_sign_in = $F090; - fa_trophy = $F091; - fa_github_square = $F092; - fa_upload = $F093; - fa_lemon_o = $F094; - fa_phone = $F095; - fa_square_o = $F096; - fa_bookmark_o = $F097; - fa_phone_square = $F098; - fa_twitter = $F099; - fa_facebook_f = $F09A; - fa_github = $F09B; - fa_unlock = $F09C; - fa_credit_card = $F09D; - fa_rss = $F09E; - fa_hdd_o = $F0A0; - fa_bullhorn = $F0A1; - fa_bell = $F0F3; - fa_certificate = $F0A3; - fa_hand_o_right = $F0A4; - fa_hand_o_left = $F0A5; - fa_hand_o_up = $F0A6; - fa_hand_o_down = $F0A7; - fa_arrow_circle_left = $F0A8; - fa_arrow_circle_right = $F0A9; - fa_arrow_circle_up = $F0AA; - fa_arrow_circle_down = $F0AB; - fa_globe = $F0AC; - fa_wrench = $F0AD; - fa_tasks = $F0AE; - fa_filter = $F0B0; - fa_clone = $F24D; - fa_briefcase = $F0B1; - fa_arrows_alt = $F0B2; - fa_group = $F0C0; - fa_chain = $F0C1; - fa_cloud = $F0C2; - fa_flask = $F0C3; - fa_cut = $F0C4; - fa_copy = $F0C5; - fa_paperclip = $F0C6; - fa_save = $F0C7; - fa_square = $F0C8; - fa_navicon = $F0C9; - fa_list_ul = $F0CA; - fa_list_ol = $F0CB; - fa_strikethrough = $F0CC; - fa_underline = $F0CD; - fa_table = $F0CE; - fa_magic = $F0D0; - fa_truck = $F0D1; - fa_pinterest = $F0D2; - fa_pinterest_square = $F0D3; - fa_google_plus_square = $F0D4; - fa_google_plus = $F0D5; - fa_money = $F0D6; - fa_caret_down = $F0D7; - fa_caret_up = $F0D8; - fa_caret_left = $F0D9; - fa_caret_right = $F0DA; - fa_columns = $F0DB; - fa_unsorted = $F0DC; - fa_sort_down = $F0DD; - fa_sort_up = $F0DE; - fa_envelope = $F0E0; - fa_linkedin = $F0E1; - fa_rotate_left = $F0E2; - fa_legal = $F0E3; - fa_dashboard = $F0E4; - fa_comment_o = $F0E5; - fa_comments_o = $F0E6; - fa_flash = $F0E7; - fa_sitemap = $F0E8; - fa_umbrella = $F0E9; - fa_paste = $F0EA; - fa_lightbulb_o = $F0EB; - fa_exchange = $F0EC; - fa_cloud_download = $F0ED; - fa_cloud_upload = $F0EE; - fa_user_md = $F0F0; - fa_stethoscope = $F0F1; - fa_suitcase = $F0F2; - fa_bell_o = $F0A2; - fa_coffee = $F0F4; - fa_cutlery = $F0F5; - fa_file_text_o = $F0F6; - fa_building_o = $F0F7; - fa_hospital_o = $F0F8; - fa_ambulance = $F0F9; - fa_medkit = $F0FA; - fa_fighter_jet = $F0FB; - fa_beer = $F0FC; - fa_h_square = $F0FD; - fa_plus_square = $F0FE; - fa_angle_double_left = $F100; - fa_angle_double_right = $F101; - fa_angle_double_up = $F102; - fa_angle_double_down = $F103; - fa_angle_left = $F104; - fa_angle_right = $F105; - fa_angle_up = $F106; - fa_angle_down = $F107; - fa_desktop = $F108; - fa_mouse_pointer = $F245; - fa_laptop = $F109; - fa_tablet = $F10A; - fa_mobile_phone = $F10B; - fa_circle_o = $F10C; - fa_quote_left = $F10D; - fa_quote_right = $F10E; - fa_spinner = $F110; - fa_circle = $F111; - fa_mail_reply = $F112; - fa_github_alt = $F113; - fa_folder_o = $F114; - fa_folder_open_o = $F115; - fa_smile_o = $F118; - fa_frown_o = $F119; - fa_meh_o = $F11A; - fa_gamepad = $F11B; - fa_keyboard_o = $F11C; - fa_flag_o = $F11D; - fa_flag_checkered = $F11E; - fa_terminal = $F120; - fa_code = $F121; - fa_mail_reply_all = $F122; - fa_star_half_empty = $F123; - fa_location_arrow = $F124; - fa_crop = $F125; - fa_code_fork = $F126; - fa_unlink = $F127; - fa_question = $F128; - fa_info = $F129; - fa_exclamation = $F12A; - fa_superscript = $F12B; - fa_subscript = $F12C; - fa_eraser = $F12D; - fa_puzzle_piece = $F12E; - fa_microphone = $F130; - fa_microphone_slash = $F131; - fa_shield = $F132; - fa_calendar_o = $F133; - fa_fire_extinguisher = $F134; - fa_rocket = $F135; - fa_maxcdn = $F136; - fa_chevron_circle_left = $F137; - fa_chevron_circle_right = $F138; - fa_chevron_circle_up = $F139; - fa_chevron_circle_down = $F13A; - fa_html5 = $F13B; - fa_css3 = $F13C; - fa_anchor = $F13D; - fa_unlock_alt = $F13E; - fa_bullseye = $F140; - fa_ellipsis_h = $F141; - fa_ellipsis_v = $F142; - fa_rss_square = $F143; - fa_play_circle = $F144; - fa_ticket = $F145; - fa_minus_square = $F146; - fa_minus_square_o = $F147; - fa_level_up = $F148; - fa_level_down = $F149; - fa_check_square = $F14A; - fa_pencil_square = $F14B; - fa_external_link_square = $F14C; - fa_share_square = $F14D; - fa_compass = $F14E; - fa_toggle_down = $F150; - fa_toggle_up = $F151; - fa_toggle_right = $F152; - fa_euro = $F153; - fa_gbp = $F154; - fa_dollar = $F155; - fa_rupee = $F156; - fa_cny = $F157; - fa_ruble = $F158; - fa_won = $F159; - fa_bitcoin = $F15A; - fa_file = $F15B; - fa_file_text = $F15C; - fa_sort_alpha_asc = $F15D; - fa_sort_alpha_desc = $F15E; - fa_sort_amount_asc = $F160; - fa_sort_amount_desc = $F161; - fa_sort_numeric_asc = $F162; - fa_sort_numeric_desc = $F163; - fa_thumbs_up = $F164; - fa_thumbs_down = $F165; - fa_youtube_square = $F166; - fa_youtube = $F167; - fa_xing = $F168; - fa_xing_square = $F169; - fa_youtube_play = $F16A; - fa_dropbox = $F16B; - fa_stack_overflow = $F16C; - fa_instagram = $F16D; - fa_flickr = $F16E; - fa_adn = $F170; - fa_bitbucket = $F171; - fa_bitbucket_square = $F172; - fa_tumblr = $F173; - fa_tumblr_square = $F174; - fa_long_arrow_down = $F175; - fa_long_arrow_up = $F176; - fa_long_arrow_left = $F177; - fa_long_arrow_right = $F178; - fa_apple = $F179; - fa_windows = $F17A; - fa_window_maximize = $f2d0; - fa_android = $F17B; - fa_linux = $F17C; - fa_dribbble = $F17D; - fa_skype = $F17E; - fa_foursquare = $F180; - fa_trello = $F181; - fa_female = $F182; - fa_male = $F183; - fa_gittip = $F184; - fa_sun_o = $F185; - fa_moon_o = $F186; - fa_archive = $F187; - fa_bug = $F188; - fa_vk = $F189; - fa_weibo = $F18A; - fa_renren = $F18B; - fa_pagelines = $F18C; - fa_stack_exchange = $F18D; - fa_arrow_circle_o_right = $F18E; - fa_arrow_circle_o_left = $F190; - fa_toggle_left = $F191; - fa_dot_circle_o = $F192; - fa_wheelchair = $F193; - fa_vimeo_square = $F194; - fa_turkish_lira = $F195; - fa_plus_square_o = $F196; - fa_space_shuttle = $F197; - fa_slack = $F198; - fa_envelope_square = $F199; - fa_wordpress = $F19A; - fa_openid = $F19B; - fa_institution = $F19C; - fa_mortar_board = $F19D; - fa_yahoo = $F19E; - fa_google = $F1A0; - fa_reddit = $F1A1; - fa_reddit_square = $F1A2; - fa_stumbleupon_circle = $F1A3; - fa_stumbleupon = $F1A4; - fa_delicious = $F1A5; - fa_digg = $F1A6; - fa_pied_piper = $F1A7; - fa_pied_piper_alt = $F1A8; - fa_drupal = $F1A9; - fa_joomla = $F1AA; - fa_language = $F1AB; - fa_fax = $F1AC; - fa_building = $F1AD; - fa_child = $F1AE; - fa_paw = $F1B0; - fa_spoon = $F1B1; - fa_cube = $F1B2; - fa_cubes = $F1B3; - fa_behance = $F1B4; - fa_behance_square = $F1B5; - fa_steam = $F1B6; - fa_steam_square = $F1B7; - fa_recycle = $F1B8; - fa_automobile = $F1B9; - fa_cab = $F1BA; - fa_tree = $F1BB; - fa_spotify = $F1BC; - fa_deviantart = $F1BD; - fa_soundcloud = $F1BE; - fa_database = $F1C0; - fa_file_pdf_o = $F1C1; - fa_file_word_o = $F1C2; - fa_file_excel_o = $F1C3; - fa_file_powerpoint_o = $F1C4; - fa_file_photo_o = $F1C5; - fa_file_zip_o = $F1C6; - fa_file_sound_o = $F1C7; - fa_file_movie_o = $F1C8; - fa_file_code_o = $F1C9; - fa_vine = $F1CA; - fa_codepen = $F1CB; - fa_jsfiddle = $F1CC; - fa_life_bouy = $F1CD; - fa_circle_o_notch = $F1CE; - fa_ra = $F1D0; - fa_ge = $F1D1; - fa_git_square = $F1D2; - fa_git = $F1D3; - fa_hacker_news = $F1D4; - fa_tencent_weibo = $F1D5; - fa_qq = $F1D6; - fa_wechat = $F1D7; - fa_send = $F1D8; - fa_send_o = $F1D9; - fa_history = $F1DA; - fa_genderless = $F1DB; - fa_header = $F1DC; - fa_paragraph = $F1DD; - fa_sliders = $F1DE; - fa_share_alt = $F1E0; - fa_share_alt_square = $F1E1; - fa_bomb = $F1E2; - fa_soccer_ball_o = $F1E3; - fa_tty = $F1E4; - fa_binoculars = $F1E5; - fa_plug = $F1E6; - fa_slideshare = $F1E7; - fa_twitch = $F1E8; - fa_yelp = $F1E9; - fa_newspaper_o = $F1EA; - fa_wifi = $F1EB; - fa_calculator = $F1EC; - fa_paypal = $F1ED; - fa_google_wallet = $F1EE; - fa_cc_visa = $F1F0; - fa_cc_mastercard = $F1F1; - fa_cc_discover = $F1F2; - fa_cc_amex = $F1F3; - fa_cc_paypal = $F1F4; - fa_cc_stripe = $F1F5; - fa_bell_slash = $F1F6; - fa_bell_slash_o = $F1F7; - fa_trash = $F1F8; - fa_copyright = $F1F9; - fa_at = $F1FA; - fa_eyedropper = $F1FB; - fa_paint_brush = $F1FC; - fa_birthday_cake = $F1FD; - fa_area_chart = $F1FE; - fa_pie_chart = $F200; - fa_line_chart = $F201; - fa_lastfm = $F202; - fa_lastfm_square = $F203; - fa_toggle_off = $F204; - fa_toggle_on = $F205; - fa_bicycle = $F206; - fa_bus = $F207; - fa_ioxhost = $F208; - fa_angellist = $F209; - fa_cc = $F20A; - fa_shekel = $F20B; - fa_meanpath = $F20C; - fa_buysellads = $F20D; - fa_connectdevelop = $F20E; - fa_dashcube = $F210; - fa_forumbee = $F211; - fa_leanpub = $F212; - fa_sellsy = $F213; - fa_shirtsinbulk = $F214; - fa_simplybuilt = $F215; - fa_skyatlas = $F216; - fa_cart_plus = $F217; - fa_cart_arrow_down = $F218; - fa_diamond = $F219; - fa_ship = $F21A; - fa_user_secret = $F21B; - fa_motorcycle = $F21C; - fa_street_view = $F21D; - fa_heartbeat = $F21E; - fa_venus = $F221; - fa_mars = $F222; - fa_mercury = $F223; - fa_transgender = $F224; - fa_transgender_alt = $F225; - fa_venus_double = $F226; - fa_mars_double = $F227; - fa_venus_mars = $F228; - fa_mars_stroke = $F229; - fa_mars_stroke_v = $F22A; - fa_mars_stroke_h = $F22B; - fa_neuter = $F22C; - fa_facebook_official = $F230; - fa_pinterest_p = $F231; - fa_whatsapp = $F232; - fa_server = $F233; - fa_user_plus = $F234; - fa_user_times = $F235; - fa_hotel = $F236; - fa_viacoin = $F237; - fa_train = $F238; - fa_subway = $F239; - fa_medium = $F23A; - -type - //http://fortawesome.github.io/Font-Awesome/cheatsheet/ - TFontAwesome = class - private - FPrivateFontCollection : TGPPrivateFontCollection; - procedure LoadFontFromResource; - public - constructor Create; - Destructor Destroy; override; - procedure DrawChar(DC: HDC; const AChar: Char; DestRect: TRect; AColor : TColor; Orientation : Integer = 0; ImageAlignment: TImageAlignment = iaLeft); overload; - procedure DrawChar(DC: HDC; const AChar: Char; DestRect: TRect; AFontHeight : Integer; AColor : TColor; Orientation : Integer = 0; ImageAlignment: TImageAlignment = iaLeft); overload; - - procedure DrawChar(DC: HDC; const ACode: Word; DestRect: TRect; AColor : TColor; Orientation : Integer = 0; ImageAlignment: TImageAlignment = iaLeft); overload; - procedure DrawChar(DC: HDC; const ACode: Word; DestRect: TRect; AFontHeight : Integer; AColor : TColor; Orientation : Integer = 0; ImageAlignment: TImageAlignment = iaLeft); overload; - - function GetIcon(const ACode: Word; Width, Height : Integer; AColor, ABackColor : TColor; Orientation : Integer = 0; ImageAlignment: TImageAlignment = iaLeft) : HICON; overload; - function GetIcon(const ACode: Word; Width, Height, CharX, CharY : Integer; AColor, ABackColor : TColor; Orientation : Integer = 0; ImageAlignment: TImageAlignment = iaLeft) : HICON; overload; - end; - {$IFDEF WinXCtrls} - TFontAwesomeAnimated = class(TCustomActivityIndicator) - private - FFontAwesomeCode : Word; - FColor, FBackColor : TColor; - procedure SetFontAwesomeCode(const Value: Word); - procedure SetColor(const Value: TColor); - procedure SetBackColor(const Value: TColor); - protected - procedure ReloadFrames; override; - procedure Resize; override; - public - constructor Create(AOwner: TComponent); override; - published - property Anchors; - property Animate; - property FrameDelay; - property IndicatorColor; - property IndicatorSize; - property IndicatorType; - property Color : TColor read FColor write SetColor; - property BackColor : TColor read FBackColor write SetBackColor; - property FontAwesomeCode : Word read FFontAwesomeCode write SetFontAwesomeCode; - end; - {$ENDIF} - -var - FontAwesome : TFontAwesome; - - -implementation - -uses - Winapi.Messages, - System.SysUtils, - System.Math, - Vcl.ExtCtrls, - Vcl.Forms, - Vcl.ImgList, - Vcl.Themes, - Vcl.Styles.Utils.Graphics; - -{ TFontLoader } - -constructor TFontAwesome.Create; -begin - inherited; -// FFontHandle := 0; -// FDefaultQuality := ANTIALIASED_QUALITY; - FPrivateFontCollection := nil; - LoadFontFromResource(); -end; - -destructor TFontAwesome.Destroy; -begin -// if (FFontHandle <> 0) then -// RemoveFontMemResourceEx(FFontHandle); - - if (FPrivateFontCollection <> nil) then - FPrivateFontCollection.Free; - inherited; -end; - -procedure TFontAwesome.LoadFontFromResource; -var - LStream : TResourceStream; - LStatus : TStatus; - cFonts: DWord; -begin - LStream := TResourceStream.Create(HInstance, 'fontawesome', RT_RCDATA); - try - FPrivateFontCollection := TGPPrivateFontCollection.Create; - - // We HAVE to do this to register the font to the system (Weird .NET bug !) - cFonts:= 0; - AddFontMemResourceEx(LStream.Memory, Cardinal(LStream.Size), nil, @cFonts); - - LStatus := FPrivateFontCollection.AddMemoryFont(LStream.Memory, LStream.Size); - if (LStatus <> Status.Ok) then - RaiseLastOSError(); - finally - LStream.Free; - end; -end; - - -function TFontAwesome.GetIcon(const ACode: Word; Width, Height, CharX, - CharY: Integer; AColor, ABackColor: TColor; Orientation: Integer; - ImageAlignment: TImageAlignment): HICON; -var - LIconInfo: TIconInfo; - LBitmap, LMask: TBitmap; - NewIcon: HICON; -begin - LBitmap := TBitmap.Create; - try - LBitmap.PixelFormat := pf32bit; - LBitmap.Canvas.Brush.Color := ABackColor; - LBitmap.SetSize(Width, Height); - //LBitmap.Canvas.FillRect(Rect(0, 0, LBitmap.Width, LBitmap.Height)); - //Bitmap32_SetAlphaAndColor(LBitmap, 255, clFuchsia); - - //DrawChar(LBitmap.Canvas.Handle, ACode, Rect(0, 0, LBitmap.Width, LBitmap.Height), AColor, Orientation, ImageAlignment); - DrawChar(LBitmap.Canvas.Handle, ACode, Rect(0, 0, Width, Height), CharY, AColor, Orientation, ImageAlignment); - Bitmap32_SetAlphaExceptColor(LBitmap, 255, ABackColor); - LBitmap.AlphaFormat := afDefined; - - LMask := TBitmap.Create; - try - //LMask.Handle:=CreateBitmap(LBitmap.Width, LBitmap.Height, 1, 1, 0); - LMask.PixelFormat := pf1bit; - LMask.SetSize(Width, Height); - - LIconInfo.fIcon := True; - LIconInfo.xHotspot := Width; - LIconInfo.yHotspot := Height; - LIconInfo.hbmMask := LMask.Handle; - LIconInfo.hbmColor := LBitmap.Handle; - - NewIcon := CreateIconIndirect(LIconInfo); - Result := NewIcon; - finally - LMask.Free; - end; - finally - LBitmap.Free; - end; -end; - - -function TFontAwesome.GetIcon(const ACode: Word; Width, Height: Integer; AColor, ABackColor: TColor; Orientation: Integer = 0; ImageAlignment: TImageAlignment = iaLeft): HICON; -begin - Result := GetIcon(ACode, Width, Height, Width, Height, AColor, ABackColor, Orientation, ImageAlignment); -end; - -procedure TFontAwesome.DrawChar(DC: HDC; const ACode: Word; DestRect: TRect; AColor: TColor; Orientation : Integer = 0; ImageAlignment: TImageAlignment = iaLeft); -begin - DrawChar(DC, Chr(ACode), DestRect, AColor, Orientation, ImageAlignment); -end; - - -procedure TFontAwesome.DrawChar(DC: HDC; const AChar: Char; DestRect: TRect; AColor: TColor; Orientation : Integer = 0; ImageAlignment: TImageAlignment = iaLeft); -begin - DrawChar(DC, AChar, DestRect, DestRect.Height, AColor, Orientation, ImageAlignment); -end; - -procedure TFontAwesome.DrawChar(DC: HDC; const ACode: Word; DestRect: TRect; - AFontHeight: Integer; AColor: TColor; Orientation: Integer; - ImageAlignment: TImageAlignment); -begin - DrawChar(DC, Chr(ACode), DestRect, AFontHeight, AColor, Orientation, ImageAlignment); -end; - -procedure TFontAwesome.DrawChar(DC: HDC; const AChar: Char; DestRect: TRect; - AFontHeight: Integer; AColor: TColor; Orientation: Integer; - ImageAlignment: TImageAlignment); -var - LFont : TGPFont; - LGPGraphics : TGPGraphics; - LBrush : TGPSolidBrush; - LColor : Cardinal; - LGPStringFormat : TGPStringFormat; - LRect: TGPRectF; -begin - LGPGraphics := TGPGraphics.Create(DC); - try - LFont := TGPFont.Create('FontAwesome', AFontHeight, FontStyleRegular, UnitPixel, FPrivateFontCollection); - try - LColor := ColorToRGB(AColor); - LRect := MakeRect(DestRect.Left * 1.0, DestRect.Top * 1.0, DestRect.Width * 1.0, DestRect.Height * 1.0); - - LBrush := TGPSolidBrush.Create(MakeColor(255, GetRValue(LColor), GetGValue(LColor), GetBValue(LColor))); - try - LGPStringFormat := TGPStringFormat.Create(); - try - LGPStringFormat.SetAlignment(StringAlignmentCenter); - //LGPStringFormat.SetLineAlignment(TStringAlignment.StringAlignmentCenter); - LGPGraphics.DrawString(AChar, -1, LFont, LRect, LGPStringFormat, LBrush); - finally - LGPStringFormat.Free; - end; - finally - LBrush.Free; - end; - finally - LFont.Free; - end; - finally - LGPGraphics.Free; - end; -end; - -//var -// LogFont: TLogFont; -// AFont : HFONT; -// pOldFont: HGDIOBJ; -// LColorRef: COLORREF; -// OldMode: integer; -// uFormat : Cardinal; -//begin -// if FFontHandle = 0 then exit; -// -// ZeroMemory(@LogFont, SizeOf(LogFont)); -// LogFont.lfHeight := DestRect.Height; -// LogFont.lfWidth := 0; -// LogFont.lfEscapement := Orientation * 10; -// LogFont.lfOrientation := LogFont.lfEscapement; -// LogFont.lfWeight := FW_NORMAL; -// LogFont.lfItalic := 0; -// LogFont.lfUnderline := 0; -// LogFont.lfStrikeOut := 0; -// LogFont.lfCharSet := DEFAULT_CHARSET; -// LogFont.lfOutPrecision := OUT_OUTLINE_PRECIS;//OUT_STROKE_PRECIS; -// LogFont.lfClipPrecision := CLIP_DEFAULT_PRECIS; -// LogFont.lfQuality := FDefaultQuality; -// LogFont.lfPitchAndFamily := DEFAULT_PITCH; -// LogFont.lfFaceName := 'FontAwesome'; -// -// LColorRef := ColorToRGB(AColor); -// -// AFont := CreateFontIndirect(LogFont); -// if AFont <> 0 then -// try -// LColorRef := SetTextColor(DC, LColorRef); -// pOldFont := SelectObject(DC, AFont); -// try -// OldMode := SetBkMode(DC, TRANSPARENT); -// uFormat := DT_SINGLELINE; -// -// case ImageAlignment of -// iaLeft : uFormat := uFormat or DT_LEFT; -// iaRight : uFormat := uFormat or DT_RIGHT; -// iaCenter : uFormat := uFormat or DT_CENTER; -// iaTop : uFormat := uFormat or DT_TOP; -// iaBottom : uFormat := uFormat or DT_BOTTOM; -// end; -// -// uFormat := uFormat or DT_NOCLIP; -// -// Winapi.Windows.DrawText(DC, AChar, 1, DestRect, uFormat); -// SetBkMode(DC, OldMode); -// SelectObject(DC, LColorRef); -// finally -// if pOldFont <> 0 then -// SelectObject(DC, pOldFont); -// end; -// finally -// DeleteObject(AFont); -// end; -//end; - - -{$IFDEF WinXCtrls} -{ TFontAwesomeAnimated } -type - TCustomActivityIndicatorShadow = class(TCustomControl) - private - FAnimate: Boolean; - FIndicatorColor: TActivityIndicatorColor; - FIndicatorSize: TActivityIndicatorSize; - FIndicatorType: TActivityIndicatorType; - FFrameDelay: Word; - FFrameIndex: Integer; - FTimer: TTimer; - FFrameList: TImageList; - FFrameCount: Integer; - FFrameSize: Integer; - FFrameBitmap: TBitmap; - FLoadedFrames: Boolean; - end; - -procedure DrawParentImage(Control: TControl; DC: HDC; InvalidateParent: Boolean = False); -var - SaveIndex: Integer; - P: TPoint; -begin - if Control.Parent = nil then - Exit; - SaveIndex := SaveDC(DC); - GetViewportOrgEx(DC, P); - - SetViewportOrgEx(DC, P.X - Control.Left, P.Y - Control.Top, nil); - IntersectClipRect(DC, 0, 0, Control.Parent.ClientWidth, Control.Parent.ClientHeight); - - Control.Parent.Perform(WM_ERASEBKGND, DC, 0); - Control.Parent.Perform(WM_PRINTCLIENT, DC, prf_Client); - - RestoreDC(DC, SaveIndex); - - if InvalidateParent then - begin - if not (Control.Parent is TCustomControl) and not (Control.Parent is TCustomForm) and - not (csDesigning in Control.ComponentState) then - begin - Control.Parent.Invalidate; - end; - end; -end; - -constructor TFontAwesomeAnimated.Create(AOwner: TComponent); -begin - inherited Create(AOwner); - FFontAwesomeCode := fa_spinner; - FColor := StyleServices.GetSystemColor(clBtnText); - FBackColor := StyleServices.GetSystemColor(clBtnFace); -end; - -procedure RotateBitmap(ABitmap: TBitmap; Degs: Integer; Resize: Boolean; ABackColor: TColor = clNone); -var - LGPBitmap: TGPBitmap; - LMatrix: TGPMatrix; - C, S: Single; - LSize: TSize; - LGPGraphics: TGPGraphics; -begin - LGPBitmap := TGPBitmap.Create(ABitmap.Handle, ABitmap.Palette); - try - LMatrix := TGPMatrix.Create; - try - LMatrix.RotateAt(Degs, MakePoint(0.5 * ABitmap.Width, 0.5 * ABitmap.Height)); - if Resize then - begin - C := Cos(DegToRad(Degs)); - S := Sin(DegToRad(Degs)); - LSize.cx := Round(ABitmap.Width * Abs(C) + ABitmap.Height * Abs(S)); - LSize.cy := Round(ABitmap.Width * Abs(S) + ABitmap.Height * Abs(C)); - ABitmap.Width := LSize.cx; - ABitmap.Height := LSize.cy; - end; - - LGPGraphics := TGPGraphics.Create(ABitmap.Canvas.Handle); - try - LGPGraphics.Clear(ColorRefToARGB(ColorToRGB(ABackColor))); - LGPGraphics.SetTransform(LMatrix); - LGPGraphics.DrawImage(LGPBitmap, (Cardinal(ABitmap.Width) - LGPBitmap.GetWidth) div 2, - (Cardinal(ABitmap.Height) - LGPBitmap.GetHeight) div 2); - finally - LGPGraphics.Free; - end; - - finally - LMatrix.Free; - end; - finally - LGPBitmap.Free; - end; -end; - -procedure TFontAwesomeAnimated.ReloadFrames; -var - i, LFrameSize, LAngleDelta, LAngle : Integer; - LBitmap : TBitmap; -begin - TCustomActivityIndicatorShadow(Self).FFrameSize := 48; - LFrameSize := TCustomActivityIndicatorShadow(Self).FFrameSize; - TCustomActivityIndicatorShadow(Self).FFrameCount := 24; //optimize - TCustomActivityIndicatorShadow(Self).FFrameBitmap.SetSize(LFrameSize, LFrameSize); - LAngleDelta := 360 div TCustomActivityIndicatorShadow(Self).FFrameCount; - - //TCustomActivityIndicatorShadow(Self).FFrameList.ColorDepth := cd24Bit; - TCustomActivityIndicatorShadow(Self).FFrameList.Width := LFrameSize; - TCustomActivityIndicatorShadow(Self).FFrameList.Height := LFrameSize; - - TCustomActivityIndicatorShadow(Self).FFrameList.Clear; - LAngle := 0; - for i := 0 to TCustomActivityIndicatorShadow(Self).FFrameCount - 1 do - begin - LBitmap := TBitmap.Create; - try - LBitmap.PixelFormat := pf32bit; - LBitmap.AlphaFormat := afDefined; - LBitmap.SetSize(LFrameSize, LFrameSize); - Bitmap32_SetAlphaAndColor(LBitmap, 0, FBackColor); - Bitmap32_SetAlpha(LBitmap, 0); - FontAwesome.DrawChar(LBitmap.Canvas.Handle, Char(FFontAwesomeCode), Rect(0, 0, LFrameSize, LFrameSize), FColor, 0, TImageAlignment.iaCenter); - if (LAngle > 0) then - RotateBitmap(LBitmap, LAngle, False, FBackColor); - Inc(LAngle, LAngleDelta); - TCustomActivityIndicatorShadow(Self).FFrameList.Add(LBitmap, nil); - finally - LBitmap.Free; - end; - end; - TCustomActivityIndicatorShadow(Self).FLoadedFrames := True; -end; - -procedure TFontAwesomeAnimated.Resize; -begin - SetBounds(Left, Top, TCustomActivityIndicatorShadow(Self).FFrameSize, TCustomActivityIndicatorShadow(Self).FFrameSize); -end; - -procedure TFontAwesomeAnimated.SetBackColor(const Value: TColor); -var - SaveAnimate: Boolean; -begin - if FBackColor <> Value then - begin - FBackColor := Value; - SaveAnimate := Animate; - Animate := False; - ReloadFrames; - Animate := SaveAnimate; - end; -end; - -procedure TFontAwesomeAnimated.SetColor(const Value: TColor); -var - SaveAnimate: Boolean; -begin - if FColor <> Value then - begin - FColor := Value; - SaveAnimate := Animate; - Animate := False; - ReloadFrames; - Animate := SaveAnimate; - end; -end; - -procedure TFontAwesomeAnimated.SetFontAwesomeCode(const Value: Word); -var - SaveAnimate: Boolean; -begin - if FFontAwesomeCode <> Value then - begin - FFontAwesomeCode := Value; - SaveAnimate := Animate; - Animate := False; - ReloadFrames; - Animate := SaveAnimate; - end; -end; -{$ENDIF} - -initialization - FontAwesome := TFontAwesome.Create; -finalization - FontAwesome.Free; -end. +//************************************************************************************************** +// +// Unit Vcl.Styles.FontAwesome +// unit for the VCL Styles Utils +// https://github.com/RRUZ/vcl-styles-utils/ +// +// 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. +// +// The Original Code is Vcl.Styles.FontAwesome.pas. +// +// The Initial Developer of the Original Code is Rodrigo Ruz V. +// Portions created by Rodrigo Ruz V. are Copyright (C) 2012-2023 Rodrigo Ruz V. +// All Rights Reserved. +// +//************************************************************************************************** +unit Vcl.Styles.FontAwesome; + +interface + +{$IF CompilerVersion >= 30.0} + + {$DEFINE WinXCtrls} +{$ENDIF} + +uses + Winapi.GDIPOBJ, + Winapi.GDIPAPI, + Winapi.Windows, + System.Classes, + {$IFDEF WinXCtrls} + Vcl.WinXCtrls, + {$ENDIF} + Vcl.Controls, + Vcl.StdCtrls, + Vcl.Graphics; + + +{$R AwesomeFont.RES} + +//http://fortawesome.github.io/Font-Awesome/cheatsheet/ +//http://prettyprinter.de/index.php + +//version 4.7.0 +const + fa_glass = $F000; + fa_music = $F001; + fa_search = $F002; + fa_envelope_o = $F003; + fa_heart = $F004; + fa_star = $F005; + fa_star_o = $F006; + fa_user = $F007; + fa_film = $F008; + fa_th_large = $F009; + fa_th = $F00A; + fa_th_list = $F00B; + fa_check = $F00C; + fa_remove = $F00D; + fa_search_plus = $F00E; + fa_search_minus = $F010; + fa_power_off = $F011; + fa_signal = $F012; + fa_gear = $F013; + fa_trash_o = $F014; + fa_home = $F015; + fa_file_o = $F016; + fa_clock_o = $F017; + fa_road = $F018; + fa_download = $F019; + fa_arrow_circle_o_down = $F01A; + fa_arrow_circle_o_up = $F01B; + fa_inbox = $F01C; + fa_play_circle_o = $F01D; + fa_rotate_right = $F01E; + fa_refresh = $F021; + fa_list_alt = $F022; + fa_lock = $F023; + fa_flag = $F024; + fa_headphones = $F025; + fa_volume_off = $F026; + fa_volume_down = $F027; + fa_volume_up = $F028; + fa_qrcode = $F029; + fa_barcode = $F02A; + fa_tag = $F02B; + fa_tags = $F02C; + fa_book = $F02D; + fa_bookmark = $F02E; + fa_print = $F02F; + fa_camera = $F030; + fa_font = $F031; + fa_bold = $F032; + fa_italic = $F033; + fa_text_height = $F034; + fa_text_width = $F035; + fa_align_left = $F036; + fa_align_center = $F037; + fa_align_right = $F038; + fa_align_justify = $F039; + fa_list = $F03A; + fa_dedent = $F03B; + fa_indent = $F03C; + fa_video_camera = $F03D; + fa_photo = $F03E; + fa_pencil = $F040; + fa_map_marker = $F041; + fa_adjust = $F042; + fa_tint = $F043; + fa_edit = $F044; + fa_share_square_o = $F045; + fa_check_square_o = $F046; + fa_arrows = $F047; + fa_step_backward = $F048; + fa_fast_backward = $F049; + fa_backward = $F04A; + fa_play = $F04B; + fa_pause = $F04C; + fa_stop = $F04D; + fa_forward = $F04E; + fa_fast_forward = $F050; + fa_step_forward = $F051; + fa_eject = $F052; + fa_chevron_left = $F053; + fa_chevron_right = $F054; + fa_plus_circle = $F055; + fa_minus_circle = $F056; + fa_times_circle = $F057; + fa_check_circle = $F058; + fa_question_circle = $F059; + fa_info_circle = $F05A; + fa_crosshairs = $F05B; + fa_times_circle_o = $F05C; + fa_check_circle_o = $F05D; + fa_ban = $F05E; + fa_arrow_left = $F060; + fa_arrow_right = $F061; + fa_arrow_up = $F062; + fa_arrow_down = $F063; + fa_mail_forward = $F064; + fa_expand = $F065; + fa_compress = $F066; + fa_plus = $F067; + fa_minus = $F068; + fa_asterisk = $F069; + fa_exclamation_circle = $F06A; + fa_gift = $F06B; + fa_leaf = $F06C; + fa_fire = $F06D; + fa_eye = $F06E; + fa_eye_slash = $F070; + fa_warning = $F071; + fa_plane = $F072; + fa_calendar = $F073; + fa_random = $F074; + fa_comment = $F075; + fa_magnet = $F076; + fa_chevron_up = $F077; + fa_chevron_down = $F078; + fa_retweet = $F079; + fa_shopping_cart = $F07A; + fa_folder = $F07B; + fa_folder_open = $F07C; + fa_arrows_v = $F07D; + fa_arrows_h = $F07E; + fa_bar_chart_o = $F080; + fa_twitter_square = $F081; + fa_facebook_square = $F082; + fa_camera_retro = $F083; + fa_key = $F084; + fa_gears = $F085; + fa_comments = $F086; + fa_commenting = $F27a; + fa_commenting_o = $f27b; + fa_thumbs_o_up = $F087; + fa_thumbs_o_down = $F088; + fa_star_half = $F089; + fa_heart_o = $F08A; + fa_sign_out = $F08B; + fa_linkedin_square = $F08C; + fa_thumb_tack = $F08D; + fa_external_link = $F08E; + fa_sign_in = $F090; + fa_trophy = $F091; + fa_github_square = $F092; + fa_upload = $F093; + fa_lemon_o = $F094; + fa_phone = $F095; + fa_square_o = $F096; + fa_bookmark_o = $F097; + fa_phone_square = $F098; + fa_twitter = $F099; + fa_facebook_f = $F09A; + fa_github = $F09B; + fa_unlock = $F09C; + fa_credit_card = $F09D; + fa_rss = $F09E; + fa_hdd_o = $F0A0; + fa_bullhorn = $F0A1; + fa_bell = $F0F3; + fa_certificate = $F0A3; + fa_hand_o_right = $F0A4; + fa_hand_o_left = $F0A5; + fa_hand_o_up = $F0A6; + fa_hand_o_down = $F0A7; + fa_arrow_circle_left = $F0A8; + fa_arrow_circle_right = $F0A9; + fa_arrow_circle_up = $F0AA; + fa_arrow_circle_down = $F0AB; + fa_globe = $F0AC; + fa_wrench = $F0AD; + fa_tasks = $F0AE; + fa_filter = $F0B0; + fa_clone = $F24D; + fa_briefcase = $F0B1; + fa_arrows_alt = $F0B2; + fa_group = $F0C0; + fa_chain = $F0C1; + fa_cloud = $F0C2; + fa_flask = $F0C3; + fa_cut = $F0C4; + fa_copy = $F0C5; + fa_paperclip = $F0C6; + fa_save = $F0C7; + fa_square = $F0C8; + fa_navicon = $F0C9; + fa_list_ul = $F0CA; + fa_list_ol = $F0CB; + fa_strikethrough = $F0CC; + fa_underline = $F0CD; + fa_table = $F0CE; + fa_magic = $F0D0; + fa_truck = $F0D1; + fa_pinterest = $F0D2; + fa_pinterest_square = $F0D3; + fa_google_plus_square = $F0D4; + fa_google_plus = $F0D5; + fa_money = $F0D6; + fa_caret_down = $F0D7; + fa_caret_up = $F0D8; + fa_caret_left = $F0D9; + fa_caret_right = $F0DA; + fa_columns = $F0DB; + fa_unsorted = $F0DC; + fa_sort_down = $F0DD; + fa_sort_up = $F0DE; + fa_envelope = $F0E0; + fa_linkedin = $F0E1; + fa_rotate_left = $F0E2; + fa_legal = $F0E3; + fa_dashboard = $F0E4; + fa_comment_o = $F0E5; + fa_comments_o = $F0E6; + fa_flash = $F0E7; + fa_sitemap = $F0E8; + fa_umbrella = $F0E9; + fa_paste = $F0EA; + fa_lightbulb_o = $F0EB; + fa_exchange = $F0EC; + fa_cloud_download = $F0ED; + fa_cloud_upload = $F0EE; + fa_user_md = $F0F0; + fa_stethoscope = $F0F1; + fa_suitcase = $F0F2; + fa_bell_o = $F0A2; + fa_coffee = $F0F4; + fa_cutlery = $F0F5; + fa_file_text_o = $F0F6; + fa_building_o = $F0F7; + fa_hospital_o = $F0F8; + fa_ambulance = $F0F9; + fa_medkit = $F0FA; + fa_fighter_jet = $F0FB; + fa_beer = $F0FC; + fa_h_square = $F0FD; + fa_plus_square = $F0FE; + fa_angle_double_left = $F100; + fa_angle_double_right = $F101; + fa_angle_double_up = $F102; + fa_angle_double_down = $F103; + fa_angle_left = $F104; + fa_angle_right = $F105; + fa_angle_up = $F106; + fa_angle_down = $F107; + fa_desktop = $F108; + fa_mouse_pointer = $F245; + fa_laptop = $F109; + fa_tablet = $F10A; + fa_mobile_phone = $F10B; + fa_circle_o = $F10C; + fa_quote_left = $F10D; + fa_quote_right = $F10E; + fa_spinner = $F110; + fa_circle = $F111; + fa_mail_reply = $F112; + fa_github_alt = $F113; + fa_folder_o = $F114; + fa_folder_open_o = $F115; + fa_smile_o = $F118; + fa_frown_o = $F119; + fa_meh_o = $F11A; + fa_gamepad = $F11B; + fa_keyboard_o = $F11C; + fa_flag_o = $F11D; + fa_flag_checkered = $F11E; + fa_terminal = $F120; + fa_code = $F121; + fa_mail_reply_all = $F122; + fa_star_half_empty = $F123; + fa_location_arrow = $F124; + fa_crop = $F125; + fa_code_fork = $F126; + fa_unlink = $F127; + fa_question = $F128; + fa_info = $F129; + fa_exclamation = $F12A; + fa_superscript = $F12B; + fa_subscript = $F12C; + fa_eraser = $F12D; + fa_puzzle_piece = $F12E; + fa_microphone = $F130; + fa_microphone_slash = $F131; + fa_shield = $F132; + fa_calendar_o = $F133; + fa_fire_extinguisher = $F134; + fa_rocket = $F135; + fa_maxcdn = $F136; + fa_chevron_circle_left = $F137; + fa_chevron_circle_right = $F138; + fa_chevron_circle_up = $F139; + fa_chevron_circle_down = $F13A; + fa_html5 = $F13B; + fa_css3 = $F13C; + fa_anchor = $F13D; + fa_unlock_alt = $F13E; + fa_bullseye = $F140; + fa_ellipsis_h = $F141; + fa_ellipsis_v = $F142; + fa_rss_square = $F143; + fa_play_circle = $F144; + fa_ticket = $F145; + fa_minus_square = $F146; + fa_minus_square_o = $F147; + fa_level_up = $F148; + fa_level_down = $F149; + fa_check_square = $F14A; + fa_pencil_square = $F14B; + fa_external_link_square = $F14C; + fa_share_square = $F14D; + fa_compass = $F14E; + fa_toggle_down = $F150; + fa_toggle_up = $F151; + fa_toggle_right = $F152; + fa_euro = $F153; + fa_gbp = $F154; + fa_dollar = $F155; + fa_rupee = $F156; + fa_cny = $F157; + fa_ruble = $F158; + fa_won = $F159; + fa_bitcoin = $F15A; + fa_file = $F15B; + fa_file_text = $F15C; + fa_sort_alpha_asc = $F15D; + fa_sort_alpha_desc = $F15E; + fa_sort_amount_asc = $F160; + fa_sort_amount_desc = $F161; + fa_sort_numeric_asc = $F162; + fa_sort_numeric_desc = $F163; + fa_thumbs_up = $F164; + fa_thumbs_down = $F165; + fa_youtube_square = $F166; + fa_youtube = $F167; + fa_xing = $F168; + fa_xing_square = $F169; + fa_youtube_play = $F16A; + fa_dropbox = $F16B; + fa_stack_overflow = $F16C; + fa_instagram = $F16D; + fa_flickr = $F16E; + fa_adn = $F170; + fa_bitbucket = $F171; + fa_bitbucket_square = $F172; + fa_tumblr = $F173; + fa_tumblr_square = $F174; + fa_long_arrow_down = $F175; + fa_long_arrow_up = $F176; + fa_long_arrow_left = $F177; + fa_long_arrow_right = $F178; + fa_apple = $F179; + fa_windows = $F17A; + fa_window_maximize = $f2d0; + fa_android = $F17B; + fa_linux = $F17C; + fa_dribbble = $F17D; + fa_skype = $F17E; + fa_foursquare = $F180; + fa_trello = $F181; + fa_female = $F182; + fa_male = $F183; + fa_gittip = $F184; + fa_sun_o = $F185; + fa_moon_o = $F186; + fa_archive = $F187; + fa_bug = $F188; + fa_vk = $F189; + fa_weibo = $F18A; + fa_renren = $F18B; + fa_pagelines = $F18C; + fa_stack_exchange = $F18D; + fa_arrow_circle_o_right = $F18E; + fa_arrow_circle_o_left = $F190; + fa_toggle_left = $F191; + fa_dot_circle_o = $F192; + fa_wheelchair = $F193; + fa_vimeo_square = $F194; + fa_turkish_lira = $F195; + fa_plus_square_o = $F196; + fa_space_shuttle = $F197; + fa_slack = $F198; + fa_envelope_square = $F199; + fa_wordpress = $F19A; + fa_openid = $F19B; + fa_institution = $F19C; + fa_mortar_board = $F19D; + fa_yahoo = $F19E; + fa_google = $F1A0; + fa_reddit = $F1A1; + fa_reddit_square = $F1A2; + fa_stumbleupon_circle = $F1A3; + fa_stumbleupon = $F1A4; + fa_delicious = $F1A5; + fa_digg = $F1A6; + fa_pied_piper = $F1A7; + fa_pied_piper_alt = $F1A8; + fa_drupal = $F1A9; + fa_joomla = $F1AA; + fa_language = $F1AB; + fa_fax = $F1AC; + fa_building = $F1AD; + fa_child = $F1AE; + fa_paw = $F1B0; + fa_spoon = $F1B1; + fa_cube = $F1B2; + fa_cubes = $F1B3; + fa_behance = $F1B4; + fa_behance_square = $F1B5; + fa_steam = $F1B6; + fa_steam_square = $F1B7; + fa_recycle = $F1B8; + fa_automobile = $F1B9; + fa_cab = $F1BA; + fa_tree = $F1BB; + fa_spotify = $F1BC; + fa_deviantart = $F1BD; + fa_soundcloud = $F1BE; + fa_database = $F1C0; + fa_file_pdf_o = $F1C1; + fa_file_word_o = $F1C2; + fa_file_excel_o = $F1C3; + fa_file_powerpoint_o = $F1C4; + fa_file_photo_o = $F1C5; + fa_file_zip_o = $F1C6; + fa_file_sound_o = $F1C7; + fa_file_movie_o = $F1C8; + fa_file_code_o = $F1C9; + fa_vine = $F1CA; + fa_codepen = $F1CB; + fa_jsfiddle = $F1CC; + fa_life_bouy = $F1CD; + fa_circle_o_notch = $F1CE; + fa_ra = $F1D0; + fa_ge = $F1D1; + fa_git_square = $F1D2; + fa_git = $F1D3; + fa_hacker_news = $F1D4; + fa_tencent_weibo = $F1D5; + fa_qq = $F1D6; + fa_wechat = $F1D7; + fa_send = $F1D8; + fa_send_o = $F1D9; + fa_history = $F1DA; + fa_genderless = $F1DB; + fa_header = $F1DC; + fa_paragraph = $F1DD; + fa_sliders = $F1DE; + fa_share_alt = $F1E0; + fa_share_alt_square = $F1E1; + fa_bomb = $F1E2; + fa_soccer_ball_o = $F1E3; + fa_tty = $F1E4; + fa_binoculars = $F1E5; + fa_plug = $F1E6; + fa_slideshare = $F1E7; + fa_twitch = $F1E8; + fa_yelp = $F1E9; + fa_newspaper_o = $F1EA; + fa_wifi = $F1EB; + fa_calculator = $F1EC; + fa_paypal = $F1ED; + fa_google_wallet = $F1EE; + fa_cc_visa = $F1F0; + fa_cc_mastercard = $F1F1; + fa_cc_discover = $F1F2; + fa_cc_amex = $F1F3; + fa_cc_paypal = $F1F4; + fa_cc_stripe = $F1F5; + fa_bell_slash = $F1F6; + fa_bell_slash_o = $F1F7; + fa_trash = $F1F8; + fa_copyright = $F1F9; + fa_at = $F1FA; + fa_eyedropper = $F1FB; + fa_paint_brush = $F1FC; + fa_birthday_cake = $F1FD; + fa_area_chart = $F1FE; + fa_pie_chart = $F200; + fa_line_chart = $F201; + fa_lastfm = $F202; + fa_lastfm_square = $F203; + fa_toggle_off = $F204; + fa_toggle_on = $F205; + fa_bicycle = $F206; + fa_bus = $F207; + fa_ioxhost = $F208; + fa_angellist = $F209; + fa_cc = $F20A; + fa_shekel = $F20B; + fa_meanpath = $F20C; + fa_buysellads = $F20D; + fa_connectdevelop = $F20E; + fa_dashcube = $F210; + fa_forumbee = $F211; + fa_leanpub = $F212; + fa_sellsy = $F213; + fa_shirtsinbulk = $F214; + fa_simplybuilt = $F215; + fa_skyatlas = $F216; + fa_cart_plus = $F217; + fa_cart_arrow_down = $F218; + fa_diamond = $F219; + fa_ship = $F21A; + fa_user_secret = $F21B; + fa_motorcycle = $F21C; + fa_street_view = $F21D; + fa_heartbeat = $F21E; + fa_venus = $F221; + fa_mars = $F222; + fa_mercury = $F223; + fa_transgender = $F224; + fa_transgender_alt = $F225; + fa_venus_double = $F226; + fa_mars_double = $F227; + fa_venus_mars = $F228; + fa_mars_stroke = $F229; + fa_mars_stroke_v = $F22A; + fa_mars_stroke_h = $F22B; + fa_neuter = $F22C; + fa_facebook_official = $F230; + fa_pinterest_p = $F231; + fa_whatsapp = $F232; + fa_server = $F233; + fa_user_plus = $F234; + fa_user_times = $F235; + fa_hotel = $F236; + fa_viacoin = $F237; + fa_train = $F238; + fa_subway = $F239; + fa_medium = $F23A; + +type + //http://fortawesome.github.io/Font-Awesome/cheatsheet/ + TFontAwesome = class + private + FPrivateFontCollection: TGPPrivateFontCollection; + procedure LoadFontFromResource; + public + constructor Create; + Destructor Destroy; override; + procedure DrawChar(DC: HDC; const AChar: Char; DestRect: TRect; AColor: TColor; Orientation: Integer = 0; ImageAlignment: TImageAlignment = iaLeft); overload; + procedure DrawChar(DC: HDC; const AChar: Char; DestRect: TRect; AFontHeight: Integer; AColor: TColor; Orientation: Integer = 0; ImageAlignment: TImageAlignment = iaLeft); overload; + + procedure DrawChar(DC: HDC; const ACode: Word; DestRect: TRect; AColor: TColor; Orientation: Integer = 0; ImageAlignment: TImageAlignment = iaLeft); overload; + procedure DrawChar(DC: HDC; const ACode: Word; DestRect: TRect; AFontHeight: Integer; AColor: TColor; Orientation: Integer = 0; ImageAlignment: TImageAlignment = iaLeft); overload; + + function GetIcon(const ACode: Word; Width, Height: Integer; AColor, ABackColor: TColor; Orientation: Integer = 0; ImageAlignment: TImageAlignment = iaLeft): HICON; overload; + function GetIcon(const ACode: Word; Width, Height, CharX, CharY: Integer; AColor, ABackColor: TColor; Orientation: Integer = 0; ImageAlignment: TImageAlignment = iaLeft): HICON; overload; + end; + {$IFDEF WinXCtrls} + TFontAwesomeAnimated = class(TCustomActivityIndicator) + private + FFontAwesomeCode: Word; + FColor, FBackColor: TColor; + procedure SetFontAwesomeCode(const Value: Word); + procedure SetColor(const Value: TColor); + procedure SetBackColor(const Value: TColor); + protected + procedure ReloadFrames; override; + procedure Resize; override; + public + constructor Create(AOwner: TComponent); override; + published + property Anchors; + property Animate; + property FrameDelay; + property IndicatorColor; + property IndicatorSize; + property IndicatorType; + property Color: TColor read FColor write SetColor; + property BackColor: TColor read FBackColor write SetBackColor; + property FontAwesomeCode: Word read FFontAwesomeCode write SetFontAwesomeCode; + end; + {$ENDIF} + +var + FontAwesome: TFontAwesome; + + +implementation + +uses + Winapi.Messages, + System.SysUtils, + System.Math, + Vcl.ExtCtrls, + Vcl.Forms, + Vcl.ImgList, + Vcl.Themes, + Vcl.Styles.Utils.Graphics; + +{ TFontLoader } + +constructor TFontAwesome.Create; +begin + inherited; +// FFontHandle := 0; +// FDefaultQuality := ANTIALIASED_QUALITY; + FPrivateFontCollection := nil; + LoadFontFromResource(); +end; + +destructor TFontAwesome.Destroy; +begin +// if (FFontHandle <> 0) then +// RemoveFontMemResourceEx(FFontHandle); + + if (FPrivateFontCollection <> nil) then + FPrivateFontCollection.Free; + inherited; +end; + +procedure TFontAwesome.LoadFontFromResource; +var + LStream: TResourceStream; + LStatus: TStatus; + cFonts: DWord; +begin + LStream := TResourceStream.Create(HInstance, 'fontawesome', RT_RCDATA); + try + FPrivateFontCollection := TGPPrivateFontCollection.Create; + + // We HAVE to do this to register the font to the system (Weird .NET bug !) + cFonts:= 0; + AddFontMemResourceEx(LStream.Memory, Cardinal(LStream.Size), nil, @cFonts); + + LStatus := FPrivateFontCollection.AddMemoryFont(LStream.Memory, LStream.Size); + if (LStatus <> Status.Ok) then + RaiseLastOSError(); + finally + LStream.Free; + end; +end; + + +function TFontAwesome.GetIcon(const ACode: Word; Width, Height, CharX, + CharY: Integer; AColor, ABackColor: TColor; Orientation: Integer; + ImageAlignment: TImageAlignment): HICON; +var + LIconInfo: TIconInfo; + LBitmap, LMask: TBitmap; + NewIcon: HICON; +begin + LBitmap := TBitmap.Create; + try + LBitmap.PixelFormat := pf32bit; + LBitmap.Canvas.Brush.Color := ABackColor; + LBitmap.SetSize(Width, Height); + //LBitmap.Canvas.FillRect(Rect(0, 0, LBitmap.Width, LBitmap.Height)); + //Bitmap32_SetAlphaAndColor(LBitmap, 255, clFuchsia); + + //DrawChar(LBitmap.Canvas.Handle, ACode, Rect(0, 0, LBitmap.Width, LBitmap.Height), AColor, Orientation, ImageAlignment); + DrawChar(LBitmap.Canvas.Handle, ACode, Rect(0, 0, Width, Height), CharY, AColor, Orientation, ImageAlignment); + Bitmap32_SetAlphaExceptColor(LBitmap, 255, ABackColor); + LBitmap.AlphaFormat := afDefined; + + LMask := TBitmap.Create; + try + //LMask.Handle:=CreateBitmap(LBitmap.Width, LBitmap.Height, 1, 1, 0); + LMask.PixelFormat := pf1bit; + LMask.SetSize(Width, Height); + + LIconInfo.fIcon := True; + LIconInfo.xHotspot := Width; + LIconInfo.yHotspot := Height; + LIconInfo.hbmMask := LMask.Handle; + LIconInfo.hbmColor := LBitmap.Handle; + + NewIcon := CreateIconIndirect(LIconInfo); + Result := NewIcon; + finally + LMask.Free; + end; + finally + LBitmap.Free; + end; +end; + + +function TFontAwesome.GetIcon(const ACode: Word; Width, Height: Integer; AColor, ABackColor: TColor; Orientation: Integer = 0; ImageAlignment: TImageAlignment = iaLeft): HICON; +begin + Result := GetIcon(ACode, Width, Height, Width, Height, AColor, ABackColor, Orientation, ImageAlignment); +end; + +procedure TFontAwesome.DrawChar(DC: HDC; const ACode: Word; DestRect: TRect; AColor: TColor; Orientation: Integer = 0; ImageAlignment: TImageAlignment = iaLeft); +begin + DrawChar(DC, Chr(ACode), DestRect, AColor, Orientation, ImageAlignment); +end; + + +procedure TFontAwesome.DrawChar(DC: HDC; const AChar: Char; DestRect: TRect; AColor: TColor; Orientation: Integer = 0; ImageAlignment: TImageAlignment = iaLeft); +begin + DrawChar(DC, AChar, DestRect, DestRect.Height, AColor, Orientation, ImageAlignment); +end; + +procedure TFontAwesome.DrawChar(DC: HDC; const ACode: Word; DestRect: TRect; + AFontHeight: Integer; AColor: TColor; Orientation: Integer; + ImageAlignment: TImageAlignment); +begin + DrawChar(DC, Chr(ACode), DestRect, AFontHeight, AColor, Orientation, ImageAlignment); +end; + +procedure TFontAwesome.DrawChar(DC: HDC; const AChar: Char; DestRect: TRect; + AFontHeight: Integer; AColor: TColor; Orientation: Integer; + ImageAlignment: TImageAlignment); +var + LFont: TGPFont; + LGPGraphics: TGPGraphics; + LBrush: TGPSolidBrush; + LColor: Cardinal; + LGPStringFormat: TGPStringFormat; + LRect: TGPRectF; +begin + LGPGraphics := TGPGraphics.Create(DC); + try + LFont := TGPFont.Create('FontAwesome', AFontHeight, FontStyleRegular, UnitPixel, FPrivateFontCollection); + try + LColor := ColorToRGB(AColor); + LRect := MakeRect(DestRect.Left * 1.0, DestRect.Top * 1.0, DestRect.Width * 1.0, DestRect.Height * 1.0); + + LBrush := TGPSolidBrush.Create(MakeColor(255, GetRValue(LColor), GetGValue(LColor), GetBValue(LColor))); + try + LGPStringFormat := TGPStringFormat.Create(); + try + LGPStringFormat.SetAlignment(StringAlignmentCenter); + //LGPStringFormat.SetLineAlignment(TStringAlignment.StringAlignmentCenter); + LGPGraphics.DrawString(AChar, -1, LFont, LRect, LGPStringFormat, LBrush); + finally + LGPStringFormat.Free; + end; + finally + LBrush.Free; + end; + finally + LFont.Free; + end; + finally + LGPGraphics.Free; + end; +end; + +//var +// LogFont: TLogFont; +// AFont: HFONT; +// pOldFont: HGDIOBJ; +// LColorRef: COLORREF; +// OldMode: integer; +// uFormat: Cardinal; +//begin +// if FFontHandle = 0 then exit; +// +// ZeroMemory(@LogFont, SizeOf(LogFont)); +// LogFont.lfHeight := DestRect.Height; +// LogFont.lfWidth := 0; +// LogFont.lfEscapement := Orientation * 10; +// LogFont.lfOrientation := LogFont.lfEscapement; +// LogFont.lfWeight := FW_NORMAL; +// LogFont.lfItalic := 0; +// LogFont.lfUnderline := 0; +// LogFont.lfStrikeOut := 0; +// LogFont.lfCharSet := DEFAULT_CHARSET; +// LogFont.lfOutPrecision := OUT_OUTLINE_PRECIS;//OUT_STROKE_PRECIS; +// LogFont.lfClipPrecision := CLIP_DEFAULT_PRECIS; +// LogFont.lfQuality := FDefaultQuality; +// LogFont.lfPitchAndFamily := DEFAULT_PITCH; +// LogFont.lfFaceName := 'FontAwesome'; +// +// LColorRef := ColorToRGB(AColor); +// +// AFont := CreateFontIndirect(LogFont); +// if AFont <> 0 then +// try +// LColorRef := SetTextColor(DC, LColorRef); +// pOldFont := SelectObject(DC, AFont); +// try +// OldMode := SetBkMode(DC, TRANSPARENT); +// uFormat := DT_SINGLELINE; +// +// case ImageAlignment of +// iaLeft: uFormat := uFormat or DT_LEFT; +// iaRight: uFormat := uFormat or DT_RIGHT; +// iaCenter: uFormat := uFormat or DT_CENTER; +// iaTop: uFormat := uFormat or DT_TOP; +// iaBottom: uFormat := uFormat or DT_BOTTOM; +// end; +// +// uFormat := uFormat or DT_NOCLIP; +// +// Winapi.Windows.DrawText(DC, AChar, 1, DestRect, uFormat); +// SetBkMode(DC, OldMode); +// SelectObject(DC, LColorRef); +// finally +// if pOldFont <> 0 then +// SelectObject(DC, pOldFont); +// end; +// finally +// DeleteObject(AFont); +// end; +//end; + + +{$IFDEF WinXCtrls} +{ TFontAwesomeAnimated } +type + TCustomActivityIndicatorShadow = class(TCustomControl) + private + FAnimate: Boolean; + FIndicatorColor: TActivityIndicatorColor; + FIndicatorSize: TActivityIndicatorSize; + FIndicatorType: TActivityIndicatorType; + FFrameDelay: Word; + FFrameIndex: Integer; + FTimer: TTimer; + FFrameList: TImageList; + FFrameCount: Integer; + FFrameSize: Integer; + FFrameBitmap: TBitmap; + FLoadedFrames: Boolean; + end; + +procedure DrawParentImage(Control: TControl; DC: HDC; InvalidateParent: Boolean = False); +var + SaveIndex: Integer; + P: TPoint; +begin + if Control.Parent = nil then + Exit; + SaveIndex := SaveDC(DC); + GetViewportOrgEx(DC, P); + + SetViewportOrgEx(DC, P.X - Control.Left, P.Y - Control.Top, nil); + IntersectClipRect(DC, 0, 0, Control.Parent.ClientWidth, Control.Parent.ClientHeight); + + Control.Parent.Perform(WM_ERASEBKGND, DC, 0); + Control.Parent.Perform(WM_PRINTCLIENT, DC, prf_Client); + + RestoreDC(DC, SaveIndex); + + if InvalidateParent then + begin + if not (Control.Parent is TCustomControl) and not (Control.Parent is TCustomForm) and + not (csDesigning in Control.ComponentState) then + begin + Control.Parent.Invalidate; + end; + end; +end; + +constructor TFontAwesomeAnimated.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + FFontAwesomeCode := fa_spinner; + FColor := StyleServices.GetSystemColor(clBtnText); + FBackColor := StyleServices.GetSystemColor(clBtnFace); +end; + +procedure RotateBitmap(ABitmap: TBitmap; Degs: Integer; Resize: Boolean; ABackColor: TColor = clNone); +var + LGPBitmap: TGPBitmap; + LMatrix: TGPMatrix; + C, S: Single; + LSize: TSize; + LGPGraphics: TGPGraphics; +begin + LGPBitmap := TGPBitmap.Create(ABitmap.Handle, ABitmap.Palette); + try + LMatrix := TGPMatrix.Create; + try + LMatrix.RotateAt(Degs, MakePoint(0.5 * ABitmap.Width, 0.5 * ABitmap.Height)); + if Resize then + begin + C := Cos(DegToRad(Degs)); + S := Sin(DegToRad(Degs)); + LSize.cx := Round(ABitmap.Width * Abs(C) + ABitmap.Height * Abs(S)); + LSize.cy := Round(ABitmap.Width * Abs(S) + ABitmap.Height * Abs(C)); + ABitmap.Width := LSize.cx; + ABitmap.Height := LSize.cy; + end; + + LGPGraphics := TGPGraphics.Create(ABitmap.Canvas.Handle); + try + LGPGraphics.Clear(ColorRefToARGB(ColorToRGB(ABackColor))); + LGPGraphics.SetTransform(LMatrix); + LGPGraphics.DrawImage(LGPBitmap, (Cardinal(ABitmap.Width) - LGPBitmap.GetWidth) div 2, + (Cardinal(ABitmap.Height) - LGPBitmap.GetHeight) div 2); + finally + LGPGraphics.Free; + end; + + finally + LMatrix.Free; + end; + finally + LGPBitmap.Free; + end; +end; + +procedure TFontAwesomeAnimated.ReloadFrames; +var + i, LFrameSize, LAngleDelta, LAngle: Integer; + LBitmap: TBitmap; +begin + TCustomActivityIndicatorShadow(Self).FFrameSize := 48; + LFrameSize := TCustomActivityIndicatorShadow(Self).FFrameSize; + TCustomActivityIndicatorShadow(Self).FFrameCount := 24; //optimize + TCustomActivityIndicatorShadow(Self).FFrameBitmap.SetSize(LFrameSize, LFrameSize); + LAngleDelta := 360 div TCustomActivityIndicatorShadow(Self).FFrameCount; + + //TCustomActivityIndicatorShadow(Self).FFrameList.ColorDepth := cd24Bit; + TCustomActivityIndicatorShadow(Self).FFrameList.Width := LFrameSize; + TCustomActivityIndicatorShadow(Self).FFrameList.Height := LFrameSize; + + TCustomActivityIndicatorShadow(Self).FFrameList.Clear; + LAngle := 0; + for i := 0 to TCustomActivityIndicatorShadow(Self).FFrameCount - 1 do + begin + LBitmap := TBitmap.Create; + try + LBitmap.PixelFormat := pf32bit; + LBitmap.AlphaFormat := afDefined; + LBitmap.SetSize(LFrameSize, LFrameSize); + Bitmap32_SetAlphaAndColor(LBitmap, 0, FBackColor); + Bitmap32_SetAlpha(LBitmap, 0); + FontAwesome.DrawChar(LBitmap.Canvas.Handle, Char(FFontAwesomeCode), Rect(0, 0, LFrameSize, LFrameSize), FColor, 0, TImageAlignment.iaCenter); + if (LAngle > 0) then + RotateBitmap(LBitmap, LAngle, False, FBackColor); + Inc(LAngle, LAngleDelta); + TCustomActivityIndicatorShadow(Self).FFrameList.Add(LBitmap, nil); + finally + LBitmap.Free; + end; + end; + TCustomActivityIndicatorShadow(Self).FLoadedFrames := True; +end; + +procedure TFontAwesomeAnimated.Resize; +begin + SetBounds(Left, Top, TCustomActivityIndicatorShadow(Self).FFrameSize, TCustomActivityIndicatorShadow(Self).FFrameSize); +end; + +procedure TFontAwesomeAnimated.SetBackColor(const Value: TColor); +var + SaveAnimate: Boolean; +begin + if FBackColor <> Value then + begin + FBackColor := Value; + SaveAnimate := Animate; + Animate := False; + ReloadFrames; + Animate := SaveAnimate; + end; +end; + +procedure TFontAwesomeAnimated.SetColor(const Value: TColor); +var + SaveAnimate: Boolean; +begin + if FColor <> Value then + begin + FColor := Value; + SaveAnimate := Animate; + Animate := False; + ReloadFrames; + Animate := SaveAnimate; + end; +end; + +procedure TFontAwesomeAnimated.SetFontAwesomeCode(const Value: Word); +var + SaveAnimate: Boolean; +begin + if FFontAwesomeCode <> Value then + begin + FFontAwesomeCode := Value; + SaveAnimate := Animate; + Animate := False; + ReloadFrames; + Animate := SaveAnimate; + end; +end; +{$ENDIF} + +initialization + FontAwesome := TFontAwesome.Create; +finalization + FontAwesome.Free; +end. diff --git a/source/vcl-styles-utils/Vcl.Styles.FormStyleHooks.pas b/source/vcl-styles-utils/Vcl.Styles.FormStyleHooks.pas index f3390215f..8269395c7 100644 --- a/source/vcl-styles-utils/Vcl.Styles.FormStyleHooks.pas +++ b/source/vcl-styles-utils/Vcl.Styles.FormStyleHooks.pas @@ -1,1480 +1,1480 @@ -// ************************************************************************************************** -// -// Unit Vcl.Styles.FormStyleHooks -// unit for the VCL Styles Utils -// https://github.com/RRUZ/vcl-styles-utils/ -// -// 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. -// -// The Original Code is Vcl.Styles.FormStyleHooks.pas. -// -// The Initial Developer of the Original Code is Rodrigo Ruz V. -// Portions created by Rodrigo Ruz V. are Copyright (C) 2012-2019 Rodrigo Ruz V. -// All Rights Reserved. -// -// ************************************************************************************************** - -unit Vcl.Styles.FormStyleHooks; - -interface -{$IF RTLVersion>=24} - {$LEGACYIFEND ON} -{$IFEND} -uses - Winapi.Windows, - Winapi.Messages, - Vcl.Themes, - Vcl.Controls, - Vcl.ComCtrls, - Vcl.Graphics, - Vcl.Forms; - -type - /// Form Style hook to add image and/or color supoort for the background and non client area - /// - TFormStyleHookBackground = class(TFormStyleHook) - strict private - type - TSettings = class - strict private - FColor: TColor; - FImageLocation: string; - FBitmap: TBitmap; - FUseColor: Boolean; - FUseImage: Boolean; - FEnabled: Boolean; - FUseAlpha: Boolean; - FAlphaValue: Byte; - procedure SetColor(const Value: TColor); - procedure SetImageLocation(const Value: string); - procedure SetUseColor(const Value: Boolean); - procedure SetUseImage(const Value: Boolean); - public - property UseImage: Boolean read FUseImage write SetUseImage; - property UseColor: Boolean read FUseColor write SetUseColor; - property Color: TColor read FColor write SetColor; - property ImageLocation: string read FImageLocation write SetImageLocation; - property Bitmap: TBitmap read FBitmap; - property Enabled: Boolean read FEnabled write FEnabled; - property UseAlpha: Boolean read FUseAlpha write FUseAlpha; - property AlphaValue: Byte read FAlphaValue write FAlphaValue; - constructor Create; - destructor Destroy; override; - end; - class var FNCSettings: TSettings; - class var FBackGroundSettings: TSettings; - class var FMergeImages: Boolean; - class Var FSharedBitMap: TBitmap; - class var FSharedImageLocation: string; - class procedure SetSharedImageLocation(const Value: string); static; - protected - procedure PaintNC(Canvas: TCanvas); override; - procedure PaintBackground(Canvas: TCanvas); override; - class constructor Create; - class destructor Destroy; - public - class property SharedImageLocation: string read FSharedImageLocation - write SetSharedImageLocation; - class property SharedBitMap: TBitmap read FSharedBitMap write FSharedBitMap; - class property MergeImages: Boolean read FMergeImages write FMergeImages; - class property NCSettings: TSettings read FNCSettings; - class property BackGroundSettings: TSettings read FBackGroundSettings; - end; - - /// Form Style hook to disable vcl styles in the non client area - /// - TFormStyleHookNC = class(TMouseTrackControlStyleHook) - public - procedure PaintBackground(Canvas: TCanvas); override; - constructor Create(AControl: TWinControl); override; - end; - - /// Form Style hook to add support for the regions in the non client area - /// - TFormStyleHookRgn = class(TFormStyleHook) - private - procedure WMWindowPosChanging(var Message: TWMWindowPosChanging); - message WM_WINDOWPOSCHANGING; - protected - procedure PaintNC(Canvas: TCanvas); override; - end; - - TFormStyleHookHelper = class helper for TFormStyleHook - private - function GetFCloseButtonRect: TRect; - procedure SetFCloseButtonRect(const Value: TRect); - function GetFCaptionRect: TRect; - function GetFHelpButtonRect: TRect; - function GetFMaxButtonRect: TRect; - function GetFMinButtonRect: TRect; - function GetFSysMenuButtonRect: TRect; - procedure SetFCaptionRect(const Value: TRect); - procedure SetFHelpButtonRect(const Value: TRect); - procedure SetFMaxButtonRect(const Value: TRect); - procedure SetFMinButtonRect(const Value: TRect); - procedure SetFSysMenuButtonRect(const Value: TRect); - function GetFFormActive: Boolean; - function GetFWidth: Integer; - function GetFPressedButton: Integer; - function GetFHotButton: Integer; - function GetFHeight: Integer; - function GetFChangeSizeCalled: Boolean; - function GetFLeft: Integer; - function GetFTop: Integer; - procedure SetFLeft(const Value: Integer); - procedure SetFTop(const Value: Integer); - procedure SetFHeight(const Value: Integer); - procedure SetFWidth(const Value: Integer); - procedure SetFChangeSizeCalled(const Value: Boolean); - function GetFRegion: HRGN; - procedure SetFRegion(const Value: HRGN); - function GetForm: TCustomForm; - public - property _FCloseButtonRect: TRect read GetFCloseButtonRect - Write SetFCloseButtonRect; - property _FMaxButtonRect: TRect read GetFMaxButtonRect - Write SetFMaxButtonRect; - property _FMinButtonRect: TRect read GetFMinButtonRect - Write SetFMinButtonRect; - property _FHelpButtonRect: TRect read GetFHelpButtonRect - Write SetFHelpButtonRect; - property _FSysMenuButtonRect: TRect read GetFSysMenuButtonRect - Write SetFSysMenuButtonRect; - property _FCaptionRect: TRect read GetFCaptionRect Write SetFCaptionRect; - function _GetBorderSize: TRect; - property _FFormActive: Boolean read GetFFormActive; - property _FChangeSizeCalled: Boolean read GetFChangeSizeCalled - write SetFChangeSizeCalled; - property _FWidth: Integer read GetFWidth write SetFWidth; - property _FHeight: Integer read GetFHeight write SetFHeight; - property _FLeft: Integer read GetFLeft write SetFLeft; - property _FTop: Integer read GetFTop write SetFTop; - property _FPressedButton: Integer read GetFPressedButton; - property _FHotButton: Integer read GetFHotButton; - property _FRegion: HRGN read GetFRegion write SetFRegion; - property _Form: TCustomForm read GetForm; - procedure MainMenuBarHookPaint(Canvas: TCanvas); - function _GetIconFast: TIcon; - procedure _ChangeSize; - function _NormalizePoint(P: TPoint): TPoint; - function _GetHitTest(P: TPoint): Integer; - function _GetBorderSizeAddr: Pointer; - function _GetRegionAddr: Pointer; - end; - -function RectVCenter(var R: TRect; Bounds: TRect): TRect; - -implementation - -Uses - System.SysUtils, - System.Classes, - System.Types, - Winapi.UxTheme, - Vcl.Imaging.Jpeg, - Vcl.Imaging.pngimage, - Vcl.Imaging.GIFImg; - -type - TCustomFormClass = class(TCustomForm); - -function RectVCenter(var R: TRect; Bounds: TRect): TRect; -begin - OffsetRect(R, -R.Left, -R.Top); - OffsetRect(R, 0, (Bounds.Height - R.Height) div 2); - OffsetRect(R, Bounds.Left, Bounds.Top); - Result := R; -end; - -{ TFormStyleHookRgn } - -procedure TFormStyleHookRgn.WMWindowPosChanging(var Message - : TWMWindowPosChanging); -var - Changed: Boolean; - - function GetRegion: HRGN; - var - R: TRect; - Details: TThemedElementDetails; - Detail: TThemedWindow; - begin - Result := 0; - if not StyleServices.Available then - Exit; - - R := Rect(0, 0, _FWidth, _FHeight); - if (Form.BorderStyle <> bsToolWindow) and (Form.BorderStyle <> bsSizeToolWin) - then - Detail := twCaptionActive - else - Detail := twSmallCaptionActive; - Details := StyleServices.GetElementDetails(Detail); - StyleServices.GetElementRegion(Details, R, Result); - end; - - procedure ChangeSize; - var - TempRegion: HRGN; - FormhRgn: HRGN; - R: TRect; - begin - _FChangeSizeCalled := True; - - if IsIconic(Handle) then - begin - R := _GetBorderSize; - _FHeight := R.Top + R.Bottom; - end; - - if Form.BorderStyle <> bsNone then - begin - TempRegion := _FRegion; - try - _FRegion := GetRegion; - FormhRgn := 0; - GetWindowRgn(Handle, FormhRgn); - { - CombineRgn(FormhRgn, FormhRgn,_FRegion,RGN_OR); - SetWindowRgn(Handle, FormhRgn, True); - } - // SetWindowRgn(Handle, _FRegion, True); - finally - if TempRegion <> 0 then - DeleteObject(TempRegion); - end; - _FChangeSizeCalled := False; - end; - end; - -begin - CallDefaultProc(TMessage(Message)); - - Handled := True; - Changed := False; - - if _FChangeSizeCalled then - Exit; - - if (Message.WindowPos^.flags and SWP_NOSIZE = 0) or - (Message.WindowPos^.flags and SWP_NOMOVE = 0) then - begin - if (Message.WindowPos^.flags and SWP_NOMOVE = 0) then - begin - _FLeft := Message.WindowPos^.x; - _FTop := Message.WindowPos^.y; - end; - if (Message.WindowPos^.flags and SWP_NOSIZE = 0) then - begin - Changed := ((Message.WindowPos^.cx <> _FWidth) or - (Message.WindowPos^.cy <> _FHeight)) and - (Message.WindowPos^.flags and SWP_NOSIZE = 0); - _FWidth := Message.WindowPos^.cx; - _FHeight := Message.WindowPos^.cy; - end; - end; - - if Changed then - begin - ChangeSize; - if Form.BorderStyle <> bsNone then - InvalidateNC; - end; -end; - -procedure TFormStyleHookRgn.PaintNC(Canvas: TCanvas); -var - Details, CaptionDetails, IconDetails: TThemedElementDetails; - Detail: TThemedWindow; - R, R1, DrawRect, ButtonRect, TextRect: TRect; - CaptionBuffer: TBitmap; - FButtonState: TThemedWindow; - TextFormat: TTextFormat; - LText: string; -begin - - if Form.BorderStyle = bsNone then - begin - MainMenuBarHookPaint(Canvas); - Exit; - end; - - { init some parameters } - _FCloseButtonRect := Rect(0, 0, 0, 0); - _FMaxButtonRect := Rect(0, 0, 0, 0); - _FMinButtonRect := Rect(0, 0, 0, 0); - _FHelpButtonRect := Rect(0, 0, 0, 0); - _FSysMenuButtonRect := Rect(0, 0, 0, 0); - _FCaptionRect := Rect(0, 0, 0, 0); - - if not StyleServices.Available then - Exit; - R := _GetBorderSize; - - { draw caption } - - if (Form.BorderStyle <> bsToolWindow) and (Form.BorderStyle <> bsSizeToolWin) - then - begin - if _FFormActive then - Detail := twCaptionActive - else - Detail := twCaptionInActive - end - else - begin - if _FFormActive then - Detail := twSmallCaptionActive - else - Detail := twSmallCaptionInActive - end; - CaptionBuffer := TBitmap.Create; - CaptionBuffer.SetSize(_FWidth, R.Top); - - { draw caption border } - DrawRect := Rect(0, 0, CaptionBuffer.Width, CaptionBuffer.Height); - Details := StyleServices.GetElementDetails(Detail); - StyleServices.DrawElement(CaptionBuffer.Canvas.Handle, Details, DrawRect); - TextRect := DrawRect; - CaptionDetails := Details; - - { draw icon } - if (biSystemMenu in TCustomFormClass(Form).BorderIcons) and - (Form.BorderStyle <> bsDialog) and (Form.BorderStyle <> bsToolWindow) and - (Form.BorderStyle <> bsSizeToolWin) then - begin - IconDetails := StyleServices.GetElementDetails(twSysButtonNormal); - if not StyleServices.GetElementContentRect(0, IconDetails, DrawRect, - ButtonRect) then - ButtonRect := Rect(0, 0, 0, 0); - R1 := Rect(0, 0, GetSystemMetrics(SM_CXSMICON), - GetSystemMetrics(SM_CYSMICON)); - RectVCenter(R1, ButtonRect); - if ButtonRect.Width > 0 then - DrawIconEx(CaptionBuffer.Canvas.Handle, R1.Left, R1.Top, - _GetIconFast.Handle, 0, 0, 0, 0, DI_NORMAL); - Inc(TextRect.Left, ButtonRect.Width + 5); - _FSysMenuButtonRect := ButtonRect; - end - else - Inc(TextRect.Left, R.Left); - - { draw buttons } - if (biSystemMenu in TCustomFormClass(Form).BorderIcons) then - begin - if (Form.BorderStyle <> bsToolWindow) and (Form.BorderStyle <> bsSizeToolWin) - then - begin - if (_FPressedButton = HTCLOSE) and (_FHotButton = HTCLOSE) then - FButtonState := twCloseButtonPushed - else if _FHotButton = HTCLOSE then - FButtonState := twCloseButtonHot - else if _FFormActive then - FButtonState := twCloseButtonNormal - else - FButtonState := twCloseButtonDisabled; - end - else - begin - if (_FPressedButton = HTCLOSE) and (_FHotButton = HTCLOSE) then - FButtonState := twSmallCloseButtonPushed - else if _FHotButton = HTCLOSE then - FButtonState := twSmallCloseButtonHot - else if _FFormActive then - FButtonState := twSmallCloseButtonNormal - else - FButtonState := twSmallCloseButtonDisabled; - end; - - Details := StyleServices.GetElementDetails(FButtonState); - if not StyleServices.GetElementContentRect(0, Details, DrawRect, ButtonRect) - then - ButtonRect := Rect(0, 0, 0, 0); - - StyleServices.DrawElement(CaptionBuffer.Canvas.Handle, Details, ButtonRect); - if ButtonRect.Left > 0 then - TextRect.Right := ButtonRect.Left; - _FCloseButtonRect := ButtonRect; - end; - - if (biMaximize in TCustomFormClass(Form).BorderIcons) and - (biSystemMenu in TCustomFormClass(Form).BorderIcons) and - (Form.BorderStyle <> bsDialog) and (Form.BorderStyle <> bsToolWindow) and - (Form.BorderStyle <> bsSizeToolWin) then - begin - if Form.WindowState = wsMaximized then - begin - if (_FPressedButton = HTMAXBUTTON) and (_FHotButton = HTMAXBUTTON) then - FButtonState := twRestoreButtonPushed - else if _FHotButton = HTMAXBUTTON then - FButtonState := twRestoreButtonHot - else if _FFormActive then - FButtonState := twRestoreButtonNormal - else - FButtonState := twRestoreButtonDisabled; - end - else - begin - if (_FPressedButton = HTMAXBUTTON) and (_FHotButton = HTMAXBUTTON) then - FButtonState := twMaxButtonPushed - else if _FHotButton = HTMAXBUTTON then - FButtonState := twMaxButtonHot - else if _FFormActive then - FButtonState := twMaxButtonNormal - else - FButtonState := twMaxButtonDisabled; - end; - Details := StyleServices.GetElementDetails(FButtonState); - - if not StyleServices.GetElementContentRect(0, Details, DrawRect, ButtonRect) - then - ButtonRect := Rect(0, 0, 0, 0); - if ButtonRect.Width > 0 then - StyleServices.DrawElement(CaptionBuffer.Canvas.Handle, Details, - ButtonRect); - if ButtonRect.Left > 0 then - TextRect.Right := ButtonRect.Left; - _FMaxButtonRect := ButtonRect; - end; - - if (biMinimize in TCustomFormClass(Form).BorderIcons) and - (biSystemMenu in TCustomFormClass(Form).BorderIcons) and - (Form.BorderStyle <> bsDialog) and (Form.BorderStyle <> bsToolWindow) and - (Form.BorderStyle <> bsSizeToolWin) then - begin - if (_FPressedButton = HTMINBUTTON) and (_FHotButton = HTMINBUTTON) then - FButtonState := twMinButtonPushed - else if _FHotButton = HTMINBUTTON then - FButtonState := twMinButtonHot - else if _FFormActive then - FButtonState := twMinButtonNormal - else - FButtonState := twMinButtonDisabled; - - Details := StyleServices.GetElementDetails(FButtonState); - - if not StyleServices.GetElementContentRect(0, Details, DrawRect, ButtonRect) - then - ButtonRect := Rect(0, 0, 0, 0); - if ButtonRect.Width > 0 then - StyleServices.DrawElement(CaptionBuffer.Canvas.Handle, Details, - ButtonRect); - if ButtonRect.Left > 0 then - TextRect.Right := ButtonRect.Left; - _FMinButtonRect := ButtonRect; - end; - - if (biHelp in TCustomFormClass(Form).BorderIcons) and - (biSystemMenu in TCustomFormClass(Form).BorderIcons) and - ((not(biMaximize in TCustomFormClass(Form).BorderIcons) and - not(biMinimize in TCustomFormClass(Form).BorderIcons)) or - (Form.BorderStyle = bsDialog)) then - begin - if (_FPressedButton = HTHELP) and (_FHotButton = HTHELP) then - FButtonState := twHelpButtonPushed - else if _FHotButton = HTHELP then - FButtonState := twHelpButtonHot - else if _FFormActive then - FButtonState := twHelpButtonNormal - else - FButtonState := twHelpButtonDisabled; - Details := StyleServices.GetElementDetails(FButtonState); - - if not StyleServices.GetElementContentRect(0, Details, DrawRect, ButtonRect) - then - ButtonRect := Rect(0, 0, 0, 0); - if ButtonRect.Width > 0 then - StyleServices.DrawElement(CaptionBuffer.Canvas.Handle, Details, - ButtonRect); - - if ButtonRect.Left > 0 then - TextRect.Right := ButtonRect.Left; - _FHelpButtonRect := ButtonRect; - end; - - { draw text } - TextFormat := [tfLeft, tfSingleLine, tfVerticalCenter]; - if Control.UseRightToLeftReading then - Include(TextFormat, tfRtlReading); - // Important: Must retrieve Text prior to calling DrawText as it causes - // CaptionBuffer.Canvas to free its handle, making the outcome of the call - // to DrawText dependent on parameter evaluation order. - LText := Text; - StyleServices.DrawText(CaptionBuffer.Canvas.Handle, CaptionDetails, LText, - TextRect, TextFormat); - _FCaptionRect := TextRect; - - { draw caption buffer } - - Canvas.Draw(0, 0, CaptionBuffer); - CaptionBuffer.Free; - - { draw menubar } - MainMenuBarHookPaint(Canvas); - - { draw left border } - - if (Form.BorderStyle <> bsToolWindow) and (Form.BorderStyle <> bsSizeToolWin) - then - begin - if _FFormActive then - Detail := twFrameLeftActive - else - Detail := twFrameLeftInActive - end - else - begin - if _FFormActive then - Detail := twSmallFrameLeftActive - else - Detail := twSmallFrameLeftInActive - end; - DrawRect := Rect(0, R.Top, R.Left, _FHeight - R.Bottom); - Details := StyleServices.GetElementDetails(Detail); - - if DrawRect.Bottom - DrawRect.Top > 0 then - StyleServices.DrawElement(Canvas.Handle, Details, DrawRect); - - { draw right border } - if (Form.BorderStyle <> bsToolWindow) and (Form.BorderStyle <> bsSizeToolWin) - then - begin - if _FFormActive then - Detail := twFrameRightActive - else - Detail := twFrameRightInActive - end - else - begin - if _FFormActive then - Detail := twSmallFrameRightActive - else - Detail := twSmallFrameRightInActive - end; - DrawRect := Rect(_FWidth - R.Right, R.Top, _FWidth, _FHeight - R.Bottom); - Details := StyleServices.GetElementDetails(Detail); - - if DrawRect.Bottom - DrawRect.Top > 0 then - StyleServices.DrawElement(Canvas.Handle, Details, DrawRect); - - { draw Bottom border } - if (Form.BorderStyle <> bsToolWindow) and (Form.BorderStyle <> bsSizeToolWin) - then - begin - if _FFormActive then - Detail := twFrameBottomActive - else - Detail := twFrameBottomInActive - end - else - begin - if _FFormActive then - Detail := twSmallFrameBottomActive - else - Detail := twSmallFrameBottomInActive - end; - DrawRect := Rect(0, _FHeight - R.Bottom, _FWidth, _FHeight); - Details := StyleServices.GetElementDetails(Detail); - - if DrawRect.Bottom - DrawRect.Top > 0 then - StyleServices.DrawElement(Canvas.Handle, Details, DrawRect); -end; - -{ TFormStyleHookBackround.TSettings } - -constructor TFormStyleHookBackground.TSettings.Create; -begin - inherited; - FUseAlpha := False; - FAlphaValue := 200; - FEnabled := False; - FBitmap := TBitmap.Create; - ImageLocation := ''; - UseImage := False; -end; - -destructor TFormStyleHookBackground.TSettings.Destroy; -begin - FBitmap.Free; - inherited; -end; - -procedure TFormStyleHookBackground.TSettings.SetColor(const Value: TColor); -begin - if Value <> FColor then - FColor := Value; -end; - -procedure TFormStyleHookBackground.TSettings.SetImageLocation - (const Value: string); -var - Picture: TPicture; -begin - FImageLocation := Value; - if FileExists(Value) then - begin - Picture := TPicture.Create; - try - Picture.LoadFromFile(Value); - FBitmap.Width := Picture.Width; - FBitmap.Height := Picture.Height; - FBitmap.Canvas.Draw(0, 0, Picture.Graphic); - finally - Picture.Free; - end; - end; -end; - -procedure TFormStyleHookBackground.TSettings.SetUseColor(const Value: Boolean); -begin - FUseColor := Value; - FUseImage := not Value; -end; - -procedure TFormStyleHookBackground.TSettings.SetUseImage(const Value: Boolean); -begin - FUseImage := Value; - FUseColor := not Value; -end; - -{ TFormStyleHookBackround } - -class constructor TFormStyleHookBackground.Create; -begin - FMergeImages := False; - FSharedBitMap := TBitmap.Create; - FNCSettings := TFormStyleHookBackground.TSettings.Create; - FBackGroundSettings := TFormStyleHookBackground.TSettings.Create; -end; - -class destructor TFormStyleHookBackground.Destroy; -begin - FreeAndNil(FSharedBitMap); - FreeAndNil(FNCSettings); - FreeAndNil(FBackGroundSettings); -end; - -class procedure TFormStyleHookBackground.SetSharedImageLocation - (const Value: string); -var - Picture: TPicture; -begin - FSharedImageLocation := Value; - if FileExists(Value) then - begin - Picture := TPicture.Create; - try - Picture.LoadFromFile(Value); - FSharedBitMap.Width := Picture.Width; - FSharedBitMap.Height := Picture.Height; - FSharedBitMap.Canvas.Draw(0, 0, Picture.Graphic); - finally - Picture.Free; - end; - end; -end; - -procedure TFormStyleHookBackground.PaintBackground(Canvas: TCanvas); -var - LRect: TRect; - RBitmap: TRect; - L, H: Integer; -begin - // if the option is not enabled use the default inherited PaintBackground method - if not BackGroundSettings.Enabled then - inherited - else - begin - // get he bounds of the control (form) - LRect := Rect(0, 0, Control.ClientWidth, Control.ClientHeight); - // use a custom color for the background? - if BackGroundSettings.UseColor then - begin - Canvas.Brush.Color := BackGroundSettings.Color; - Canvas.FillRect(LRect); - end - else - // use a bitmap - begin - // check the size of the bitmap against the control bounds to detrine how the bitmap is drawn - if not FMergeImages and ((BackGroundSettings.Bitmap.Width < LRect.Width) - or (BackGroundSettings.Bitmap.Height < LRect.Height)) then - begin - Canvas.Brush.Bitmap := BackGroundSettings.Bitmap; - Canvas.FillRect(LRect); - end - else - begin - // check if the the background bitmap must be merged with non client area bitmap - if not FMergeImages then - Canvas.CopyRect(LRect, BackGroundSettings.Bitmap.Canvas, LRect) - else - begin - RBitmap := LRect; - H := _GetBorderSize.Top; - L := _GetBorderSize.Left; - RBitmap.SetLocation(L, H); - // Canvas.CopyRect(LRect,BackGroundSettings.Bitmap.Canvas,RBitmap); - Canvas.CopyRect(LRect, FSharedBitMap.Canvas, RBitmap); - end; - end; - end; - end; -end; - -procedure TFormStyleHookBackground.PaintNC(Canvas: TCanvas); -var - LDetail: TThemedWindow; - LDetails, CaptionDetails, IconDetails: TThemedElementDetails; - R, R1, DrawRect, ButtonRect, TextRect: TRect; - LBitmap: TBitmap; - FButtonState: TThemedWindow; - TextFormat: TTextFormat; - LText: string; - SrcBackRect: TRect; - - pblend: TBlendFunction; - LBitmapPos: TPoint; - LBitmapSize: TSize; - LExStyle: DWORD; -{$IF CompilerVersion>23} - TextTopOffset: Integer; -{$IFEND} - function GetTopOffset: Integer; - var - P: TPoint; - begin - P.x := Form.Left + Form.Width div 2; - P.y := Form.Top + Form.Height div 2; - Result := Screen.MonitorFromPoint(P).WorkareaRect.Top; - if Form.Top < Result then - Result := Result - Form.Top - else - Result := 0; - end; - - procedure CorrectLeftButtonRect(var AButtonRect: TRect); - var - TopOffset, LeftOffset: Integer; - BS: TRect; - begin - if (Form.WindowState = wsMaximized) and - (TCustomFormClass(Form).FormStyle <> fsMDIChild) and (ButtonRect.Width > 0) - then - begin - BS := _GetBorderSize; - TopOffset := GetTopOffset; - LeftOffset := BS.Left; - if ButtonRect.Top < TopOffset then - begin - TopOffset := TopOffset - ButtonRect.Top; - OffsetRect(ButtonRect, LeftOffset, TopOffset); - TopOffset := ButtonRect.Bottom - BS.Top; - if TopOffset > 0 then - OffsetRect(ButtonRect, 0, -TopOffset); - end; - end; - end; - - procedure CorrectRightButtonRect(var AButtonRect: TRect); - var - TopOffset, RightOffset: Integer; - BS: TRect; - begin - if (Form.WindowState = wsMaximized) and - (TCustomFormClass(Form).FormStyle <> fsMDIChild) and (ButtonRect.Width > 0) - then - begin - BS := _GetBorderSize; - TopOffset := GetTopOffset; - RightOffset := -BS.Right; - if ButtonRect.Top < TopOffset then - begin - TopOffset := TopOffset - ButtonRect.Top; - OffsetRect(ButtonRect, RightOffset, TopOffset); - TopOffset := ButtonRect.Bottom - BS.Top; - if TopOffset > 0 then - OffsetRect(ButtonRect, 0, -TopOffset); - end; - end; - end; - -begin - // if the setting is not enabled use the original PaintNC method - if not NCSettings.Enabled then - begin - inherited; - Exit; - end; - - // check the border style of the form - if Form.BorderStyle = bsNone then - begin - MainMenuBarHookPaint(Canvas); - Exit; - end; - - { init some parameters } - _FCloseButtonRect := Rect(0, 0, 0, 0); - _FMaxButtonRect := Rect(0, 0, 0, 0); - _FMinButtonRect := Rect(0, 0, 0, 0); - _FHelpButtonRect := Rect(0, 0, 0, 0); - _FSysMenuButtonRect := Rect(0, 0, 0, 0); - _FCaptionRect := Rect(0, 0, 0, 0); - - if not StyleServices.Available then - Exit; - R := _GetBorderSize; - - { draw caption } - if (Form.BorderStyle <> bsToolWindow) and (Form.BorderStyle <> bsSizeToolWin) - then - begin - if _FFormActive then - LDetail := twCaptionActive - else - LDetail := twCaptionInActive - end - else - begin - if _FFormActive then - LDetail := twSmallCaptionActive - else - LDetail := twSmallCaptionInActive - end; - - LBitmap := TBitmap.Create; - if FNCSettings.UseAlpha then - LBitmap.SetSize(_FWidth, _FHeight) - else - LBitmap.SetSize(_FWidth, R.Top); - - { draw caption border } - DrawRect := Rect(0, 0, LBitmap.Width, LBitmap.Height); - LDetails := StyleServices.GetElementDetails(LDetail); - // used for draw text in the caption -{$IF CompilerVersion>23} - TextTopOffset := 3; -{$IFEND} - // check if a must use a custom color or a bitmap - if FNCSettings.UseColor then - begin - if FNCSettings.UseAlpha then - begin - LExStyle := GetWindowLongA(Handle, GWL_EXSTYLE); - if (LExStyle and WS_EX_LAYERED = 0) then - SetWindowLong(Handle, GWL_EXSTYLE, LExStyle or WS_EX_LAYERED); - - LBitmap.PixelFormat := pf32bit; - LBitmap.Canvas.Brush.Color := FNCSettings.Color; - LBitmap.Canvas.FillRect(DrawRect); - LBitmapPos := Point(0, 0); - LBitmapSize.cx := LBitmap.Width; - LBitmapSize.cy := LBitmap.Height; - pblend.BlendOp := AC_SRC_OVER; - pblend.BlendFlags := 0; - pblend.SourceConstantAlpha := FNCSettings.AlphaValue; - pblend.AlphaFormat := 0; - end - else - begin - // use the select color to fill the background of the canvas - LBitmap.Canvas.Brush.Color := FNCSettings.Color; - LBitmap.Canvas.FillRect(DrawRect); - end; - - end - else - begin - // use the bitmap to fill the canvas - SrcBackRect.Left := 0; - SrcBackRect.Top := 0; - SrcBackRect.Width := DrawRect.Width; - SrcBackRect.Height := DrawRect.Height; - // SrcBackRect.SetLocation(FNCSettings.Bitmap.Width-DrawRect.Width, 0); - // SrcBackRect.SetLocation(_GetBorderSize.Width, 0); - if not FMergeImages then - LBitmap.Canvas.CopyRect(DrawRect, FNCSettings.Bitmap.Canvas, SrcBackRect) - else - LBitmap.Canvas.CopyRect(DrawRect, FSharedBitMap.Canvas, SrcBackRect) - end; - - TextRect := DrawRect; - CaptionDetails := LDetails; - - { draw icon } - if (biSystemMenu in TCustomFormClass(Form).BorderIcons) and - (Form.BorderStyle <> bsDialog) and (Form.BorderStyle <> bsToolWindow) and - (Form.BorderStyle <> bsSizeToolWin) then - begin - IconDetails := StyleServices.GetElementDetails(twSysButtonNormal); - if not StyleServices.GetElementContentRect(0, IconDetails, DrawRect, - ButtonRect) then - ButtonRect := Rect(0, 0, 0, 0); - -{$IF CompilerVersion > 23.0} - R1 := ButtonRect; - if not StyleServices.HasElementFixedPosition(LDetails) then - begin - CorrectLeftButtonRect(ButtonRect); - TextTopOffset := Abs(R1.Top - ButtonRect.Top); - if TextTopOffset > R.Top then - TextTopOffset := 3; - end - else - TextTopOffset := 0; -{$IFEND} - R1 := Rect(0, 0, GetSystemMetrics(SM_CXSMICON), - GetSystemMetrics(SM_CYSMICON)); - RectVCenter(R1, ButtonRect); - if ButtonRect.Width > 0 then - DrawIconEx(LBitmap.Canvas.Handle, R1.Left, R1.Top, _GetIconFast.Handle, 0, - 0, 0, 0, DI_NORMAL); - Inc(TextRect.Left, ButtonRect.Width + 5); - _FSysMenuButtonRect := ButtonRect; - end - else - Inc(TextRect.Left, R.Left); - - { draw buttons } - if (biSystemMenu in TCustomFormClass(Form).BorderIcons) then - begin - if (Form.BorderStyle <> bsToolWindow) and (Form.BorderStyle <> bsSizeToolWin) - then - begin - if (_FPressedButton = HTCLOSE) and (_FHotButton = HTCLOSE) then - FButtonState := twCloseButtonPushed - else if _FHotButton = HTCLOSE then - FButtonState := twCloseButtonHot - else if _FFormActive then - FButtonState := twCloseButtonNormal - else - FButtonState := twCloseButtonDisabled; - end - else - begin - if (_FPressedButton = HTCLOSE) and (_FHotButton = HTCLOSE) then - FButtonState := twSmallCloseButtonPushed - else if _FHotButton = HTCLOSE then - FButtonState := twSmallCloseButtonHot - else if _FFormActive then - FButtonState := twSmallCloseButtonNormal - else - FButtonState := twSmallCloseButtonDisabled; - end; - - LDetails := StyleServices.GetElementDetails(FButtonState); - if not StyleServices.GetElementContentRect(0, LDetails, DrawRect, ButtonRect) - then - ButtonRect := Rect(0, 0, 0, 0); - -{$IF CompilerVersion > 23.0} - if not StyleServices.HasElementFixedPosition(LDetails) then - CorrectRightButtonRect(ButtonRect); -{$IFEND} - StyleServices.DrawElement(LBitmap.Canvas.Handle, LDetails, ButtonRect); - - if ButtonRect.Left > 0 then - TextRect.Right := ButtonRect.Left; - _FCloseButtonRect := ButtonRect; - end; - - if (biMaximize in TCustomFormClass(Form).BorderIcons) and - (biSystemMenu in TCustomFormClass(Form).BorderIcons) and - (Form.BorderStyle <> bsDialog) and (Form.BorderStyle <> bsToolWindow) and - (Form.BorderStyle <> bsSizeToolWin) then - begin - if Form.WindowState = wsMaximized then - begin - if (_FPressedButton = HTMAXBUTTON) and (_FHotButton = HTMAXBUTTON) then - FButtonState := twRestoreButtonPushed - else if _FHotButton = HTMAXBUTTON then - FButtonState := twRestoreButtonHot - else if _FFormActive then - FButtonState := twRestoreButtonNormal - else - FButtonState := twRestoreButtonDisabled; - end - else - begin - if (_FPressedButton = HTMAXBUTTON) and (_FHotButton = HTMAXBUTTON) then - FButtonState := twMaxButtonPushed - else if _FHotButton = HTMAXBUTTON then - FButtonState := twMaxButtonHot - else if _FFormActive then - FButtonState := twMaxButtonNormal - else - FButtonState := twMaxButtonDisabled; - end; - LDetails := StyleServices.GetElementDetails(FButtonState); - - if not StyleServices.GetElementContentRect(0, LDetails, DrawRect, ButtonRect) - then - ButtonRect := Rect(0, 0, 0, 0); - -{$IF CompilerVersion > 23.0} - if not StyleServices.HasElementFixedPosition(LDetails) then - CorrectRightButtonRect(ButtonRect); -{$IFEND} - if ButtonRect.Width > 0 then - StyleServices.DrawElement(LBitmap.Canvas.Handle, LDetails, ButtonRect); - if ButtonRect.Left > 0 then - TextRect.Right := ButtonRect.Left; - _FMaxButtonRect := ButtonRect; - end; - - if (biMinimize in TCustomFormClass(Form).BorderIcons) and - (biSystemMenu in TCustomFormClass(Form).BorderIcons) and - (Form.BorderStyle <> bsDialog) and (Form.BorderStyle <> bsToolWindow) and - (Form.BorderStyle <> bsSizeToolWin) then - begin - if (_FPressedButton = HTMINBUTTON) and (_FHotButton = HTMINBUTTON) then - FButtonState := twMinButtonPushed - else if _FHotButton = HTMINBUTTON then - FButtonState := twMinButtonHot - else if _FFormActive then - FButtonState := twMinButtonNormal - else - FButtonState := twMinButtonDisabled; - - LDetails := StyleServices.GetElementDetails(FButtonState); - - if not StyleServices.GetElementContentRect(0, LDetails, DrawRect, ButtonRect) - then - ButtonRect := Rect(0, 0, 0, 0); - -{$IF CompilerVersion > 23.0} - if not StyleServices.HasElementFixedPosition(LDetails) then - CorrectRightButtonRect(ButtonRect); -{$IFEND} - if ButtonRect.Width > 0 then - StyleServices.DrawElement(LBitmap.Canvas.Handle, LDetails, ButtonRect); - if ButtonRect.Left > 0 then - TextRect.Right := ButtonRect.Left; - _FMinButtonRect := ButtonRect; - end; - - if (biHelp in TCustomFormClass(Form).BorderIcons) and - (biSystemMenu in TCustomFormClass(Form).BorderIcons) and - ((not(biMaximize in TCustomFormClass(Form).BorderIcons) and - not(biMinimize in TCustomFormClass(Form).BorderIcons)) or - (Form.BorderStyle = bsDialog)) then - begin - if (_FPressedButton = HTHELP) and (_FHotButton = HTHELP) then - FButtonState := twHelpButtonPushed - else if _FHotButton = HTHELP then - FButtonState := twHelpButtonHot - else if _FFormActive then - FButtonState := twHelpButtonNormal - else - FButtonState := twHelpButtonDisabled; - LDetails := StyleServices.GetElementDetails(FButtonState); - - if not StyleServices.GetElementContentRect(0, LDetails, DrawRect, ButtonRect) - then - ButtonRect := Rect(0, 0, 0, 0); - -{$IF CompilerVersion > 23.0} - if not StyleServices.HasElementFixedPosition(LDetails) then - CorrectRightButtonRect(ButtonRect); -{$IFEND} - if ButtonRect.Width > 0 then - StyleServices.DrawElement(LBitmap.Canvas.Handle, LDetails, ButtonRect); - - if ButtonRect.Left > 0 then - TextRect.Right := ButtonRect.Left; - _FHelpButtonRect := ButtonRect; - end; - - { draw text } - TextFormat := [tfLeft, tfSingleLine, tfVerticalCenter]; - if Control.UseRightToLeftReading then - Include(TextFormat, tfRtlReading); - - LText := Text; - -{$IF CompilerVersion > 23.0} - if (Form.WindowState = wsMaximized) and - (TCustomFormClass(Form).FormStyle <> fsMDIChild) and (TextTopOffset <> 0) - and (biSystemMenu in TCustomFormClass(Form).BorderIcons) then - begin - Inc(TextRect.Left, R.Left); - MoveWindowOrg(LBitmap.Canvas.Handle, 0, TextTopOffset); - StyleServices.DrawText(LBitmap.Canvas.Handle, CaptionDetails, LText, - TextRect, TextFormat); - MoveWindowOrg(LBitmap.Canvas.Handle, 0, -TextTopOffset); - end - else -{$IFEND} - StyleServices.DrawText(LBitmap.Canvas.Handle, CaptionDetails, LText, - TextRect, TextFormat); - _FCaptionRect := TextRect; - - { draw caption buffer } - - if FNCSettings.UseAlpha then - UpdateLayeredWindow(Handle, 0, nil, @LBitmapSize, LBitmap.Canvas.Handle, - @LBitmapPos, 0, @pblend, ULW_ALPHA) - else - Canvas.Draw(0, 0, LBitmap); - - // LBitmap.Free; - { draw menubar } - MainMenuBarHookPaint(Canvas); // doesn't suport alpha for now :( - - { draw left border } - DrawRect := Rect(0, R.Top, R.Left, _FHeight - R.Bottom); - if DrawRect.Bottom - DrawRect.Top > 0 then - // use a color? - if FNCSettings.UseColor then - begin - if FNCSettings.UseAlpha then - begin - LBitmap.Canvas.Brush.Color := FNCSettings.Color; - LBitmap.Canvas.FillRect(DrawRect); - end - else - Begin - Canvas.Brush.Color := FNCSettings.Color; - Canvas.FillRect(DrawRect); - End; - end - else - begin - if FMergeImages then - if (DrawRect.Height <= FSharedBitMap.Height) and - (DrawRect.Width <= FSharedBitMap.Width) then - Canvas.CopyRect(DrawRect, FSharedBitMap.Canvas, DrawRect) - else - Canvas.StretchDraw(DrawRect, FSharedBitMap) - else if (DrawRect.Height <= FNCSettings.Bitmap.Height) and - (DrawRect.Width <= FNCSettings.Bitmap.Width) then - Canvas.CopyRect(DrawRect, FNCSettings.Bitmap.Canvas, DrawRect) - else - Canvas.StretchDraw(DrawRect, FNCSettings.Bitmap); - - end; - - { draw right border } - DrawRect := Rect(_FWidth - R.Right, R.Top, _FWidth, _FHeight - R.Bottom); - - if DrawRect.Bottom - DrawRect.Top > 0 then - // use a color? - if FNCSettings.UseColor then - begin - Canvas.Brush.Color := FNCSettings.Color; - Canvas.FillRect(DrawRect); - end - else - begin - if FMergeImages then - if (DrawRect.Height <= FSharedBitMap.Height) and - (Control.Width <= FSharedBitMap.Width) then - Canvas.CopyRect(DrawRect, FSharedBitMap.Canvas, DrawRect) - else - Canvas.StretchDraw(DrawRect, FSharedBitMap) - else if (DrawRect.Height <= FNCSettings.Bitmap.Height) and - (Control.Width <= FNCSettings.Bitmap.Width) then - Canvas.CopyRect(DrawRect, FNCSettings.Bitmap.Canvas, DrawRect) - else - Canvas.StretchDraw(DrawRect, FNCSettings.Bitmap); - end; - - { draw Bottom border } - DrawRect := Rect(0, _FHeight - R.Bottom, _FWidth, _FHeight); - - if DrawRect.Bottom - DrawRect.Top > 0 then - // use a color? - if FNCSettings.UseColor then - begin - Canvas.Brush.Color := FNCSettings.Color; - Canvas.FillRect(DrawRect); - end - else - begin - if FMergeImages then - if (DrawRect.Height <= FSharedBitMap.Height) and - (Control.Width <= FSharedBitMap.Width) then - Canvas.CopyRect(DrawRect, FSharedBitMap.Canvas, DrawRect) - else - begin - SrcBackRect.Left := 0; - SrcBackRect.Top := 0; - SrcBackRect.Width := DrawRect.Width; - SrcBackRect.Height := DrawRect.Height; - SrcBackRect.SetLocation(FSharedBitMap.Width - DrawRect.Width, 0); - Canvas.CopyRect(DrawRect, FSharedBitMap.Canvas, SrcBackRect); - end - else if (DrawRect.Height <= FNCSettings.Bitmap.Height) and - (Control.Width <= FNCSettings.Bitmap.Width) then - Canvas.CopyRect(DrawRect, FNCSettings.Bitmap.Canvas, DrawRect) - else - begin - SrcBackRect.Left := 0; - SrcBackRect.Top := 0; - SrcBackRect.Width := DrawRect.Width; - SrcBackRect.Height := DrawRect.Height; - SrcBackRect.SetLocation(FNCSettings.Bitmap.Width - DrawRect.Width, 0); - Canvas.CopyRect(DrawRect, FNCSettings.Bitmap.Canvas, SrcBackRect); - end; - end; - - LBitmap.Free; -end; - -{ TFormStyleHookNC } - -constructor TFormStyleHookNC.Create(AControl: TWinControl); -begin - inherited; - OverrideEraseBkgnd := True; -end; - -procedure TFormStyleHookNC.PaintBackground(Canvas: TCanvas); -var - Details: TThemedElementDetails; - R: TRect; -begin - if StyleServices.Available then - begin - Details.Element := teWindow; - Details.Part := 0; - R := Rect(0, 0, Control.ClientWidth, Control.ClientHeight); - StyleServices.DrawElement(Canvas.Handle, Details, R); - end; -end; - -{ TFormStyleHookHelper } - -function TFormStyleHookHelper.GetFCaptionRect: TRect; -begin - with Self do - Result := FCaptionRect; -end; - -function TFormStyleHookHelper.GetFChangeSizeCalled: Boolean; -begin - with Self do - Result := FChangeSizeCalled; -end; - -function TFormStyleHookHelper.GetFCloseButtonRect: TRect; -begin - with Self do - Result := FCloseButtonRect; -end; - -function TFormStyleHookHelper.GetFFormActive: Boolean; -begin - with Self do - Result := FFormActive; -end; - -function TFormStyleHookHelper.GetFHeight: Integer; -begin - with Self do - Result := FHeight; -end; - -function TFormStyleHookHelper.GetFHelpButtonRect: TRect; -begin - with Self do - Result := FHelpButtonRect; -end; - -function TFormStyleHookHelper.GetFHotButton: Integer; -begin - with Self do - Result := FHotButton; -end; - -function TFormStyleHookHelper.GetFLeft: Integer; -begin - with Self do - Result := FLeft; -end; - -function TFormStyleHookHelper.GetFMaxButtonRect: TRect; -begin - with Self do - Result := FMaxButtonRect; -end; - -function TFormStyleHookHelper.GetFMinButtonRect: TRect; -begin - with Self do - Result := FMinButtonRect; -end; - -function TFormStyleHookHelper.GetForm: TCustomForm; -begin - with Self do - Result := Form; -end; - -function TFormStyleHookHelper.GetFPressedButton: Integer; -begin - with Self do - Result := FPressedButton; -end; - -function TFormStyleHookHelper.GetFRegion: HRGN; -begin - with Self do - Result := FRegion; -end; - -function TFormStyleHookHelper.GetFSysMenuButtonRect: TRect; -begin - with Self do - Result := FSysMenuButtonRect; -end; - -function TFormStyleHookHelper.GetFTop: Integer; -begin - with Self do - Result := FTop; -end; - -function TFormStyleHookHelper.GetFWidth: Integer; -begin - with Self do - Result := FWidth; -end; - -procedure TFormStyleHookHelper.MainMenuBarHookPaint(Canvas: TCanvas); -begin - with Self do - if (FMainMenuBarHook <> nil) then - FMainMenuBarHook.Paint(Canvas); -end; - -procedure TFormStyleHookHelper.SetFCaptionRect(const Value: TRect); -begin - with Self do - FCaptionRect := Value; -end; - -procedure TFormStyleHookHelper.SetFChangeSizeCalled(const Value: Boolean); -begin - with Self do - FChangeSizeCalled := Value; -end; - -procedure TFormStyleHookHelper.SetFCloseButtonRect(const Value: TRect); -begin - with Self do - FCloseButtonRect := Value; -end; - -procedure TFormStyleHookHelper.SetFHeight(const Value: Integer); -begin - with Self do - FHeight := Value; -end; - -procedure TFormStyleHookHelper.SetFHelpButtonRect(const Value: TRect); -begin - with Self do - FHelpButtonRect := Value; -end; - -procedure TFormStyleHookHelper.SetFLeft(const Value: Integer); -begin - with Self do - FLeft := Value; -end; - -procedure TFormStyleHookHelper.SetFMaxButtonRect(const Value: TRect); -begin - with Self do - FMaxButtonRect := Value; -end; - -procedure TFormStyleHookHelper.SetFMinButtonRect(const Value: TRect); -begin - with Self do - FMinButtonRect := Value; -end; - -procedure TFormStyleHookHelper.SetFRegion(const Value: HRGN); -begin - with Self do - FRegion := Value; -end; - -procedure TFormStyleHookHelper.SetFSysMenuButtonRect(const Value: TRect); -begin - with Self do - FSysMenuButtonRect := Value; -end; - -procedure TFormStyleHookHelper.SetFTop(const Value: Integer); -begin - with Self do - FTop := Value; -end; - -procedure TFormStyleHookHelper.SetFWidth(const Value: Integer); -begin - with Self do - FWidth := Value; -end; - -procedure TFormStyleHookHelper._ChangeSize; -begin - with Self do - ChangeSize; -end; - -function TFormStyleHookHelper._GetBorderSize: TRect; -begin - with Self do - Result := GetBorderSize; -end; - -function TFormStyleHookHelper._GetBorderSizeAddr: Pointer; -var - MethodAddr: function: TRect of object; -begin - with Self do - MethodAddr := GetBorderSize; - Result := TMethod(MethodAddr).Code; -end; - - -function TFormStyleHookHelper._GetRegionAddr: Pointer; -var - MethodAddr: function: HRGN of object; -begin - with Self do - MethodAddr := GetRegion; - Result := TMethod(MethodAddr).Code; -end; - -function TFormStyleHookHelper._GetHitTest(P: TPoint): Integer; -begin - with Self do - Result := GetHitTest(P); -end; - -function TFormStyleHookHelper._GetIconFast: TIcon; -begin - with Self do - Result := GetIconFast; -end; - -function TFormStyleHookHelper._NormalizePoint(P: TPoint): TPoint; -begin - with Self do - Result := NormalizePoint(P); -end; - - -end. +// ************************************************************************************************** +// +// Unit Vcl.Styles.FormStyleHooks +// unit for the VCL Styles Utils +// https://github.com/RRUZ/vcl-styles-utils/ +// +// 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. +// +// The Original Code is Vcl.Styles.FormStyleHooks.pas. +// +// The Initial Developer of the Original Code is Rodrigo Ruz V. +// Portions created by Rodrigo Ruz V. are Copyright (C) 2012-2023 Rodrigo Ruz V. +// All Rights Reserved. +// +// ************************************************************************************************** + +unit Vcl.Styles.FormStyleHooks; + +interface +{$IF RTLVersion>=24} + {$LEGACYIFEND ON} +{$IFEND} +uses + Winapi.Windows, + Winapi.Messages, + Vcl.Themes, + Vcl.Controls, + Vcl.ComCtrls, + Vcl.Graphics, + Vcl.Forms; + +type + /// Form Style hook to add image and/or color supoort for the background and non client area + /// + TFormStyleHookBackground = class(TFormStyleHook) + strict private + type + TSettings = class + strict private + FColor: TColor; + FImageLocation: string; + FBitmap: TBitmap; + FUseColor: Boolean; + FUseImage: Boolean; + FEnabled: Boolean; + FUseAlpha: Boolean; + FAlphaValue: Byte; + procedure SetColor(const Value: TColor); + procedure SetImageLocation(const Value: string); + procedure SetUseColor(const Value: Boolean); + procedure SetUseImage(const Value: Boolean); + public + property UseImage: Boolean read FUseImage write SetUseImage; + property UseColor: Boolean read FUseColor write SetUseColor; + property Color: TColor read FColor write SetColor; + property ImageLocation: string read FImageLocation write SetImageLocation; + property Bitmap: TBitmap read FBitmap; + property Enabled: Boolean read FEnabled write FEnabled; + property UseAlpha: Boolean read FUseAlpha write FUseAlpha; + property AlphaValue: Byte read FAlphaValue write FAlphaValue; + constructor Create; + destructor Destroy; override; + end; + class var FNCSettings: TSettings; + class var FBackGroundSettings: TSettings; + class var FMergeImages: Boolean; + class Var FSharedBitMap: TBitmap; + class var FSharedImageLocation: string; + class procedure SetSharedImageLocation(const Value: string); static; + protected + procedure PaintNC(Canvas: TCanvas); override; + procedure PaintBackground(Canvas: TCanvas); override; + class constructor Create; + class destructor Destroy; + public + class property SharedImageLocation: string read FSharedImageLocation + write SetSharedImageLocation; + class property SharedBitMap: TBitmap read FSharedBitMap write FSharedBitMap; + class property MergeImages: Boolean read FMergeImages write FMergeImages; + class property NCSettings: TSettings read FNCSettings; + class property BackGroundSettings: TSettings read FBackGroundSettings; + end; + + /// Form Style hook to disable vcl styles in the non client area + /// + TFormStyleHookNC = class(TMouseTrackControlStyleHook) + public + procedure PaintBackground(Canvas: TCanvas); override; + constructor Create(AControl: TWinControl); override; + end; + + /// Form Style hook to add support for the regions in the non client area + /// + TFormStyleHookRgn = class(TFormStyleHook) + private + procedure WMWindowPosChanging(var Message: TWMWindowPosChanging); + message WM_WINDOWPOSCHANGING; + protected + procedure PaintNC(Canvas: TCanvas); override; + end; + + TFormStyleHookHelper = class helper for TFormStyleHook + private + function GetFCloseButtonRect: TRect; + procedure SetFCloseButtonRect(const Value: TRect); + function GetFCaptionRect: TRect; + function GetFHelpButtonRect: TRect; + function GetFMaxButtonRect: TRect; + function GetFMinButtonRect: TRect; + function GetFSysMenuButtonRect: TRect; + procedure SetFCaptionRect(const Value: TRect); + procedure SetFHelpButtonRect(const Value: TRect); + procedure SetFMaxButtonRect(const Value: TRect); + procedure SetFMinButtonRect(const Value: TRect); + procedure SetFSysMenuButtonRect(const Value: TRect); + function GetFFormActive: Boolean; + function GetFWidth: Integer; + function GetFPressedButton: Integer; + function GetFHotButton: Integer; + function GetFHeight: Integer; + function GetFChangeSizeCalled: Boolean; + function GetFLeft: Integer; + function GetFTop: Integer; + procedure SetFLeft(const Value: Integer); + procedure SetFTop(const Value: Integer); + procedure SetFHeight(const Value: Integer); + procedure SetFWidth(const Value: Integer); + procedure SetFChangeSizeCalled(const Value: Boolean); + function GetFRegion: HRGN; + procedure SetFRegion(const Value: HRGN); + function GetForm: TCustomForm; + public + property _FCloseButtonRect: TRect read GetFCloseButtonRect + Write SetFCloseButtonRect; + property _FMaxButtonRect: TRect read GetFMaxButtonRect + Write SetFMaxButtonRect; + property _FMinButtonRect: TRect read GetFMinButtonRect + Write SetFMinButtonRect; + property _FHelpButtonRect: TRect read GetFHelpButtonRect + Write SetFHelpButtonRect; + property _FSysMenuButtonRect: TRect read GetFSysMenuButtonRect + Write SetFSysMenuButtonRect; + property _FCaptionRect: TRect read GetFCaptionRect Write SetFCaptionRect; + function _GetBorderSize{$IF CompilerVersion >= 36}(UseActiveStyle: Boolean = True){$IFEND}: TRect; + property _FFormActive: Boolean read GetFFormActive; + property _FChangeSizeCalled: Boolean read GetFChangeSizeCalled + write SetFChangeSizeCalled; + property _FWidth: Integer read GetFWidth write SetFWidth; + property _FHeight: Integer read GetFHeight write SetFHeight; + property _FLeft: Integer read GetFLeft write SetFLeft; + property _FTop: Integer read GetFTop write SetFTop; + property _FPressedButton: Integer read GetFPressedButton; + property _FHotButton: Integer read GetFHotButton; + property _FRegion: HRGN read GetFRegion write SetFRegion; + property _Form: TCustomForm read GetForm; + procedure MainMenuBarHookPaint(Canvas: TCanvas); + function _GetIconFast: TIcon; + procedure _ChangeSize; + function _NormalizePoint(P: TPoint): TPoint; + function _GetHitTest(P: TPoint): Integer; + function _GetBorderSizeAddr: Pointer; + function _GetRegionAddr: Pointer; + end; + +function RectVCenter(var R: TRect; Bounds: TRect): TRect; + +implementation + +Uses + System.SysUtils, + System.Classes, + System.Types, + Winapi.UxTheme, + Vcl.Imaging.Jpeg, + Vcl.Imaging.pngimage, + Vcl.Imaging.GIFImg; + +type + TCustomFormClass = class(TCustomForm); + +function RectVCenter(var R: TRect; Bounds: TRect): TRect; +begin + OffsetRect(R, -R.Left, -R.Top); + OffsetRect(R, 0, (Bounds.Height - R.Height) div 2); + OffsetRect(R, Bounds.Left, Bounds.Top); + Result := R; +end; + +{ TFormStyleHookRgn } + +procedure TFormStyleHookRgn.WMWindowPosChanging(var Message +: TWMWindowPosChanging); +var + Changed: Boolean; + + function GetRegion: HRGN; + var + R: TRect; + Details: TThemedElementDetails; + Detail: TThemedWindow; + begin + Result := 0; + if not StyleServices.Available then + Exit; + + R := Rect(0, 0, _FWidth, _FHeight); + if (Form.BorderStyle <> bsToolWindow) and (Form.BorderStyle <> bsSizeToolWin) + then + Detail := twCaptionActive + else + Detail := twSmallCaptionActive; + Details := StyleServices.GetElementDetails(Detail); + StyleServices.GetElementRegion(Details, R, Result); + end; + + procedure ChangeSize; + var + TempRegion: HRGN; + FormhRgn: HRGN; + R: TRect; + begin + _FChangeSizeCalled := True; + + if IsIconic(Handle) then + begin + R := _GetBorderSize; + _FHeight := R.Top + R.Bottom; + end; + + if Form.BorderStyle <> bsNone then + begin + TempRegion := _FRegion; + try + _FRegion := GetRegion; + FormhRgn := 0; + GetWindowRgn(Handle, FormhRgn); + { + CombineRgn(FormhRgn, FormhRgn,_FRegion,RGN_OR); + SetWindowRgn(Handle, FormhRgn, True); + } + // SetWindowRgn(Handle, _FRegion, True); + finally + if TempRegion <> 0 then + DeleteObject(TempRegion); + end; + _FChangeSizeCalled := False; + end; + end; + +begin + CallDefaultProc(TMessage(Message)); + + Handled := True; + Changed := False; + + if _FChangeSizeCalled then + Exit; + + if (Message.WindowPos^.flags and SWP_NOSIZE = 0) or + (Message.WindowPos^.flags and SWP_NOMOVE = 0) then + begin + if (Message.WindowPos^.flags and SWP_NOMOVE = 0) then + begin + _FLeft := Message.WindowPos^.x; + _FTop := Message.WindowPos^.y; + end; + if (Message.WindowPos^.flags and SWP_NOSIZE = 0) then + begin + Changed := ((Message.WindowPos^.cx <> _FWidth) or + (Message.WindowPos^.cy <> _FHeight)) and + (Message.WindowPos^.flags and SWP_NOSIZE = 0); + _FWidth := Message.WindowPos^.cx; + _FHeight := Message.WindowPos^.cy; + end; + end; + + if Changed then + begin + ChangeSize; + if Form.BorderStyle <> bsNone then + InvalidateNC; + end; +end; + +procedure TFormStyleHookRgn.PaintNC(Canvas: TCanvas); +var + Details, CaptionDetails, IconDetails: TThemedElementDetails; + Detail: TThemedWindow; + R, R1, DrawRect, ButtonRect, TextRect: TRect; + CaptionBuffer: TBitmap; + FButtonState: TThemedWindow; + TextFormat: TTextFormat; + LText: string; +begin + + if Form.BorderStyle = bsNone then + begin + MainMenuBarHookPaint(Canvas); + Exit; + end; + + { init some parameters } + _FCloseButtonRect := Rect(0, 0, 0, 0); + _FMaxButtonRect := Rect(0, 0, 0, 0); + _FMinButtonRect := Rect(0, 0, 0, 0); + _FHelpButtonRect := Rect(0, 0, 0, 0); + _FSysMenuButtonRect := Rect(0, 0, 0, 0); + _FCaptionRect := Rect(0, 0, 0, 0); + + if not StyleServices.Available then + Exit; + R := _GetBorderSize; + + { draw caption } + + if (Form.BorderStyle <> bsToolWindow) and (Form.BorderStyle <> bsSizeToolWin) + then + begin + if _FFormActive then + Detail := twCaptionActive + else + Detail := twCaptionInActive + end + else + begin + if _FFormActive then + Detail := twSmallCaptionActive + else + Detail := twSmallCaptionInActive + end; + CaptionBuffer := TBitmap.Create; + CaptionBuffer.SetSize(_FWidth, R.Top); + + { draw caption border } + DrawRect := Rect(0, 0, CaptionBuffer.Width, CaptionBuffer.Height); + Details := StyleServices.GetElementDetails(Detail); + StyleServices.DrawElement(CaptionBuffer.Canvas.Handle, Details, DrawRect); + TextRect := DrawRect; + CaptionDetails := Details; + + { draw icon } + if (biSystemMenu in TCustomFormClass(Form).BorderIcons) and + (Form.BorderStyle <> bsDialog) and (Form.BorderStyle <> bsToolWindow) and + (Form.BorderStyle <> bsSizeToolWin) then + begin + IconDetails := StyleServices.GetElementDetails(twSysButtonNormal); + if not StyleServices.GetElementContentRect(0, IconDetails, DrawRect, + ButtonRect) then + ButtonRect := Rect(0, 0, 0, 0); + R1 := Rect(0, 0, GetSystemMetrics(SM_CXSMICON), + GetSystemMetrics(SM_CYSMICON)); + RectVCenter(R1, ButtonRect); + if ButtonRect.Width > 0 then + DrawIconEx(CaptionBuffer.Canvas.Handle, R1.Left, R1.Top, + _GetIconFast.Handle, 0, 0, 0, 0, DI_NORMAL); + Inc(TextRect.Left, ButtonRect.Width + 5); + _FSysMenuButtonRect := ButtonRect; + end + else + Inc(TextRect.Left, R.Left); + + { draw buttons } + if (biSystemMenu in TCustomFormClass(Form).BorderIcons) then + begin + if (Form.BorderStyle <> bsToolWindow) and (Form.BorderStyle <> bsSizeToolWin) + then + begin + if (_FPressedButton = HTCLOSE) and (_FHotButton = HTCLOSE) then + FButtonState := twCloseButtonPushed + else if _FHotButton = HTCLOSE then + FButtonState := twCloseButtonHot + else if _FFormActive then + FButtonState := twCloseButtonNormal + else + FButtonState := twCloseButtonDisabled; + end + else + begin + if (_FPressedButton = HTCLOSE) and (_FHotButton = HTCLOSE) then + FButtonState := twSmallCloseButtonPushed + else if _FHotButton = HTCLOSE then + FButtonState := twSmallCloseButtonHot + else if _FFormActive then + FButtonState := twSmallCloseButtonNormal + else + FButtonState := twSmallCloseButtonDisabled; + end; + + Details := StyleServices.GetElementDetails(FButtonState); + if not StyleServices.GetElementContentRect(0, Details, DrawRect, ButtonRect) + then + ButtonRect := Rect(0, 0, 0, 0); + + StyleServices.DrawElement(CaptionBuffer.Canvas.Handle, Details, ButtonRect); + if ButtonRect.Left > 0 then + TextRect.Right := ButtonRect.Left; + _FCloseButtonRect := ButtonRect; + end; + + if (biMaximize in TCustomFormClass(Form).BorderIcons) and + (biSystemMenu in TCustomFormClass(Form).BorderIcons) and + (Form.BorderStyle <> bsDialog) and (Form.BorderStyle <> bsToolWindow) and + (Form.BorderStyle <> bsSizeToolWin) then + begin + if Form.WindowState = wsMaximized then + begin + if (_FPressedButton = HTMAXBUTTON) and (_FHotButton = HTMAXBUTTON) then + FButtonState := twRestoreButtonPushed + else if _FHotButton = HTMAXBUTTON then + FButtonState := twRestoreButtonHot + else if _FFormActive then + FButtonState := twRestoreButtonNormal + else + FButtonState := twRestoreButtonDisabled; + end + else + begin + if (_FPressedButton = HTMAXBUTTON) and (_FHotButton = HTMAXBUTTON) then + FButtonState := twMaxButtonPushed + else if _FHotButton = HTMAXBUTTON then + FButtonState := twMaxButtonHot + else if _FFormActive then + FButtonState := twMaxButtonNormal + else + FButtonState := twMaxButtonDisabled; + end; + Details := StyleServices.GetElementDetails(FButtonState); + + if not StyleServices.GetElementContentRect(0, Details, DrawRect, ButtonRect) + then + ButtonRect := Rect(0, 0, 0, 0); + if ButtonRect.Width > 0 then + StyleServices.DrawElement(CaptionBuffer.Canvas.Handle, Details, + ButtonRect); + if ButtonRect.Left > 0 then + TextRect.Right := ButtonRect.Left; + _FMaxButtonRect := ButtonRect; + end; + + if (biMinimize in TCustomFormClass(Form).BorderIcons) and + (biSystemMenu in TCustomFormClass(Form).BorderIcons) and + (Form.BorderStyle <> bsDialog) and (Form.BorderStyle <> bsToolWindow) and + (Form.BorderStyle <> bsSizeToolWin) then + begin + if (_FPressedButton = HTMINBUTTON) and (_FHotButton = HTMINBUTTON) then + FButtonState := twMinButtonPushed + else if _FHotButton = HTMINBUTTON then + FButtonState := twMinButtonHot + else if _FFormActive then + FButtonState := twMinButtonNormal + else + FButtonState := twMinButtonDisabled; + + Details := StyleServices.GetElementDetails(FButtonState); + + if not StyleServices.GetElementContentRect(0, Details, DrawRect, ButtonRect) + then + ButtonRect := Rect(0, 0, 0, 0); + if ButtonRect.Width > 0 then + StyleServices.DrawElement(CaptionBuffer.Canvas.Handle, Details, + ButtonRect); + if ButtonRect.Left > 0 then + TextRect.Right := ButtonRect.Left; + _FMinButtonRect := ButtonRect; + end; + + if (biHelp in TCustomFormClass(Form).BorderIcons) and + (biSystemMenu in TCustomFormClass(Form).BorderIcons) and + ((not(biMaximize in TCustomFormClass(Form).BorderIcons) and + not(biMinimize in TCustomFormClass(Form).BorderIcons)) or + (Form.BorderStyle = bsDialog)) then + begin + if (_FPressedButton = HTHELP) and (_FHotButton = HTHELP) then + FButtonState := twHelpButtonPushed + else if _FHotButton = HTHELP then + FButtonState := twHelpButtonHot + else if _FFormActive then + FButtonState := twHelpButtonNormal + else + FButtonState := twHelpButtonDisabled; + Details := StyleServices.GetElementDetails(FButtonState); + + if not StyleServices.GetElementContentRect(0, Details, DrawRect, ButtonRect) + then + ButtonRect := Rect(0, 0, 0, 0); + if ButtonRect.Width > 0 then + StyleServices.DrawElement(CaptionBuffer.Canvas.Handle, Details, + ButtonRect); + + if ButtonRect.Left > 0 then + TextRect.Right := ButtonRect.Left; + _FHelpButtonRect := ButtonRect; + end; + + { draw text } + TextFormat := [tfLeft, tfSingleLine, tfVerticalCenter]; + if Control.UseRightToLeftReading then + Include(TextFormat, tfRtlReading); + // Important: Must retrieve Text prior to calling DrawText as it causes + // CaptionBuffer.Canvas to free its handle, making the outcome of the call + // to DrawText dependent on parameter evaluation order. + LText := Text; + StyleServices.DrawText(CaptionBuffer.Canvas.Handle, CaptionDetails, LText, + TextRect, TextFormat); + _FCaptionRect := TextRect; + + { draw caption buffer } + + Canvas.Draw(0, 0, CaptionBuffer); + CaptionBuffer.Free; + + { draw menubar } + MainMenuBarHookPaint(Canvas); + + { draw left border } + + if (Form.BorderStyle <> bsToolWindow) and (Form.BorderStyle <> bsSizeToolWin) + then + begin + if _FFormActive then + Detail := twFrameLeftActive + else + Detail := twFrameLeftInActive + end + else + begin + if _FFormActive then + Detail := twSmallFrameLeftActive + else + Detail := twSmallFrameLeftInActive + end; + DrawRect := Rect(0, R.Top, R.Left, _FHeight - R.Bottom); + Details := StyleServices.GetElementDetails(Detail); + + if DrawRect.Bottom - DrawRect.Top > 0 then + StyleServices.DrawElement(Canvas.Handle, Details, DrawRect); + + { draw right border } + if (Form.BorderStyle <> bsToolWindow) and (Form.BorderStyle <> bsSizeToolWin) + then + begin + if _FFormActive then + Detail := twFrameRightActive + else + Detail := twFrameRightInActive + end + else + begin + if _FFormActive then + Detail := twSmallFrameRightActive + else + Detail := twSmallFrameRightInActive + end; + DrawRect := Rect(_FWidth - R.Right, R.Top, _FWidth, _FHeight - R.Bottom); + Details := StyleServices.GetElementDetails(Detail); + + if DrawRect.Bottom - DrawRect.Top > 0 then + StyleServices.DrawElement(Canvas.Handle, Details, DrawRect); + + { draw Bottom border } + if (Form.BorderStyle <> bsToolWindow) and (Form.BorderStyle <> bsSizeToolWin) + then + begin + if _FFormActive then + Detail := twFrameBottomActive + else + Detail := twFrameBottomInActive + end + else + begin + if _FFormActive then + Detail := twSmallFrameBottomActive + else + Detail := twSmallFrameBottomInActive + end; + DrawRect := Rect(0, _FHeight - R.Bottom, _FWidth, _FHeight); + Details := StyleServices.GetElementDetails(Detail); + + if DrawRect.Bottom - DrawRect.Top > 0 then + StyleServices.DrawElement(Canvas.Handle, Details, DrawRect); +end; + +{ TFormStyleHookBackround.TSettings } + +constructor TFormStyleHookBackground.TSettings.Create; +begin + inherited; + FUseAlpha := False; + FAlphaValue := 200; + FEnabled := False; + FBitmap := TBitmap.Create; + ImageLocation := ''; + UseImage := False; +end; + +destructor TFormStyleHookBackground.TSettings.Destroy; +begin + FBitmap.Free; + inherited; +end; + +procedure TFormStyleHookBackground.TSettings.SetColor(const Value: TColor); +begin + if Value <> FColor then + FColor := Value; +end; + +procedure TFormStyleHookBackground.TSettings.SetImageLocation + (const Value: string); +var + Picture: TPicture; +begin + FImageLocation := Value; + if FileExists(Value) then + begin + Picture := TPicture.Create; + try + Picture.LoadFromFile(Value); + FBitmap.Width := Picture.Width; + FBitmap.Height := Picture.Height; + FBitmap.Canvas.Draw(0, 0, Picture.Graphic); + finally + Picture.Free; + end; + end; +end; + +procedure TFormStyleHookBackground.TSettings.SetUseColor(const Value: Boolean); +begin + FUseColor := Value; + FUseImage := not Value; +end; + +procedure TFormStyleHookBackground.TSettings.SetUseImage(const Value: Boolean); +begin + FUseImage := Value; + FUseColor := not Value; +end; + +{ TFormStyleHookBackround } + +class constructor TFormStyleHookBackground.Create; +begin + FMergeImages := False; + FSharedBitMap := TBitmap.Create; + FNCSettings := TFormStyleHookBackground.TSettings.Create; + FBackGroundSettings := TFormStyleHookBackground.TSettings.Create; +end; + +class destructor TFormStyleHookBackground.Destroy; +begin + FreeAndNil(FSharedBitMap); + FreeAndNil(FNCSettings); + FreeAndNil(FBackGroundSettings); +end; + +class procedure TFormStyleHookBackground.SetSharedImageLocation + (const Value: string); +var + Picture: TPicture; +begin + FSharedImageLocation := Value; + if FileExists(Value) then + begin + Picture := TPicture.Create; + try + Picture.LoadFromFile(Value); + FSharedBitMap.Width := Picture.Width; + FSharedBitMap.Height := Picture.Height; + FSharedBitMap.Canvas.Draw(0, 0, Picture.Graphic); + finally + Picture.Free; + end; + end; +end; + +procedure TFormStyleHookBackground.PaintBackground(Canvas: TCanvas); +var + LRect: TRect; + RBitmap: TRect; + L, H: Integer; +begin + // if the option is not enabled use the default inherited PaintBackground method + if not BackGroundSettings.Enabled then + inherited + else + begin + // get he bounds of the control (form) + LRect := Rect(0, 0, Control.ClientWidth, Control.ClientHeight); + // use a custom color for the background? + if BackGroundSettings.UseColor then + begin + Canvas.Brush.Color := BackGroundSettings.Color; + Canvas.FillRect(LRect); + end + else + // use a bitmap + begin + // check the size of the bitmap against the control bounds to detrine how the bitmap is drawn + if not FMergeImages and ((BackGroundSettings.Bitmap.Width < LRect.Width) + or (BackGroundSettings.Bitmap.Height < LRect.Height)) then + begin + Canvas.Brush.Bitmap := BackGroundSettings.Bitmap; + Canvas.FillRect(LRect); + end + else + begin + // check if the the background bitmap must be merged with non client area bitmap + if not FMergeImages then + Canvas.CopyRect(LRect, BackGroundSettings.Bitmap.Canvas, LRect) + else + begin + RBitmap := LRect; + H := _GetBorderSize.Top; + L := _GetBorderSize.Left; + RBitmap.SetLocation(L, H); + // Canvas.CopyRect(LRect,BackGroundSettings.Bitmap.Canvas,RBitmap); + Canvas.CopyRect(LRect, FSharedBitMap.Canvas, RBitmap); + end; + end; + end; + end; +end; + +procedure TFormStyleHookBackground.PaintNC(Canvas: TCanvas); +var + LDetail: TThemedWindow; + LDetails, CaptionDetails, IconDetails: TThemedElementDetails; + R, R1, DrawRect, ButtonRect, TextRect: TRect; + LBitmap: TBitmap; + FButtonState: TThemedWindow; + TextFormat: TTextFormat; + LText: string; + SrcBackRect: TRect; + + pblend: TBlendFunction; + LBitmapPos: TPoint; + LBitmapSize: TSize; + LExStyle: DWORD; +{$IF CompilerVersion>23} + TextTopOffset: Integer; +{$IFEND} + function GetTopOffset: Integer; + var + P: TPoint; + begin + P.x := Form.Left + Form.Width div 2; + P.y := Form.Top + Form.Height div 2; + Result := Screen.MonitorFromPoint(P).WorkareaRect.Top; + if Form.Top < Result then + Result := Result - Form.Top + else + Result := 0; + end; + + procedure CorrectLeftButtonRect(var AButtonRect: TRect); + var + TopOffset, LeftOffset: Integer; + BS: TRect; + begin + if (Form.WindowState = wsMaximized) and + (TCustomFormClass(Form).FormStyle <> fsMDIChild) and (ButtonRect.Width > 0) + then + begin + BS := _GetBorderSize; + TopOffset := GetTopOffset; + LeftOffset := BS.Left; + if ButtonRect.Top < TopOffset then + begin + TopOffset := TopOffset - ButtonRect.Top; + OffsetRect(ButtonRect, LeftOffset, TopOffset); + TopOffset := ButtonRect.Bottom - BS.Top; + if TopOffset > 0 then + OffsetRect(ButtonRect, 0, -TopOffset); + end; + end; + end; + + procedure CorrectRightButtonRect(var AButtonRect: TRect); + var + TopOffset, RightOffset: Integer; + BS: TRect; + begin + if (Form.WindowState = wsMaximized) and + (TCustomFormClass(Form).FormStyle <> fsMDIChild) and (ButtonRect.Width > 0) + then + begin + BS := _GetBorderSize; + TopOffset := GetTopOffset; + RightOffset := -BS.Right; + if ButtonRect.Top < TopOffset then + begin + TopOffset := TopOffset - ButtonRect.Top; + OffsetRect(ButtonRect, RightOffset, TopOffset); + TopOffset := ButtonRect.Bottom - BS.Top; + if TopOffset > 0 then + OffsetRect(ButtonRect, 0, -TopOffset); + end; + end; + end; + +begin + // if the setting is not enabled use the original PaintNC method + if not NCSettings.Enabled then + begin + inherited; + Exit; + end; + + // check the border style of the form + if Form.BorderStyle = bsNone then + begin + MainMenuBarHookPaint(Canvas); + Exit; + end; + + { init some parameters } + _FCloseButtonRect := Rect(0, 0, 0, 0); + _FMaxButtonRect := Rect(0, 0, 0, 0); + _FMinButtonRect := Rect(0, 0, 0, 0); + _FHelpButtonRect := Rect(0, 0, 0, 0); + _FSysMenuButtonRect := Rect(0, 0, 0, 0); + _FCaptionRect := Rect(0, 0, 0, 0); + + if not StyleServices.Available then + Exit; + R := _GetBorderSize; + + { draw caption } + if (Form.BorderStyle <> bsToolWindow) and (Form.BorderStyle <> bsSizeToolWin) + then + begin + if _FFormActive then + LDetail := twCaptionActive + else + LDetail := twCaptionInActive + end + else + begin + if _FFormActive then + LDetail := twSmallCaptionActive + else + LDetail := twSmallCaptionInActive + end; + + LBitmap := TBitmap.Create; + if FNCSettings.UseAlpha then + LBitmap.SetSize(_FWidth, _FHeight) + else + LBitmap.SetSize(_FWidth, R.Top); + + { draw caption border } + DrawRect := Rect(0, 0, LBitmap.Width, LBitmap.Height); + LDetails := StyleServices.GetElementDetails(LDetail); + // used for draw text in the caption +{$IF CompilerVersion>23} + TextTopOffset := 3; +{$IFEND} + // check if a must use a custom color or a bitmap + if FNCSettings.UseColor then + begin + if FNCSettings.UseAlpha then + begin + LExStyle := GetWindowLongA(Handle, GWL_EXSTYLE); + if (LExStyle and WS_EX_LAYERED = 0) then + SetWindowLong(Handle, GWL_EXSTYLE, LExStyle or WS_EX_LAYERED); + + LBitmap.PixelFormat := pf32bit; + LBitmap.Canvas.Brush.Color := FNCSettings.Color; + LBitmap.Canvas.FillRect(DrawRect); + LBitmapPos := Point(0, 0); + LBitmapSize.cx := LBitmap.Width; + LBitmapSize.cy := LBitmap.Height; + pblend.BlendOp := AC_SRC_OVER; + pblend.BlendFlags := 0; + pblend.SourceConstantAlpha := FNCSettings.AlphaValue; + pblend.AlphaFormat := 0; + end + else + begin + // use the select color to fill the background of the canvas + LBitmap.Canvas.Brush.Color := FNCSettings.Color; + LBitmap.Canvas.FillRect(DrawRect); + end; + + end + else + begin + // use the bitmap to fill the canvas + SrcBackRect.Left := 0; + SrcBackRect.Top := 0; + SrcBackRect.Width := DrawRect.Width; + SrcBackRect.Height := DrawRect.Height; + // SrcBackRect.SetLocation(FNCSettings.Bitmap.Width-DrawRect.Width, 0); + // SrcBackRect.SetLocation(_GetBorderSize.Width, 0); + if not FMergeImages then + LBitmap.Canvas.CopyRect(DrawRect, FNCSettings.Bitmap.Canvas, SrcBackRect) + else + LBitmap.Canvas.CopyRect(DrawRect, FSharedBitMap.Canvas, SrcBackRect) + end; + + TextRect := DrawRect; + CaptionDetails := LDetails; + + { draw icon } + if (biSystemMenu in TCustomFormClass(Form).BorderIcons) and + (Form.BorderStyle <> bsDialog) and (Form.BorderStyle <> bsToolWindow) and + (Form.BorderStyle <> bsSizeToolWin) then + begin + IconDetails := StyleServices.GetElementDetails(twSysButtonNormal); + if not StyleServices.GetElementContentRect(0, IconDetails, DrawRect, + ButtonRect) then + ButtonRect := Rect(0, 0, 0, 0); + +{$IF CompilerVersion > 23.0} + R1 := ButtonRect; + if not StyleServices.HasElementFixedPosition(LDetails) then + begin + CorrectLeftButtonRect(ButtonRect); + TextTopOffset := Abs(R1.Top - ButtonRect.Top); + if TextTopOffset > R.Top then + TextTopOffset := 3; + end + else + TextTopOffset := 0; +{$IFEND} + R1 := Rect(0, 0, GetSystemMetrics(SM_CXSMICON), + GetSystemMetrics(SM_CYSMICON)); + RectVCenter(R1, ButtonRect); + if ButtonRect.Width > 0 then + DrawIconEx(LBitmap.Canvas.Handle, R1.Left, R1.Top, _GetIconFast.Handle, 0, + 0, 0, 0, DI_NORMAL); + Inc(TextRect.Left, ButtonRect.Width + 5); + _FSysMenuButtonRect := ButtonRect; + end + else + Inc(TextRect.Left, R.Left); + + { draw buttons } + if (biSystemMenu in TCustomFormClass(Form).BorderIcons) then + begin + if (Form.BorderStyle <> bsToolWindow) and (Form.BorderStyle <> bsSizeToolWin) + then + begin + if (_FPressedButton = HTCLOSE) and (_FHotButton = HTCLOSE) then + FButtonState := twCloseButtonPushed + else if _FHotButton = HTCLOSE then + FButtonState := twCloseButtonHot + else if _FFormActive then + FButtonState := twCloseButtonNormal + else + FButtonState := twCloseButtonDisabled; + end + else + begin + if (_FPressedButton = HTCLOSE) and (_FHotButton = HTCLOSE) then + FButtonState := twSmallCloseButtonPushed + else if _FHotButton = HTCLOSE then + FButtonState := twSmallCloseButtonHot + else if _FFormActive then + FButtonState := twSmallCloseButtonNormal + else + FButtonState := twSmallCloseButtonDisabled; + end; + + LDetails := StyleServices.GetElementDetails(FButtonState); + if not StyleServices.GetElementContentRect(0, LDetails, DrawRect, ButtonRect) + then + ButtonRect := Rect(0, 0, 0, 0); + +{$IF CompilerVersion > 23.0} + if not StyleServices.HasElementFixedPosition(LDetails) then + CorrectRightButtonRect(ButtonRect); +{$IFEND} + StyleServices.DrawElement(LBitmap.Canvas.Handle, LDetails, ButtonRect); + + if ButtonRect.Left > 0 then + TextRect.Right := ButtonRect.Left; + _FCloseButtonRect := ButtonRect; + end; + + if (biMaximize in TCustomFormClass(Form).BorderIcons) and + (biSystemMenu in TCustomFormClass(Form).BorderIcons) and + (Form.BorderStyle <> bsDialog) and (Form.BorderStyle <> bsToolWindow) and + (Form.BorderStyle <> bsSizeToolWin) then + begin + if Form.WindowState = wsMaximized then + begin + if (_FPressedButton = HTMAXBUTTON) and (_FHotButton = HTMAXBUTTON) then + FButtonState := twRestoreButtonPushed + else if _FHotButton = HTMAXBUTTON then + FButtonState := twRestoreButtonHot + else if _FFormActive then + FButtonState := twRestoreButtonNormal + else + FButtonState := twRestoreButtonDisabled; + end + else + begin + if (_FPressedButton = HTMAXBUTTON) and (_FHotButton = HTMAXBUTTON) then + FButtonState := twMaxButtonPushed + else if _FHotButton = HTMAXBUTTON then + FButtonState := twMaxButtonHot + else if _FFormActive then + FButtonState := twMaxButtonNormal + else + FButtonState := twMaxButtonDisabled; + end; + LDetails := StyleServices.GetElementDetails(FButtonState); + + if not StyleServices.GetElementContentRect(0, LDetails, DrawRect, ButtonRect) + then + ButtonRect := Rect(0, 0, 0, 0); + +{$IF CompilerVersion > 23.0} + if not StyleServices.HasElementFixedPosition(LDetails) then + CorrectRightButtonRect(ButtonRect); +{$IFEND} + if ButtonRect.Width > 0 then + StyleServices.DrawElement(LBitmap.Canvas.Handle, LDetails, ButtonRect); + if ButtonRect.Left > 0 then + TextRect.Right := ButtonRect.Left; + _FMaxButtonRect := ButtonRect; + end; + + if (biMinimize in TCustomFormClass(Form).BorderIcons) and + (biSystemMenu in TCustomFormClass(Form).BorderIcons) and + (Form.BorderStyle <> bsDialog) and (Form.BorderStyle <> bsToolWindow) and + (Form.BorderStyle <> bsSizeToolWin) then + begin + if (_FPressedButton = HTMINBUTTON) and (_FHotButton = HTMINBUTTON) then + FButtonState := twMinButtonPushed + else if _FHotButton = HTMINBUTTON then + FButtonState := twMinButtonHot + else if _FFormActive then + FButtonState := twMinButtonNormal + else + FButtonState := twMinButtonDisabled; + + LDetails := StyleServices.GetElementDetails(FButtonState); + + if not StyleServices.GetElementContentRect(0, LDetails, DrawRect, ButtonRect) + then + ButtonRect := Rect(0, 0, 0, 0); + +{$IF CompilerVersion > 23.0} + if not StyleServices.HasElementFixedPosition(LDetails) then + CorrectRightButtonRect(ButtonRect); +{$IFEND} + if ButtonRect.Width > 0 then + StyleServices.DrawElement(LBitmap.Canvas.Handle, LDetails, ButtonRect); + if ButtonRect.Left > 0 then + TextRect.Right := ButtonRect.Left; + _FMinButtonRect := ButtonRect; + end; + + if (biHelp in TCustomFormClass(Form).BorderIcons) and + (biSystemMenu in TCustomFormClass(Form).BorderIcons) and + ((not(biMaximize in TCustomFormClass(Form).BorderIcons) and + not(biMinimize in TCustomFormClass(Form).BorderIcons)) or + (Form.BorderStyle = bsDialog)) then + begin + if (_FPressedButton = HTHELP) and (_FHotButton = HTHELP) then + FButtonState := twHelpButtonPushed + else if _FHotButton = HTHELP then + FButtonState := twHelpButtonHot + else if _FFormActive then + FButtonState := twHelpButtonNormal + else + FButtonState := twHelpButtonDisabled; + LDetails := StyleServices.GetElementDetails(FButtonState); + + if not StyleServices.GetElementContentRect(0, LDetails, DrawRect, ButtonRect) + then + ButtonRect := Rect(0, 0, 0, 0); + +{$IF CompilerVersion > 23.0} + if not StyleServices.HasElementFixedPosition(LDetails) then + CorrectRightButtonRect(ButtonRect); +{$IFEND} + if ButtonRect.Width > 0 then + StyleServices.DrawElement(LBitmap.Canvas.Handle, LDetails, ButtonRect); + + if ButtonRect.Left > 0 then + TextRect.Right := ButtonRect.Left; + _FHelpButtonRect := ButtonRect; + end; + + { draw text } + TextFormat := [tfLeft, tfSingleLine, tfVerticalCenter]; + if Control.UseRightToLeftReading then + Include(TextFormat, tfRtlReading); + + LText := Text; + +{$IF CompilerVersion > 23.0} + if (Form.WindowState = wsMaximized) and + (TCustomFormClass(Form).FormStyle <> fsMDIChild) and (TextTopOffset <> 0) + and (biSystemMenu in TCustomFormClass(Form).BorderIcons) then + begin + Inc(TextRect.Left, R.Left); + MoveWindowOrg(LBitmap.Canvas.Handle, 0, TextTopOffset); + StyleServices.DrawText(LBitmap.Canvas.Handle, CaptionDetails, LText, + TextRect, TextFormat); + MoveWindowOrg(LBitmap.Canvas.Handle, 0, -TextTopOffset); + end + else +{$IFEND} + StyleServices.DrawText(LBitmap.Canvas.Handle, CaptionDetails, LText, + TextRect, TextFormat); + _FCaptionRect := TextRect; + + { draw caption buffer } + + if FNCSettings.UseAlpha then + UpdateLayeredWindow(Handle, 0, nil, @LBitmapSize, LBitmap.Canvas.Handle, + @LBitmapPos, 0, @pblend, ULW_ALPHA) + else + Canvas.Draw(0, 0, LBitmap); + + // LBitmap.Free; + { draw menubar } + MainMenuBarHookPaint(Canvas); // doesn't suport alpha for now :( + + { draw left border } + DrawRect := Rect(0, R.Top, R.Left, _FHeight - R.Bottom); + if DrawRect.Bottom - DrawRect.Top > 0 then + // use a color? + if FNCSettings.UseColor then + begin + if FNCSettings.UseAlpha then + begin + LBitmap.Canvas.Brush.Color := FNCSettings.Color; + LBitmap.Canvas.FillRect(DrawRect); + end + else + Begin + Canvas.Brush.Color := FNCSettings.Color; + Canvas.FillRect(DrawRect); + End; + end + else + begin + if FMergeImages then + if (DrawRect.Height <= FSharedBitMap.Height) and + (DrawRect.Width <= FSharedBitMap.Width) then + Canvas.CopyRect(DrawRect, FSharedBitMap.Canvas, DrawRect) + else + Canvas.StretchDraw(DrawRect, FSharedBitMap) + else if (DrawRect.Height <= FNCSettings.Bitmap.Height) and + (DrawRect.Width <= FNCSettings.Bitmap.Width) then + Canvas.CopyRect(DrawRect, FNCSettings.Bitmap.Canvas, DrawRect) + else + Canvas.StretchDraw(DrawRect, FNCSettings.Bitmap); + + end; + + { draw right border } + DrawRect := Rect(_FWidth - R.Right, R.Top, _FWidth, _FHeight - R.Bottom); + + if DrawRect.Bottom - DrawRect.Top > 0 then + // use a color? + if FNCSettings.UseColor then + begin + Canvas.Brush.Color := FNCSettings.Color; + Canvas.FillRect(DrawRect); + end + else + begin + if FMergeImages then + if (DrawRect.Height <= FSharedBitMap.Height) and + (Control.Width <= FSharedBitMap.Width) then + Canvas.CopyRect(DrawRect, FSharedBitMap.Canvas, DrawRect) + else + Canvas.StretchDraw(DrawRect, FSharedBitMap) + else if (DrawRect.Height <= FNCSettings.Bitmap.Height) and + (Control.Width <= FNCSettings.Bitmap.Width) then + Canvas.CopyRect(DrawRect, FNCSettings.Bitmap.Canvas, DrawRect) + else + Canvas.StretchDraw(DrawRect, FNCSettings.Bitmap); + end; + + { draw Bottom border } + DrawRect := Rect(0, _FHeight - R.Bottom, _FWidth, _FHeight); + + if DrawRect.Bottom - DrawRect.Top > 0 then + // use a color? + if FNCSettings.UseColor then + begin + Canvas.Brush.Color := FNCSettings.Color; + Canvas.FillRect(DrawRect); + end + else + begin + if FMergeImages then + if (DrawRect.Height <= FSharedBitMap.Height) and + (Control.Width <= FSharedBitMap.Width) then + Canvas.CopyRect(DrawRect, FSharedBitMap.Canvas, DrawRect) + else + begin + SrcBackRect.Left := 0; + SrcBackRect.Top := 0; + SrcBackRect.Width := DrawRect.Width; + SrcBackRect.Height := DrawRect.Height; + SrcBackRect.SetLocation(FSharedBitMap.Width - DrawRect.Width, 0); + Canvas.CopyRect(DrawRect, FSharedBitMap.Canvas, SrcBackRect); + end + else if (DrawRect.Height <= FNCSettings.Bitmap.Height) and + (Control.Width <= FNCSettings.Bitmap.Width) then + Canvas.CopyRect(DrawRect, FNCSettings.Bitmap.Canvas, DrawRect) + else + begin + SrcBackRect.Left := 0; + SrcBackRect.Top := 0; + SrcBackRect.Width := DrawRect.Width; + SrcBackRect.Height := DrawRect.Height; + SrcBackRect.SetLocation(FNCSettings.Bitmap.Width - DrawRect.Width, 0); + Canvas.CopyRect(DrawRect, FNCSettings.Bitmap.Canvas, SrcBackRect); + end; + end; + + LBitmap.Free; +end; + +{ TFormStyleHookNC } + +constructor TFormStyleHookNC.Create(AControl: TWinControl); +begin + inherited; + OverrideEraseBkgnd := True; +end; + +procedure TFormStyleHookNC.PaintBackground(Canvas: TCanvas); +var + Details: TThemedElementDetails; + R: TRect; +begin + if StyleServices.Available then + begin + Details.Element := teWindow; + Details.Part := 0; + R := Rect(0, 0, Control.ClientWidth, Control.ClientHeight); + StyleServices.DrawElement(Canvas.Handle, Details, R); + end; +end; + +{ TFormStyleHookHelper } + +function TFormStyleHookHelper.GetFCaptionRect: TRect; +begin + with Self do + Result := FCaptionRect; +end; + +function TFormStyleHookHelper.GetFChangeSizeCalled: Boolean; +begin + with Self do + Result := FChangeSizeCalled; +end; + +function TFormStyleHookHelper.GetFCloseButtonRect: TRect; +begin + with Self do + Result := FCloseButtonRect; +end; + +function TFormStyleHookHelper.GetFFormActive: Boolean; +begin + with Self do + Result := FFormActive; +end; + +function TFormStyleHookHelper.GetFHeight: Integer; +begin + with Self do + Result := FHeight; +end; + +function TFormStyleHookHelper.GetFHelpButtonRect: TRect; +begin + with Self do + Result := FHelpButtonRect; +end; + +function TFormStyleHookHelper.GetFHotButton: Integer; +begin + with Self do + Result := FHotButton; +end; + +function TFormStyleHookHelper.GetFLeft: Integer; +begin + with Self do + Result := FLeft; +end; + +function TFormStyleHookHelper.GetFMaxButtonRect: TRect; +begin + with Self do + Result := FMaxButtonRect; +end; + +function TFormStyleHookHelper.GetFMinButtonRect: TRect; +begin + with Self do + Result := FMinButtonRect; +end; + +function TFormStyleHookHelper.GetForm: TCustomForm; +begin + with Self do + Result := Form; +end; + +function TFormStyleHookHelper.GetFPressedButton: Integer; +begin + with Self do + Result := FPressedButton; +end; + +function TFormStyleHookHelper.GetFRegion: HRGN; +begin + with Self do + Result := FRegion; +end; + +function TFormStyleHookHelper.GetFSysMenuButtonRect: TRect; +begin + with Self do + Result := FSysMenuButtonRect; +end; + +function TFormStyleHookHelper.GetFTop: Integer; +begin + with Self do + Result := FTop; +end; + +function TFormStyleHookHelper.GetFWidth: Integer; +begin + with Self do + Result := FWidth; +end; + +procedure TFormStyleHookHelper.MainMenuBarHookPaint(Canvas: TCanvas); +begin + with Self do + if (FMainMenuBarHook <> nil) then + FMainMenuBarHook.Paint(Canvas); +end; + +procedure TFormStyleHookHelper.SetFCaptionRect(const Value: TRect); +begin + with Self do + FCaptionRect := Value; +end; + +procedure TFormStyleHookHelper.SetFChangeSizeCalled(const Value: Boolean); +begin + with Self do + FChangeSizeCalled := Value; +end; + +procedure TFormStyleHookHelper.SetFCloseButtonRect(const Value: TRect); +begin + with Self do + FCloseButtonRect := Value; +end; + +procedure TFormStyleHookHelper.SetFHeight(const Value: Integer); +begin + with Self do + FHeight := Value; +end; + +procedure TFormStyleHookHelper.SetFHelpButtonRect(const Value: TRect); +begin + with Self do + FHelpButtonRect := Value; +end; + +procedure TFormStyleHookHelper.SetFLeft(const Value: Integer); +begin + with Self do + FLeft := Value; +end; + +procedure TFormStyleHookHelper.SetFMaxButtonRect(const Value: TRect); +begin + with Self do + FMaxButtonRect := Value; +end; + +procedure TFormStyleHookHelper.SetFMinButtonRect(const Value: TRect); +begin + with Self do + FMinButtonRect := Value; +end; + +procedure TFormStyleHookHelper.SetFRegion(const Value: HRGN); +begin + with Self do + FRegion := Value; +end; + +procedure TFormStyleHookHelper.SetFSysMenuButtonRect(const Value: TRect); +begin + with Self do + FSysMenuButtonRect := Value; +end; + +procedure TFormStyleHookHelper.SetFTop(const Value: Integer); +begin + with Self do + FTop := Value; +end; + +procedure TFormStyleHookHelper.SetFWidth(const Value: Integer); +begin + with Self do + FWidth := Value; +end; + +procedure TFormStyleHookHelper._ChangeSize; +begin + with Self do + ChangeSize; +end; + +function TFormStyleHookHelper._GetBorderSize{$IF CompilerVersion >= 36}(UseActiveStyle: Boolean = True){$IFEND}: TRect; +begin + with Self do + Result := GetBorderSize; +end; + +function TFormStyleHookHelper._GetBorderSizeAddr: Pointer; +var + MethodAddr: function{$IF CompilerVersion >= 36}(UseActiveStyle: Boolean = True){$IFEND}: TRect of object; +begin + with Self do + MethodAddr := GetBorderSize; + Result := TMethod(MethodAddr).Code; +end; + + +function TFormStyleHookHelper._GetRegionAddr: Pointer; +var + MethodAddr: function: HRGN of object; +begin + with Self do + MethodAddr := GetRegion; + Result := TMethod(MethodAddr).Code; +end; + +function TFormStyleHookHelper._GetHitTest(P: TPoint): Integer; +begin + with Self do + Result := GetHitTest(P); +end; + +function TFormStyleHookHelper._GetIconFast: TIcon; +begin + with Self do + Result := GetIconFast; +end; + +function TFormStyleHookHelper._NormalizePoint(P: TPoint): TPoint; +begin + with Self do + Result := NormalizePoint(P); +end; + + +end. diff --git a/source/vcl-styles-utils/Vcl.Styles.Hooks.pas b/source/vcl-styles-utils/Vcl.Styles.Hooks.pas index aaeaa90f7..43fbf00aa 100644 --- a/source/vcl-styles-utils/Vcl.Styles.Hooks.pas +++ b/source/vcl-styles-utils/Vcl.Styles.Hooks.pas @@ -1,900 +1,876 @@ -// ************************************************************************************************** -// -// Unit Vcl.Styles.Hooks -// unit for the VCL Styles Utils -// https://github.com/RRUZ/vcl-styles-utils/ -// -// 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. -// -// The Original Code is Vcl.Styles.Hooks.pas. -// -// The Initial Developer of the Original Code is Rodrigo Ruz V. -// -// Portions created by Rodrigo Ruz V. are Copyright (C) 2013-2019 Rodrigo Ruz V. -// -// Contributor(s): Mahdi Safsafi. -// -// All Rights Reserved. -// -// ************************************************************************************************** -unit Vcl.Styles.Hooks; - -interface - -uses - WinApi.Windows; - -implementation - -{$I VCL.Styles.Utils.inc} - -uses - DDetours, - System.SyncObjs, - System.SysUtils, - System.Types, - System.UITypes, - System.Classes, - System.Generics.Collections, - System.StrUtils, - WinApi.Messages, - WinApi.UXTheme, - Vcl.Graphics, - Vcl.Styles.Utils.Graphics, - {$IFDEF HOOK_UXTHEME} - Vcl.Styles.UxTheme, - {$ENDIF HOOK_UXTHEME} - Vcl.Styles.Utils.SysControls, - Vcl.Styles.FontAwesome, - Vcl.Forms, - Vcl.Controls, - Vcl.StdCtrls, - Vcl.ComCtrls, - Vcl.Themes, - Vcl.Styles.Utils.Misc; - -type - TListStyleBrush = class(TDictionary) - protected - procedure ValueNotify(const Value: HBRUSH; Action: TCollectionNotification); override; - end; - - TSetStyle = procedure(Style: TCustomStyleServices) of object; - TMonthCalendarClass = class(TMonthCalendar); - TCommonCalendarClass = class(TCommonCalendar); - -var - VCLStylesBrush: TObjectDictionary; - VCLStylesLock: TCriticalSection = nil; - LSetStylePtr: TSetStyle; - - Trampoline_SetStyle : procedure(Self: TObject; Style: TCustomStyleServices); - Trampoline_user32_FillRect : function(hDC: hDC; const lprc: TRect; hbr: HBRUSH): Integer; stdcall; - Trampoline_user32_DrawEdge : function(hDC: hDC; var qrc: TRect; edge: UINT; grfFlags: UINT): BOOL; stdcall = nil; - Trampoline_user32_DrawFrameControl : function (DC: HDC; Rect: PRect; uType, uState: UINT): BOOL; stdcall = nil; - Trampoline_user32_LoadIconW : function (hInstance: HINST; lpIconName: PWideChar): HICON; stdcall = nil; - Trampoline_user32_GetSysColorBrush: function(nIndex: Integer): HBRUSH; stdcall; - {$IFDEF HOOK_UXTHEME} - Trampoline_user32_LoadImageW: function (hInst: HINST; ImageName: LPCWSTR; ImageType: UINT; X, Y: Integer; Flags: UINT): THandle; stdcall = nil; - {$ELSE} - Trampoline_user32_GetSysColor: function(nIndex: Integer): DWORD; stdcall; - {$ENDIF HOOK_UXTHEME} - -{$IFDEF HOOK_TDateTimePicker} - {$IF CompilerVersion>=29} - Trampoline_SetWindowTheme: function(hwnd: HWND; pszSubAppName: LPCWSTR; pszSubIdList: LPCWSTR): HRESULT; stdcall; - {$IFEND CompilerVersion} -{$ENDIF HOOK_TDateTimePicker} - - -function Detour_DrawEdge(hDC: hDC; var qrc: TRect; edge: UINT; grfFlags: UINT): BOOL; stdcall; -var - CanDraw: Boolean; - SaveIndex: Integer; -begin - if not(ExecutingInMainThread) then - Exit(Trampoline_user32_DrawEdge(hDC, qrc, edge, grfFlags)); - - CanDraw := (not StyleServices.IsSystemStyle) and (TSysStyleManager.Enabled); - if (CanDraw) and (edge <> BDR_OUTER) and (edge <> BDR_INNER) then - begin - SaveIndex := SaveDC(hDC); - try - DrawStyleEdge(hDC, qrc, TStyleElementEdges(edge), TStyleElementEdgeFlags(grfFlags)); - finally - RestoreDC(hDC, SaveIndex); - end; - Exit(True); - end; - Exit(Trampoline_user32_DrawEdge(hDC, qrc, edge, grfFlags)); -end; - -function Detour_FillRect(hDC: hDC; const lprc: TRect; hbr: HBRUSH): Integer; stdcall; -begin - if not(ExecutingInMainThread) or StyleServices.IsSystemStyle or not(TSysStyleManager.Enabled) then - Exit(Trampoline_user32_FillRect(hDC, lprc, hbr)) - else if (hbr > 0) and (hbr < COLOR_ENDCOLORS + 1) then - Exit(Trampoline_user32_FillRect(hDC, lprc, GetSysColorBrush(hbr - 1))) - else - Exit(Trampoline_user32_FillRect(hDC, lprc, hbr)); -end; - -function Detour_GetSysColor(nIndex: Integer): DWORD; stdcall; -begin - if not(ExecutingInMainThread) or StyleServices.IsSystemStyle or not(TSysStyleManager.Enabled) then - Result := Trampoline_user32_GetSysColor(nIndex) - else if nIndex = COLOR_HOTLIGHT then - Result := DWORD(StyleServices.GetSystemColor(clHighlight)) - else - Result := DWORD(StyleServices.GetSystemColor(TColor(nIndex or Integer($FF000000)))); -end; - -function Detour_GetSysColorBrush(nIndex: Integer): HBRUSH; stdcall; -var - LCurrentStyleBrush: TListStyleBrush; - LBrush: HBRUSH; - LColor: TColor; -begin - if not(ExecutingInMainThread) then - Exit(Trampoline_user32_GetSysColorBrush(nIndex)); - - { - The reason to change the previous code implementation - is that the win32 graphics may differ with the VCL graphics: - Eg: TColor is signed in VCL and Unsigned in Win32Api. - When hooking : keep always using the native way ! - Need Color ? - Use GetObject with LOGBRUSH ! or use TBrushColorPair ! - } - VCLStylesLock.Enter; - try - if StyleServices.IsSystemStyle or not TSysStyleManager.Enabled then - Exit(Trampoline_user32_GetSysColorBrush(nIndex)) - else - begin - if VCLStylesBrush.ContainsKey(StyleServices.Name) then - LCurrentStyleBrush := VCLStylesBrush.Items[StyleServices.Name] - else - begin - VCLStylesBrush.Add(StyleServices.Name, TListStyleBrush.Create()); - LCurrentStyleBrush := VCLStylesBrush.Items[StyleServices.Name]; - end; - if Assigned(LCurrentStyleBrush) then - begin - if LCurrentStyleBrush.ContainsKey(nIndex) then - Exit(LCurrentStyleBrush[nIndex]) - else - begin - if nIndex = COLOR_HOTLIGHT then - LColor := StyleServices.GetSystemColor(clHighlight) - else - LColor := StyleServices.GetSystemColor(TColor(nIndex or Integer($FF000000))); - - LBrush := CreateSolidBrush(LColor); - LCurrentStyleBrush.Add(nIndex, LBrush); - Exit(LBrush); - end; - end; - Exit(Trampoline_user32_GetSysColorBrush(nIndex)); - end; - finally - VCLStylesLock.Leave; - end; -end; - -procedure Detour_SetStyle(Self: TObject; Style: TCustomStyleServices); -var - I: Integer; - LActiveStyle: TCustomStyleServices; -begin - if not(ExecutingInMainThread) then - begin - Trampoline_SetStyle(Self, Style); - exit; - end; - - LActiveStyle := TStyleManager.ActiveStyle; - Trampoline_SetStyle(Self, Style); - if (Style <> LActiveStyle) then - begin - for I := 0 to Screen.FormCount - 1 do - if Screen.Forms[I].HandleAllocated then - SendMessage(Screen.Forms[I].Handle, WM_SYSCOLORCHANGE, 0, 0); - end; -end; - -//based on JvThemes.DrawThemedFrameControl -function Detour_WinApi_DrawFrameControl(DC: HDC; Rect: PRect; uType, uState: UINT): BOOL; stdcall; -const - Mask = $00FF; -var - LRect: TRect; - LDetails: TThemedElementDetails; - CanDraw : Boolean; - - LThemedButton: TThemedButton; - LThemedComboBox: TThemedComboBox; - LThemedScrollBar: TThemedScrollBar; -begin - if not(ExecutingInMainThread) then - Exit(Trampoline_user32_DrawFrameControl(DC, Rect, uType, uState)); - - Result := False; - CanDraw:= (not StyleServices.IsSystemStyle) and (TSysStyleManager.Enabled) and (Rect <> nil); - if CanDraw then - begin - LRect := Rect^; - case uType of - DFC_BUTTON: - case uState and Mask of - - DFCS_BUTTONPUSH: - begin - if uState and (DFCS_TRANSPARENT or DFCS_FLAT) = 0 then - begin - if uState and DFCS_INACTIVE <> 0 then - LThemedButton := tbPushButtonDisabled - else - if uState and DFCS_PUSHED <> 0 then - LThemedButton := tbPushButtonPressed - else - if uState and DFCS_HOT <> 0 then - LThemedButton := tbPushButtonHot - else - if uState and DFCS_MONO <> 0 then - LThemedButton := tbPushButtonDefaulted - else - LThemedButton := tbPushButtonNormal; - - LDetails := StyleServices.GetElementDetails(LThemedButton); - StyleServices.DrawElement(DC, LDetails, LRect); - Result := True; - end; - end; - - DFCS_BUTTONCHECK: - begin - if uState and DFCS_CHECKED <> 0 then - begin - if uState and DFCS_INACTIVE <> 0 then - LThemedButton := tbCheckBoxCheckedDisabled - else - if uState and DFCS_PUSHED <> 0 then - LThemedButton := tbCheckBoxCheckedPressed - else - if uState and DFCS_HOT <> 0 then - LThemedButton := tbCheckBoxCheckedHot - else - LThemedButton := tbCheckBoxCheckedNormal; - end - else - if uState and DFCS_MONO <> 0 then - begin - if uState and DFCS_INACTIVE <> 0 then - LThemedButton := tbCheckBoxMixedDisabled - else - if uState and DFCS_PUSHED <> 0 then - LThemedButton := tbCheckBoxMixedPressed - else - if uState and DFCS_HOT <> 0 then - LThemedButton := tbCheckBoxMixedHot - else - LThemedButton := tbCheckBoxMixedNormal; - end - else - begin - if uState and DFCS_INACTIVE <> 0 then - LThemedButton := tbCheckBoxUncheckedDisabled - else - if uState and DFCS_PUSHED <> 0 then - LThemedButton := tbCheckBoxUncheckedPressed - else - if uState and DFCS_HOT <> 0 then - LThemedButton := tbCheckBoxUncheckedHot - else - LThemedButton := tbCheckBoxUncheckedNormal; - end; - LDetails := StyleServices.GetElementDetails(LThemedButton); - StyleServices.DrawElement(DC, LDetails, LRect); - Result := True; - end; - - DFCS_BUTTONRADIO: - begin - if uState and DFCS_CHECKED <> 0 then - begin - if uState and DFCS_INACTIVE <> 0 then - LThemedButton := tbRadioButtonCheckedDisabled - else - if uState and DFCS_PUSHED <> 0 then - LThemedButton := tbRadioButtonCheckedPressed - else - if uState and DFCS_HOT <> 0 then - LThemedButton := tbRadioButtonCheckedHot - else - LThemedButton := tbRadioButtonCheckedNormal; - end - else - begin - if uState and DFCS_INACTIVE <> 0 then - LThemedButton := tbRadioButtonUncheckedDisabled - else - if uState and DFCS_PUSHED <> 0 then - LThemedButton := tbRadioButtonUncheckedPressed - else - if uState and DFCS_HOT <> 0 then - LThemedButton := tbRadioButtonUncheckedHot - else - LThemedButton := tbRadioButtonUncheckedNormal; - end; - LDetails := StyleServices.GetElementDetails(LThemedButton); - StyleServices.DrawElement(DC, LDetails, LRect); - Result := True; - end; - end; - - DFC_SCROLL: - begin - case uState and Mask of - - DFCS_SCROLLCOMBOBOX: - begin - if uState and DFCS_INACTIVE <> 0 then - LThemedComboBox := tcDropDownButtonDisabled - else - if uState and DFCS_PUSHED <> 0 then - LThemedComboBox := tcDropDownButtonPressed - else - if uState and DFCS_HOT <> 0 then - LThemedComboBox := tcDropDownButtonHot - else - LThemedComboBox := tcDropDownButtonNormal; - - LDetails := StyleServices.GetElementDetails(LThemedComboBox); - StyleServices.DrawElement(DC, LDetails, LRect); - Result := True; - end; - - DFCS_SCROLLUP: - if uState and (DFCS_TRANSPARENT {or DFCS_FLAT}) = 0 then - begin - if uState and DFCS_INACTIVE <> 0 then - LThemedScrollBar := tsArrowBtnUpDisabled - else - if uState and DFCS_PUSHED <> 0 then - LThemedScrollBar := tsArrowBtnUpPressed - else - if uState and DFCS_HOT <> 0 then - LThemedScrollBar := tsArrowBtnUpHot - else - LThemedScrollBar := tsArrowBtnUpNormal; - - LDetails := StyleServices.GetElementDetails(LThemedScrollBar); - StyleServices.DrawElement(DC, LDetails, LRect); - Result := True; - end; - - DFCS_SCROLLDOWN: - if uState and (DFCS_TRANSPARENT {or DFCS_FLAT}) = 0 then - begin - if uState and DFCS_INACTIVE <> 0 then - LThemedScrollBar := tsArrowBtnDownDisabled - else - if uState and DFCS_PUSHED <> 0 then - LThemedScrollBar := tsArrowBtnDownPressed - else - if uState and DFCS_HOT <> 0 then - LThemedScrollBar := tsArrowBtnDownHot - else - LThemedScrollBar := tsArrowBtnDownNormal; - - LDetails := StyleServices.GetElementDetails(LThemedScrollBar); - StyleServices.DrawElement(DC, LDetails, LRect); - Result := True; - end; - - DFCS_SCROLLLEFT: - if uState and (DFCS_TRANSPARENT {or DFCS_FLAT}) = 0 then - begin - if uState and DFCS_INACTIVE <> 0 then - LThemedScrollBar := tsArrowBtnLeftDisabled - else - if uState and DFCS_PUSHED <> 0 then - LThemedScrollBar := tsArrowBtnLeftPressed - else - if uState and DFCS_HOT <> 0 then - LThemedScrollBar := tsArrowBtnLeftHot - else - LThemedScrollBar := tsArrowBtnLeftNormal; - - LDetails := StyleServices.GetElementDetails(LThemedScrollBar); - StyleServices.DrawElement(DC, LDetails, LRect); - Result := True; - end; - - DFCS_SCROLLRIGHT: - if uState and (DFCS_TRANSPARENT {or DFCS_FLAT}) = 0 then - begin - if uState and DFCS_INACTIVE <> 0 then - LThemedScrollBar := tsArrowBtnRightDisabled - else - if uState and DFCS_PUSHED <> 0 then - LThemedScrollBar := tsArrowBtnRightPressed - else - if uState and DFCS_HOT <> 0 then - LThemedScrollBar := tsArrowBtnRightHot - else - LThemedScrollBar := tsArrowBtnRightNormal; - - LDetails := StyleServices.GetElementDetails(LThemedScrollBar); - StyleServices.DrawElement(DC, LDetails, LRect); - Result := True; - end; - - end; - end; - end; - end; - - if not Result then - Exit(Trampoline_user32_DrawFrameControl(DC, Rect, uType, uState)); -end; - -function GetStyleHighLightColor : TColor; -begin - if ColorIsBright(StyleServices.GetSystemColor(clBtnFace)) or not ColorIsBright(StyleServices.GetSystemColor(clHighlight)) then - Result := StyleServices.GetSystemColor(clBtnText) - else - Result := StyleServices.GetSystemColor(clHighlight); -end; - -function Detour_LoadIconW(_hInstance: HINST; lpIconName: PWideChar): HICON; stdcall; -var - s : string; - LIcon : TIcon; - LHandle : THandle; - MustRelease : Boolean; - - procedure DrawIcon(const ACode: Word); - begin - //DestroyIcon(LHandle); - Result := FontAwesome.GetIcon(ACode, LIcon.Width, LIcon.Height, GetStyleHighLightColor, StyleServices.GetSystemColor(clBtnFace), 0); - MustRelease:=False; - end; - -begin - if not(ExecutingInMainThread) or - StyleServices.IsSystemStyle or - not(TSysStyleManager.Enabled) or - not(TSysStyleManager.HookDialogIcons) then - Exit(Trampoline_user32_LoadIconW(_hInstance, lpIconName)); - - if {(_hInstance>0) and (_hInstance<>HInstance) and} IS_INTRESOURCE(lpIconName) then - begin - LIcon := TIcon.Create; - try - MustRelease := True; - LHandle := Trampoline_user32_LoadIconW(_hInstance, lpIconName); - LIcon.Handle := LHandle; - Result := LHandle; - s := IntToStr(NativeUInt(lpIconName)); - - //OutputDebugString(PChar('Detour_LoadIconW '+s+ ' Module Name '+GetModuleName(_hInstance)+' _hInstance '+IntToHex(_hInstance, 8) )); - case NativeUInt(lpIconName) of - 78: DrawIcon(fa_shield); - 81: DrawIcon(fa_info_circle); - 84: DrawIcon(fa_warning); - 98: DrawIcon(fa_minus_circle); - 99: DrawIcon(fa_question_circle); - end; - - if _hInstance=0 then - case NativeUInt(lpIconName) of - 32518 : DrawIcon(fa_shield); - 32516 : DrawIcon(fa_info_circle); - 32515 : DrawIcon(fa_warning); - 32513 : DrawIcon(fa_minus_circle); - 32514 : DrawIcon(fa_question_circle); - 32517 : DrawIcon(fa_windows); - end; - - finally - if MustRelease then - LIcon.ReleaseHandle; - LIcon.Free; - end; - end - else - Exit(Trampoline_user32_LoadIconW(_hInstance, lpIconName)); -end; - -{$IFDEF HOOK_UXTHEME} -function Detour_LoadImageW(hInst: HINST; ImageName: LPCWSTR; ImageType: UINT; X, Y: Integer; Flags: UINT): THandle; stdcall; -const - ExplorerFrame = 'explorerframe.dll'; -var - hModule : WinApi.Windows.HMODULE; - LBitmap : TBitmap; - s : string; - LRect, LRect2 : TRect; - LBackColor, LColor : TColor; -begin - if not(ExecutingInMainThread) or StyleServices.IsSystemStyle or not(TSysStyleManager.Enabled) then - Exit(Trampoline_user32_LoadImageW(hInst, ImageName, ImageType, X, Y, Flags)); - - //w8 - W10 - if (hInst > 0) and (hInst <> HInstance) and (ImageType = IMAGE_ICON) and (X = 16) and (Y = 16) and IS_INTRESOURCE(ImageName) and TOSVersion.Check(6, 2) then - begin - s := IntToStr(NativeUInt(ImageName)); - - case NativeUInt(ImageName) of - //W8, W10 - //comctl32.dll - 16817: - begin - Exit(FontAwesome.GetIcon(fa_arrow_up, X, Y, StyleServices.GetSystemColor(clBtnText), StyleServices.GetSystemColor(clBtnFace), 0)); - end; - 16818: - begin - Exit(FontAwesome.GetIcon(fa_arrow_up, X, Y, StyleServices.GetSystemColor(clGrayText), StyleServices.GetSystemColor(clBtnFace), 0)); - end; - //W10 - //shell32.dll - 5100: - begin - //OutputDebugString(PChar('GetModuleName ' + GetModuleName(hInst))); - Exit(FontAwesome.GetIcon(fa_thumb_tack, 16, 16, 12, 12, StyleServices.GetSystemColor(clGrayText), StyleServices.GetSystemColor(clWindow), -22, iaRight)); - //Exit(FontAwesome.GetIcon(fa_check_square_o, 16, 16, StyleServices.GetSystemColor(clWindowText), StyleServices.GetSystemColor(clWindow), 0)); - end; - end; - Exit(Trampoline_user32_LoadImageW(hInst, ImageName, ImageType, X, Y, Flags)); - end - else - if (hInst > 0) and (ImageType = IMAGE_BITMAP) and (X = 0) and (Y = 0) and IS_INTRESOURCE(ImageName) then - begin - hModule := GetModuleHandle(ExplorerFrame); - if (hModule = hInst) then - begin - s := IntToStr(NativeUInt(ImageName)); - Result := Trampoline_user32_LoadImageW(hInst, ImageName, ImageType, X, Y, Flags); - LBitmap := TBitmap.Create; - try - LBitmap.Handle := Result; - //LBitmap.SaveToFile(IncludeTrailingPathDelimiter(ExtractFilePath(ParamStr(0)))+s+'.bmp');//SaveToFile('C:\Users\Rodrigo\Desktop\vcl-styles-utils\Vcl Styles Utils New Dialogs (Demo App)\Win32\Debug\Images\'+s+'.bmp'); - - //W8 - W10 - if TOSVersion.Check(6, 2) then - begin - LBackColor := StyleServices.GetSystemColor(clWindow); - LRect := Rect(0, 0, LBitmap.Width, LBitmap.Height ); - case NativeUInt(ImageName) of - // Right Arrow, cross button, refresh, down arrow - 288: - begin - LColor := StyleServices.GetSystemColor(clBtnText); - Bitmap32_SetAlphaAndColor(LBitmap, 1, LBackColor); - - LRect := Rect(0, 0, 16, 16); - FontAwesome.DrawChar(LBitmap.Canvas.Handle, fa_arrow_right, LRect, LColor); - - OffsetRect(LRect, 16, 0); - FontAwesome.DrawChar(LBitmap.Canvas.Handle, fa_remove, LRect, LColor); - - OffsetRect(LRect, 16, 0); - LRect2 := LRect; - InflateRect(LRect2, -2, -2); - FontAwesome.DrawChar(LBitmap.Canvas.Handle, fa_refresh, LRect2, LColor); - - OffsetRect(LRect, 16 + 2, 0); - LRect2 := LRect; - InflateRect(LRect2, -2, -2); - FontAwesome.DrawChar(LBitmap.Canvas.Handle, fa_caret_down, LRect2, LColor); - - Bitmap32_SetAlphaExceptColor(LBitmap, 255, LBackColor); - end; - else - begin - Bitmap32_Grayscale(LBitmap); - _ProcessBitmap32(LBitmap, StyleServices.GetSystemColor(clHighlight), _BlendBurn) - end; - end; - end - else - //Windows Vista - W7 - if (TOSVersion.Major = 6) and ((TOSVersion.Minor = 0) or (TOSVersion.Minor = 1)) then - begin - LBackColor := StyleServices.GetSystemColor(clWindow); - LRect := Rect(0, 0, LBitmap.Width, LBitmap.Height ); - case NativeUInt(ImageName) of - //Magnifier - 34560..34562, // Aero Enabled - 34563..34568: // Classic Theme - begin - LColor := StyleServices.GetSystemColor(clHighlight); - Bitmap32_SetAlphaAndColor(LBitmap, 1, LBackColor); - FontAwesome.DrawChar(LBitmap.Canvas.Handle, fa_search, LRect, LColor); - Bitmap32_SetAlphaExceptColor(LBitmap, 255, LBackColor); - //Bitmap32_SetAlphaByColor(LBitmap, 255, LColor); - end; - - //cross button normal - 34569..34571, // Aero Enabled - 34572..34574: // Classic Theme - begin - LColor:= StyleServices.GetSystemColor(clWindowText); - Bitmap32_SetAlphaAndColor(LBitmap, 1, LBackColor); - FontAwesome.DrawChar(LBitmap.Canvas.Handle, fa_remove, LRect, LColor); - Bitmap32_SetAlphaExceptColor(LBitmap, 255, LBackColor); - end; - - //cross button hot - 34575..34577, // Aero Enabled - 34581..34583, // Aero Enabled - 34578..34580: // Classic Theme - begin - LColor := StyleServices.GetSystemColor(clHighlight); - Bitmap32_SetAlphaAndColor(LBitmap, 1, LBackColor); - FontAwesome.DrawChar(LBitmap.Canvas.Handle, fa_remove, LRect, LColor); - Bitmap32_SetAlphaExceptColor(LBitmap, 255, LBackColor); - end; - - // Aero Enabled - // Right Arrow, cross button, refresh, down arrow - 288: - begin - LColor := StyleServices.GetSystemColor(clBtnText); - Bitmap32_SetAlphaAndColor(LBitmap, 1, LBackColor); - - LRect:=Rect(0, 0, 16, 16); - FontAwesome.DrawChar(LBitmap.Canvas.Handle, fa_arrow_right, LRect, LColor); - - OffsetRect(LRect, 16, 0); - FontAwesome.DrawChar(LBitmap.Canvas.Handle, fa_remove, LRect, LColor); - - OffsetRect(LRect, 16, 0); - FontAwesome.DrawChar(LBitmap.Canvas.Handle, fa_refresh, LRect, LColor); - - OffsetRect(LRect, 16, 0); - FontAwesome.DrawChar(LBitmap.Canvas.Handle, fa_caret_down, LRect, LColor); - - Bitmap32_SetAlphaExceptColor(LBitmap, 255, LBackColor); - end; - - // Classic Theme - // Right Arrow, cross button, refresh, down arrow - 289, 290: - begin - LColor := StyleServices.GetSystemColor(clBtnText); - Bitmap32_SetAlphaAndColor(LBitmap, 1, LBackColor); - - LRect:=Rect(0, 0, 21, 21); - FontAwesome.DrawChar(LBitmap.Canvas.Handle, fa_arrow_right, LRect, LColor); - - OffsetRect(LRect, 21, 0); - FontAwesome.DrawChar(LBitmap.Canvas.Handle, fa_remove, LRect, LColor); - - OffsetRect(LRect, 21, 0); - FontAwesome.DrawChar(LBitmap.Canvas.Handle, fa_refresh, LRect, LColor); - - OffsetRect(LRect, 21, 0); - FontAwesome.DrawChar(LBitmap.Canvas.Handle, fa_caret_down, LRect, LColor); - - Bitmap32_SetAlphaExceptColor(LBitmap, 255, LBackColor); - end; - - // Aero Enabled - // navigation buttons (arrows) - 577..579, - 581: - begin - case NativeUInt(ImageName) of - 577 : LColor := StyleServices.GetSystemColor(clBtnText); - 578 : LColor := StyleServices.GetSystemColor(clHighlight); - 579 : LColor := StyleServices.GetSystemColor(clGrayText); - 581 : LColor := StyleServices.GetSystemColor(clBtnText); - else - LColor:= StyleServices.GetSystemColor(clBtnText); - end; - - Bitmap32_SetAlphaAndColor(LBitmap, 1, LBackColor); - - LRect := Rect(0, 0, 27, 27); - InflateRect(LRect, -4, -4); - FontAwesome.DrawChar(LBitmap.Canvas.Handle, fa_arrow_left, LRect, LColor); - OffsetRect(LRect, 27 + 4, 0); - FontAwesome.DrawChar(LBitmap.Canvas.Handle, fa_arrow_right, LRect, LColor); - - Bitmap32_SetAlphaExceptColor(LBitmap, 255, LBackColor); - end; - - //Classic Theme - // navigation buttons (arrows) - 582..584: - begin - case NativeUInt(ImageName) of - 582 : LColor := StyleServices.GetSystemColor(clBtnText); - 583 : LColor := StyleServices.GetSystemColor(clHighlight); - 584 : LColor := StyleServices.GetSystemColor(clGrayText); - else - LColor := StyleServices.GetSystemColor(clBtnText); - end; - - Bitmap32_SetAlphaAndColor(LBitmap, 1, LBackColor); - - //left arrow - LRect := Rect(0, 0, 25, 25); - InflateRect(LRect, -4, -4); - FontAwesome.DrawChar(LBitmap.Canvas.Handle, fa_arrow_left, LRect, LColor); - - //right arrow - OffsetRect(LRect, 25 + 4, 0); - FontAwesome.DrawChar(LBitmap.Canvas.Handle, fa_arrow_right, LRect, LColor); - - //dropdown arrow - LRect := Rect(60, 8, 72, 20); - FontAwesome.DrawChar(LBitmap.Canvas.Handle, fa_caret_down, LRect, LColor); - - - Bitmap32_SetAlphaExceptColor(LBitmap, 255, LBackColor); - end; - - //Aero Enabled - //background navigation buttons - 280: - begin - Bitmap32_SetAlphaAndColor(LBitmap, 1, LBackColor); - - LRect := Rect(0, 8, 12, 20); - LColor := StyleServices.GetSystemColor(clGrayText); - OffsetRect(LRect, 58, 0); - FontAwesome.DrawChar(LBitmap.Canvas.Handle, fa_caret_down, LRect, LColor); - - LColor := StyleServices.GetSystemColor(clBtnText); - OffsetRect(LRect, 70, 0); - FontAwesome.DrawChar(LBitmap.Canvas.Handle, fa_caret_down, LRect, LColor); - - LColor := StyleServices.GetSystemColor(clHighlight); - OffsetRect(LRect, 70, 0); - FontAwesome.DrawChar(LBitmap.Canvas.Handle, fa_caret_down, LRect, LColor); - - LColor := StyleServices.GetSystemColor(clHighlight); - OffsetRect(LRect, 70, 0); - FontAwesome.DrawChar(LBitmap.Canvas.Handle, fa_caret_down, LRect, LColor); - - Bitmap32_SetAlphaExceptColor(LBitmap, 255, LBackColor); - end; - - //Classic Theme - //background navigation buttons - 281: - begin - Bitmap32_SetAlphaAndColor(LBitmap, 1, LBackColor); - end; - end; - end; - LBitmap.ReleaseHandle; - finally - LBitmap.Free; - end; - //OutputDebugString(PChar(Format('Detour_LoadImageW ImageName %s', [s]))); - Exit(Result); - end; - end; - - Exit(Trampoline_user32_LoadImageW(hInst, ImageName, ImageType, X, Y, Flags)); -end; -{$ENDIF HOOK_UXTHEME} - - -{$IFDEF HOOK_TDateTimePicker} - {$IF CompilerVersion>=29} - function Detour_SetWindowTheme(hwnd: HWND; pszSubAppName: LPCWSTR; pszSubIdList: LPCWSTR): HRESULT; stdcall; - var - LControl : TWinControl; - begin - if not(ExecutingInMainThread) then - Exit(Trampoline_SetWindowTheme(hwnd, pszSubAppName, pszSubIdList)); - - LControl:= FindControl(hwnd); - if (pszSubAppName = '') and (pszSubIdList = '') and TStyleManager.IsCustomStyleActive and (LControl<>nil) and (LControl is TMonthCalendar) then - Exit(S_OK) - else - Exit(Trampoline_SetWindowTheme(hwnd, pszSubAppName, pszSubIdList)); - end; - {$IFEND CompilerVersion} -{$ENDIF HOOK_TDateTimePicker} - - -//don't hook CreateSolidBrush, because is used internally by GetSysColorBrush -//don't hook CopyImage - -{ TListStyleBrush } - -//Delete brushes -procedure TListStyleBrush.ValueNotify(const Value: HBRUSH; Action: TCollectionNotification); -begin - inherited; - if Action = TCollectionNotification.cnRemoved then - DeleteObject(Value); -end; - -const - themelib = 'uxtheme.dll'; - -initialization - - VCLStylesLock := TCriticalSection.Create; - VCLStylesBrush := TObjectDictionary.Create([doOwnsValues]); - -if StyleServices.Available then -begin - -{$IFDEF HOOK_TDateTimePicker} - TCustomStyleEngine.RegisterStyleHook(TDateTimePicker, TStyleHook); -{$ENDIF HOOK_TDateTimePicker} - - -{$IFDEF HOOK_TProgressBar} - TCustomStyleEngine.RegisterStyleHook(TProgressBar, TStyleHook); -{$ENDIF HOOK_TProgressBar} - LSetStylePtr := TStyleManager.SetStyle; - - BeginHooks; - @Trampoline_user32_GetSysColor := InterceptCreate(user32, 'GetSysColor', @Detour_GetSysColor); - @Trampoline_user32_GetSysColorBrush := InterceptCreate(user32, 'GetSysColorBrush', @Detour_GetSysColorBrush); - @Trampoline_user32_FillRect := InterceptCreate(user32, 'FillRect', @Detour_FillRect); - @Trampoline_user32_DrawEdge := InterceptCreate(user32, 'DrawEdge', @Detour_DrawEdge); - @Trampoline_user32_DrawFrameControl := InterceptCreate(user32, 'DrawFrameControl', @Detour_WinApi_DrawFrameControl); - @Trampoline_user32_LoadIconW := InterceptCreate(user32, 'LoadIconW', @Detour_LoadIconW); -{$IFDEF HOOK_UXTHEME} - if TOSVersion.Check(6) then - @Trampoline_user32_LoadImageW := InterceptCreate(user32, 'LoadImageW', @Detour_LoadImageW); - -{$ENDIF HOOK_UXTHEME} - - @Trampoline_SetStyle := InterceptCreate(@LSetStylePtr, @Detour_SetStyle); - -{$IFDEF HOOK_TDateTimePicker} - {$IF CompilerVersion>=29} - //@Trampoline_TMonthCalendar_CreateWnd := InterceptCreate(@TMonthCalendarClass.CreateWnd, @Detour_TMonthCalendar_CreateWnd); - @Trampoline_SetWindowTheme := InterceptCreate(themelib, 'SetWindowTheme', @Detour_SetWindowTheme); - {$IFEND CompilerVersion} -{$ENDIF HOOK_TDateTimePicker} - - EndHooks; -end; - -finalization - - BeginUnHooks; - InterceptRemove(@Trampoline_user32_GetSysColor); - InterceptRemove(@Trampoline_user32_GetSysColorBrush); - InterceptRemove(@Trampoline_user32_FillRect); - InterceptRemove(@Trampoline_user32_DrawEdge); - InterceptRemove(@Trampoline_user32_DrawFrameControl); - InterceptRemove(@Trampoline_user32_LoadIconW); - -{$IFDEF HOOK_UXTHEME} - if TOSVersion.Check(6) then - InterceptRemove(@Trampoline_user32_LoadImageW); -{$ENDIF HOOK_UXTHEME} - InterceptRemove(@Trampoline_SetStyle); - -{$IFDEF HOOK_TDateTimePicker} - {$IF CompilerVersion>=29} - InterceptRemove(@Trampoline_SetWindowTheme); - {$IFEND CompilerVersion} -{$ENDIF HOOK_TDateTimePicker} - - EndUnHooks; - VCLStylesBrush.Free; - VCLStylesLock.Free; - VCLStylesLock := nil; - -end. +// ************************************************************************************************** +// +// Unit Vcl.Styles.Hooks +// unit for the VCL Styles Utils +// https://github.com/RRUZ/vcl-styles-utils/ +// +// 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. +// +// The Original Code is Vcl.Styles.Hooks.pas. +// +// The Initial Developer of the Original Code is Rodrigo Ruz V. +// +// Portions created by Rodrigo Ruz V. are Copyright (C) 2013-2023 Rodrigo Ruz V. +// +// Contributor(s): Mahdi Safsafi. +// +// All Rights Reserved. +// +// ************************************************************************************************** +unit Vcl.Styles.Hooks; + +interface + +uses + WinApi.Windows; + +implementation + +{$I VCL.Styles.Utils.inc} + +uses + DDetours, System.SyncObjs, System.SysUtils, System.Types, System.UITypes, + System.Classes, System.Generics.Collections, System.StrUtils, WinApi.Messages, + WinApi.UXTheme, Vcl.Graphics, Vcl.Styles.Utils.Graphics, + {$IFDEF HOOK_UXTHEME} + Vcl.Styles.UxTheme, + {$ENDIF HOOK_UXTHEME} + Vcl.Styles.Utils.SysControls, Vcl.Styles.FontAwesome, Vcl.Forms, Vcl.Controls, + Vcl.StdCtrls, Vcl.ComCtrls, Vcl.Themes, Vcl.Styles.Utils.Misc; + +type + TListStyleBrush = class(TDictionary) + protected + procedure ValueNotify(const Value: HBRUSH; Action: TCollectionNotification); override; + end; + + TSetStyle = procedure(Style: TCustomStyleServices) of object; + + TMonthCalendarClass = class(TMonthCalendar); + + TCommonCalendarClass = class(TCommonCalendar); + +var + VCLStylesBrush: TObjectDictionary; + VCLStylesLock: TCriticalSection = nil; + LSetStylePtr: TSetStyle; + Trampoline_SetStyle: procedure(Self: TObject; Style: TCustomStyleServices); + Trampoline_user32_FillRect: function(hDC: hDC; const lprc: TRect; hbr: HBRUSH): Integer; stdcall; + Trampoline_user32_DrawEdge: function(hDC: hDC; var qrc: TRect; edge: UINT; grfFlags: UINT): BOOL; stdcall = nil; + Trampoline_user32_DrawFrameControl: function(DC: HDC; Rect: PRect; uType, uState: UINT): BOOL; stdcall = nil; + Trampoline_user32_LoadIconW: function(hInstance: HINST; lpIconName: PWideChar): HICON; stdcall = nil; + Trampoline_user32_GetSysColorBrush: function(nIndex: Integer): HBRUSH; stdcall; + {$IFDEF HOOK_UXTHEME} + Trampoline_user32_LoadImageW: function(hInst: HINST; ImageName: LPCWSTR; ImageType: UINT; X, Y: Integer; Flags: UINT): THandle; stdcall = nil; + {$ELSE} + Trampoline_user32_GetSysColor: function(nIndex: Integer): DWORD; stdcall; + {$ENDIF HOOK_UXTHEME} + +{$IFDEF HOOK_TDateTimePicker} + {$IF CompilerVersion>=29} + Trampoline_SetWindowTheme: function(hwnd: HWND; pszSubAppName: LPCWSTR; pszSubIdList: LPCWSTR): HRESULT; stdcall; + {$IFEND CompilerVersion} +{$ENDIF HOOK_TDateTimePicker} + +function Detour_DrawEdge(hDC: hDC; var qrc: TRect; edge: UINT; grfFlags: UINT): BOOL; stdcall; +var + CanDraw: Boolean; + SaveIndex: Integer; +begin + if not (ExecutingInMainThread) then + Exit(Trampoline_user32_DrawEdge(hDC, qrc, edge, grfFlags)); + + CanDraw := (not StyleServices.IsSystemStyle) and (TSysStyleManager.Enabled); + if (CanDraw) and (edge <> BDR_OUTER) and (edge <> BDR_INNER) then + begin + SaveIndex := SaveDC(hDC); + try + DrawStyleEdge(hDC, qrc, TStyleElementEdges(edge), TStyleElementEdgeFlags(grfFlags)); + finally + RestoreDC(hDC, SaveIndex); + end; + Exit(True); + end; + Exit(Trampoline_user32_DrawEdge(hDC, qrc, edge, grfFlags)); +end; + +function Detour_FillRect(hDC: hDC; const lprc: TRect; hbr: HBRUSH): Integer; stdcall; +begin + if not (ExecutingInMainThread) or StyleServices.IsSystemStyle or not (TSysStyleManager.Enabled) then + Exit(Trampoline_user32_FillRect(hDC, lprc, hbr)) + else if (hbr > 0) and (hbr < COLOR_ENDCOLORS + 1) then + Exit(Trampoline_user32_FillRect(hDC, lprc, GetSysColorBrush(hbr - 1))) + else + Exit(Trampoline_user32_FillRect(hDC, lprc, hbr)); +end; + +function Detour_GetSysColor(nIndex: Integer): DWORD; stdcall; +begin + if not (ExecutingInMainThread) or StyleServices.IsSystemStyle or not (TSysStyleManager.Enabled) then + Result := Trampoline_user32_GetSysColor(nIndex) + else if nIndex = COLOR_HOTLIGHT then + Result := DWORD(StyleServices.GetSystemColor(clHighlight)) + else + Result := DWORD(StyleServices.GetSystemColor(TColor(nIndex or Integer($FF000000)))); +end; + +function Detour_GetSysColorBrush(nIndex: Integer): HBRUSH; stdcall; +var + LCurrentStyleBrush: TListStyleBrush; + LBrush: HBRUSH; + LColor: TColor; +begin + if not (ExecutingInMainThread) then + Exit(Trampoline_user32_GetSysColorBrush(nIndex)); + + { + The reason to change the previous code implementation + is that the win32 graphics may differ with the VCL graphics: + Eg: TColor is signed in VCL and Unsigned in Win32Api. + When hooking: keep always using the native way ! + Need Color ? + Use GetObject with LOGBRUSH ! or use TBrushColorPair ! + } + VCLStylesLock.Enter; + try + if StyleServices.IsSystemStyle or not TSysStyleManager.Enabled then + Exit(Trampoline_user32_GetSysColorBrush(nIndex)) + else + begin + if VCLStylesBrush.ContainsKey(StyleServices.Name) then + LCurrentStyleBrush := VCLStylesBrush.Items[StyleServices.Name] + else + begin + VCLStylesBrush.Add(StyleServices.Name, TListStyleBrush.Create()); + LCurrentStyleBrush := VCLStylesBrush.Items[StyleServices.Name]; + end; + if Assigned(LCurrentStyleBrush) then + begin + if LCurrentStyleBrush.ContainsKey(nIndex) then + Exit(LCurrentStyleBrush[nIndex]) + else + begin + if nIndex = COLOR_HOTLIGHT then + LColor := StyleServices.GetSystemColor(clHighlight) + else + LColor := StyleServices.GetSystemColor(TColor(nIndex or Integer($FF000000))); + + LBrush := CreateSolidBrush(LColor); + LCurrentStyleBrush.Add(nIndex, LBrush); + Exit(LBrush); + end; + end; + Exit(Trampoline_user32_GetSysColorBrush(nIndex)); + end; + finally + VCLStylesLock.Leave; + end; +end; + +procedure Detour_SetStyle(Self: TObject; Style: TCustomStyleServices); +var + I: Integer; + LActiveStyle: TCustomStyleServices; +begin + if not (ExecutingInMainThread) then + begin + Trampoline_SetStyle(Self, Style); + exit; + end; + + LActiveStyle := TStyleManager.ActiveStyle; + Trampoline_SetStyle(Self, Style); + if (Style <> LActiveStyle) then + begin + for I := 0 to Screen.FormCount - 1 do + if Screen.Forms[I].HandleAllocated then + SendMessage(Screen.Forms[I].Handle, WM_SYSCOLORCHANGE, 0, 0); + end; +end; + +//based on JvThemes.DrawThemedFrameControl +function Detour_WinApi_DrawFrameControl(DC: hDC; Rect: PRect; uType, uState: UINT): BOOL; stdcall; +const + Mask = $00FF; +var + LRect: TRect; + LDetails: TThemedElementDetails; + CanDraw: Boolean; + LThemedButton: TThemedButton; + LThemedComboBox: TThemedComboBox; + LThemedScrollBar: TThemedScrollBar; +begin + if not (ExecutingInMainThread) then + Exit(Trampoline_user32_DrawFrameControl(DC, Rect, uType, uState)); + + Result := False; + CanDraw := (not StyleServices.IsSystemStyle) and (TSysStyleManager.Enabled) and (Rect <> nil); + if CanDraw then + begin + LRect := Rect^; + case uType of + DFC_BUTTON: + case uState and Mask of + + DFCS_BUTTONPUSH: + begin + if uState and (DFCS_TRANSPARENT or DFCS_FLAT) = 0 then + begin + if uState and DFCS_INACTIVE <> 0 then + LThemedButton := tbPushButtonDisabled + else if uState and DFCS_PUSHED <> 0 then + LThemedButton := tbPushButtonPressed + else if uState and DFCS_HOT <> 0 then + LThemedButton := tbPushButtonHot + else if uState and DFCS_MONO <> 0 then + LThemedButton := tbPushButtonDefaulted + else + LThemedButton := tbPushButtonNormal; + + LDetails := StyleServices.GetElementDetails(LThemedButton); + DrawStyleElement(DC, LDetails, LRect); + Result := True; + end; + end; + + DFCS_BUTTONCHECK: + begin + if uState and DFCS_CHECKED <> 0 then + begin + if uState and DFCS_INACTIVE <> 0 then + LThemedButton := tbCheckBoxCheckedDisabled + else if uState and DFCS_PUSHED <> 0 then + LThemedButton := tbCheckBoxCheckedPressed + else if uState and DFCS_HOT <> 0 then + LThemedButton := tbCheckBoxCheckedHot + else + LThemedButton := tbCheckBoxCheckedNormal; + end + else if uState and DFCS_MONO <> 0 then + begin + if uState and DFCS_INACTIVE <> 0 then + LThemedButton := tbCheckBoxMixedDisabled + else if uState and DFCS_PUSHED <> 0 then + LThemedButton := tbCheckBoxMixedPressed + else if uState and DFCS_HOT <> 0 then + LThemedButton := tbCheckBoxMixedHot + else + LThemedButton := tbCheckBoxMixedNormal; + end + else + begin + if uState and DFCS_INACTIVE <> 0 then + LThemedButton := tbCheckBoxUncheckedDisabled + else if uState and DFCS_PUSHED <> 0 then + LThemedButton := tbCheckBoxUncheckedPressed + else if uState and DFCS_HOT <> 0 then + LThemedButton := tbCheckBoxUncheckedHot + else + LThemedButton := tbCheckBoxUncheckedNormal; + end; + LDetails := StyleServices.GetElementDetails(LThemedButton); + DrawStyleElement(DC, LDetails, LRect); + Result := True; + end; + + DFCS_BUTTONRADIO: + begin + if uState and DFCS_CHECKED <> 0 then + begin + if uState and DFCS_INACTIVE <> 0 then + LThemedButton := tbRadioButtonCheckedDisabled + else if uState and DFCS_PUSHED <> 0 then + LThemedButton := tbRadioButtonCheckedPressed + else if uState and DFCS_HOT <> 0 then + LThemedButton := tbRadioButtonCheckedHot + else + LThemedButton := tbRadioButtonCheckedNormal; + end + else + begin + if uState and DFCS_INACTIVE <> 0 then + LThemedButton := tbRadioButtonUncheckedDisabled + else if uState and DFCS_PUSHED <> 0 then + LThemedButton := tbRadioButtonUncheckedPressed + else if uState and DFCS_HOT <> 0 then + LThemedButton := tbRadioButtonUncheckedHot + else + LThemedButton := tbRadioButtonUncheckedNormal; + end; + LDetails := StyleServices.GetElementDetails(LThemedButton); + DrawStyleElement(DC, LDetails, LRect); + Result := True; + end; + end; + + DFC_SCROLL: + begin + case uState and Mask of + + DFCS_SCROLLCOMBOBOX: + begin + if uState and DFCS_INACTIVE <> 0 then + LThemedComboBox := tcDropDownButtonDisabled + else if uState and DFCS_PUSHED <> 0 then + LThemedComboBox := tcDropDownButtonPressed + else if uState and DFCS_HOT <> 0 then + LThemedComboBox := tcDropDownButtonHot + else + LThemedComboBox := tcDropDownButtonNormal; + + LDetails := StyleServices.GetElementDetails(LThemedComboBox); + DrawStyleElement(DC, LDetails, LRect); + Result := True; + end; + + DFCS_SCROLLUP: + if uState and (DFCS_TRANSPARENT {or DFCS_FLAT}) = 0 then + begin + if uState and DFCS_INACTIVE <> 0 then + LThemedScrollBar := tsArrowBtnUpDisabled + else if uState and DFCS_PUSHED <> 0 then + LThemedScrollBar := tsArrowBtnUpPressed + else if uState and DFCS_HOT <> 0 then + LThemedScrollBar := tsArrowBtnUpHot + else + LThemedScrollBar := tsArrowBtnUpNormal; + + LDetails := StyleServices.GetElementDetails(LThemedScrollBar); + DrawStyleElement(DC, LDetails, LRect); + Result := True; + end; + + DFCS_SCROLLDOWN: + if uState and (DFCS_TRANSPARENT {or DFCS_FLAT}) = 0 then + begin + if uState and DFCS_INACTIVE <> 0 then + LThemedScrollBar := tsArrowBtnDownDisabled + else if uState and DFCS_PUSHED <> 0 then + LThemedScrollBar := tsArrowBtnDownPressed + else if uState and DFCS_HOT <> 0 then + LThemedScrollBar := tsArrowBtnDownHot + else + LThemedScrollBar := tsArrowBtnDownNormal; + + LDetails := StyleServices.GetElementDetails(LThemedScrollBar); + DrawStyleElement(DC, LDetails, LRect); + Result := True; + end; + + DFCS_SCROLLLEFT: + if uState and (DFCS_TRANSPARENT {or DFCS_FLAT}) = 0 then + begin + if uState and DFCS_INACTIVE <> 0 then + LThemedScrollBar := tsArrowBtnLeftDisabled + else if uState and DFCS_PUSHED <> 0 then + LThemedScrollBar := tsArrowBtnLeftPressed + else if uState and DFCS_HOT <> 0 then + LThemedScrollBar := tsArrowBtnLeftHot + else + LThemedScrollBar := tsArrowBtnLeftNormal; + + LDetails := StyleServices.GetElementDetails(LThemedScrollBar); + DrawStyleElement(DC, LDetails, LRect); + Result := True; + end; + + DFCS_SCROLLRIGHT: + if uState and (DFCS_TRANSPARENT {or DFCS_FLAT}) = 0 then + begin + if uState and DFCS_INACTIVE <> 0 then + LThemedScrollBar := tsArrowBtnRightDisabled + else if uState and DFCS_PUSHED <> 0 then + LThemedScrollBar := tsArrowBtnRightPressed + else if uState and DFCS_HOT <> 0 then + LThemedScrollBar := tsArrowBtnRightHot + else + LThemedScrollBar := tsArrowBtnRightNormal; + + LDetails := StyleServices.GetElementDetails(LThemedScrollBar); + DrawStyleElement(DC, LDetails, LRect); + Result := True; + end; + + end; + end; + end; + end; + + if not Result then + Exit(Trampoline_user32_DrawFrameControl(DC, Rect, uType, uState)); +end; + +function GetStyleHighLightColor: TColor; +begin + if ColorIsBright(StyleServices.GetSystemColor(clBtnFace)) or not ColorIsBright(StyleServices.GetSystemColor(clHighlight)) then + Result := StyleServices.GetSystemColor(clBtnText) + else + Result := StyleServices.GetSystemColor(clHighlight); +end; + +function Detour_LoadIconW(_hInstance: HINST; lpIconName: PWideChar): HICON; stdcall; +var + s: string; + LIcon: TIcon; + LHandle: THandle; + MustRelease: Boolean; + + procedure DrawIcon(const ACode: Word); + begin + //DestroyIcon(LHandle); + Result := FontAwesome.GetIcon(ACode, LIcon.Width, LIcon.Height, GetStyleHighLightColor, StyleServices.GetSystemColor(clBtnFace), 0); + MustRelease := False; + end; + +begin + if not (ExecutingInMainThread) or StyleServices.IsSystemStyle or not (TSysStyleManager.Enabled) or not (TSysStyleManager.HookDialogIcons) then + Exit(Trampoline_user32_LoadIconW(_hInstance, lpIconName)); + + if {(_hInstance>0) and (_hInstance<>HInstance) and} IS_INTRESOURCE(lpIconName) then + begin + LIcon := TIcon.Create; + try + MustRelease := True; + LHandle := Trampoline_user32_LoadIconW(_hInstance, lpIconName); + LIcon.Handle := LHandle; + Result := LHandle; + s := IntToStr(NativeUInt(lpIconName)); + + //OutputDebugString(PChar('Detour_LoadIconW '+s+ ' Module Name '+GetModuleName(_hInstance)+' _hInstance '+IntToHex(_hInstance, 8) )); + case NativeUInt(lpIconName) of + 78: + DrawIcon(fa_shield); + 81: + DrawIcon(fa_info_circle); + 84: + DrawIcon(fa_warning); + 98: + DrawIcon(fa_minus_circle); + 99: + DrawIcon(fa_question_circle); + end; + + if _hInstance = 0 then + case NativeUInt(lpIconName) of + 32518: + DrawIcon(fa_shield); + 32516: + DrawIcon(fa_info_circle); + 32515: + DrawIcon(fa_warning); + 32513: + DrawIcon(fa_minus_circle); + 32514: + DrawIcon(fa_question_circle); + 32517: + DrawIcon(fa_windows); + end; + + finally + if MustRelease then + LIcon.ReleaseHandle; + LIcon.Free; + end; + end + else + Exit(Trampoline_user32_LoadIconW(_hInstance, lpIconName)); +end; + +{$IFDEF HOOK_UXTHEME} +function Detour_LoadImageW(hInst: hInst; ImageName: LPCWSTR; ImageType: UINT; X, Y: Integer; Flags: UINT): THandle; stdcall; +const + ExplorerFrame = 'explorerframe.dll'; +var + hModule: WinApi.Windows.HMODULE; + LBitmap: TBitmap; + s: string; + LRect, LRect2: TRect; + LBackColor, LColor: TColor; +begin + if not (ExecutingInMainThread) or StyleServices.IsSystemStyle or not (TSysStyleManager.Enabled) then + Exit(Trampoline_user32_LoadImageW(hInst, ImageName, ImageType, X, Y, Flags)); + + //w8 - W10 + if (hInst > 0) and (hInst <> HInstance) and (ImageType = IMAGE_ICON) and (X = 16) and (Y = 16) and IS_INTRESOURCE(ImageName) and TOSVersion.Check(6, 2) then + begin + s := IntToStr(NativeUInt(ImageName)); + + case NativeUInt(ImageName) of + //W8, W10 + //comctl32.dll + 16817: + begin + Exit(FontAwesome.GetIcon(fa_arrow_up, X, Y, StyleServices.GetSystemColor(clBtnText), StyleServices.GetSystemColor(clBtnFace), 0)); + end; + 16818: + begin + Exit(FontAwesome.GetIcon(fa_arrow_up, X, Y, StyleServices.GetSystemColor(clGrayText), StyleServices.GetSystemColor(clBtnFace), 0)); + end; + //W10 + //shell32.dll + 5100: + begin + //OutputDebugString(PChar('GetModuleName ' + GetModuleName(hInst))); + Exit(FontAwesome.GetIcon(fa_thumb_tack, 16, 16, 12, 12, StyleServices.GetSystemColor(clGrayText), StyleServices.GetSystemColor(clWindow), -22, iaRight)); + //Exit(FontAwesome.GetIcon(fa_check_square_o, 16, 16, StyleServices.GetSystemColor(clWindowText), StyleServices.GetSystemColor(clWindow), 0)); + end; + end; + Exit(Trampoline_user32_LoadImageW(hInst, ImageName, ImageType, X, Y, Flags)); + end + else if (hInst > 0) and (ImageType = IMAGE_BITMAP) and (X = 0) and (Y = 0) and IS_INTRESOURCE(ImageName) then + begin + hModule := GetModuleHandle(ExplorerFrame); + if (hModule = hInst) then + begin + s := IntToStr(NativeUInt(ImageName)); + Result := Trampoline_user32_LoadImageW(hInst, ImageName, ImageType, X, Y, Flags); + LBitmap := TBitmap.Create; + try + LBitmap.Handle := Result; + //LBitmap.SaveToFile(IncludeTrailingPathDelimiter(ExtractFilePath(ParamStr(0)))+s+'.bmp');//SaveToFile('C:\Users\Rodrigo\Desktop\vcl-styles-utils\Vcl Styles Utils New Dialogs (Demo App)\Win32\Debug\Images\'+s+'.bmp'); + + //W8 - W10 + if TOSVersion.Check(6, 2) then + begin + LBackColor := StyleServices.GetSystemColor(clWindow); + LRect := Rect(0, 0, LBitmap.Width, LBitmap.Height); + case NativeUInt(ImageName) of + // Right Arrow, cross button, refresh, down arrow + 288: + begin + LColor := StyleServices.GetSystemColor(clBtnText); + Bitmap32_SetAlphaAndColor(LBitmap, 1, LBackColor); + + LRect := Rect(0, 0, 16, 16); + FontAwesome.DrawChar(LBitmap.Canvas.Handle, fa_arrow_right, LRect, LColor); + + OffsetRect(LRect, 16, 0); + FontAwesome.DrawChar(LBitmap.Canvas.Handle, fa_remove, LRect, LColor); + + OffsetRect(LRect, 16, 0); + LRect2 := LRect; + InflateRect(LRect2, -2, -2); + FontAwesome.DrawChar(LBitmap.Canvas.Handle, fa_refresh, LRect2, LColor); + + OffsetRect(LRect, 16 + 2, 0); + LRect2 := LRect; + InflateRect(LRect2, -2, -2); + FontAwesome.DrawChar(LBitmap.Canvas.Handle, fa_caret_down, LRect2, LColor); + + Bitmap32_SetAlphaExceptColor(LBitmap, 255, LBackColor); + end; + else + begin + Bitmap32_Grayscale(LBitmap); + _ProcessBitmap32(LBitmap, StyleServices.GetSystemColor(clHighlight), _BlendBurn) + end; + end; + end + else + //Windows Vista - W7 + if (TOSVersion.Major = 6) and ((TOSVersion.Minor = 0) or (TOSVersion.Minor = 1)) then + begin + LBackColor := StyleServices.GetSystemColor(clWindow); + LRect := Rect(0, 0, LBitmap.Width, LBitmap.Height); + case NativeUInt(ImageName) of + //Magnifier + 34560..34562, // Aero Enabled + 34563..34568: // Classic Theme + begin + LColor := StyleServices.GetSystemColor(clHighlight); + Bitmap32_SetAlphaAndColor(LBitmap, 1, LBackColor); + FontAwesome.DrawChar(LBitmap.Canvas.Handle, fa_search, LRect, LColor); + Bitmap32_SetAlphaExceptColor(LBitmap, 255, LBackColor); + //Bitmap32_SetAlphaByColor(LBitmap, 255, LColor); + end; + + //cross button normal + 34569..34571, // Aero Enabled + 34572..34574: // Classic Theme + begin + LColor := StyleServices.GetSystemColor(clWindowText); + Bitmap32_SetAlphaAndColor(LBitmap, 1, LBackColor); + FontAwesome.DrawChar(LBitmap.Canvas.Handle, fa_remove, LRect, LColor); + Bitmap32_SetAlphaExceptColor(LBitmap, 255, LBackColor); + end; + + //cross button hot + 34575..34577, // Aero Enabled + 34581..34583, // Aero Enabled + 34578..34580: // Classic Theme + begin + LColor := StyleServices.GetSystemColor(clHighlight); + Bitmap32_SetAlphaAndColor(LBitmap, 1, LBackColor); + FontAwesome.DrawChar(LBitmap.Canvas.Handle, fa_remove, LRect, LColor); + Bitmap32_SetAlphaExceptColor(LBitmap, 255, LBackColor); + end; + + // Aero Enabled + // Right Arrow, cross button, refresh, down arrow + 288: + begin + LColor := StyleServices.GetSystemColor(clBtnText); + Bitmap32_SetAlphaAndColor(LBitmap, 1, LBackColor); + + LRect := Rect(0, 0, 16, 16); + FontAwesome.DrawChar(LBitmap.Canvas.Handle, fa_arrow_right, LRect, LColor); + + OffsetRect(LRect, 16, 0); + FontAwesome.DrawChar(LBitmap.Canvas.Handle, fa_remove, LRect, LColor); + + OffsetRect(LRect, 16, 0); + FontAwesome.DrawChar(LBitmap.Canvas.Handle, fa_refresh, LRect, LColor); + + OffsetRect(LRect, 16, 0); + FontAwesome.DrawChar(LBitmap.Canvas.Handle, fa_caret_down, LRect, LColor); + + Bitmap32_SetAlphaExceptColor(LBitmap, 255, LBackColor); + end; + + // Classic Theme + // Right Arrow, cross button, refresh, down arrow + 289, 290: + begin + LColor := StyleServices.GetSystemColor(clBtnText); + Bitmap32_SetAlphaAndColor(LBitmap, 1, LBackColor); + + LRect := Rect(0, 0, 21, 21); + FontAwesome.DrawChar(LBitmap.Canvas.Handle, fa_arrow_right, LRect, LColor); + + OffsetRect(LRect, 21, 0); + FontAwesome.DrawChar(LBitmap.Canvas.Handle, fa_remove, LRect, LColor); + + OffsetRect(LRect, 21, 0); + FontAwesome.DrawChar(LBitmap.Canvas.Handle, fa_refresh, LRect, LColor); + + OffsetRect(LRect, 21, 0); + FontAwesome.DrawChar(LBitmap.Canvas.Handle, fa_caret_down, LRect, LColor); + + Bitmap32_SetAlphaExceptColor(LBitmap, 255, LBackColor); + end; + + // Aero Enabled + // navigation buttons (arrows) + 577..579, 581: + begin + case NativeUInt(ImageName) of + 577: + LColor := StyleServices.GetSystemColor(clBtnText); + 578: + LColor := StyleServices.GetSystemColor(clHighlight); + 579: + LColor := StyleServices.GetSystemColor(clGrayText); + 581: + LColor := StyleServices.GetSystemColor(clBtnText); + else + LColor := StyleServices.GetSystemColor(clBtnText); + end; + + Bitmap32_SetAlphaAndColor(LBitmap, 1, LBackColor); + + LRect := Rect(0, 0, 27, 27); + InflateRect(LRect, -4, -4); + FontAwesome.DrawChar(LBitmap.Canvas.Handle, fa_arrow_left, LRect, LColor); + OffsetRect(LRect, 27 + 4, 0); + FontAwesome.DrawChar(LBitmap.Canvas.Handle, fa_arrow_right, LRect, LColor); + + Bitmap32_SetAlphaExceptColor(LBitmap, 255, LBackColor); + end; + + //Classic Theme + // navigation buttons (arrows) + 582..584: + begin + case NativeUInt(ImageName) of + 582: + LColor := StyleServices.GetSystemColor(clBtnText); + 583: + LColor := StyleServices.GetSystemColor(clHighlight); + 584: + LColor := StyleServices.GetSystemColor(clGrayText); + else + LColor := StyleServices.GetSystemColor(clBtnText); + end; + + Bitmap32_SetAlphaAndColor(LBitmap, 1, LBackColor); + + //left arrow + LRect := Rect(0, 0, 25, 25); + InflateRect(LRect, -4, -4); + FontAwesome.DrawChar(LBitmap.Canvas.Handle, fa_arrow_left, LRect, LColor); + + //right arrow + OffsetRect(LRect, 25 + 4, 0); + FontAwesome.DrawChar(LBitmap.Canvas.Handle, fa_arrow_right, LRect, LColor); + + //dropdown arrow + LRect := Rect(60, 8, 72, 20); + FontAwesome.DrawChar(LBitmap.Canvas.Handle, fa_caret_down, LRect, LColor); + + Bitmap32_SetAlphaExceptColor(LBitmap, 255, LBackColor); + end; + + //Aero Enabled + //background navigation buttons + 280: + begin + Bitmap32_SetAlphaAndColor(LBitmap, 1, LBackColor); + + LRect := Rect(0, 8, 12, 20); + LColor := StyleServices.GetSystemColor(clGrayText); + OffsetRect(LRect, 58, 0); + FontAwesome.DrawChar(LBitmap.Canvas.Handle, fa_caret_down, LRect, LColor); + + LColor := StyleServices.GetSystemColor(clBtnText); + OffsetRect(LRect, 70, 0); + FontAwesome.DrawChar(LBitmap.Canvas.Handle, fa_caret_down, LRect, LColor); + + LColor := StyleServices.GetSystemColor(clHighlight); + OffsetRect(LRect, 70, 0); + FontAwesome.DrawChar(LBitmap.Canvas.Handle, fa_caret_down, LRect, LColor); + + LColor := StyleServices.GetSystemColor(clHighlight); + OffsetRect(LRect, 70, 0); + FontAwesome.DrawChar(LBitmap.Canvas.Handle, fa_caret_down, LRect, LColor); + + Bitmap32_SetAlphaExceptColor(LBitmap, 255, LBackColor); + end; + + //Classic Theme + //background navigation buttons + 281: + begin + Bitmap32_SetAlphaAndColor(LBitmap, 1, LBackColor); + end; + end; + end; + LBitmap.ReleaseHandle; + finally + LBitmap.Free; + end; + //OutputDebugString(PChar(Format('Detour_LoadImageW ImageName %s', [s]))); + Exit(Result); + end; + end; + + Exit(Trampoline_user32_LoadImageW(hInst, ImageName, ImageType, X, Y, Flags)); +end; +{$ENDIF HOOK_UXTHEME} + + +{$IFDEF HOOK_TDateTimePicker} + {$IF CompilerVersion>=29} + +function Detour_SetWindowTheme(hwnd: hwnd; pszSubAppName: LPCWSTR; pszSubIdList: LPCWSTR): HRESULT; stdcall; +var + LControl: TWinControl; +begin + if not (ExecutingInMainThread) then + Exit(Trampoline_SetWindowTheme(hwnd, pszSubAppName, pszSubIdList)); + + LControl := FindControl(hwnd); + if (pszSubAppName = '') and (pszSubIdList = '') and TStyleManager.IsCustomStyleActive and (LControl <> nil) and (LControl is TMonthCalendar) then + Exit(S_OK) + else + Exit(Trampoline_SetWindowTheme(hwnd, pszSubAppName, pszSubIdList)); +end; + {$IFEND CompilerVersion} +{$ENDIF HOOK_TDateTimePicker} + + +//don't hook CreateSolidBrush, because is used internally by GetSysColorBrush +//don't hook CopyImage + +{ TListStyleBrush } + +//Delete brushes + +procedure TListStyleBrush.ValueNotify(const Value: HBRUSH; Action: TCollectionNotification); +begin + inherited; + if Action = TCollectionNotification.cnRemoved then + DeleteObject(Value); +end; + +const + themelib = 'uxtheme.dll'; + +var + hnd: THandle; + +initialization + VCLStylesLock := TCriticalSection.Create; + VCLStylesBrush := TObjectDictionary.Create([doOwnsValues]); + + if StyleServices.Available then + begin + + {$IFDEF HOOK_TDateTimePicker} + TCustomStyleEngine.RegisterStyleHook(TDateTimePicker, TStyleHook); + {$ENDIF HOOK_TDateTimePicker} + + {$IFDEF HOOK_TProgressBar} + TCustomStyleEngine.RegisterStyleHook(TProgressBar, TStyleHook); + {$ENDIF HOOK_TProgressBar} + LSetStylePtr := TStyleManager.SetStyle; + + hnd := BeginTransaction(); + @Trampoline_user32_GetSysColor := InterceptCreate(user32, 'GetSysColor', @Detour_GetSysColor); + @Trampoline_user32_GetSysColorBrush := InterceptCreate(user32, 'GetSysColorBrush', @Detour_GetSysColorBrush); + @Trampoline_user32_FillRect := InterceptCreate(user32, 'FillRect', @Detour_FillRect); + @Trampoline_user32_DrawEdge := InterceptCreate(user32, 'DrawEdge', @Detour_DrawEdge); + @Trampoline_user32_DrawFrameControl := InterceptCreate(user32, 'DrawFrameControl', @Detour_WinApi_DrawFrameControl); + @Trampoline_user32_LoadIconW := InterceptCreate(user32, 'LoadIconW', @Detour_LoadIconW); + {$IFDEF HOOK_UXTHEME} + if TOSVersion.Check(6) then + @Trampoline_user32_LoadImageW := InterceptCreate(user32, 'LoadImageW', @Detour_LoadImageW); + + {$ENDIF HOOK_UXTHEME} + + @Trampoline_SetStyle := InterceptCreate(@LSetStylePtr, @Detour_SetStyle); + + {$IFDEF HOOK_TDateTimePicker} + {$IF CompilerVersion>=29} + //@Trampoline_TMonthCalendar_CreateWnd := InterceptCreate(@TMonthCalendarClass.CreateWnd, @Detour_TMonthCalendar_CreateWnd); + @Trampoline_SetWindowTheme := InterceptCreate(themelib, 'SetWindowTheme', @Detour_SetWindowTheme); + {$IFEND CompilerVersion} + {$ENDIF HOOK_TDateTimePicker} + + EndTransaction(hnd); + end; + + +finalization + hnd := BeginTransaction(); + InterceptRemove(@Trampoline_user32_GetSysColor); + InterceptRemove(@Trampoline_user32_GetSysColorBrush); + InterceptRemove(@Trampoline_user32_FillRect); + InterceptRemove(@Trampoline_user32_DrawEdge); + InterceptRemove(@Trampoline_user32_DrawFrameControl); + InterceptRemove(@Trampoline_user32_LoadIconW); + +{$IFDEF HOOK_UXTHEME} + if TOSVersion.Check(6) then + InterceptRemove(@Trampoline_user32_LoadImageW); +{$ENDIF HOOK_UXTHEME} + InterceptRemove(@Trampoline_SetStyle); + +{$IFDEF HOOK_TDateTimePicker} + {$IF CompilerVersion>=29} + InterceptRemove(@Trampoline_SetWindowTheme); + {$IFEND CompilerVersion} +{$ENDIF HOOK_TDateTimePicker} + + EndTransaction(hnd); + VCLStylesBrush.Free; + VCLStylesLock.Free; + VCLStylesLock := nil; + +end. + diff --git a/source/vcl-styles-utils/Vcl.Styles.NC.pas b/source/vcl-styles-utils/Vcl.Styles.NC.pas index ae163bc33..b1b45503f 100644 --- a/source/vcl-styles-utils/Vcl.Styles.NC.pas +++ b/source/vcl-styles-utils/Vcl.Styles.NC.pas @@ -15,7 +15,7 @@ // The Original Code is Vcl.Styles.NC.pas. // // The Initial Developer of the Original Code is Rodrigo Ruz V. -// Portions created by Rodrigo Ruz V. are Copyright (C) 2014-2020 Rodrigo Ruz V. +// Portions created by Rodrigo Ruz V. are Copyright (C) 2014-2021 Rodrigo Ruz V. // All Rights Reserved. // // ************************************************************************************************** @@ -2294,7 +2294,7 @@ procedure TNCControl.SetVisible(const Value: Boolean); begin if FVisible <> Value then FVisible := Value; - // TODO : Add parent notification + // TODO: Add parent notification end; procedure TNCControl.SetWidth(const Value: Integer); diff --git a/source/vcl-styles-utils/Vcl.Styles.OwnerDrawFix.pas b/source/vcl-styles-utils/Vcl.Styles.OwnerDrawFix.pas index bbb4f8017..4a73112c3 100644 --- a/source/vcl-styles-utils/Vcl.Styles.OwnerDrawFix.pas +++ b/source/vcl-styles-utils/Vcl.Styles.OwnerDrawFix.pas @@ -1,251 +1,251 @@ -// ************************************************************************************************** -// -// Unit Vcl.Styles.OwnerDrawFix -// unit for the VCL Styles Utils -// https://github.com/RRUZ/vcl-styles-utils/ -// -// 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. -// -// The Original Code is Vcl.Styles.OwnerDrawFix.pas. -// -// The Initial Developer of the Original Code is Rodrigo Ruz V. -// Portions created by Rodrigo Ruz V. are Copyright (C) 2012-2019 Rodrigo Ruz V. -// All Rights Reserved. -// -// ************************************************************************************************** -unit Vcl.Styles.OwnerDrawFix; - -interface - -uses - Winapi.Windows, - Winapi.CommCtrl, - Vcl.ComCtrls, - Vcl.Graphics, - Vcl.StdCtrls, - Vcl.Controls, - Vcl.Styles, - Vcl.Themes, - System.Classes; - -type - TVclStylesOwnerDrawFix = class - public - procedure ComboBoxDrawItem(Control: TWinControl; Index: Integer; Rect: TRect; State: TOwnerDrawState); - procedure ListBoxDrawItem(Control: TWinControl; Index: Integer; Rect: TRect; State: TOwnerDrawState); - procedure ListViewDrawItem(Sender: TCustomListView; Item: TListItem; Rect: TRect; State: TOwnerDrawState); - procedure ListViewMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); - end deprecated 'Use the Vcl.Styles.Hooks unit Instead'; - -var - VclStylesOwnerDrawFix: TVclStylesOwnerDrawFix; - -implementation - -uses - System.SysUtils; - -type - TCustomListViewClass = class(TCustomListView); - - { TVclStylesOwnerDrawFix } - -procedure TVclStylesOwnerDrawFix.ComboBoxDrawItem(Control: TWinControl; Index: Integer; Rect: TRect; - State: TOwnerDrawState); -const - ColorStates: array [Boolean] of TStyleColor = (scComboBoxDisabled, scComboBox); - FontColorStates: array [Boolean] of TStyleFont = (sfComboBoxItemDisabled, sfComboBoxItemNormal); -var - LStyles: TCustomStyleServices; -begin - LStyles := StyleServices; - with Control as TComboBox do - begin - Canvas.Brush.Color := LStyles.GetStyleColor(ColorStates[Control.Enabled]); - Canvas.Font.Color := LStyles.GetStyleFontColor(FontColorStates[Control.Enabled]); - - if odSelected in State then - begin - Canvas.Brush.Color := LStyles.GetSystemColor(clHighlight); - Canvas.Font.Color := LStyles.GetSystemColor(clHighlightText); - end; - - Canvas.FillRect(Rect); - Canvas.TextOut(Rect.Left + 2, Rect.Top, Items[Index]); - end; -end; - -procedure TVclStylesOwnerDrawFix.ListBoxDrawItem(Control: TWinControl; Index: Integer; Rect: TRect; - State: TOwnerDrawState); -Var - LListBox: TListBox; - LStyles: TCustomStyleServices; - LDetails: TThemedElementDetails; -begin - LListBox := TListBox(Control); - LStyles := StyleServices; - - if odSelected in State then - LListBox.Brush.Color := LStyles.GetSystemColor(clHighlight); - - LDetails := StyleServices.GetElementDetails(tlListItemNormal); - - LListBox.Canvas.FillRect(Rect); - Rect.Left := Rect.Left + 2; - LStyles.DrawText(LListBox.Canvas.Handle, LDetails, LListBox.Items[Index], Rect, - [tfLeft, tfSingleLine, tfVerticalCenter]); - - if odFocused In State then - begin - LListBox.Canvas.Brush.Color := LStyles.GetSystemColor(clHighlight); - LListBox.Canvas.DrawFocusRect(Rect); - end; -end; - -procedure TVclStylesOwnerDrawFix.ListViewDrawItem(Sender: TCustomListView; Item: TListItem; Rect: TRect; - State: TOwnerDrawState); -const - Spacing = 4; -var - Dx: Integer; - r: TRect; - rc: TRect; - ColIdx: Integer; - s: string; - LDetails: TThemedElementDetails; - LStyles: TCustomStyleServices; - BoxSize: TSize; - LColor: TColor; - ImageSize: Integer; -begin - ImageSize := 0; - LStyles := StyleServices; - if not LStyles.GetElementColor(LStyles.GetElementDetails(ttItemNormal), ecTextColor, LColor) or (LColor = clNone) then - LColor := LStyles.GetSystemColor(clWindowText); - - Sender.Canvas.Brush.Color := LStyles.GetStyleColor(scListView); - Sender.Canvas.Font.Color := LColor; - Sender.Canvas.FillRect(Rect); - - r := Rect; - inc(r.Left, Spacing); - for ColIdx := 0 to TListView(Sender).Columns.Count - 1 do - begin - Dx := 0; - r.Right := r.Left + Sender.Column[ColIdx].Width; - - if (ColIdx > 0) and (Item.SubItems.Count >= ColIdx) then - s := Item.SubItems[ColIdx - 1] - else - begin - BoxSize.cx := GetSystemMetrics(SM_CXMENUCHECK); - BoxSize.cy := GetSystemMetrics(SM_CYMENUCHECK); - s := Item.Caption; - if TListView(Sender).Checkboxes then - begin - inc(Dx, BoxSize.cx + 3); - r.Left := r.Left + BoxSize.cx + 3; - end; - end; - - if ColIdx = 0 then - begin - if not IsWindowVisible(ListView_GetEditControl(Sender.Handle)) and ([odSelected, odHotLight] * State <> []) then - begin - if ([odSelected, odHotLight] * State <> []) then - begin - rc := Rect; - if TListView(Sender).Checkboxes then - rc.Left := rc.Left + BoxSize.cx + Spacing; - - if not TListView(Sender).RowSelect then - rc.Right := Sender.Column[0].Width; - - Sender.Canvas.Brush.Color := LStyles.GetSystemColor(clHighlight); - Sender.Canvas.FillRect(rc); - end; - end; - end; - - if TListView(Sender).RowSelect then - Sender.Canvas.Brush.Color := LStyles.GetSystemColor(clHighlight); - - if (ColIdx = 0) and (TCustomListViewClass(Sender).SmallImages <> nil) and - (TCustomListViewClass(Sender).SmallImages.Handle <> 0) and (Item.ImageIndex >= 0) then - begin - ImageList_Draw(TCustomListViewClass(Sender).SmallImages.Handle, Item.ImageIndex, Sender.Canvas.Handle, r.Left - 2, - r.Top, ILD_NORMAL); - ImageSize := TCustomListViewClass(Sender).SmallImages.Width; - inc(Dx, ImageSize); - r.Left := r.Left + ImageSize; - end; - - if ([odSelected, odHotLight] * State <> []) then - LDetails := StyleServices.GetElementDetails(tlListItemSelected) - else - LDetails := StyleServices.GetElementDetails(tlListItemNormal); - - Sender.Canvas.Brush.Style := bsClear; - LStyles.DrawText(Sender.Canvas.Handle, LDetails, s, r, [tfLeft, tfSingleLine, tfVerticalCenter, tfEndEllipsis]); - - if (ColIdx = 0) and TListView(Sender).Checkboxes then - begin - rc := Rect; - rc.Top := Rect.Top + (Rect.Bottom - Rect.Top - BoxSize.cy) div 2; - rc.Bottom := rc.Top + BoxSize.cy; - rc.Left := rc.Left + Spacing; - rc.Right := rc.Left + BoxSize.cx; - - if Item.Checked then - LDetails := StyleServices.GetElementDetails(tbCheckBoxCheckedNormal) - else - LDetails := StyleServices.GetElementDetails(tbCheckBoxUncheckedNormal); - - LStyles.DrawElement(Sender.Canvas.Handle, LDetails, rc); - end; - - if ColIdx = 0 then - r.Left := r.Left - Dx; - { else } - inc(r.Left, Sender.Column[ColIdx].Width); - end; - -end; - -procedure TVclStylesOwnerDrawFix.ListViewMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; - X, Y: Integer); -const - Spacing = 4; -var - LDetails: TThemedElementDetails; - Size: TSize; -begin - if TListView(Sender).OwnerDraw and (TListView(Sender).Checkboxes) then - begin - LDetails := StyleServices.GetElementDetails(tbCheckBoxCheckedNormal); - Size.cx := 0; - Size.cy := 0; - - if StyleServices.GetElementSize(TListView(Sender).Canvas.Handle, LDetails, esMinimum, Size) and (X > Spacing) and - (X <= Size.Width) then - TListView(Sender).Selected.Checked := not TListView(Sender).Selected.Checked; - - // OutputDebugString(PChar(Format('X %d Size.Width %d',[X, Size.Width]))); - end; -end; - -initialization - -VclStylesOwnerDrawFix := TVclStylesOwnerDrawFix.Create; - -finalization - -VclStylesOwnerDrawFix.Free; - -end. +// ************************************************************************************************** +// +// Unit Vcl.Styles.OwnerDrawFix +// unit for the VCL Styles Utils +// https://github.com/RRUZ/vcl-styles-utils/ +// +// 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. +// +// The Original Code is Vcl.Styles.OwnerDrawFix.pas. +// +// The Initial Developer of the Original Code is Rodrigo Ruz V. +// Portions created by Rodrigo Ruz V. are Copyright (C) 2012-2023 Rodrigo Ruz V. +// All Rights Reserved. +// +// ************************************************************************************************** +unit Vcl.Styles.OwnerDrawFix; + +interface + +uses + Winapi.Windows, + Winapi.CommCtrl, + Vcl.ComCtrls, + Vcl.Graphics, + Vcl.StdCtrls, + Vcl.Controls, + Vcl.Styles, + Vcl.Themes, + System.Classes; + +type + TVclStylesOwnerDrawFix = class + public + procedure ComboBoxDrawItem(Control: TWinControl; Index: Integer; Rect: TRect; State: TOwnerDrawState); + procedure ListBoxDrawItem(Control: TWinControl; Index: Integer; Rect: TRect; State: TOwnerDrawState); + procedure ListViewDrawItem(Sender: TCustomListView; Item: TListItem; Rect: TRect; State: TOwnerDrawState); + procedure ListViewMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); + end deprecated 'Use the Vcl.Styles.Hooks unit Instead'; + +var + VclStylesOwnerDrawFix: TVclStylesOwnerDrawFix; + +implementation + +uses + System.SysUtils; + +type + TCustomListViewClass = class(TCustomListView); + + { TVclStylesOwnerDrawFix } + +procedure TVclStylesOwnerDrawFix.ComboBoxDrawItem(Control: TWinControl; Index: Integer; Rect: TRect; + State: TOwnerDrawState); +const + ColorStates: array [Boolean] of TStyleColor = (scComboBoxDisabled, scComboBox); + FontColorStates: array [Boolean] of TStyleFont = (sfComboBoxItemDisabled, sfComboBoxItemNormal); +var + LStyles: TCustomStyleServices; +begin + LStyles := StyleServices; + with Control as TComboBox do + begin + Canvas.Brush.Color := LStyles.GetStyleColor(ColorStates[Control.Enabled]); + Canvas.Font.Color := LStyles.GetStyleFontColor(FontColorStates[Control.Enabled]); + + if odSelected in State then + begin + Canvas.Brush.Color := LStyles.GetSystemColor(clHighlight); + Canvas.Font.Color := LStyles.GetSystemColor(clHighlightText); + end; + + Canvas.FillRect(Rect); + Canvas.TextOut(Rect.Left + 2, Rect.Top, Items[Index]); + end; +end; + +procedure TVclStylesOwnerDrawFix.ListBoxDrawItem(Control: TWinControl; Index: Integer; Rect: TRect; + State: TOwnerDrawState); +Var + LListBox: TListBox; + LStyles: TCustomStyleServices; + LDetails: TThemedElementDetails; +begin + LListBox := TListBox(Control); + LStyles := StyleServices; + + if odSelected in State then + LListBox.Brush.Color := LStyles.GetSystemColor(clHighlight); + + LDetails := StyleServices.GetElementDetails(tlListItemNormal); + + LListBox.Canvas.FillRect(Rect); + Rect.Left := Rect.Left + 2; + LStyles.DrawText(LListBox.Canvas.Handle, LDetails, LListBox.Items[Index], Rect, + [tfLeft, tfSingleLine, tfVerticalCenter]); + + if odFocused In State then + begin + LListBox.Canvas.Brush.Color := LStyles.GetSystemColor(clHighlight); + LListBox.Canvas.DrawFocusRect(Rect); + end; +end; + +procedure TVclStylesOwnerDrawFix.ListViewDrawItem(Sender: TCustomListView; Item: TListItem; Rect: TRect; + State: TOwnerDrawState); +const + Spacing = 4; +var + Dx: Integer; + r: TRect; + rc: TRect; + ColIdx: Integer; + s: string; + LDetails: TThemedElementDetails; + LStyles: TCustomStyleServices; + BoxSize: TSize; + LColor: TColor; + ImageSize: Integer; +begin + ImageSize := 0; + LStyles := StyleServices; + if not LStyles.GetElementColor(LStyles.GetElementDetails(ttItemNormal), ecTextColor, LColor) or (LColor = clNone) then + LColor := LStyles.GetSystemColor(clWindowText); + + Sender.Canvas.Brush.Color := LStyles.GetStyleColor(scListView); + Sender.Canvas.Font.Color := LColor; + Sender.Canvas.FillRect(Rect); + + r := Rect; + inc(r.Left, Spacing); + for ColIdx := 0 to TListView(Sender).Columns.Count - 1 do + begin + Dx := 0; + r.Right := r.Left + Sender.Column[ColIdx].Width; + + if (ColIdx > 0) and (Item.SubItems.Count >= ColIdx) then + s := Item.SubItems[ColIdx - 1] + else + begin + BoxSize.cx := GetSystemMetrics(SM_CXMENUCHECK); + BoxSize.cy := GetSystemMetrics(SM_CYMENUCHECK); + s := Item.Caption; + if TListView(Sender).Checkboxes then + begin + inc(Dx, BoxSize.cx + 3); + r.Left := r.Left + BoxSize.cx + 3; + end; + end; + + if ColIdx = 0 then + begin + if not IsWindowVisible(ListView_GetEditControl(Sender.Handle)) and ([odSelected, odHotLight] * State <> []) then + begin + if ([odSelected, odHotLight] * State <> []) then + begin + rc := Rect; + if TListView(Sender).Checkboxes then + rc.Left := rc.Left + BoxSize.cx + Spacing; + + if not TListView(Sender).RowSelect then + rc.Right := Sender.Column[0].Width; + + Sender.Canvas.Brush.Color := LStyles.GetSystemColor(clHighlight); + Sender.Canvas.FillRect(rc); + end; + end; + end; + + if TListView(Sender).RowSelect then + Sender.Canvas.Brush.Color := LStyles.GetSystemColor(clHighlight); + + if (ColIdx = 0) and (TCustomListViewClass(Sender).SmallImages <> nil) and + (TCustomListViewClass(Sender).SmallImages.Handle <> 0) and (Item.ImageIndex >= 0) then + begin + ImageList_Draw(TCustomListViewClass(Sender).SmallImages.Handle, Item.ImageIndex, Sender.Canvas.Handle, r.Left - 2, + r.Top, ILD_NORMAL); + ImageSize := TCustomListViewClass(Sender).SmallImages.Width; + inc(Dx, ImageSize); + r.Left := r.Left + ImageSize; + end; + + if ([odSelected, odHotLight] * State <> []) then + LDetails := StyleServices.GetElementDetails(tlListItemSelected) + else + LDetails := StyleServices.GetElementDetails(tlListItemNormal); + + Sender.Canvas.Brush.Style := bsClear; + LStyles.DrawText(Sender.Canvas.Handle, LDetails, s, r, [tfLeft, tfSingleLine, tfVerticalCenter, tfEndEllipsis]); + + if (ColIdx = 0) and TListView(Sender).Checkboxes then + begin + rc := Rect; + rc.Top := Rect.Top + (Rect.Bottom - Rect.Top - BoxSize.cy) div 2; + rc.Bottom := rc.Top + BoxSize.cy; + rc.Left := rc.Left + Spacing; + rc.Right := rc.Left + BoxSize.cx; + + if Item.Checked then + LDetails := StyleServices.GetElementDetails(tbCheckBoxCheckedNormal) + else + LDetails := StyleServices.GetElementDetails(tbCheckBoxUncheckedNormal); + + LStyles.DrawElement(Sender.Canvas.Handle, LDetails, rc); + end; + + if ColIdx = 0 then + r.Left := r.Left - Dx; + { else } + inc(r.Left, Sender.Column[ColIdx].Width); + end; + +end; + +procedure TVclStylesOwnerDrawFix.ListViewMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; + X, Y: Integer); +const + Spacing = 4; +var + LDetails: TThemedElementDetails; + Size: TSize; +begin + if TListView(Sender).OwnerDraw and (TListView(Sender).Checkboxes) then + begin + LDetails := StyleServices.GetElementDetails(tbCheckBoxCheckedNormal); + Size.cx := 0; + Size.cy := 0; + + if StyleServices.GetElementSize(TListView(Sender).Canvas.Handle, LDetails, esMinimum, Size) and (X > Spacing) and + (X <= Size.Width) then + TListView(Sender).Selected.Checked := not TListView(Sender).Selected.Checked; + + // OutputDebugString(PChar(Format('X %d Size.Width %d',[X, Size.Width]))); + end; +end; + +initialization + +VclStylesOwnerDrawFix := TVclStylesOwnerDrawFix.Create; + +finalization + +VclStylesOwnerDrawFix.Free; + +end. diff --git a/source/vcl-styles-utils/Vcl.Styles.Preview.pas b/source/vcl-styles-utils/Vcl.Styles.Preview.pas index 09c830310..afa3e0985 100644 --- a/source/vcl-styles-utils/Vcl.Styles.Preview.pas +++ b/source/vcl-styles-utils/Vcl.Styles.Preview.pas @@ -1,603 +1,660 @@ -unit Vcl.Styles.Preview; - -interface - -Uses - System.Classes, System.Generics.Collections, Winapi.Windows, Vcl.Styles, - Vcl.Themes, Vcl.Forms, Vcl.Graphics, Vcl.Controls, Vcl.ExtCtrls; - -type - TPreviewType = (ptOriginal, ptTabs); - - TVisualStylePreview = class(TCustomControl) - protected - FStyle : TCustomStyleServices; - FIcon : HICON; - FCaption : TCaption; - FRegion : HRGN; - FBitmap : TBitmap; - FPreviewType : TPreviewType; - FFormBorderSize : TRect; - FBkgColor : TColor; - FUnavailableText : string; - FSelectedText : string; - FHotText : string; - FNormalText : string; - FDisabledText : string; - FPressedText : string; - FButtonText : string; - FFileMenuText : string; - FEditMenuText : string; - FViewMenuText : string; - FHelpMenuText : string; - - procedure SetStyle(const aStyle : TCustomStyleServices); - - function GetFormBorderSize : TRect; - function GetMainMenuRect : TRect; - function GetTabsRect : TRect; - - function GetCaptionHeight : integer; - function GetLeftFormBorderWidth : integer; - function GetRightFormBorderWidth : integer; - function GetBottomFormBorderHeight : integer; - function RectVCenter(var aRect : TRect; aBounds : TRect): TRect; - - procedure DrawCaption; - procedure DrawFormBorders; - procedure DrawMainMenu; - procedure DrawToolButtons; - procedure DrawButtons; - procedure DrawTabs; - procedure DrawDefaultPanel; - procedure DrawOriginalPreview; - procedure DrawTabsPreview; - - procedure Paint; override; - - public - constructor Create(AControl: TComponent); override; - destructor Destroy; override; - procedure AfterConstruction; override; - - property Icon : HICON read FIcon write FIcon; - property Style : TCustomStyleServices read FStyle write SetStyle; - property Caption : TCaption read FCaption write FCaption; - property Bitmap : TBitmap read FBitmap write FBitmap; - property UnavailableText : string read FUnavailableText write FUnavailableText; - property SelectedText : string read FSelectedText write FSelectedText; - property HotText : string read FHotText write FHotText; - property NormalText : string read FNormalText write FNormalText; - property DisabledText : string read FDisabledText write FDisabledText; - property PressedText : string read FPressedText write FPressedText; - property ButtonText : string read FButtonText write FButtonText; - property FileMenuText : string read FFileMenuText write FFileMenuText; - property EditMenuText : string read FEditMenuText write FEditMenuText; - property ViewMenuText : string read FViewMenuText write FViewMenuText; - property HelpMenuText : string read FHelpMenuText write FHelpMenuText; - - published - property PreviewType : TPreviewType read FPreviewType write FPreviewType; - property BkgColor : TColor read FBkgColor write FBkgColor; - property Align; - property Anchors; - property Visible; - end; - -implementation - -uses - System.SysUtils, System.Types, System.UITypes; - -const - ORIGINAL_PPI = 96; - -constructor TVisualStylePreview.Create(AControl: TComponent); -begin - inherited Create(AControl); - - FRegion := 0; - FStyle := nil; - FCaption := ''; - FIcon := 0; - FBitmap := nil; - FPreviewType := ptOriginal; - FFormBorderSize := rect(0, 0, 0, 0); - FBkgColor := clNone; - - FUnavailableText := 'Preview not available'; - FSelectedText := 'Selected'; - FHotText := 'Hot'; - FNormalText := 'Normal'; - FDisabledText := 'Disabled'; - FPressedText := 'Pressed'; - FButtonText := 'ToolButton'; - FFileMenuText := 'File'; - FEditMenuText := 'Edit'; - FViewMenuText := 'View'; - FHelpMenuText := 'Help'; -end; - -destructor TVisualStylePreview.Destroy; -begin - try - if (FRegion <> 0) then - begin - DeleteObject(FRegion); - FRegion := 0; - end; - - if (FBitmap <> nil) then FreeAndNil(FBitmap); - if (FStyle <> nil) then FreeAndNil(FStyle); - if (FStyle <> nil) then FreeAndNil(FStyle); - finally - inherited Destroy; - end; -end; - -procedure TVisualStylePreview.AfterConstruction; -begin - inherited AfterConstruction; - - FBitmap := TBitmap.Create; - FBitmap.PixelFormat := pf32bit; -end; - -procedure TVisualStylePreview.SetStyle(const aStyle : TCustomStyleServices); -begin - if (FStyle <> nil) then FreeAndNil(FStyle); - - FStyle := aStyle; - Refresh; -end; - -function TVisualStylePreview.GetCaptionHeight : integer; -var - LSize : TSize; - LDetails : TThemedElementDetails; -begin - LDetails := FStyle.GetElementDetails(twCaptionActive); - FStyle.GetElementSize(0, LDetails, esActual, LSize); - Result := LSize.cy; -end; - -function TVisualStylePreview.GetLeftFormBorderWidth : integer; -var - LSize : TSize; - LDetails : TThemedElementDetails; -begin - LDetails := FStyle.GetElementDetails(twFrameLeftActive); - FStyle.GetElementSize(0, LDetails, esActual, LSize); - Result := LSize.cx; -end; - -function TVisualStylePreview.GetRightFormBorderWidth : integer; -var - LSize : TSize; - LDetails : TThemedElementDetails; -begin - LDetails := FStyle.GetElementDetails(twFrameRightActive); - FStyle.GetElementSize(0, LDetails, esActual, LSize); - Result := LSize.cx; -end; - -function TVisualStylePreview.GetBottomFormBorderHeight : integer; -var - LSize : TSize; - LDetails : TThemedElementDetails; -begin - LDetails := FStyle.GetElementDetails(twFrameBottomActive); - FStyle.GetElementSize(0, LDetails, esActual, LSize); - Result := LSize.cy; -end; - -function TVisualStylePreview.GetFormBorderSize: TRect; -begin - Result.Top := GetCaptionHeight; - Result.Left := GetLeftFormBorderWidth; - Result.Right := GetRightFormBorderWidth; - Result.Bottom := GetBottomFormBorderHeight; -end; - -function TVisualStylePreview.GetMainMenuRect : TRect; -const - MENU_ITEM_HEIGHT = 20; -begin - Result.Left := FFormBorderSize.Left; - Result.Top := FFormBorderSize.Top; - Result.Right := FBitmap.Width - FFormBorderSize.Right; - Result.Bottom := Result.Top + MulDiv(MENU_ITEM_HEIGHT, screen.PixelsPerInch, ORIGINAL_PPI); -end; - -function TVisualStylePreview.GetTabsRect : TRect; -const - TABS_HEIGHT = 27; -begin - Result.Left := FFormBorderSize.Left; - Result.Top := FFormBorderSize.Top; - Result.Right := FBitmap.Width - FFormBorderSize.Right; - Result.Bottom := Result.Top + MulDiv(TABS_HEIGHT, screen.PixelsPerInch, ORIGINAL_PPI); -end; - -function TVisualStylePreview.RectVCenter(var aRect : TRect; aBounds : TRect): TRect; -begin - OffsetRect(aRect, - aRect.Left, - aRect.Top); - OffsetRect(aRect, 0, (aBounds.Height - aRect.Height) div 2); - OffsetRect(aRect, aBounds.Left, aBounds.Top); - - Result := aRect; -end; - -procedure TVisualStylePreview.DrawDefaultPanel; -var - LDetails : TThemedElementDetails; - LColor : TColor; - LRect : TRect; -begin - LRect := rect(0, 0, FBitmap.Width, FBitmap.Height); - - if (csDesigning in ComponentState) then - begin - if (FBkgColor <> clNone) then - FBitmap.Canvas.Brush.Color := FBkgColor - else - FBitmap.Canvas.Brush.Color := clWhite; - - FBitmap.Canvas.Brush.Style := bsSolid; - FBitmap.Canvas.FillRect(LRect); - exit; - end; - - if (FBkgColor <> clNone) then - LColor := FBkgColor - else - begin - LDetails := StyleServices.GetElementDetails(tpPanelBackground); - - if not(StyleServices.GetElementColor(LDetails, ecFillColor, LColor)) then - LColor := GetSysColor(COLOR_BTNFACE); - end; - - FBitmap.Canvas.Brush.Color := LColor; - FBitmap.Canvas.Brush.Style := bsSolid; - FBitmap.Canvas.FillRect(LRect); - - if (length(FUnavailableText) > 0) then - begin - if not(StyleServices.GetElementColor(LDetails, ecTextColor, LColor)) then - LColor := GetSysColor(COLOR_BTNTEXT); - - FBitmap.Canvas.Font.Color := LColor; - FBitmap.Canvas.TextRect(LRect, FUnavailableText, [tfVerticalCenter, tfCenter, tfSingleLine]); - end; -end; - -procedure TVisualStylePreview.DrawCaption; -var - LClientRect : TRect; - LCaptionRect : TRect; - LTextRect : TRect; - LIconRect : TRect; - LButtonRect : TRect; - LDetails : TThemedElementDetails; - LCaptionDetails : TThemedElementDetails; - LIconDetails : TThemedElementDetails; - LRegion : HRGN; -begin - LClientRect := ClientRect; - LCaptionRect := Rect(0, 0, FBitmap.Width, FFormBorderSize.Top); - - //Draw background - LDetails.Element := teWindow; - LDetails.Part := 0; - FStyle.DrawElement(FBitmap.Canvas.Handle, LDetails, LClientRect); - - //Draw caption border - LDetails := FStyle.GetElementDetails(twCaptionActive); - - LRegion := FRegion; - try - FStyle.GetElementRegion(LDetails, LClientRect, FRegion); - SetWindowRgn(Handle, FRegion, True); - finally - if (LRegion <> 0) then DeleteObject(LRegion); - end; - - FStyle.DrawElement(FBitmap.Canvas.Handle, LDetails, LCaptionRect); - LTextRect := LCaptionRect; - LCaptionDetails := LDetails; - - //Draw icon - LIconDetails := FStyle.GetElementDetails(twSysButtonNormal); - LIconRect := Rect(0, 0, GetSystemMetrics(SM_CXSMICON), GetSystemMetrics(SM_CYSMICON)); - - if not(FStyle.GetElementContentRect(0, LIconDetails, LCaptionRect, LButtonRect)) then - LButtonRect := Rect(0, 0, 0, 0); - - RectVCenter(LIconRect, LButtonRect); - - if (LButtonRect.Width > 0) and (FIcon <> 0) then - DrawIconEx(FBitmap.Canvas.Handle, LIconRect.Left, LIconRect.Top, FIcon, 0, 0, 0, 0, DI_NORMAL); - - Inc(LTextRect.Left, LButtonRect.Width + MulDiv(5, screen.PixelsPerInch, ORIGINAL_PPI)); - - //Draw buttons - - //Close button - LDetails := FStyle.GetElementDetails(twCloseButtonNormal); - if FStyle.GetElementContentRect(0, LDetails, LCaptionRect, LButtonRect) then - FStyle.DrawElement(FBitmap.Canvas.Handle, LDetails, LButtonRect); - - //Maximize button - LDetails := FStyle.GetElementDetails(twMaxButtonNormal); - if FStyle.GetElementContentRect(0, LDetails, LCaptionRect, LButtonRect) then - FStyle.DrawElement(FBitmap.Canvas.Handle, LDetails, LButtonRect); - - //Minimize button - LDetails := FStyle.GetElementDetails(twMinButtonNormal); - - if FStyle.GetElementContentRect(0, LDetails, LCaptionRect, LButtonRect) then - FStyle.DrawElement(FBitmap.Canvas.Handle, LDetails, LButtonRect); - - //Help button - LDetails := FStyle.GetElementDetails(twHelpButtonNormal); - if FStyle.GetElementContentRect(0, LDetails, LCaptionRect, LButtonRect) then - FStyle.DrawElement(FBitmap.Canvas.Handle, LDetails, LButtonRect); - - if (LButtonRect.Left > 0) then LTextRect.Right := LButtonRect.Left; - - //Draw text - FStyle.DrawText(FBitmap.Canvas.Handle, LCaptionDetails, FCaption, LTextRect, [tfLeft, tfSingleLine, tfVerticalCenter]); -end; - -procedure TVisualStylePreview.DrawFormBorders; -var - LRect : TRect; - LDetails : TThemedElementDetails; -begin - //Draw left border - LRect := Rect(0, FFormBorderSize.Top, FFormBorderSize.Left, FBitmap.Height - FFormBorderSize.Bottom); - LDetails := FStyle.GetElementDetails(twFrameLeftActive); - FStyle.DrawElement(FBitmap.Canvas.Handle, LDetails, LRect); - - //Draw right border - LRect := Rect(FBitmap.Width - FFormBorderSize.Right, FFormBorderSize.Top, FBitmap.Width, FBitmap.Height - FFormBorderSize.Bottom); - LDetails := FStyle.GetElementDetails(twFrameRightActive); - FStyle.DrawElement(FBitmap.Canvas.Handle, LDetails, LRect); - - //Draw Bottom border - LRect := Rect(0, FBitmap.Height - FFormBorderSize.Bottom, FBitmap.Width, FBitmap.Height); - LDetails := FStyle.GetElementDetails(twFrameBottomActive); - FStyle.DrawElement(FBitmap.Canvas.Handle, LDetails, LRect); -end; - -procedure TVisualStylePreview.DrawMainMenu; -const - MENU_ITEM_WIDTH = 30; -var - LMenuRect : TRect; - LItemRect : TRect; - LDetails : TThemedElementDetails; - LColor : TColor; - LWidth : integer; -begin - LMenuRect := GetMainMenuRect; - - LDetails := FStyle.GetElementDetails(tmMenuBarBackgroundActive); - FStyle.DrawElement(FBitmap.Canvas.Handle, LDetails, LMenuRect); - - LDetails := FStyle.GetElementDetails(tmMenuBarItemNormal); - FStyle.GetElementColor(LDetails, ecTextColor, LColor); - - LWidth := MulDiv(MENU_ITEM_WIDTH, screen.PixelsPerInch, ORIGINAL_PPI); - - LItemRect.Left := LMenuRect.Left + MulDiv(10, screen.PixelsPerInch, ORIGINAL_PPI); - LItemRect.Top := LMenuRect.Top + MulDiv(3, screen.PixelsPerInch, ORIGINAL_PPI); - LItemRect.Right := LItemRect.Left + LWidth; - LItemRect.Bottom := LMenuRect.Bottom; - FStyle.DrawText(FBitmap.Canvas.Handle, LDetails, FFileMenuText, LItemRect, [tfLeft], LColor); - - LItemRect.Left := LItemRect.Right; - LItemRect.Right := LItemRect.Left + LWidth; - FStyle.DrawText(FBitmap.Canvas.Handle, LDetails, FEditMenuText, LItemRect, [tfLeft], LColor); - - LItemRect.Left := LItemRect.Right; - LItemRect.Right := LItemRect.Left + LWidth; - FStyle.DrawText(FBitmap.Canvas.Handle, LDetails, FViewMenuText, LItemRect, [tfLeft], LColor); - - LItemRect.Left := LItemRect.Right; - LItemRect.Right := LItemRect.Left + LWidth; - FStyle.DrawText(FBitmap.Canvas.Handle, LDetails, FHelpMenuText, LItemRect, [tfLeft], LColor); -end; - -procedure TVisualStylePreview.DrawToolButtons; -const - BUTTON_WIDTH = 75; - BUTTON_HEIGHT = 25; - PANEL_PADDING = 10; -var - LMenuRect : TRect; - LButtonRect : TRect; - LDetails : TThemedElementDetails; - LColor : TColor; - i : integer; - LWidth : integer; - LHeight : integer; - LPadding : integer; -begin - LMenuRect := GetMainMenuRect; - LWidth := MulDiv(BUTTON_WIDTH, screen.PixelsPerInch, ORIGINAL_PPI); - LHeight := MulDiv(BUTTON_HEIGHT, screen.PixelsPerInch, ORIGINAL_PPI); - LPadding := MulDiv(PANEL_PADDING, screen.PixelsPerInch, ORIGINAL_PPI); - - LButtonRect.Left := FFormBorderSize.Left + LPadding; - LButtonRect.Top := LMenuRect.Bottom + LPadding; - LButtonRect.Right := LButtonRect.Left + LWidth; - LButtonRect.Bottom := LButtonRect.Top + LHeight; - - for i := 1 to 3 do - begin - LDetails := FStyle.GetElementDetails(ttbButtonNormal); - FStyle.DrawElement(FBitmap.Canvas.Handle, LDetails, LButtonRect); - - FStyle.GetElementColor(LDetails, ecTextColor, LColor); - FStyle.DrawText(FBitmap.Canvas.Handle, LDetails, FButtonText + IntToStr(i), LButtonRect, TTextFormatFlags(DT_VCENTER or DT_CENTER), LColor); - - LButtonRect.Left := LButtonRect.Right; - LButtonRect.Right := LButtonRect.Left + LWidth; - end; -end; - -procedure TVisualStylePreview.DrawButtons; -const - BUTTON_WIDTH = 75; - BUTTON_HEIGHT = 25; - PANEL_PADDING = 10; -var - LButtonRect : TRect; - LDetails : TThemedElementDetails; - LColor : TColor; - i : integer; - LCaption : string; - LWidth : integer; - LHeight : integer; - LPadding : integer; -begin - LWidth := MulDiv(BUTTON_WIDTH, screen.PixelsPerInch, ORIGINAL_PPI); - LHeight := MulDiv(BUTTON_HEIGHT, screen.PixelsPerInch, ORIGINAL_PPI); - LPadding := MulDiv(PANEL_PADDING, screen.PixelsPerInch, ORIGINAL_PPI); - - LButtonRect.Left := FFormBorderSize.Left + LPadding; - LButtonRect.Right := LButtonRect.Left + LWidth; - LButtonRect.Bottom := FBitmap.Height - FFormBorderSize.Bottom - LPadding; - LButtonRect.Top := LButtonRect.Bottom - LHeight; - - for i := 1 to 4 do - begin - case i of - 1 : - begin - LDetails := FStyle.GetElementDetails(tbPushButtonNormal); - LCaption := FNormalText; - end; - - 2 : - begin - LDetails := FStyle.GetElementDetails(tbPushButtonHot); - LCaption := FHotText; - end; - - 3 : - begin - LDetails := FStyle.GetElementDetails(tbPushButtonPressed); - LCaption := FPressedText; - end; - - 4 : - begin - LDetails := FStyle.GetElementDetails(tbPushButtonDisabled); - LCaption := FDisabledText; - end; - end; - - FStyle.DrawElement(FBitmap.Canvas.Handle, LDetails, LButtonRect); - FStyle.GetElementColor(LDetails, ecTextColor, LColor); - FStyle.DrawText(FBitmap.Canvas.Handle, LDetails, LCaption, LButtonRect, TTextFormatFlags(DT_VCENTER or DT_CENTER), LColor); - - LButtonRect.Left := LButtonRect.Right + LPadding; - LButtonRect.Right := LButtonRect.Left + LWidth; - end; -end; - -procedure TVisualStylePreview.DrawTabs; -const - TAB_WIDTH = 80; - TAB_OFFSET = 3; -var - LDetails : TThemedElementDetails; - LTabsRect : TRect; - LItemRect : TRect; - LWidth : integer; - LColor : TColor; - LFlags : TTextFormat; - LOffset : integer; -begin - LWidth := MulDiv(TAB_WIDTH, screen.PixelsPerInch, ORIGINAL_PPI); - LOffset := MulDiv(TAB_OFFSET, screen.PixelsPerInch, ORIGINAL_PPI); - LTabsRect := GetTabsRect; - LFlags := TTextFormatFlags(DT_VCENTER or DT_CENTER); - LColor := clBlack; - - // Tabs background - LDetails := StyleServices.GetElementDetails(ttPane); - FStyle.DrawElement(FBitmap.Canvas.Handle, LDetails, LTabsRect); - - - // Selected tab - LItemRect := LTabsRect; - LItemRect.Right := LItemRect.Left + LWidth; - - LDetails := StyleServices.GetElementDetails(ttTabItemSelected); - FStyle.DrawElement(FBitmap.Canvas.Handle, LDetails, LItemRect); - FStyle.GetElementColor(LDetails, ecTextColor, LColor); - FStyle.DrawText(FBitmap.Canvas.Handle, LDetails, FSelectedText, LItemRect, LFlags, LColor); - - - // Hot tab - LItemRect.Left := succ(LItemRect.Right); - LItemRect.Right := LItemRect.Left + LWidth; - LItemRect.Top := LTabsRect.Top + LOffset; // unselected tabs are slightly shorter - - LDetails := StyleServices.GetElementDetails(ttTabItemHot); - FStyle.DrawElement(FBitmap.Canvas.Handle, LDetails, LItemRect); - FStyle.GetElementColor(LDetails, ecTextColor, LColor); - FStyle.DrawText(FBitmap.Canvas.Handle, LDetails, FHotText, LItemRect, LFlags, LColor); - - - // Normal tab - LItemRect.Left := succ(LItemRect.Right); - LItemRect.Right := LItemRect.Left + LWidth; - - LDetails := StyleServices.GetElementDetails(ttTabItemNormal); - FStyle.DrawElement(FBitmap.Canvas.Handle, LDetails, LItemRect); - FStyle.GetElementColor(LDetails, ecTextColor, LColor); - FStyle.DrawText(FBitmap.Canvas.Handle, LDetails, FNormalText, LItemRect, LFlags, LColor); -end; - -procedure TVisualStylePreview.DrawOriginalPreview; -begin - FFormBorderSize := GetFormBorderSize; - - DrawCaption; - DrawFormBorders; - DrawMainMenu; - DrawToolButtons; - DrawButtons; -end; - -procedure TVisualStylePreview.DrawTabsPreview; -begin - FFormBorderSize := GetFormBorderSize; - - DrawCaption; - DrawFormBorders; - DrawTabs; - DrawButtons; -end; - -procedure TVisualStylePreview.Paint; -begin - FBitmap.SetSize(ClientRect.Width, ClientRect.Height); - - if (FStyle = nil) then - DrawDefaultPanel - else - case FPreviewType of - ptOriginal : DrawOriginalPreview; - ptTabs : DrawTabsPreview; - end; - - Canvas.Draw(0, 0, FBitmap); -end; - -end. +unit Vcl.Styles.Preview; + +interface + +Uses + System.Classes, System.Generics.Collections, Winapi.Windows, Vcl.Themes, Vcl.Styles, + Vcl.Forms, Vcl.Graphics, Vcl.Controls, Vcl.ExtCtrls, Vcl.Styles.Utils.Graphics; + +type + TPreviewType = (ptOriginal, ptTabs); + + TVisualStylePreview = class(TCustomControl) + protected + FStyle: TCustomStyleServices; + FIcon: HICON; + FCaption: TCaption; + FRegion: HRGN; + FBitmap: TBitmap; + FPreviewType: TPreviewType; + FFormBorderSize: TRect; + FBkgColor: TColor; + FUnavailableText: string; + FSelectedText: string; + FHotText: string; + FNormalText: string; + FDisabledText: string; + FPressedText: string; + FButtonText: string; + FFileMenuText: string; + FEditMenuText: string; + FViewMenuText: string; + FHelpMenuText: string; + + procedure SetStyle(const aStyle: TCustomStyleServices); + + function GetFormBorderSize: TRect; + function GetMainMenuRect: TRect; + function GetTabsRect: TRect; + + function GetCaptionHeight: integer; + function GetLeftFormBorderWidth: integer; + function GetRightFormBorderWidth: integer; + function GetBottomFormBorderHeight: integer; + function RectVCenter(var aRect: TRect; aBounds: TRect): TRect; + + procedure DrawCaption; + procedure DrawFormBorders; + procedure DrawMainMenu; + procedure DrawToolButtons; + procedure DrawButtons; + procedure DrawTabs; + procedure DrawDefaultPanel; + procedure DrawOriginalPreview; + procedure DrawTabsPreview; + + procedure Paint; override; + + public + constructor Create(AControl: TComponent); override; + destructor Destroy; override; + procedure AfterConstruction; override; + + property Icon: HICON read FIcon write FIcon; + property Style: TCustomStyleServices read FStyle write SetStyle; + property Caption: TCaption read FCaption write FCaption; + property Bitmap: TBitmap read FBitmap write FBitmap; + property UnavailableText: string read FUnavailableText write FUnavailableText; + property SelectedText: string read FSelectedText write FSelectedText; + property HotText: string read FHotText write FHotText; + property NormalText: string read FNormalText write FNormalText; + property DisabledText: string read FDisabledText write FDisabledText; + property PressedText: string read FPressedText write FPressedText; + property ButtonText: string read FButtonText write FButtonText; + property FileMenuText: string read FFileMenuText write FFileMenuText; + property EditMenuText: string read FEditMenuText write FEditMenuText; + property ViewMenuText: string read FViewMenuText write FViewMenuText; + property HelpMenuText: string read FHelpMenuText write FHelpMenuText; + + published + property PreviewType: TPreviewType read FPreviewType write FPreviewType; + property BkgColor: TColor read FBkgColor write FBkgColor; + property Align; + property Anchors; + property Visible; + end; + +implementation + +uses + System.SysUtils, System.Types, System.UITypes, + Vcl.Styles.Utils.Misc; + +const + ORIGINAL_PPI = 96; + +constructor TVisualStylePreview.Create(AControl: TComponent); +begin + inherited Create(AControl); + + FRegion := 0; + FStyle := nil; + FCaption := ''; + FIcon := 0; + FBitmap := nil; + FPreviewType := ptOriginal; + FFormBorderSize := rect(0, 0, 0, 0); + FBkgColor := clNone; + + FUnavailableText := 'Preview not available'; + FSelectedText := 'Selected'; + FHotText := 'Hot'; + FNormalText := 'Normal'; + FDisabledText := 'Disabled'; + FPressedText := 'Pressed'; + FButtonText := 'ToolButton'; + FFileMenuText := 'File'; + FEditMenuText := 'Edit'; + FViewMenuText := 'View'; + FHelpMenuText := 'Help'; +end; + +destructor TVisualStylePreview.Destroy; +begin + try + if (FRegion <> 0) then + begin + DeleteObject(FRegion); + FRegion := 0; + end; + + if (FBitmap <> nil) then FreeAndNil(FBitmap); + if (FStyle <> nil) then FreeAndNil(FStyle); + if (FStyle <> nil) then FreeAndNil(FStyle); + finally + inherited Destroy; + end; +end; + +procedure TVisualStylePreview.AfterConstruction; +begin + inherited AfterConstruction; + + FBitmap := TBitmap.Create; + FBitmap.PixelFormat := pf32bit; +end; + +procedure TVisualStylePreview.SetStyle(const aStyle: TCustomStyleServices); +begin + if (FStyle <> nil) then FreeAndNil(FStyle); + + FStyle := aStyle; + Refresh; +end; + +function TVisualStylePreview.GetCaptionHeight: integer; +var + LSize: TSize; + LDetails: TThemedElementDetails; +begin + LDetails := FStyle.GetElementDetails(twCaptionActive); + if Assigned(Application.Mainform) then + FStyle.GetElementSize(0, LDetails, esActual, LSize{$IF (CompilerVersion >=33)}, Application.MainForm.Monitor.PixelsPerInch{$IFEND}) + else + FStyle.GetElementSize(0, LDetails, esActual, LSize{$IF (CompilerVersion >=33)}, Screen.PixelsPerInch{$IFEND}); + Result := LSize.cy; +end; + +function TVisualStylePreview.GetLeftFormBorderWidth: integer; +var + LSize: TSize; + LDetails: TThemedElementDetails; +begin + LDetails := FStyle.GetElementDetails(twFrameLeftActive); + if Assigned(Application.Mainform) then + FStyle.GetElementSize(0, LDetails, esActual, LSize{$IF (CompilerVersion >=33)}, Application.MainForm.Monitor.PixelsPerInch{$IFEND}) + else + FStyle.GetElementSize(0, LDetails, esActual, LSize{$IF (CompilerVersion >=33)}, Screen.PixelsPerInch{$IFEND}); + Result := LSize.cx; +end; + +function TVisualStylePreview.GetRightFormBorderWidth: integer; +var + LSize: TSize; + LDetails: TThemedElementDetails; +begin + LDetails := FStyle.GetElementDetails(twFrameRightActive); + if Assigned(Application.Mainform) then + FStyle.GetElementSize(0, LDetails, esActual, LSize{$IF (CompilerVersion >=33)}, Application.MainForm.Monitor.PixelsPerInch{$IFEND}) + else + FStyle.GetElementSize(0, LDetails, esActual, LSize{$IF (CompilerVersion >=33)}, Screen.PixelsPerInch{$IFEND}); + Result := LSize.cx; +end; + +function TVisualStylePreview.GetBottomFormBorderHeight: integer; +var + LSize: TSize; + LDetails: TThemedElementDetails; +begin + LDetails := FStyle.GetElementDetails(twFrameBottomActive); + if Assigned(Application.Mainform) then + FStyle.GetElementSize(0, LDetails, esActual, LSize{$IF (CompilerVersion >=33)}, Application.MainForm.Monitor.PixelsPerInch{$IFEND}) + else + FStyle.GetElementSize(0, LDetails, esActual, LSize{$IF (CompilerVersion >=33)}, Screen.PixelsPerInch{$IFEND}); + Result := LSize.cy; +end; + +function TVisualStylePreview.GetFormBorderSize: TRect; +begin + Result.Top := GetCaptionHeight; + Result.Left := GetLeftFormBorderWidth; + Result.Right := GetRightFormBorderWidth; + Result.Bottom := GetBottomFormBorderHeight; +end; + +function TVisualStylePreview.GetMainMenuRect: TRect; +const + MENU_ITEM_HEIGHT = 20; +begin + Result.Left := FFormBorderSize.Left; + Result.Top := FFormBorderSize.Top; + Result.Right := FBitmap.Width - FFormBorderSize.Right; + if Assigned(Application.Mainform) then + Result.Bottom := Result.Top + MulDiv(MENU_ITEM_HEIGHT, Application.MainForm.Monitor.PixelsPerInch, ORIGINAL_PPI) + else + Result.Bottom := Result.Top + MulDiv(MENU_ITEM_HEIGHT, Screen.PixelsPerInch, ORIGINAL_PPI); +end; + +function TVisualStylePreview.GetTabsRect: TRect; +const + TABS_HEIGHT = 27; +begin + Result.Left := FFormBorderSize.Left; + Result.Top := FFormBorderSize.Top; + Result.Right := FBitmap.Width - FFormBorderSize.Right; + if Assigned(Application.Mainform) then + Result.Bottom := Result.Top + MulDiv(TABS_HEIGHT, Application.MainForm.Monitor.PixelsPerInch, ORIGINAL_PPI) + else + Result.Bottom := Result.Top + MulDiv(TABS_HEIGHT, Screen.PixelsPerInch, ORIGINAL_PPI); +end; + +function TVisualStylePreview.RectVCenter(var aRect: TRect; aBounds: TRect): TRect; +begin + OffsetRect(aRect, - aRect.Left, - aRect.Top); + OffsetRect(aRect, 0, (aBounds.Height - aRect.Height) div 2); + OffsetRect(aRect, aBounds.Left, aBounds.Top); + + Result := aRect; +end; + +procedure TVisualStylePreview.DrawDefaultPanel; +var + LDetails: TThemedElementDetails; + LColor: TColor; + LRect: TRect; +begin + LRect := rect(0, 0, FBitmap.Width, FBitmap.Height); + + if (csDesigning in ComponentState) then + begin + if (FBkgColor <> clNone) then + FBitmap.Canvas.Brush.Color := FBkgColor + else + FBitmap.Canvas.Brush.Color := clWhite; + + FBitmap.Canvas.Brush.Style := bsSolid; + FBitmap.Canvas.FillRect(LRect); + exit; + end; + + if (FBkgColor <> clNone) then + LColor := FBkgColor + else + begin + LDetails := StyleServices.GetElementDetails(tpPanelBackground); + + if not(StyleServices.GetElementColor(LDetails, ecFillColor, LColor)) then + LColor := GetSysColor(COLOR_BTNFACE); + end; + + FBitmap.Canvas.Brush.Color := LColor; + FBitmap.Canvas.Brush.Style := bsSolid; + FBitmap.Canvas.FillRect(LRect); + + if (length(FUnavailableText) > 0) then + begin + if not(StyleServices.GetElementColor(LDetails, ecTextColor, LColor)) then + LColor := GetSysColor(COLOR_BTNTEXT); + + FBitmap.Canvas.Font.Color := LColor; + FBitmap.Canvas.TextRect(LRect, FUnavailableText, [tfVerticalCenter, tfCenter, tfSingleLine]); + end; +end; + +procedure TVisualStylePreview.DrawCaption; +var + LClientRect: TRect; + LCaptionRect: TRect; + LTextRect: TRect; + LIconRect: TRect; + LButtonRect: TRect; + LDetails: TThemedElementDetails; + LCaptionDetails: TThemedElementDetails; + LIconDetails: TThemedElementDetails; + LRegion: HRGN; +begin + LClientRect := ClientRect; + LCaptionRect := Rect(0, 0, FBitmap.Width, FFormBorderSize.Top); + + //Draw background + LDetails.Element := teWindow; + LDetails.Part := 0; + DrawStyleElement(FBitmap.Canvas.Handle, LDetails, LClientRect); + + //Draw caption border + LDetails := FStyle.GetElementDetails(twCaptionActive); + + LRegion := FRegion; + try + FStyle.GetElementRegion(LDetails, LClientRect, FRegion); + SetWindowRgn(Handle, FRegion, True); + finally + if (LRegion <> 0) then DeleteObject(LRegion); + end; + + DrawStyleElement(FBitmap.Canvas.Handle, LDetails, LCaptionRect); + LTextRect := LCaptionRect; + LCaptionDetails := LDetails; + + //Draw icon + LIconDetails := FStyle.GetElementDetails(twSysButtonNormal); + LIconRect := Rect(0, 0, GetSysMetrics(SM_CXSMICON), GetSysMetrics(SM_CYSMICON)); + + if not(FStyle.GetElementContentRect(0, LIconDetails, LCaptionRect, LButtonRect)) then + LButtonRect := Rect(0, 0, 0, 0); + + RectVCenter(LIconRect, LButtonRect); + + if (LButtonRect.Width > 0) and (FIcon <> 0) then + DrawIconEx(FBitmap.Canvas.Handle, LIconRect.Left, LIconRect.Top, FIcon, 0, 0, 0, 0, DI_NORMAL); + + if Assigned(Application.Mainform) then + Inc(LTextRect.Left, LButtonRect.Width + MulDiv(5, Application.MainForm.Monitor.PixelsPerInch, ORIGINAL_PPI)) + else + Inc(LTextRect.Left, LButtonRect.Width + MulDiv(5, Screen.PixelsPerInch, ORIGINAL_PPI)); + + //Draw buttons + + //Close button + LDetails := FStyle.GetElementDetails(twCloseButtonNormal); + if FStyle.GetElementContentRect(0, LDetails, LCaptionRect, LButtonRect) then + FStyle.DrawElement(FBitmap.Canvas.Handle, LDetails, LButtonRect); + + //Maximize button + LDetails := FStyle.GetElementDetails(twMaxButtonNormal); + if FStyle.GetElementContentRect(0, LDetails, LCaptionRect, LButtonRect) then + FStyle.DrawElement(FBitmap.Canvas.Handle, LDetails, LButtonRect); + + //Minimize button + LDetails := FStyle.GetElementDetails(twMinButtonNormal); + + if FStyle.GetElementContentRect(0, LDetails, LCaptionRect, LButtonRect) then + FStyle.DrawElement(FBitmap.Canvas.Handle, LDetails, LButtonRect); + + //Help button + LDetails := FStyle.GetElementDetails(twHelpButtonNormal); + if FStyle.GetElementContentRect(0, LDetails, LCaptionRect, LButtonRect) then + FStyle.DrawElement(FBitmap.Canvas.Handle, LDetails, LButtonRect); + + if (LButtonRect.Left > 0) then LTextRect.Right := LButtonRect.Left; + + //Draw text + FStyle.DrawText(FBitmap.Canvas.Handle, LCaptionDetails, FCaption, LTextRect, [tfLeft, tfSingleLine, tfVerticalCenter]); +end; + +procedure TVisualStylePreview.DrawFormBorders; +var + LRect: TRect; + LDetails: TThemedElementDetails; +begin + //Draw left border + LRect := Rect(0, FFormBorderSize.Top, FFormBorderSize.Left, FBitmap.Height - FFormBorderSize.Bottom); + LDetails := FStyle.GetElementDetails(twFrameLeftActive); + DrawStyleElement(FBitmap.Canvas.Handle, LDetails, LRect); + + //Draw right border + LRect := Rect(FBitmap.Width - FFormBorderSize.Right, FFormBorderSize.Top, FBitmap.Width, FBitmap.Height - FFormBorderSize.Bottom); + LDetails := FStyle.GetElementDetails(twFrameRightActive); + DrawStyleElement(FBitmap.Canvas.Handle, LDetails, LRect); + + //Draw Bottom border + LRect := Rect(0, FBitmap.Height - FFormBorderSize.Bottom, FBitmap.Width, FBitmap.Height); + LDetails := FStyle.GetElementDetails(twFrameBottomActive); + DrawStyleElement(FBitmap.Canvas.Handle, LDetails, LRect); +end; + +procedure TVisualStylePreview.DrawMainMenu; +const + MENU_ITEM_WIDTH = 30; +var + LMenuRect: TRect; + LItemRect: TRect; + LDetails: TThemedElementDetails; + LColor: TColor; + LWidth: integer; +begin + LMenuRect := GetMainMenuRect; + + LDetails := FStyle.GetElementDetails(tmMenuBarBackgroundActive); + DrawStyleElement(FBitmap.Canvas.Handle, LDetails, LMenuRect); + + LDetails := FStyle.GetElementDetails(tmMenuBarItemNormal); + FStyle.GetElementColor(LDetails, ecTextColor, LColor); + + if Assigned(Application.Mainform) then + begin + LWidth := MulDiv(MENU_ITEM_WIDTH, Application.MainForm.Monitor.PixelsPerInch, ORIGINAL_PPI); + LItemRect.Left := LMenuRect.Left + MulDiv(10, Application.MainForm.Monitor.PixelsPerInch, ORIGINAL_PPI); + LItemRect.Top := LMenuRect.Top + MulDiv(3, Application.MainForm.Monitor.PixelsPerInch, ORIGINAL_PPI); + end + else + begin + LWidth := MulDiv(MENU_ITEM_WIDTH, Screen.PixelsPerInch, ORIGINAL_PPI); + LItemRect.Left := LMenuRect.Left + MulDiv(10, Screen.PixelsPerInch, ORIGINAL_PPI); + LItemRect.Top := LMenuRect.Top + MulDiv(3, Screen.PixelsPerInch, ORIGINAL_PPI); + end; + + LItemRect.Right := LItemRect.Left + LWidth; + LItemRect.Bottom := LMenuRect.Bottom; + FStyle.DrawText(FBitmap.Canvas.Handle, LDetails, FFileMenuText, LItemRect, [tfLeft], LColor); + + LItemRect.Left := LItemRect.Right; + LItemRect.Right := LItemRect.Left + LWidth; + FStyle.DrawText(FBitmap.Canvas.Handle, LDetails, FEditMenuText, LItemRect, [tfLeft], LColor); + + LItemRect.Left := LItemRect.Right; + LItemRect.Right := LItemRect.Left + LWidth; + FStyle.DrawText(FBitmap.Canvas.Handle, LDetails, FViewMenuText, LItemRect, [tfLeft], LColor); + + LItemRect.Left := LItemRect.Right; + LItemRect.Right := LItemRect.Left + LWidth; + FStyle.DrawText(FBitmap.Canvas.Handle, LDetails, FHelpMenuText, LItemRect, [tfLeft], LColor); +end; + +procedure TVisualStylePreview.DrawToolButtons; +const + BUTTON_WIDTH = 75; + BUTTON_HEIGHT = 25; + PANEL_PADDING = 10; +var + LMenuRect: TRect; + LButtonRect: TRect; + LDetails: TThemedElementDetails; + LColor: TColor; + i: integer; + LWidth: integer; + LHeight: integer; + LPadding: integer; +begin + LMenuRect := GetMainMenuRect; + if Assigned(Application.Mainform) then + begin + LWidth := MulDiv(BUTTON_WIDTH, Application.MainForm.Monitor.PixelsPerInch, ORIGINAL_PPI); + LHeight := MulDiv(BUTTON_HEIGHT, Application.MainForm.Monitor.PixelsPerInch, ORIGINAL_PPI); + LPadding := MulDiv(PANEL_PADDING, Application.MainForm.Monitor.PixelsPerInch, ORIGINAL_PPI); + end + else + begin + LWidth := MulDiv(BUTTON_WIDTH, Screen.PixelsPerInch, ORIGINAL_PPI); + LHeight := MulDiv(BUTTON_HEIGHT, Screen.PixelsPerInch, ORIGINAL_PPI); + LPadding := MulDiv(PANEL_PADDING, Screen.PixelsPerInch, ORIGINAL_PPI); + end; + + LButtonRect.Left := FFormBorderSize.Left + LPadding; + LButtonRect.Top := LMenuRect.Bottom + LPadding; + LButtonRect.Right := LButtonRect.Left + LWidth; + LButtonRect.Bottom := LButtonRect.Top + LHeight; + + for i := 1 to 3 do + begin + LDetails := FStyle.GetElementDetails(ttbButtonNormal); + DrawStyleElement(FBitmap.Canvas.Handle, LDetails, LButtonRect); + + FStyle.GetElementColor(LDetails, ecTextColor, LColor); + FStyle.DrawText(FBitmap.Canvas.Handle, LDetails, FButtonText + IntToStr(i), LButtonRect, TTextFormatFlags(DT_VCENTER or DT_CENTER), LColor); + + LButtonRect.Left := LButtonRect.Right; + LButtonRect.Right := LButtonRect.Left + LWidth; + end; +end; + +procedure TVisualStylePreview.DrawButtons; +const + BUTTON_WIDTH = 75; + BUTTON_HEIGHT = 25; + PANEL_PADDING = 10; +var + LButtonRect: TRect; + LDetails: TThemedElementDetails; + LColor: TColor; + i: integer; + LCaption: string; + LWidth: integer; + LHeight: integer; + LPadding: integer; +begin + if Assigned(Application.Mainform) then + begin + LWidth := MulDiv(BUTTON_WIDTH, Application.MainForm.Monitor.PixelsPerInch, ORIGINAL_PPI); + LHeight := MulDiv(BUTTON_HEIGHT, Application.MainForm.Monitor.PixelsPerInch, ORIGINAL_PPI); + LPadding := MulDiv(PANEL_PADDING, Application.MainForm.Monitor.PixelsPerInch, ORIGINAL_PPI); + end + else + begin + LWidth := MulDiv(BUTTON_WIDTH, Screen.PixelsPerInch, ORIGINAL_PPI); + LHeight := MulDiv(BUTTON_HEIGHT, Screen.PixelsPerInch, ORIGINAL_PPI); + LPadding := MulDiv(PANEL_PADDING, Screen.PixelsPerInch, ORIGINAL_PPI); + end; + + LButtonRect.Left := FFormBorderSize.Left + LPadding; + LButtonRect.Right := LButtonRect.Left + LWidth; + LButtonRect.Bottom := FBitmap.Height - FFormBorderSize.Bottom - LPadding; + LButtonRect.Top := LButtonRect.Bottom - LHeight; + + for i := 1 to 4 do + begin + case i of + 1 : + begin + LDetails := FStyle.GetElementDetails(tbPushButtonNormal); + LCaption := FNormalText; + end; + + 2 : + begin + LDetails := FStyle.GetElementDetails(tbPushButtonHot); + LCaption := FHotText; + end; + + 3 : + begin + LDetails := FStyle.GetElementDetails(tbPushButtonPressed); + LCaption := FPressedText; + end; + + 4 : + begin + LDetails := FStyle.GetElementDetails(tbPushButtonDisabled); + LCaption := FDisabledText; + end; + end; + + DrawStyleElement(FBitmap.Canvas.Handle, LDetails, LButtonRect); + FStyle.GetElementColor(LDetails, ecTextColor, LColor); + FStyle.DrawText(FBitmap.Canvas.Handle, LDetails, LCaption, LButtonRect, TTextFormatFlags(DT_VCENTER or DT_CENTER), LColor); + + LButtonRect.Left := LButtonRect.Right + LPadding; + LButtonRect.Right := LButtonRect.Left + LWidth; + end; +end; + +procedure TVisualStylePreview.DrawTabs; +const + TAB_WIDTH = 80; + TAB_OFFSET = 3; +var + LDetails: TThemedElementDetails; + LTabsRect: TRect; + LItemRect: TRect; + LWidth: integer; + LColor: TColor; + LFlags: TTextFormat; + LOffset: integer; +begin + if Assigned(Application.Mainform) then + begin + LWidth := MulDiv(TAB_WIDTH, Application.MainForm.Monitor.PixelsPerInch, ORIGINAL_PPI); + LOffset := MulDiv(TAB_OFFSET, Application.MainForm.Monitor.PixelsPerInch, ORIGINAL_PPI); + end + else + begin + LWidth := MulDiv(TAB_WIDTH, Screen.PixelsPerInch, ORIGINAL_PPI); + LOffset := MulDiv(TAB_OFFSET, Screen.PixelsPerInch, ORIGINAL_PPI); + end; + LTabsRect := GetTabsRect; + LFlags := TTextFormatFlags(DT_VCENTER or DT_CENTER); + LColor := clBlack; + + // Tabs background + LDetails := StyleServices.GetElementDetails(ttPane); + DrawStyleElement(FBitmap.Canvas.Handle, LDetails, LTabsRect); + + + // Selected tab + LItemRect := LTabsRect; + LItemRect.Right := LItemRect.Left + LWidth; + + LDetails := StyleServices.GetElementDetails(ttTabItemSelected); + FStyle.DrawElement(FBitmap.Canvas.Handle, LDetails, LItemRect); + FStyle.GetElementColor(LDetails, ecTextColor, LColor); + FStyle.DrawText(FBitmap.Canvas.Handle, LDetails, FSelectedText, LItemRect, LFlags, LColor); + + + // Hot tab + LItemRect.Left := succ(LItemRect.Right); + LItemRect.Right := LItemRect.Left + LWidth; + LItemRect.Top := LTabsRect.Top + LOffset; // unselected tabs are slightly shorter + + LDetails := StyleServices.GetElementDetails(ttTabItemHot); + FStyle.DrawElement(FBitmap.Canvas.Handle, LDetails, LItemRect); + FStyle.GetElementColor(LDetails, ecTextColor, LColor); + FStyle.DrawText(FBitmap.Canvas.Handle, LDetails, FHotText, LItemRect, LFlags, LColor); + + + // Normal tab + LItemRect.Left := succ(LItemRect.Right); + LItemRect.Right := LItemRect.Left + LWidth; + + LDetails := StyleServices.GetElementDetails(ttTabItemNormal); + FStyle.DrawElement(FBitmap.Canvas.Handle, LDetails, LItemRect); + FStyle.GetElementColor(LDetails, ecTextColor, LColor); + FStyle.DrawText(FBitmap.Canvas.Handle, LDetails, FNormalText, LItemRect, LFlags, LColor); +end; + +procedure TVisualStylePreview.DrawOriginalPreview; +begin + FFormBorderSize := GetFormBorderSize; + + DrawCaption; + DrawFormBorders; + DrawMainMenu; + DrawToolButtons; + DrawButtons; +end; + +procedure TVisualStylePreview.DrawTabsPreview; +begin + FFormBorderSize := GetFormBorderSize; + + DrawCaption; + DrawFormBorders; + DrawTabs; + DrawButtons; +end; + +procedure TVisualStylePreview.Paint; +begin + FBitmap.SetSize(ClientRect.Width, ClientRect.Height); + + if (FStyle = nil) then + DrawDefaultPanel + else + case FPreviewType of + ptOriginal: DrawOriginalPreview; + ptTabs: DrawTabsPreview; + end; + + Canvas.Draw(0, 0, FBitmap); +end; + +end. diff --git a/source/vcl-styles-utils/Vcl.Styles.Register.pas b/source/vcl-styles-utils/Vcl.Styles.Register.pas index 7a69363ef..d9b9af20a 100644 --- a/source/vcl-styles-utils/Vcl.Styles.Register.pas +++ b/source/vcl-styles-utils/Vcl.Styles.Register.pas @@ -1,17 +1,17 @@ -unit Vcl.Styles.Register; - -interface - -procedure Register; - -implementation - -uses - System.Classes, Vcl.Styles.Preview; - -procedure Register; -begin - RegisterComponents('VisualStyles', [TVisualStylePreview]); -end; - -end. +unit Vcl.Styles.Register; + +interface + +procedure Register; + +implementation + +uses + System.Classes, Vcl.Styles.Preview; + +procedure Register; +begin + RegisterComponents('VisualStyles', [TVisualStylePreview]); +end; + +end. diff --git a/source/vcl-styles-utils/Vcl.Styles.Utils.ComCtrls.pas b/source/vcl-styles-utils/Vcl.Styles.Utils.ComCtrls.pas index 75845175e..6ab8d6d7c 100644 --- a/source/vcl-styles-utils/Vcl.Styles.Utils.ComCtrls.pas +++ b/source/vcl-styles-utils/Vcl.Styles.Utils.ComCtrls.pas @@ -1,2824 +1,2826 @@ -//************************************************************************************************** -// -// Unit Vcl.Styles.Utils.ComCtrls -// unit for the VCL Styles Utils -// https://github.com/RRUZ/vcl-styles-utils/ -// -// 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. -// -// -// Portions created by Mahdi Safsafi [SMP3] e-mail SMP@LIVE.FR -// Portions created by Rodrigo Ruz V. are Copyright (C) 2013-2019 Rodrigo Ruz V. -// All Rights Reserved. -// -//************************************************************************************************ -unit Vcl.Styles.Utils.ComCtrls; - -{$I VCL.Styles.Utils.inc} - -interface - -uses - System.Classes, - System.Types, - System.SysUtils, - Winapi.Windows, - Winapi.Messages, - Winapi.CommCtrl, - Winapi.RichEdit, - Vcl.Styles, - Vcl.Themes, - Vcl.Graphics, - {$IFDEF USE_Vcl.Styles.Hooks} - Vcl.Styles.Hooks, - {$ENDIF} - Vcl.Styles.Utils.SysStyleHook, - Vcl.Styles.Utils.StdCtrls, - Vcl.Forms, - Vcl.ImgList, - Vcl.ComCtrls, - Vcl.ExtCtrls, - Vcl.Styles.Utils.Forms, - Vcl.Controls; - -type - TSysListViewStyleHook = class(TSysScrollingStyleHook) - private type -{$REGION 'TSysHeaderStyleHook'} - TSysHeaderStyleHook = class(TMouseTrackSysControlStyleHook) - private type -{$REGION 'TSysSection'} - TSysSection = class - private - FIndex: Integer; - FColumnIndex: Integer; - FImageIndex: Integer; - FImageListHandle: THandle; - FText: String; - FSectionRect: TRect; - FHeaderHandle: THandle; - FHasSplitButton: Boolean; - FTextFormat: TTextFormat; - FBitmapOnRight: Boolean; - FShowImage: Boolean; - FDropDownRect: TRect; - protected - procedure DoGetSectionInfo; - public - constructor Create(SysParent: TSysControl; Index: Integer); virtual; - Destructor Destroy; override; - property Text: string read FText; - property ImageListHandle: THandle read FImageListHandle; - property ImageIndex: Integer read FImageIndex; - property SectionRect: TRect read FSectionRect; - property ColumnIndex: Integer read FColumnIndex; - property ShowImage: Boolean read FShowImage; - property BitmapOnRight: Boolean read FBitmapOnRight; - property TextFormat: TTextFormat read FTextFormat; - property HasSplitButton: Boolean read FHasSplitButton; - property DropDownRect: TRect read FDropDownRect; - end; -{$ENDREGION} - private - FPressedSection: Integer; - FMouseDown: Boolean; - FSysSection: TSysSection; - FListViewStyleHook: TSysListViewStyleHook; - function GetButtonsCount: Integer; - function GetItem(Index: Integer): TSysSection; - protected - procedure MouseLeave; override; - procedure WndProc(var Message: TMessage); override; - procedure Paint(Canvas: TCanvas); override; - procedure PaintBackground(Canvas: TCanvas); override; - - public - constructor Create(AHandle: THandle); override; - Destructor Destroy; override; - property ButtonsCount: Integer read GetButtonsCount; - property Items[Index: Integer]: TSysSection read GetItem; - end; -{$ENDREGION} - private - FHeaderHandle: THandle; - FHeaderStyleHook: TSysHeaderStyleHook; - protected - procedure Scroll(const Kind: TScrollBarKind; const ScrollType: TSysScrollingType; Pos, Delta: Integer); override; - procedure UpdateColors; override; - procedure WndProc(var Message: TMessage); override; - procedure PaintBackground(Canvas: TCanvas); override; - procedure Paint(Canvas: TCanvas); override; - - public - procedure SetSelectedColumn(iCol: Integer); - constructor Create(AHandle: THandle); override; - Destructor Destroy; override; - property HeaderHandle: THandle read FHeaderHandle write FHeaderHandle; - end; - - TSysTreeViewStyleHook = class(TSysScrollingStyleHook) - protected - procedure Scroll(const Kind: TScrollBarKind; const ScrollType: TSysScrollingType; Pos, Delta: Integer); override; - procedure UpdateColors; override; - procedure WndProc(var Message: TMessage); override; - public - constructor Create(AHandle: THandle); override; - Destructor Destroy; override; - end; - - TSysTabControlStyleHook = class(TMouseTrackSysControlStyleHook) - private - FHotTabIndex: Integer; - function GetDisplayRect: TRect; - function GetTabCount: Integer; - function GetTabIndex: Integer; - function GetImages: TCustomImageList; - function GetTabRect(Index: Integer): TRect; - function GetTabPosition: TTabPosition; - function GetTabs(Index: Integer): string; - procedure AngleTextOut(Canvas: TCanvas; const Angle, X, Y: Integer; const Text: string); - protected - procedure DrawTab(Canvas: TCanvas; const Index: Integer); - procedure PaintBackground(Canvas: TCanvas); override; - procedure Paint(Canvas: TCanvas); override; - procedure PaintNC(Canvas: TCanvas); override; - procedure WndProc(var Message: TMessage); override; - public - constructor Create(AHandle: THandle); override; - Destructor Destroy; override; - property DisplayRect: TRect read GetDisplayRect; - property TabCount: Integer read GetTabCount; - property TabIndex: Integer read GetTabIndex; - property Images: TCustomImageList read GetImages; - property TabRect[Index: Integer]: TRect read GetTabRect; - property TabPosition: TTabPosition read GetTabPosition; - property Tabs[Index: Integer]: string read GetTabs; - end; - - TSysRichEditStyleHook = class(TSysScrollingStyleHook) - strict private - - procedure EMSetBkgndColor(var Message: TMessage); message EM_SETBKGNDCOLOR; - procedure EMSetCharFormat(var Message: TMessage); message EM_SETCHARFORMAT; - strict private - FBackColor: TColor; - protected - procedure UpdateColors; override; - procedure WndProc(var Message: TMessage); override; - function GetBorderSize: TRect; override; - public - property BackColor: TColor read FBackColor write FBackColor; - constructor Create(AHandle: THandle); override; - end; - -type - TSysToolbarButtonState = set of (bsEnabled, bsPressed, bsChecked, bsHidden); - TSysToolbarButtonStyle = set of (bsBtn, bsSep, bsCheck, bsGroup, bsCheckGroup, bsDropDown); - - TSysReBarStyleHook = class(TSysStyleHook) - strict private - function GetBandText(const Index: Integer): string; - function GetBandRect(const Index: Integer): TRect; - function GetBandBorder(const Index: Integer): TRect; - function GetBandCount: Integer; - strict protected - procedure PaintBackground(Canvas: TCanvas); override; - procedure Paint(Canvas: TCanvas); override; - procedure PaintNC(Canvas: TCanvas); override; - procedure WndProc(var Message: TMessage); override; - public - constructor Create(AHandle: THandle); override; - end; - - TSysStatusBarStyleHook = class(TSysStyleHook) - strict protected - procedure Paint(Canvas: TCanvas); override; - procedure WndProc(var Message: TMessage); override; - public - constructor Create(AHandle: THandle); override; - end; - - TSysTrackBarStyleHook = class(TSysStyleHook) - strict private - FMouseOnThumb: Boolean; - FThumbPressed: Boolean; - strict protected - procedure Paint(Canvas: TCanvas); override; - procedure PaintBackground(Canvas: TCanvas); override; - procedure WndProc(var Message: TMessage); override; - public - constructor Create(AHandle: THandle); override; - end; - - TSysToolbarStyleHook = class(TMouseTrackSysControlStyleHook) - private type -{$REGION 'TSysToolbarButton'} - TSysToolbarButton = class - private - FParent: TSysControl; - FIndex: Integer; - FText: String; - FImageIndex: Integer; - FState: TSysToolbarButtonState; - FStyle: TSysToolbarButtonStyle; - function GetItemRect: TRect; - procedure DoGetItemInfo; - function GetDropDownWidth: Integer; - public - constructor Create(SysParent: TSysControl; Index: Integer); virtual; - Destructor Destroy; override; - property ItemRect: TRect read GetItemRect; - property Parent: TSysControl read FParent; - property Text: String Read FText; - Property ImageIndex: Integer read FImageIndex; - property State: TSysToolbarButtonState read FState; - property Style: TSysToolbarButtonStyle read FStyle; - property DropDownWidth: Integer read GetDropDownWidth; - end; -{$ENDREGION} - - var - FImages: TImageList; - FDisabledImages: TImageList; - FSysToolbarButton: TSysToolbarButton; - FButtonsPainted: Boolean; - function GetItem(Index: Integer): TSysToolbarButton; - function GetCount: Integer; - function IsToolbarTransparent: Boolean; - function IsToolbarFlat: Boolean; - function GetShowText: Boolean; - function IsToolbarList: Boolean; - function IsToolbarWrapable: Boolean; - protected - procedure ApplyImageList; - procedure PaintBackground(Canvas: TCanvas); override; - procedure Paint(Canvas: TCanvas); override; - procedure PaintNC(Canvas: TCanvas); override; - procedure WndProc(var Message: TMessage); override; - public - constructor Create(AHandle: THandle); override; - Destructor Destroy; override; - property Items[index: Integer]: TSysToolbarButton read GetItem; - property Count: Integer read GetCount; - Property Flat: Boolean Read IsToolbarFlat; - Property Transparent: Boolean Read IsToolbarTransparent; - property ShowText: Boolean read GetShowText; - property List: Boolean read IsToolbarList; - property Wrapable: Boolean read IsToolbarWrapable; - end; - - TSysProgressBarStyleHook = class(TSysStyleHook) - strict private - FStep: Integer; - // FLastPos : Integer; - FOrientation: TProgressBarOrientation; - FTimer: TTimer; - procedure TimerAction(Sender: TObject); - function GetBarRect: TRect; - function GetBorderWidth: Integer; - function GetMax: Integer; - function GetMin: Integer; - function GetOrientation: TProgressBarOrientation; - function GetPercent: Single; - function GetPosition: Integer; - procedure WMNCCalcSize(var Message: TWMNCCalcSize); message WM_NCCALCSIZE; - strict protected - procedure PaintBackground(Canvas: TCanvas); override; - procedure PaintBar(Canvas: TCanvas); virtual; - procedure PaintFrame(Canvas: TCanvas); virtual; - procedure Paint(Canvas: TCanvas); override; - procedure WndProc(var Message: TMessage); override; - property BarRect: TRect read GetBarRect; - property BorderWidth: Integer read GetBorderWidth; - property Max: Integer read GetMax; - property Min: Integer read GetMin; - property Orientation: TProgressBarOrientation read GetOrientation; - property Position: Integer read GetPosition; - public - constructor Create(AHandle: THandle); override; - destructor Destroy; override; - end; - - TSysUpDownStyleHook = class(TMouseTrackSysControlStyleHook) - strict private - FLeftPressed, FRightPressed: Boolean; - FMouseOnLeft, FMouseOnRight: Boolean; - function GetOrientation: TUDOrientation; - procedure WMLButtonDblClk(var Message: TWMMouse); message WM_LBUTTONDBLCLK; - procedure WMLButtonDown(var Message: TWMMouse); message WM_LBUTTONDOWN; - procedure WMLButtonUp(var Message: TWMMouse); message WM_LBUTTONUP; - procedure WMMouseMove(var Message: TWMMouse); message WM_MOUSEMOVE; - protected - procedure Paint(Canvas: TCanvas); override; - procedure MouseLeave; override; - procedure WndProc(var Message: TMessage); override; - public - constructor Create(AHandle: THandle); override; - destructor Destroy; override; - end; - - TSysLinkStyleHook = class(TSysStaticStyleHook) - private - procedure WMNCCalcSize(var Message: TWMNCCalcSize); message WM_NCCALCSIZE; - protected - procedure PaintNC(Canvas: TCanvas); override; - procedure Paint(Canvas: TCanvas); override; - procedure WndProc(var Message: TMessage); override; - public - constructor Create(AHandle: THandle); override; - Destructor Destroy; override; - end; - -implementation - -uses - // IOUtils, - Vcl.Styles.Utils.SysControls; - -// -// procedure Addlog(const Msg: string); -// begin -// TFile.AppendAllText('C:\Test\log.txt',Format('%s %s %s',[FormatDateTime('hh:nn:ss.zzz', Now), msg, sLineBreak])); -// end; - -{ TSysListViewStyleHook } - -constructor TSysListViewStyleHook.Create(AHandle: THandle); -begin - inherited; - FHeaderStyleHook := nil; - FHeaderHandle := 0; -{$IF CompilerVersion > 23} - StyleElements := [seFont, seBorder]; -{$ELSE} - OverridePaint := False; - OverridePaintNC := True; - OverrideFont := True; -{$IFEND} - OverrideEraseBkgnd := True; - SendMessage(Handle, WM_NOTIFY, 0, 0); -end; - -procedure TSysListViewStyleHook.Scroll(const Kind: TScrollBarKind; const ScrollType: TSysScrollingType; Pos, Delta: Integer); -var - R: TRect; -begin - if ScrollType = skTracking then - begin - if Kind = sbVertical then - begin - if ListView_GetView(Handle) = LVS_REPORT then - begin - R := Rect(0, 0, 0, 0); - ListView_GetItemRect(Handle, 0, R, LVIR_BOUNDS); - Delta := Delta * R.Height; - end; - ListView_Scroll(Handle, 0, Delta); - end; - if Kind = sbHorizontal then - begin - if ListView_GetView(Handle) = LVS_LIST then - begin - R := TRect.Empty; - ListView_GetItemRect(Handle, 0, R, LVIR_BOUNDS); - Delta := Delta * R.Width; - end; - ListView_Scroll(Handle, Delta, 0); - end; - end - else - inherited; -end; - -procedure TSysListViewStyleHook.SetSelectedColumn(iCol: Integer); -begin - ListView_SetSelectedColumn(Handle, iCol); -end; - -destructor TSysListViewStyleHook.Destroy; -begin - if Assigned(FHeaderStyleHook) then - FreeAndNil(FHeaderStyleHook); - inherited; -end; - -procedure TSysListViewStyleHook.UpdateColors; -begin - inherited; - if OverrideEraseBkgnd then - Color := StyleServices.GetStyleColor(scListView) - else - Color := clWindow; - if OverrideFont then - FontColor := StyleServices.GetSystemColor(clWindowText) - else - FontColor := clWindowText; - - ListView_SetBkColor(Handle, ColorToRGB(Color)); - ListView_SetTextBkColor(Handle, ColorToRGB(Color)); - ListView_SetTextColor(Handle, ColorToRGB(FontColor)); - -end; - -procedure TSysListViewStyleHook.WndProc(var Message: TMessage); -begin - case Message.Msg of - - WM_CREATE, LVM_UPDATE: - begin - Message.Result := CallDefaultProc(Message); - UpdateColors; - SetSelectedColumn(-1); - Exit; - end; - - WM_ERASEBKGND: - begin - UpdateColors; - SetSelectedColumn(-1); - Message.Result := CallDefaultProc(Message); - Exit; - end; - - WM_NOTIFY: - begin - if not Assigned(FHeaderStyleHook) then - begin - HeaderHandle := ListView_GetHeader(Handle); - if (HeaderHandle <> 0) then - begin - FHeaderStyleHook := TSysHeaderStyleHook.Create(HeaderHandle); - FHeaderStyleHook.FListViewStyleHook := Self; - end; - end; - - if (Message.WParam <> 0) or (Message.LParam <> 0) then - Message.Result := CallDefaultProc(Message); - Exit; - end; - else inherited; - end; - -end; - -{ TSysListViewStyleHook.TSysHeaderStyleHook } - -constructor TSysListViewStyleHook.TSysHeaderStyleHook.Create(AHandle: THandle); -begin - inherited; -{$IF CompilerVersion > 23} - StyleElements := [seClient]; -{$ELSE} - OverridePaint := True; - OverridePaintNC := False; - OverrideFont := False; -{$IFEND} - FPressedSection := -1; - FSysSection := nil; -end; - -destructor TSysListViewStyleHook.TSysHeaderStyleHook.Destroy; -begin - if Assigned(FSysSection) then - FreeAndNil(FSysSection); - inherited; -end; - -function TSysListViewStyleHook.TSysHeaderStyleHook.GetButtonsCount: Integer; -begin - Result := Header_GetItemCount(Handle); -end; - -function TSysListViewStyleHook.TSysHeaderStyleHook.GetItem(Index: Integer): TSysSection; -begin - Result := nil; - if (Index > -1) and (index < ButtonsCount) then - begin - if Assigned(FSysSection) then - FreeAndNil(FSysSection); - FSysSection := TSysSection.Create(SysControl, Index); - Result := FSysSection; - end; -end; - -procedure TSysListViewStyleHook.TSysHeaderStyleHook.MouseLeave; -begin - Invalidate; -end; - -procedure TSysListViewStyleHook.TSysHeaderStyleHook.Paint(Canvas: TCanvas); -var - i: Integer; - Bmp: TBitmap; - LImageList: TImageList; - R, TxtRect, ImgRect: TRect; - LSectionRect: TRect; - LTextFormat: TTextFormat; - LText: String; - LSplitDetails, LDetails: TThemedElementDetails; - DC: HDC; - SectionHot: Boolean; - LDropDownRect: TRect; - P: TPoint; -begin - Bmp := TBitmap.Create; - try - Bmp.SetSize(SysControl.Width, SysControl.Height); - Bmp.Canvas.Brush.Color := Color; - R := Rect(0, 0, Bmp.Width, Bmp.Height); - Bmp.Canvas.FillRect(R); - DC := Bmp.Canvas.Handle; - - LDetails := StyleServices.GetElementDetails(thHeaderItemNormal); - StyleServices.DrawElement(DC, LDetails, R); - - for i := 0 to ButtonsCount - 1 do - begin - with Items[i] do - begin - LSectionRect := SectionRect; - LTextFormat := TextFormat; - LText := Text; - LDropDownRect := DropDownRect; - end; - SectionHot := False; - if (MouseInControl) and (not FMouseDown) then - begin - GetCursorPos(P); - ScreenToClient(Handle, P); - if LSectionRect.Contains(P) then - SectionHot := True; - end; - - LDetails := StyleServices.GetElementDetails(thHeaderItemNormal); - if SectionHot then - LDetails := StyleServices.GetElementDetails(thHeaderItemHot); - if FPressedSection = i then - LDetails := StyleServices.GetElementDetails(thHeaderItemPressed); - StyleServices.DrawElement(DC, LDetails, LSectionRect); - - TxtRect := LSectionRect; - inc(TxtRect.Left, 4); - - if Items[i].HasSplitButton then - begin - LSplitDetails := StyleServices.GetElementDetails(ttbDropDownButtonGlyphHot);; - R := LDropDownRect; - if SectionHot then - begin - StyleServices.DrawElement(DC, LSplitDetails, R); - with Bmp.Canvas do - begin - Pen.Color := StyleServices.GetSystemColor(clBtnShadow); - MoveTo(R.Left, 3); - LineTo(R.Left, R.Height - 3); - Pen.Color := StyleServices.GetSystemColor(clBtnHighLight); - MoveTo(R.Left - 1, 3); - LineTo(R.Left - 1, R.Height - 3); - end; - end; - dec(TxtRect.Right, R.Width); - end; - - if (Items[i].ShowImage) and (Items[i].ImageListHandle > 0) then - begin - LImageList := TImageList.Create(nil); - try - LImageList.Handle := Items[i].ImageListHandle; - LImageList.Masked := True; - LImageList.BkColor := clNone; { Transparent bitmap } - R := LSectionRect; - ImgRect := Rect(0, 0, LImageList.Width, LImageList.Height); - ImgRect := RectCenter(ImgRect, R); - if not Items[i].BitmapOnRight then - begin - ImgRect.Left := R.Left + 2; - ImgRect.Right := ImgRect.Left + 2 + LImageList.Width; - inc(TxtRect.Left, ImgRect.Width + 2); - end - else - begin - ImgRect.Left := LSectionRect.Right - LImageList.Width - 2; - ImgRect.Right := LSectionRect.Right; - TxtRect.Right := TxtRect.Right - ImgRect.Width - 2; - end; - LImageList.Draw(Bmp.Canvas, ImgRect.Left, ImgRect.Top, Items[i].ImageIndex); - finally - LImageList.Free; - end; - end; - - include(LTextFormat, tfSingleLine); - include(LTextFormat, tfVerticalCenter); - StyleServices.DrawText(DC, LDetails, LText, TxtRect, LTextFormat); - end; - Canvas.Draw(0, 0, Bmp); - finally - Bmp.Free; - end; -end; - -procedure TSysListViewStyleHook.TSysHeaderStyleHook.PaintBackground(Canvas: TCanvas); -begin - // inherited; - { Leave this block clean . } -end; - -procedure TSysListViewStyleHook.Paint(Canvas: TCanvas); -begin - { Leave this block clean . } -end; - -procedure TSysListViewStyleHook.PaintBackground(Canvas: TCanvas); -begin - { Leave this block clean . } -end; - -procedure TSysListViewStyleHook.TSysHeaderStyleHook.WndProc(var Message: TMessage); -var - Info: THDHitTestInfo; -begin - case Message.Msg of - - WM_LBUTTONDOWN, WM_LBUTTONDBLCLK: - begin - FMouseDown := True; - Info.Point.X := TWMMouse(Message).XPos; - Info.Point.Y := TWMMouse(Message).YPos; - SendMessage(Handle, HDM_HITTEST, 0, IntPtr(@Info)); - - if (Info.Flags and HHT_ONDIVIDER = 0) and (Info.Flags and HHT_ONDIVOPEN = 0) then - FPressedSection := Info.item - else - FPressedSection := -1; - end; - - WM_LBUTTONUP, WM_RBUTTONUP: - begin - FMouseDown := False; - FPressedSection := -1; - end; - - end; - inherited; - -end; - -{ TSysListViewStyleHook.TSysHeaderStyleHook.TSysSection } - -constructor TSysListViewStyleHook.TSysHeaderStyleHook.TSysSection.Create(SysParent: TSysControl; Index: Integer); -begin - inherited Create; - FTextFormat := []; - FIndex := Index; - FText := ''; - FImageListHandle := 0; - FImageIndex := -1; - FColumnIndex := -1; - FSectionRect := TRect.Empty; - FDropDownRect := TRect.Empty; - FHasSplitButton := False; - FShowImage := False; - FHeaderHandle := SysParent.Handle; - DoGetSectionInfo; -end; - -destructor TSysListViewStyleHook.TSysHeaderStyleHook.TSysSection.Destroy; -begin - - inherited; -end; - -procedure TSysListViewStyleHook.TSysHeaderStyleHook.TSysSection.DoGetSectionInfo; -var - SectionOrder: array of Integer; - R: TRect; - item: THDItem; - Buffer: array [0 .. 255] of Char; - LRtlReading: Boolean; -begin - FillChar(Buffer, 255, Char(0)); - SetLength(SectionOrder, Header_GetItemCount(FHeaderHandle)); - Header_GetOrderArray(FHeaderHandle, Header_GetItemCount(FHeaderHandle), Pointer(SectionOrder)); - FColumnIndex := SectionOrder[FIndex]; - Header_GetItemRect(FHeaderHandle, ColumnIndex, @R); - FSectionRect := R; - FillChar(item, sizeof(item), 0); - item.mask := HDI_TEXT or HDI_FORMAT or HDI_IMAGE; - item.pszText := @Buffer; - item.cchTextMax := Length(Buffer); - if Header_GetItem(FHeaderHandle, FColumnIndex, item) then - begin - with item do - begin - FImageIndex := iImage; - FText := String(pszText); - FHasSplitButton := (fmt and HDF_SPLITBUTTON = HDF_SPLITBUTTON); - LRtlReading := (fmt and HDF_RTLREADING = HDF_RTLREADING); - FTextFormat := []; - if (fmt and HDF_LEFT = HDF_LEFT) then - include(FTextFormat, tfLeft) - else if (fmt and HDF_RIGHT = HDF_RIGHT) then - include(FTextFormat, tfRight) - else if (fmt and HDF_CENTER = HDF_CENTER) then - include(FTextFormat, tfCenter); - - if LRtlReading then - include(FTextFormat, tfRtlReading); - FBitmapOnRight := (fmt and HDF_BITMAP_ON_RIGHT = HDF_BITMAP_ON_RIGHT); - - FShowImage := (FImageIndex > -1) and (fmt and HDF_BITMAP = HDF_BITMAP); - end; - end; - R := TRect.Empty; - if Header_GetItemDropDownRect(FHeaderHandle, FIndex, R) then - FDropDownRect := R; - FImageListHandle := Header_GetImageList(FHeaderHandle); -end; - -{ TSysTreeViewStyleHook } - - -constructor TSysTreeViewStyleHook.Create(AHandle: THandle); -begin - inherited; -{$IF CompilerVersion > 23} - StyleElements := [seFont{, seBorder}]; //Allow to the Vcl.Styles.Hook handle the NC and scroll paint -{$ELSE} - OverrideFont := True; - OverridePaintNC := False; //Allow to the Vcl.Styles.Hook handle the NC and scroll paint -{$IFEND} - OverrideEraseBkgnd := True; -end; - -destructor TSysTreeViewStyleHook.Destroy; -begin - - inherited; -end; - -procedure TSysTreeViewStyleHook.Scroll(const Kind: TScrollBarKind; - const ScrollType: TSysScrollingType; Pos, Delta: Integer); -begin - if Kind = sbVertical then - begin - case ScrollType of - skTracking: - begin - LstPos := Pos; - //OutputDebugString(PChar(Format('sbVertical Pos %d Delta %d AllowScrolling %s', [Pos, Delta, BooltoStr(AllowScrolling, True)]))); - AllowScrolling := True; - SendMessage(Handle, WM_VSCROLL, MakeWParam(SB_THUMBTRACK, Pos), 0); - AllowScrolling := False; - //OutputDebugString(PChar(Format('sbVertical Pos %d Delta %d', [Pos, Delta]))); - end; - skLineUp: SendMessage(Handle, WM_VSCROLL, SB_LINEUP, 0); - skLineDown: SendMessage(Handle, WM_VSCROLL, SB_LINEDOWN, 0); - skPageUp: SendMessage(Handle, WM_VSCROLL, SB_PAGEUP, 0); - skPageDown: SendMessage(Handle, WM_VSCROLL, SB_PAGEDOWN, 0); - end; - end - else - if Kind = sbHorizontal then - begin - case ScrollType of - skTracking: - begin - LstPos := Pos; - //OutputDebugString(PChar(Format('sbHorizontal Pos %d Delta %d AllowScrolling %s', [Pos, Delta, BooltoStr(AllowScrolling, True)]))); - AllowScrolling := True; - SendMessage(Handle, WM_HSCROLL, MakeWParam(SB_THUMBTRACK, Pos), 0); - AllowScrolling := False; - //OutputDebugString(PChar(Format('sbHorizontal Pos %d Delta %d', [Pos, Delta]))); - end; - skLineLeft: SendMessage(Handle, WM_HSCROLL, SB_LINELEFT, 0); - skLineRight: SendMessage(Handle, WM_HSCROLL, SB_LINERIGHT, 0); - skPageLeft: SendMessage(Handle, WM_HSCROLL, SB_PAGELEFT, 0); - skPageRight: SendMessage(Handle, WM_HSCROLL, SB_PAGERIGHT, 0); - end; - end; -end; - -procedure TSysTreeViewStyleHook.UpdateColors; -begin - inherited; - if OverrideEraseBkgnd then - Color := StyleServices.GetStyleColor(scTreeView) - else - Color := clWhite; - - if OverrideFont then - FontColor := StyleServices.GetSystemColor(clWindowText) - else - FontColor := clWindowText; -end; - -procedure TSysTreeViewStyleHook.WndProc(var Message: TMessage); -begin - case Message.Msg of - WM_ERASEBKGND: - begin - UpdateColors; - - if (Longint(TreeView_GetBkColor(Handle))<>ColorToRGB(Color)) then - TreeView_SetBkColor(Handle, ColorToRGB(Color)); - - if (Longint(TreeView_GetTextColor(Handle))<>ColorToRGB(FontColor)) then - TreeView_SetTextColor(Handle, ColorToRGB(FontColor)); - - Message.Result := CallDefaultProc(Message); - Exit; - end; - else inherited; - end; -end; - -{ TSysTabControlStyleHook } - -procedure TSysTabControlStyleHook.AngleTextOut(Canvas: TCanvas; const Angle, X, Y: Integer; const Text: string); -var - SaveIndex: Integer; -begin - SaveIndex := SaveDC(Canvas.Handle); - try - SetBkMode(Canvas.Handle, Transparent); - Canvas.Font.Orientation := Angle; - Canvas.TextOut(X, Y, Text); - finally - RestoreDC(Canvas.Handle, SaveIndex); - end; - -end; - -constructor TSysTabControlStyleHook.Create(AHandle: THandle); -begin - inherited; -{$IF CompilerVersion > 23} - StyleElements := [seClient, seFont]; -{$ELSE} - OverridePaint := True; - OverridePaintNC := False; - OverrideFont := True; -{$IFEND} - // OverrideEraseBkgnd:=True; - FHotTabIndex := -1; -end; - -destructor TSysTabControlStyleHook.Destroy; -begin - - inherited; -end; - -function TSysTabControlStyleHook.GetDisplayRect: TRect; -begin - //Result := Rect(0, 0, 0, 0); - Result := SysControl.ClientRect; - SendMessage(Handle, TCM_ADJUSTRECT, 0, IntPtr(@Result)); - inc(Result.Top, 2); -end; - -function TSysTabControlStyleHook.GetImages: TCustomImageList; -begin - Result := nil; -end; - -function TSysTabControlStyleHook.GetTabCount: Integer; -begin - Result := SendMessage(Handle, TCM_GETITEMCOUNT, 0, 0); -end; - -function TSysTabControlStyleHook.GetTabIndex: Integer; -begin - Result := SendMessage(Handle, TCM_GETCURSEL, 0, 0); -end; - -function TSysTabControlStyleHook.GetTabPosition: TTabPosition; -begin - Result := tpTop; -end; - -function TSysTabControlStyleHook.GetTabRect(Index: Integer): TRect; -begin - Result := Rect(0, 0, 0, 0); - TabCtrl_GetItemRect(Handle, Index, Result); -end; - -function TSysTabControlStyleHook.GetTabs(Index: Integer): string; -var - TCItem: TTCItem; - Buffer: array [0 .. 254] of Char; -begin - FillChar(TCItem, sizeof(TCItem), 0); - - TCItem.mask := TCIF_TEXT; - TCItem.pszText := @Buffer; - TCItem.cchTextMax := sizeof(Buffer); - if SendMessageW(Handle, TCM_GETITEMW, Index, IntPtr(@TCItem)) <> 0 then - Result := TCItem.pszText - else - Result := ''; - -end; - -procedure TSysTabControlStyleHook.Paint(Canvas: TCanvas); -var - R: TRect; - i, SaveIndex: Integer; - Details: TThemedElementDetails; -begin - SaveIndex := SaveDC(Canvas.Handle); - try - R := DisplayRect; - ExcludeClipRect(Canvas.Handle, R.Left, R.Top, R.Right, R.Bottom); - PaintBackground(Canvas); - finally - RestoreDC(Canvas.Handle, SaveIndex); - end; - { Draw tabs } - for i := 0 to TabCount - 1 do - begin - // if I = TabIndex then - // Continue; - DrawTab(Canvas, i); - end; - case TabPosition of - tpTop: InflateRect(R, SysControl.Width - R.Right, SysControl.Height - R.Bottom); - tpLeft: InflateRect(R, SysControl.Width - R.Right, SysControl.Height - R.Bottom); - tpBottom: InflateRect(R, R.Left, R.Top); - tpRight: InflateRect(R, R.Left, R.Top); - end; - - if StyleServices.Available then - begin - Details := StyleServices.GetElementDetails(ttPane); - StyleServices.DrawElement(Canvas.Handle, Details, R); - end; - { Draw active tab } - if TabIndex >= 0 then - DrawTab(Canvas, TabIndex); - -end; - -procedure TSysTabControlStyleHook.DrawTab(Canvas: TCanvas; const Index: Integer); -var - R, LayoutR, GlyphR: TRect; - ImageWidth, ImageHeight, ImageStep, TX, TY: Integer; - DrawState: TThemedTab; - Details: TThemedElementDetails; - ThemeTextColor: TColor; - FImageIndex: Integer; -begin - if (Images <> nil) and (Index < Images.Count) then - begin - ImageWidth := Images.Width; - ImageHeight := Images.Height; - ImageStep := 3; - end - else - begin - ImageWidth := 0; - ImageHeight := 0; - ImageStep := 0; - end; - - R := TabRect[Index]; - if R.Left < 0 then - Exit; - - if TabPosition in [tpTop, tpBottom] then - begin - if Index = TabIndex then - InflateRect(R, 0, 2); - end - else if Index = TabIndex then - dec(R.Left, 2) - else - dec(R.Right, 2); - - // Canvas.Font.Assign(TCustomTabControl(Control).Font); - LayoutR := R; - DrawState := ttTabDontCare; - case TabPosition of - tpTop: - begin - if Index = TabIndex then - DrawState := ttTabItemSelected - else if (Index = FHotTabIndex) and MouseInControl then - DrawState := ttTabItemHot - else - DrawState := ttTabItemNormal; - end; - tpLeft: - begin - if Index = TabIndex then - DrawState := ttTabItemLeftEdgeSelected - else if (Index = FHotTabIndex) and MouseInControl then - DrawState := ttTabItemLeftEdgeHot - else - DrawState := ttTabItemLeftEdgeNormal; - end; - tpBottom: - begin - if Index = TabIndex then - DrawState := ttTabItemBothEdgeSelected - else if (Index = FHotTabIndex) and MouseInControl then - DrawState := ttTabItemBothEdgeHot - else - DrawState := ttTabItemBothEdgeNormal; - end; - tpRight: - begin - if Index = TabIndex then - DrawState := ttTabItemRightEdgeSelected - else if (Index = FHotTabIndex) and MouseInControl then - DrawState := ttTabItemRightEdgeHot - else - DrawState := ttTabItemRightEdgeNormal; - end; - end; - - if StyleServices.Available then - begin - Details := StyleServices.GetElementDetails(DrawState); - StyleServices.DrawElement(Canvas.Handle, Details, R); - end; - - { Image } - - FImageIndex := Index; - - if (Images <> nil) and (FImageIndex >= 0) and (FImageIndex < Images.Count) then - begin - GlyphR := LayoutR; - case TabPosition of - tpTop, tpBottom: - begin - GlyphR.Left := GlyphR.Left + ImageStep; - GlyphR.Right := GlyphR.Left + ImageWidth; - LayoutR.Left := GlyphR.Right; - GlyphR.Top := GlyphR.Top + (GlyphR.Bottom - GlyphR.Top) div 2 - ImageHeight div 2; - if (TabPosition = tpTop) and (Index = TabIndex) then - OffsetRect(GlyphR, 0, -1) - else if (TabPosition = tpBottom) and (Index = TabIndex) then - OffsetRect(GlyphR, 0, 1); - end; - tpLeft: - begin - GlyphR.Bottom := GlyphR.Bottom - ImageStep; - GlyphR.Top := GlyphR.Bottom - ImageHeight; - LayoutR.Bottom := GlyphR.Top; - GlyphR.Left := GlyphR.Left + (GlyphR.Right - GlyphR.Left) div 2 - ImageWidth div 2; - end; - tpRight: - begin - GlyphR.Top := GlyphR.Top + ImageStep; - GlyphR.Bottom := GlyphR.Top + ImageHeight; - LayoutR.Top := GlyphR.Bottom; - GlyphR.Left := GlyphR.Left + (GlyphR.Right - GlyphR.Left) div 2 - ImageWidth div 2; - end; - end; - if StyleServices.Available then - StyleServices.DrawIcon(Canvas.Handle, Details, GlyphR, Images.Handle, FImageIndex); - end; - - { Text } - if StyleServices.Available then - begin - if (TabPosition = tpTop) and (Index = TabIndex) then - OffsetRect(LayoutR, 0, -1) - else if (TabPosition = tpBottom) and (Index = TabIndex) then - OffsetRect(LayoutR, 0, 1); - - if TabPosition = tpLeft then - begin - TX := LayoutR.Left + (LayoutR.Right - LayoutR.Left) div 2 - Canvas.TextHeight(Tabs[Index]) div 2; - TY := LayoutR.Top + (LayoutR.Bottom - LayoutR.Top) div 2 + Canvas.TextWidth(Tabs[Index]) div 2; - if StyleServices.GetElementColor(Details, ecTextColor, ThemeTextColor) then - Canvas.Font.Color := ThemeTextColor; - AngleTextOut(Canvas, 900, TX, TY, Tabs[Index]); - end - else if TabPosition = tpRight then - begin - TX := LayoutR.Left + (LayoutR.Right - LayoutR.Left) div 2 + Canvas.TextHeight(Tabs[Index]) div 2; - TY := LayoutR.Top + (LayoutR.Bottom - LayoutR.Top) div 2 - Canvas.TextWidth(Tabs[Index]) div 2; - if StyleServices.GetElementColor(Details, ecTextColor, ThemeTextColor) then - Canvas.Font.Color := ThemeTextColor; - AngleTextOut(Canvas, -900, TX, TY, Tabs[Index]); - end - else - StyleServices.DrawText(Canvas.Handle, Details, Tabs[Index], LayoutR, [tfSingleLine, tfVerticalCenter, tfCenter, tfNoClip]); - // DrawControlText(Canvas, Details, Tabs[Index], LayoutR, - // DT_VCENTER or DT_CENTER or DT_SINGLELINE or DT_NOCLIP); - end; -end; - -procedure TSysTabControlStyleHook.PaintBackground(Canvas: TCanvas); -begin - inherited; -end; - -procedure TSysTabControlStyleHook.PaintNC(Canvas: TCanvas); -begin - inherited; -end; - -procedure TSysTabControlStyleHook.WndProc(var Message: TMessage); -begin - // Addlog(Format('TSysTabControlStyleHook $0x%x %s', [SysControl.Handle, WM_To_String(Message.Msg)])); - - // case Message.Msg of - // WM_MOUSEMOVE: - // begin - // - // end; - // else - // inherited; - // end; - inherited; -end; - -{ TSysToolbarStyleHook } - -{$REGION 'TSysToolbarStyleHook'} - -constructor TSysToolbarStyleHook.Create(AHandle: THandle); -begin - inherited; -{$IF CompilerVersion > 23} - StyleElements := [seClient, seFont]; -{$ELSE} - OverridePaint := True; - OverrideFont := True; -{$IFEND} - OverrideEraseBkgnd := False; - FImages := nil; - FDisabledImages := nil; - FSysToolbarButton := nil; - FButtonsPainted := False; -end; - -destructor TSysToolbarStyleHook.Destroy; -begin - if Assigned(FImages) then - FreeAndNil(FImages); - if Assigned(FDisabledImages) then - FreeAndNil(FDisabledImages); - if Assigned(FSysToolbarButton) then - FreeAndNil(FSysToolbarButton); - inherited; -end; - -function TSysToolbarStyleHook.GetItem(Index: Integer): TSysToolbarButton; -begin - Result := nil; - if (Index > -1) and (index <= Count) then - begin - if Assigned(FSysToolbarButton) then - FreeAndNil(FSysToolbarButton); - FSysToolbarButton := TSysToolbarButton.Create(SysControl, Index); - Result := FSysToolbarButton; - end; -end; - -function TSysToolbarStyleHook.GetShowText: Boolean; -begin - Result := (SysControl.Style and BTNS_SHOWTEXT = BTNS_SHOWTEXT); -end; - -function TSysToolbarStyleHook.IsToolbarFlat: Boolean; -begin - { MSDN : - In a flat toolbar, both the toolbar and the buttons are transparent - and hot-tracking is enabled. - } - Result := (SysControl.Style and TBSTYLE_FLAT = TBSTYLE_FLAT) -end; - -function TSysToolbarStyleHook.IsToolbarList: Boolean; -begin - Result := (SysControl.Style and TBSTYLE_LIST = TBSTYLE_LIST); -end; - -function TSysToolbarStyleHook.IsToolbarTransparent: Boolean; -begin - { MSDN: - In a transparent toolbar, the toolbar is transparent but the buttons are not. - } - Result := (SysControl.Style and TBSTYLE_TRANSPARENT = TBSTYLE_TRANSPARENT) -end; - -function TSysToolbarStyleHook.IsToolbarWrapable: Boolean; -begin - Result := (SysControl.Style and TBSTYLE_WRAPABLE = TBSTYLE_WRAPABLE) -end; - -function TSysToolbarStyleHook.GetCount: Integer; -begin - Result := SendMessage(Handle, TB_BUTTONCOUNT, 0, 0); -end; - -procedure TSysToolbarStyleHook.ApplyImageList; -var - H: Cardinal; -begin - H := SendMessage(Handle, TB_GETIMAGELIST, 0, 0); - if (H <> 0) and (FImages = nil) then - begin - FImages := TImageList.Create(nil); - FImages.ShareImages := True; - FImages.Handle := H; - end; - H := SendMessage(Handle, TB_GETDISABLEDIMAGELIST, 0, 0); - if (H <> 0) and (FDisabledImages = nil) then - begin - FDisabledImages := TImageList.Create(nil); - FDisabledImages.ShareImages := True; - FDisabledImages.Handle := H; - end; -end; - -procedure TSysToolbarStyleHook.Paint(Canvas: TCanvas); -var - i: Integer; - ItemRect, R, R2: TRect; - LDetails: TThemedElementDetails; - DC: HDC; - LButtonHot: Boolean; - P: TPoint; - LStyle: TSysToolbarButtonStyle; - LState: TSysToolbarButtonState; - Bmp: TBitmap; - ImgRect, TxtRect: TRect; - LText: String; - LImageIndex, LDropDownWidth: Integer; - TxtFlags: DWORD; - TxtFormat: TTextFormat; -begin - - Bmp := TBitmap.Create; - try - ApplyImageList; - if Assigned(FImages) then - begin - FImages.Masked := True; - FImages.BkColor := clNone; { Transparent bitmap } - end; - ImgRect := Rect(0, 0, 0, 0); - TxtRect := Rect(0, 0, 0, 0); - Bmp.SetSize(SysControl.Width, SysControl.Height); - R := Rect(0, 0, Bmp.Width, Bmp.Height); - // Bmp.Canvas.Brush.Color := StyleServices.GetStyleColor(scWindow); - // Bmp.Canvas.FillRect(R); - DC := Bmp.Canvas.Handle; - DrawParentBackground(DC); - - TxtFlags := 0; - if (SysControl.Style and TBSTYLE_NOPREFIX = TBSTYLE_NOPREFIX) then - TxtFlags := DT_NOPREFIX; - - if Flat or Transparent then - begin - { Dont paint the toolbar background => the toolbar is transparent . } - end - else - begin - { Toolbar is not transparent } - LDetails.Element := teToolBar; - LDetails.Part := 0; - LDetails.State := 0; - if StyleServices.HasTransparentParts(LDetails) then - StyleServices.DrawParentBackground(Handle, DC, LDetails, False); - StyleServices.DrawElement(DC, LDetails, R); - end; - except - Bmp.Free; - Exit; - end; - - try - { Draw toolbar buttons } - for i := 0 to Count - 1 do - begin - if i = Count - 1 then - FButtonsPainted := True; - - ItemRect := Items[i].ItemRect; - with Items[i] do - begin - LState := State; - LStyle := Style; - LText := Text; - LImageIndex := ImageIndex; - LDropDownWidth := DropDownWidth; - end; - - LButtonHot := False; - if not(bsHidden in LState) then - begin - if MouseInControl then - begin - GetCursorPos(P); - ScreenToClient(Handle, P); - if ItemRect.Contains(P) then - LButtonHot := True; - end; - - if (bsEnabled in LState) then - LDetails := StyleServices.GetElementDetails(ttbButtonNormal) - else - LDetails := StyleServices.GetElementDetails(ttbButtonDisabled); - if (LButtonHot) and (bsEnabled in LState) then - begin - LDetails := StyleServices.GetElementDetails(ttbButtonHot); - end; - if (bsPressed in LState) and (bsEnabled in LState) then - LDetails := StyleServices.GetElementDetails(ttbButtonPressed); - - if bsChecked in LState then - LDetails := StyleServices.GetElementDetails(ttbButtonChecked); - - if not(bsSep in LStyle) then - begin - if Flat then - begin - // Bmp.Canvas.FillRect(ItemRect); - DrawParentBackground(DC, @ItemRect); - if (LButtonHot or (bsPressed in LState) or (bsChecked in LState)) and (bsEnabled in LState) then - begin - StyleServices.DrawElement(DC, LDetails, ItemRect); - end; - end - else - StyleServices.DrawElement(DC, LDetails, ItemRect); - end - else - begin - LDetails := StyleServices.GetElementDetails(ttbSeparatorNormal); - StyleServices.DrawElement(DC, LDetails, ItemRect); - end; - - if not(bsSep in LStyle) then - begin - R := ItemRect; - ImgRect := TRect.Empty; - if Assigned(FImages) then - ImgRect := Rect(0, 0, FImages.Width, FImages.Height); - ImgRect := CenteredRect(R, ImgRect); - - if bsDropDown in LStyle then - begin - { If button is DropDown then draw the button glyph. } - R := ItemRect; - R := Rect(R.Right - LDropDownWidth, R.Top, R.Right, R.Bottom); - if bsEnabled in LState then - LDetails := StyleServices.GetElementDetails(ttbDropDownButtonGlyphNormal) - else - LDetails := StyleServices.GetElementDetails(ttbDropDownButtonGlyphDisabled); - if (LButtonHot and (bsEnabled in LState)) then - LDetails := StyleServices.GetElementDetails(ttbDropDownButtonGlyphHot); - if ((bsPressed in LState) and (bsEnabled in LState)) then - LDetails := StyleServices.GetElementDetails(ttbDropDownButtonGlyphPressed); - StyleServices.DrawElement(DC, LDetails, R); - - { Adjust bitmap position } - - if Assigned(FImages) then - ImgRect := Rect(0, 0, FImages.Width, FImages.Height); - R := ItemRect; - R.Right := R.Right - LDropDownWidth; - ImgRect := CenteredRect(R, ImgRect); - inc(ImgRect.Left, 2); - end; - - { Adjust bitmap & Text positions } - if Wrapable then - begin - R := Rect(0, 0, 0, 0); - if (ShowText and not List) then - begin - Winapi.Windows.DrawText(DC, LText, -1, R, DT_CENTER or DT_CALCRECT); - end; - ImgRect.Offset(0, -R.Height); - end - else if List then - begin - R := Rect(0, 0, 0, 0); - if ShowText then - begin - Winapi.Windows.DrawText(DC, LText, -1, R, DT_CENTER or DT_CALCRECT or TxtFlags); - end; - ImgRect := Rect(0, 0, FImages.Width, FImages.Height); - R2 := ItemRect; - dec(R2.Right, R.Width + 2); - ImgRect := CenteredRect(R2, ImgRect); - end; - - { Draw Bitmap } - if (LImageIndex > -1) and (Assigned(FImages)) then - begin - if bsEnabled in LState then - FImages.DrawingStyle := Vcl.ImgList.TDrawingStyle.dsNormal - else - FImages.DrawingStyle := Vcl.ImgList.TDrawingStyle.dsSelected; - FImages.Draw(Bmp.Canvas, ImgRect.Left, ImgRect.Top, LImageIndex); - end; - - { Draw Text } - TxtRect := Rect(0, 0, 0, 0); - if ShowText then - begin - if not List then - begin - { Text appear under the button bitmap } - if (ImgRect.Width > 0) and (LImageIndex > -1) then - TxtRect := Rect(ItemRect.Left, ImgRect.Bottom, ItemRect.Right, ItemRect.Bottom) - else - TxtRect := ItemRect; - if LText <> '' then - DrawTextCentered(DC, LDetails, TxtRect, LText, TxtFlags); - end - else - begin - { List } - { Text appear to the right of the button bitmap } - if (ImgRect.Width > 0) and (LImageIndex > -1) then - TxtRect := Rect(ImgRect.Right + 2, ItemRect.Top, ItemRect.Right, ItemRect.Bottom) - else - TxtRect := ItemRect; - TxtFormat := [tfCenter, tfVerticalCenter, tfSingleLine, tfLeft]; - if TxtFlags <> 0 then - include(TxtFormat, tfNoPrefix); - if LText <> '' then - StyleServices.DrawText(DC, LDetails, LText, TxtRect, TxtFormat); - end; - end; - end; - end; - end; - Canvas.Draw(0, 0, Bmp); - finally - Bmp.Free; - end; -end; - -procedure TSysToolbarStyleHook.PaintBackground(Canvas: TCanvas); -begin - inherited; - -end; - -procedure TSysToolbarStyleHook.PaintNC(Canvas: TCanvas); -begin - inherited; -end; - -procedure TSysToolbarStyleHook.WndProc(var Message: TMessage); -begin - inherited; -end; -{$ENDREGION} -{$REGION 'TSysToolbarButton'} -{ TSysToolbarStyleHook.TSysToolbarButton } - -constructor TSysToolbarStyleHook.TSysToolbarButton.Create(SysParent: TSysControl; Index: Integer); -begin - FIndex := Index; - FParent := SysParent; - FText := ''; - FImageIndex := -1; - FState := []; - FStyle := []; - DoGetItemInfo; -end; - -destructor TSysToolbarStyleHook.TSysToolbarButton.Destroy; -begin - inherited; -end; - -Procedure TSysToolbarStyleHook.TSysToolbarButton.DoGetItemInfo; -const - BufferSize = 255; -var - TB: TTBButton; - Buffer: array [0 .. BufferSize - 1] of Char; - BtnInfo: TTBButtonInfo; -begin - FillChar(Buffer, BufferSize, Char(0)); - FillChar(TB, sizeof(TB), 0); - SendMessage(FParent.Handle, TB_GETBUTTON, FIndex, IntPtr(@TB)); - FillChar(BtnInfo, sizeof(BtnInfo), Char(0)); - BtnInfo.cbSize := sizeof(TTBButtonInfo); - BtnInfo.dwMask := TBIF_STATE or TBIF_STYLE or TBIF_IMAGE or TBIF_TEXT; - BtnInfo.cchText := BufferSize; - BtnInfo.pszText := @Buffer; - SendMessage(FParent.Handle, TB_GETBUTTONINFO, TB.idCommand, LParam(@BtnInfo)); - BtnInfo.fsStyle := TB.fsStyle; - SendMessage(FParent.Handle, TB_GETBUTTONTEXT, TB.idCommand, LParam(BtnInfo.pszText)); - FText := String(Buffer); - FImageIndex := BtnInfo.iImage; - with BtnInfo do - begin - { Button State } - if fsState and TBSTATE_ENABLED = TBSTATE_ENABLED then - include(FState, bsEnabled); - if fsState and TBSTATE_PRESSED = TBSTATE_PRESSED then - include(FState, bsPressed); - if fsState and TBSTATE_CHECKED = TBSTATE_CHECKED then - include(FState, bsChecked); - if fsState and TBSTATE_HIDDEN = TBSTATE_HIDDEN then - include(FState, bsHidden); - - { Button Style } - if fsStyle and TBSTYLE_BUTTON = TBSTYLE_BUTTON then - include(FStyle, bsBtn); - if fsStyle and TBSTYLE_SEP = TBSTYLE_SEP then - include(FStyle, bsSep); - if fsStyle and TBSTYLE_CHECK = TBSTYLE_CHECK then - include(FStyle, bsCheck); - if fsStyle and TBSTYLE_GROUP = TBSTYLE_GROUP then - include(FStyle, bsGroup); - if fsStyle and TBSTYLE_CHECKGROUP = TBSTYLE_CHECKGROUP then - include(FStyle, bsCheckGroup); - if (fsStyle and TBSTYLE_DROPDOWN = TBSTYLE_DROPDOWN) or (fsStyle and BTNS_WHOLEDROPDOWN = BTNS_WHOLEDROPDOWN) then - include(FStyle, bsDropDown); - - end; - -end; - -function TSysToolbarStyleHook.TSysToolbarButton.GetItemRect: TRect; -begin - Result := TRect.Empty; - if not BOOL(SendMessage(FParent.Handle, TB_GETITEMRECT, FIndex, LParam(@Result))) then - Result := TRect.Empty; -end; - -function TSysToolbarStyleHook.TSysToolbarButton.GetDropDownWidth: Integer; -var - R: TRect; -begin - if BOOL(SendMessage(FParent.Handle, TB_GETITEMDROPDOWNRECT, FIndex, LParam(@R))) then - Result := R.Right - R.Left - else - Result := 15; // default width when runtime themes are enabled -end; - -{$ENDREGION} -{ TSysProgressBarStyleHook } - -constructor TSysProgressBarStyleHook.Create(AHandle: THandle); -begin - inherited; - if (SysControl.Style And PBS_VERTICAL) <> 0 then - FOrientation := pbVertical - else - FOrientation := pbHorizontal; - // DoubleBuffered := True; - OverridePaint := True; - // OverrideEraseBkgnd :=True; - // FLastPos:=-1; - FStep := 0; - FTimer := TTimer.Create(nil); - FTimer.Interval := 100; - FTimer.Enabled := False; - // if ((SysControl.Style And PBS_MARQUEE) <> 0) then - begin - FTimer.OnTimer := TimerAction; - FTimer.Enabled := True; - end; -end; - -destructor TSysProgressBarStyleHook.Destroy; -begin - FTimer.Free; - inherited; -end; - -function TSysProgressBarStyleHook.GetBarRect: TRect; -begin - Result := TRect.Create(0, 0, SysControl.Width, SysControl.Height); - InflateRect(Result, -BorderWidth, -BorderWidth); -end; - -function TSysProgressBarStyleHook.GetBorderWidth: Integer; -begin - Result := 0; -end; - -function TSysProgressBarStyleHook.GetMax: Integer; -begin - Result := SendMessage(Handle, PBM_GetRange, 0, 0); -end; - -function TSysProgressBarStyleHook.GetMin: Integer; -begin - Result := SendMessage(Handle, PBM_GetRange, 1, 0); -end; - -function TSysProgressBarStyleHook.GetOrientation: TProgressBarOrientation; -begin - Result := pbHorizontal; - if (Handle <> 0) and (GetWindowLong(Handle, GWL_STYLE) and PBS_VERTICAL = PBS_VERTICAL) then - Result := pbVertical; -end; - -function TSysProgressBarStyleHook.GetPercent: Single; -var - LMin, LMax, LPos: Integer; -begin - LMin := Min; - LMax := Max; - LPos := Position; - if (LMin >= 0) and (LPos >= LMin) and (LMax >= LPos) and (LMax - LMin <> 0) then - Result := (LPos - LMin) / (LMax - LMin) - else - Result := 0; -end; - -function TSysProgressBarStyleHook.GetPosition: Integer; -begin - Result := SendMessage(Handle, PBM_GETPOS, 0, 0); -end; - -procedure TSysProgressBarStyleHook.Paint(Canvas: TCanvas); -var - LDetails: TThemedElementDetails; -begin - - // if ((SysControl.Style And PBS_MARQUEE) <> 0) or ((FLastPos=-1) or (Position 0) then - begin - InflateRect(LRect, -2, -2); - if Orientation = pbHorizontal then - LWidth := LRect.Width - else - LWidth := LRect.Height; - - LPos := Round(LWidth * 0.05); - FillR := LRect; - if Orientation = pbHorizontal then - begin - FillR.Right := FillR.Left + LPos; - LDetails := StyleServices.GetElementDetails(tpChunk); - end - else - begin - FillR.Top := FillR.Bottom - LPos; - LDetails := StyleServices.GetElementDetails(tpChunkVert); - end; - - FillR.SetLocation(FStep * FillR.Width, FillR.Top); - StyleServices.DrawElement(Canvas.Handle, LDetails, FillR); - // Inc(FStep,1); - // if FStep mod 20=0 then - // FStep:=0; - end - else - begin - InflateRect(LRect, -2, -2); - if Orientation = pbHorizontal then - LWidth := LRect.Width - else - LWidth := LRect.Height; - LPos := Round(LWidth * GetPercent); - // FLastPos := GetPosition; - FillR := LRect; - if Orientation = pbHorizontal then - begin - FillR.Right := FillR.Left + LPos; - LDetails := StyleServices.GetElementDetails(tpChunk); - end - else - begin - FillR.Top := FillR.Bottom - LPos; - LDetails := StyleServices.GetElementDetails(tpChunkVert); - end; - StyleServices.DrawElement(Canvas.Handle, LDetails, FillR); - end; -end; - -procedure TSysProgressBarStyleHook.PaintFrame(Canvas: TCanvas); -var - R: TRect; - Details: TThemedElementDetails; -begin - if not StyleServices.Available then - Exit; - R := BarRect; - if Orientation = pbHorizontal then - Details := StyleServices.GetElementDetails(tpBar) - else - Details := StyleServices.GetElementDetails(tpBarVert); - StyleServices.DrawElement(Canvas.Handle, Details, R); -end; - -procedure TSysProgressBarStyleHook.TimerAction(Sender: TObject); -var - LCanvas: TCanvas; - LHandle: THandle; -begin - // if StyleServices.Available and ((SysControl.Style And PBS_MARQUEE) <> 0) then - // begin - LHandle := 0; - LCanvas := TCanvas.Create; - try - LHandle := GetWindowDC(Self.Handle); - - if LHandle<>0 then - begin - LCanvas.Handle := LHandle; - - if SysControl.Visible then - begin - PaintFrame(LCanvas); - PaintBar(LCanvas); - end; - end; - - inc(FStep, 1); - if FStep mod 20 = 0 then - FStep := 0; - - finally - if LHandle<>0 then - ReleaseDC(Handle, LHandle); - LCanvas.Handle := 0; - LCanvas.Free; - end; - - // end - // else - // FTimer.Enabled := False; -end; - -procedure TSysProgressBarStyleHook.WMNCCalcSize(var Message: TWMNCCalcSize); -begin - Message.Result := 0; - Handled := True; -end; - -procedure TSysProgressBarStyleHook.WndProc(var Message: TMessage); -begin - // Addlog(Format('TSysProgressBarStyleHook $0x%x %s', [SysControl.Handle, WM_To_String(Message.Msg)])); - // - case Message.Msg of - WM_TIMER:; // avoid flicker in progress bar and memory increased; - - else inherited; - end; - -end; - -{ TSysRichEditStyleHook } - -constructor TSysRichEditStyleHook.Create(AHandle: THandle); -begin - inherited; - -{$IF CompilerVersion > 23} - StyleElements := [seBorder]; -{$ELSE} - OverridePaintNC := True; - OverrideFont := False; -{$IFEND} -end; - -procedure TSysRichEditStyleHook.EMSetBkgndColor(var Message: TMessage); -begin - Message.LParam := Color; - Handled := False; -end; - -function TSysRichEditStyleHook.GetBorderSize: TRect; -begin - if SysControl.HasBorder then - Result := Rect(2, 2, 2, 2); -end; - -procedure TSysRichEditStyleHook.UpdateColors; -var - cf: TCharFormat2; -const - TextColor: array [Boolean] of TStyleFont = (sfEditBoxTextDisabled, sfEditBoxTextNormal); - BkColor: array [Boolean] of TStyleColor = (scEditDisabled, scEdit); -begin - Color := ColorToRGB(StyleServices.GetStyleColor(scEdit)); - FontColor := ColorToRGB(StyleServices.GetStyleFontColor(TextColor[SysControl.Enabled])); - BackColor := ColorToRGB(StyleServices.GetStyleColor(BkColor[SysControl.Enabled])); - - ZeroMemory(@cf, sizeof(TCharFormat2)); - cf.cbSize := sizeof(TCharFormat2); - cf.dwMask := CFM_ALL; - { Need to send this message .. } - SendMessage(Handle, EM_SETBKGNDCOLOR, 0, 0); - SendMessage(Handle, EM_GETCHARFORMAT, SCF_DEFAULT, LParam(@cf)); - SendMessage(Handle, EM_SETCHARFORMAT, SCF_DEFAULT, LParam(@cf)); -end; - -procedure TSysRichEditStyleHook.EMSetCharFormat(var Message: TMessage); -type - PCharFormat2 = ^TCharFormat2; -var - Format: PCharFormat2; -begin - Format := PCharFormat2(Message.LParam); - Format.crTextColor := FontColor; - Format.crBackColor := BackColor; - Format.dwEffects := Format.dwEffects and not CFE_AUTOCOLOR; - Handled := False; -end; - -procedure TSysRichEditStyleHook.WndProc(var Message: TMessage); -begin - inherited; -end; - -{ TSysReBarStyleHook } - -constructor TSysReBarStyleHook.Create(AHandle: THandle); -begin - inherited; - OverrideEraseBkgnd := True; - OverridePaint := True; - OverridePaintNC := True; -end; - -function TSysReBarStyleHook.GetBandBorder(const Index: Integer): TRect; -begin - SendMessage(Handle, RB_GETBANDBORDERS, Index, IntPtr(@Result)); -end; - -function TSysReBarStyleHook.GetBandCount: Integer; -begin - Result := SendMessage(Handle, RB_GETBANDCOUNT, 0, 0); -end; - -function TSysReBarStyleHook.GetBandRect(const Index: Integer): TRect; -begin - Result := Rect(0, 0, 0, 0); - SendMessage(Handle, RB_GETRECT, Index, IntPtr(@Result)); -end; - -function SizeOfReBarBandInfo: Integer; -var - ReBarBandInfo: TReBarBandInfo; -begin - ZeroMemory(@ReBarBandInfo, sizeof(ReBarBandInfo)); - if GetComCtlVersion >= $60001 then - Result := sizeof(TReBarBandInfo) - else - // Platforms prior to Vista do not support the fields rcChevronLocation & uChevronState - Result := sizeof(ReBarBandInfo) - sizeof(ReBarBandInfo.rcChevronLocation) - sizeof(ReBarBandInfo.uChevronState); -end; - -function TSysReBarStyleHook.GetBandText(const Index: Integer): string; -const - BufSize = 255; -var - Info: TReBarBandInfo; - Buffer: array [0 .. BufSize - 1] of Char; -begin - FillChar(Info, sizeof(Info), 0); - Info.cbSize := SizeOfReBarBandInfo; - // Size differs depending on OS and ComCtl32.dll version - Info.fMask := RBBIM_TEXT; - Info.lpText := @Buffer; - Info.cch := BufSize; - if BOOL(SendMessage(Handle, RB_GETBANDINFO, Index, IntPtr(@Info))) then - Result := Info.lpText - else - Result := ''; -end; - -procedure TSysReBarStyleHook.Paint(Canvas: TCanvas); -var - i: Integer; - R, Margin, LTextRect: TRect; - S: string; - Details: TThemedElementDetails; -begin - for i := 0 to GetBandCount - 1 do - begin - R := GetBandRect(i); - Margin := GetBandBorder(i); - InflateRect(R, 1, 1); - if R.Top < 0 then - R.Top := 0; - if R.Left < 0 then - R.Left := 0; - if R.Right > SysControl.ClientRect.Right then - R.Right := SysControl.ClientRect.Right; - if R.Bottom > SysControl.ClientRect.Bottom then - R.Bottom := SysControl.ClientRect.Bottom; - { band } - Details := StyleServices.GetElementDetails(trBand); - StyleServices.DrawElement(Canvas.Handle, Details, R); - { text } - LTextRect := Rect(R.Left + 10, R.Top, R.Left + Margin.Left, R.Bottom); - - S := GetBandText(i); - if S <> '' then - DrawControlText(Canvas, Details, S, LTextRect, DT_CENTER or DT_VCENTER or DT_SINGLELINE); - - { gripper } - R := Rect(R.Left + 2, R.Top + 2, R.Left + 6, R.Bottom - 2); - Details := StyleServices.GetElementDetails(trGripper); - StyleServices.DrawElement(Canvas.Handle, Details, R); - end; -end; - -procedure TSysReBarStyleHook.PaintBackground(Canvas: TCanvas); -var - LRect: TRect; - LDetails: TThemedElementDetails; -begin - LRect := Rect(0, 0, SysControl.ClientWidth, SysControl.ClientHeight); - InflateRect(LRect, 2, 2); - LDetails.Element := teToolBar; - LDetails.Part := 0; - if StyleServices.HasTransparentParts(LDetails) then - StyleServices.DrawParentBackground(Handle, Canvas.Handle, LDetails, False); - StyleServices.DrawElement(Canvas.Handle, LDetails, LRect); -end; - -procedure TSysReBarStyleHook.PaintNC(Canvas: TCanvas); -var - LDetails: TThemedElementDetails; -begin - ExcludeClipRect(Canvas.Handle, 2, 2, SysControl.Width - 2, SysControl.Height - 2); - Canvas.Brush.Color := StyleServices.ColorToRGB(clBtnFace); - Canvas.FillRect(Rect(0, 0, SysControl.Width, SysControl.Height)); - LDetails.Element := teToolBar; - LDetails.Part := 0; - StyleServices.DrawElement(Canvas.Handle, LDetails, Rect(0, 0, SysControl.Width, SysControl.Height)); -end; - -procedure TSysReBarStyleHook.WndProc(var Message: TMessage); -begin - case Message.Msg of - WM_SIZE: - begin - CallDefaultProc(Message); - Invalidate; - Handled := True; - end; - else inherited; - end; -end; - -{ TSysStatusBarStyleHook } - -constructor TSysStatusBarStyleHook.Create(AHandle: THandle); -begin - inherited; - OverridePaint := True; - // DoubleBuffered := True; -end; - -procedure TSysStatusBarStyleHook.Paint(Canvas: TCanvas); -const - AlignStyles: array [TAlignment] of Integer = (DT_LEFT, DT_RIGHT, DT_CENTER); -var - R, R1: TRect; - Res, Count, i: Integer; - Idx, Flags: Cardinal; - Details: TThemedElementDetails; - LText: string; - Borders: array [0 .. 2] of Integer; -begin - Details := StyleServices.GetElementDetails(tsStatusRoot); - StyleServices.DrawElement(Canvas.Handle, Details, Rect(0, 0, SysControl.Width, SysControl.Height)); - - if SendMessage(Handle, SB_ISSIMPLE, 0, 0) > 0 then - begin - R := SysControl.ClientRect; - FillChar(Borders, sizeof(Borders), 0); - SendMessage(Handle, SB_GETBORDERS, 0, IntPtr(@Borders)); - R.Left := Borders[0] + Borders[2]; - R.Top := Borders[1]; - R.Bottom := R.Bottom - Borders[1]; - R.Right := R.Right - Borders[2]; - - Details := StyleServices.GetElementDetails(tsPane); - StyleServices.DrawElement(Canvas.Handle, Details, R); - - R1 := SysControl.ClientRect; - R1.Left := R1.Right - R.Height; - Details := StyleServices.GetElementDetails(tsGripper); - StyleServices.DrawElement(Canvas.Handle, Details, R1); - Details := StyleServices.GetElementDetails(tsPane); - SetLength(LText, Word(SendMessage(Handle, SB_GETTEXTLENGTH, 0, 0))); - if Length(LText) > 0 then - begin - SendMessage(Handle, SB_GETTEXT, 0, IntPtr(@LText[1])); - Flags := SysControl.DrawTextBiDiModeFlags(DT_LEFT); - DrawControlText(Canvas, Details, LText, R, Flags); - end; - end - else - begin - Count := SendMessage(Handle, SB_GETPARTS, 0, 0); - for i := 0 to Count - 1 do - begin - R := Rect(0, 0, 0, 0); - SendMessage(Handle, SB_GETRECT, i, IntPtr(@R)); - if IsRectEmpty(R) then - Exit; - Details := StyleServices.GetElementDetails(tsPane); - StyleServices.DrawElement(Canvas.Handle, Details, R); - if i = Count - 1 then - begin - R1 := SysControl.ClientRect; - R1.Left := R1.Right - R.Height; - Details := StyleServices.GetElementDetails(tsGripper); - StyleServices.DrawElement(Canvas.Handle, Details, R1); - end; - Details := StyleServices.GetElementDetails(tsPane); - InflateRect(R, -1, -1); - - Flags := SysControl.DrawTextBiDiModeFlags(DT_LEFT); - Idx := i; - SetLength(LText, Word(SendMessage(Handle, SB_GETTEXTLENGTH, Idx, 0))); - if Length(LText) > 0 then - begin - Res := SendMessage(Handle, SB_GETTEXT, Idx, IntPtr(@LText[1])); - if (Res and SBT_OWNERDRAW = 0) then - DrawControlText(Canvas, Details, LText, R, Flags); - end; - end; - end; -end; - -procedure TSysStatusBarStyleHook.WndProc(var Message: TMessage); -begin - inherited; -end; - -{ TSysTrackBarStyleHook } - -constructor TSysTrackBarStyleHook.Create(AHandle: THandle); -begin - inherited; - OverridePaint := True; - // OverrideEraseBkgnd :=True; - DoubleBuffered := True; - FThumbPressed := False; -end; - -procedure TSysTrackBarStyleHook.Paint(Canvas: TCanvas); -var - LDetails: TThemedElementDetails; - TrackBarStyle: Cardinal; - LThemedTrackBar: TThemedTrackBar; - i, TickCount, TickStart, TickEnd, TickPos: Integer; - LRect: TRect; - LRect2: TRect; - LThumbRect: TRect; -begin - if not StyleServices.Available then - Exit; - - LThemedTrackBar := ttbTrackBarDontCare; - { Track } - TrackBarStyle := GetWindowLong(Handle, GWL_STYLE); - SendMessage(Handle, TBM_GETCHANNELRECT, 0, IntPtr(@LRect)); - if TrackBarStyle and TBS_VERT = 0 then - begin - LDetails := StyleServices.GetElementDetails(ttbTrack); - StyleServices.DrawElement(Canvas.Handle, LDetails, LRect); - end - else - begin - LRect2 := LRect; - LRect.Left := LRect2.Top; - LRect.Top := LRect2.Left; - LRect.Right := LRect2.Bottom; - LRect.Bottom := LRect2.Right; - LDetails := StyleServices.GetElementDetails(ttbTrackVert); - StyleServices.DrawElement(Canvas.Handle, LDetails, LRect); - end; - - SendMessage(Handle, TBM_GETCHANNELRECT, 0, IntPtr(@LRect)); - SendMessage(Handle, TBM_GETTHUMBRECT, 0, IntPtr(@LThumbRect)); - - // Ticks - if TrackBarStyle and TBS_NOTICKS = 0 then - begin - TickCount := SendMessage(Handle, TBM_GETNUMTICS, 0, 0); - - Canvas.Pen.Color := StyleServices.ColorToRGB(clBtnText); - - // First - if TrackBarStyle and TBS_VERT = 0 then - begin - TickPos := LRect.Left + LThumbRect.Width div 2; - if (TrackBarStyle and TBS_TOP = TBS_TOP) or (TrackBarStyle and TBS_BOTH = TBS_BOTH) then - begin - Canvas.MoveTo(TickPos, LRect.Top - 7); - Canvas.LineTo(TickPos, LRect.Top - 3); - end; - if (TrackBarStyle and TBS_TOP = 0) or (TrackBarStyle and TBS_BOTH = TBS_BOTH) then - begin - Canvas.MoveTo(TickPos, LRect.Bottom + 3); - Canvas.LineTo(TickPos, LRect.Bottom + 7); - end; - TickStart := TickPos; - end - else - begin - TickPos := LRect.Left + LThumbRect.Height div 2; - if (TrackBarStyle and TBS_TOP = TBS_TOP) or (TrackBarStyle and TBS_BOTH = TBS_BOTH) then - begin - Canvas.MoveTo(LRect.Top - 7, TickPos); - Canvas.LineTo(LRect.Top - 3, TickPos); - end; - if (TrackBarStyle and TBS_TOP = 0) or (TrackBarStyle and TBS_BOTH = TBS_BOTH) then - begin - Canvas.MoveTo(LRect.Bottom + 3, TickPos); - Canvas.LineTo(LRect.Bottom + 7, TickPos); - end; - TickStart := TickPos; - end; - // last - if TrackBarStyle and TBS_VERT = 0 then - begin - TickPos := LRect.Right - LThumbRect.Width div 2; - if (TrackBarStyle and TBS_TOP = TBS_TOP) or (TrackBarStyle and TBS_BOTH = TBS_BOTH) then - begin - Canvas.MoveTo(TickPos, LRect.Top - 7); - Canvas.LineTo(TickPos, LRect.Top - 3); - end; - if (TrackBarStyle and TBS_TOP = 0) or (TrackBarStyle and TBS_BOTH = TBS_BOTH) then - begin - Canvas.MoveTo(TickPos, LRect.Bottom + 3); - Canvas.LineTo(TickPos, LRect.Bottom + 7); - end; - TickEnd := TickPos; - end - else - begin - TickPos := LRect.Right - LThumbRect.Height div 2; - if (TrackBarStyle and TBS_TOP = TBS_TOP) or (TrackBarStyle and TBS_BOTH = TBS_BOTH) then - begin - Canvas.MoveTo(LRect.Top - 7, TickPos); - Canvas.LineTo(LRect.Top - 3, TickPos); - end; - if (TrackBarStyle and TBS_TOP = 0) or (TrackBarStyle and TBS_BOTH = TBS_BOTH) then - begin - Canvas.MoveTo(LRect.Bottom + 3, TickPos); - Canvas.LineTo(LRect.Bottom + 7, TickPos); - end; - TickEnd := TickPos; - end; - // ticks - for i := 1 to TickCount - 1 do - begin - TickPos := TickStart + Round((TickEnd - TickStart) * (i / (TickCount - 1))); - if TrackBarStyle and TBS_VERT = 0 then - begin - if (TrackBarStyle and TBS_TOP = TBS_TOP) or (TrackBarStyle and TBS_BOTH = TBS_BOTH) then - begin - Canvas.MoveTo(TickPos, LRect.Top - 6); - Canvas.LineTo(TickPos, LRect.Top - 3); - end; - if (TrackBarStyle and TBS_TOP = 0) or (TrackBarStyle and TBS_BOTH = TBS_BOTH) then - begin - Canvas.MoveTo(TickPos, LRect.Bottom + 3); - Canvas.LineTo(TickPos, LRect.Bottom + 6); - end; - end - else - begin - if (TrackBarStyle and TBS_TOP = TBS_TOP) or (TrackBarStyle and TBS_BOTH = TBS_BOTH) then - begin - Canvas.MoveTo(LRect.Top - 6, TickPos); - Canvas.LineTo(LRect.Top - 3, TickPos); - end; - if (TrackBarStyle and TBS_TOP = 0) or (TrackBarStyle and TBS_BOTH = TBS_BOTH) then - begin - Canvas.MoveTo(LRect.Bottom + 3, TickPos); - Canvas.LineTo(LRect.Bottom + 6, TickPos); - end; - end; - end; - end; - - // Thumb - if TrackBarStyle and TBS_NOTHUMB = 0 then - begin - SendMessage(Handle, TBM_GETTHUMBRECT, 0, IntPtr(@LRect)); - if not SysControl.Enabled then - begin - if TrackBarStyle and TBS_VERT = 0 then - begin - if TrackBarStyle and TBS_BOTH = TBS_BOTH then - LThemedTrackBar := ttbThumbDisabled - else if TrackBarStyle and TBS_TOP = TBS_TOP then - LThemedTrackBar := ttbThumbTopDisabled - else if TrackBarStyle and TBS_BOTTOM = TBS_BOTTOM then - LThemedTrackBar := ttbThumbBottomDisabled; - end - else - begin - LThemedTrackBar := ttbThumbRightDisabled; - if TrackBarStyle and TBS_TOP = TBS_TOP then - LThemedTrackBar := ttbThumbLeftDisabled - else if TrackBarStyle and TBS_BOTH = TBS_BOTH then - LThemedTrackBar := ttbThumbVertDisabled; - end; - end - else if FThumbPressed then - begin - if TrackBarStyle and TBS_VERT = 0 then - begin - if TrackBarStyle and TBS_BOTH = TBS_BOTH then - LThemedTrackBar := ttbThumbPressed - else if TrackBarStyle and TBS_TOP = TBS_TOP then - LThemedTrackBar := ttbThumbTopPressed - else if TrackBarStyle and TBS_BOTTOM = TBS_BOTTOM then - LThemedTrackBar := ttbThumbBottomPressed; - end - else - begin - LThemedTrackBar := ttbThumbRightPressed; - if TrackBarStyle and TBS_TOP = TBS_TOP then - LThemedTrackBar := ttbThumbLeftPressed - else if TrackBarStyle and TBS_BOTH = TBS_BOTH then - LThemedTrackBar := ttbThumbVertPressed; - end; - end - else if FMouseOnThumb then - begin - if TrackBarStyle and TBS_VERT = 0 then - begin - if TrackBarStyle and TBS_BOTH = TBS_BOTH then - LThemedTrackBar := ttbThumbHot - else if TrackBarStyle and TBS_TOP = TBS_TOP then - LThemedTrackBar := ttbThumbTopHot - else if TrackBarStyle and TBS_BOTTOM = TBS_BOTTOM then - LThemedTrackBar := ttbThumbBottomHot; - end - else - begin - LThemedTrackBar := ttbThumbRightHot; - if TrackBarStyle and TBS_TOP = TBS_TOP then - LThemedTrackBar := ttbThumbLeftHot - else if TrackBarStyle and TBS_BOTH = TBS_BOTH then - LThemedTrackBar := ttbThumbVertHot; - end; - end - else - begin - if TrackBarStyle and TBS_VERT = 0 then - begin - if TrackBarStyle and TBS_BOTH = TBS_BOTH then - LThemedTrackBar := ttbThumbNormal - else if TrackBarStyle and TBS_TOP = TBS_TOP then - LThemedTrackBar := ttbThumbTopNormal - else if TrackBarStyle and TBS_BOTTOM = TBS_BOTTOM then - LThemedTrackBar := ttbThumbBottomNormal; - end - else - begin - LThemedTrackBar := ttbThumbRightNormal; - if TrackBarStyle and TBS_TOP = TBS_TOP then - LThemedTrackBar := ttbThumbLeftNormal - else if TrackBarStyle and TBS_BOTH = TBS_BOTH then - LThemedTrackBar := ttbThumbVertNormal; - end; - end; - - LDetails := StyleServices.GetElementDetails(LThemedTrackBar); - StyleServices.DrawElement(Canvas.Handle, LDetails, LRect); - end; - - if Focused then - Canvas.DrawFocusRect(Rect(0, 0, SysControl.Width, SysControl.Height)); -end; - -procedure TSysTrackBarStyleHook.PaintBackground(Canvas: TCanvas); -var - LDetails: TThemedElementDetails; -begin - LDetails.Element := teTrackBar; - StyleServices.DrawParentBackground(Handle, Canvas.Handle, LDetails, False); -end; - -procedure TSysTrackBarStyleHook.WndProc(var Message: TMessage); -var - LRect: TRect; - NewValue: Boolean; -begin - // Addlog(Format('TSysTrackBarStyleHook $0x%x %s', [SysControl.Handle, WM_To_String(Message.Msg)])); - - case Message.Msg of - // WM_KEYUP, - WM_VSCROLL, WM_HSCROLL, TBM_SETPOS: - begin - Invalidate; - // CallDefaultProc(Message); - end; - - WM_MOUSEMOVE: - if GetWindowLong(Handle, GWL_STYLE) and TBS_NOTHUMB = 0 then - begin - SendMessage(Handle, TBM_GETTHUMBRECT, 0, IntPtr(@LRect)); - NewValue := PtInRect(LRect, Point(TWMMouse(Message).XPos, TWMMouse(Message).YPos)); - if NewValue <> FMouseOnThumb then - begin - FMouseOnThumb := NewValue; - Invalidate; - end; - end; - WM_LBUTTONUP: - if GetWindowLong(Handle, GWL_STYLE) and TBS_NOTHUMB = 0 then - begin - FThumbPressed := False; - Invalidate; - end; - WM_LBUTTONDOWN: - if GetWindowLong(Handle, GWL_STYLE) and TBS_NOTHUMB = 0 then - begin - SendMessage(Handle, TBM_GETTHUMBRECT, 0, IntPtr(@LRect)); - if PtInRect(LRect, Point(TWMMouse(Message).XPos, TWMMouse(Message).YPos)) then - FThumbPressed := True; - Invalidate; - end; - - else inherited; - end; -end; - -{ TSysUpDownStyleHook } - -constructor TSysUpDownStyleHook.Create(AHandle: THandle); -begin - inherited; - OverridePaint := True; - DoubleBuffered := True; -end; - -destructor TSysUpDownStyleHook.Destroy; -begin - inherited; -end; - -function TSysUpDownStyleHook.GetOrientation: TUDOrientation; -begin - if SysControl.Style and UDS_HORZ = UDS_HORZ then - Result := udHorizontal - else - Result := udVertical; -end; - -procedure TSysUpDownStyleHook.MouseLeave; -begin - FMouseOnLeft := False; - FMouseOnRight := False; - Invalidate; -end; - -procedure TSysUpDownStyleHook.Paint(Canvas: TCanvas); -var - R: TRect; - DrawState: TThemedScrollBar; - Details: TThemedElementDetails; -begin - if not StyleServices.Available then - Exit; - - StyleServices.DrawParentBackground(Handle, Canvas.Handle, Details, False); - - if GetOrientation = udHorizontal then - begin - R := SysControl.ClientRect; - R.Right := R.Left + R.Width div 2; - if FLeftPressed then - DrawState := tsArrowBtnLeftPressed - else if FMouseOnLeft and MouseInControl then - DrawState := tsArrowBtnLeftHot - else - DrawState := tsArrowBtnLeftNormal; - - Details := StyleServices.GetElementDetails(DrawState); - StyleServices.DrawElement(Canvas.Handle, Details, R); - - R := SysControl.ClientRect; - R.Left := R.Right - R.Width div 2; - if FRightPressed then - DrawState := tsArrowBtnRightPressed - else if FMouseOnRight and MouseInControl then - DrawState := tsArrowBtnRightHot - else - DrawState := tsArrowBtnRightNormal; - - Details := StyleServices.GetElementDetails(DrawState); - StyleServices.DrawElement(Canvas.Handle, Details, R); - end - else - begin - R := SysControl.ClientRect; - R.Bottom := R.Top + R.Height div 2; - if FLeftPressed then - DrawState := tsArrowBtnUpPressed - else if FMouseOnLeft and MouseInControl then - DrawState := tsArrowBtnUpHot - else - DrawState := tsArrowBtnUpNormal; - - Details := StyleServices.GetElementDetails(DrawState); - StyleServices.DrawElement(Canvas.Handle, Details, R); - - R := SysControl.ClientRect; - R.Top := R.Bottom - R.Height div 2; - - if FRightPressed then - DrawState := tsArrowBtnDownPressed - else if FMouseOnRight and MouseInControl then - DrawState := tsArrowBtnDownHot - else - DrawState := tsArrowBtnDownNormal; - - Details := StyleServices.GetElementDetails(DrawState); - StyleServices.DrawElement(Canvas.Handle, Details, R); - end; -end; - -procedure TSysUpDownStyleHook.WMLButtonDblClk(var Message: TWMMouse); -var - R: TRect; -begin - SetRedraw(False); - CallDefaultProc(TMessage(Message)); - SetRedraw(True); - if GetOrientation = udHorizontal then - begin - R := SysControl.ClientRect; - R.Right := R.Left + R.Width div 2; - if R.Contains(Point(Message.XPos, Message.YPos)) then - FLeftPressed := True - else - FLeftPressed := False; - - R := SysControl.ClientRect; - R.Left := R.Right - R.Width div 2; - if R.Contains(Point(Message.XPos, Message.YPos)) then - FRightPressed := True - else - FRightPressed := False; - end - else - begin - R := SysControl.ClientRect; - R.Bottom := R.Top + R.Height div 2; - if R.Contains(Point(Message.XPos, Message.YPos)) then - FLeftPressed := True - else - FLeftPressed := False; - - R := SysControl.ClientRect; - R.Top := R.Bottom - R.Height div 2; - if R.Contains(Point(Message.XPos, Message.YPos)) then - FRightPressed := True - else - FRightPressed := False; - end; - Invalidate; - Handled := True; -end; - -procedure TSysUpDownStyleHook.WMLButtonDown(var Message: TWMMouse); -var - R: TRect; -begin - SetRedraw(False); - CallDefaultProc(TMessage(Message)); - SetRedraw(True); - - if GetOrientation = udHorizontal then - begin - R := SysControl.ClientRect; - R.Right := R.Left + R.Width div 2; - if R.Contains(Point(Message.XPos, Message.YPos)) then - FLeftPressed := True - else - FLeftPressed := False; - - R := SysControl.ClientRect; - R.Left := R.Right - R.Width div 2; - if R.Contains(Point(Message.XPos, Message.YPos)) then - FRightPressed := True - else - FRightPressed := False; - end - else - begin - R := SysControl.ClientRect; - R.Bottom := R.Top + R.Height div 2; - if R.Contains(Point(Message.XPos, Message.YPos)) then - FLeftPressed := True - else - FLeftPressed := False; - - R := SysControl.ClientRect; - R.Top := R.Bottom - R.Height div 2; - if R.Contains(Point(Message.XPos, Message.YPos)) then - FRightPressed := True - else - FRightPressed := False; - end; - - Invalidate; - Handled := True; -end; - -procedure TSysUpDownStyleHook.WMLButtonUp(var Message: TWMMouse); -begin - SetRedraw(False); - CallDefaultProc(TMessage(Message)); - SetRedraw(True); - FLeftPressed := False; - FRightPressed := False; - Invalidate; - Handled := True; -end; - -procedure TSysUpDownStyleHook.WMMouseMove(var Message: TWMMouse); -var - R: TRect; - FOldMouseOnLeft, FOldMouseOnRight: Boolean; -begin - inherited; - CallDefaultProc(TMessage(Message)); - - FOldMouseOnLeft := FMouseOnLeft; - FOldMouseOnRight := FMouseOnRight; - - if GetOrientation = udHorizontal then - begin - R := SysControl.ClientRect; - R.Right := R.Left + R.Width div 2; - if R.Contains(Point(Message.XPos, Message.YPos)) then - FMouseOnLeft := True - else - FMouseOnLeft := False; - - R := SysControl.ClientRect; - R.Left := R.Right - R.Width div 2; - if R.Contains(Point(Message.XPos, Message.YPos)) then - FMouseOnRight := True - else - FMouseOnRight := False; - end - else - begin - R := SysControl.ClientRect; - R.Bottom := R.Top + R.Height div 2; - if R.Contains(Point(Message.XPos, Message.YPos)) then - FMouseOnLeft := True - else - FMouseOnLeft := False; - - R := SysControl.ClientRect; - R.Top := R.Bottom - R.Height div 2; - if R.Contains(Point(Message.XPos, Message.YPos)) then - FMouseOnRight := True - else - FMouseOnRight := False; - end; - - if (FOldMouseOnLeft <> FMouseOnLeft) and (FOldMouseOnRight <> FMouseOnRight) then - Invalidate; - - Handled := True; -end; - -procedure TSysUpDownStyleHook.WndProc(var Message: TMessage); -begin - inherited; -end; - - - -{ TSysLinkStyleHook } -{ -Debug Output: TSysLinkStyleHook WM_WINDOWPOSCHANGING Process ThemedSysControls.exe (1800) -Debug Output: TSysLinkStyleHook WM_NCCALCSIZE Process ThemedSysControls.exe (1800) -Debug Output: TSysLinkStyleHook WM_CHILDACTIVATE Process ThemedSysControls.exe (1800) -Debug Output: TSysLinkStyleHook WM_WINDOWPOSCHANGED Process ThemedSysControls.exe (1800) -Debug Output: TSysLinkStyleHook Unknown(067C) Process ThemedSysControls.exe (1800) -} -constructor TSysLinkStyleHook.Create(AHandle: THandle); -var - Style: DWORD; -begin - Style := GetWindowLongPtr(AHandle, GWL_STYLE); - if (Style and SS_ICON <> SS_ICON) and (Style and SS_BITMAP <> SS_BITMAP) then - - inherited; - -{$IF CompilerVersion > 23} - StyleElements := [seFont, seBorder, seClient]; -{$ELSE} - OverridePaint := True; - OverridePaintNC := True; - OverrideFont := True; -{$IFEND} - UpdateColors; -end; - -destructor TSysLinkStyleHook.Destroy; -begin - - inherited; -end; - -procedure TSysLinkStyleHook.Paint(Canvas: TCanvas); -const - States: array [Boolean] of TThemedTextLabel = (ttlTextLabelDisabled, - ttlTextLabelNormal); -var - LDetails: TThemedElementDetails; - LRect: TRect; - s : string; -begin - LRect := SysControl.ClientRect; - if GetBkMode(Canvas.Handle) = TRANSPARENT then - begin - LDetails := StyleServices.GetElementDetails(tbCheckBoxUncheckedNormal); - StyleServices.DrawParentBackground(Handle, Canvas.Handle, LDetails, False); - Canvas.Brush.Style := bsClear; - end - else - begin - Canvas.Brush.Color := StyleServices.GetStyleColor(scWindow); - Canvas.FillRect(LRect); - end; - - LDetails := StyleServices.GetElementDetails(States[SysControl.Enabled]); - Canvas.Font := SysControl.Font; - s:=SysControl.Text; - //OutputDebugString(PChar('Text '+s)); - DrawText(Canvas.Handle, LDetails, s, LRect, TextFormat); -end; - - -procedure TSysLinkStyleHook.PaintNC(Canvas: TCanvas); -var - LRect: TRect; - LBitMap: TBitmap; -begin - if IsFrameOrLine then - begin - LRect := Rect(0, 0, SysControl.Width, SysControl.Height); - LBitMap := TBitmap.Create; - try - LBitMap.Width := LRect.Width; - LBitMap.Height := LRect.Height; - Frame3D(LBitMap.Canvas, LRect, StyleServices.ColorToRGB(clBtnShadow), - StyleServices.ColorToRGB(clBtnHighLight), 1); - ExcludeClipRect(Canvas.Handle, 1, 1, SysControl.Width - 1, - SysControl.Height - 1); - Canvas.Draw(0, 0, LBitMap); - finally - LBitMap.Free; - end; - end; -end; - -procedure TSysLinkStyleHook.WMNCCalcSize(var Message: TWMNCCalcSize); -begin - -end; - -procedure TSysLinkStyleHook.WndProc(var Message: TMessage); -begin - //OutputDebugString(PChar('TSysLinkStyleHook '+WM_To_String(Message.Msg)+' Handle '+IntToHex(SysControl.Handle, 8))); - - case Message.Msg of - -// $067C : -// begin -// CallDefaultProc(Message); -// if SysControl.Visible then -// Invalidate; -// end; - - WM_SETTEXT: - begin - CallDefaultProc(Message); - if SysControl.Visible then - Invalidate; - end; - - WM_ENABLE: - if SysControl.Visible then - Invalidate; - - WM_PAINT: - begin - if OverridePaint and StyleServicesEnabled then - begin - if (IsText and (Length(SysControl.Text) > 0)) then - inherited - else - CallDefaultProc(Message); - end - else - CallDefaultProc(Message); - end; - - else - inherited; - end; -end; - -initialization - -if StyleServices.Available then -begin - with TSysStyleManager do - begin - RegisterSysStyleHook(TOOLBARCLASSNAME, TSysToolbarStyleHook); - RegisterSysStyleHook(WC_LISTVIEW, TSysListViewStyleHook); - RegisterSysStyleHook(WC_TABCONTROL, TSysTabControlStyleHook); - RegisterSysStyleHook(WC_TREEVIEW, TSysTreeViewStyleHook); - {$IFNDEF USE_Vcl.Styles.Hooks} - RegisterSysStyleHook(PROGRESS_CLASS, TSysProgressBarStyleHook); - {$ENDIF} - RegisterSysStyleHook('RichEdit20A', TSysRichEditStyleHook); - RegisterSysStyleHook('RichEdit20W', TSysRichEditStyleHook); - RegisterSysStyleHook('RichEdit30A', TSysRichEditStyleHook); - RegisterSysStyleHook('RichEdit30W', TSysRichEditStyleHook); - RegisterSysStyleHook('RichEdit41A', TSysRichEditStyleHook); - RegisterSysStyleHook('RichEdit41W', TSysRichEditStyleHook); - RegisterSysStyleHook('RichEdit50A', TSysRichEditStyleHook); - RegisterSysStyleHook('RichEdit50W', TSysRichEditStyleHook); - RegisterSysStyleHook(REBARCLASSNAME, TSysReBarStyleHook); - RegisterSysStyleHook(STATUSCLASSNAME, TSysStatusBarStyleHook); - RegisterSysStyleHook(TRACKBAR_CLASS, TSysTrackBarStyleHook); - RegisterSysStyleHook(UPDOWN_CLASS, TSysUpDownStyleHook); - end; -end; - -finalization - -with TSysStyleManager do -begin - UnRegisterSysStyleHook(TOOLBARCLASSNAME, TSysToolbarStyleHook); - UnRegisterSysStyleHook(WC_LISTVIEW, TSysListViewStyleHook); - UnRegisterSysStyleHook(WC_TABCONTROL, TSysTabControlStyleHook); - UnRegisterSysStyleHook(WC_TREEVIEW, TSysTreeViewStyleHook); - {$IFNDEF USE_Vcl.Styles.Hooks} - UnRegisterSysStyleHook(PROGRESS_CLASS, TSysProgressBarStyleHook); - {$ENDIF} - - UnRegisterSysStyleHook('RichEdit20A', TSysRichEditStyleHook); - UnRegisterSysStyleHook('RichEdit20W', TSysRichEditStyleHook); - UnRegisterSysStyleHook('RichEdit30A', TSysRichEditStyleHook); - UnRegisterSysStyleHook('RichEdit30W', TSysRichEditStyleHook); - UnRegisterSysStyleHook('RichEdit41A', TSysRichEditStyleHook); - UnRegisterSysStyleHook('RichEdit41W', TSysRichEditStyleHook); - UnRegisterSysStyleHook('RichEdit50A', TSysRichEditStyleHook); - UnRegisterSysStyleHook('RichEdit50W', TSysRichEditStyleHook); - UnRegisterSysStyleHook(REBARCLASSNAME, TSysReBarStyleHook); - UnRegisterSysStyleHook(STATUSCLASSNAME, TSysStatusBarStyleHook); - UnRegisterSysStyleHook(TRACKBAR_CLASS, TSysTrackBarStyleHook); - UnRegisterSysStyleHook(UPDOWN_CLASS, TSysUpDownStyleHook); -end; - -end. +//************************************************************************************************** +// +// Unit Vcl.Styles.Utils.ComCtrls +// unit for the VCL Styles Utils +// https://github.com/RRUZ/vcl-styles-utils/ +// +// 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. +// +// +// Portions created by Mahdi Safsafi [SMP3] e-mail SMP@LIVE.FR +// Portions created by Rodrigo Ruz V. are Copyright (C) 2013-2023 Rodrigo Ruz V. +// All Rights Reserved. +// +//************************************************************************************************ +unit Vcl.Styles.Utils.ComCtrls; + +{$I VCL.Styles.Utils.inc} + +interface + +uses + System.Classes, + System.Types, + System.SysUtils, + Winapi.Windows, + Winapi.Messages, + Winapi.CommCtrl, + Winapi.RichEdit, + Vcl.Styles, + Vcl.Themes, + Vcl.Graphics, + {$IFDEF USE_Vcl.Styles.Hooks} + Vcl.Styles.Hooks, + {$ENDIF} + Vcl.Styles.Utils.SysStyleHook, + Vcl.Styles.Utils.StdCtrls, + Vcl.Forms, + Vcl.ImgList, + Vcl.ComCtrls, + Vcl.ExtCtrls, + Vcl.Styles.Utils.Forms, + Vcl.Controls; + +type + TSysListViewStyleHook = class(TSysScrollingStyleHook) + private type +{$REGION 'TSysHeaderStyleHook'} + TSysHeaderStyleHook = class(TMouseTrackSysControlStyleHook) + private type +{$REGION 'TSysSection'} + TSysSection = class + private + FIndex: Integer; + FColumnIndex: Integer; + FImageIndex: Integer; + FImageListHandle: THandle; + FText: String; + FSectionRect: TRect; + FHeaderHandle: THandle; + FHasSplitButton: Boolean; + FTextFormat: TTextFormat; + FBitmapOnRight: Boolean; + FShowImage: Boolean; + FDropDownRect: TRect; + protected + procedure DoGetSectionInfo; + public + constructor Create(SysParent: TSysControl; Index: Integer); virtual; + Destructor Destroy; override; + property Text: string read FText; + property ImageListHandle: THandle read FImageListHandle; + property ImageIndex: Integer read FImageIndex; + property SectionRect: TRect read FSectionRect; + property ColumnIndex: Integer read FColumnIndex; + property ShowImage: Boolean read FShowImage; + property BitmapOnRight: Boolean read FBitmapOnRight; + property TextFormat: TTextFormat read FTextFormat; + property HasSplitButton: Boolean read FHasSplitButton; + property DropDownRect: TRect read FDropDownRect; + end; +{$ENDREGION} + private + FPressedSection: Integer; + FMouseDown: Boolean; + FSysSection: TSysSection; + FListViewStyleHook: TSysListViewStyleHook; + function GetButtonsCount: Integer; + function GetItem(Index: Integer): TSysSection; + protected + procedure MouseLeave; override; + procedure WndProc(var Message: TMessage); override; + procedure Paint(Canvas: TCanvas); override; + procedure PaintBackground(Canvas: TCanvas); override; + + public + constructor Create(AHandle: THandle); override; + Destructor Destroy; override; + property ButtonsCount: Integer read GetButtonsCount; + property Items[Index: Integer]: TSysSection read GetItem; + end; +{$ENDREGION} + private + FHeaderHandle: THandle; + FHeaderStyleHook: TSysHeaderStyleHook; + protected + procedure Scroll(const Kind: TScrollBarKind; const ScrollType: TSysScrollingType; Pos, Delta: Integer); override; + procedure UpdateColors; override; + procedure WndProc(var Message: TMessage); override; + procedure PaintBackground(Canvas: TCanvas); override; + procedure Paint(Canvas: TCanvas); override; + + public + procedure SetSelectedColumn(iCol: Integer); + constructor Create(AHandle: THandle); override; + Destructor Destroy; override; + property HeaderHandle: THandle read FHeaderHandle write FHeaderHandle; + end; + + TSysTreeViewStyleHook = class(TSysScrollingStyleHook) + protected + procedure Scroll(const Kind: TScrollBarKind; const ScrollType: TSysScrollingType; Pos, Delta: Integer); override; + procedure UpdateColors; override; + procedure WndProc(var Message: TMessage); override; + public + constructor Create(AHandle: THandle); override; + Destructor Destroy; override; + end; + + TSysTabControlStyleHook = class(TMouseTrackSysControlStyleHook) + private + FHotTabIndex: Integer; + function GetDisplayRect: TRect; + function GetTabCount: Integer; + function GetTabIndex: Integer; + function GetImages: TCustomImageList; + function GetTabRect(Index: Integer): TRect; + function GetTabPosition: TTabPosition; + function GetTabs(Index: Integer): string; + procedure AngleTextOut(Canvas: TCanvas; const Angle, X, Y: Integer; const Text: string); + protected + procedure DrawTab(Canvas: TCanvas; const Index: Integer); + procedure PaintBackground(Canvas: TCanvas); override; + procedure Paint(Canvas: TCanvas); override; + procedure PaintNC(Canvas: TCanvas); override; + procedure WndProc(var Message: TMessage); override; + public + constructor Create(AHandle: THandle); override; + Destructor Destroy; override; + property DisplayRect: TRect read GetDisplayRect; + property TabCount: Integer read GetTabCount; + property TabIndex: Integer read GetTabIndex; + property Images: TCustomImageList read GetImages; + property TabRect[Index: Integer]: TRect read GetTabRect; + property TabPosition: TTabPosition read GetTabPosition; + property Tabs[Index: Integer]: string read GetTabs; + end; + + TSysRichEditStyleHook = class(TSysScrollingStyleHook) + strict private + + procedure EMSetBkgndColor(var Message: TMessage); message EM_SETBKGNDCOLOR; + procedure EMSetCharFormat(var Message: TMessage); message EM_SETCHARFORMAT; + strict private + FBackColor: TColor; + protected + procedure UpdateColors; override; + procedure WndProc(var Message: TMessage); override; + function GetBorderSize: TRect; override; + public + property BackColor: TColor read FBackColor write FBackColor; + constructor Create(AHandle: THandle); override; + end; + +type + TSysToolbarButtonState = set of (bsEnabled, bsPressed, bsChecked, bsHidden); + TSysToolbarButtonStyle = set of (bsBtn, bsSep, bsCheck, bsGroup, bsCheckGroup, bsDropDown); + + TSysReBarStyleHook = class(TSysStyleHook) + strict private + function GetBandText(const Index: Integer): string; + function GetBandRect(const Index: Integer): TRect; + function GetBandBorder(const Index: Integer): TRect; + function GetBandCount: Integer; + strict protected + procedure PaintBackground(Canvas: TCanvas); override; + procedure Paint(Canvas: TCanvas); override; + procedure PaintNC(Canvas: TCanvas); override; + procedure WndProc(var Message: TMessage); override; + public + constructor Create(AHandle: THandle); override; + end; + + TSysStatusBarStyleHook = class(TSysStyleHook) + strict protected + procedure Paint(Canvas: TCanvas); override; + procedure WndProc(var Message: TMessage); override; + public + constructor Create(AHandle: THandle); override; + end; + + TSysTrackBarStyleHook = class(TSysStyleHook) + strict private + FMouseOnThumb: Boolean; + FThumbPressed: Boolean; + strict protected + procedure Paint(Canvas: TCanvas); override; + procedure PaintBackground(Canvas: TCanvas); override; + procedure WndProc(var Message: TMessage); override; + public + constructor Create(AHandle: THandle); override; + end; + + TSysToolbarStyleHook = class(TMouseTrackSysControlStyleHook) + private type +{$REGION 'TSysToolbarButton'} + TSysToolbarButton = class + private + FParent: TSysControl; + FIndex: Integer; + FText: String; + FImageIndex: Integer; + FState: TSysToolbarButtonState; + FStyle: TSysToolbarButtonStyle; + function GetItemRect: TRect; + procedure DoGetItemInfo; + function GetDropDownWidth: Integer; + public + constructor Create(SysParent: TSysControl; Index: Integer); virtual; + Destructor Destroy; override; + property ItemRect: TRect read GetItemRect; + property Parent: TSysControl read FParent; + property Text: String Read FText; + Property ImageIndex: Integer read FImageIndex; + property State: TSysToolbarButtonState read FState; + property Style: TSysToolbarButtonStyle read FStyle; + property DropDownWidth: Integer read GetDropDownWidth; + end; +{$ENDREGION} + + var + FImages: TImageList; + FDisabledImages: TImageList; + FSysToolbarButton: TSysToolbarButton; + FButtonsPainted: Boolean; + function GetItem(Index: Integer): TSysToolbarButton; + function GetCount: Integer; + function IsToolbarTransparent: Boolean; + function IsToolbarFlat: Boolean; + function GetShowText: Boolean; + function IsToolbarList: Boolean; + function IsToolbarWrapable: Boolean; + protected + procedure ApplyImageList; + procedure PaintBackground(Canvas: TCanvas); override; + procedure Paint(Canvas: TCanvas); override; + procedure PaintNC(Canvas: TCanvas); override; + procedure WndProc(var Message: TMessage); override; + public + constructor Create(AHandle: THandle); override; + Destructor Destroy; override; + property Items[index: Integer]: TSysToolbarButton read GetItem; + property Count: Integer read GetCount; + Property Flat: Boolean Read IsToolbarFlat; + Property Transparent: Boolean Read IsToolbarTransparent; + property ShowText: Boolean read GetShowText; + property List: Boolean read IsToolbarList; + property Wrapable: Boolean read IsToolbarWrapable; + end; + + TSysProgressBarStyleHook = class(TSysStyleHook) + strict private + FStep: Integer; + // FLastPos: Integer; + FOrientation: TProgressBarOrientation; + FTimer: TTimer; + procedure TimerAction(Sender: TObject); + function GetBarRect: TRect; + function GetBorderWidth: Integer; + function GetMax: Integer; + function GetMin: Integer; + function GetOrientation: TProgressBarOrientation; + function GetPercent: Single; + function GetPosition: Integer; + procedure WMNCCalcSize(var Message: TWMNCCalcSize); message WM_NCCALCSIZE; + strict protected + procedure PaintBackground(Canvas: TCanvas); override; + procedure PaintBar(Canvas: TCanvas); virtual; + procedure PaintFrame(Canvas: TCanvas); virtual; + procedure Paint(Canvas: TCanvas); override; + procedure WndProc(var Message: TMessage); override; + property BarRect: TRect read GetBarRect; + property BorderWidth: Integer read GetBorderWidth; + property Max: Integer read GetMax; + property Min: Integer read GetMin; + property Orientation: TProgressBarOrientation read GetOrientation; + property Position: Integer read GetPosition; + public + constructor Create(AHandle: THandle); override; + destructor Destroy; override; + end; + + TSysUpDownStyleHook = class(TMouseTrackSysControlStyleHook) + strict private + FLeftPressed, FRightPressed: Boolean; + FMouseOnLeft, FMouseOnRight: Boolean; + function GetOrientation: TUDOrientation; + procedure WMLButtonDblClk(var Message: TWMMouse); message WM_LBUTTONDBLCLK; + procedure WMLButtonDown(var Message: TWMMouse); message WM_LBUTTONDOWN; + procedure WMLButtonUp(var Message: TWMMouse); message WM_LBUTTONUP; + procedure WMMouseMove(var Message: TWMMouse); message WM_MOUSEMOVE; + protected + procedure Paint(Canvas: TCanvas); override; + procedure MouseLeave; override; + procedure WndProc(var Message: TMessage); override; + public + constructor Create(AHandle: THandle); override; + destructor Destroy; override; + end; + + TSysLinkStyleHook = class(TSysStaticStyleHook) + private + procedure WMNCCalcSize(var Message: TWMNCCalcSize); message WM_NCCALCSIZE; + protected + procedure PaintNC(Canvas: TCanvas); override; + procedure Paint(Canvas: TCanvas); override; + procedure WndProc(var Message: TMessage); override; + public + constructor Create(AHandle: THandle); override; + Destructor Destroy; override; + end; + +implementation + +uses + // IOUtils, + Vcl.Styles.Utils.SysControls, Vcl.Styles.Utils.Graphics; + +// +// procedure Addlog(const Msg: string); +// begin +// TFile.AppendAllText('C:\Test\log.txt',Format('%s %s %s',[FormatDateTime('hh:nn:ss.zzz', Now), msg, sLineBreak])); +// end; + +{ TSysListViewStyleHook } + +constructor TSysListViewStyleHook.Create(AHandle: THandle); +begin + inherited; + FHeaderStyleHook := nil; + FHeaderHandle := 0; +{$IF CompilerVersion > 23} + StyleElements := [seFont, seBorder]; +{$ELSE} + OverridePaint := False; + OverridePaintNC := True; + OverrideFont := True; +{$IFEND} + OverrideEraseBkgnd := True; + SendMessage(Handle, WM_NOTIFY, 0, 0); +end; + +procedure TSysListViewStyleHook.Scroll(const Kind: TScrollBarKind; const ScrollType: TSysScrollingType; Pos, Delta: Integer); +var + R: TRect; +begin + if ScrollType = skTracking then + begin + if Kind = sbVertical then + begin + if ListView_GetView(Handle) = LVS_REPORT then + begin + R := Rect(0, 0, 0, 0); + ListView_GetItemRect(Handle, 0, R, LVIR_BOUNDS); + Delta := Delta * R.Height; + end; + ListView_Scroll(Handle, 0, Delta); + end; + if Kind = sbHorizontal then + begin + if ListView_GetView(Handle) = LVS_LIST then + begin + R := TRect.Empty; + ListView_GetItemRect(Handle, 0, R, LVIR_BOUNDS); + Delta := Delta * R.Width; + end; + ListView_Scroll(Handle, Delta, 0); + end; + end + else + inherited; +end; + +procedure TSysListViewStyleHook.SetSelectedColumn(iCol: Integer); +begin + ListView_SetSelectedColumn(Handle, iCol); +end; + +destructor TSysListViewStyleHook.Destroy; +begin + if Assigned(FHeaderStyleHook) then + FreeAndNil(FHeaderStyleHook); + inherited; +end; + +procedure TSysListViewStyleHook.UpdateColors; +begin + inherited; + if OverrideEraseBkgnd then + Color := StyleServices.GetStyleColor(scListView) + else + Color := clWindow; + if OverrideFont then + FontColor := StyleServices.GetSystemColor(clWindowText) + else + FontColor := clWindowText; + + ListView_SetBkColor(Handle, ColorToRGB(Color)); + ListView_SetTextBkColor(Handle, ColorToRGB(Color)); + ListView_SetTextColor(Handle, ColorToRGB(FontColor)); + +end; + +procedure TSysListViewStyleHook.WndProc(var Message: TMessage); +begin + case Message.Msg of + + WM_CREATE, LVM_UPDATE: + begin + Message.Result := CallDefaultProc(Message); + UpdateColors; + SetSelectedColumn(-1); + Exit; + end; + + WM_ERASEBKGND: + begin + UpdateColors; + SetSelectedColumn(-1); + Message.Result := CallDefaultProc(Message); + Exit; + end; + + WM_NOTIFY: + begin + if not Assigned(FHeaderStyleHook) then + begin + HeaderHandle := ListView_GetHeader(Handle); + if (HeaderHandle <> 0) then + begin + FHeaderStyleHook := TSysHeaderStyleHook.Create(HeaderHandle); + FHeaderStyleHook.FListViewStyleHook := Self; + end; + end; + + if (Message.WParam <> 0) or (Message.LParam <> 0) then + Message.Result := CallDefaultProc(Message); + Exit; + end; + else inherited; + end; + +end; + +{ TSysListViewStyleHook.TSysHeaderStyleHook } + +constructor TSysListViewStyleHook.TSysHeaderStyleHook.Create(AHandle: THandle); +begin + inherited; +{$IF CompilerVersion > 23} + StyleElements := [seClient]; +{$ELSE} + OverridePaint := True; + OverridePaintNC := False; + OverrideFont := False; +{$IFEND} + FPressedSection := -1; + FSysSection := nil; +end; + +destructor TSysListViewStyleHook.TSysHeaderStyleHook.Destroy; +begin + if Assigned(FSysSection) then + FreeAndNil(FSysSection); + inherited; +end; + +function TSysListViewStyleHook.TSysHeaderStyleHook.GetButtonsCount: Integer; +begin + Result := Header_GetItemCount(Handle); +end; + +function TSysListViewStyleHook.TSysHeaderStyleHook.GetItem(Index: Integer): TSysSection; +begin + Result := nil; + if (Index > -1) and (index < ButtonsCount) then + begin + if Assigned(FSysSection) then + FreeAndNil(FSysSection); + FSysSection := TSysSection.Create(SysControl, Index); + Result := FSysSection; + end; +end; + +procedure TSysListViewStyleHook.TSysHeaderStyleHook.MouseLeave; +begin + Invalidate; +end; + +procedure TSysListViewStyleHook.TSysHeaderStyleHook.Paint(Canvas: TCanvas); +var + i: Integer; + Bmp: TBitmap; + LImageList: TImageList; + R, TxtRect, ImgRect: TRect; + LSectionRect: TRect; + LTextFormat: TTextFormat; + LText: String; + LSplitDetails, LDetails: TThemedElementDetails; + DC: HDC; + SectionHot: Boolean; + LDropDownRect: TRect; + P: TPoint; +begin + Bmp := TBitmap.Create; + try + Bmp.SetSize(SysControl.Width, SysControl.Height); + Bmp.Canvas.Brush.Color := Color; + R := Rect(0, 0, Bmp.Width, Bmp.Height); + Bmp.Canvas.FillRect(R); + DC := Bmp.Canvas.Handle; + + LDetails := StyleServices.GetElementDetails(thHeaderItemNormal); + DrawStyleElement(DC, LDetails, R); + + for i := 0 to ButtonsCount - 1 do + begin + with Items[i] do + begin + LSectionRect := SectionRect; + LTextFormat := TextFormat; + LText := Text; + LDropDownRect := DropDownRect; + end; + SectionHot := False; + if (MouseInControl) and (not FMouseDown) then + begin + GetCursorPos(P); + ScreenToClient(Handle, P); + if LSectionRect.Contains(P) then + SectionHot := True; + end; + + LDetails := StyleServices.GetElementDetails(thHeaderItemNormal); + if SectionHot then + LDetails := StyleServices.GetElementDetails(thHeaderItemHot); + if FPressedSection = i then + LDetails := StyleServices.GetElementDetails(thHeaderItemPressed); + DrawStyleElement(DC, LDetails, LSectionRect); + + TxtRect := LSectionRect; + inc(TxtRect.Left, 4); + + if Items[i].HasSplitButton then + begin + LSplitDetails := StyleServices.GetElementDetails(ttbDropDownButtonGlyphHot);; + R := LDropDownRect; + if SectionHot then + begin + DrawStyleElement(DC, LSplitDetails, R); + with Bmp.Canvas do + begin + Pen.Color := StyleServices.GetSystemColor(clBtnShadow); + MoveTo(R.Left, 3); + LineTo(R.Left, R.Height - 3); + Pen.Color := StyleServices.GetSystemColor(clBtnHighLight); + MoveTo(R.Left - 1, 3); + LineTo(R.Left - 1, R.Height - 3); + end; + end; + dec(TxtRect.Right, R.Width); + end; + + if (Items[i].ShowImage) and (Items[i].ImageListHandle > 0) then + begin + LImageList := TImageList.Create(nil); + try + LImageList.Handle := Items[i].ImageListHandle; + LImageList.Masked := True; + LImageList.BkColor := clNone; { Transparent bitmap } + R := LSectionRect; + ImgRect := Rect(0, 0, LImageList.Width, LImageList.Height); + ImgRect := RectCenter(ImgRect, R); + if not Items[i].BitmapOnRight then + begin + ImgRect.Left := R.Left + 2; + ImgRect.Right := ImgRect.Left + 2 + LImageList.Width; + inc(TxtRect.Left, ImgRect.Width + 2); + end + else + begin + ImgRect.Left := LSectionRect.Right - LImageList.Width - 2; + ImgRect.Right := LSectionRect.Right; + TxtRect.Right := TxtRect.Right - ImgRect.Width - 2; + end; + LImageList.Draw(Bmp.Canvas, ImgRect.Left, ImgRect.Top, Items[i].ImageIndex); + finally + LImageList.Free; + end; + end; + + include(LTextFormat, tfSingleLine); + include(LTextFormat, tfVerticalCenter); + StyleServices.DrawText(DC, LDetails, LText, TxtRect, LTextFormat); + end; + Canvas.Draw(0, 0, Bmp); + finally + Bmp.Free; + end; +end; + +procedure TSysListViewStyleHook.TSysHeaderStyleHook.PaintBackground(Canvas: TCanvas); +begin + // inherited; + { Leave this block clean . } +end; + +procedure TSysListViewStyleHook.Paint(Canvas: TCanvas); +begin + { Leave this block clean . } +end; + +procedure TSysListViewStyleHook.PaintBackground(Canvas: TCanvas); +begin + { Leave this block clean . } +end; + +procedure TSysListViewStyleHook.TSysHeaderStyleHook.WndProc(var Message: TMessage); +var + Info: THDHitTestInfo; +begin + case Message.Msg of + + WM_LBUTTONDOWN, WM_LBUTTONDBLCLK: + begin + FMouseDown := True; + Info.Point.X := TWMMouse(Message).XPos; + Info.Point.Y := TWMMouse(Message).YPos; + SendMessage(Handle, HDM_HITTEST, 0, IntPtr(@Info)); + + if (Info.Flags and HHT_ONDIVIDER = 0) and (Info.Flags and HHT_ONDIVOPEN = 0) then + FPressedSection := Info.item + else + FPressedSection := -1; + end; + + WM_LBUTTONUP, WM_RBUTTONUP: + begin + FMouseDown := False; + FPressedSection := -1; + end; + + end; + inherited; + +end; + +{ TSysListViewStyleHook.TSysHeaderStyleHook.TSysSection } + +constructor TSysListViewStyleHook.TSysHeaderStyleHook.TSysSection.Create(SysParent: TSysControl; Index: Integer); +begin + inherited Create; + FTextFormat := []; + FIndex := Index; + FText := ''; + FImageListHandle := 0; + FImageIndex := -1; + FColumnIndex := -1; + FSectionRect := TRect.Empty; + FDropDownRect := TRect.Empty; + FHasSplitButton := False; + FShowImage := False; + FHeaderHandle := SysParent.Handle; + DoGetSectionInfo; +end; + +destructor TSysListViewStyleHook.TSysHeaderStyleHook.TSysSection.Destroy; +begin + + inherited; +end; + +procedure TSysListViewStyleHook.TSysHeaderStyleHook.TSysSection.DoGetSectionInfo; +var + SectionOrder: array of Integer; + R: TRect; + item: THDItem; + Buffer: array [0 .. 255] of Char; + LRtlReading: Boolean; +begin + FillChar(Buffer, 255, Char(0)); + SetLength(SectionOrder, Header_GetItemCount(FHeaderHandle)); + Header_GetOrderArray(FHeaderHandle, Header_GetItemCount(FHeaderHandle), Pointer(SectionOrder)); + FColumnIndex := SectionOrder[FIndex]; + Header_GetItemRect(FHeaderHandle, ColumnIndex, @R); + FSectionRect := R; + FillChar(item, sizeof(item), 0); + item.mask := HDI_TEXT or HDI_FORMAT or HDI_IMAGE; + item.pszText := @Buffer; + item.cchTextMax := Length(Buffer); + if Header_GetItem(FHeaderHandle, FColumnIndex, item) then + begin + with item do + begin + FImageIndex := iImage; + FText := String(pszText); + FHasSplitButton := (fmt and HDF_SPLITBUTTON = HDF_SPLITBUTTON); + LRtlReading := (fmt and HDF_RTLREADING = HDF_RTLREADING); + FTextFormat := []; + if (fmt and HDF_LEFT = HDF_LEFT) then + include(FTextFormat, tfLeft) + else if (fmt and HDF_RIGHT = HDF_RIGHT) then + include(FTextFormat, tfRight) + else if (fmt and HDF_CENTER = HDF_CENTER) then + include(FTextFormat, tfCenter); + + if LRtlReading then + include(FTextFormat, tfRtlReading); + FBitmapOnRight := (fmt and HDF_BITMAP_ON_RIGHT = HDF_BITMAP_ON_RIGHT); + + FShowImage := (FImageIndex > -1) and (fmt and HDF_BITMAP = HDF_BITMAP); + end; + end; + R := TRect.Empty; + if Header_GetItemDropDownRect(FHeaderHandle, FIndex, R) then + FDropDownRect := R; + FImageListHandle := Header_GetImageList(FHeaderHandle); +end; + +{ TSysTreeViewStyleHook } + + +constructor TSysTreeViewStyleHook.Create(AHandle: THandle); +begin + inherited; +{$IF CompilerVersion > 23} + StyleElements := [seFont{, seBorder}]; //Allow to the Vcl.Styles.Hook handle the NC and scroll paint +{$ELSE} + OverrideFont := True; + OverridePaintNC := False; //Allow to the Vcl.Styles.Hook handle the NC and scroll paint +{$IFEND} + OverrideEraseBkgnd := True; +end; + +destructor TSysTreeViewStyleHook.Destroy; +begin + + inherited; +end; + +procedure TSysTreeViewStyleHook.Scroll(const Kind: TScrollBarKind; + const ScrollType: TSysScrollingType; Pos, Delta: Integer); +begin + if Kind = sbVertical then + begin + case ScrollType of + skTracking: + begin + LstPos := Pos; + //OutputDebugString(PChar(Format('sbVertical Pos %d Delta %d AllowScrolling %s', [Pos, Delta, BooltoStr(AllowScrolling, True)]))); + AllowScrolling := True; + SendMessage(Handle, WM_VSCROLL, MakeWParam(SB_THUMBTRACK, Pos), 0); + AllowScrolling := False; + //OutputDebugString(PChar(Format('sbVertical Pos %d Delta %d', [Pos, Delta]))); + end; + skLineUp: SendMessage(Handle, WM_VSCROLL, SB_LINEUP, 0); + skLineDown: SendMessage(Handle, WM_VSCROLL, SB_LINEDOWN, 0); + skPageUp: SendMessage(Handle, WM_VSCROLL, SB_PAGEUP, 0); + skPageDown: SendMessage(Handle, WM_VSCROLL, SB_PAGEDOWN, 0); + end; + end + else + if Kind = sbHorizontal then + begin + case ScrollType of + skTracking: + begin + LstPos := Pos; + //OutputDebugString(PChar(Format('sbHorizontal Pos %d Delta %d AllowScrolling %s', [Pos, Delta, BooltoStr(AllowScrolling, True)]))); + AllowScrolling := True; + SendMessage(Handle, WM_HSCROLL, MakeWParam(SB_THUMBTRACK, Pos), 0); + AllowScrolling := False; + //OutputDebugString(PChar(Format('sbHorizontal Pos %d Delta %d', [Pos, Delta]))); + end; + skLineLeft: SendMessage(Handle, WM_HSCROLL, SB_LINELEFT, 0); + skLineRight: SendMessage(Handle, WM_HSCROLL, SB_LINERIGHT, 0); + skPageLeft: SendMessage(Handle, WM_HSCROLL, SB_PAGELEFT, 0); + skPageRight: SendMessage(Handle, WM_HSCROLL, SB_PAGERIGHT, 0); + end; + end; +end; + +procedure TSysTreeViewStyleHook.UpdateColors; +begin + inherited; + if OverrideEraseBkgnd then + Color := StyleServices.GetStyleColor(scTreeView) + else + Color := clWhite; + + if OverrideFont then + FontColor := StyleServices.GetSystemColor(clWindowText) + else + FontColor := clWindowText; +end; + +procedure TSysTreeViewStyleHook.WndProc(var Message: TMessage); +begin + case Message.Msg of + WM_ERASEBKGND: + begin + UpdateColors; + + if (Longint(TreeView_GetBkColor(Handle))<>ColorToRGB(Color)) then + TreeView_SetBkColor(Handle, ColorToRGB(Color)); + + if (Longint(TreeView_GetTextColor(Handle))<>ColorToRGB(FontColor)) then + TreeView_SetTextColor(Handle, ColorToRGB(FontColor)); + + Message.Result := CallDefaultProc(Message); + Exit; + end; + else inherited; + end; +end; + +{ TSysTabControlStyleHook } + +procedure TSysTabControlStyleHook.AngleTextOut(Canvas: TCanvas; const Angle, X, Y: Integer; const Text: string); +var + SaveIndex: Integer; +begin + SaveIndex := SaveDC(Canvas.Handle); + try + SetBkMode(Canvas.Handle, Transparent); + Canvas.Font.Orientation := Angle; + Canvas.TextOut(X, Y, Text); + finally + RestoreDC(Canvas.Handle, SaveIndex); + end; + +end; + +constructor TSysTabControlStyleHook.Create(AHandle: THandle); +begin + inherited; +{$IF CompilerVersion > 23} + StyleElements := [seClient, seFont]; +{$ELSE} + OverridePaint := True; + OverridePaintNC := False; + OverrideFont := True; +{$IFEND} + // OverrideEraseBkgnd:=True; + FHotTabIndex := -1; +end; + +destructor TSysTabControlStyleHook.Destroy; +begin + + inherited; +end; + +function TSysTabControlStyleHook.GetDisplayRect: TRect; +begin + //Result := Rect(0, 0, 0, 0); + Result := SysControl.ClientRect; + SendMessage(Handle, TCM_ADJUSTRECT, 0, IntPtr(@Result)); + inc(Result.Top, 2); +end; + +function TSysTabControlStyleHook.GetImages: TCustomImageList; +begin + Result := nil; +end; + +function TSysTabControlStyleHook.GetTabCount: Integer; +begin + Result := SendMessage(Handle, TCM_GETITEMCOUNT, 0, 0); +end; + +function TSysTabControlStyleHook.GetTabIndex: Integer; +begin + Result := SendMessage(Handle, TCM_GETCURSEL, 0, 0); +end; + +function TSysTabControlStyleHook.GetTabPosition: TTabPosition; +begin + Result := tpTop; +end; + +function TSysTabControlStyleHook.GetTabRect(Index: Integer): TRect; +begin + Result := Rect(0, 0, 0, 0); + TabCtrl_GetItemRect(Handle, Index, Result); +end; + +function TSysTabControlStyleHook.GetTabs(Index: Integer): string; +var + TCItem: TTCItem; + Buffer: array [0 .. 254] of Char; +begin + FillChar(TCItem, sizeof(TCItem), 0); + + TCItem.mask := TCIF_TEXT; + TCItem.pszText := @Buffer; + TCItem.cchTextMax := sizeof(Buffer); + if SendMessageW(Handle, TCM_GETITEMW, Index, IntPtr(@TCItem)) <> 0 then + Result := TCItem.pszText + else + Result := ''; + +end; + +procedure TSysTabControlStyleHook.Paint(Canvas: TCanvas); +var + R: TRect; + i, SaveIndex: Integer; + Details: TThemedElementDetails; +begin + SaveIndex := SaveDC(Canvas.Handle); + try + R := DisplayRect; + ExcludeClipRect(Canvas.Handle, R.Left, R.Top, R.Right, R.Bottom); + PaintBackground(Canvas); + finally + RestoreDC(Canvas.Handle, SaveIndex); + end; + { Draw tabs } + for i := 0 to TabCount - 1 do + begin + // if I = TabIndex then + // Continue; + DrawTab(Canvas, i); + end; + case TabPosition of + tpTop: InflateRect(R, SysControl.Width - R.Right, SysControl.Height - R.Bottom); + tpLeft: InflateRect(R, SysControl.Width - R.Right, SysControl.Height - R.Bottom); + tpBottom: InflateRect(R, R.Left, R.Top); + tpRight: InflateRect(R, R.Left, R.Top); + end; + + if StyleServices.Available then + begin + Details := StyleServices.GetElementDetails(ttPane); + DrawStyleElement(Canvas.Handle, Details, R); + end; + { Draw active tab } + if TabIndex >= 0 then + DrawTab(Canvas, TabIndex); + +end; + +procedure TSysTabControlStyleHook.DrawTab(Canvas: TCanvas; const Index: Integer); +var + R, LayoutR, GlyphR: TRect; + ImageWidth, ImageHeight, ImageStep, TX, TY: Integer; + DrawState: TThemedTab; + Details: TThemedElementDetails; + ThemeTextColor: TColor; + FImageIndex: Integer; +begin + if (Images <> nil) and (Index < Images.Count) then + begin + ImageWidth := Images.Width; + ImageHeight := Images.Height; + ImageStep := 3; + end + else + begin + ImageWidth := 0; + ImageHeight := 0; + ImageStep := 0; + end; + + R := TabRect[Index]; + if R.Left < 0 then + Exit; + + if TabPosition in [tpTop, tpBottom] then + begin + if Index = TabIndex then + InflateRect(R, 0, 2); + end + else if Index = TabIndex then + dec(R.Left, 2) + else + dec(R.Right, 2); + + // Canvas.Font.Assign(TCustomTabControl(Control).Font); + LayoutR := R; + DrawState := ttTabDontCare; + case TabPosition of + tpTop: + begin + if Index = TabIndex then + DrawState := ttTabItemSelected + else if (Index = FHotTabIndex) and MouseInControl then + DrawState := ttTabItemHot + else + DrawState := ttTabItemNormal; + end; + tpLeft: + begin + if Index = TabIndex then + DrawState := ttTabItemLeftEdgeSelected + else if (Index = FHotTabIndex) and MouseInControl then + DrawState := ttTabItemLeftEdgeHot + else + DrawState := ttTabItemLeftEdgeNormal; + end; + tpBottom: + begin + if Index = TabIndex then + DrawState := ttTabItemBothEdgeSelected + else if (Index = FHotTabIndex) and MouseInControl then + DrawState := ttTabItemBothEdgeHot + else + DrawState := ttTabItemBothEdgeNormal; + end; + tpRight: + begin + if Index = TabIndex then + DrawState := ttTabItemRightEdgeSelected + else if (Index = FHotTabIndex) and MouseInControl then + DrawState := ttTabItemRightEdgeHot + else + DrawState := ttTabItemRightEdgeNormal; + end; + end; + + if StyleServices.Available then + begin + Details := StyleServices.GetElementDetails(DrawState); + DrawStyleElement(Canvas.Handle, Details, R); + end; + + { Image } + + FImageIndex := Index; + + if (Images <> nil) and (FImageIndex >= 0) and (FImageIndex < Images.Count) then + begin + GlyphR := LayoutR; + case TabPosition of + tpTop, tpBottom: + begin + GlyphR.Left := GlyphR.Left + ImageStep; + GlyphR.Right := GlyphR.Left + ImageWidth; + LayoutR.Left := GlyphR.Right; + GlyphR.Top := GlyphR.Top + (GlyphR.Bottom - GlyphR.Top) div 2 - ImageHeight div 2; + if (TabPosition = tpTop) and (Index = TabIndex) then + OffsetRect(GlyphR, 0, -1) + else if (TabPosition = tpBottom) and (Index = TabIndex) then + OffsetRect(GlyphR, 0, 1); + end; + tpLeft: + begin + GlyphR.Bottom := GlyphR.Bottom - ImageStep; + GlyphR.Top := GlyphR.Bottom - ImageHeight; + LayoutR.Bottom := GlyphR.Top; + GlyphR.Left := GlyphR.Left + (GlyphR.Right - GlyphR.Left) div 2 - ImageWidth div 2; + end; + tpRight: + begin + GlyphR.Top := GlyphR.Top + ImageStep; + GlyphR.Bottom := GlyphR.Top + ImageHeight; + LayoutR.Top := GlyphR.Bottom; + GlyphR.Left := GlyphR.Left + (GlyphR.Right - GlyphR.Left) div 2 - ImageWidth div 2; + end; + end; + if StyleServices.Available then + StyleServices.DrawIcon(Canvas.Handle, Details, GlyphR, Images.Handle, FImageIndex); + end; + + { Text } + if StyleServices.Available then + begin + if (TabPosition = tpTop) and (Index = TabIndex) then + OffsetRect(LayoutR, 0, -1) + else if (TabPosition = tpBottom) and (Index = TabIndex) then + OffsetRect(LayoutR, 0, 1); + + if TabPosition = tpLeft then + begin + TX := LayoutR.Left + (LayoutR.Right - LayoutR.Left) div 2 - Canvas.TextHeight(Tabs[Index]) div 2; + TY := LayoutR.Top + (LayoutR.Bottom - LayoutR.Top) div 2 + Canvas.TextWidth(Tabs[Index]) div 2; + if StyleServices.GetElementColor(Details, ecTextColor, ThemeTextColor) then + Canvas.Font.Color := ThemeTextColor; + AngleTextOut(Canvas, 900, TX, TY, Tabs[Index]); + end + else if TabPosition = tpRight then + begin + TX := LayoutR.Left + (LayoutR.Right - LayoutR.Left) div 2 + Canvas.TextHeight(Tabs[Index]) div 2; + TY := LayoutR.Top + (LayoutR.Bottom - LayoutR.Top) div 2 - Canvas.TextWidth(Tabs[Index]) div 2; + if StyleServices.GetElementColor(Details, ecTextColor, ThemeTextColor) then + Canvas.Font.Color := ThemeTextColor; + AngleTextOut(Canvas, -900, TX, TY, Tabs[Index]); + end + else + StyleServices.DrawText(Canvas.Handle, Details, Tabs[Index], LayoutR, [tfSingleLine, tfVerticalCenter, tfCenter, tfNoClip]); + // DrawControlText(Canvas, Details, Tabs[Index], LayoutR, + // DT_VCENTER or DT_CENTER or DT_SINGLELINE or DT_NOCLIP); + end; +end; + +procedure TSysTabControlStyleHook.PaintBackground(Canvas: TCanvas); +begin + inherited; +end; + +procedure TSysTabControlStyleHook.PaintNC(Canvas: TCanvas); +begin + inherited; +end; + +procedure TSysTabControlStyleHook.WndProc(var Message: TMessage); +begin + // Addlog(Format('TSysTabControlStyleHook $0x%x %s', [SysControl.Handle, WM_To_String(Message.Msg)])); + + // case Message.Msg of + // WM_MOUSEMOVE: + // begin + // + // end; + // else + // inherited; + // end; + inherited; +end; + +{ TSysToolbarStyleHook } + +{$REGION 'TSysToolbarStyleHook'} + +constructor TSysToolbarStyleHook.Create(AHandle: THandle); +begin + inherited; +{$IF CompilerVersion > 23} + StyleElements := [seClient, seFont]; +{$ELSE} + OverridePaint := True; + OverrideFont := True; +{$IFEND} + OverrideEraseBkgnd := False; + FImages := nil; + FDisabledImages := nil; + FSysToolbarButton := nil; + FButtonsPainted := False; +end; + +destructor TSysToolbarStyleHook.Destroy; +begin + if Assigned(FImages) then + FreeAndNil(FImages); + if Assigned(FDisabledImages) then + FreeAndNil(FDisabledImages); + if Assigned(FSysToolbarButton) then + FreeAndNil(FSysToolbarButton); + inherited; +end; + +function TSysToolbarStyleHook.GetItem(Index: Integer): TSysToolbarButton; +begin + Result := nil; + if (Index > -1) and (index <= Count) then + begin + if Assigned(FSysToolbarButton) then + FreeAndNil(FSysToolbarButton); + FSysToolbarButton := TSysToolbarButton.Create(SysControl, Index); + Result := FSysToolbarButton; + end; +end; + +function TSysToolbarStyleHook.GetShowText: Boolean; +begin + Result := (SysControl.Style and BTNS_SHOWTEXT = BTNS_SHOWTEXT); +end; + +function TSysToolbarStyleHook.IsToolbarFlat: Boolean; +begin + { MSDN : + In a flat toolbar, both the toolbar and the buttons are transparent + and hot-tracking is enabled. + } + Result := (SysControl.Style and TBSTYLE_FLAT = TBSTYLE_FLAT) +end; + +function TSysToolbarStyleHook.IsToolbarList: Boolean; +begin + Result := (SysControl.Style and TBSTYLE_LIST = TBSTYLE_LIST); +end; + +function TSysToolbarStyleHook.IsToolbarTransparent: Boolean; +begin + { MSDN: + In a transparent toolbar, the toolbar is transparent but the buttons are not. + } + Result := (SysControl.Style and TBSTYLE_TRANSPARENT = TBSTYLE_TRANSPARENT) +end; + +function TSysToolbarStyleHook.IsToolbarWrapable: Boolean; +begin + Result := (SysControl.Style and TBSTYLE_WRAPABLE = TBSTYLE_WRAPABLE) +end; + +function TSysToolbarStyleHook.GetCount: Integer; +begin + Result := SendMessage(Handle, TB_BUTTONCOUNT, 0, 0); +end; + +procedure TSysToolbarStyleHook.ApplyImageList; +var + H: LRESULT; +begin + H := SendMessage(Handle, TB_GETIMAGELIST, 0, 0); + if (H <> 0) and (FImages = nil) then + begin + FImages := TImageList.Create(nil); + FImages.ShareImages := True; + FImages.Handle := THandle(H); + end; + H := SendMessage(Handle, TB_GETDISABLEDIMAGELIST, 0, 0); + if (H <> 0) and (FDisabledImages = nil) then + begin + FDisabledImages := TImageList.Create(nil); + FDisabledImages.ShareImages := True; + FDisabledImages.Handle := THandle(H); + end; +end; + +procedure TSysToolbarStyleHook.Paint(Canvas: TCanvas); +var + i: Integer; + ItemRect, R, R2: TRect; + LDetails: TThemedElementDetails; + DC: HDC; + LButtonHot: Boolean; + P: TPoint; + LStyle: TSysToolbarButtonStyle; + LState: TSysToolbarButtonState; + Bmp: TBitmap; + ImgRect, TxtRect: TRect; + LText: String; + LImageIndex, LDropDownWidth: Integer; + TxtFlags: DWORD; + TxtFormat: TTextFormat; +begin + + Bmp := TBitmap.Create; + try + ApplyImageList; + if Assigned(FImages) then + begin + FImages.Masked := True; + FImages.BkColor := clNone; { Transparent bitmap } + end; + ImgRect := Rect(0, 0, 0, 0); + TxtRect := Rect(0, 0, 0, 0); + Bmp.SetSize(SysControl.Width, SysControl.Height); + R := Rect(0, 0, Bmp.Width, Bmp.Height); + // Bmp.Canvas.Brush.Color := StyleServices.GetStyleColor(scWindow); + // Bmp.Canvas.FillRect(R); + DC := Bmp.Canvas.Handle; + DrawParentBackground(DC); + + TxtFlags := 0; + if (SysControl.Style and TBSTYLE_NOPREFIX = TBSTYLE_NOPREFIX) then + TxtFlags := DT_NOPREFIX; + + if Flat or Transparent then + begin + { Dont paint the toolbar background => the toolbar is transparent . } + end + else + begin + { Toolbar is not transparent } + LDetails.Element := teToolBar; + LDetails.Part := 0; + LDetails.State := 0; + if StyleServices.HasTransparentParts(LDetails) then + StyleServices.DrawParentBackground(Handle, DC, LDetails, False); + DrawStyleElement(DC, LDetails, R); + end; + except + Bmp.Free; + Exit; + end; + + try + { Draw toolbar buttons } + for i := 0 to Count - 1 do + begin + if i = Count - 1 then + FButtonsPainted := True; + + ItemRect := Items[i].ItemRect; + with Items[i] do + begin + LState := State; + LStyle := Style; + LText := Text; + LImageIndex := ImageIndex; + LDropDownWidth := DropDownWidth; + end; + + LButtonHot := False; + if not(bsHidden in LState) then + begin + if MouseInControl then + begin + GetCursorPos(P); + ScreenToClient(Handle, P); + if ItemRect.Contains(P) then + LButtonHot := True; + end; + + if (bsEnabled in LState) then + LDetails := StyleServices.GetElementDetails(ttbButtonNormal) + else + LDetails := StyleServices.GetElementDetails(ttbButtonDisabled); + if (LButtonHot) and (bsEnabled in LState) then + begin + LDetails := StyleServices.GetElementDetails(ttbButtonHot); + end; + if (bsPressed in LState) and (bsEnabled in LState) then + LDetails := StyleServices.GetElementDetails(ttbButtonPressed); + + if bsChecked in LState then + LDetails := StyleServices.GetElementDetails(ttbButtonChecked); + + if not(bsSep in LStyle) then + begin + if Flat then + begin + // Bmp.Canvas.FillRect(ItemRect); + DrawParentBackground(DC, @ItemRect); + if (LButtonHot or (bsPressed in LState) or (bsChecked in LState)) and (bsEnabled in LState) then + begin + DrawStyleElement(DC, LDetails, ItemRect); + end; + end + else + DrawStyleElement(DC, LDetails, ItemRect); + end + else + begin + LDetails := StyleServices.GetElementDetails(ttbSeparatorNormal); + DrawStyleElement(DC, LDetails, ItemRect); + end; + + if not(bsSep in LStyle) then + begin + R := ItemRect; + ImgRect := TRect.Empty; + if Assigned(FImages) then + ImgRect := Rect(0, 0, FImages.Width, FImages.Height); + ImgRect := CenteredRect(R, ImgRect); + + if bsDropDown in LStyle then + begin + { If button is DropDown then draw the button glyph. } + R := ItemRect; + R := Rect(R.Right - LDropDownWidth, R.Top, R.Right, R.Bottom); + if bsEnabled in LState then + LDetails := StyleServices.GetElementDetails(ttbDropDownButtonGlyphNormal) + else + LDetails := StyleServices.GetElementDetails(ttbDropDownButtonGlyphDisabled); + if (LButtonHot and (bsEnabled in LState)) then + LDetails := StyleServices.GetElementDetails(ttbDropDownButtonGlyphHot); + if ((bsPressed in LState) and (bsEnabled in LState)) then + LDetails := StyleServices.GetElementDetails(ttbDropDownButtonGlyphPressed); + DrawStyleElement(DC, LDetails, R); + + { Adjust bitmap position } + + if Assigned(FImages) then + ImgRect := Rect(0, 0, FImages.Width, FImages.Height); + R := ItemRect; + R.Right := R.Right - LDropDownWidth; + ImgRect := CenteredRect(R, ImgRect); + inc(ImgRect.Left, 2); + end; + + { Adjust bitmap & Text positions } + if Wrapable then + begin + R := Rect(0, 0, 0, 0); + if (ShowText and not List) then + begin + Winapi.Windows.DrawText(DC, LText, -1, R, DT_CENTER or DT_CALCRECT); + end; + ImgRect.Offset(0, -R.Height); + end + else if List then + begin + R := Rect(0, 0, 0, 0); + if ShowText then + begin + Winapi.Windows.DrawText(DC, LText, -1, R, DT_CENTER or DT_CALCRECT or TxtFlags); + end; + ImgRect := Rect(0, 0, FImages.Width, FImages.Height); + R2 := ItemRect; + dec(R2.Right, R.Width + 2); + ImgRect := CenteredRect(R2, ImgRect); + end; + + { Draw Bitmap } + if (LImageIndex > -1) and (Assigned(FImages)) then + begin + if bsEnabled in LState then + FImages.DrawingStyle := Vcl.ImgList.TDrawingStyle.dsNormal + else + FImages.DrawingStyle := Vcl.ImgList.TDrawingStyle.dsSelected; + FImages.Draw(Bmp.Canvas, ImgRect.Left, ImgRect.Top, LImageIndex); + end; + + { Draw Text } + TxtRect := Rect(0, 0, 0, 0); + if ShowText then + begin + if not List then + begin + { Text appear under the button bitmap } + if (ImgRect.Width > 0) and (LImageIndex > -1) then + TxtRect := Rect(ItemRect.Left, ImgRect.Bottom, ItemRect.Right, ItemRect.Bottom) + else + TxtRect := ItemRect; + if LText <> '' then + DrawTextCentered(DC, LDetails, TxtRect, LText, TxtFlags); + end + else + begin + { List } + { Text appear to the right of the button bitmap } + if (ImgRect.Width > 0) and (LImageIndex > -1) then + TxtRect := Rect(ImgRect.Right + 2, ItemRect.Top, ItemRect.Right, ItemRect.Bottom) + else + TxtRect := ItemRect; + TxtFormat := [tfCenter, tfVerticalCenter, tfSingleLine, tfLeft]; + if TxtFlags <> 0 then + include(TxtFormat, tfNoPrefix); + if LText <> '' then + StyleServices.DrawText(DC, LDetails, LText, TxtRect, TxtFormat); + end; + end; + end; + end; + end; + Canvas.Draw(0, 0, Bmp); + finally + Bmp.Free; + end; +end; + +procedure TSysToolbarStyleHook.PaintBackground(Canvas: TCanvas); +begin + inherited; + +end; + +procedure TSysToolbarStyleHook.PaintNC(Canvas: TCanvas); +begin + inherited; +end; + +procedure TSysToolbarStyleHook.WndProc(var Message: TMessage); +begin + inherited; +end; +{$ENDREGION} +{$REGION 'TSysToolbarButton'} +{ TSysToolbarStyleHook.TSysToolbarButton } + +constructor TSysToolbarStyleHook.TSysToolbarButton.Create(SysParent: TSysControl; Index: Integer); +begin + FIndex := Index; + FParent := SysParent; + FText := ''; + FImageIndex := -1; + FState := []; + FStyle := []; + DoGetItemInfo; +end; + +destructor TSysToolbarStyleHook.TSysToolbarButton.Destroy; +begin + inherited; +end; + +Procedure TSysToolbarStyleHook.TSysToolbarButton.DoGetItemInfo; +const + BufferSize = 255; +var + TB: TTBButton; + Buffer: array [0 .. BufferSize - 1] of Char; + BtnInfo: TTBButtonInfo; +begin + FillChar(Buffer, BufferSize, Char(0)); + FillChar(TB, sizeof(TB), 0); + SendMessage(FParent.Handle, TB_GETBUTTON, FIndex, IntPtr(@TB)); + FillChar(BtnInfo, sizeof(BtnInfo), Char(0)); + BtnInfo.cbSize := sizeof(TTBButtonInfo); + BtnInfo.dwMask := TBIF_STATE or TBIF_STYLE or TBIF_IMAGE or TBIF_TEXT; + BtnInfo.cchText := BufferSize; + BtnInfo.pszText := @Buffer; + SendMessage(FParent.Handle, TB_GETBUTTONINFO, TB.idCommand, LParam(@BtnInfo)); + BtnInfo.fsStyle := TB.fsStyle; + SendMessage(FParent.Handle, TB_GETBUTTONTEXT, TB.idCommand, LParam(BtnInfo.pszText)); + FText := String(Buffer); + FImageIndex := BtnInfo.iImage; + with BtnInfo do + begin + { Button State } + if fsState and TBSTATE_ENABLED = TBSTATE_ENABLED then + include(FState, bsEnabled); + if fsState and TBSTATE_PRESSED = TBSTATE_PRESSED then + include(FState, bsPressed); + if fsState and TBSTATE_CHECKED = TBSTATE_CHECKED then + include(FState, bsChecked); + if fsState and TBSTATE_HIDDEN = TBSTATE_HIDDEN then + include(FState, bsHidden); + + { Button Style } + if fsStyle and TBSTYLE_BUTTON = TBSTYLE_BUTTON then + include(FStyle, bsBtn); + if fsStyle and TBSTYLE_SEP = TBSTYLE_SEP then + include(FStyle, bsSep); + if fsStyle and TBSTYLE_CHECK = TBSTYLE_CHECK then + include(FStyle, bsCheck); + if fsStyle and TBSTYLE_GROUP = TBSTYLE_GROUP then + include(FStyle, bsGroup); + if fsStyle and TBSTYLE_CHECKGROUP = TBSTYLE_CHECKGROUP then + include(FStyle, bsCheckGroup); + if (fsStyle and TBSTYLE_DROPDOWN = TBSTYLE_DROPDOWN) or (fsStyle and BTNS_WHOLEDROPDOWN = BTNS_WHOLEDROPDOWN) then + include(FStyle, bsDropDown); + + end; + +end; + +function TSysToolbarStyleHook.TSysToolbarButton.GetItemRect: TRect; +begin + Result := TRect.Empty; + if not BOOL(SendMessage(FParent.Handle, TB_GETITEMRECT, FIndex, LParam(@Result))) then + Result := TRect.Empty; +end; + +function TSysToolbarStyleHook.TSysToolbarButton.GetDropDownWidth: Integer; +var + R: TRect; +begin + if BOOL(SendMessage(FParent.Handle, TB_GETITEMDROPDOWNRECT, FIndex, LParam(@R))) then + Result := R.Right - R.Left + else + Result := 15; // default width when runtime themes are enabled +end; + +{$ENDREGION} +{ TSysProgressBarStyleHook } + +constructor TSysProgressBarStyleHook.Create(AHandle: THandle); +begin + inherited; + if (SysControl.Style And PBS_VERTICAL) <> 0 then + FOrientation := pbVertical + else + FOrientation := pbHorizontal; + // DoubleBuffered := True; + OverridePaint := True; + // OverrideEraseBkgnd :=True; + // FLastPos:=-1; + FStep := 0; + FTimer := TTimer.Create(nil); + FTimer.Interval := 100; + FTimer.Enabled := False; + // if ((SysControl.Style And PBS_MARQUEE) <> 0) then + begin + FTimer.OnTimer := TimerAction; + FTimer.Enabled := True; + end; +end; + +destructor TSysProgressBarStyleHook.Destroy; +begin + FTimer.Free; + inherited; +end; + +function TSysProgressBarStyleHook.GetBarRect: TRect; +begin + Result := TRect.Create(0, 0, SysControl.Width, SysControl.Height); + InflateRect(Result, -BorderWidth, -BorderWidth); +end; + +function TSysProgressBarStyleHook.GetBorderWidth: Integer; +begin + Result := 0; +end; + +function TSysProgressBarStyleHook.GetMax: Integer; +begin + Result := SendMessage(Handle, PBM_GetRange, 0, 0); +end; + +function TSysProgressBarStyleHook.GetMin: Integer; +begin + Result := SendMessage(Handle, PBM_GetRange, 1, 0); +end; + +function TSysProgressBarStyleHook.GetOrientation: TProgressBarOrientation; +begin + Result := pbHorizontal; + if (Handle <> 0) and (GetWindowLong(Handle, GWL_STYLE) and PBS_VERTICAL = PBS_VERTICAL) then + Result := pbVertical; +end; + +function TSysProgressBarStyleHook.GetPercent: Single; +var + LMin, LMax, LPos: Integer; +begin + LMin := Min; + LMax := Max; + LPos := Position; + if (LMin >= 0) and (LPos >= LMin) and (LMax >= LPos) and (LMax - LMin <> 0) then + Result := (LPos - LMin) / (LMax - LMin) + else + Result := 0; +end; + +function TSysProgressBarStyleHook.GetPosition: Integer; +begin + Result := SendMessage(Handle, PBM_GETPOS, 0, 0); +end; + +procedure TSysProgressBarStyleHook.Paint(Canvas: TCanvas); +var + LDetails: TThemedElementDetails; +begin + + // if ((SysControl.Style And PBS_MARQUEE) <> 0) or ((FLastPos=-1) or (Position 0) then + begin + InflateRect(LRect, -2, -2); + if Orientation = pbHorizontal then + LWidth := LRect.Width + else + LWidth := LRect.Height; + + LPos := Round(LWidth * 0.05); + FillR := LRect; + if Orientation = pbHorizontal then + begin + FillR.Right := FillR.Left + LPos; + LDetails := StyleServices.GetElementDetails(tpChunk); + end + else + begin + FillR.Top := FillR.Bottom - LPos; + LDetails := StyleServices.GetElementDetails(tpChunkVert); + end; + + FillR.SetLocation(FStep * FillR.Width, FillR.Top); + DrawStyleElement(Canvas.Handle, LDetails, FillR); + // Inc(FStep,1); + // if FStep mod 20=0 then + // FStep:=0; + end + else + begin + InflateRect(LRect, -2, -2); + if Orientation = pbHorizontal then + LWidth := LRect.Width + else + LWidth := LRect.Height; + LPos := Round(LWidth * GetPercent); + // FLastPos := GetPosition; + FillR := LRect; + if Orientation = pbHorizontal then + begin + FillR.Right := FillR.Left + LPos; + LDetails := StyleServices.GetElementDetails(tpChunk); + end + else + begin + FillR.Top := FillR.Bottom - LPos; + LDetails := StyleServices.GetElementDetails(tpChunkVert); + end; + DrawStyleElement(Canvas.Handle, LDetails, FillR); + end; +end; + +procedure TSysProgressBarStyleHook.PaintFrame(Canvas: TCanvas); +var + R: TRect; + Details: TThemedElementDetails; +begin + if not StyleServices.Available then + Exit; + R := BarRect; + if Orientation = pbHorizontal then + Details := StyleServices.GetElementDetails(tpBar) + else + Details := StyleServices.GetElementDetails(tpBarVert); + DrawStyleElement(Canvas.Handle, Details, R); +end; + +procedure TSysProgressBarStyleHook.TimerAction(Sender: TObject); +var + LCanvas: TCanvas; + LHandle: THandle; +begin + // if StyleServices.Available and ((SysControl.Style And PBS_MARQUEE) <> 0) then + // begin + LHandle := 0; + LCanvas := TCanvas.Create; + try + LHandle := GetWindowDC(Self.Handle); + + if LHandle<>0 then + begin + LCanvas.Handle := LHandle; + + if SysControl.Visible then + begin + PaintFrame(LCanvas); + PaintBar(LCanvas); + end; + end; + + inc(FStep, 1); + if FStep mod 20 = 0 then + FStep := 0; + + finally + if LHandle<>0 then + ReleaseDC(Handle, LHandle); + LCanvas.Handle := 0; + LCanvas.Free; + end; + + // end + // else + // FTimer.Enabled := False; +end; + +procedure TSysProgressBarStyleHook.WMNCCalcSize(var Message: TWMNCCalcSize); +begin + Message.Result := 0; + Handled := True; +end; + +procedure TSysProgressBarStyleHook.WndProc(var Message: TMessage); +begin + // Addlog(Format('TSysProgressBarStyleHook $0x%x %s', [SysControl.Handle, WM_To_String(Message.Msg)])); + // + case Message.Msg of + WM_TIMER:; // avoid flicker in progress bar and memory increased; + + else inherited; + end; + +end; + +{ TSysRichEditStyleHook } + +constructor TSysRichEditStyleHook.Create(AHandle: THandle); +begin + inherited; + +{$IF CompilerVersion > 23} + StyleElements := [seBorder]; +{$ELSE} + OverridePaintNC := True; + OverrideFont := False; +{$IFEND} +end; + +procedure TSysRichEditStyleHook.EMSetBkgndColor(var Message: TMessage); +begin + Message.LParam := Color; + Handled := False; +end; + +function TSysRichEditStyleHook.GetBorderSize: TRect; +begin + if SysControl.HasBorder then + Result := Rect(2, 2, 2, 2) + else + Result := Rect(0, 0, 0, 0); +end; + +procedure TSysRichEditStyleHook.UpdateColors; +var + cf: TCharFormat2; +const + TextColor: array [Boolean] of TStyleFont = (sfEditBoxTextDisabled, sfEditBoxTextNormal); + BkColor: array [Boolean] of TStyleColor = (scEditDisabled, scEdit); +begin + Color := ColorToRGB(StyleServices.GetStyleColor(scEdit)); + FontColor := ColorToRGB(StyleServices.GetStyleFontColor(TextColor[SysControl.Enabled])); + BackColor := ColorToRGB(StyleServices.GetStyleColor(BkColor[SysControl.Enabled])); + + ZeroMemory(@cf, sizeof(TCharFormat2)); + cf.cbSize := sizeof(TCharFormat2); + cf.dwMask := CFM_ALL; + { Need to send this message .. } + SendMessage(Handle, EM_SETBKGNDCOLOR, 0, 0); + SendMessage(Handle, EM_GETCHARFORMAT, SCF_DEFAULT, LParam(@cf)); + SendMessage(Handle, EM_SETCHARFORMAT, SCF_DEFAULT, LParam(@cf)); +end; + +procedure TSysRichEditStyleHook.EMSetCharFormat(var Message: TMessage); +type + PCharFormat2 = ^TCharFormat2; +var + Format: PCharFormat2; +begin + Format := PCharFormat2(Message.LParam); + Format.crTextColor := FontColor; + Format.crBackColor := BackColor; + Format.dwEffects := Format.dwEffects and not CFE_AUTOCOLOR; + Handled := False; +end; + +procedure TSysRichEditStyleHook.WndProc(var Message: TMessage); +begin + inherited; +end; + +{ TSysReBarStyleHook } + +constructor TSysReBarStyleHook.Create(AHandle: THandle); +begin + inherited; + OverrideEraseBkgnd := True; + OverridePaint := True; + OverridePaintNC := True; +end; + +function TSysReBarStyleHook.GetBandBorder(const Index: Integer): TRect; +begin + SendMessage(Handle, RB_GETBANDBORDERS, Index, IntPtr(@Result)); +end; + +function TSysReBarStyleHook.GetBandCount: Integer; +begin + Result := SendMessage(Handle, RB_GETBANDCOUNT, 0, 0); +end; + +function TSysReBarStyleHook.GetBandRect(const Index: Integer): TRect; +begin + Result := Rect(0, 0, 0, 0); + SendMessage(Handle, RB_GETRECT, Index, IntPtr(@Result)); +end; + +function SizeOfReBarBandInfo: Integer; +var + ReBarBandInfo: TReBarBandInfo; +begin + ZeroMemory(@ReBarBandInfo, sizeof(ReBarBandInfo)); + if GetComCtlVersion >= $60001 then + Result := sizeof(TReBarBandInfo) + else + // Platforms prior to Vista do not support the fields rcChevronLocation & uChevronState + Result := sizeof(ReBarBandInfo) - sizeof(ReBarBandInfo.rcChevronLocation) - sizeof(ReBarBandInfo.uChevronState); +end; + +function TSysReBarStyleHook.GetBandText(const Index: Integer): string; +const + BufSize = 255; +var + Info: TReBarBandInfo; + Buffer: array [0 .. BufSize - 1] of Char; +begin + FillChar(Info, sizeof(Info), 0); + Info.cbSize := SizeOfReBarBandInfo; + // Size differs depending on OS and ComCtl32.dll version + Info.fMask := RBBIM_TEXT; + Info.lpText := @Buffer; + Info.cch := BufSize; + if BOOL(SendMessage(Handle, RB_GETBANDINFO, Index, IntPtr(@Info))) then + Result := Info.lpText + else + Result := ''; +end; + +procedure TSysReBarStyleHook.Paint(Canvas: TCanvas); +var + i: Integer; + R, Margin, LTextRect: TRect; + S: string; + Details: TThemedElementDetails; +begin + for i := 0 to GetBandCount - 1 do + begin + R := GetBandRect(i); + Margin := GetBandBorder(i); + InflateRect(R, 1, 1); + if R.Top < 0 then + R.Top := 0; + if R.Left < 0 then + R.Left := 0; + if R.Right > SysControl.ClientRect.Right then + R.Right := SysControl.ClientRect.Right; + if R.Bottom > SysControl.ClientRect.Bottom then + R.Bottom := SysControl.ClientRect.Bottom; + { band } + Details := StyleServices.GetElementDetails(trBand); + DrawStyleElement(Canvas.Handle, Details, R); + { text } + LTextRect := Rect(R.Left + 10, R.Top, R.Left + Margin.Left, R.Bottom); + + S := GetBandText(i); + if S <> '' then + DrawControlText(Canvas, Details, S, LTextRect, DT_CENTER or DT_VCENTER or DT_SINGLELINE); + + { gripper } + R := Rect(R.Left + 2, R.Top + 2, R.Left + 6, R.Bottom - 2); + Details := StyleServices.GetElementDetails(trGripper); + DrawStyleElement(Canvas.Handle, Details, R); + end; +end; + +procedure TSysReBarStyleHook.PaintBackground(Canvas: TCanvas); +var + LRect: TRect; + LDetails: TThemedElementDetails; +begin + LRect := Rect(0, 0, SysControl.ClientWidth, SysControl.ClientHeight); + InflateRect(LRect, 2, 2); + LDetails.Element := teToolBar; + LDetails.Part := 0; + if StyleServices.HasTransparentParts(LDetails) then + StyleServices.DrawParentBackground(Handle, Canvas.Handle, LDetails, False); + DrawStyleElement(Canvas.Handle, LDetails, LRect); +end; + +procedure TSysReBarStyleHook.PaintNC(Canvas: TCanvas); +var + LDetails: TThemedElementDetails; +begin + ExcludeClipRect(Canvas.Handle, 2, 2, SysControl.Width - 2, SysControl.Height - 2); + Canvas.Brush.Color := StyleServices.ColorToRGB(clBtnFace); + Canvas.FillRect(Rect(0, 0, SysControl.Width, SysControl.Height)); + LDetails.Element := teToolBar; + LDetails.Part := 0; + DrawStyleElement(Canvas.Handle, LDetails, Rect(0, 0, SysControl.Width, SysControl.Height)); +end; + +procedure TSysReBarStyleHook.WndProc(var Message: TMessage); +begin + case Message.Msg of + WM_SIZE: + begin + CallDefaultProc(Message); + Invalidate; + Handled := True; + end; + else inherited; + end; +end; + +{ TSysStatusBarStyleHook } + +constructor TSysStatusBarStyleHook.Create(AHandle: THandle); +begin + inherited; + OverridePaint := True; + // DoubleBuffered := True; +end; + +procedure TSysStatusBarStyleHook.Paint(Canvas: TCanvas); +const + AlignStyles: array [TAlignment] of Integer = (DT_LEFT, DT_RIGHT, DT_CENTER); +var + R, R1: TRect; + Res, Count, i: Integer; + Idx, Flags: Cardinal; + Details: TThemedElementDetails; + LText: string; + Borders: array [0 .. 2] of Integer; +begin + Details := StyleServices.GetElementDetails(tsStatusRoot); + DrawStyleElement(Canvas.Handle, Details, Rect(0, 0, SysControl.Width, SysControl.Height)); + + if SendMessage(Handle, SB_ISSIMPLE, 0, 0) > 0 then + begin + R := SysControl.ClientRect; + FillChar(Borders, sizeof(Borders), 0); + SendMessage(Handle, SB_GETBORDERS, 0, IntPtr(@Borders)); + R.Left := Borders[0] + Borders[2]; + R.Top := Borders[1]; + R.Bottom := R.Bottom - Borders[1]; + R.Right := R.Right - Borders[2]; + + Details := StyleServices.GetElementDetails(tsPane); + DrawStyleElement(Canvas.Handle, Details, R); + + R1 := SysControl.ClientRect; + R1.Left := R1.Right - R.Height; + Details := StyleServices.GetElementDetails(tsGripper); + DrawStyleElement(Canvas.Handle, Details, R1); + Details := StyleServices.GetElementDetails(tsPane); + SetLength(LText, Word(SendMessage(Handle, SB_GETTEXTLENGTH, 0, 0))); + if Length(LText) > 0 then + begin + SendMessage(Handle, SB_GETTEXT, 0, IntPtr(@LText[1])); + Flags := SysControl.DrawTextBiDiModeFlags(DT_LEFT); + DrawControlText(Canvas, Details, LText, R, Flags); + end; + end + else + begin + Count := SendMessage(Handle, SB_GETPARTS, 0, 0); + for i := 0 to Count - 1 do + begin + R := Rect(0, 0, 0, 0); + SendMessage(Handle, SB_GETRECT, i, IntPtr(@R)); + if IsRectEmpty(R) then + Exit; + Details := StyleServices.GetElementDetails(tsPane); + DrawStyleElement(Canvas.Handle, Details, R); + if i = Count - 1 then + begin + R1 := SysControl.ClientRect; + R1.Left := R1.Right - R.Height; + Details := StyleServices.GetElementDetails(tsGripper); + DrawStyleElement(Canvas.Handle, Details, R1); + end; + Details := StyleServices.GetElementDetails(tsPane); + InflateRect(R, -1, -1); + + Flags := SysControl.DrawTextBiDiModeFlags(DT_LEFT); + Idx := i; + SetLength(LText, Word(SendMessage(Handle, SB_GETTEXTLENGTH, Idx, 0))); + if Length(LText) > 0 then + begin + Res := SendMessage(Handle, SB_GETTEXT, Idx, IntPtr(@LText[1])); + if (Res and SBT_OWNERDRAW = 0) then + DrawControlText(Canvas, Details, LText, R, Flags); + end; + end; + end; +end; + +procedure TSysStatusBarStyleHook.WndProc(var Message: TMessage); +begin + inherited; +end; + +{ TSysTrackBarStyleHook } + +constructor TSysTrackBarStyleHook.Create(AHandle: THandle); +begin + inherited; + OverridePaint := True; + // OverrideEraseBkgnd :=True; + DoubleBuffered := True; + FThumbPressed := False; +end; + +procedure TSysTrackBarStyleHook.Paint(Canvas: TCanvas); +var + LDetails: TThemedElementDetails; + TrackBarStyle: Cardinal; + LThemedTrackBar: TThemedTrackBar; + i, TickCount, TickStart, TickEnd, TickPos: Integer; + LRect: TRect; + LRect2: TRect; + LThumbRect: TRect; +begin + if not StyleServices.Available then + Exit; + + LThemedTrackBar := ttbTrackBarDontCare; + { Track } + TrackBarStyle := GetWindowLong(Handle, GWL_STYLE); + SendMessage(Handle, TBM_GETCHANNELRECT, 0, IntPtr(@LRect)); + if TrackBarStyle and TBS_VERT = 0 then + begin + LDetails := StyleServices.GetElementDetails(ttbTrack); + DrawStyleElement(Canvas.Handle, LDetails, LRect); + end + else + begin + LRect2 := LRect; + LRect.Left := LRect2.Top; + LRect.Top := LRect2.Left; + LRect.Right := LRect2.Bottom; + LRect.Bottom := LRect2.Right; + LDetails := StyleServices.GetElementDetails(ttbTrackVert); + DrawStyleElement(Canvas.Handle, LDetails, LRect); + end; + + SendMessage(Handle, TBM_GETCHANNELRECT, 0, IntPtr(@LRect)); + SendMessage(Handle, TBM_GETTHUMBRECT, 0, IntPtr(@LThumbRect)); + + // Ticks + if TrackBarStyle and TBS_NOTICKS = 0 then + begin + TickCount := SendMessage(Handle, TBM_GETNUMTICS, 0, 0); + + Canvas.Pen.Color := StyleServices.ColorToRGB(clBtnText); + + // First + if TrackBarStyle and TBS_VERT = 0 then + begin + TickPos := LRect.Left + LThumbRect.Width div 2; + if (TrackBarStyle and TBS_TOP = TBS_TOP) or (TrackBarStyle and TBS_BOTH = TBS_BOTH) then + begin + Canvas.MoveTo(TickPos, LRect.Top - 7); + Canvas.LineTo(TickPos, LRect.Top - 3); + end; + if (TrackBarStyle and TBS_TOP = 0) or (TrackBarStyle and TBS_BOTH = TBS_BOTH) then + begin + Canvas.MoveTo(TickPos, LRect.Bottom + 3); + Canvas.LineTo(TickPos, LRect.Bottom + 7); + end; + TickStart := TickPos; + end + else + begin + TickPos := LRect.Left + LThumbRect.Height div 2; + if (TrackBarStyle and TBS_TOP = TBS_TOP) or (TrackBarStyle and TBS_BOTH = TBS_BOTH) then + begin + Canvas.MoveTo(LRect.Top - 7, TickPos); + Canvas.LineTo(LRect.Top - 3, TickPos); + end; + if (TrackBarStyle and TBS_TOP = 0) or (TrackBarStyle and TBS_BOTH = TBS_BOTH) then + begin + Canvas.MoveTo(LRect.Bottom + 3, TickPos); + Canvas.LineTo(LRect.Bottom + 7, TickPos); + end; + TickStart := TickPos; + end; + // last + if TrackBarStyle and TBS_VERT = 0 then + begin + TickPos := LRect.Right - LThumbRect.Width div 2; + if (TrackBarStyle and TBS_TOP = TBS_TOP) or (TrackBarStyle and TBS_BOTH = TBS_BOTH) then + begin + Canvas.MoveTo(TickPos, LRect.Top - 7); + Canvas.LineTo(TickPos, LRect.Top - 3); + end; + if (TrackBarStyle and TBS_TOP = 0) or (TrackBarStyle and TBS_BOTH = TBS_BOTH) then + begin + Canvas.MoveTo(TickPos, LRect.Bottom + 3); + Canvas.LineTo(TickPos, LRect.Bottom + 7); + end; + TickEnd := TickPos; + end + else + begin + TickPos := LRect.Right - LThumbRect.Height div 2; + if (TrackBarStyle and TBS_TOP = TBS_TOP) or (TrackBarStyle and TBS_BOTH = TBS_BOTH) then + begin + Canvas.MoveTo(LRect.Top - 7, TickPos); + Canvas.LineTo(LRect.Top - 3, TickPos); + end; + if (TrackBarStyle and TBS_TOP = 0) or (TrackBarStyle and TBS_BOTH = TBS_BOTH) then + begin + Canvas.MoveTo(LRect.Bottom + 3, TickPos); + Canvas.LineTo(LRect.Bottom + 7, TickPos); + end; + TickEnd := TickPos; + end; + // ticks + for i := 1 to TickCount - 1 do + begin + TickPos := TickStart + Round((TickEnd - TickStart) * (i / (TickCount - 1))); + if TrackBarStyle and TBS_VERT = 0 then + begin + if (TrackBarStyle and TBS_TOP = TBS_TOP) or (TrackBarStyle and TBS_BOTH = TBS_BOTH) then + begin + Canvas.MoveTo(TickPos, LRect.Top - 6); + Canvas.LineTo(TickPos, LRect.Top - 3); + end; + if (TrackBarStyle and TBS_TOP = 0) or (TrackBarStyle and TBS_BOTH = TBS_BOTH) then + begin + Canvas.MoveTo(TickPos, LRect.Bottom + 3); + Canvas.LineTo(TickPos, LRect.Bottom + 6); + end; + end + else + begin + if (TrackBarStyle and TBS_TOP = TBS_TOP) or (TrackBarStyle and TBS_BOTH = TBS_BOTH) then + begin + Canvas.MoveTo(LRect.Top - 6, TickPos); + Canvas.LineTo(LRect.Top - 3, TickPos); + end; + if (TrackBarStyle and TBS_TOP = 0) or (TrackBarStyle and TBS_BOTH = TBS_BOTH) then + begin + Canvas.MoveTo(LRect.Bottom + 3, TickPos); + Canvas.LineTo(LRect.Bottom + 6, TickPos); + end; + end; + end; + end; + + // Thumb + if TrackBarStyle and TBS_NOTHUMB = 0 then + begin + SendMessage(Handle, TBM_GETTHUMBRECT, 0, IntPtr(@LRect)); + if not SysControl.Enabled then + begin + if TrackBarStyle and TBS_VERT = 0 then + begin + if TrackBarStyle and TBS_BOTH = TBS_BOTH then + LThemedTrackBar := ttbThumbDisabled + else if TrackBarStyle and TBS_TOP = TBS_TOP then + LThemedTrackBar := ttbThumbTopDisabled + else if TrackBarStyle and TBS_BOTTOM = TBS_BOTTOM then + LThemedTrackBar := ttbThumbBottomDisabled; + end + else + begin + LThemedTrackBar := ttbThumbRightDisabled; + if TrackBarStyle and TBS_TOP = TBS_TOP then + LThemedTrackBar := ttbThumbLeftDisabled + else if TrackBarStyle and TBS_BOTH = TBS_BOTH then + LThemedTrackBar := ttbThumbVertDisabled; + end; + end + else if FThumbPressed then + begin + if TrackBarStyle and TBS_VERT = 0 then + begin + if TrackBarStyle and TBS_BOTH = TBS_BOTH then + LThemedTrackBar := ttbThumbPressed + else if TrackBarStyle and TBS_TOP = TBS_TOP then + LThemedTrackBar := ttbThumbTopPressed + else if TrackBarStyle and TBS_BOTTOM = TBS_BOTTOM then + LThemedTrackBar := ttbThumbBottomPressed; + end + else + begin + LThemedTrackBar := ttbThumbRightPressed; + if TrackBarStyle and TBS_TOP = TBS_TOP then + LThemedTrackBar := ttbThumbLeftPressed + else if TrackBarStyle and TBS_BOTH = TBS_BOTH then + LThemedTrackBar := ttbThumbVertPressed; + end; + end + else if FMouseOnThumb then + begin + if TrackBarStyle and TBS_VERT = 0 then + begin + if TrackBarStyle and TBS_BOTH = TBS_BOTH then + LThemedTrackBar := ttbThumbHot + else if TrackBarStyle and TBS_TOP = TBS_TOP then + LThemedTrackBar := ttbThumbTopHot + else if TrackBarStyle and TBS_BOTTOM = TBS_BOTTOM then + LThemedTrackBar := ttbThumbBottomHot; + end + else + begin + LThemedTrackBar := ttbThumbRightHot; + if TrackBarStyle and TBS_TOP = TBS_TOP then + LThemedTrackBar := ttbThumbLeftHot + else if TrackBarStyle and TBS_BOTH = TBS_BOTH then + LThemedTrackBar := ttbThumbVertHot; + end; + end + else + begin + if TrackBarStyle and TBS_VERT = 0 then + begin + if TrackBarStyle and TBS_BOTH = TBS_BOTH then + LThemedTrackBar := ttbThumbNormal + else if TrackBarStyle and TBS_TOP = TBS_TOP then + LThemedTrackBar := ttbThumbTopNormal + else if TrackBarStyle and TBS_BOTTOM = TBS_BOTTOM then + LThemedTrackBar := ttbThumbBottomNormal; + end + else + begin + LThemedTrackBar := ttbThumbRightNormal; + if TrackBarStyle and TBS_TOP = TBS_TOP then + LThemedTrackBar := ttbThumbLeftNormal + else if TrackBarStyle and TBS_BOTH = TBS_BOTH then + LThemedTrackBar := ttbThumbVertNormal; + end; + end; + + LDetails := StyleServices.GetElementDetails(LThemedTrackBar); + DrawStyleElement(Canvas.Handle, LDetails, LRect); + end; + + if Focused then + Canvas.DrawFocusRect(Rect(0, 0, SysControl.Width, SysControl.Height)); +end; + +procedure TSysTrackBarStyleHook.PaintBackground(Canvas: TCanvas); +var + LDetails: TThemedElementDetails; +begin + LDetails.Element := teTrackBar; + StyleServices.DrawParentBackground(Handle, Canvas.Handle, LDetails, False); +end; + +procedure TSysTrackBarStyleHook.WndProc(var Message: TMessage); +var + LRect: TRect; + NewValue: Boolean; +begin + // Addlog(Format('TSysTrackBarStyleHook $0x%x %s', [SysControl.Handle, WM_To_String(Message.Msg)])); + + case Message.Msg of + // WM_KEYUP, + WM_VSCROLL, WM_HSCROLL, TBM_SETPOS: + begin + Invalidate; + // CallDefaultProc(Message); + end; + + WM_MOUSEMOVE: + if GetWindowLong(Handle, GWL_STYLE) and TBS_NOTHUMB = 0 then + begin + SendMessage(Handle, TBM_GETTHUMBRECT, 0, IntPtr(@LRect)); + NewValue := PtInRect(LRect, Point(TWMMouse(Message).XPos, TWMMouse(Message).YPos)); + if NewValue <> FMouseOnThumb then + begin + FMouseOnThumb := NewValue; + Invalidate; + end; + end; + WM_LBUTTONUP: + if GetWindowLong(Handle, GWL_STYLE) and TBS_NOTHUMB = 0 then + begin + FThumbPressed := False; + Invalidate; + end; + WM_LBUTTONDOWN: + if GetWindowLong(Handle, GWL_STYLE) and TBS_NOTHUMB = 0 then + begin + SendMessage(Handle, TBM_GETTHUMBRECT, 0, IntPtr(@LRect)); + if PtInRect(LRect, Point(TWMMouse(Message).XPos, TWMMouse(Message).YPos)) then + FThumbPressed := True; + Invalidate; + end; + + else inherited; + end; +end; + +{ TSysUpDownStyleHook } + +constructor TSysUpDownStyleHook.Create(AHandle: THandle); +begin + inherited; + OverridePaint := True; + DoubleBuffered := True; +end; + +destructor TSysUpDownStyleHook.Destroy; +begin + inherited; +end; + +function TSysUpDownStyleHook.GetOrientation: TUDOrientation; +begin + if SysControl.Style and UDS_HORZ = UDS_HORZ then + Result := udHorizontal + else + Result := udVertical; +end; + +procedure TSysUpDownStyleHook.MouseLeave; +begin + FMouseOnLeft := False; + FMouseOnRight := False; + Invalidate; +end; + +procedure TSysUpDownStyleHook.Paint(Canvas: TCanvas); +var + R: TRect; + DrawState: TThemedScrollBar; + Details: TThemedElementDetails; +begin + if not StyleServices.Available then + Exit; + + StyleServices.DrawParentBackground(Handle, Canvas.Handle, Details, False); + + if GetOrientation = udHorizontal then + begin + R := SysControl.ClientRect; + R.Right := R.Left + R.Width div 2; + if FLeftPressed then + DrawState := tsArrowBtnLeftPressed + else if FMouseOnLeft and MouseInControl then + DrawState := tsArrowBtnLeftHot + else + DrawState := tsArrowBtnLeftNormal; + + Details := StyleServices.GetElementDetails(DrawState); + DrawStyleElement(Canvas.Handle, Details, R); + + R := SysControl.ClientRect; + R.Left := R.Right - R.Width div 2; + if FRightPressed then + DrawState := tsArrowBtnRightPressed + else if FMouseOnRight and MouseInControl then + DrawState := tsArrowBtnRightHot + else + DrawState := tsArrowBtnRightNormal; + + Details := StyleServices.GetElementDetails(DrawState); + DrawStyleElement(Canvas.Handle, Details, R); + end + else + begin + R := SysControl.ClientRect; + R.Bottom := R.Top + R.Height div 2; + if FLeftPressed then + DrawState := tsArrowBtnUpPressed + else if FMouseOnLeft and MouseInControl then + DrawState := tsArrowBtnUpHot + else + DrawState := tsArrowBtnUpNormal; + + Details := StyleServices.GetElementDetails(DrawState); + DrawStyleElement(Canvas.Handle, Details, R); + + R := SysControl.ClientRect; + R.Top := R.Bottom - R.Height div 2; + + if FRightPressed then + DrawState := tsArrowBtnDownPressed + else if FMouseOnRight and MouseInControl then + DrawState := tsArrowBtnDownHot + else + DrawState := tsArrowBtnDownNormal; + + Details := StyleServices.GetElementDetails(DrawState); + DrawStyleElement(Canvas.Handle, Details, R); + end; +end; + +procedure TSysUpDownStyleHook.WMLButtonDblClk(var Message: TWMMouse); +var + R: TRect; +begin + SetRedraw(False); + CallDefaultProc(TMessage(Message)); + SetRedraw(True); + if GetOrientation = udHorizontal then + begin + R := SysControl.ClientRect; + R.Right := R.Left + R.Width div 2; + if R.Contains(Point(Message.XPos, Message.YPos)) then + FLeftPressed := True + else + FLeftPressed := False; + + R := SysControl.ClientRect; + R.Left := R.Right - R.Width div 2; + if R.Contains(Point(Message.XPos, Message.YPos)) then + FRightPressed := True + else + FRightPressed := False; + end + else + begin + R := SysControl.ClientRect; + R.Bottom := R.Top + R.Height div 2; + if R.Contains(Point(Message.XPos, Message.YPos)) then + FLeftPressed := True + else + FLeftPressed := False; + + R := SysControl.ClientRect; + R.Top := R.Bottom - R.Height div 2; + if R.Contains(Point(Message.XPos, Message.YPos)) then + FRightPressed := True + else + FRightPressed := False; + end; + Invalidate; + Handled := True; +end; + +procedure TSysUpDownStyleHook.WMLButtonDown(var Message: TWMMouse); +var + R: TRect; +begin + SetRedraw(False); + CallDefaultProc(TMessage(Message)); + SetRedraw(True); + + if GetOrientation = udHorizontal then + begin + R := SysControl.ClientRect; + R.Right := R.Left + R.Width div 2; + if R.Contains(Point(Message.XPos, Message.YPos)) then + FLeftPressed := True + else + FLeftPressed := False; + + R := SysControl.ClientRect; + R.Left := R.Right - R.Width div 2; + if R.Contains(Point(Message.XPos, Message.YPos)) then + FRightPressed := True + else + FRightPressed := False; + end + else + begin + R := SysControl.ClientRect; + R.Bottom := R.Top + R.Height div 2; + if R.Contains(Point(Message.XPos, Message.YPos)) then + FLeftPressed := True + else + FLeftPressed := False; + + R := SysControl.ClientRect; + R.Top := R.Bottom - R.Height div 2; + if R.Contains(Point(Message.XPos, Message.YPos)) then + FRightPressed := True + else + FRightPressed := False; + end; + + Invalidate; + Handled := True; +end; + +procedure TSysUpDownStyleHook.WMLButtonUp(var Message: TWMMouse); +begin + SetRedraw(False); + CallDefaultProc(TMessage(Message)); + SetRedraw(True); + FLeftPressed := False; + FRightPressed := False; + Invalidate; + Handled := True; +end; + +procedure TSysUpDownStyleHook.WMMouseMove(var Message: TWMMouse); +var + R: TRect; + FOldMouseOnLeft, FOldMouseOnRight: Boolean; +begin + inherited; + CallDefaultProc(TMessage(Message)); + + FOldMouseOnLeft := FMouseOnLeft; + FOldMouseOnRight := FMouseOnRight; + + if GetOrientation = udHorizontal then + begin + R := SysControl.ClientRect; + R.Right := R.Left + R.Width div 2; + if R.Contains(Point(Message.XPos, Message.YPos)) then + FMouseOnLeft := True + else + FMouseOnLeft := False; + + R := SysControl.ClientRect; + R.Left := R.Right - R.Width div 2; + if R.Contains(Point(Message.XPos, Message.YPos)) then + FMouseOnRight := True + else + FMouseOnRight := False; + end + else + begin + R := SysControl.ClientRect; + R.Bottom := R.Top + R.Height div 2; + if R.Contains(Point(Message.XPos, Message.YPos)) then + FMouseOnLeft := True + else + FMouseOnLeft := False; + + R := SysControl.ClientRect; + R.Top := R.Bottom - R.Height div 2; + if R.Contains(Point(Message.XPos, Message.YPos)) then + FMouseOnRight := True + else + FMouseOnRight := False; + end; + + if (FOldMouseOnLeft <> FMouseOnLeft) and (FOldMouseOnRight <> FMouseOnRight) then + Invalidate; + + Handled := True; +end; + +procedure TSysUpDownStyleHook.WndProc(var Message: TMessage); +begin + inherited; +end; + + + +{ TSysLinkStyleHook } +{ +Debug Output: TSysLinkStyleHook WM_WINDOWPOSCHANGING Process ThemedSysControls.exe (1800) +Debug Output: TSysLinkStyleHook WM_NCCALCSIZE Process ThemedSysControls.exe (1800) +Debug Output: TSysLinkStyleHook WM_CHILDACTIVATE Process ThemedSysControls.exe (1800) +Debug Output: TSysLinkStyleHook WM_WINDOWPOSCHANGED Process ThemedSysControls.exe (1800) +Debug Output: TSysLinkStyleHook Unknown(067C) Process ThemedSysControls.exe (1800) +} +constructor TSysLinkStyleHook.Create(AHandle: THandle); +var + Style: DWORD; +begin + Style := GetWindowLongPtr(AHandle, GWL_STYLE); + if (Style and SS_ICON <> SS_ICON) and (Style and SS_BITMAP <> SS_BITMAP) then + + inherited; + +{$IF CompilerVersion > 23} + StyleElements := [seFont, seBorder, seClient]; +{$ELSE} + OverridePaint := True; + OverridePaintNC := True; + OverrideFont := True; +{$IFEND} + UpdateColors; +end; + +destructor TSysLinkStyleHook.Destroy; +begin + + inherited; +end; + +procedure TSysLinkStyleHook.Paint(Canvas: TCanvas); +const + States: array [Boolean] of TThemedTextLabel = (ttlTextLabelDisabled, + ttlTextLabelNormal); +var + LDetails: TThemedElementDetails; + LRect: TRect; + s: string; +begin + LRect := SysControl.ClientRect; + if GetBkMode(Canvas.Handle) = TRANSPARENT then + begin + LDetails := StyleServices.GetElementDetails(tbCheckBoxUncheckedNormal); + StyleServices.DrawParentBackground(Handle, Canvas.Handle, LDetails, False); + Canvas.Brush.Style := bsClear; + end + else + begin + Canvas.Brush.Color := StyleServices.GetStyleColor(scWindow); + Canvas.FillRect(LRect); + end; + + LDetails := StyleServices.GetElementDetails(States[SysControl.Enabled]); + Canvas.Font := SysControl.Font; + s:=SysControl.Text; + //OutputDebugString(PChar('Text '+s)); + DrawText(Canvas.Handle, LDetails, s, LRect, TextFormat); +end; + + +procedure TSysLinkStyleHook.PaintNC(Canvas: TCanvas); +var + LRect: TRect; + LBitMap: TBitmap; +begin + if IsFrameOrLine then + begin + LRect := Rect(0, 0, SysControl.Width, SysControl.Height); + LBitMap := TBitmap.Create; + try + LBitMap.Width := LRect.Width; + LBitMap.Height := LRect.Height; + Frame3D(LBitMap.Canvas, LRect, StyleServices.ColorToRGB(clBtnShadow), + StyleServices.ColorToRGB(clBtnHighLight), 1); + ExcludeClipRect(Canvas.Handle, 1, 1, SysControl.Width - 1, + SysControl.Height - 1); + Canvas.Draw(0, 0, LBitMap); + finally + LBitMap.Free; + end; + end; +end; + +procedure TSysLinkStyleHook.WMNCCalcSize(var Message: TWMNCCalcSize); +begin + +end; + +procedure TSysLinkStyleHook.WndProc(var Message: TMessage); +begin + //OutputDebugString(PChar('TSysLinkStyleHook '+WM_To_String(Message.Msg)+' Handle '+IntToHex(SysControl.Handle, 8))); + + case Message.Msg of + +// $067C : +// begin +// CallDefaultProc(Message); +// if SysControl.Visible then +// Invalidate; +// end; + + WM_SETTEXT: + begin + CallDefaultProc(Message); + if SysControl.Visible then + Invalidate; + end; + + WM_ENABLE: + if SysControl.Visible then + Invalidate; + + WM_PAINT: + begin + if OverridePaint and StyleServicesEnabled then + begin + if (IsText and (Length(SysControl.Text) > 0)) then + inherited + else + CallDefaultProc(Message); + end + else + CallDefaultProc(Message); + end; + + else + inherited; + end; +end; + +initialization + +if StyleServices.Available then +begin + with TSysStyleManager do + begin + RegisterSysStyleHook(TOOLBARCLASSNAME, TSysToolbarStyleHook); + RegisterSysStyleHook(WC_LISTVIEW, TSysListViewStyleHook); + RegisterSysStyleHook(WC_TABCONTROL, TSysTabControlStyleHook); + RegisterSysStyleHook(WC_TREEVIEW, TSysTreeViewStyleHook); + {$IFNDEF USE_Vcl.Styles.Hooks} + RegisterSysStyleHook(PROGRESS_CLASS, TSysProgressBarStyleHook); + {$ENDIF} + RegisterSysStyleHook('RichEdit20A', TSysRichEditStyleHook); + RegisterSysStyleHook('RichEdit20W', TSysRichEditStyleHook); + RegisterSysStyleHook('RichEdit30A', TSysRichEditStyleHook); + RegisterSysStyleHook('RichEdit30W', TSysRichEditStyleHook); + RegisterSysStyleHook('RichEdit41A', TSysRichEditStyleHook); + RegisterSysStyleHook('RichEdit41W', TSysRichEditStyleHook); + RegisterSysStyleHook('RichEdit50A', TSysRichEditStyleHook); + RegisterSysStyleHook('RichEdit50W', TSysRichEditStyleHook); + RegisterSysStyleHook(REBARCLASSNAME, TSysReBarStyleHook); + RegisterSysStyleHook(STATUSCLASSNAME, TSysStatusBarStyleHook); + RegisterSysStyleHook(TRACKBAR_CLASS, TSysTrackBarStyleHook); + RegisterSysStyleHook(UPDOWN_CLASS, TSysUpDownStyleHook); + end; +end; + +finalization + +with TSysStyleManager do +begin + UnRegisterSysStyleHook(TOOLBARCLASSNAME, TSysToolbarStyleHook); + UnRegisterSysStyleHook(WC_LISTVIEW, TSysListViewStyleHook); + UnRegisterSysStyleHook(WC_TABCONTROL, TSysTabControlStyleHook); + UnRegisterSysStyleHook(WC_TREEVIEW, TSysTreeViewStyleHook); + {$IFNDEF USE_Vcl.Styles.Hooks} + UnRegisterSysStyleHook(PROGRESS_CLASS, TSysProgressBarStyleHook); + {$ENDIF} + + UnRegisterSysStyleHook('RichEdit20A', TSysRichEditStyleHook); + UnRegisterSysStyleHook('RichEdit20W', TSysRichEditStyleHook); + UnRegisterSysStyleHook('RichEdit30A', TSysRichEditStyleHook); + UnRegisterSysStyleHook('RichEdit30W', TSysRichEditStyleHook); + UnRegisterSysStyleHook('RichEdit41A', TSysRichEditStyleHook); + UnRegisterSysStyleHook('RichEdit41W', TSysRichEditStyleHook); + UnRegisterSysStyleHook('RichEdit50A', TSysRichEditStyleHook); + UnRegisterSysStyleHook('RichEdit50W', TSysRichEditStyleHook); + UnRegisterSysStyleHook(REBARCLASSNAME, TSysReBarStyleHook); + UnRegisterSysStyleHook(STATUSCLASSNAME, TSysStatusBarStyleHook); + UnRegisterSysStyleHook(TRACKBAR_CLASS, TSysTrackBarStyleHook); + UnRegisterSysStyleHook(UPDOWN_CLASS, TSysUpDownStyleHook); +end; + +end. diff --git a/source/vcl-styles-utils/Vcl.Styles.Utils.Forms.pas b/source/vcl-styles-utils/Vcl.Styles.Utils.Forms.pas index 13f62f0f0..511ebf2a7 100644 --- a/source/vcl-styles-utils/Vcl.Styles.Utils.Forms.pas +++ b/source/vcl-styles-utils/Vcl.Styles.Utils.Forms.pas @@ -1,2694 +1,2827 @@ -// ************************************************************************************************** -// -// Unit Vcl.Styles.Utils.Forms -// unit for the VCL Styles Utils -// https://github.com/RRUZ/vcl-styles-utils/ -// -// 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. -// -// -// Portions created by Mahdi Safsafi [SMP3] e-mail SMP@LIVE.FR -// Portions created by Rodrigo Ruz V. are Copyright (C) 2013-2019 Rodrigo Ruz V. -// All Rights Reserved. -// -// ************************************************************************************************** -unit Vcl.Styles.Utils.Forms; - - -{$I VCL.Styles.Utils.inc} - -interface - -uses - System.Classes, - System.Types, - System.SysUtils, - Winapi.Windows, - Winapi.Messages, - Vcl.Styles, - Vcl.Themes, - Vcl.Dialogs, - Vcl.Graphics, - Vcl.Styles.Utils.SysStyleHook, - {$IFDEF USE_Vcl.Styles.Hooks} - Vcl.Styles.Hooks, - {$ENDIF} - Vcl.Forms, - Vcl.GraphUtil, - Vcl.ExtCtrls, - Vcl.Controls; - -type - TSysScrollingType = (skNone, skTracking, skLineUp, skLineDown, skLineLeft, skLineRight, skPageUp, skPageDown, skPageLeft, skPageRight); - - TSysScrollingStyleHook = class(TMouseTrackSysControlStyleHook) - private - FVertScrollBar: Boolean; - FHorzScrollBar: Boolean; - FTrackTimer: TTimer; - FPrevPoint: TPoint; - FPrevPos: Integer; - FDownDis: Integer; - FDownPoint: TPoint; - FTrackingPos: Integer; - FTrackingRect: TRect; - FTracking: Boolean; - FScrollingType: TSysScrollingType; - FScrollKind: TScrollBarKind; - FBtnUpDetail: TThemedScrollBar; - FBtnDownDetail: TThemedScrollBar; - FVertBtnSliderDetail: TThemedScrollBar; - FBtnLeftDetail: TThemedScrollBar; - FBtnRightDetail: TThemedScrollBar; - FHorzBtnSliderDetail: TThemedScrollBar; - FNCMouseDown: Boolean; - FAllowScrolling: Boolean; - FLstPos: Integer; - function GetDefaultScrollBarSize: TSize; - procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST; - procedure WMNCCalcSize(var Message: TWMNCCalcSize); message WM_NCCALCSIZE; - procedure WMNCLButtonDown(var Message: TWMNCLButtonDown); message WM_NCLBUTTONDOWN; - procedure WMNCLButtonUp(var Message: TWMNCLButtonUp); message WM_NCLBUTTONUP; - procedure CMSCROLLTRACKING(var Message: TMessage); message CM_SCROLLTRACKING; - function GetVertScrollRect: TRect; - function GetVertUpRect: TRect; - function GetVertDownRect: TRect; - function GetVertSliderRect: TRect; - function GetVertSliderPos: Integer; - function GetVertThumbSize: Integer; - function GetVertTrackRect: TRect; - function GetVertScrollInfo: TScrollInfo; - function GetVertThumbPosFromPos(const Pos: Integer): Integer; - function GetVertScrollPosFromPoint(const P: TPoint): Integer; - function GetHorzThumbPosFromPos(const Pos: Integer): Integer; - function GetHorzScrollPosFromPoint(const P: TPoint): Integer; - function GetHorzSliderPos: Integer; - function GetHorzThumbSize: Integer; - function GetHorzLeftRect: TRect; - function GetHorzScrollInfo: TScrollInfo; - function GetHorzSliderRect: TRect; - function GetHorzTrackRect: TRect; - function GetHorzRightRect: TRect; - function GetHorzScrollRect: TRect; - function IsLeftScrollBar: Boolean; - function IsHorzScrollDisabled: Boolean; - function IsVertScrollDisabled: Boolean; - protected - property LstPos : Integer read FLstPos write FLstPos; - property AllowScrolling : Boolean read FAllowScrolling write FAllowScrolling; - function NormalizePoint(const P: TPoint): TPoint; - procedure Scroll(const Kind: TScrollBarKind; const ScrollType: TSysScrollingType; Pos, Delta: Integer); virtual; - procedure DoScroll(const Kind: TScrollBarKind; const ScrollType: TSysScrollingType; Pos, Delta: Integer); - procedure DrawHorzScroll(DC: HDC); virtual; - procedure DrawVertScroll(DC: HDC); virtual; - procedure DrawSmallRect(DC: HDC; const SmallRect: TRect); virtual; - procedure MouseEnter; override; - procedure MouseLeave; override; - procedure StartSliderTrackTimer; - procedure StopSliderTrackTimer; - procedure DoSliderTrackTimer(Sender: TObject); - procedure StartPageTrackTimer; - procedure StopPageTrackTimer; - procedure DoPageTrackTimer(Sender: TObject); - procedure StartLineTrackTimer; - procedure StopLineTrackTimer; - procedure DoLineTrackTimer(Sender: TObject); - procedure InitScrollState; - procedure PaintNC(Canvas: TCanvas); override; - procedure WndProc(var Message: TMessage); override; - public - constructor Create(AHandle: THandle); override; - Destructor Destroy; override; - property VertScrollRect: TRect read GetVertScrollRect; - property VertUpRect: TRect read GetVertUpRect; - property VertDownRect: TRect read GetVertDownRect; - property VertSliderRect: TRect read GetVertSliderRect; - property VertTrackRect: TRect read GetVertTrackRect; - property VertScrollInfo: TScrollInfo read GetVertScrollInfo; - property HorzScrollRect: TRect read GetHorzScrollRect; - property HorzLeftRect: TRect read GetHorzLeftRect; - property HorzRightRect: TRect read GetHorzRightRect; - property HorzSliderRect: TRect read GetHorzSliderRect; - property HorzTrackRect: TRect read GetHorzTrackRect; - property HorzScrollInfo: TScrollInfo read GetHorzScrollInfo; - property BtnSize: TSize read GetDefaultScrollBarSize; - property Tracking: Boolean read FTracking; - property TrackingRect: TRect read FTrackingRect; - property TrackingPos: Integer read FTrackingPos; - property LeftScrollBar: Boolean read IsLeftScrollBar; - property VertScrollDisabled: Boolean read IsVertScrollDisabled; - property HorzScrollDisabled: Boolean read IsHorzScrollDisabled; - end; - - TSysDialogStyleHook = class(TSysScrollingStyleHook) - private - FFrameActive: Boolean; - FPressedButton: Integer; - FHotButton: Integer; - FIcon: TIcon; - FIconHandle: HICON; - FCaptionRect: TRect; - FSysMenuButtonRect: TRect; - FRegion: HRGN; - // FUpdateRegion: Boolean; - FSysCloseButtonDisabled: Boolean; - procedure WMPaint(var Message: TMessage); message WM_PAINT; - procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST; - procedure WMNCLButtonDown(var Message: TWMNCLButtonDown); message WM_NCLBUTTONDOWN; - procedure WMNCLButtonUp(var Message: TWMNCLButtonUp); message WM_NCLBUTTONUP; - procedure WMNCMouseMove(var Message: TWMNCHitMessage); message WM_NCMOUSEMOVE; - procedure WMNCACTIVATE(var Message: TWMNCActivate); message WM_NCACTIVATE; - procedure WMNCCalcSize(var Message: TWMNCCalcSize); message WM_NCCALCSIZE; - procedure WMSIZE(var Message: TWMSize); message WM_SIZE; - procedure WMSetText(var Message: TMessage); message WM_SETTEXT; - function GetCaptionRect: TRect; - function GetBorderStyle: TFormBorderStyle; - function GetBorderIcons: TBorderIcons; - function GetCloseButtonRect: TRect; - function GetMaxButtonRect: TRect; - function GetMinButtonRect: TRect; - function GetHelpButtonRect: TRect; - function GetSysMenuButtonRect: TRect; - function GetWindowState: TWindowState; - function UseSmallBorder: Boolean; - function GetRegion: HRGN; - function GetIcon: TIcon; - function GetIconFast: TIcon; - function NormalizePoint(const P: TPoint): TPoint; - function GetHitTest(const P: TPoint): Integer; - function IsSysCloseButtonDisabled: Boolean; - function GetSysMenu: HMENU; - function GetUpdateRegion: Boolean; - protected - procedure DrawBorder(Canvas: TCanvas); override; - function GetBorderSize: TRect; override; - procedure PaintBackground(Canvas: TCanvas); override; - procedure Paint(Canvas: TCanvas); override; - procedure PaintNC(Canvas: TCanvas); override; - procedure WndProc(var Message: TMessage); override; - procedure Close; virtual; - procedure Help; virtual; - procedure Maximize; virtual; - procedure Minimize; virtual; - procedure Restore; virtual; - property PressedButton: Integer read FPressedButton write FPressedButton; - property HotButton: Integer read FHotButton write FHotButton; - public - constructor Create(AHandle: THandle); override; - Destructor Destroy; override; - property CaptionRect: TRect read GetCaptionRect; - property UpdateRegion: Boolean read GetUpdateRegion; - property BorderStyle: TFormBorderStyle read GetBorderStyle; - property BorderSize: TRect read GetBorderSize; - property BorderIcons: TBorderIcons read GetBorderIcons; - Property WindowState: TWindowState read GetWindowState; - Property CloseButtonRect: TRect read GetCloseButtonRect; - Property MaxButtonRect: TRect read GetMaxButtonRect; - Property MinButtonRect: TRect read GetMinButtonRect; - Property HelpButtonRect: TRect read GetHelpButtonRect; - property SysMenuButtonRect: TRect read GetSysMenuButtonRect; - property Icon: TIcon read GetIconFast; - property SysMenu: HMENU read GetSysMenu; - property SysCloseButtonDisabled: Boolean read FSysCloseButtonDisabled; - end; - - { - Note: The development of this class is not finished yet . - Only ScrollBar with SIZEBOX is supported !!. - } - TSysScrollBarStyleHook = class(TSysStyleHook) - protected - procedure WndProc(var Message: TMessage); override; - public - constructor Create(AHandle: THandle); override; - Destructor Destroy; override; - end; - -implementation - -uses - Vcl.Styles.Utils.Misc, - Vcl.Styles.Utils.SysControls; - -// ----------------------------------------------------------------------------------- -procedure FillDC(const DC: HDC; const R: TRect; const Color: TColor); -var - Brush: HBRUSH; -begin - Brush := CreateSolidBrush(Color); - FillRect(DC, R, Brush); - DeleteObject(Brush); -end; - -function IsItemDisabled(const Menu: HMENU; const Index: Integer): Boolean; -var - Info: TMenuItemInfo; -begin - Result := False; - if (Menu = 0) or (Index < 0) then - Exit; - - FillChar(Info, sizeof(Info), Char(0)); - Info.cbSize := sizeof(TMenuItemInfo); - Info.fMask := MIIM_STATE; - GetMenuItemInfo(Menu, Index, True, Info); - Result := (Info.fState and MFS_DISABLED = MFS_DISABLED) or (Info.fState and MF_DISABLED = MF_DISABLED) or (Info.fState and MF_GRAYED = MF_GRAYED); -end; - -function GetMenuItemPos(const Menu: HMENU; const ID: Integer): Integer; -var - i: Integer; - mii: MENUITEMINFO; -begin - Result := -1; - if Menu = 0 then - Exit; - for i := 0 to GetMenuItemCount(Menu) do - begin - FillChar(mii, sizeof(mii), Char(0)); - mii.cbSize := sizeof(mii); - mii.fMask := MIIM_ID; - if (GetMenuItemInfo(Menu, i, True, mii)) then - if mii.wID = Cardinal(ID) then - Exit(i); - end; -end; - -function IsWindowMsgBox(Handle: HWND): Boolean; -begin - Result := ((FindWindowEx(Handle, 0, 'Edit', nil) = 0) and (GetDlgItem(Handle, $FFFF) <> 0)) and (GetWindowLongPtr(Handle, GWL_USERDATA) <> 0); -end; - -// ----------------------------------------------------------------------------------------- -{ TSysDialogStyleHook } - -procedure TSysDialogStyleHook.Close; -begin - if (Handle <> 0) and not(FSysCloseButtonDisabled) then - SendMessage(Handle, WM_SYSCOMMAND, SC_CLOSE, 0); -end; - -constructor TSysDialogStyleHook.Create(AHandle: THandle); -begin - inherited; - FRegion := 0; -{$IF CompilerVersion > 23} - StyleElements := [seFont, seClient, seBorder]; -{$ELSE} - OverridePaint := True; - OverridePaintNC := True; - OverrideFont := True; -{$IFEND} - OverrideEraseBkgnd := True; - FPressedButton := 0; - FHotButton := 0; - FIconHandle := 0; - FIcon := nil; - FSysMenuButtonRect := Rect(0, 0, 0, 0); -end; - -destructor TSysDialogStyleHook.Destroy; -begin - if FRegion <> 0 then - DeleteObject(FRegion); - if Assigned(FIcon) then - FreeAndNil(FIcon); - inherited; -end; - -procedure TSysDialogStyleHook.DrawBorder(Canvas: TCanvas); -begin - // -end; - -function TSysDialogStyleHook.GetCaptionRect: TRect; -var - LDetails: TThemedElementDetails; - ElementSize: TSize; - CaptionHeight: Integer; -begin - Result := Rect(0, 0, SysControl.Width, 0); - if BorderStyle = bsNone then - Exit; - - if FFrameActive then - begin - if not UseSmallBorder then - LDetails := StyleServices.GetElementDetails(twCaptionActive) - else - LDetails := StyleServices.GetElementDetails(twSmallCaptionActive); - end - else - begin - if not UseSmallBorder then - LDetails := StyleServices.GetElementDetails(twCaptionInActive) - else - LDetails := StyleServices.GetElementDetails(twSmallCaptionInActive); - end; - StyleServices.GetElementSize(0, LDetails, esActual, ElementSize); - CaptionHeight := ElementSize.Height; - Result := Rect(0, 0, SysControl.Width, CaptionHeight); - -end; - -function TSysDialogStyleHook.GetCloseButtonRect: TRect; -var - FButtonState: TThemedWindow; - LDetails: TThemedElementDetails; -begin - Result := Rect(0, 0, 0, 0); - if (biSystemMenu in BorderIcons) then - begin - if not UseSmallBorder then - begin - if (FPressedButton = HTCLOSE) and (FHotButton = HTCLOSE) then - FButtonState := twCloseButtonPushed - else if FHotButton = HTCLOSE then - FButtonState := twCloseButtonHot - else if FFrameActive then - FButtonState := twCloseButtonNormal - else - FButtonState := twCloseButtonDisabled; - end - else - begin - if (FPressedButton = HTCLOSE) and (FHotButton = HTCLOSE) then - FButtonState := twSmallCloseButtonPushed - else if FHotButton = HTCLOSE then - FButtonState := twSmallCloseButtonHot - else if FFrameActive then - FButtonState := twSmallCloseButtonNormal - else - FButtonState := twSmallCloseButtonDisabled; - end; - LDetails := StyleServices.GetElementDetails(FButtonState); - if not StyleServices.GetElementContentRect(0, LDetails, CaptionRect, Result) then - Result := Rect(0, 0, 0, 0); - end; -end; - -function TSysDialogStyleHook.GetHelpButtonRect: TRect; -var - FButtonState: TThemedWindow; - LDetails: TThemedElementDetails; -begin - Result := Rect(0, 0, 0, 0); - if (biHelp in BorderIcons) and (biSystemMenu in BorderIcons) and ((not(biMaximize in BorderIcons) and not(biMinimize in BorderIcons)) or (BorderStyle = bsDialog)) then - begin - if (FPressedButton = HTHELP) and (FHotButton = HTHELP) then - FButtonState := twHelpButtonPushed - else if FHotButton = HTHELP then - FButtonState := twHelpButtonHot - else if FFrameActive then - FButtonState := twHelpButtonNormal - else - FButtonState := twHelpButtonDisabled; - LDetails := StyleServices.GetElementDetails(FButtonState); - - if not StyleServices.GetElementContentRect(0, LDetails, CaptionRect, Result) then - Result := Rect(0, 0, 0, 0); - end; -end; - -function TSysDialogStyleHook.GetHitTest(const P: TPoint): Integer; -begin - Result := HTCAPTION; - if CloseButtonRect.Contains(P) then - Result := HTCLOSE; - if MaxButtonRect.Contains(P) then - Result := HTMAXBUTTON; - if MinButtonRect.Contains(P) then - Result := HTMINBUTTON; - if HelpButtonRect.Contains(P) then - Result := HTHELP; - - if Result <> HTCAPTION then - begin - if FHotButton <> Result then - begin - FHotButton := Result; - InvalidateNC; - end; - Exit; - end - else - begin - if FHotButton <> 0 then - begin - FHotButton := 0; - InvalidateNC; - end; - end; -end; - -function TSysDialogStyleHook.GetMaxButtonRect: TRect; -var - FButtonState: TThemedWindow; - LDetails: TThemedElementDetails; -begin - Result := Rect(0, 0, 0, 0); - if (biMaximize in BorderIcons) and (biSystemMenu in BorderIcons) and (BorderStyle <> bsDialog) and (BorderStyle <> bsToolWindow) and (BorderStyle <> bsSizeToolWin) then - begin - if WindowState = wsMaximized then - begin - if (FPressedButton = HTMAXBUTTON) and (FHotButton = HTMAXBUTTON) then - FButtonState := twRestoreButtonPushed - else if FHotButton = HTMAXBUTTON then - FButtonState := twRestoreButtonHot - else if FFrameActive then - FButtonState := twRestoreButtonNormal - else - FButtonState := twRestoreButtonDisabled; - end - else - begin - if (FPressedButton = HTMAXBUTTON) and (FHotButton = HTMAXBUTTON) then - FButtonState := twMaxButtonPushed - else if FHotButton = HTMAXBUTTON then - FButtonState := twMaxButtonHot - else if FFrameActive then - FButtonState := twMaxButtonNormal - else - FButtonState := twMaxButtonDisabled; - end; - LDetails := StyleServices.GetElementDetails(FButtonState); - - if not StyleServices.GetElementContentRect(0, LDetails, CaptionRect, Result) then - Result := Rect(0, 0, 0, 0); - end; -end; - -function TSysDialogStyleHook.GetMinButtonRect: TRect; -var - FButtonState: TThemedWindow; - LDetails: TThemedElementDetails; -begin - Result := Rect(0, 0, 0, 0); - if (biMinimize in BorderIcons) and (biSystemMenu in BorderIcons) and (BorderStyle <> bsDialog) and (BorderStyle <> bsToolWindow) and (BorderStyle <> bsSizeToolWin) then - begin - if (FPressedButton = HTMINBUTTON) and (FHotButton = HTMINBUTTON) then - FButtonState := twMinButtonPushed - else if FHotButton = HTMINBUTTON then - FButtonState := twMinButtonHot - else if FFrameActive then - FButtonState := twMinButtonNormal - else - FButtonState := twMinButtonDisabled; - - LDetails := StyleServices.GetElementDetails(FButtonState); - - if not StyleServices.GetElementContentRect(0, LDetails, CaptionRect, Result) then - Result := Rect(0, 0, 0, 0); - end; - -end; - -function TSysDialogStyleHook.GetWindowState: TWindowState; -begin - Result := wsNormal; - if IsZoomed(Handle) then - Result := wsMaximized; - if IsIconic(Handle) then - Result := wsMinimized; -end; - -procedure TSysDialogStyleHook.Help; -begin - SendMessage(Handle, WM_SYSCOMMAND, SC_CONTEXTHELP, 0) -end; - -function TSysDialogStyleHook.IsSysCloseButtonDisabled: Boolean; -var - i, ID: Integer; -begin - Result := True; - if SysMenu > 0 then - begin - for i := 0 to GetMenuItemCount(SysMenu) - 1 do - begin - ID := GetMenuItemID(SysMenu, i); - if ID = SC_CLOSE then - begin - Result := False; - Exit; - end; - end; - end; -end; - -procedure TSysDialogStyleHook.Maximize; -begin - if Handle <> 0 then - begin - FPressedButton := 0; - FHotButton := 0; - - if IsZoomed(Handle) then - SendMessage(Handle, WM_SYSCOMMAND, SC_RESTORE, 0) - else - SendMessage(Handle, WM_SYSCOMMAND, SC_MAXIMIZE, 0); - end; -end; - -procedure TSysDialogStyleHook.Minimize; -begin - if Handle <> 0 then - begin - FPressedButton := 0; - FHotButton := 0; - if IsIconic(Handle) then - SendMessage(Handle, WM_SYSCOMMAND, SC_RESTORE, 0) - else - SendMessage(Handle, WM_SYSCOMMAND, SC_MINIMIZE, 0); - end; -end; - -procedure TSysDialogStyleHook.Paint(Canvas: TCanvas); -begin - inherited; - PaintBackground(Canvas); -end; - -procedure TSysDialogStyleHook.PaintBackground(Canvas: TCanvas); -begin - inherited; -end; - -function TSysDialogStyleHook.GetBorderIcons: TBorderIcons; -begin - Result := []; - with SysControl do - begin - if (Style and WS_SYSMENU = WS_SYSMENU) then - Include(Result, biSystemMenu); - if (Style and WS_MAXIMIZEBOX = WS_MAXIMIZEBOX) then - Include(Result, biMaximize); - if (Style and WS_MINIMIZEBOX = WS_MINIMIZEBOX) then - Include(Result, biMinimize); - if (ExStyle and WS_EX_CONTEXTHELP = WS_EX_CONTEXTHELP) and (not(biMaximize in Result)) and (not(biMinimize in Result)) then - Include(Result, biHelp); - end; -end; - -function TSysDialogStyleHook.GetBorderSize: TRect; -var - Size: TSize; - Details: TThemedElementDetails; - Detail: TThemedWindow; -begin - { - Result.Left = Left border width - Result.Top = Caption height - Result.Right = Right border width - Result.Bottom = Bottom border height - } - Result := Rect(0, 0, 0, 0); - if BorderStyle = bsNone then - Exit; - - if not StyleServices.Available then - Exit; - { Caption height } - if not UseSmallBorder then - Detail := twCaptionActive - else - Detail := twSmallCaptionActive; - Details := StyleServices.GetElementDetails(Detail); - StyleServices.GetElementSize(0, Details, esActual, Size); - Result.Top := Size.cy; - { Left border width } - if not UseSmallBorder then - Detail := twFrameLeftActive - else - Detail := twSmallFrameLeftActive; - Details := StyleServices.GetElementDetails(Detail); - StyleServices.GetElementSize(0, Details, esActual, Size); - Result.Left := Size.cx; - { Right border width } - if not UseSmallBorder then - Detail := twFrameRightActive - else - Detail := twSmallFrameRightActive; - Details := StyleServices.GetElementDetails(Detail); - StyleServices.GetElementSize(0, Details, esActual, Size); - Result.Right := Size.cx; - { Bottom border height } - if not UseSmallBorder then - Detail := twFrameBottomActive - else - Detail := twSmallFrameBottomActive; - Details := StyleServices.GetElementDetails(Detail); - StyleServices.GetElementSize(0, Details, esActual, Size); - Result.Bottom := Size.cy; -end; - -function TSysDialogStyleHook.GetBorderStyle: TFormBorderStyle; -begin - Result := bsNone; - if not UpdateRegion then - Exit(bsNone); - with SysControl do - begin - if (Style and WS_OVERLAPPED = WS_OVERLAPPED) or (Style and WS_OVERLAPPEDWINDOW = WS_OVERLAPPEDWINDOW) or (Style and WS_CAPTION = WS_CAPTION) or - (ExStyle and WS_EX_OVERLAPPEDWINDOW = WS_EX_OVERLAPPEDWINDOW) and (ExStyle and WS_EX_TOOLWINDOW <> WS_EX_TOOLWINDOW) then - begin - if (Style and WS_SIZEBOX <> WS_SIZEBOX) and ((Style and WS_MINIMIZEBOX = WS_MAXIMIZE) or (Style and WS_MINIMIZEBOX = WS_MINIMIZEBOX)) then - Result := bsSingle; - - if (Style and WS_SIZEBOX <> WS_SIZEBOX) and (Style and WS_MINIMIZEBOX <> WS_MAXIMIZE) and (Style and WS_MINIMIZEBOX <> WS_MINIMIZEBOX) then - Result := bsDialog; - - if (Style and WS_SIZEBOX = WS_SIZEBOX) then - Result := bsSizeable; - end - else if (ExStyle and WS_EX_TOOLWINDOW = WS_EX_TOOLWINDOW) then - begin - if (Style and WS_SIZEBOX = WS_SIZEBOX) then - Result := bsSizeToolWin - else - Result := bsToolWindow; - end - else - Result := bsNone; - end; -end; - -function TSysDialogStyleHook.UseSmallBorder: Boolean; -begin - Result := (BorderStyle = bsToolWindow) or (BorderStyle = bsSizeToolWin); -end; - -function TSysDialogStyleHook.GetRegion: HRGN; -var - R: TRect; - LDetails: TThemedElementDetails; - Detail: TThemedWindow; -begin - Result := 0; - if not StyleServices.Available then - Exit; - { Get Window Region } - R := Rect(0, 0, SysControl.Width, SysControl.Height); - if not UseSmallBorder then - Detail := twCaptionActive - else - Detail := twSmallCaptionActive; - - DeleteObject(FRegion); - LDetails := StyleServices.GetElementDetails(Detail); - if not StyleServices.GetElementRegion(LDetails, R, Result) then - FRegion := 0; -end; - -function TSysDialogStyleHook.GetSysMenu: HMENU; -begin - Result := GetSystemMenu(Handle, False); -end; - -function TSysDialogStyleHook.GetSysMenuButtonRect: TRect; -var - LBorderIcons: TBorderIcons; - LBorderStyle: TBorderStyle; - IconDetails: TThemedElementDetails; - ButtonRect, R: TRect; -begin - Result := Rect(0, 0, 0, 0); - LBorderStyle := BorderStyle; - LBorderIcons := BorderIcons; - if (biSystemMenu in LBorderIcons) and (LBorderStyle <> bsDialog) and (LBorderStyle <> bsToolWindow) and (LBorderStyle <> bsSizeToolWin) then - begin - IconDetails := StyleServices.GetElementDetails(twSysButtonNormal); - if not StyleServices.GetElementContentRect(0, IconDetails, CaptionRect, ButtonRect) then - ButtonRect := Rect(0, 0, 0, 0); - //R := ButtonRect; - R := Rect(0, 0, GetSystemMetrics(SM_CXSMICON), GetSystemMetrics(SM_CYSMICON)); - RectVCenter(R, ButtonRect); - Result := ButtonRect; - end; - -end; - -function TSysDialogStyleHook.GetUpdateRegion: Boolean; -begin - with SysControl do - Result := not((Style and WS_CAPTION <> WS_CAPTION) and (Style and WS_SYSMENU <> WS_SYSMENU) and (Style and WS_SIZEBOX <> WS_SIZEBOX)); -end; - -function TSysDialogStyleHook.GetIconFast: TIcon; -begin - if (FIcon = nil) or (FIconHandle = 0) then - Result := GetIcon - else - Result := FIcon; -end; - -function TSysDialogStyleHook.GetIcon: TIcon; -var - IconX, IconY: Integer; - TmpHandle: THandle; - Info: TWndClassEx; - Buffer: array [0 .. 255] of Char; -begin - TmpHandle := THandle(SendMessage(Handle, WM_GETICON, ICON_SMALL, 0)); - if TmpHandle = 0 then - TmpHandle := THandle(SendMessage(Handle, WM_GETICON, ICON_BIG, 0)); - - if TmpHandle = 0 then - TmpHandle := THandle(SendMessage(Handle, WM_GETICON, ICON_SMALL2, 0)); - - if TmpHandle = 0 then - begin - { Get instance } - GetClassName(Handle, @Buffer, sizeof(Buffer)); - FillChar(Info, sizeof(Info), 0); - Info.cbSize := sizeof(Info); - - if GetClassInfoEx(GetWindowLong(Handle, GWL_HINSTANCE), @Buffer, Info) then - begin - TmpHandle := Info.hIconSm; - if TmpHandle = 0 then - TmpHandle := Info.HICON; - end - end; - - if FIcon = nil then - FIcon := TIcon.Create; - if TmpHandle <> 0 then - begin - IconX := GetSystemMetrics(SM_CXSMICON); - if IconX = 0 then - IconX := GetSystemMetrics(SM_CXSIZE); - IconY := GetSystemMetrics(SM_CYSMICON); - if IconY = 0 then - IconY := GetSystemMetrics(SM_CYSIZE); - FIcon.Handle := CopyImage(TmpHandle, IMAGE_ICON, IconX, IconY, 0); - FIconHandle := TmpHandle; - end; - - Result := FIcon; -end; - -procedure TSysDialogStyleHook.PaintNC(Canvas: TCanvas); -var - LDetails: TThemedElementDetails; - CaptionBmp: TBitmap; - DC: HDC; - FButtonState: TThemedWindow; - LCaptionRect, LBorderSize, R: TRect; - ButtonRect, TextRect: TRect; - TextTopOffset: Integer; - IconDetails: TThemedElementDetails; - LBorderIcons: TBorderIcons; - LBorderStyle: TFormBorderStyle; - CaptionDetails: TThemedElementDetails; - TextFormat: TTextFormat; - LText: String; - nPos: Integer; - LSysMenu: HMENU; - ItemDisabled: Boolean; -begin - LBorderStyle := BorderStyle; - if (LBorderStyle = bsNone) or (WindowState = wsMinimized) then // (WindowState=wsMinimized) avoid bug in windows 8.1 and increase performance - Exit; - - LBorderIcons := BorderIcons; - LCaptionRect := CaptionRect; - CaptionBmp := TBitmap.Create; - CaptionBmp.SetSize(LCaptionRect.Width, LCaptionRect.Height); - DC := CaptionBmp.Canvas.Handle; - TextTopOffset := 0; - TextRect := Rect(0, 0, 0, 0);; - ButtonRect := Rect(0, 0, 0, 0);; - FCaptionRect := Rect(0, 0, 0, 0); - R := Rect(0, 0, 0, 0); - - { Caption } - if FFrameActive then - begin - if not UseSmallBorder then - LDetails := StyleServices.GetElementDetails(twCaptionActive) - else - LDetails := StyleServices.GetElementDetails(twSmallCaptionActive); - end - else - begin - if not UseSmallBorder then - LDetails := StyleServices.GetElementDetails(twCaptionInActive) - else - LDetails := StyleServices.GetElementDetails(twSmallCaptionInActive); - end; - CaptionDetails := LDetails; - StyleServices.DrawElement(DC, LDetails, LCaptionRect, nil); - - { Draw icon } - - if (biSystemMenu in LBorderIcons) and (LBorderStyle <> bsDialog) and (LBorderStyle <> bsToolWindow) and (LBorderStyle <> bsSizeToolWin) then - begin - IconDetails := StyleServices.GetElementDetails(twSysButtonNormal); - if not StyleServices.GetElementContentRect(0, IconDetails, LCaptionRect, ButtonRect) then - ButtonRect := Rect(0, 0, 0, 0); - - R := Rect(0, 0, GetSystemMetrics(SM_CXSMICON), GetSystemMetrics(SM_CYSMICON)); - RectVCenter(R, ButtonRect); - - if ButtonRect.Width > 0 then - DrawIconEx(CaptionBmp.Canvas.Handle, R.Left, R.Top, GetIconFast.Handle, 0, 0, 0, 0, DI_NORMAL); - Inc(TextRect.Left, ButtonRect.Width + 5); - FSysMenuButtonRect := ButtonRect; - end - else - Inc(TextRect.Left, 7); - - { Draw buttons } - LSysMenu := GetSystemMenu(Handle, False); - nPos := GetMenuItemPos(LSysMenu, SC_CLOSE); - ItemDisabled := IsItemDisabled(LSysMenu, nPos); - if (biSystemMenu in LBorderIcons) and (not ItemDisabled) then - begin - if not UseSmallBorder then - begin - if (FPressedButton = HTCLOSE) and (FHotButton = HTCLOSE) then - FButtonState := twCloseButtonPushed - else if FHotButton = HTCLOSE then - FButtonState := twCloseButtonHot - else if FFrameActive then - FButtonState := twCloseButtonNormal - else - FButtonState := twCloseButtonDisabled; - end - else - begin - if (FPressedButton = HTCLOSE) and (FHotButton = HTCLOSE) then - FButtonState := twSmallCloseButtonPushed - else if FHotButton = HTCLOSE then - FButtonState := twSmallCloseButtonHot - else if FFrameActive then - FButtonState := twSmallCloseButtonNormal - else - FButtonState := twSmallCloseButtonDisabled; - end; - if FSysCloseButtonDisabled then - begin - if UseSmallBorder then - LDetails := StyleServices.GetElementDetails(twSmallCloseButtonNormal) - else - LDetails := StyleServices.GetElementDetails(twCloseButtonNormal); - end - else - LDetails := StyleServices.GetElementDetails(FButtonState); - ButtonRect := CloseButtonRect; - if (ButtonRect.Width > 0) then - StyleServices.DrawElement(CaptionBmp.Canvas.Handle, LDetails, ButtonRect); - - if ButtonRect.Left > 0 then - TextRect.Right := ButtonRect.Left; - end; - - if (biMaximize in LBorderIcons) and (biSystemMenu in LBorderIcons) and (LBorderStyle <> bsDialog) and (LBorderStyle <> bsToolWindow) and (LBorderStyle <> bsSizeToolWin) then - begin - if WindowState = wsMaximized then - begin - if (FPressedButton = HTMAXBUTTON) and (FHotButton = HTMAXBUTTON) then - FButtonState := twRestoreButtonPushed - else if FHotButton = HTMAXBUTTON then - FButtonState := twRestoreButtonHot - else if FFrameActive then - FButtonState := twRestoreButtonNormal - else - FButtonState := twRestoreButtonDisabled; - end - else - begin - if (FPressedButton = HTMAXBUTTON) and (FHotButton = HTMAXBUTTON) then - FButtonState := twMaxButtonPushed - else if FHotButton = HTMAXBUTTON then - FButtonState := twMaxButtonHot - else if FFrameActive then - FButtonState := twMaxButtonNormal - else - FButtonState := twMaxButtonDisabled; - end; - LDetails := StyleServices.GetElementDetails(FButtonState); - ButtonRect := MaxButtonRect; - - if ButtonRect.Width > 0 then - StyleServices.DrawElement(CaptionBmp.Canvas.Handle, LDetails, ButtonRect); - if ButtonRect.Left > 0 then - TextRect.Right := ButtonRect.Left; - end; - - if (biMinimize in LBorderIcons) and (biSystemMenu in LBorderIcons) and (LBorderStyle <> bsDialog) and (LBorderStyle <> bsToolWindow) and (LBorderStyle <> bsSizeToolWin) then - begin - if (FPressedButton = HTMINBUTTON) and (FHotButton = HTMINBUTTON) then - FButtonState := twMinButtonPushed - else if FHotButton = HTMINBUTTON then - FButtonState := twMinButtonHot - else if FFrameActive then - FButtonState := twMinButtonNormal - else - FButtonState := twMinButtonDisabled; - - LDetails := StyleServices.GetElementDetails(FButtonState); - ButtonRect := MinButtonRect; - if ButtonRect.Width > 0 then - StyleServices.DrawElement(CaptionBmp.Canvas.Handle, LDetails, ButtonRect); - if ButtonRect.Left > 0 then - TextRect.Right := ButtonRect.Left; - end; - - if (biHelp in LBorderIcons) and (biSystemMenu in LBorderIcons) and ((not(biMaximize in LBorderIcons) and not(biMinimize in LBorderIcons)) or (LBorderStyle = bsDialog)) then - begin - if (FPressedButton = HTHELP) and (FHotButton = HTHELP) then - FButtonState := twHelpButtonPushed - else if FHotButton = HTHELP then - FButtonState := twHelpButtonHot - else if FFrameActive then - FButtonState := twHelpButtonNormal - else - FButtonState := twHelpButtonDisabled; - LDetails := StyleServices.GetElementDetails(FButtonState); - - if not StyleServices.GetElementContentRect(0, LDetails, LCaptionRect, ButtonRect) then - ButtonRect := Rect(0, 0, 0, 0); - if ButtonRect.Width > 0 then - StyleServices.DrawElement(CaptionBmp.Canvas.Handle, LDetails, ButtonRect); - - if ButtonRect.Left > 0 then - TextRect.Right := ButtonRect.Left; - end; - - { draw text } - TextFormat := [tfLeft, tfSingleLine, tfVerticalCenter]; - if SysControl.BidiMode = bmRightToLeft then - Include(TextFormat, tfRtlReading); - // Important: Must retrieve Text prior to calling DrawText as it causes - // CaptionBuffer.Canvas to free its handle, making the outcome of the call - // to DrawText dependent on parameter evaluation order. - LText := SysControl.Text; - - if (WindowState = wsMaximized) // and (FormStyle <> fsMDIChild) - and (TextTopOffset <> 0) and (biSystemMenu in LBorderIcons) then - begin - Inc(TextRect.Left, R.Left); - MoveWindowOrg(CaptionBmp.Canvas.Handle, 0, TextTopOffset); - StyleServices.DrawText(CaptionBmp.Canvas.Handle, CaptionDetails, LText, TextRect, TextFormat); - MoveWindowOrg(CaptionBmp.Canvas.Handle, 0, -TextTopOffset); - end - else - StyleServices.DrawText(CaptionBmp.Canvas.Handle, CaptionDetails, LText, TextRect, TextFormat); - - FCaptionRect := TextRect; - - Canvas.Draw(0, 0, CaptionBmp); - CaptionBmp.Free; - - DC := Canvas.Handle; - LBorderSize := BorderSize; - - { Left Border } - if FFrameActive then - begin - if not UseSmallBorder then - LDetails := StyleServices.GetElementDetails(twFrameLeftActive) - else - LDetails := StyleServices.GetElementDetails(twSmallFrameLeftActive); - end - else - begin - if not UseSmallBorder then - LDetails := StyleServices.GetElementDetails(twFrameLeftInActive) - else - LDetails := StyleServices.GetElementDetails(twSmallFrameLeftInActive); - end; - - R := Rect(0, LCaptionRect.Height, LBorderSize.Left, SysControl.Height); - if SysControl.Width > LBorderSize.Left then - StyleServices.DrawElement(DC, LDetails, R); - - { Right Border } - if FFrameActive then - begin - if not UseSmallBorder then - LDetails := StyleServices.GetElementDetails(twFrameRightActive) - else - LDetails := StyleServices.GetElementDetails(twSmallFrameRightActive); - end - else - begin - if not UseSmallBorder then - LDetails := StyleServices.GetElementDetails(twFrameRightInActive) - else - LDetails := StyleServices.GetElementDetails(twSmallFrameRightInActive); - end; - R := Rect(SysControl.Width - LBorderSize.Right, LCaptionRect.Height, SysControl.Width, SysControl.Height); - if SysControl.Width > LBorderSize.Right then - StyleServices.DrawElement(DC, LDetails, R); - - { Bottom Border } - if FFrameActive then - begin - if not UseSmallBorder then - LDetails := StyleServices.GetElementDetails(twFrameBottomActive) - else - LDetails := StyleServices.GetElementDetails(twSmallFrameBottomActive); - end - else - begin - if not UseSmallBorder then - LDetails := StyleServices.GetElementDetails(twFrameBottomInActive) - else - LDetails := StyleServices.GetElementDetails(twSmallFrameBottomInActive); - end; - R := Rect(0, SysControl.Height - LBorderSize.Bottom, SysControl.Width, SysControl.Height); - StyleServices.DrawElement(DC, LDetails, R); -end; - -procedure TSysDialogStyleHook.Restore; -begin - FPressedButton := 0; - FHotButton := 0; - if Handle <> 0 then - SendMessage(Handle, WM_SYSCOMMAND, SC_RESTORE, 0); -end; - -procedure TSysDialogStyleHook.WMNCACTIVATE(var Message: TWMNCActivate); -begin - Handled := False; - if not StyleServicesEnabled then - Exit; - - if not OverridePaintNC then - Exit; - - FFrameActive := Message.Active; - InvalidateNC; - Message.Result := 1; - Handled := True; -end; - -procedure TSysDialogStyleHook.WMNCCalcSize(var Message: TWMNCCalcSize); -begin - Handled := False; - if (not StyleServicesEnabled) or (not OverridePaintNC) then - Exit; - if (BorderStyle = bsNone) or (not UpdateRegion) then - Exit; - inherited; -end; - -function TSysDialogStyleHook.NormalizePoint(const P: TPoint): TPoint; -var - WindowPos, ClientPos: TPoint; -begin - { Convert the point from the screen to the client window . } - WindowPos := Point(SysControl.Left, SysControl.Top); - ClientPos := Point(0, 0); - ClientToScreen(Handle, ClientPos); - Result := P; - ScreenToClient(Handle, Result); - Inc(Result.X, ClientPos.X - WindowPos.X); - Inc(Result.Y, ClientPos.Y - WindowPos.Y); -end; - -procedure TSysDialogStyleHook.WMNCHitTest(var Message: TWMNCHitTest); -var - P: TPoint; -begin - Handled := False; - if (not StyleServicesEnabled) or (not OverridePaintNC) then - Exit; - - if OverridePaintNC then - begin - P := Point(Message.XPos, Message.YPos); - P := NormalizePoint(P); - Message.Result := GetHitTest(P); - if ((Message.Result <> HTCLOSE) and (Message.Result <> HTMAXBUTTON) and (Message.Result <> HTMINBUTTON) and (Message.Result <> HTHELP)) then - begin - // Message.Result := CallDefaultProc(TMessage(Message)); - { Check if form can be scrolled . } - inherited; - { We need to correct the result after calling the default message . } - if ((Message.Result = HTCLOSE) or (Message.Result = HTMAXBUTTON) or (Message.Result = HTMINBUTTON) or (Message.Result = HTHELP)) then - Message.Result := HTCLIENT; - end; - Handled := True; - end; -end; - -procedure TSysDialogStyleHook.WMNCLButtonDown(var Message: TWMNCLButtonDown); -var - P: TPoint; -begin - Handled := False; - if (not StyleServicesEnabled) or (not OverridePaintNC) then - Exit; - - if OverridePaintNC then - begin - if (Message.HitTest = HTCLOSE) or (Message.HitTest = HTMAXBUTTON) or (Message.HitTest = HTMINBUTTON) or (Message.HitTest = HTHELP) then - begin - FPressedButton := Message.HitTest; - InvalidateNC; - SetRedraw(False); - { For some reason ,we can not handle the WMNCLBUTTONUP message .. - So we need to handle it inside the WMNCLBUTTONDOWN proc (this proc). - } - { Before handling the default message => this proc is WMNCLBUTTONDOWN } - Message.Result := CallDefaultProc(TMessage(Message)); - - { After handling the default message => this proc is WMNCLBUTTONUP } - - SetRedraw(True); - FPressedButton := 0; - FHotButton := 0; - InvalidateNC; - GetCursorPos(P); - P := NormalizePoint(P); - - case Message.HitTest of - HTCLOSE: - if CloseButtonRect.Contains(P) then - if Message.Result <> 0 then // only if the app doesn't processes this message - Close; - HTMAXBUTTON: - begin - if MaxButtonRect.Contains(P) then - begin - if WindowState = wsMaximized then - Restore - else - Maximize; - end; - end; - HTMINBUTTON: - if MinButtonRect.Contains(P) then - Minimize; - HTHELP: - if HelpButtonRect.Contains(P) then - Help; - end; - end - else - begin - inherited; - Handled := True; - Exit; - end; - Handled := True; - end; -end; - -procedure TSysDialogStyleHook.WMNCLButtonUp(var Message: TWMNCLButtonUp); -begin - { Reserved for potential updates . } - Handled := False; -end; - -procedure TSysDialogStyleHook.WMNCMouseMove(var Message: TWMNCHitMessage); -begin - { Reserved for potential updates . } - Handled := False; -end; - -procedure TSysDialogStyleHook.WMPaint(var Message: TMessage); -begin - if IsWindowMsgBox(Handle) and OverridePaint then - begin - inherited; - Exit; - end; - Message.Result := CallDefaultProc(Message); - Handled := True; -end; - -procedure TSysDialogStyleHook.WMSetText(var Message: TMessage); -var - FRedraw: Boolean; - LBorderStyle : TFormBorderStyle; -begin - LBorderStyle := BorderStyle; - if (LBorderStyle = bsNone) or (WindowState = wsMinimized) or (StyleServices.IsSystemStyle) then - begin - Handled := False; - Exit; - end; - - FRedraw := True; - - if IsWindowVisible(Handle) then - begin - //Application.ProcessMessages; - FRedraw := False; - SetRedraw(False); - end; - - CallDefaultProc(Message); - - if not FRedraw then - begin - SetRedraw(True); - InvalidateNC; - end; - Handled := True; -end; - - -procedure TSysDialogStyleHook.WMSIZE(var Message: TWMSize); -begin - Handled := False; - if (not StyleServicesEnabled) or (not OverridePaintNC) then - Exit; - - Message.Result := CallDefaultProc(TMessage(Message)); - - FRegion := GetRegion; - if (FRegion <> 0) and (BorderStyle <> bsNone) and UpdateRegion then - SetWindowRgn(Handle, FRegion, True); - Handled := True; -end; - -procedure TSysDialogStyleHook.WndProc(var Message: TMessage); -var - DFBW: Integer; - LBorderSize: TRect; - LParentHandle: HWND; -begin - // Addlog(Format('TSysDialogStyleHook $0x%x %s', [SysControl.Handle, WM_To_String(Message.Msg)])); - case Message.msg of - - WM_WINDOWPOSCHANGED: - begin - FSysCloseButtonDisabled := IsSysCloseButtonDisabled; - end; - - WM_CREATE: - begin - Message.Result := CallDefaultProc(Message); - { DFBW =Default Frame Border Width } - DFBW := GetSystemMetrics(SM_CXBORDER); - Inc(DFBW); - LBorderSize := GetBorderSize; - if (SysControl.Width > LBorderSize.Left) and (SysControl.Width > LBorderSize.Right) then - SetWindowPos(Handle, 0, 0, 0, SysControl.Width + DFBW, SysControl.Height + DFBW + 1, SWP_NOMOVE or SWP_NOZORDER or SWP_FRAMECHANGED); - Exit; - end; - - WM_DESTROY: - begin - { In some situations ..we can not get the ParentHandle - after processing the default WM_DESTROY message. - => Save the parent before calling the default message. - } - SysControl.Destroyed:=True; - //OutputDebugString(PChar(Format('TSysDialogStyleHook $0x%x %s', [SysControl.Handle, WM_To_String(Message.Msg)]))); - LParentHandle := ParentHandle; - - if (LParentHandle>0) and (TSysStyleManager.SysStyleHookList.ContainsKey(LParentHandle)) and TSysStyleManager.SysStyleHookList.Items[ParentHandle].SysControl.Destroyed then - Message.Result :=0 - else - Message.Result := CallDefaultProc(Message); - - if LParentHandle > 0 then - begin - { When destroying the child window .. - the parent window must be repainted . } - RedrawWindow(LParentHandle, nil, 0, RDW_ERASE or RDW_FRAME or RDW_INTERNALPAINT or RDW_INVALIDATE); - end; - - Handled := True; - end; - end; - inherited; -end; - -{ TSysScrollingStyleHook } -function TSysScrollingStyleHook.NormalizePoint(const P: TPoint): TPoint; -var - WindowPos, ClientPos: TPoint; -begin - { Convert the point from the screen to the client window . } - WindowPos := Point(SysControl.Left, SysControl.Top); - ClientPos := Point(0, 0); - ClientToScreen(Handle, ClientPos); - Result := P; - ScreenToClient(Handle, Result); - Inc(Result.X, ClientPos.X - WindowPos.X); - Inc(Result.Y, ClientPos.Y - WindowPos.Y); -end; - -procedure TSysScrollingStyleHook.CMSCROLLTRACKING(var Message: TMessage); -var - P: TPoint; - Pos, Delta: Integer; -begin - if (not OverridePaintNC) or (not StyleServicesEnabled) then - begin - Handled := False; - Exit; - end; - P.X := Longint(Word(Message.WParam)); - P.Y := Longint(HiWord(Message.WParam)); - GetCursorPos(P); - if FScrollKind = sbVertical then - begin - if (P.Y >= 0) then - begin - Pos := GetVertScrollPosFromPoint(P); - FTrackingPos := GetVertThumbPosFromPos(Pos); - Delta := Pos - FPrevPos; - DrawVertScroll(0); { Draw & take Tracking account . } - { Do Scroll } - Scroll(sbVertical, skTracking, Pos, Delta); - FPrevPos := VertScrollInfo.nPos; - end; - end - else if FScrollKind = sbHorizontal then - begin - if (P.X >= 0) then - begin - Pos := GetHorzScrollPosFromPoint(P); - FTrackingPos := GetHorzThumbPosFromPos(Pos); - Delta := Pos - FPrevPos; - DrawHorzScroll(0); { Draw & take Tracking account . } - { Do Scroll } - Scroll(sbHorizontal, skTracking, Pos, Delta); - FPrevPos := HorzScrollInfo.nPos; - end; - end; - Handled := True; -end; - -constructor TSysScrollingStyleHook.Create(AHandle: THandle); -begin - inherited; - FTracking := False; - FNCMouseDown := False; - FAllowScrolling := True; - FTrackingPos := 0; - FTrackTimer := nil; - FPrevPoint := Point(-1, -1); - FPrevPos := 0; - InitScrollState; -end; - -destructor TSysScrollingStyleHook.Destroy; -begin - if Assigned(FTrackTimer) then - FreeAndNil(FTrackTimer); - inherited; -end; - -procedure TSysScrollingStyleHook.DoLineTrackTimer(Sender: TObject); -begin - Scroll(FScrollKind, FScrollingType, 0, 0); -end; - -procedure TSysScrollingStyleHook.DoPageTrackTimer(Sender: TObject); -var - P: TPoint; -begin - GetCursorPos(P); - if (not VertSliderRect.Contains(P)) and (not HorzSliderRect.Contains(P)) then - begin - DoScroll(FScrollKind, FScrollingType, 0, 0); - end; -end; - -procedure TSysScrollingStyleHook.DoScroll(const Kind: TScrollBarKind; const ScrollType: TSysScrollingType; Pos, Delta: Integer); -begin - if ScrollType <> skNone then - begin - Scroll(Kind, ScrollType, Pos, Delta); - FPrevPos := VertScrollInfo.nPos; - end; -end; - -procedure TSysScrollingStyleHook.DoSliderTrackTimer(Sender: TObject); -var - P: TPoint; -begin - GetCursorPos(P); - if (FPrevPoint <> P) and (FDownPoint <> P) then - begin - SendMessage(Handle, CM_SCROLLTRACKING, MakeWParam(P.X, P.Y), 0); - FPrevPoint := P; - FDownPoint := Point(-1, -1); - end; -end; - -procedure TSysScrollingStyleHook.DrawHorzScroll(DC: HDC); -var - LDetails: TThemedElementDetails; - R: TRect; - B: TBitmap; - BmpDC, LDC: HDC; - cx, cy, PosX, ThumbSize: Integer; - P: TPoint; - Detail: TThemedScrollBar; -begin - if not FHorzScrollBar then - Exit; - LDC := DC; - R := HorzScrollRect; - cx := BtnSize.cx; - cy := BtnSize.cy; - if R.Width > 0 then - begin - B := TBitmap.Create; - try - if DC = 0 then - DC := GetWindowDC(Handle); - - if FVertScrollBar then - begin - if not LeftScrollBar then - begin - P := Point(R.Right, R.Top); - P := NormalizePoint(P); - DrawSmallRect(DC, Rect(P.X, P.Y, P.X + cx, P.Y + cy)); - end - else - begin - P := Point(R.Left, R.Top); - P := NormalizePoint(P); - FillDC(DC, Rect(P.X - cx, P.Y, P.X, P.Y + cy), Color); - end; - end; - - B.SetSize(R.Width, R.Height); - BmpDC := B.Canvas.Handle; - - { Draw Track face } - Detail := tsUpperTrackHorzNormal; - if (not SysControl.Enabled) or (HorzScrollDisabled) then - Detail := tsUpperTrackHorzDisabled; - R := Rect(0, 0, B.Width, B.Height); - LDetails := StyleServices.GetElementDetails(Detail); - StyleServices.DrawElement(BmpDC, LDetails, R); - { Draw Left Button } - Detail := FBtnLeftDetail; - if (not SysControl.Enabled) or (HorzScrollDisabled) then - Detail := tsArrowBtnLeftDisabled; - R := Rect(0, 0, cx, cy); - LDetails := StyleServices.GetElementDetails(Detail); - StyleServices.DrawElement(BmpDC, LDetails, R); - { Draw Slider Button } - Detail := FHorzBtnSliderDetail; - if (not SysControl.Enabled) or (HorzScrollDisabled) then - Detail := tsThumbBtnHorzDisabled; - PosX := GetHorzSliderPos; - ThumbSize := GetHorzThumbSize; - if FTracking then - // R := Rect(cx + FTrackingPos, 0, cx + FTrackingPos + ThumbSize, cy) - R := FTrackingRect - else - R := Rect(cx + PosX, 0, cy + PosX + ThumbSize, cy); - if R.Left < cx then - R := Rect(cx, 0, cx + ThumbSize, cy); - if R.Right > (B.Width - cx) then - R := Rect(B.Width - cx - ThumbSize, 0, B.Width - cx, cy); - - LDetails := StyleServices.GetElementDetails(Detail); - if not HorzScrollDisabled then - StyleServices.DrawElement(BmpDC, LDetails, R); - - { Draw Right Button } - Detail := FBtnRightDetail; - if (not SysControl.Enabled) or (HorzScrollDisabled) then - Detail := tsArrowBtnRightDisabled; - //R := HorzRightRect; - R := Rect(B.Width - cx, 0, B.Width, cy); - LDetails := StyleServices.GetElementDetails(Detail); - StyleServices.DrawElement(BmpDC, LDetails, R); - finally - P.X := HorzScrollRect.Left; - P.Y := HorzScrollRect.Top; - P := NormalizePoint(P); - BitBlt(DC, P.X, P.Y, HorzScrollRect.Width, HorzScrollRect.Height, B.Canvas.Handle, 0, 0, SRCCOPY); - B.Free; - if LDC = 0 then - ReleaseDC(Handle, DC); - end; - end; - -end; - -procedure TSysScrollingStyleHook.DrawSmallRect(DC: HDC; const SmallRect: TRect); -var - sColor: TColor; -begin - sColor := StyleServices.GetStyleColor(scWindow); - FillDC(DC, SmallRect, sColor); -end; - -procedure TSysScrollingStyleHook.DrawVertScroll(DC: HDC); -var - LDetails: TThemedElementDetails; - R: TRect; - B: TBitmap; - BmpDC, LDC: HDC; - cx, cy, PosY, ThumbSize: Integer; - P: TPoint; - Detail: TThemedScrollBar; -begin - if not FVertScrollBar then - Exit; - LDC := DC; - R := VertScrollRect; - cx := BtnSize.cx; - cy := BtnSize.cy; - if R.Width > 0 then - begin - - B := TBitmap.Create; - try - if DC = 0 then - DC := GetWindowDC(Handle); - - B.SetSize(R.Width, R.Height); - BmpDC := B.Canvas.Handle; - - { Draw Track face } - R := Rect(0, 0, B.Width, B.Height); - Detail := tsUpperTrackVertNormal; - if (not SysControl.Enabled) or (VertScrollDisabled) then - Detail := tsUpperTrackHorzDisabled; - - LDetails := StyleServices.GetElementDetails(Detail); - StyleServices.DrawElement(BmpDC, LDetails, R); - - { Draw UpButton } - R := Rect(0, 0, cx, cy); - Detail := FBtnUpDetail; - if (not SysControl.Enabled) or (VertScrollDisabled) then - Detail := tsArrowBtnUpDisabled; - - LDetails := StyleServices.GetElementDetails(Detail); - StyleServices.DrawElement(BmpDC, LDetails, R); - - { Draw SliderButton } - PosY := GetVertSliderPos; - ThumbSize := GetVertThumbSize; - if FTracking then - // R := Rect(0, FTrackingPos, BtnSize.cx, FTrackingPos + GetVertThumbSize) - R := FTrackingRect - else - R := Rect(0, cy + PosY, cx, cy + PosY + ThumbSize); - if R.Top < cy then - R := Rect(0, cy, cx, cy + ThumbSize); - if R.Bottom > (B.Height - cy) then - R := Rect(0, B.Height - cy - ThumbSize, cx, B.Height - cy); - - Detail := FVertBtnSliderDetail; - if (not SysControl.Enabled) or (VertScrollDisabled) then - Detail := tsThumbBtnVertDisabled; - - LDetails := StyleServices.GetElementDetails(Detail); - if not VertScrollDisabled then - StyleServices.DrawElement(BmpDC, LDetails, R); - - { Draw DownButton } - R := Rect(0, B.Height - cy, cx, B.Height); - Detail := FBtnDownDetail; - if (not SysControl.Enabled) or (VertScrollDisabled) then - Detail := tsArrowBtnDownDisabled; - - LDetails := StyleServices.GetElementDetails(Detail); - StyleServices.DrawElement(BmpDC, LDetails, R); - finally - // Canvas.Draw(VertScrollRect.Left, VertScrollRect.Top, B); - P.X := VertScrollRect.Left; - P.Y := VertScrollRect.Top; - // ScreenToClient(Handle, P); - P := NormalizePoint(P); - BitBlt(DC, P.X, P.Y, VertScrollRect.Width, VertScrollRect.Height, B.Canvas.Handle, 0, 0, SRCCOPY); - B.Free; - if LDC = 0 then - ReleaseDC(Handle, DC); - end; - end; -end; - -function TSysScrollingStyleHook.GetDefaultScrollBarSize: TSize; -begin - { Return the default ScrollBar button size . } - Result.cx := GetSystemMetrics(SM_CXVSCROLL); - Result.cy := GetSystemMetrics(SM_CYVSCROLL); -end; - -function TSysScrollingStyleHook.GetHorzLeftRect: TRect; -begin - with HorzScrollRect do - Result := Rect(Left, Top, Left + BtnSize.cx, Bottom); -end; - -function TSysScrollingStyleHook.GetHorzScrollInfo: TScrollInfo; -begin - FillChar(Result, sizeof(TScrollInfo), Char(0)); - Result.cbSize := sizeof(TScrollInfo); - Result.fMask := SIF_ALL; - Winapi.Windows.GetScrollInfo(Handle, SB_HORZ, Result); -end; - -function TSysScrollingStyleHook.GetHorzScrollPosFromPoint(const P: TPoint): Integer; -var - TrackRect, WinRect: TRect; - Pos, MaxMin: Integer; - LInfo: TScrollInfo; - ThumbSize: Integer; -begin - LInfo := HorzScrollInfo; - Pos := P.X - FDownDis; - WinRect := SysControl.WindowRect; - TrackRect := HorzTrackRect; - Dec(Pos, WinRect.Left); - ThumbSize := GetHorzThumbSize; - OffsetRect(TrackRect, -WinRect.Left, -WinRect.Top); - - FTrackingRect := Rect(Pos, 0, Pos + ThumbSize, BtnSize.cy); - - MaxMin := LInfo.nMax - LInfo.nMin; - if MaxMin > 0 then - Pos := MulDiv(Pos - TrackRect.Left, MaxMin - Integer(LInfo.nPage) + 1, TrackRect.Width - ThumbSize) - else - Pos := Pos - TrackRect.Left; - if Pos < 0 then - Pos := 0; - if Pos >= LInfo.nMax - (Integer(LInfo.nPage) - 1) then - Pos := LInfo.nMax - (Integer(LInfo.nPage) - 1); - Result := Pos; -end; - -function TSysScrollingStyleHook.GetHorzScrollRect: TRect; -var - WinRect: TRect; - BorderSize: TRect; -begin - Result := Rect(0, 0, 0, 0); - WinRect := SysControl.WindowRect; - BorderSize := GetBorderSize; - with WinRect do - begin - Result.Left := Left; - Result.Right := Right; - Result.Top := Bottom - BtnSize.cy; - Result.Bottom := Result.Top + BtnSize.cy; - end; - if (BorderSize.Left > 0) or (BorderSize.Top > 0) or (BorderSize.Right > 0) or (BorderSize.Bottom > 0) then - begin - Result.Left := Result.Left + BorderSize.Left; - Result.Right := Result.Right - BorderSize.Right; - Result.Bottom := Result.Bottom - BorderSize.Bottom; - Result.Top := Result.Bottom - BtnSize.cy; - end; - if FVertScrollBar then - begin - if not LeftScrollBar then - Dec(Result.Right, BtnSize.cx) - else - Inc(Result.Left, BtnSize.cx) - end; -end; - -function TSysScrollingStyleHook.GetHorzSliderPos: Integer; -begin - with HorzScrollInfo do - Result := MulDiv(nPos, HorzTrackRect.Width, nMax - nMin); -end; - -function TSysScrollingStyleHook.GetHorzSliderRect: TRect; -var - ThumbSize: Integer; - PosX: Integer; -begin - Result := Rect(0, 0, 0, 0); - ThumbSize := GetHorzThumbSize; - PosX := MulDiv(HorzScrollInfo.nPos, HorzTrackRect.Width, HorzScrollInfo.nMax - HorzScrollInfo.nMin); - with HorzTrackRect do - Result := Rect(Left + PosX, Top, Left + PosX + ThumbSize, Bottom); -end; - -function TSysScrollingStyleHook.GetHorzThumbPosFromPos(const Pos: Integer): Integer; -var - PosX: Integer; -begin - with HorzScrollInfo do - begin - PosX := MulDiv(Pos, HorzTrackRect.Width, nMax - nMin); - Result := PosX + BtnSize.cx; - end; -end; - -function TSysScrollingStyleHook.GetHorzThumbSize: Integer; -begin - with HorzScrollInfo do - begin - Result := MulDiv(nPage, HorzScrollRect.Width - (2 * BtnSize.cx), nMax - nMin); - if Result < BtnSize.cy then - Result := BtnSize.cy; - end; -end; - -function TSysScrollingStyleHook.GetHorzTrackRect: TRect; -begin - Result := HorzScrollRect; - if Result.Width > 0 then - begin - Result.Left := Result.Left + GetSystemMetrics(SM_CXHTHUMB); - Result.Right := Result.Right - GetSystemMetrics(SM_CXHTHUMB); - end - else - Result := Rect(0, 0, 0, 0); -end; - -function TSysScrollingStyleHook.GetVertTrackRect: TRect; -begin - Result := VertScrollRect; - if Result.Width > 0 then - begin - Result.Top := Result.Top + GetSystemMetrics(SM_CYVTHUMB); - Result.Bottom := Result.Bottom - GetSystemMetrics(SM_CYVTHUMB); - end - else - Result := Rect(0, 0, 0, 0); -end; - -function TSysScrollingStyleHook.GetVertDownRect: TRect; -begin - with VertScrollRect do - Result := Rect(Left, Bottom - BtnSize.cy, Right, Bottom); -end; - -function TSysScrollingStyleHook.GetHorzRightRect: TRect; -begin - with HorzScrollRect do - Result := Rect(Right - BtnSize.cx, Top, Right, Bottom); -end; - -function TSysScrollingStyleHook.GetVertScrollRect: TRect; -var - WinRect: TRect; - BorderSize: TRect; -begin - Result := Rect(0, 0, 0, 0); - WinRect := SysControl.WindowRect; - BorderSize := GetBorderSize; - with WinRect do - begin - if not LeftScrollBar then - begin - Result.Left := Right - BtnSize.cx; - Result.Right := Result.Left + BtnSize.cx; - Result.Top := Top; - Result.Bottom := Bottom; - end - else - begin - Result.Left := Left; - Result.Right := Left + BtnSize.cx; - Result.Top := Top; - Result.Bottom := Bottom; - end; - end; - if (BorderSize.Left >= 0) or (BorderSize.Top >= 0) or (BorderSize.Right >= 0) or (BorderSize.Bottom >= 0) then - begin - if not LeftScrollBar then - begin - Result.Left := Result.Left - BorderSize.Right; - Result.Right := Result.Left + BtnSize.cx; - Result.Top := Result.Top + BorderSize.Top; - Result.Bottom := Result.Bottom - BorderSize.Bottom; - end - else - begin - Result.Left := Result.Left + BorderSize.Left; - Result.Right := Result.Left + BtnSize.cx; - Result.Top := Result.Top + BorderSize.Top; - Result.Bottom := Result.Bottom - BorderSize.Bottom; - end; - end; - if FHorzScrollBar then - Dec(Result.Bottom, BtnSize.cy); -end; - -function TSysScrollingStyleHook.GetVertScrollInfo: TScrollInfo; -begin - FillChar(Result, sizeof(TScrollInfo), Char(0)); - Result.cbSize := sizeof(TScrollInfo); - Result.fMask := SIF_ALL; - Winapi.Windows.GetScrollInfo(Handle, SB_VERT, Result); -end; - -function TSysScrollingStyleHook.GetVertScrollPosFromPoint(const P: TPoint): Integer; -var - TrackRect, WinRect: TRect; - Pos, MaxMin: Integer; - LInfo: TScrollInfo; - ThumbSize: Integer; -begin - LInfo := VertScrollInfo; - Pos := P.Y - FDownDis; - WinRect := SysControl.WindowRect; - TrackRect := VertTrackRect; - OffsetRect(TrackRect, -WinRect.Left, -WinRect.Top); - Dec(Pos, WinRect.Top); - ThumbSize := GetVertThumbSize; - - FTrackingRect := Rect(0, Pos, BtnSize.cx, Pos + ThumbSize); - - MaxMin := LInfo.nMax - LInfo.nMin; - if MaxMin > 0 then - Pos := MulDiv(Pos - TrackRect.Top, MaxMin - Integer(LInfo.nPage) + 2, (TrackRect.Height) - ThumbSize) - else - Pos := Pos - TrackRect.Top; - if Pos < 0 then - Pos := 0; - if Pos >= LInfo.nMax - (Integer(LInfo.nPage) - 1) then - Pos := LInfo.nMax - (Integer(LInfo.nPage) - 1); - - Result := Pos; -end; - -function TSysScrollingStyleHook.GetVertSliderPos: Integer; -begin - with VertScrollInfo do - Result := MulDiv(nPos, VertTrackRect.Height, nMax - nMin); -end; - -function TSysScrollingStyleHook.GetVertSliderRect: TRect; -var - ThumbSize: Integer; - PosY: Integer; -begin - Result := Rect(0, 0, 0, 0); - ThumbSize := GetVertThumbSize; - PosY := MulDiv(VertScrollInfo.nPos, VertTrackRect.Height, VertScrollInfo.nMax - VertScrollInfo.nMin); - with VertTrackRect do - Result := Rect(Left, Top + PosY, Right, Top + PosY + ThumbSize); -end; - -function TSysScrollingStyleHook.GetVertThumbPosFromPos(const Pos: Integer): Integer; -var - PosY: Integer; -begin - with VertScrollInfo do - begin - PosY := MulDiv(Pos, VertTrackRect.Height, nMax - nMin); - Result := PosY + BtnSize.cy; - end; -end; - -function TSysScrollingStyleHook.GetVertThumbSize: Integer; -begin - with VertScrollInfo do - begin - Result := MulDiv(nPage, VertTrackRect.Height, nMax - nMin); - if Result < BtnSize.cy then - Result := BtnSize.cy; - end; -end; - -function TSysScrollingStyleHook.GetVertUpRect: TRect; -begin - with VertScrollRect Do - Result := Rect(Left, Top, Right, Top + BtnSize.cy); -end; - -procedure TSysScrollingStyleHook.InitScrollState; -begin - FBtnUpDetail := tsArrowBtnUpNormal; - FBtnDownDetail := tsArrowBtnDownNormal; - FVertBtnSliderDetail := tsThumbBtnVertNormal; - FBtnLeftDetail := tsArrowBtnLeftNormal; - FBtnRightDetail := tsArrowBtnRightNormal; - FHorzBtnSliderDetail := tsThumbBtnHorzNormal; -end; - -function TSysScrollingStyleHook.IsHorzScrollDisabled: Boolean; -begin - if FHorzScrollBar then - begin - with HorzScrollInfo do - Result := (Integer(nPage) > nMax); - end - else - Result := False; -end; - -function TSysScrollingStyleHook.IsLeftScrollBar: Boolean; -begin - Result := (SysControl.ExStyle and WS_EX_LEFTSCROLLBAR = WS_EX_LEFTSCROLLBAR); -end; - -function TSysScrollingStyleHook.IsVertScrollDisabled: Boolean; -begin - if FVertScrollBar then - begin - with VertScrollInfo do - Result := (Integer(nPage) > nMax); - end - else - Result := False; -end; - -procedure TSysScrollingStyleHook.MouseEnter; -begin - if FVertScrollBar and (not FNCMouseDown) and (not VertScrollDisabled) then - begin - if (FBtnUpDetail <> tsArrowBtnUpNormal) or (FBtnDownDetail <> tsArrowBtnDownNormal) or (FVertBtnSliderDetail <> tsThumbBtnVertNormal) then - begin - FBtnUpDetail := tsArrowBtnUpNormal; - FBtnDownDetail := tsArrowBtnDownNormal; - FVertBtnSliderDetail := tsThumbBtnVertNormal; - DrawVertScroll(0); - end; - end; - if FHorzScrollBar and (not FNCMouseDown) and (not HorzScrollDisabled) then - begin - if (FBtnLeftDetail <> tsArrowBtnLeftNormal) or (FBtnRightDetail <> tsArrowBtnRightNormal) or (FHorzBtnSliderDetail <> tsThumbBtnHorzNormal) then - begin - FBtnLeftDetail := tsArrowBtnLeftNormal; - FBtnRightDetail := tsArrowBtnRightNormal; - FHorzBtnSliderDetail := tsThumbBtnHorzNormal; - DrawHorzScroll(0); - end; - end; -end; - -procedure TSysScrollingStyleHook.MouseLeave; -begin - if not FNCMouseDown then - begin - if FVertScrollBar and not VertScrollDisabled then - begin - if (FBtnUpDetail <> tsArrowBtnUpNormal) or (FBtnDownDetail <> tsArrowBtnDownNormal) or (FVertBtnSliderDetail <> tsThumbBtnVertNormal) then - begin - FBtnUpDetail := tsArrowBtnUpNormal; - FBtnDownDetail := tsArrowBtnDownNormal; - FVertBtnSliderDetail := tsThumbBtnVertNormal; - DrawVertScroll(0); - end; - end; - if FHorzScrollBar and not HorzScrollDisabled then - begin - if (FBtnLeftDetail <> tsArrowBtnLeftNormal) or (FBtnRightDetail <> tsArrowBtnRightNormal) or (FHorzBtnSliderDetail <> tsThumbBtnHorzNormal) then - begin - FBtnLeftDetail := tsArrowBtnLeftNormal; - FBtnRightDetail := tsArrowBtnRightNormal; - FHorzBtnSliderDetail := tsThumbBtnHorzNormal; - DrawHorzScroll(0); - end; - end; - end; -end; - -procedure TSysScrollingStyleHook.PaintNC(Canvas: TCanvas); -begin - if (Canvas.HandleAllocated) and (not FTracking) then - begin - if FVertScrollBar then - DrawVertScroll(Canvas.Handle); - if FHorzScrollBar then - DrawHorzScroll(Canvas.Handle); - end; -end; - -procedure TSysScrollingStyleHook.Scroll(const Kind: TScrollBarKind; const ScrollType: TSysScrollingType; Pos, Delta: Integer); -begin - if Kind = sbVertical then - begin - case ScrollType of - skTracking: - begin - FLstPos := Pos; - FAllowScrolling := True; - SendMessage(Handle, WM_VSCROLL, MakeWParam(SB_THUMBTRACK, Pos), 0); - FAllowScrolling := False; - end; - skLineUp: SendMessage(Handle, WM_VSCROLL, SB_LINEUP, 0); - skLineDown: SendMessage(Handle, WM_VSCROLL, SB_LINEDOWN, 0); - skPageUp: SendMessage(Handle, WM_VSCROLL, SB_PAGEUP, 0); - skPageDown: SendMessage(Handle, WM_VSCROLL, SB_PAGEDOWN, 0); - end; - end - else if Kind = sbHorizontal then - begin - case ScrollType of - skTracking: - begin - FLstPos := Pos; - FAllowScrolling := True; - SendMessage(Handle, WM_HSCROLL, MakeWParam(SB_THUMBTRACK, Pos), 0); - FAllowScrolling := False; - end; - skLineLeft: SendMessage(Handle, WM_HSCROLL, SB_LINELEFT, 0); - skLineRight: SendMessage(Handle, WM_HSCROLL, SB_LINERIGHT, 0); - skPageLeft: SendMessage(Handle, WM_HSCROLL, SB_PAGELEFT, 0); - skPageRight: SendMessage(Handle, WM_HSCROLL, SB_PAGERIGHT, 0); - end; - end; -end; - -procedure TSysScrollingStyleHook.StartLineTrackTimer; -begin - if Assigned(FTrackTimer) then - begin - FTrackTimer.Enabled := False; - FreeAndNil(FTrackTimer); - end; - - FTrackTimer := TTimer.Create(nil); - with FTrackTimer do - begin - Interval := 100; - OnTimer := DoLineTrackTimer; - Enabled := True; - end; -end; - -procedure TSysScrollingStyleHook.StartPageTrackTimer; -begin - if Assigned(FTrackTimer) then - begin - FTrackTimer.Enabled := False; - FreeAndNil(FTrackTimer); - end; - - FTrackTimer := TTimer.Create(nil); - with FTrackTimer do - begin - Interval := 100; - OnTimer := DoPageTrackTimer; - Enabled := True; - end; -end; - -procedure TSysScrollingStyleHook.StartSliderTrackTimer; -begin - if Assigned(FTrackTimer) then - begin - FTrackTimer.Enabled := False; - FreeAndNil(FTrackTimer); - end; - - FTrackTimer := TTimer.Create(nil); - with FTrackTimer do - begin - Interval := 100; - OnTimer := DoSliderTrackTimer; - Enabled := True; - end; -end; - -procedure TSysScrollingStyleHook.StopLineTrackTimer; -begin - if Assigned(FTrackTimer) then - begin - FTrackTimer.Enabled := False; - FreeAndNil(FTrackTimer); - end; -end; - -procedure TSysScrollingStyleHook.StopPageTrackTimer; -begin - if Assigned(FTrackTimer) then - begin - FTrackTimer.Enabled := False; - FreeAndNil(FTrackTimer); - end; -end; - -procedure TSysScrollingStyleHook.StopSliderTrackTimer; -begin - if Assigned(FTrackTimer) then - begin - FTrackTimer.Enabled := False; - FreeAndNil(FTrackTimer); - end; -end; - -procedure TSysScrollingStyleHook.WMNCCalcSize(var Message: TWMNCCalcSize); -var - OrgStyle, NewStyle: NativeInt; - BorderSize: TRect; -begin - if (not OverridePaintNC) or (not StyleServicesEnabled) then - begin - Handled := False; - Exit; - end; - BorderSize := GetBorderSize; - OrgStyle := SysControl.Style; - NewStyle := SysControl.Style; - FVertScrollBar := False; - FHorzScrollBar := False; - if OrgStyle and WS_VSCROLL = WS_VSCROLL then - begin - { Remove the VertScrollBar . } - NewStyle := NewStyle and not WS_VSCROLL; - FVertScrollBar := True; - end; - if OrgStyle and WS_HSCROLL = WS_HSCROLL then - begin - { Remove the HorzScrollBar . } - NewStyle := NewStyle and not WS_HSCROLL; - FHorzScrollBar := True; - end; - if OrgStyle <> NewStyle then - begin - SysControl.Style := NewStyle; - if not HookedDirectly then - Message.Result := CallDefaultProc(TMessage(Message)); - SysControl.Style := OrgStyle; - end; - if FVertScrollBar then - begin - { Insert a new VertScrollBar area . } - if not LeftScrollBar then - Dec(Message.CalcSize_Params.rgrc[0].Right, BtnSize.cx) - else - Inc(Message.CalcSize_Params.rgrc[0].Left, BtnSize.cx); - end; - if FHorzScrollBar then - { Insert a new HorzScrollBar area . } - Dec(Message.CalcSize_Params.rgrc[0].Bottom, BtnSize.cx); - if SysControl.HasBorder then - begin - Inc(Message.CalcSize_Params.rgrc[0].Left, BorderSize.Left); - Inc(Message.CalcSize_Params.rgrc[0].Top, BorderSize.Top); - Dec(Message.CalcSize_Params.rgrc[0].Bottom, BorderSize.Bottom); - Dec(Message.CalcSize_Params.rgrc[0].Right, BorderSize.Right); - end; - Handled := True; -end; - -procedure TSysScrollingStyleHook.WMNCHitTest(var Message: TWMNCHitTest); -var - P: TPoint; -begin - if (not OverridePaintNC) or (not StyleServicesEnabled) then - begin - Handled := False; - Exit; - end; - Message.Result := CallDefaultProc(TMessage(Message)); - P.X := Message.XPos; - P.Y := Message.YPos; - { If Mouse on VertScrollBar . } - if (FVertScrollBar and VertScrollRect.Contains(P)) then - begin - { Return HTVSCROLL allow the app to get WM_NCLBUTTONDOWN message . } - Message.Result := HTVSCROLL; - if (SysControl.Enabled and not VertScrollDisabled) then - begin - { If Mouse pressed then exit . } - if not FNCMouseDown then - begin - if VertUpRect.Contains(P) then - begin - { VertUpButton Hot . } - FVertBtnSliderDetail := tsThumbBtnVertNormal; - if FBtnUpDetail <> tsArrowBtnUpHot then - begin - FBtnUpDetail := tsArrowBtnUpHot; - DrawVertScroll(0); - end; - end - else if VertDownRect.Contains(P) then - begin - { VertDownButton Hot . } - FVertBtnSliderDetail := tsThumbBtnVertNormal; - if FBtnDownDetail <> tsArrowBtnDownHot then - begin - FBtnDownDetail := tsArrowBtnDownHot; - DrawVertScroll(0); - end; - end - else if VertSliderRect.Contains(P) then - begin - { VertSliderButton Hot . } - FBtnUpDetail := tsArrowBtnUpNormal; - FBtnDownDetail := tsArrowBtnDownNormal; - if FVertBtnSliderDetail <> tsThumbBtnVertHot then - begin - FVertBtnSliderDetail := tsThumbBtnVertHot; - DrawVertScroll(0); - end; - end - else - begin - { Update ScrollBar state . } - if (FBtnUpDetail <> tsArrowBtnUpNormal) or (FBtnDownDetail <> tsArrowBtnDownNormal) or (FVertBtnSliderDetail <> tsThumbBtnVertNormal) then - begin - FBtnUpDetail := tsArrowBtnUpNormal; - FBtnDownDetail := tsArrowBtnDownNormal; - FVertBtnSliderDetail := tsThumbBtnVertNormal; - DrawVertScroll(0); - end - end; - end; - end; - end; - { If Mouse on HorzScrollBar . } - if (FHorzScrollBar and HorzScrollRect.Contains(P)) then - begin - { Return HTHSCROLL allow the app to get WM_NCLBUTTONDOWN message . } - Message.Result := HTHSCROLL; - if (SysControl.Enabled and not HorzScrollDisabled) then - begin - { If Mouse pressed then exit . } - if not FNCMouseDown then - begin - if HorzLeftRect.Contains(P) then - begin - { HorzLeftButton Hot . } - FHorzBtnSliderDetail := tsThumbBtnHorzNormal; - if FBtnLeftDetail <> tsArrowBtnLeftHot then - begin - FBtnLeftDetail := tsArrowBtnLeftHot; - DrawHorzScroll(0); - end; - end - else if HorzRightRect.Contains(P) then - begin - { HorzRightButton Hot . } - FHorzBtnSliderDetail := tsThumbBtnHorzNormal; - if FBtnRightDetail <> tsArrowBtnRightHot then - begin - FBtnRightDetail := tsArrowBtnRightHot; - DrawHorzScroll(0); - end; - end - else if HorzSliderRect.Contains(P) then - begin - { HorzSliderButton Hot . } - FBtnLeftDetail := tsArrowBtnLeftNormal; - FBtnRightDetail := tsArrowBtnRightNormal; - if FHorzBtnSliderDetail <> tsThumbBtnHorzHot then - begin - FHorzBtnSliderDetail := tsThumbBtnHorzHot; - DrawHorzScroll(0); - end; - end - else - begin - { Update ScrollBar state . } - if (FBtnLeftDetail <> tsArrowBtnLeftNormal) or (FBtnRightDetail <> tsArrowBtnRightNormal) or (FHorzBtnSliderDetail <> tsThumbBtnHorzNormal) then - begin - FBtnLeftDetail := tsArrowBtnLeftNormal; - FBtnRightDetail := tsArrowBtnRightNormal; - FHorzBtnSliderDetail := tsThumbBtnHorzNormal; - DrawHorzScroll(0); - end - end; - end; - end; - end; - Handled := True; -end; - -procedure TSysScrollingStyleHook.WMNCLButtonDown(var Message: TWMNCLButtonDown); -var - P: TPoint; -begin - if (not OverridePaintNC) or (not StyleServicesEnabled) then - begin - Handled := False; - Exit; - end; - - if not SysControl.Enabled then - begin - Message.Result := CallDefaultProc(TMessage(Message)); - Exit; - end; - - FNCMouseDown := True; - FTracking := False; - if (Message.HitTest = HTVSCROLL) then - begin - if VertScrollDisabled then - begin - FTracking := False; - FNCMouseDown := False; - Message.Result := CallDefaultProc(TMessage(Message)); - FAllowScrolling := True; - Handled := True; - Exit; - end; - { Vertical ScrollBar } - FScrollKind := sbVertical; - GetCursorPos(P); - { Save the DownPoint } - FDownPoint := P; - { The distance between the point & the top of VertSliderButton . } - FDownDis := P.Y - VertSliderRect.Top; - { The old ScrollBar Position } - FPrevPos := VertScrollInfo.nPos; - -// OutputDebugString(PChar(Format('TSysScrollingStyleHook.WMNCLButtonDown P.X %d P.Y %d VertSliderRect.Left %d VertSliderRect.Top %d VertSliderRect.Width %d VertSliderRect.Height %d', -// [P.X, P.Y, VertSliderRect.Left, VertSliderRect.Top, VertSliderRect.Width, VertSliderRect.Height]))); - - if VertSliderRect.Contains(P) then - begin - { VertSliderButton pressed . } - FVertBtnSliderDetail := tsThumbBtnVertPressed; - StartSliderTrackTimer; - DrawVertScroll(0); { Need Repaint ==> First painting } - FTracking := True; { ==> Set it after first painting . } - FAllowScrolling := False; - { Mouse Down } - Message.Result := CallDefaultProc(TMessage(Message)); - { Mouse Up } - FAllowScrolling := False; - StopSliderTrackTimer; - FVertBtnSliderDetail := tsThumbBtnVertNormal; - FTracking := False; { Set it before the second painting . } - DrawVertScroll(0); { Need Repaint ==> Second painting . } - end - else if (VertUpRect.Contains(P) or (VertDownRect.Contains(P))) then - begin - if VertUpRect.Contains(P) then - begin - { VertUpButton pressed . } - FScrollingType := skLineUp; - FBtnUpDetail := tsArrowBtnUpPressed; - end - else - begin - { VertDownButton pressed . } - FScrollingType := skLineDown; - FBtnDownDetail := tsArrowBtnDownPressed; - end; - DrawVertScroll(0); { Need Repaint . } - StartLineTrackTimer; - { Mouse Down } - Message.Result := CallDefaultProc(TMessage(Message)); - { Mouse Up } - StopLineTrackTimer; - FBtnDownDetail := tsArrowBtnDownNormal; - FBtnUpDetail := tsArrowBtnUpNormal; - DrawVertScroll(0); { Need Repaint . } - end - else - begin - FScrollingType := skNone; - if FDownPoint.Y > VertSliderRect.Bottom then - FScrollingType := skPageDown; - if FDownPoint.Y < VertSliderRect.Top then - FScrollingType := skPageUp; - DrawVertScroll(0); { Need Repaint . } - { - Scrolling from the track rect . - ==> Not from Slider or Up/Down Button . - } - - StartPageTrackTimer; - { Mouse Down } - Message.Result := CallDefaultProc(TMessage(Message)); - { Mouse Up } - StopPageTrackTimer; - end; - DrawVertScroll(0); { Need Repaint . } - end - else if (Message.HitTest = HTHSCROLL) then - { Horizontal ScrollBar } - begin - if HorzScrollDisabled then - begin - FTracking := False; - FNCMouseDown := False; - Message.Result := CallDefaultProc(TMessage(Message)); - FAllowScrolling := True; - Handled := True; - Exit; - end; - FScrollKind := sbHorizontal; - GetCursorPos(P); - FDownPoint := P; - { The distance between the point & the left of HorzSliderButton . } - FDownDis := P.X - HorzSliderRect.Left; - FPrevPos := HorzScrollInfo.nPos; - if HorzSliderRect.Contains(P) then - begin - FHorzBtnSliderDetail := tsThumbBtnHorzPressed; - DrawHorzScroll(0); { Need Repaint ==> First painting . } - FTracking := True; { Set it after first painting . } - StartSliderTrackTimer; - { Mouse Down } - Message.Result := CallDefaultProc(TMessage(Message)); - { Mouse Up } - StopSliderTrackTimer; - FHorzBtnSliderDetail := tsThumbBtnHorzNormal; - FTracking := False; { Set it before second painting . } - DrawHorzScroll(0); { Need Repaint ==> Second painting. } - end - else if (HorzLeftRect.Contains(P) or (HorzRightRect.Contains(P))) then - begin - if HorzLeftRect.Contains(P) then - begin - FBtnLeftDetail := tsArrowBtnLeftPressed; - FBtnRightDetail := tsArrowBtnRightNormal; - FScrollingType := skLineLeft - end - else - begin - FBtnLeftDetail := tsArrowBtnLeftNormal; - FBtnRightDetail := tsArrowBtnRightPressed; - FScrollingType := skLineRight; - end; - DrawHorzScroll(0); { Need Repaint . } - StartLineTrackTimer; - { Mouse Down } - Message.Result := CallDefaultProc(TMessage(Message)); - { Mouse Up } - FBtnLeftDetail := tsArrowBtnLeftNormal; - FBtnRightDetail := tsArrowBtnRightNormal; - StopLineTrackTimer; - DrawHorzScroll(0); { Need Repaint . } - end - else - begin - FScrollingType := skNone; - if FDownPoint.X > HorzSliderRect.Right then - FScrollingType := skPageRight; - if FDownPoint.X < HorzSliderRect.Right then - FScrollingType := skPageLeft; - { - Scrolling from the track rect . - ==> Not from Slider or Left/Right Button . - } - StartPageTrackTimer; - { Mouse Down } - Message.Result := CallDefaultProc(TMessage(Message)); - { Mouse Up } - StopPageTrackTimer; - end; - FTracking := False; - DrawHorzScroll(0); { Need Repaint . } - end - else - begin - Message.Result := CallDefaultProc(TMessage(Message)); - end; - FTracking := False; - FNCMouseDown := False; - Handled := True; - FAllowScrolling := True; -end; - -procedure TSysScrollingStyleHook.WMNCLButtonUp(var Message: TWMNCLButtonUp); -begin - Message.Result := CallDefaultProc(TMessage(Message)); - Handled := True; -end; - -procedure TSysScrollingStyleHook.WndProc(var Message: TMessage); -begin - case Message.msg of - - WM_MOUSEWHEEL: - begin - Inherited; - if FVertScrollBar then - DrawVertScroll(0); - end; - - WM_VSCROLL, WM_HSCROLL: - begin - if Word(Message.WParam) = SB_THUMBPOSITION then - begin - Message.WParam := MakeWParam(SB_THUMBPOSITION, FLstPos); - CallDefaultProc(Message); - Exit; - end; - if (not OverridePaintNC) or (not StyleServicesEnabled) then - begin - CallDefaultProc(Message); - Exit; - end; - // if not FAllowScrolling then - // Exit; - inherited; - end; - - WM_NCMOUSELEAVE, WM_MOUSEMOVE: - begin - if (not OverridePaintNC) or (not StyleServicesEnabled) then - begin - CallDefaultProc(Message); - Exit; - end; - { Update ScrollBar State } - if (FVertScrollBar and SysControl.Enabled and (not FNCMouseDown) and (not VertScrollDisabled)) then - begin - if (FBtnUpDetail <> tsArrowBtnUpNormal) or (FBtnDownDetail <> tsArrowBtnDownNormal) or (FVertBtnSliderDetail <> tsThumbBtnVertNormal) then - begin - FBtnUpDetail := tsArrowBtnUpNormal; - FBtnDownDetail := tsArrowBtnDownNormal; - FVertBtnSliderDetail := tsThumbBtnVertNormal; - DrawVertScroll(0); - end; - end; - if (FHorzScrollBar and SysControl.Enabled and (not FNCMouseDown) and (not HorzScrollDisabled)) then - begin - if (FBtnLeftDetail <> tsArrowBtnLeftNormal) or (FBtnRightDetail <> tsArrowBtnRightNormal) or (FHorzBtnSliderDetail <> tsThumbBtnHorzNormal) then - begin - FBtnLeftDetail := tsArrowBtnLeftNormal; - FBtnRightDetail := tsArrowBtnRightNormal; - FHorzBtnSliderDetail := tsThumbBtnHorzNormal; - DrawHorzScroll(0); - end; - end; - inherited; - end; - - WM_PAINT: - begin - if (not OverridePaintNC) or (not StyleServicesEnabled) then - begin - CallDefaultProc(Message); - Exit; - end; - - inherited WndProc(Message); - { Do not paint while tracking . } - if (not FTracking) and (OverridePaintNC) then - begin - if FVertScrollBar then - DrawVertScroll(0); - if FHorzScrollBar then - DrawHorzScroll(0); - end; - Exit; - end; - else inherited; - end; - -end; - -{ TSysScrollBarStyleHook } - -constructor TSysScrollBarStyleHook.Create(AHandle: THandle); -begin - inherited; -{$IF CompilerVersion > 23} - StyleElements := [seClient]; -{$ELSE} - OverridePaint := True; - OverridePaintNC := False; - OverrideFont := False; -{$IFEND} -end; - -destructor TSysScrollBarStyleHook.Destroy; -begin - inherited; -end; - -procedure TSysScrollBarStyleHook.WndProc(var Message: TMessage); -var - DC: HDC; - PS: TPaintStruct; - LDetails: TThemedElementDetails; -begin - case Message.msg of - WM_PAINT: - begin - if not OverridePaint then - begin - Message.Result := CallDefaultProc(Message); - Exit; - end; - if ((SysControl.Style and SBS_SIZEGRIP = SBS_SIZEGRIP) or (SysControl.Style and SBS_SIZEBOX = SBS_SIZEBOX)) then - begin - BeginPaint(Handle, PS); - try - DC := GetDC(Handle); - try - LDetails := StyleServices.GetElementDetails(tsSizeBoxLeftAlign); - StyleServices.DrawElement(DC, LDetails, SysControl.ClientRect); - finally - ReleaseDC(Handle, DC); - end; - finally - EndPaint(Handle, PS); - end; - Exit; - end - - else - begin - Message.Result := CallDefaultProc(Message); - Exit; - end; - Exit; - end; - WM_ERASEBKGND: - begin - if OverridePaint then - begin - Message.Result := 1; - Exit; - end - else - begin - Message.Result := CallDefaultProc(Message); - Exit; - end; - end; - end; - - inherited; -end; - -initialization - - {$IFNDEF USE_Vcl.Styles.Hooks} - //UseLatestCommonDialogs := False; - {$ENDIF} - -{$IF CompilerVersion >= 30} - TStyleManager.SystemHooks := TStyleManager.SystemHooks - [shDialogs]; -{$IFEND} - - - if StyleServices.Available then - begin - TSysStyleManager.RegisterSysStyleHook('#32770', TSysDialogStyleHook); - //TSysStyleManager.RegisterSysStyleHook('HH Parent', TSysDialogStyleHook); - TSysStyleManager.RegisterSysStyleHook('ScrollBar', TSysScrollBarStyleHook); - end; - -finalization - TSysStyleManager.UnRegisterSysStyleHook('#32770', TSysDialogStyleHook); - //TSysStyleManager.UnRegisterSysStyleHook('HH Parent', TSysDialogStyleHook); - TSysStyleManager.UnRegisterSysStyleHook('ScrollBar', TSysScrollBarStyleHook); -end. +// ************************************************************************************************** +// +// Unit Vcl.Styles.Utils.Forms +// unit for the VCL Styles Utils +// https://github.com/RRUZ/vcl-styles-utils/ +// +// 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. +// +// +// Portions created by Mahdi Safsafi [SMP3] e-mail SMP@LIVE.FR +// Portions created by Rodrigo Ruz V. are Copyright (C) 2013-2023 Rodrigo Ruz V. +// All Rights Reserved. +// +// ************************************************************************************************** +unit Vcl.Styles.Utils.Forms; + + +{$I VCL.Styles.Utils.inc} + +interface + +uses + System.Classes, + System.Types, + System.SysUtils, + Winapi.Windows, + Winapi.Messages, + Vcl.Styles, + Vcl.Themes, + Vcl.Dialogs, + Vcl.Graphics, + Vcl.Styles.Utils.SysStyleHook, + {$IFDEF USE_Vcl.Styles.Hooks} + Vcl.Styles.Hooks, + {$ENDIF} + Vcl.Forms, + Vcl.GraphUtil, + Vcl.ExtCtrls, + Vcl.Controls; + +type + TSysScrollingType = (skNone, skTracking, skLineUp, skLineDown, skLineLeft, skLineRight, skPageUp, skPageDown, skPageLeft, skPageRight); + + TSysScrollingStyleHook = class(TMouseTrackSysControlStyleHook) + private + FVertScrollBar: Boolean; + FHorzScrollBar: Boolean; + FTrackTimer: TTimer; + FPrevPoint: TPoint; + FPrevPos: Integer; + FDownDis: Integer; + FDownPoint: TPoint; + FTrackingPos: Integer; + FTrackingRect: TRect; + FTracking: Boolean; + FScrollingType: TSysScrollingType; + FScrollKind: TScrollBarKind; + FBtnUpDetail: TThemedScrollBar; + FBtnDownDetail: TThemedScrollBar; + FVertBtnSliderDetail: TThemedScrollBar; + FBtnLeftDetail: TThemedScrollBar; + FBtnRightDetail: TThemedScrollBar; + FHorzBtnSliderDetail: TThemedScrollBar; + FNCMouseDown: Boolean; + FAllowScrolling: Boolean; + FLstPos: Integer; + function GetDefaultScrollBarSize: TSize; + procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST; + procedure WMNCCalcSize(var Message: TWMNCCalcSize); message WM_NCCALCSIZE; + procedure WMNCLButtonDown(var Message: TWMNCLButtonDown); message WM_NCLBUTTONDOWN; + procedure WMNCLButtonUp(var Message: TWMNCLButtonUp); message WM_NCLBUTTONUP; + procedure CMSCROLLTRACKING(var Message: TMessage); message CM_SCROLLTRACKING; + function GetVertScrollRect: TRect; + function GetVertUpRect: TRect; + function GetVertDownRect: TRect; + function GetVertSliderRect: TRect; + function GetVertSliderPos: Integer; + function GetVertThumbSize: Integer; + function GetVertTrackRect: TRect; + function GetVertScrollInfo: TScrollInfo; + function GetVertThumbPosFromPos(const Pos: Integer): Integer; + function GetVertScrollPosFromPoint(const P: TPoint): Integer; + function GetHorzThumbPosFromPos(const Pos: Integer): Integer; + function GetHorzScrollPosFromPoint(const P: TPoint): Integer; + function GetHorzSliderPos: Integer; + function GetHorzThumbSize: Integer; + function GetHorzLeftRect: TRect; + function GetHorzScrollInfo: TScrollInfo; + function GetHorzSliderRect: TRect; + function GetHorzTrackRect: TRect; + function GetHorzRightRect: TRect; + function GetHorzScrollRect: TRect; + function IsLeftScrollBar: Boolean; + function IsHorzScrollDisabled: Boolean; + function IsVertScrollDisabled: Boolean; + protected + property LstPos: Integer read FLstPos write FLstPos; + property AllowScrolling: Boolean read FAllowScrolling write FAllowScrolling; + function NormalizePoint(const P: TPoint): TPoint; + procedure Scroll(const Kind: TScrollBarKind; const ScrollType: TSysScrollingType; Pos, Delta: Integer); virtual; + procedure DoScroll(const Kind: TScrollBarKind; const ScrollType: TSysScrollingType; Pos, Delta: Integer); + procedure DrawHorzScroll(DC: HDC); virtual; + procedure DrawVertScroll(DC: HDC); virtual; + procedure DrawSmallRect(DC: HDC; const SmallRect: TRect); virtual; + procedure MouseEnter; override; + procedure MouseLeave; override; + procedure StartSliderTrackTimer; + procedure StopSliderTrackTimer; + procedure DoSliderTrackTimer(Sender: TObject); + procedure StartPageTrackTimer; + procedure StopPageTrackTimer; + procedure DoPageTrackTimer(Sender: TObject); + procedure StartLineTrackTimer; + procedure StopLineTrackTimer; + procedure DoLineTrackTimer(Sender: TObject); + procedure InitScrollState; + procedure PaintNC(Canvas: TCanvas); override; + procedure WndProc(var Message: TMessage); override; + public + constructor Create(AHandle: THandle); override; + Destructor Destroy; override; + property VertScrollRect: TRect read GetVertScrollRect; + property VertUpRect: TRect read GetVertUpRect; + property VertDownRect: TRect read GetVertDownRect; + property VertSliderRect: TRect read GetVertSliderRect; + property VertTrackRect: TRect read GetVertTrackRect; + property VertScrollInfo: TScrollInfo read GetVertScrollInfo; + property HorzScrollRect: TRect read GetHorzScrollRect; + property HorzLeftRect: TRect read GetHorzLeftRect; + property HorzRightRect: TRect read GetHorzRightRect; + property HorzSliderRect: TRect read GetHorzSliderRect; + property HorzTrackRect: TRect read GetHorzTrackRect; + property HorzScrollInfo: TScrollInfo read GetHorzScrollInfo; + property BtnSize: TSize read GetDefaultScrollBarSize; + property Tracking: Boolean read FTracking; + property TrackingRect: TRect read FTrackingRect; + property TrackingPos: Integer read FTrackingPos; + property LeftScrollBar: Boolean read IsLeftScrollBar; + property VertScrollDisabled: Boolean read IsVertScrollDisabled; + property HorzScrollDisabled: Boolean read IsHorzScrollDisabled; + end; + + TSysDialogStyleHook = class(TSysScrollingStyleHook) + private + FFrameActive: Boolean; + FPressedButton: Integer; + FHotButton: Integer; + FIcon: TIcon; + FIconHandle: HICON; + FCaptionRect: TRect; + FSysMenuButtonRect: TRect; + FRegion: HRGN; + // FUpdateRegion: Boolean; + FSysCloseButtonDisabled: Boolean; + procedure WMPaint(var Message: TMessage); message WM_PAINT; + procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST; + procedure WMNCLButtonDown(var Message: TWMNCLButtonDown); message WM_NCLBUTTONDOWN; + procedure WMNCLButtonUp(var Message: TWMNCLButtonUp); message WM_NCLBUTTONUP; + procedure WMNCMouseMove(var Message: TWMNCHitMessage); message WM_NCMOUSEMOVE; + procedure WMNCACTIVATE(var Message: TWMNCActivate); message WM_NCACTIVATE; + procedure WMNCCalcSize(var Message: TWMNCCalcSize); message WM_NCCALCSIZE; + procedure WMSIZE(var Message: TWMSize); message WM_SIZE; + procedure WMSetText(var Message: TMessage); message WM_SETTEXT; + function GetCaptionRect: TRect; + function GetBorderStyle: TFormBorderStyle; + function GetBorderIcons: TBorderIcons; + function GetCloseButtonRect: TRect; + function GetMaxButtonRect: TRect; + function GetMinButtonRect: TRect; + function GetHelpButtonRect: TRect; + function GetSysMenuButtonRect: TRect; + function GetWindowState: TWindowState; + function UseSmallBorder: Boolean; + function GetRegion: HRGN; + function GetIcon: TIcon; + function GetIconFast: TIcon; + function NormalizePoint(const P: TPoint): TPoint; + function GetHitTest(const P: TPoint): Integer; + function IsSysCloseButtonDisabled: Boolean; + function GetSysMenu: HMENU; + function GetUpdateRegion: Boolean; + protected + procedure DrawBorder(Canvas: TCanvas); override; + function GetBorderSize: TRect; override; + procedure PaintBackground(Canvas: TCanvas); override; + procedure Paint(Canvas: TCanvas); override; + procedure PaintNC(Canvas: TCanvas); override; + procedure WndProc(var Message: TMessage); override; + procedure Close; virtual; + procedure Help; virtual; + procedure Maximize; virtual; + procedure Minimize; virtual; + procedure Restore; virtual; + property PressedButton: Integer read FPressedButton write FPressedButton; + property HotButton: Integer read FHotButton write FHotButton; + public + constructor Create(AHandle: THandle); override; + Destructor Destroy; override; + property CaptionRect: TRect read GetCaptionRect; + property UpdateRegion: Boolean read GetUpdateRegion; + property BorderStyle: TFormBorderStyle read GetBorderStyle; + property BorderSize: TRect read GetBorderSize; + property BorderIcons: TBorderIcons read GetBorderIcons; + Property WindowState: TWindowState read GetWindowState; + Property CloseButtonRect: TRect read GetCloseButtonRect; + Property MaxButtonRect: TRect read GetMaxButtonRect; + Property MinButtonRect: TRect read GetMinButtonRect; + Property HelpButtonRect: TRect read GetHelpButtonRect; + property SysMenuButtonRect: TRect read GetSysMenuButtonRect; + property Icon: TIcon read GetIconFast; + property SysMenu: HMENU read GetSysMenu; + property SysCloseButtonDisabled: Boolean read FSysCloseButtonDisabled; + end; + + { + Note: The development of this class is not finished yet . + Only ScrollBar with SIZEBOX is supported !!. + } + TSysScrollBarStyleHook = class(TSysStyleHook) + protected + procedure WndProc(var Message: TMessage); override; + public + constructor Create(AHandle: THandle); override; + Destructor Destroy; override; + end; + +implementation + +uses + Vcl.Styles.Utils.Misc, + Vcl.Styles.Utils.SysControls, Vcl.Styles.Utils.Graphics, Winapi.UxTheme; + +// ----------------------------------------------------------------------------------- +procedure FillDC(const DC: HDC; const R: TRect; const Color: TColor); +var + Brush: HBRUSH; +begin + Brush := CreateSolidBrush(Color); + FillRect(DC, R, Brush); + DeleteObject(Brush); +end; + +function IsItemDisabled(const Menu: HMENU; const Index: Integer): Boolean; +var + Info: TMenuItemInfo; +begin + Result := False; + if (Menu = 0) or (Index < 0) then + Exit; + + FillChar(Info, sizeof(Info), Char(0)); + Info.cbSize := sizeof(TMenuItemInfo); + Info.fMask := MIIM_STATE; + GetMenuItemInfo(Menu, Index, True, Info); + Result := (Info.fState and MFS_DISABLED = MFS_DISABLED) or (Info.fState and MF_DISABLED = MF_DISABLED) or (Info.fState and MF_GRAYED = MF_GRAYED); +end; + +function GetMenuItemPos(const Menu: HMENU; const ID: Integer): Integer; +var + i: Integer; + mii: MENUITEMINFO; +begin + Result := -1; + if Menu = 0 then + Exit; + for i := 0 to GetMenuItemCount(Menu) do + begin + FillChar(mii, sizeof(mii), Char(0)); + mii.cbSize := sizeof(mii); + mii.fMask := MIIM_ID; + if (GetMenuItemInfo(Menu, i, True, mii)) then + if mii.wID = Cardinal(ID) then + Exit(i); + end; +end; + +function IsWindowMsgBox(Handle: HWND): Boolean; +begin + Result := ((FindWindowEx(Handle, 0, 'Edit', nil) = 0) and (GetDlgItem(Handle, $FFFF) <> 0)) and (GetWindowLongPtr(Handle, GWL_USERDATA) <> 0); +end; + +// ----------------------------------------------------------------------------------------- +{ TSysDialogStyleHook } + +procedure TSysDialogStyleHook.Close; +begin + if (Handle <> 0) and not(FSysCloseButtonDisabled) then + SendMessage(Handle, WM_SYSCOMMAND, SC_CLOSE, 0); +end; + +constructor TSysDialogStyleHook.Create(AHandle: THandle); +begin + inherited; + FRegion := 0; +{$IF CompilerVersion > 23} + StyleElements := [seFont, seClient, seBorder]; +{$ELSE} + OverridePaint := True; + OverridePaintNC := True; + OverrideFont := True; +{$IFEND} + OverrideEraseBkgnd := True; + FPressedButton := 0; + FHotButton := 0; + FIconHandle := 0; + FIcon := nil; + FSysMenuButtonRect := Rect(0, 0, 0, 0); +end; + +destructor TSysDialogStyleHook.Destroy; +begin + if FRegion <> 0 then + DeleteObject(FRegion); + if Assigned(FIcon) then + FreeAndNil(FIcon); + inherited; +end; + +procedure TSysDialogStyleHook.DrawBorder(Canvas: TCanvas); +begin + // +end; + +function TSysDialogStyleHook.GetCaptionRect: TRect; +var + LDetails: TThemedElementDetails; + ElementSize: TSize; + CaptionHeight: Integer; +begin + Result := Rect(0, 0, SysControl.Width, 0); + if BorderStyle = bsNone then + Exit; + + if FFrameActive then + begin + if not UseSmallBorder then + LDetails := StyleServices.GetElementDetails(twCaptionActive) + else + LDetails := StyleServices.GetElementDetails(twSmallCaptionActive); + end + else + begin + if not UseSmallBorder then + LDetails := StyleServices.GetElementDetails(twCaptionInActive) + else + LDetails := StyleServices.GetElementDetails(twSmallCaptionInActive); + end; + StyleServices.GetElementSize(0, LDetails, esActual, ElementSize); + {$IF (CompilerVersion >= 34)} + if Assigned(Application.Mainform) then + CaptionHeight := Round(ElementSize.Height * Application.MainForm.Monitor.PixelsPerInch / 96) + else + CaptionHeight := Round(ElementSize.Height * Screen.PixelsPerInch / 96); + {$ELSE} + CaptionHeight := ElementSize.Height; + {$ENDIF} + Result := Rect(0, 0, SysControl.Width, CaptionHeight); + +end; + +function TSysDialogStyleHook.GetCloseButtonRect: TRect; +var + FButtonState: TThemedWindow; + LDetails: TThemedElementDetails; +begin + Result := Rect(0, 0, 0, 0); + if (biSystemMenu in BorderIcons) then + begin + if not UseSmallBorder then + begin + if (FPressedButton = HTCLOSE) and (FHotButton = HTCLOSE) then + FButtonState := twCloseButtonPushed + else if FHotButton = HTCLOSE then + FButtonState := twCloseButtonHot + else if FFrameActive then + FButtonState := twCloseButtonNormal + else + FButtonState := twCloseButtonDisabled; + end + else + begin + if (FPressedButton = HTCLOSE) and (FHotButton = HTCLOSE) then + FButtonState := twSmallCloseButtonPushed + else if FHotButton = HTCLOSE then + FButtonState := twSmallCloseButtonHot + else if FFrameActive then + FButtonState := twSmallCloseButtonNormal + else + FButtonState := twSmallCloseButtonDisabled; + end; + LDetails := StyleServices.GetElementDetails(FButtonState); + if not StyleServices.GetElementContentRect(0, LDetails, CaptionRect, Result) then + Result := Rect(0, 0, 0, 0); + + {$IF (CompilerVersion >= 34)} + if Assigned(Application.Mainform) then + begin + Result.Height := Round(Result.Height * Application.MainForm.Monitor.PixelsPerInch / 96); + // The button is right aligned so move the left side + Result.Left := Result.Left + Result.Width - Round(Result.Width * Application.MainForm.Monitor.PixelsPerInch / 96); + Result.Top := Round(Result.Top * Application.MainForm.Monitor.PixelsPerInch / 96); + end + else + begin + Result.Height := Round(Result.Height * Screen.PixelsPerInch / 96); + // The button is right aligned so move the left side + Result.Left := Result.Left + Result.Width - Round(Result.Width * Screen.PixelsPerInch / 96); + Result.Top := Round(Result.Top * Screen.PixelsPerInch / 96); + end; + {$ENDIF} + end; +end; + +function TSysDialogStyleHook.GetHelpButtonRect: TRect; +var + FButtonState: TThemedWindow; + LDetails: TThemedElementDetails; +begin + Result := Rect(0, 0, 0, 0); + if (biHelp in BorderIcons) and (biSystemMenu in BorderIcons) and ((not(biMaximize in BorderIcons) and not(biMinimize in BorderIcons)) or (BorderStyle = bsDialog)) then + begin + if (FPressedButton = HTHELP) and (FHotButton = HTHELP) then + FButtonState := twHelpButtonPushed + else if FHotButton = HTHELP then + FButtonState := twHelpButtonHot + else if FFrameActive then + FButtonState := twHelpButtonNormal + else + FButtonState := twHelpButtonDisabled; + LDetails := StyleServices.GetElementDetails(FButtonState); + + if not StyleServices.GetElementContentRect(0, LDetails, CaptionRect, Result) then + Result := Rect(0, 0, 0, 0); + + {$IF (CompilerVersion >= 34)} + if Assigned(Application.Mainform) then + begin + Result.Height := Round(Result.Height * Application.MainForm.Monitor.PixelsPerInch / 96); + // The button is right aligned so move the left side + Result.Left := Result.Left + Result.Width - Round(Result.Width * Application.MainForm.Monitor.PixelsPerInch / 96); + Result.Top := Round(Result.Top * Application.MainForm.Monitor.PixelsPerInch / 96); + end + else + begin + Result.Height := Round(Result.Height * Screen.PixelsPerInch / 96); + // The button is right aligned so move the left side + Result.Left := Result.Left + Result.Width - Round(Result.Width * Screen.PixelsPerInch / 96); + Result.Top := Round(Result.Top * Screen.PixelsPerInch / 96); + end; + {$ENDIF} + end; +end; + +function TSysDialogStyleHook.GetHitTest(const P: TPoint): Integer; +begin + Result := HTCAPTION; + if CloseButtonRect.Contains(P) then + Result := HTCLOSE; + if MaxButtonRect.Contains(P) then + Result := HTMAXBUTTON; + if MinButtonRect.Contains(P) then + Result := HTMINBUTTON; + if HelpButtonRect.Contains(P) then + Result := HTHELP; + + if Result <> HTCAPTION then + begin + if FHotButton <> Result then + begin + FHotButton := Result; + InvalidateNC; + end; + Exit; + end + else + begin + if FHotButton <> 0 then + begin + FHotButton := 0; + InvalidateNC; + end; + end; +end; + +function TSysDialogStyleHook.GetMaxButtonRect: TRect; +var + FButtonState: TThemedWindow; + LDetails: TThemedElementDetails; +begin + Result := Rect(0, 0, 0, 0); + if (biMaximize in BorderIcons) and (biSystemMenu in BorderIcons) and (BorderStyle <> bsDialog) and (BorderStyle <> bsToolWindow) and (BorderStyle <> bsSizeToolWin) then + begin + if WindowState = wsMaximized then + begin + if (FPressedButton = HTMAXBUTTON) and (FHotButton = HTMAXBUTTON) then + FButtonState := twRestoreButtonPushed + else if FHotButton = HTMAXBUTTON then + FButtonState := twRestoreButtonHot + else if FFrameActive then + FButtonState := twRestoreButtonNormal + else + FButtonState := twRestoreButtonDisabled; + end + else + begin + if (FPressedButton = HTMAXBUTTON) and (FHotButton = HTMAXBUTTON) then + FButtonState := twMaxButtonPushed + else if FHotButton = HTMAXBUTTON then + FButtonState := twMaxButtonHot + else if FFrameActive then + FButtonState := twMaxButtonNormal + else + FButtonState := twMaxButtonDisabled; + end; + LDetails := StyleServices.GetElementDetails(FButtonState); + + if not StyleServices.GetElementContentRect(0, LDetails, CaptionRect, Result) then + Result := Rect(0, 0, 0, 0); + + {$IF (CompilerVersion >= 34)} + if Assigned(Application.Mainform) then + begin + Result.Height := Round(Result.Height * Application.MainForm.Monitor.PixelsPerInch / 96); + // The button is right aligned so move the left side + Result.Left := Result.Left + Result.Width - Round(Result.Width * Application.MainForm.Monitor.PixelsPerInch / 96); + Result.Top := Round(Result.Top * Application.MainForm.Monitor.PixelsPerInch / 96); + end + else + begin + Result.Height := Round(Result.Height * Screen.PixelsPerInch / 96); + // The button is right aligned so move the left side + Result.Left := Result.Left + Result.Width - Round(Result.Width * Screen.PixelsPerInch / 96); + Result.Top := Round(Result.Top * Screen.PixelsPerInch / 96); + end; + {$ENDIF} + end; +end; + +function TSysDialogStyleHook.GetMinButtonRect: TRect; +var + FButtonState: TThemedWindow; + LDetails: TThemedElementDetails; +begin + Result := Rect(0, 0, 0, 0); + if (biMinimize in BorderIcons) and (biSystemMenu in BorderIcons) and (BorderStyle <> bsDialog) and (BorderStyle <> bsToolWindow) and (BorderStyle <> bsSizeToolWin) then + begin + if (FPressedButton = HTMINBUTTON) and (FHotButton = HTMINBUTTON) then + FButtonState := twMinButtonPushed + else if FHotButton = HTMINBUTTON then + FButtonState := twMinButtonHot + else if FFrameActive then + FButtonState := twMinButtonNormal + else + FButtonState := twMinButtonDisabled; + + LDetails := StyleServices.GetElementDetails(FButtonState); + + if not StyleServices.GetElementContentRect(0, LDetails, CaptionRect, Result) then + Result := Rect(0, 0, 0, 0); + + {$IF (CompilerVersion >= 34)} + if Assigned(Application.Mainform) then + begin + Result.Height := Round(Result.Height * Application.MainForm.Monitor.PixelsPerInch / 96); + // The button is right aligned so move the left side + Result.Left := Result.Left + Result.Width - Round(Result.Width * Application.MainForm.Monitor.PixelsPerInch / 96); + Result.Top := Round(Result.Top * Application.MainForm.Monitor.PixelsPerInch / 96); + end + else + begin + Result.Height := Round(Result.Height * Screen.PixelsPerInch / 96); + // The button is right aligned so move the left side + Result.Left := Result.Left + Result.Width - Round(Result.Width * Screen.PixelsPerInch / 96); + Result.Top := Round(Result.Top * Screen.PixelsPerInch / 96); + end; + {$ENDIF} + end; + +end; + +function TSysDialogStyleHook.GetWindowState: TWindowState; +begin + Result := wsNormal; + if IsZoomed(Handle) then + Result := wsMaximized; + if IsIconic(Handle) then + Result := wsMinimized; +end; + +procedure TSysDialogStyleHook.Help; +begin + SendMessage(Handle, WM_SYSCOMMAND, SC_CONTEXTHELP, 0) +end; + +function TSysDialogStyleHook.IsSysCloseButtonDisabled: Boolean; +var + i, ID: Integer; +begin + Result := True; + if SysMenu > 0 then + begin + for i := 0 to GetMenuItemCount(SysMenu) - 1 do + begin + ID := GetMenuItemID(SysMenu, i); + if ID = SC_CLOSE then + begin + Result := False; + Exit; + end; + end; + end; +end; + +procedure TSysDialogStyleHook.Maximize; +begin + if Handle <> 0 then + begin + FPressedButton := 0; + FHotButton := 0; + + if IsZoomed(Handle) then + SendMessage(Handle, WM_SYSCOMMAND, SC_RESTORE, 0) + else + SendMessage(Handle, WM_SYSCOMMAND, SC_MAXIMIZE, 0); + end; +end; + +procedure TSysDialogStyleHook.Minimize; +begin + if Handle <> 0 then + begin + FPressedButton := 0; + FHotButton := 0; + if IsIconic(Handle) then + SendMessage(Handle, WM_SYSCOMMAND, SC_RESTORE, 0) + else + SendMessage(Handle, WM_SYSCOMMAND, SC_MINIMIZE, 0); + end; +end; + +procedure TSysDialogStyleHook.Paint(Canvas: TCanvas); +begin + inherited; + PaintBackground(Canvas); +end; + +procedure TSysDialogStyleHook.PaintBackground(Canvas: TCanvas); +begin + inherited; +end; + +function TSysDialogStyleHook.GetBorderIcons: TBorderIcons; +begin + Result := []; + with SysControl do + begin + if (Style and WS_SYSMENU = WS_SYSMENU) then + Include(Result, biSystemMenu); + if (Style and WS_MAXIMIZEBOX = WS_MAXIMIZEBOX) then + Include(Result, biMaximize); + if (Style and WS_MINIMIZEBOX = WS_MINIMIZEBOX) then + Include(Result, biMinimize); + if (ExStyle and WS_EX_CONTEXTHELP = WS_EX_CONTEXTHELP) and (not(biMaximize in Result)) and (not(biMinimize in Result)) then + Include(Result, biHelp); + end; +end; + +function TSysDialogStyleHook.GetBorderSize: TRect; +var + Size: TSize; + Details: TThemedElementDetails; + Detail: TThemedWindow; +begin + { + Result.Left = Left border width + Result.Top = Caption height + Result.Right = Right border width + Result.Bottom = Bottom border height + } + Result := Rect(0, 0, 0, 0); + if BorderStyle = bsNone then + Exit; + + if not StyleServices.Available then + Exit; + { Caption height } + if not UseSmallBorder then + Detail := twCaptionActive + else + Detail := twSmallCaptionActive; + Details := StyleServices.GetElementDetails(Detail); + StyleServices.GetElementSize(0, Details, esActual, Size); + {$IF (CompilerVersion >= 34)} + if Assigned(Application.Mainform) then + Result.Top := Round(Size.cy * Application.MainForm.Monitor.PixelsPerInch / 96) + else + Result.Top := Round(Size.cy * Screen.PixelsPerInch / 96); + {$ELSE} + Result.Top := Size.cy; + {$ENDIF} + { Left border width } + if not UseSmallBorder then + Detail := twFrameLeftActive + else + Detail := twSmallFrameLeftActive; + Details := StyleServices.GetElementDetails(Detail); + StyleServices.GetElementSize(0, Details, esActual, Size); + Result.Left := Size.cx; + { Right border width } + if not UseSmallBorder then + Detail := twFrameRightActive + else + Detail := twSmallFrameRightActive; + Details := StyleServices.GetElementDetails(Detail); + StyleServices.GetElementSize(0, Details, esActual, Size); + Result.Right := Size.cx; + { Bottom border height } + if not UseSmallBorder then + Detail := twFrameBottomActive + else + Detail := twSmallFrameBottomActive; + Details := StyleServices.GetElementDetails(Detail); + StyleServices.GetElementSize(0, Details, esActual, Size); + Result.Bottom := Size.cy; +end; + +function TSysDialogStyleHook.GetBorderStyle: TFormBorderStyle; +begin + Result := bsNone; + if not UpdateRegion then + Exit(bsNone); + with SysControl do + begin + if (Style and WS_OVERLAPPED = WS_OVERLAPPED) or (Style and WS_OVERLAPPEDWINDOW = WS_OVERLAPPEDWINDOW) or (Style and WS_CAPTION = WS_CAPTION) or + (ExStyle and WS_EX_OVERLAPPEDWINDOW = WS_EX_OVERLAPPEDWINDOW) and (ExStyle and WS_EX_TOOLWINDOW <> WS_EX_TOOLWINDOW) then + begin + if (Style and WS_SIZEBOX <> WS_SIZEBOX) and ((Style and WS_MINIMIZEBOX = WS_MAXIMIZE) or (Style and WS_MINIMIZEBOX = WS_MINIMIZEBOX)) then + Result := bsSingle; + + if (Style and WS_SIZEBOX <> WS_SIZEBOX) and (Style and WS_MINIMIZEBOX <> WS_MAXIMIZE) and (Style and WS_MINIMIZEBOX <> WS_MINIMIZEBOX) then + Result := bsDialog; + + if (Style and WS_SIZEBOX = WS_SIZEBOX) then + Result := bsSizeable; + end + else if (ExStyle and WS_EX_TOOLWINDOW = WS_EX_TOOLWINDOW) then + begin + if (Style and WS_SIZEBOX = WS_SIZEBOX) then + Result := bsSizeToolWin + else + Result := bsToolWindow; + end + else + Result := bsNone; + end; +end; + +function TSysDialogStyleHook.UseSmallBorder: Boolean; +begin + Result := (BorderStyle = bsToolWindow) or (BorderStyle = bsSizeToolWin); +end; + +function TSysDialogStyleHook.GetRegion: HRGN; +var + R: TRect; + LDetails: TThemedElementDetails; + Detail: TThemedWindow; +begin + Result := 0; + if not StyleServices.Available then + Exit; + { Get Window Region } + R := Rect(0, 0, SysControl.Width, SysControl.Height); + if not UseSmallBorder then + Detail := twCaptionActive + else + Detail := twSmallCaptionActive; + + DeleteObject(FRegion); + LDetails := StyleServices.GetElementDetails(Detail); + if not StyleServices.GetElementRegion(LDetails, R, Result) then + FRegion := 0; +end; + +function TSysDialogStyleHook.GetSysMenu: HMENU; +begin + Result := GetSystemMenu(Handle, False); +end; + +function TSysDialogStyleHook.GetSysMenuButtonRect: TRect; +var + LBorderIcons: TBorderIcons; + LBorderStyle: TBorderStyle; + IconDetails: TThemedElementDetails; + ButtonRect, R: TRect; +begin + Result := Rect(0, 0, 0, 0); + LBorderStyle := BorderStyle; + LBorderIcons := BorderIcons; + if (biSystemMenu in LBorderIcons) and (LBorderStyle <> bsDialog) and (LBorderStyle <> bsToolWindow) and (LBorderStyle <> bsSizeToolWin) then + begin + IconDetails := StyleServices.GetElementDetails(twSysButtonNormal); + if not StyleServices.GetElementContentRect(0, IconDetails, CaptionRect, ButtonRect) then + ButtonRect := Rect(0, 0, 0, 0); + + R := Rect(0, 0, GetSysMetrics(SM_CXSMICON), GetSysMetrics(SM_CYSMICON)); + RectVCenter(R, ButtonRect); + Result := R; + end; + +end; + +function TSysDialogStyleHook.GetUpdateRegion: Boolean; +begin + with SysControl do + Result := not((Style and WS_CAPTION <> WS_CAPTION) and (Style and WS_SYSMENU <> WS_SYSMENU) and (Style and WS_SIZEBOX <> WS_SIZEBOX)); +end; + +function TSysDialogStyleHook.GetIconFast: TIcon; +begin + if (FIcon = nil) or (FIconHandle = 0) then + Result := GetIcon + else + Result := FIcon; +end; + +function TSysDialogStyleHook.GetIcon: TIcon; +var + IconX, IconY: Integer; + TmpHandle: THandle; + Info: TWndClassEx; + Buffer: array [0 .. 255] of Char; +begin + TmpHandle := 0; + + {$IF (CompilerVersion >= 33)} + if Assigned(Application.Mainform) and (Application.MainForm.Monitor.PixelsPerInch <> Screen.PixelsPerInch) then + TmpHandle := Application.Icon.Handle; + {$ENDIF} + + if TmpHandle = 0 then + TmpHandle := THandle(SendMessage(Handle, WM_GETICON, ICON_SMALL, 0)); + + if TmpHandle = 0 then + TmpHandle := THandle(SendMessage(Handle, WM_GETICON, ICON_BIG, 0)); + + if TmpHandle = 0 then + TmpHandle := THandle(SendMessage(Handle, WM_GETICON, ICON_SMALL2, 0)); + + if TmpHandle = 0 then + begin + { Get instance } + GetClassName(Handle, @Buffer, sizeof(Buffer)); + FillChar(Info, sizeof(Info), 0); + Info.cbSize := sizeof(Info); + + if GetClassInfoEx(GetWindowLong(Handle, GWL_HINSTANCE), @Buffer, Info) then + begin + TmpHandle := Info.hIconSm; + if TmpHandle = 0 then + TmpHandle := Info.HICON; + end + end; + + if FIcon = nil then + FIcon := TIcon.Create; + if TmpHandle <> 0 then + begin + IconX := GetSysMetrics(SM_CXSMICON); + if IconX = 0 then + IconX := GetSystemMetrics(SM_CXSIZE); + IconY := GetSysMetrics(SM_CYSMICON); + if IconY = 0 then + IconY := GetSystemMetrics(SM_CYSIZE); + FIcon.Handle := CopyImage(TmpHandle, IMAGE_ICON, IconX, IconY, 0); + FIconHandle := TmpHandle; + end; + + Result := FIcon; +end; + +procedure TSysDialogStyleHook.PaintNC(Canvas: TCanvas); +var + LDetails: TThemedElementDetails; + CaptionBmp: TBitmap; + DC: HDC; + FButtonState: TThemedWindow; + LCaptionRect, LBorderSize, R: TRect; + ButtonRect, TextRect: TRect; + TextTopOffset: Integer; + IconDetails: TThemedElementDetails; + LBorderIcons: TBorderIcons; + LBorderStyle: TFormBorderStyle; + CaptionDetails: TThemedElementDetails; + TextFormat: TTextFormat; + LText: String; + nPos: Integer; + LSysMenu: HMENU; + ItemDisabled: Boolean; +begin + LBorderStyle := BorderStyle; + if (LBorderStyle = bsNone) or (WindowState = wsMinimized) then // (WindowState=wsMinimized) avoid bug in windows 8.1 and increase performance + Exit; + + LBorderIcons := BorderIcons; + LCaptionRect := CaptionRect; + CaptionBmp := TBitmap.Create; + CaptionBmp.SetSize(LCaptionRect.Width, LCaptionRect.Height); + DC := CaptionBmp.Canvas.Handle; + TextTopOffset := 0; + TextRect := Rect(0, 0, 0, 0);; + ButtonRect := Rect(0, 0, 0, 0);; + FCaptionRect := Rect(0, 0, 0, 0); + R := Rect(0, 0, 0, 0); + + { Caption } + if FFrameActive then + begin + if not UseSmallBorder then + LDetails := StyleServices.GetElementDetails(twCaptionActive) + else + LDetails := StyleServices.GetElementDetails(twSmallCaptionActive); + end + else + begin + if not UseSmallBorder then + LDetails := StyleServices.GetElementDetails(twCaptionInActive) + else + LDetails := StyleServices.GetElementDetails(twSmallCaptionInActive); + end; + CaptionDetails := LDetails; + DrawStyleElement(DC, LDetails, LCaptionRect); + + { Draw icon } + + if (biSystemMenu in LBorderIcons) and (LBorderStyle <> bsDialog) and (LBorderStyle <> bsToolWindow) and (LBorderStyle <> bsSizeToolWin) then + begin + IconDetails := StyleServices.GetElementDetails(twSysButtonNormal); + if not StyleServices.GetElementContentRect(0, IconDetails, LCaptionRect, ButtonRect) then + ButtonRect := Rect(0, 0, 0, 0); + + {$IF (CompilerVersion >= 34)} + if Assigned(Application.Mainform) then + begin + ButtonRect.Top := Round(ButtonRect.Top * Application.MainForm.Monitor.PixelsPerInch / 96); + ButtonRect.Height := Round(ButtonRect.Height * Application.MainForm.Monitor.PixelsPerInch / 96); + ButtonRect.Width := Round(ButtonRect.Width * Application.MainForm.Monitor.PixelsPerInch / 96); + end + else + begin + ButtonRect.Top := Round(ButtonRect.Top * Screen.PixelsPerInch / 96); + ButtonRect.Height := Round(ButtonRect.Height * Screen.PixelsPerInch / 96); + ButtonRect.Width := Round(ButtonRect.Width * Screen.PixelsPerInch / 96); + end; + {$ENDIF} + + R := Rect(0, 0, GetSysMetrics(SM_CXSMICON), GetSysMetrics(SM_CYSMICON)); + RectVCenter(R, ButtonRect); + + if ButtonRect.Width > 0 then + DrawIconEx(CaptionBmp.Canvas.Handle, R.Left, R.Top, GetIconFast.Handle, 0, 0, 0, 0, DI_NORMAL); + Inc(TextRect.Left, ButtonRect.Width + 8); + FSysMenuButtonRect := ButtonRect; + end + else + Inc(TextRect.Left, 8); + + { Draw buttons } + LSysMenu := GetSystemMenu(Handle, False); + nPos := GetMenuItemPos(LSysMenu, SC_CLOSE); + ItemDisabled := IsItemDisabled(LSysMenu, nPos); + if (biSystemMenu in LBorderIcons) and (not ItemDisabled) then + begin + if not UseSmallBorder then + begin + if (FPressedButton = HTCLOSE) and (FHotButton = HTCLOSE) then + FButtonState := twCloseButtonPushed + else if FHotButton = HTCLOSE then + FButtonState := twCloseButtonHot + else if FFrameActive then + FButtonState := twCloseButtonNormal + else + FButtonState := twCloseButtonDisabled; + end + else + begin + if (FPressedButton = HTCLOSE) and (FHotButton = HTCLOSE) then + FButtonState := twSmallCloseButtonPushed + else if FHotButton = HTCLOSE then + FButtonState := twSmallCloseButtonHot + else if FFrameActive then + FButtonState := twSmallCloseButtonNormal + else + FButtonState := twSmallCloseButtonDisabled; + end; + if FSysCloseButtonDisabled then + begin + if UseSmallBorder then + LDetails := StyleServices.GetElementDetails(twSmallCloseButtonNormal) + else + LDetails := StyleServices.GetElementDetails(twCloseButtonNormal); + end + else + LDetails := StyleServices.GetElementDetails(FButtonState); + ButtonRect := CloseButtonRect; + if (ButtonRect.Width > 0) then + DrawStyleElement(CaptionBmp.Canvas.Handle, LDetails, ButtonRect); + + if ButtonRect.Left > 0 then + TextRect.Right := ButtonRect.Left; + end; + + if (biMaximize in LBorderIcons) and (biSystemMenu in LBorderIcons) and (LBorderStyle <> bsDialog) and (LBorderStyle <> bsToolWindow) and (LBorderStyle <> bsSizeToolWin) then + begin + if WindowState = wsMaximized then + begin + if (FPressedButton = HTMAXBUTTON) and (FHotButton = HTMAXBUTTON) then + FButtonState := twRestoreButtonPushed + else if FHotButton = HTMAXBUTTON then + FButtonState := twRestoreButtonHot + else if FFrameActive then + FButtonState := twRestoreButtonNormal + else + FButtonState := twRestoreButtonDisabled; + end + else + begin + if (FPressedButton = HTMAXBUTTON) and (FHotButton = HTMAXBUTTON) then + FButtonState := twMaxButtonPushed + else if FHotButton = HTMAXBUTTON then + FButtonState := twMaxButtonHot + else if FFrameActive then + FButtonState := twMaxButtonNormal + else + FButtonState := twMaxButtonDisabled; + end; + LDetails := StyleServices.GetElementDetails(FButtonState); + ButtonRect := MaxButtonRect; + + if ButtonRect.Width > 0 then + DrawStyleElement(CaptionBmp.Canvas.Handle, LDetails, ButtonRect); + if ButtonRect.Left > 0 then + TextRect.Right := ButtonRect.Left; + end; + + if (biMinimize in LBorderIcons) and (biSystemMenu in LBorderIcons) and (LBorderStyle <> bsDialog) and (LBorderStyle <> bsToolWindow) and (LBorderStyle <> bsSizeToolWin) then + begin + if (FPressedButton = HTMINBUTTON) and (FHotButton = HTMINBUTTON) then + FButtonState := twMinButtonPushed + else if FHotButton = HTMINBUTTON then + FButtonState := twMinButtonHot + else if FFrameActive then + FButtonState := twMinButtonNormal + else + FButtonState := twMinButtonDisabled; + + LDetails := StyleServices.GetElementDetails(FButtonState); + ButtonRect := MinButtonRect; + if ButtonRect.Width > 0 then + DrawStyleElement(CaptionBmp.Canvas.Handle, LDetails, ButtonRect); + if ButtonRect.Left > 0 then + TextRect.Right := ButtonRect.Left; + end; + + if (biHelp in LBorderIcons) and (biSystemMenu in LBorderIcons) and ((not(biMaximize in LBorderIcons) and not(biMinimize in LBorderIcons)) or (LBorderStyle = bsDialog)) then + begin + if (FPressedButton = HTHELP) and (FHotButton = HTHELP) then + FButtonState := twHelpButtonPushed + else if FHotButton = HTHELP then + FButtonState := twHelpButtonHot + else if FFrameActive then + FButtonState := twHelpButtonNormal + else + FButtonState := twHelpButtonDisabled; + LDetails := StyleServices.GetElementDetails(FButtonState); + + if not StyleServices.GetElementContentRect(0, LDetails, LCaptionRect, ButtonRect) then + ButtonRect := Rect(0, 0, 0, 0); + if ButtonRect.Width > 0 then + DrawStyleElement(CaptionBmp.Canvas.Handle, LDetails, ButtonRect); + + if ButtonRect.Left > 0 then + TextRect.Right := ButtonRect.Left; + end; + + // Draw background and buttons first, then caption text directly on the Canvas. + // This to make sure "right to left" caption is displayed properly + Canvas.Draw(0, 0, CaptionBmp); + + { draw text } + TextFormat := [tfLeft, tfSingleLine, tfVerticalCenter]; +// if SysControl.BidiMode = bmRightToLeft then +// Include(TextFormat, tfRtlReading); + // Important: Must retrieve Text prior to calling DrawText as it causes + // CaptionBuffer.Canvas to free its handle, making the outcome of the call + // to DrawText dependent on parameter evaluation order. + LText := SysControl.Text; + + if (WindowState = wsMaximized) // and (FormStyle <> fsMDIChild) + and (TextTopOffset <> 0) and (biSystemMenu in LBorderIcons) then + begin + Inc(TextRect.Left, R.Left); + MoveWindowOrg(Canvas.Handle, 0, TextTopOffset); + if Assigned(Application.Mainform) then + StyleServices.DrawText(Canvas.Handle, CaptionDetails, LText, TextRect, TextFormat, clRed{$IF RTLVersion > 32}, Application.MainForm.Monitor.PixelsPerInch{$IFEND}) + else + StyleServices.DrawText(Canvas.Handle, CaptionDetails, LText, TextRect, TextFormat, clRed{$IF RTLVersion > 32}, Screen.PixelsPerInch{$IFEND}); + MoveWindowOrg(Canvas.Handle, 0, -TextTopOffset); + end + else + begin + {$IF (CompilerVersion >= 33)} + if Assigned(Application.Mainform) then + StyleServices.DrawText(Canvas.Handle, CaptionDetails, LText, TextRect, TextFormat, clBlue, Application.MainForm.Monitor.PixelsPerInch) + else + StyleServices.DrawText(Canvas.Handle, CaptionDetails, LText, TextRect, TextFormat, clBlue, Screen.PixelsPerInch); + {$ELSE} + StyleServices.DrawText(Canvas.Handle, CaptionDetails, LText, TextRect, TextFormat); + {$ENDIF} + end; + + FCaptionRect := TextRect; + + CaptionBmp.Free; + + DC := Canvas.Handle; + LBorderSize := BorderSize; + + { Left Border } + if FFrameActive then + begin + if not UseSmallBorder then + LDetails := StyleServices.GetElementDetails(twFrameLeftActive) + else + LDetails := StyleServices.GetElementDetails(twSmallFrameLeftActive); + end + else + begin + if not UseSmallBorder then + LDetails := StyleServices.GetElementDetails(twFrameLeftInActive) + else + LDetails := StyleServices.GetElementDetails(twSmallFrameLeftInActive); + end; + + R := Rect(0, LCaptionRect.Height, LBorderSize.Left, SysControl.Height); + if SysControl.Width > LBorderSize.Left then + DrawStyleElement(DC, LDetails, R); + + { Right Border } + if FFrameActive then + begin + if not UseSmallBorder then + LDetails := StyleServices.GetElementDetails(twFrameRightActive) + else + LDetails := StyleServices.GetElementDetails(twSmallFrameRightActive); + end + else + begin + if not UseSmallBorder then + LDetails := StyleServices.GetElementDetails(twFrameRightInActive) + else + LDetails := StyleServices.GetElementDetails(twSmallFrameRightInActive); + end; + R := Rect(SysControl.Width - LBorderSize.Right, LCaptionRect.Height, SysControl.Width, SysControl.Height); + if SysControl.Width > LBorderSize.Right then + DrawStyleElement(DC, LDetails, R); + + { Bottom Border } + if FFrameActive then + begin + if not UseSmallBorder then + LDetails := StyleServices.GetElementDetails(twFrameBottomActive) + else + LDetails := StyleServices.GetElementDetails(twSmallFrameBottomActive); + end + else + begin + if not UseSmallBorder then + LDetails := StyleServices.GetElementDetails(twFrameBottomInActive) + else + LDetails := StyleServices.GetElementDetails(twSmallFrameBottomInActive); + end; + R := Rect(0, SysControl.Height - LBorderSize.Bottom, SysControl.Width, SysControl.Height); + DrawStyleElement(DC, LDetails, R); +end; + +procedure TSysDialogStyleHook.Restore; +begin + FPressedButton := 0; + FHotButton := 0; + if Handle <> 0 then + SendMessage(Handle, WM_SYSCOMMAND, SC_RESTORE, 0); +end; + +procedure TSysDialogStyleHook.WMNCACTIVATE(var Message: TWMNCActivate); +begin + Handled := False; + if not StyleServicesEnabled then + Exit; + + if not OverridePaintNC then + Exit; + + FFrameActive := Message.Active; + InvalidateNC; + Message.Result := 1; + Handled := True; +end; + +procedure TSysDialogStyleHook.WMNCCalcSize(var Message: TWMNCCalcSize); +begin + Handled := False; + if (not StyleServicesEnabled) or (not OverridePaintNC) then + Exit; + if (BorderStyle = bsNone) or (not UpdateRegion) then + Exit; + inherited; +end; + +function TSysDialogStyleHook.NormalizePoint(const P: TPoint): TPoint; +var + WindowPos, ClientPos: TPoint; + bsize: TRect; +begin + { Convert the point from the screen to the client window . } + WindowPos := Point(SysControl.Left, SysControl.Top); + ClientPos := Point(0, 0); + ClientToScreen(Handle, ClientPos); + if GetWindowLong(Handle, GWL_EXSTYLE) and WS_EX_LAYOUTRTL > 0 then + begin + bsize := BorderSize; + ClientPos.X := ClientPos.X - SysControl.Width + bsize.left + bsize.Right; + end; + Result := P; + ScreenToClient(Handle, Result); + Inc(Result.X, ClientPos.X - WindowPos.X); + Inc(Result.Y, ClientPos.Y - WindowPos.Y); +end; + +procedure TSysDialogStyleHook.WMNCHitTest(var Message: TWMNCHitTest); +var + P: TPoint; +begin + Handled := False; + if (not StyleServicesEnabled) or (not OverridePaintNC) then + Exit; + + if OverridePaintNC then + begin + P := Point(Message.XPos, Message.YPos); + P := NormalizePoint(P); + Message.Result := GetHitTest(P); + if ((Message.Result <> HTCLOSE) and (Message.Result <> HTMAXBUTTON) and (Message.Result <> HTMINBUTTON) and (Message.Result <> HTHELP)) then + begin + // Message.Result := CallDefaultProc(TMessage(Message)); + { Check if form can be scrolled . } + inherited; + { We need to correct the result after calling the default message . } + if ((Message.Result = HTCLOSE) or (Message.Result = HTMAXBUTTON) or (Message.Result = HTMINBUTTON) or (Message.Result = HTHELP)) then + Message.Result := HTCLIENT; + end; + Handled := True; + end; +end; + +procedure TSysDialogStyleHook.WMNCLButtonDown(var Message: TWMNCLButtonDown); +var + P: TPoint; +begin + Handled := False; + if (not StyleServicesEnabled) or (not OverridePaintNC) then + Exit; + + if OverridePaintNC then + begin + if (Message.HitTest = HTCLOSE) or (Message.HitTest = HTMAXBUTTON) or (Message.HitTest = HTMINBUTTON) or (Message.HitTest = HTHELP) then + begin + FPressedButton := Message.HitTest; + InvalidateNC; + SetRedraw(False); + { For some reason ,we can not handle the WMNCLBUTTONUP message .. + So we need to handle it inside the WMNCLBUTTONDOWN proc (this proc). + } + { Before handling the default message => this proc is WMNCLBUTTONDOWN } + Message.Result := CallDefaultProc(TMessage(Message)); + + { After handling the default message => this proc is WMNCLBUTTONUP } + + SetRedraw(True); + FPressedButton := 0; + FHotButton := 0; + InvalidateNC; + GetCursorPos(P); + P := NormalizePoint(P); + + case Message.HitTest of + HTCLOSE: + if CloseButtonRect.Contains(P) then + Close; + HTMAXBUTTON: + begin + if MaxButtonRect.Contains(P) then + begin + if WindowState = wsMaximized then + Restore + else + Maximize; + end; + end; + HTMINBUTTON: + if MinButtonRect.Contains(P) then + Minimize; + HTHELP: + if HelpButtonRect.Contains(P) then + Help; + end; + end + else + begin + inherited; + Handled := True; + Exit; + end; + Handled := True; + end; +end; + +procedure TSysDialogStyleHook.WMNCLButtonUp(var Message: TWMNCLButtonUp); +begin + { Reserved for potential updates . } + Handled := False; +end; + +procedure TSysDialogStyleHook.WMNCMouseMove(var Message: TWMNCHitMessage); +begin + { Reserved for potential updates . } + Handled := False; +end; + +procedure TSysDialogStyleHook.WMPaint(var Message: TMessage); +begin + if IsWindowMsgBox(Handle) and OverridePaint then + begin + inherited; + Exit; + end; + Message.Result := CallDefaultProc(Message); + Handled := True; +end; + +procedure TSysDialogStyleHook.WMSetText(var Message: TMessage); +var + FRedraw: Boolean; + LBorderStyle: TFormBorderStyle; +begin + LBorderStyle := BorderStyle; + if (LBorderStyle = bsNone) or (WindowState = wsMinimized) or (StyleServices.IsSystemStyle) then + begin + Handled := False; + Exit; + end; + + FRedraw := True; + + if IsWindowVisible(Handle) then + begin + //Application.ProcessMessages; + FRedraw := False; + SetRedraw(False); + end; + + CallDefaultProc(Message); + + if not FRedraw then + begin + SetRedraw(True); + InvalidateNC; + end; + Handled := True; +end; + + +procedure TSysDialogStyleHook.WMSIZE(var Message: TWMSize); +begin + Handled := False; + if (not StyleServicesEnabled) or (not OverridePaintNC) then + Exit; + + Message.Result := CallDefaultProc(TMessage(Message)); + + FRegion := GetRegion; + if (FRegion <> 0) and (BorderStyle <> bsNone) and UpdateRegion then + SetWindowRgn(Handle, FRegion, True); + Handled := True; +end; + +procedure TSysDialogStyleHook.WndProc(var Message: TMessage); +var + DFBW,DX: Integer; + LBorderSize: TRect; + LParentHandle: HWND; +begin + // Addlog(Format('TSysDialogStyleHook $0x%x %s', [SysControl.Handle, WM_To_String(Message.Msg)])); + case Message.msg of + + WM_WINDOWPOSCHANGED: + begin + FSysCloseButtonDisabled := IsSysCloseButtonDisabled; + end; + + WM_SHOWWINDOW: + begin + Message.Result := CallDefaultProc(Message); + { DFBW =Default Frame Border Width } + DFBW := GetSysMetrics(SM_CXSIZEFRAME) * 2; + //Inc(DFBW); + LBorderSize := GetBorderSize; + DX := LBorderSize.Left + LBorderSize.Right - 2*DFBW; + + // Adjust the window size if the vcl style border is smaller or larger + // than the default frame border is. + + if (DFBW <> LBorderSize.Left) then + SetWindowPos(Handle, 0, 0, 0, SysControl.Width + DX, SysControl.Height + DX + 1, SWP_NOMOVE or SWP_NOZORDER or SWP_FRAMECHANGED); + + // This code was moved from WM_CREATE: to be able to change TaskDialog, ColorDialog... sizes. + // E.g. the TaskDialog size is changed after creation to fit controls added to it. So in + // order to change its size - we need to do it here. + end; + + WM_DESTROY: + begin + { In some situations ..we can not get the ParentHandle + after processing the default WM_DESTROY message. + => Save the parent before calling the default message. + } + SysControl.Destroyed:=True; + //OutputDebugString(PChar(Format('TSysDialogStyleHook $0x%x %s', [SysControl.Handle, WM_To_String(Message.Msg)]))); + LParentHandle := ParentHandle; + + if (LParentHandle>0) and (TSysStyleManager.SysStyleHookList.ContainsKey(LParentHandle)) and TSysStyleManager.SysStyleHookList.Items[ParentHandle].SysControl.Destroyed then + Message.Result :=0 + else + Message.Result := CallDefaultProc(Message); + + if LParentHandle > 0 then + begin + { When destroying the child window .. + the parent window must be repainted . } + RedrawWindow(LParentHandle, nil, 0, RDW_ERASE or RDW_FRAME or RDW_INTERNALPAINT or RDW_INVALIDATE); + end; + + Handled := True; + end; + end; + inherited; +end; + +{ TSysScrollingStyleHook } +function TSysScrollingStyleHook.NormalizePoint(const P: TPoint): TPoint; +var + WindowPos, ClientPos: TPoint; +begin + { Convert the point from the screen to the client window . } + WindowPos := Point(SysControl.Left, SysControl.Top); + ClientPos := Point(0, 0); + ClientToScreen(Handle, ClientPos); + Result := P; + ScreenToClient(Handle, Result); + Inc(Result.X, ClientPos.X - WindowPos.X); + Inc(Result.Y, ClientPos.Y - WindowPos.Y); +end; + +procedure TSysScrollingStyleHook.CMSCROLLTRACKING(var Message: TMessage); +var + P: TPoint; + Pos, Delta: Integer; +begin + if (not OverridePaintNC) or (not StyleServicesEnabled) then + begin + Handled := False; + Exit; + end; + P.X := Int16(Message.LParam and $0000FFFF); + P.Y := Int16(Message.LParam shr 16); + if FScrollKind = sbVertical then + begin + if (P.Y >= 0) then + begin + Pos := GetVertScrollPosFromPoint(P); + FTrackingPos := GetVertThumbPosFromPos(Pos); + Delta := Pos - FPrevPos; + DrawVertScroll(0); { Draw & take Tracking account . } + { Do Scroll } + Scroll(sbVertical, skTracking, Pos, Delta); + FPrevPos := VertScrollInfo.nPos; + end; + end + else if FScrollKind = sbHorizontal then + begin + if (P.X >= 0) then + begin + Pos := GetHorzScrollPosFromPoint(P); + FTrackingPos := GetHorzThumbPosFromPos(Pos); + Delta := Pos - FPrevPos; + DrawHorzScroll(0); { Draw & take Tracking account . } + { Do Scroll } + Scroll(sbHorizontal, skTracking, Pos, Delta); + FPrevPos := HorzScrollInfo.nPos; + end; + end; + Handled := True; +end; + +constructor TSysScrollingStyleHook.Create(AHandle: THandle); +begin + inherited; + FTracking := False; + FNCMouseDown := False; + FAllowScrolling := True; + FTrackingPos := 0; + FTrackTimer := nil; + FPrevPoint := Point(-1, -1); + FPrevPos := 0; + InitScrollState; +end; + +destructor TSysScrollingStyleHook.Destroy; +begin + if Assigned(FTrackTimer) then + FreeAndNil(FTrackTimer); + inherited; +end; + +procedure TSysScrollingStyleHook.DoLineTrackTimer(Sender: TObject); +begin + Scroll(FScrollKind, FScrollingType, 0, 0); +end; + +procedure TSysScrollingStyleHook.DoPageTrackTimer(Sender: TObject); +var + P: TPoint; +begin + GetCursorPos(P); + if (not VertSliderRect.Contains(P)) and (not HorzSliderRect.Contains(P)) then + begin + DoScroll(FScrollKind, FScrollingType, 0, 0); + end; +end; + +procedure TSysScrollingStyleHook.DoScroll(const Kind: TScrollBarKind; const ScrollType: TSysScrollingType; Pos, Delta: Integer); +begin + if ScrollType <> skNone then + begin + Scroll(Kind, ScrollType, Pos, Delta); + FPrevPos := VertScrollInfo.nPos; + end; +end; + +procedure TSysScrollingStyleHook.DoSliderTrackTimer(Sender: TObject); +var + P: TPoint; +begin + GetCursorPos(P); + if (FPrevPoint <> P) and (FDownPoint <> P) then + begin + SendMessage(Handle, CM_SCROLLTRACKING, 0, PointToLParam(P)); + FPrevPoint := P; + FDownPoint := Point(-1, -1); + end; +end; + +procedure TSysScrollingStyleHook.DrawHorzScroll(DC: HDC); +var + LDetails: TThemedElementDetails; + R: TRect; + B: TBitmap; + BmpDC, LDC: HDC; + cx, cy, PosX, ThumbSize: Integer; + P: TPoint; + Detail: TThemedScrollBar; +begin + if not FHorzScrollBar then + Exit; + LDC := DC; + R := HorzScrollRect; + cx := BtnSize.cx; + cy := BtnSize.cy; + if R.Width > 0 then + begin + B := TBitmap.Create; + try + if DC = 0 then + DC := GetWindowDC(Handle); + + if FVertScrollBar then + begin + if not LeftScrollBar then + begin + P := Point(R.Right, R.Top); + P := NormalizePoint(P); + DrawSmallRect(DC, Rect(P.X, P.Y, P.X + cx, P.Y + cy)); + end + else + begin + P := Point(R.Left, R.Top); + P := NormalizePoint(P); + FillDC(DC, Rect(P.X - cx, P.Y, P.X, P.Y + cy), Color); + end; + end; + + B.SetSize(R.Width, R.Height); + BmpDC := B.Canvas.Handle; + + { Draw Track face } + Detail := tsUpperTrackHorzNormal; + if (not SysControl.Enabled) or (HorzScrollDisabled) then + Detail := tsUpperTrackHorzDisabled; + R := Rect(0, 0, B.Width, B.Height); + LDetails := StyleServices.GetElementDetails(Detail); + StyleServices.DrawElement(BmpDC, LDetails, R); + { Draw Left Button } + Detail := FBtnLeftDetail; + if (not SysControl.Enabled) or (HorzScrollDisabled) then + Detail := tsArrowBtnLeftDisabled; + R := Rect(0, 0, cx, cy); + LDetails := StyleServices.GetElementDetails(Detail); + StyleServices.DrawElement(BmpDC, LDetails, R); + { Draw Slider Button } + Detail := FHorzBtnSliderDetail; + if (not SysControl.Enabled) or (HorzScrollDisabled) then + Detail := tsThumbBtnHorzDisabled; + PosX := GetHorzSliderPos; + ThumbSize := GetHorzThumbSize; + if FTracking then + // R := Rect(cx + FTrackingPos, 0, cx + FTrackingPos + ThumbSize, cy) + R := FTrackingRect + else + R := Rect(cx + PosX, 0, cy + PosX + ThumbSize, cy); + if R.Left < cx then + R := Rect(cx, 0, cx + ThumbSize, cy); + if R.Right > (B.Width - cx) then + R := Rect(B.Width - cx - ThumbSize, 0, B.Width - cx, cy); + + LDetails := StyleServices.GetElementDetails(Detail); + if not HorzScrollDisabled then + StyleServices.DrawElement(BmpDC, LDetails, R); + + { Draw Right Button } + Detail := FBtnRightDetail; + if (not SysControl.Enabled) or (HorzScrollDisabled) then + Detail := tsArrowBtnRightDisabled; + //R := HorzRightRect; + R := Rect(B.Width - cx, 0, B.Width, cy); + LDetails := StyleServices.GetElementDetails(Detail); + StyleServices.DrawElement(BmpDC, LDetails, R); + finally + P.X := HorzScrollRect.Left; + P.Y := HorzScrollRect.Top; + P := NormalizePoint(P); + BitBlt(DC, P.X, P.Y, HorzScrollRect.Width, HorzScrollRect.Height, B.Canvas.Handle, 0, 0, SRCCOPY); + B.Free; + if LDC = 0 then + ReleaseDC(Handle, DC); + end; + end; + +end; + +procedure TSysScrollingStyleHook.DrawSmallRect(DC: HDC; const SmallRect: TRect); +var + sColor: TColor; +begin + sColor := StyleServices.GetStyleColor(scWindow); + FillDC(DC, SmallRect, sColor); +end; + +procedure TSysScrollingStyleHook.DrawVertScroll(DC: HDC); +var + LDetails: TThemedElementDetails; + R: TRect; + B: TBitmap; + BmpDC, LDC: HDC; + cx, cy, PosY, ThumbSize: Integer; + P: TPoint; + Detail: TThemedScrollBar; +begin + if not FVertScrollBar then + Exit; + LDC := DC; + R := VertScrollRect; + cx := BtnSize.cx; + cy := BtnSize.cy; + if R.Width > 0 then + begin + + B := TBitmap.Create; + try + if DC = 0 then + DC := GetWindowDC(Handle); + + B.SetSize(R.Width, R.Height); + BmpDC := B.Canvas.Handle; + + { Draw Track face } + R := Rect(0, 0, B.Width, B.Height); + Detail := tsUpperTrackVertNormal; + if (not SysControl.Enabled) or (VertScrollDisabled) then + Detail := tsUpperTrackHorzDisabled; + + LDetails := StyleServices.GetElementDetails(Detail); + StyleServices.DrawElement(BmpDC, LDetails, R); + + { Draw UpButton } + R := Rect(0, 0, cx, cy); + Detail := FBtnUpDetail; + if (not SysControl.Enabled) or (VertScrollDisabled) then + Detail := tsArrowBtnUpDisabled; + + LDetails := StyleServices.GetElementDetails(Detail); + StyleServices.DrawElement(BmpDC, LDetails, R); + + { Draw SliderButton } + PosY := GetVertSliderPos; + ThumbSize := GetVertThumbSize; + if FTracking then + // R := Rect(0, FTrackingPos, BtnSize.cx, FTrackingPos + GetVertThumbSize) + R := FTrackingRect + else + R := Rect(0, cy + PosY, cx, cy + PosY + ThumbSize); + if R.Top < cy then + R := Rect(0, cy, cx, cy + ThumbSize); + if R.Bottom > (B.Height - cy) then + R := Rect(0, B.Height - cy - ThumbSize, cx, B.Height - cy); + + Detail := FVertBtnSliderDetail; + if (not SysControl.Enabled) or (VertScrollDisabled) then + Detail := tsThumbBtnVertDisabled; + + LDetails := StyleServices.GetElementDetails(Detail); + if not VertScrollDisabled then + StyleServices.DrawElement(BmpDC, LDetails, R); + + { Draw DownButton } + R := Rect(0, B.Height - cy, cx, B.Height); + Detail := FBtnDownDetail; + if (not SysControl.Enabled) or (VertScrollDisabled) then + Detail := tsArrowBtnDownDisabled; + + LDetails := StyleServices.GetElementDetails(Detail); + StyleServices.DrawElement(BmpDC, LDetails, R); + finally + // Canvas.Draw(VertScrollRect.Left, VertScrollRect.Top, B); + P.X := VertScrollRect.Left; + P.Y := VertScrollRect.Top; + // ScreenToClient(Handle, P); + P := NormalizePoint(P); + BitBlt(DC, P.X, P.Y, VertScrollRect.Width, VertScrollRect.Height, B.Canvas.Handle, 0, 0, SRCCOPY); + B.Free; + if LDC = 0 then + ReleaseDC(Handle, DC); + end; + end; +end; + +function TSysScrollingStyleHook.GetDefaultScrollBarSize: TSize; +begin + { Return the default ScrollBar button size . } + Result.cx := GetSysMetrics(SM_CXVSCROLL); + Result.cy := GetSysMetrics(SM_CYVSCROLL); +end; + +function TSysScrollingStyleHook.GetHorzLeftRect: TRect; +begin + with HorzScrollRect do + Result := Rect(Left, Top, Left + BtnSize.cx, Bottom); +end; + +function TSysScrollingStyleHook.GetHorzScrollInfo: TScrollInfo; +begin + FillChar(Result, sizeof(TScrollInfo), Char(0)); + Result.cbSize := sizeof(TScrollInfo); + Result.fMask := SIF_ALL; + Winapi.Windows.GetScrollInfo(Handle, SB_HORZ, Result); +end; + +function TSysScrollingStyleHook.GetHorzScrollPosFromPoint(const P: TPoint): Integer; +var + TrackRect, WinRect: TRect; + Pos, MaxMin: Integer; + LInfo: TScrollInfo; + ThumbSize: Integer; +begin + LInfo := HorzScrollInfo; + Pos := P.X - FDownDis; + WinRect := SysControl.WindowRect; + TrackRect := HorzTrackRect; + Dec(Pos, WinRect.Left); + ThumbSize := GetHorzThumbSize; + OffsetRect(TrackRect, -WinRect.Left, -WinRect.Top); + + FTrackingRect := Rect(Pos, 0, Pos + ThumbSize, BtnSize.cy); + + MaxMin := LInfo.nMax - LInfo.nMin; + if MaxMin > 0 then + Pos := MulDiv(Pos - TrackRect.Left, MaxMin - Integer(LInfo.nPage) + 1, TrackRect.Width - ThumbSize) + else + Pos := Pos - TrackRect.Left; + if Pos < 0 then + Pos := 0; + if Pos >= LInfo.nMax - (Integer(LInfo.nPage) - 1) then + Pos := LInfo.nMax - (Integer(LInfo.nPage) - 1); + Result := Pos; +end; + +function TSysScrollingStyleHook.GetHorzScrollRect: TRect; +var + WinRect: TRect; + BorderSize: TRect; +begin + Result := Rect(0, 0, 0, 0); + WinRect := SysControl.WindowRect; + BorderSize := GetBorderSize; + with WinRect do + begin + Result.Left := Left; + Result.Right := Right; + Result.Top := Bottom - BtnSize.cy; + Result.Bottom := Result.Top + BtnSize.cy; + end; + if (BorderSize.Left > 0) or (BorderSize.Top > 0) or (BorderSize.Right > 0) or (BorderSize.Bottom > 0) then + begin + Result.Left := Result.Left + BorderSize.Left; + Result.Right := Result.Right - BorderSize.Right; + Result.Bottom := Result.Bottom - BorderSize.Bottom; + Result.Top := Result.Bottom - BtnSize.cy; + end; + if FVertScrollBar then + begin + if not LeftScrollBar then + Dec(Result.Right, BtnSize.cx) + else + Inc(Result.Left, BtnSize.cx) + end; +end; + +function TSysScrollingStyleHook.GetHorzSliderPos: Integer; +begin + with HorzScrollInfo do + Result := MulDiv(nPos, HorzTrackRect.Width, nMax - nMin); +end; + +function TSysScrollingStyleHook.GetHorzSliderRect: TRect; +var + ThumbSize: Integer; + PosX: Integer; +begin + Result := Rect(0, 0, 0, 0); + ThumbSize := GetHorzThumbSize; + PosX := MulDiv(HorzScrollInfo.nPos, HorzTrackRect.Width, HorzScrollInfo.nMax - HorzScrollInfo.nMin); + with HorzTrackRect do + Result := Rect(Left + PosX, Top, Left + PosX + ThumbSize, Bottom); +end; + +function TSysScrollingStyleHook.GetHorzThumbPosFromPos(const Pos: Integer): Integer; +var + PosX: Integer; +begin + with HorzScrollInfo do + begin + PosX := MulDiv(Pos, HorzTrackRect.Width, nMax - nMin); + Result := PosX + BtnSize.cx; + end; +end; + +function TSysScrollingStyleHook.GetHorzThumbSize: Integer; +begin + with HorzScrollInfo do + begin + Result := MulDiv(nPage, HorzScrollRect.Width - (2 * BtnSize.cx), nMax - nMin); + if Result < BtnSize.cy then + Result := BtnSize.cy; + end; +end; + +function TSysScrollingStyleHook.GetHorzTrackRect: TRect; +begin + Result := HorzScrollRect; + if Result.Width > 0 then + begin + Result.Left := Result.Left + GetSysMetrics(SM_CXHTHUMB); + Result.Right := Result.Right - GetSysMetrics(SM_CXHTHUMB); + end + else + Result := Rect(0, 0, 0, 0); +end; + +function TSysScrollingStyleHook.GetVertTrackRect: TRect; +begin + Result := VertScrollRect; + if Result.Width > 0 then + begin + Result.Top := Result.Top + GetSysMetrics(SM_CYVTHUMB); + Result.Bottom := Result.Bottom - GetSysMetrics(SM_CYVTHUMB); + end + else + Result := Rect(0, 0, 0, 0); +end; + +function TSysScrollingStyleHook.GetVertDownRect: TRect; +begin + with VertScrollRect do + Result := Rect(Left, Bottom - BtnSize.cy, Right, Bottom); +end; + +function TSysScrollingStyleHook.GetHorzRightRect: TRect; +begin + with HorzScrollRect do + Result := Rect(Right - BtnSize.cx, Top, Right, Bottom); +end; + +function TSysScrollingStyleHook.GetVertScrollRect: TRect; +var + WinRect: TRect; + BorderSize: TRect; +begin + Result := Rect(0, 0, 0, 0); + WinRect := SysControl.WindowRect; + BorderSize := GetBorderSize; + with WinRect do + begin + if not LeftScrollBar then + begin + Result.Left := Right - BtnSize.cx; + Result.Right := Result.Left + BtnSize.cx; + Result.Top := Top; + Result.Bottom := Bottom; + end + else + begin + Result.Left := Left; + Result.Right := Left + BtnSize.cx; + Result.Top := Top; + Result.Bottom := Bottom; + end; + end; + if (BorderSize.Left >= 0) or (BorderSize.Top >= 0) or (BorderSize.Right >= 0) or (BorderSize.Bottom >= 0) then + begin + if not LeftScrollBar then + begin + Result.Left := Result.Left - BorderSize.Right; + Result.Right := Result.Left + BtnSize.cx; + Result.Top := Result.Top + BorderSize.Top; + Result.Bottom := Result.Bottom - BorderSize.Bottom; + end + else + begin + Result.Left := Result.Left + BorderSize.Left; + Result.Right := Result.Left + BtnSize.cx; + Result.Top := Result.Top + BorderSize.Top; + Result.Bottom := Result.Bottom - BorderSize.Bottom; + end; + end; + if FHorzScrollBar then + Dec(Result.Bottom, BtnSize.cy); +end; + +function TSysScrollingStyleHook.GetVertScrollInfo: TScrollInfo; +begin + FillChar(Result, sizeof(TScrollInfo), Char(0)); + Result.cbSize := sizeof(TScrollInfo); + Result.fMask := SIF_ALL; + Winapi.Windows.GetScrollInfo(Handle, SB_VERT, Result); +end; + +function TSysScrollingStyleHook.GetVertScrollPosFromPoint(const P: TPoint): Integer; +var + TrackRect, WinRect: TRect; + Pos, MaxMin: Integer; + LInfo: TScrollInfo; + ThumbSize: Integer; +begin + LInfo := VertScrollInfo; + Pos := P.Y - FDownDis; + WinRect := SysControl.WindowRect; + TrackRect := VertTrackRect; + OffsetRect(TrackRect, -WinRect.Left, -WinRect.Top); + Dec(Pos, WinRect.Top); + ThumbSize := GetVertThumbSize; + + FTrackingRect := Rect(0, Pos, BtnSize.cx, Pos + ThumbSize); + + MaxMin := LInfo.nMax - LInfo.nMin; + if MaxMin > 0 then + Pos := MulDiv(Pos - TrackRect.Top, MaxMin - Integer(LInfo.nPage) + 2, (TrackRect.Height) - ThumbSize) + else + Pos := Pos - TrackRect.Top; + if Pos < 0 then + Pos := 0; + if Pos >= LInfo.nMax - (Integer(LInfo.nPage) - 1) then + Pos := LInfo.nMax - (Integer(LInfo.nPage) - 1); + + Result := Pos; +end; + +function TSysScrollingStyleHook.GetVertSliderPos: Integer; +begin + with VertScrollInfo do + Result := MulDiv(nPos, VertTrackRect.Height, nMax - nMin); +end; + +function TSysScrollingStyleHook.GetVertSliderRect: TRect; +var + ThumbSize: Integer; + PosY: Integer; +begin + Result := Rect(0, 0, 0, 0); + ThumbSize := GetVertThumbSize; + PosY := MulDiv(VertScrollInfo.nPos, VertTrackRect.Height, VertScrollInfo.nMax - VertScrollInfo.nMin); + with VertTrackRect do + Result := Rect(Left, Top + PosY, Right, Top + PosY + ThumbSize); +end; + +function TSysScrollingStyleHook.GetVertThumbPosFromPos(const Pos: Integer): Integer; +var + PosY: Integer; +begin + with VertScrollInfo do + begin + PosY := MulDiv(Pos, VertTrackRect.Height, nMax - nMin); + Result := PosY + BtnSize.cy; + end; +end; + +function TSysScrollingStyleHook.GetVertThumbSize: Integer; +begin + with VertScrollInfo do + begin + Result := MulDiv(nPage, VertTrackRect.Height, nMax - nMin); + if Result < BtnSize.cy then + Result := BtnSize.cy; + end; +end; + +function TSysScrollingStyleHook.GetVertUpRect: TRect; +begin + with VertScrollRect Do + Result := Rect(Left, Top, Right, Top + BtnSize.cy); +end; + +procedure TSysScrollingStyleHook.InitScrollState; +begin + FBtnUpDetail := tsArrowBtnUpNormal; + FBtnDownDetail := tsArrowBtnDownNormal; + FVertBtnSliderDetail := tsThumbBtnVertNormal; + FBtnLeftDetail := tsArrowBtnLeftNormal; + FBtnRightDetail := tsArrowBtnRightNormal; + FHorzBtnSliderDetail := tsThumbBtnHorzNormal; +end; + +function TSysScrollingStyleHook.IsHorzScrollDisabled: Boolean; +begin + if FHorzScrollBar then + begin + with HorzScrollInfo do + Result := (Integer(nPage) > nMax); + end + else + Result := False; +end; + +function TSysScrollingStyleHook.IsLeftScrollBar: Boolean; +begin + Result := (SysControl.ExStyle and WS_EX_LEFTSCROLLBAR = WS_EX_LEFTSCROLLBAR); +end; + +function TSysScrollingStyleHook.IsVertScrollDisabled: Boolean; +begin + if FVertScrollBar then + begin + with VertScrollInfo do + Result := (Integer(nPage) > nMax); + end + else + Result := False; +end; + +procedure TSysScrollingStyleHook.MouseEnter; +begin + if FVertScrollBar and (not FNCMouseDown) and (not VertScrollDisabled) then + begin + if (FBtnUpDetail <> tsArrowBtnUpNormal) or (FBtnDownDetail <> tsArrowBtnDownNormal) or (FVertBtnSliderDetail <> tsThumbBtnVertNormal) then + begin + FBtnUpDetail := tsArrowBtnUpNormal; + FBtnDownDetail := tsArrowBtnDownNormal; + FVertBtnSliderDetail := tsThumbBtnVertNormal; + DrawVertScroll(0); + end; + end; + if FHorzScrollBar and (not FNCMouseDown) and (not HorzScrollDisabled) then + begin + if (FBtnLeftDetail <> tsArrowBtnLeftNormal) or (FBtnRightDetail <> tsArrowBtnRightNormal) or (FHorzBtnSliderDetail <> tsThumbBtnHorzNormal) then + begin + FBtnLeftDetail := tsArrowBtnLeftNormal; + FBtnRightDetail := tsArrowBtnRightNormal; + FHorzBtnSliderDetail := tsThumbBtnHorzNormal; + DrawHorzScroll(0); + end; + end; +end; + +procedure TSysScrollingStyleHook.MouseLeave; +begin + if not FNCMouseDown then + begin + if FVertScrollBar and not VertScrollDisabled then + begin + if (FBtnUpDetail <> tsArrowBtnUpNormal) or (FBtnDownDetail <> tsArrowBtnDownNormal) or (FVertBtnSliderDetail <> tsThumbBtnVertNormal) then + begin + FBtnUpDetail := tsArrowBtnUpNormal; + FBtnDownDetail := tsArrowBtnDownNormal; + FVertBtnSliderDetail := tsThumbBtnVertNormal; + DrawVertScroll(0); + end; + end; + if FHorzScrollBar and not HorzScrollDisabled then + begin + if (FBtnLeftDetail <> tsArrowBtnLeftNormal) or (FBtnRightDetail <> tsArrowBtnRightNormal) or (FHorzBtnSliderDetail <> tsThumbBtnHorzNormal) then + begin + FBtnLeftDetail := tsArrowBtnLeftNormal; + FBtnRightDetail := tsArrowBtnRightNormal; + FHorzBtnSliderDetail := tsThumbBtnHorzNormal; + DrawHorzScroll(0); + end; + end; + end; +end; + +procedure TSysScrollingStyleHook.PaintNC(Canvas: TCanvas); +begin + if (Canvas.HandleAllocated) and (not FTracking) then + begin + if FVertScrollBar then + DrawVertScroll(Canvas.Handle); + if FHorzScrollBar then + DrawHorzScroll(Canvas.Handle); + end; +end; + +procedure TSysScrollingStyleHook.Scroll(const Kind: TScrollBarKind; const ScrollType: TSysScrollingType; Pos, Delta: Integer); +begin + if Kind = sbVertical then + begin + case ScrollType of + skTracking: + begin + FLstPos := Pos; + FAllowScrolling := True; + SendMessage(Handle, WM_VSCROLL, MakeWParam(SB_THUMBTRACK, Pos), 0); + FAllowScrolling := False; + end; + skLineUp: SendMessage(Handle, WM_VSCROLL, SB_LINEUP, 0); + skLineDown: SendMessage(Handle, WM_VSCROLL, SB_LINEDOWN, 0); + skPageUp: SendMessage(Handle, WM_VSCROLL, SB_PAGEUP, 0); + skPageDown: SendMessage(Handle, WM_VSCROLL, SB_PAGEDOWN, 0); + end; + end + else if Kind = sbHorizontal then + begin + case ScrollType of + skTracking: + begin + FLstPos := Pos; + FAllowScrolling := True; + SendMessage(Handle, WM_HSCROLL, MakeWParam(SB_THUMBTRACK, Pos), 0); + FAllowScrolling := False; + end; + skLineLeft: SendMessage(Handle, WM_HSCROLL, SB_LINELEFT, 0); + skLineRight: SendMessage(Handle, WM_HSCROLL, SB_LINERIGHT, 0); + skPageLeft: SendMessage(Handle, WM_HSCROLL, SB_PAGELEFT, 0); + skPageRight: SendMessage(Handle, WM_HSCROLL, SB_PAGERIGHT, 0); + end; + end; +end; + +procedure TSysScrollingStyleHook.StartLineTrackTimer; +begin + if Assigned(FTrackTimer) then + begin + FTrackTimer.Enabled := False; + FreeAndNil(FTrackTimer); + end; + + FTrackTimer := TTimer.Create(nil); + with FTrackTimer do + begin + Interval := 100; + OnTimer := DoLineTrackTimer; + Enabled := True; + end; +end; + +procedure TSysScrollingStyleHook.StartPageTrackTimer; +begin + if Assigned(FTrackTimer) then + begin + FTrackTimer.Enabled := False; + FreeAndNil(FTrackTimer); + end; + + FTrackTimer := TTimer.Create(nil); + with FTrackTimer do + begin + Interval := 100; + OnTimer := DoPageTrackTimer; + Enabled := True; + end; +end; + +procedure TSysScrollingStyleHook.StartSliderTrackTimer; +begin + if Assigned(FTrackTimer) then + begin + FTrackTimer.Enabled := False; + FreeAndNil(FTrackTimer); + end; + + FTrackTimer := TTimer.Create(nil); + with FTrackTimer do + begin + Interval := 100; + OnTimer := DoSliderTrackTimer; + Enabled := True; + end; +end; + +procedure TSysScrollingStyleHook.StopLineTrackTimer; +begin + if Assigned(FTrackTimer) then + begin + FTrackTimer.Enabled := False; + FreeAndNil(FTrackTimer); + end; +end; + +procedure TSysScrollingStyleHook.StopPageTrackTimer; +begin + if Assigned(FTrackTimer) then + begin + FTrackTimer.Enabled := False; + FreeAndNil(FTrackTimer); + end; +end; + +procedure TSysScrollingStyleHook.StopSliderTrackTimer; +begin + if Assigned(FTrackTimer) then + begin + FTrackTimer.Enabled := False; + FreeAndNil(FTrackTimer); + end; +end; + +procedure TSysScrollingStyleHook.WMNCCalcSize(var Message: TWMNCCalcSize); +var + OrgStyle, NewStyle: NativeInt; + BorderSize: TRect; +begin + if (not OverridePaintNC) or (not StyleServicesEnabled) then + begin + Handled := False; + Exit; + end; + BorderSize := GetBorderSize; + OrgStyle := SysControl.Style; + NewStyle := SysControl.Style; + FVertScrollBar := False; + FHorzScrollBar := False; + if OrgStyle and WS_VSCROLL = WS_VSCROLL then + begin + { Remove the VertScrollBar . } + NewStyle := NewStyle and not WS_VSCROLL; + FVertScrollBar := True; + end; + if OrgStyle and WS_HSCROLL = WS_HSCROLL then + begin + { Remove the HorzScrollBar . } + NewStyle := NewStyle and not WS_HSCROLL; + FHorzScrollBar := True; + end; + if OrgStyle <> NewStyle then + begin + SysControl.Style := NewStyle; + if not HookedDirectly then + Message.Result := CallDefaultProc(TMessage(Message)); + SysControl.Style := OrgStyle; + end; + if FVertScrollBar then + begin + { Insert a new VertScrollBar area . } + if not LeftScrollBar then + Dec(Message.CalcSize_Params.rgrc[0].Right, BtnSize.cx) + else + Inc(Message.CalcSize_Params.rgrc[0].Left, BtnSize.cx); + end; + if FHorzScrollBar then + { Insert a new HorzScrollBar area . } + Dec(Message.CalcSize_Params.rgrc[0].Bottom, BtnSize.cx); + if SysControl.HasBorder then + begin + Inc(Message.CalcSize_Params.rgrc[0].Left, BorderSize.Left); + Inc(Message.CalcSize_Params.rgrc[0].Top, BorderSize.Top); + Dec(Message.CalcSize_Params.rgrc[0].Bottom, BorderSize.Bottom); + Dec(Message.CalcSize_Params.rgrc[0].Right, BorderSize.Right); + end; + Handled := True; +end; + +procedure TSysScrollingStyleHook.WMNCHitTest(var Message: TWMNCHitTest); +var + P: TPoint; +begin + if (not OverridePaintNC) or (not StyleServicesEnabled) then + begin + Handled := False; + Exit; + end; + Message.Result := CallDefaultProc(TMessage(Message)); + P.X := Message.XPos; + P.Y := Message.YPos; + { If Mouse on VertScrollBar . } + if (FVertScrollBar and VertScrollRect.Contains(P)) then + begin + { Return HTVSCROLL allow the app to get WM_NCLBUTTONDOWN message . } + Message.Result := HTVSCROLL; + if (SysControl.Enabled and not VertScrollDisabled) then + begin + { If Mouse pressed then exit . } + if not FNCMouseDown then + begin + if VertUpRect.Contains(P) then + begin + { VertUpButton Hot . } + FVertBtnSliderDetail := tsThumbBtnVertNormal; + if FBtnUpDetail <> tsArrowBtnUpHot then + begin + FBtnUpDetail := tsArrowBtnUpHot; + DrawVertScroll(0); + end; + end + else if VertDownRect.Contains(P) then + begin + { VertDownButton Hot . } + FVertBtnSliderDetail := tsThumbBtnVertNormal; + if FBtnDownDetail <> tsArrowBtnDownHot then + begin + FBtnDownDetail := tsArrowBtnDownHot; + DrawVertScroll(0); + end; + end + else if VertSliderRect.Contains(P) then + begin + { VertSliderButton Hot . } + FBtnUpDetail := tsArrowBtnUpNormal; + FBtnDownDetail := tsArrowBtnDownNormal; + if FVertBtnSliderDetail <> tsThumbBtnVertHot then + begin + FVertBtnSliderDetail := tsThumbBtnVertHot; + DrawVertScroll(0); + end; + end + else + begin + { Update ScrollBar state . } + if (FBtnUpDetail <> tsArrowBtnUpNormal) or (FBtnDownDetail <> tsArrowBtnDownNormal) or (FVertBtnSliderDetail <> tsThumbBtnVertNormal) then + begin + FBtnUpDetail := tsArrowBtnUpNormal; + FBtnDownDetail := tsArrowBtnDownNormal; + FVertBtnSliderDetail := tsThumbBtnVertNormal; + DrawVertScroll(0); + end + end; + end; + end; + end; + { If Mouse on HorzScrollBar . } + if (FHorzScrollBar and HorzScrollRect.Contains(P)) then + begin + { Return HTHSCROLL allow the app to get WM_NCLBUTTONDOWN message . } + Message.Result := HTHSCROLL; + if (SysControl.Enabled and not HorzScrollDisabled) then + begin + { If Mouse pressed then exit . } + if not FNCMouseDown then + begin + if HorzLeftRect.Contains(P) then + begin + { HorzLeftButton Hot . } + FHorzBtnSliderDetail := tsThumbBtnHorzNormal; + if FBtnLeftDetail <> tsArrowBtnLeftHot then + begin + FBtnLeftDetail := tsArrowBtnLeftHot; + DrawHorzScroll(0); + end; + end + else if HorzRightRect.Contains(P) then + begin + { HorzRightButton Hot . } + FHorzBtnSliderDetail := tsThumbBtnHorzNormal; + if FBtnRightDetail <> tsArrowBtnRightHot then + begin + FBtnRightDetail := tsArrowBtnRightHot; + DrawHorzScroll(0); + end; + end + else if HorzSliderRect.Contains(P) then + begin + { HorzSliderButton Hot . } + FBtnLeftDetail := tsArrowBtnLeftNormal; + FBtnRightDetail := tsArrowBtnRightNormal; + if FHorzBtnSliderDetail <> tsThumbBtnHorzHot then + begin + FHorzBtnSliderDetail := tsThumbBtnHorzHot; + DrawHorzScroll(0); + end; + end + else + begin + { Update ScrollBar state . } + if (FBtnLeftDetail <> tsArrowBtnLeftNormal) or (FBtnRightDetail <> tsArrowBtnRightNormal) or (FHorzBtnSliderDetail <> tsThumbBtnHorzNormal) then + begin + FBtnLeftDetail := tsArrowBtnLeftNormal; + FBtnRightDetail := tsArrowBtnRightNormal; + FHorzBtnSliderDetail := tsThumbBtnHorzNormal; + DrawHorzScroll(0); + end + end; + end; + end; + end; + Handled := True; +end; + +procedure TSysScrollingStyleHook.WMNCLButtonDown(var Message: TWMNCLButtonDown); +var + P: TPoint; +begin + if (not OverridePaintNC) or (not StyleServicesEnabled) then + begin + Handled := False; + Exit; + end; + + if not SysControl.Enabled then + begin + Message.Result := CallDefaultProc(TMessage(Message)); + Exit; + end; + + FNCMouseDown := True; + FTracking := False; + if (Message.HitTest = HTVSCROLL) then + begin + if VertScrollDisabled then + begin + FTracking := False; + FNCMouseDown := False; + Message.Result := CallDefaultProc(TMessage(Message)); + FAllowScrolling := True; + Handled := True; + Exit; + end; + { Vertical ScrollBar } + FScrollKind := sbVertical; + GetCursorPos(P); + { Save the DownPoint } + FDownPoint := P; + { The distance between the point & the top of VertSliderButton . } + FDownDis := P.Y - VertSliderRect.Top; + { The old ScrollBar Position } + FPrevPos := VertScrollInfo.nPos; + +// OutputDebugString(PChar(Format('TSysScrollingStyleHook.WMNCLButtonDown P.X %d P.Y %d VertSliderRect.Left %d VertSliderRect.Top %d VertSliderRect.Width %d VertSliderRect.Height %d', +// [P.X, P.Y, VertSliderRect.Left, VertSliderRect.Top, VertSliderRect.Width, VertSliderRect.Height]))); + + if VertSliderRect.Contains(P) then + begin + { VertSliderButton pressed . } + FVertBtnSliderDetail := tsThumbBtnVertPressed; + StartSliderTrackTimer; + DrawVertScroll(0); { Need Repaint ==> First painting } + FTracking := True; { ==> Set it after first painting . } + FAllowScrolling := False; + { Mouse Down } + Message.Result := CallDefaultProc(TMessage(Message)); + { Mouse Up } + FAllowScrolling := False; + StopSliderTrackTimer; + FVertBtnSliderDetail := tsThumbBtnVertNormal; + FTracking := False; { Set it before the second painting . } + DrawVertScroll(0); { Need Repaint ==> Second painting . } + end + else if (VertUpRect.Contains(P) or (VertDownRect.Contains(P))) then + begin + if VertUpRect.Contains(P) then + begin + { VertUpButton pressed . } + FScrollingType := skLineUp; + FBtnUpDetail := tsArrowBtnUpPressed; + end + else + begin + { VertDownButton pressed . } + FScrollingType := skLineDown; + FBtnDownDetail := tsArrowBtnDownPressed; + end; + DrawVertScroll(0); { Need Repaint . } + StartLineTrackTimer; + { Mouse Down } + Message.Result := CallDefaultProc(TMessage(Message)); + { Mouse Up } + StopLineTrackTimer; + FBtnDownDetail := tsArrowBtnDownNormal; + FBtnUpDetail := tsArrowBtnUpNormal; + DrawVertScroll(0); { Need Repaint . } + end + else + begin + FScrollingType := skNone; + if FDownPoint.Y > VertSliderRect.Bottom then + FScrollingType := skPageDown; + if FDownPoint.Y < VertSliderRect.Top then + FScrollingType := skPageUp; + DrawVertScroll(0); { Need Repaint . } + { + Scrolling from the track rect . + ==> Not from Slider or Up/Down Button . + } + + StartPageTrackTimer; + { Mouse Down } + Message.Result := CallDefaultProc(TMessage(Message)); + { Mouse Up } + StopPageTrackTimer; + end; + DrawVertScroll(0); { Need Repaint . } + end + else if (Message.HitTest = HTHSCROLL) then + { Horizontal ScrollBar } + begin + if HorzScrollDisabled then + begin + FTracking := False; + FNCMouseDown := False; + Message.Result := CallDefaultProc(TMessage(Message)); + FAllowScrolling := True; + Handled := True; + Exit; + end; + FScrollKind := sbHorizontal; + GetCursorPos(P); + FDownPoint := P; + { The distance between the point & the left of HorzSliderButton . } + FDownDis := P.X - HorzSliderRect.Left; + FPrevPos := HorzScrollInfo.nPos; + if HorzSliderRect.Contains(P) then + begin + FHorzBtnSliderDetail := tsThumbBtnHorzPressed; + DrawHorzScroll(0); { Need Repaint ==> First painting . } + FTracking := True; { Set it after first painting . } + StartSliderTrackTimer; + { Mouse Down } + Message.Result := CallDefaultProc(TMessage(Message)); + { Mouse Up } + StopSliderTrackTimer; + FHorzBtnSliderDetail := tsThumbBtnHorzNormal; + FTracking := False; { Set it before second painting . } + DrawHorzScroll(0); { Need Repaint ==> Second painting. } + end + else if (HorzLeftRect.Contains(P) or (HorzRightRect.Contains(P))) then + begin + if HorzLeftRect.Contains(P) then + begin + FBtnLeftDetail := tsArrowBtnLeftPressed; + FBtnRightDetail := tsArrowBtnRightNormal; + FScrollingType := skLineLeft + end + else + begin + FBtnLeftDetail := tsArrowBtnLeftNormal; + FBtnRightDetail := tsArrowBtnRightPressed; + FScrollingType := skLineRight; + end; + DrawHorzScroll(0); { Need Repaint . } + StartLineTrackTimer; + { Mouse Down } + Message.Result := CallDefaultProc(TMessage(Message)); + { Mouse Up } + FBtnLeftDetail := tsArrowBtnLeftNormal; + FBtnRightDetail := tsArrowBtnRightNormal; + StopLineTrackTimer; + DrawHorzScroll(0); { Need Repaint . } + end + else + begin + FScrollingType := skNone; + if FDownPoint.X > HorzSliderRect.Right then + FScrollingType := skPageRight; + if FDownPoint.X < HorzSliderRect.Right then + FScrollingType := skPageLeft; + { + Scrolling from the track rect . + ==> Not from Slider or Left/Right Button . + } + StartPageTrackTimer; + { Mouse Down } + Message.Result := CallDefaultProc(TMessage(Message)); + { Mouse Up } + StopPageTrackTimer; + end; + FTracking := False; + DrawHorzScroll(0); { Need Repaint . } + end + else + begin + Message.Result := CallDefaultProc(TMessage(Message)); + end; + FTracking := False; + FNCMouseDown := False; + Handled := True; + FAllowScrolling := True; +end; + +procedure TSysScrollingStyleHook.WMNCLButtonUp(var Message: TWMNCLButtonUp); +begin + Message.Result := CallDefaultProc(TMessage(Message)); + Handled := True; +end; + +procedure TSysScrollingStyleHook.WndProc(var Message: TMessage); +begin + case Message.msg of + + WM_MOUSEWHEEL: + begin + Inherited; + if FVertScrollBar then + DrawVertScroll(0); + end; + + WM_VSCROLL, WM_HSCROLL: + begin + if Word(Message.WParam) = SB_THUMBPOSITION then + begin + Message.WParam := MakeWParam(SB_THUMBPOSITION, FLstPos); + CallDefaultProc(Message); + Exit; + end; + if (not OverridePaintNC) or (not StyleServicesEnabled) then + begin + CallDefaultProc(Message); + Exit; + end; + // if not FAllowScrolling then + // Exit; + inherited; + end; + + WM_NCMOUSELEAVE, WM_MOUSEMOVE: + begin + if (not OverridePaintNC) or (not StyleServicesEnabled) then + begin + CallDefaultProc(Message); + Exit; + end; + { Update ScrollBar State } + if (FVertScrollBar and SysControl.Enabled and (not FNCMouseDown) and (not VertScrollDisabled)) then + begin + if (FBtnUpDetail <> tsArrowBtnUpNormal) or (FBtnDownDetail <> tsArrowBtnDownNormal) or (FVertBtnSliderDetail <> tsThumbBtnVertNormal) then + begin + FBtnUpDetail := tsArrowBtnUpNormal; + FBtnDownDetail := tsArrowBtnDownNormal; + FVertBtnSliderDetail := tsThumbBtnVertNormal; + DrawVertScroll(0); + end; + end; + if (FHorzScrollBar and SysControl.Enabled and (not FNCMouseDown) and (not HorzScrollDisabled)) then + begin + if (FBtnLeftDetail <> tsArrowBtnLeftNormal) or (FBtnRightDetail <> tsArrowBtnRightNormal) or (FHorzBtnSliderDetail <> tsThumbBtnHorzNormal) then + begin + FBtnLeftDetail := tsArrowBtnLeftNormal; + FBtnRightDetail := tsArrowBtnRightNormal; + FHorzBtnSliderDetail := tsThumbBtnHorzNormal; + DrawHorzScroll(0); + end; + end; + inherited; + end; + + WM_PAINT: + begin + if (not OverridePaintNC) or (not StyleServicesEnabled) then + begin + CallDefaultProc(Message); + Exit; + end; + + inherited WndProc(Message); + { Do not paint while tracking . } + if (not FTracking) and (OverridePaintNC) then + begin + if FVertScrollBar then + DrawVertScroll(0); + if FHorzScrollBar then + DrawHorzScroll(0); + end; + Exit; + end; + else inherited; + end; + +end; + +{ TSysScrollBarStyleHook } + +constructor TSysScrollBarStyleHook.Create(AHandle: THandle); +begin + inherited; +{$IF CompilerVersion > 23} + StyleElements := [seClient]; +{$ELSE} + OverridePaint := True; + OverridePaintNC := False; + OverrideFont := False; +{$IFEND} +end; + +destructor TSysScrollBarStyleHook.Destroy; +begin + inherited; +end; + +procedure TSysScrollBarStyleHook.WndProc(var Message: TMessage); +var + DC: HDC; + PS: TPaintStruct; + LDetails: TThemedElementDetails; +begin + case Message.msg of + WM_PAINT: + begin + if not OverridePaint then + begin + Message.Result := CallDefaultProc(Message); + Exit; + end; + if ((SysControl.Style and SBS_SIZEGRIP = SBS_SIZEGRIP) or (SysControl.Style and SBS_SIZEBOX = SBS_SIZEBOX)) then + begin + BeginPaint(Handle, PS); + try + DC := GetDC(Handle); + try + LDetails := StyleServices.GetElementDetails(tsSizeBoxLeftAlign); + DrawStyleElement(DC, LDetails, SysControl.ClientRect); + finally + ReleaseDC(Handle, DC); + end; + finally + EndPaint(Handle, PS); + end; + Exit; + end + + else + begin + Message.Result := CallDefaultProc(Message); + Exit; + end; + Exit; + end; + WM_ERASEBKGND: + begin + if OverridePaint then + begin + Message.Result := 1; + Exit; + end + else + begin + Message.Result := CallDefaultProc(Message); + Exit; + end; + end; + end; + + inherited; +end; + +initialization + + {$IFNDEF USE_Vcl.Styles.Hooks} + //UseLatestCommonDialogs := False; + {$ENDIF} + +{$IF CompilerVersion >= 30} + TStyleManager.SystemHooks := TStyleManager.SystemHooks - [shDialogs]; +{$IFEND} + + + if StyleServices.Available then + begin + TSysStyleManager.RegisterSysStyleHook('#32770', TSysDialogStyleHook); + //TSysStyleManager.RegisterSysStyleHook('HH Parent', TSysDialogStyleHook); + TSysStyleManager.RegisterSysStyleHook('ScrollBar', TSysScrollBarStyleHook); + end; + +finalization + TSysStyleManager.UnRegisterSysStyleHook('#32770', TSysDialogStyleHook); + //TSysStyleManager.UnRegisterSysStyleHook('HH Parent', TSysDialogStyleHook); + TSysStyleManager.UnRegisterSysStyleHook('ScrollBar', TSysScrollBarStyleHook); +end. diff --git a/source/vcl-styles-utils/Vcl.Styles.Utils.Graphics.pas b/source/vcl-styles-utils/Vcl.Styles.Utils.Graphics.pas index 518066fa3..3b9fce6e7 100644 --- a/source/vcl-styles-utils/Vcl.Styles.Utils.Graphics.pas +++ b/source/vcl-styles-utils/Vcl.Styles.Utils.Graphics.pas @@ -15,7 +15,7 @@ // The Original Code is Vcl.Styles.Utils.Graphics.pas. // // The Initial Developer of the Original Code is Rodrigo Ruz V. -// Portions created by Rodrigo Ruz V. are Copyright (C) 2012-2019 Rodrigo Ruz V. +// Portions created by Rodrigo Ruz V. are Copyright (C) 2012-2023 Rodrigo Ruz V. // All Rights Reserved. // // ************************************************************************************************** @@ -146,7 +146,7 @@ TColorFilter = class TBitmapFilter = class(TColorFilter) private - // FColorValue : Integer; + // FColorValue: Integer; FUseBitmap: Boolean; FSourceBitmap: TBitmap; public @@ -264,8 +264,9 @@ procedure AlphaBlendRectangle(const ACanvas: TCanvas; const AColor: TColor; cons procedure AlphaBlendRectangle(const DC: HDC; const AColor: TColor; const ARect: TRect; SourceConstantAlpha: byte); overload; -procedure DrawStyleElement(HDC: HDC; LDetails: TThemedElementDetails; pRect: TRect; RestoreDC: Boolean = True); - overload; +procedure DrawStyleElement(HDC: HDC; LDetails: TThemedElementDetails; pRect: + TRect; RestoreDC: Boolean = True; const AStyle: TCustomStyleServices = + nil); overload; {$IF (CompilerVersion >= 33)} procedure DrawStyleElement(HDC: HDC; LDetails: TThemedElementDetails; pRect: TRect; ClipRect: pRect; DPI: Integer = 0; RestoreDC: Boolean = True); overload; @@ -293,7 +294,7 @@ implementation System.Zip, {$ENDIF} System.Types, - System.Math; + System.Math, Vcl.Forms; type PRGBArray24 = ^TRGBArray24; @@ -787,15 +788,28 @@ procedure DrawStyleParentBackgroundEx(Handle: THandle; DC: HDC; const ARect: TRe end; end; -procedure DrawStyleElement(HDC: HDC; LDetails: TThemedElementDetails; pRect: TRect; RestoreDC: Boolean = True); +procedure DrawStyleElement(HDC: HDC; LDetails: TThemedElementDetails; pRect: + TRect; RestoreDC: Boolean = True; const AStyle: TCustomStyleServices = nil); var SaveIndex: Integer; + LStyle: TCustomStyleServices; begin SaveIndex := 0; + if Assigned(AStyle) then + LStyle := AStyle + else + LStyle := StyleServices; if RestoreDC then SaveIndex := SaveDC(HDC); try - StyleServices.DrawElement(HDC, LDetails, pRect, nil); + {$IF (CompilerVersion >= 34)} + if Assigned(Application.Mainform) then + LStyle.DrawElement(HDC, LDetails, pRect, nil, Application.MainForm.Monitor.PixelsPerInch) + else + LStyle.DrawElement(HDC, LDetails, pRect, nil, Screen.PixelsPerInch); + {$ELSE} + LStyle.DrawElement(HDC, LDetails, pRect, nil); + {$ENDIF} finally if (SaveIndex > 0) and RestoreDC then Winapi.Windows.RestoreDC(HDC, SaveIndex); diff --git a/source/vcl-styles-utils/Vcl.Styles.Utils.Menus.pas b/source/vcl-styles-utils/Vcl.Styles.Utils.Menus.pas index da0d5252e..94ca4a8a3 100644 --- a/source/vcl-styles-utils/Vcl.Styles.Utils.Menus.pas +++ b/source/vcl-styles-utils/Vcl.Styles.Utils.Menus.pas @@ -14,7 +14,7 @@ // // // Portions created by Mahdi Safsafi [SMP3] e-mail SMP@LIVE.FR -// Portions created by Rodrigo Ruz V. are Copyright (C) 2013-2020 Rodrigo Ruz V. +// Portions created by Rodrigo Ruz V. are Copyright (C) 2013-2023 Rodrigo Ruz V. // All Rights Reserved. // // ************************************************************************************************** @@ -140,10 +140,10 @@ TSysPopupItem = class {$ENDREGION} var - FOffset : Integer; - FOffsetCache : Integer; - FSeparatorHeightCache : Integer; - FItemHeightCache : Integer; + FOffset: Integer; + FOffsetCache: Integer; + FSeparatorHeightCache: Integer; + FItemHeightCache: Integer; FItemsPainted: Boolean; FParentSubItemPainted: Boolean; FPreviousHotItemIndex: integer; @@ -153,11 +153,11 @@ TSysPopupItem = class FCount: integer; FMenu: HMENU; FVCLMenuItems: TMenuItem; - FNCRect : TRect; - FEnterWithKeyboard : Boolean; - FPersistentHotKeys : Boolean; + FNCRect: TRect; + FEnterWithKeyboard: Boolean; + FPersistentHotKeys: Boolean; - FMenuBarHook : TObject; + FMenuBarHook: TObject; function GetMenuFromHandle(AHandle: HWND): HMENU; function GetItemsCount: integer; procedure MNSELECTITEM(var Message: TMessage); message MN_SELECTITEM; @@ -171,20 +171,20 @@ TSysPopupItem = class const Style: TSysPopupItemStyle); Virtual; procedure PaintBackground(Canvas: TCanvas); override; procedure GetNbSeparator(var PNbSeparator: Integer; const PIndex: Integer); - function GetMenuItemHeight(const Index: Integer) : Integer; - function GetOffset(UseCache: Boolean) : Integer; + function GetMenuItemHeight(const Index: Integer): Integer; + function GetOffset(UseCache: Boolean): Integer; function ItemIsVisible(const Index: Integer): Boolean; procedure SetMaxOffset(); procedure RefreshMenu(); procedure GetItemHeight(); procedure GetSeparatorHeight(); function GetClientRectHeight(var PValue: TRect): Integer; - function GetItemClicked(var PButton: Byte; PInitPos: TPoint) : Integer; - function GetMousePos() : TPoint; + function GetItemClicked(var PButton: Byte; PInitPos: TPoint): Integer; + function GetMousePos(): TPoint; procedure WndProc(var Message: TMessage); override; procedure UpdateColors; override; procedure SetOffset(PValue: Integer); - function GetBottom(const Index: Integer) : Integer; + function GetBottom(const Index: Integer): Integer; public constructor Create(AHandle: THandle); override; Destructor Destroy; override; @@ -415,6 +415,7 @@ procedure TSysPopupStyleHook.DrawItem(Canvas: TCanvas; const Index: integer; con var LTextRect: TRect; DC: HDC; + LPixelsPerInch: Integer; procedure DrawSubMenu(const ItemRect: TRect); var @@ -429,7 +430,7 @@ procedure TSysPopupStyleHook.DrawItem(Canvas: TCanvas; const Index: integer; con if isDisabled in State then LSubMenuDetail := tmPopupSubMenuDisabled; LSubMenuDetails := StyleServices.GetElementDetails(LSubMenuDetail); - StyleServices.GetElementSize(DC, LSubMenuDetails, esActual, SubMenuSize); + StyleServices.GetElementSize(DC, LSubMenuDetails, esActual, SubMenuSize, LPixelsPerInch); if not RightToLeft then LSubMenuRect := Rect(ItemRect.Right - SubMenuSize.cx, ItemRect.Top, ItemRect.Right, ItemRect.Top + SubMenuSize.cy) else @@ -439,7 +440,7 @@ procedure TSysPopupStyleHook.DrawItem(Canvas: TCanvas; const Index: integer; con LBitmap.SetSize(SubMenuSize.Width, SubMenuSize.Height); LBitmap.Canvas.Brush.Color := clFuchsia; LBitmap.Canvas.FillRect(Rect(0, 0, SubMenuSize.Width, SubMenuSize.Height)); - StyleServices.DrawElement(LBitmap.Canvas.Handle, LSubMenuDetails, Rect(0, 0, SubMenuSize.Width, SubMenuSize.Height)); + StyleServices.DrawElement(LBitmap.Canvas.Handle, LSubMenuDetails, Rect(0, 0, SubMenuSize.Width, SubMenuSize.Height), nil, LPixelsPerInch); if RightToLeft then begin RotateBitmap(LBitmap, DegToRad(180), False, clFuchsia); @@ -534,6 +535,10 @@ procedure TSysPopupStyleHook.DrawItem(Canvas: TCanvas; const Index: integer; con begin + if Assigned(Application.Mainform) then + LPixelsPerInch := Application.MainForm.Monitor.PixelsPerInch + else + LPixelsPerInch := screen.PixelsPerInch; DisplayCheckedGlyph := True; ItemRect2 := ItemRect; ItemRect2.Top := ItemRect.Top - GetOffset(True); //add offset @@ -1269,7 +1274,7 @@ procedure TSysPopupStyleHook.GetNbSeparator(var PNbSeparator: Integer; const PIn end; end; -function TSysPopupStyleHook.GetMenuItemHeight(const Index: Integer) : Integer; +function TSysPopupStyleHook.GetMenuItemHeight(const Index: Integer): Integer; var LItemRect: TRect; begin @@ -1277,7 +1282,7 @@ function TSysPopupStyleHook.GetMenuItemHeight(const Index: Integer) : Integer; Result := LItemRect.Height; end; -function TSysPopupStyleHook.GetBottom(const Index: Integer) : Integer; +function TSysPopupStyleHook.GetBottom(const Index: Integer): Integer; var LItemRect: TRect; P: TPoint; @@ -1288,7 +1293,7 @@ function TSysPopupStyleHook.GetBottom(const Index: Integer) : Integer; Result := P.Y; end; -function TSysPopupStyleHook.GetOffset(UseCache: Boolean) : Integer; +function TSysPopupStyleHook.GetOffset(UseCache: Boolean): Integer; var LNbSeparator: Integer; begin @@ -1478,7 +1483,7 @@ procedure TSysPopupStyleHook.SetOffset(PValue: Integer); FOffsetCache := 0; end; -function TSysPopupStyleHook.GetItemClicked(var PButton: Byte; PInitPos: TPoint) : Integer; +function TSysPopupStyleHook.GetItemClicked(var PButton: Byte; PInitPos: TPoint): Integer; var ArrowHeight, i: Integer; R, LItemRect: TRect; @@ -1529,7 +1534,7 @@ function TSysPopupStyleHook.GetItemClicked(var PButton: Byte; PInitPos: TPoint) Result := -1; end; -function TSysPopupStyleHook.GetMousePos() : TPoint; +function TSysPopupStyleHook.GetMousePos(): TPoint; begin Result := Mouse.CursorPos; ScreenToClient(Handle, Result); @@ -2034,7 +2039,7 @@ function TSysPopupStyleHook.TSysPopupItem.GetVCLRealItem: TMenuItem; windows will delete this item but the VCL will not delete the item from Items property .And thats can cause the item to be painted ! Do not access VCLMenuItems.Items[Index] directly - => Instead , use this one : VCLItem . + => Instead , use this one: VCLItem . } VisibleItems := nil; Result := nil; diff --git a/source/vcl-styles-utils/Vcl.Styles.Utils.Misc.pas b/source/vcl-styles-utils/Vcl.Styles.Utils.Misc.pas index 52e766c9a..697ef2af1 100644 --- a/source/vcl-styles-utils/Vcl.Styles.Utils.Misc.pas +++ b/source/vcl-styles-utils/Vcl.Styles.Utils.Misc.pas @@ -1,832 +1,855 @@ -// ************************************************************************************************** -// -// Unit Vcl.Styles.Utils.Misc -// unit for the VCL Styles Utils -// https://github.com/RRUZ/vcl-styles-utils/ -// -// 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. -// -// The Original Code is Vcl.Styles.Utils.Misc.pas. -// -// Portions created by Rodrigo Ruz V. are Copyright (C) 2013-2019 Rodrigo Ruz V. -// All Rights Reserved. -// -// ************************************************************************************************** -unit Vcl.Styles.Utils.Misc; - -{$I VCL.Styles.Utils.inc} - -interface - -uses - Winapi.Messages, - Winapi.Windows; - -{ .$DEFINE EventLog } -function GetWindowClassName(Window: HWND): String; -function RectVCenter(var R: TRect; const Bounds: TRect): TRect; -procedure MoveWindowOrg(DC: HDC; const DX, DY: Integer); -{$IFDEF EventLog} -procedure AddToLog(const Msg: TMessage); overload; -procedure AddToLog(const S: string; const Value: Integer); overload; -procedure AddToLog(const Msg: string); overload; -function WM_To_String(const WM_Message: Integer): string; -{$ENDIF} -function ExecutingInMainThread: boolean; - -implementation - -uses - Winapi.CommCtrl, - System.SysUtils; - -function ExecutingInMainThread: boolean; -begin - // VCL is not thread safe and some components like CEF will create Windows - // controls in secondary threads. It's strongly recommended to define - // LimitStylesToMainApplicationThread in VCL.Styles.Utils.inc if you see - // dialogs or controls partially themed. - {$IFDEF LimitStylesToMainApplicationThread} - Result := (GetCurrentThreadId = MainThreadId); +// ************************************************************************************************** +// +// Unit Vcl.Styles.Utils.Misc +// unit for the VCL Styles Utils +// https://github.com/RRUZ/vcl-styles-utils/ +// +// 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. +// +// The Original Code is Vcl.Styles.Utils.Misc.pas. +// +// Portions created by Rodrigo Ruz V. are Copyright (C) 2013-2023 Rodrigo Ruz V. +// All Rights Reserved. +// +// ************************************************************************************************** +unit Vcl.Styles.Utils.Misc; + +{$I VCL.Styles.Utils.inc} + +interface + +uses + Winapi.Messages, + Winapi.Windows; + +{ .$DEFINE EventLog } +function GetWindowClassName(Window: HWND): String; +function RectVCenter(var R: TRect; const Bounds: TRect): TRect; +procedure MoveWindowOrg(DC: HDC; const DX, DY: Integer); +{$IFDEF EventLog} +procedure AddToLog(const Msg: TMessage); overload; +procedure AddToLog(const S: string; const Value: Integer); overload; +procedure AddToLog(const Msg: string); overload; +function WM_To_String(const WM_Message: Integer): string; +{$ENDIF} +function ExecutingInMainThread: boolean; +function GetSysMetrics(nIndex: Integer): Integer; + +var + GlobalMainThreadID: TThreadID = 0; + +implementation + +uses + Winapi.CommCtrl, + System.SysUtils, + Vcl.Forms; + +function ExecutingInMainThread: boolean; +begin + // VCL is not thread safe and some components like CEF will create Windows + // controls in secondary threads. It's strongly recommended to define + // LimitStylesToMainApplicationThread in VCL.Styles.Utils.inc if you see + // dialogs or controls partially themed. + {$IFDEF LimitStylesToMainApplicationThread} + Result := (GetCurrentThreadId = MainThreadId); + {$ELSE} + Result := True; + {$ENDIF} +end; + +function GetSysMetrics(nIndex: Integer): Integer; +begin + {$IF (CompilerVersion >= 33)} + if TOSVersion.Check(10) and (TOSVersion.Build >= 14393) then + begin + // Windows 10, version 1607 or higher + if Assigned(Application.Mainform) then + Result := GetSystemMetricsForDPI(nIndex, Application.Mainform.Monitor.PixelsPerInch) + else + Result := GetSystemMetricsForDPI(nIndex, Screen.PixelsPerInch); + end + else + Result := GetSystemMetrics(nIndex); {$ELSE} - Result := True; + Result := GetSystemMetrics(nIndex); {$ENDIF} end; - -{$IFDEF EventLog} - -{ Useful functions when debugging } -procedure AddToLog(const Msg: TMessage); -begin - with Msg do - OutputDebugString(PChar(FormatDateTime('hh:nn:ss.zzz', Now) + ' Msg = ' + WM_To_String(Msg) + ' wParam = ' + - IntToStr(wParam) + ' LParam = ' + IntToStr(lParam))); -end; - -procedure AddToLog(const S: string; const Value: Integer); -begin - OutputDebugString(PChar((S) + ' = ' + IntToStr(Value))); -end; - -procedure AddToLog(const Msg: string); -begin - OutputDebugString(PChar(Msg)); -end; - -function WM_To_String(const WM_Message: Integer): string; -begin - case WM_Message of - $0000: - Result := 'WM_NULL'; - $0001: - Result := 'WM_CREATE'; - $0002: - Result := 'WM_DESTROY'; - $0003: - Result := 'WM_MOVE'; - $0005: - Result := 'WM_SIZE'; - $0006: - Result := 'WM_ACTIVATE'; - $0007: - Result := 'WM_SETFOCUS'; - $0008: - Result := 'WM_KILLFOCUS'; - $000A: - Result := 'WM_ENABLE'; - $000B: - Result := 'WM_SETREDRAW'; - $000C: - Result := 'WM_SETTEXT'; - $000D: - Result := 'WM_GETTEXT'; - $000E: - Result := 'WM_GETTEXTLENGTH'; - $000F: - Result := 'WM_PAINT'; - $0010: - Result := 'WM_CLOSE'; - $0011: - Result := 'WM_QUERYENDSESSION'; - $0012: - Result := 'WM_QUIT'; - $0013: - Result := 'WM_QUERYOPEN'; - $0014: - Result := 'WM_ERASEBKGND'; - $0015: - Result := 'WM_SYSCOLORCHANGE'; - $0016: - Result := 'WM_EndSESSION'; - $0017: - Result := 'WM_SYSTEMERROR'; - $0018: - Result := 'WM_SHOWWINDOW'; - $0019: - Result := 'WM_CTLCOLOR'; - $001A: - Result := 'WM_WININICHANGE or WM_SETTINGCHANGE'; - $001B: - Result := 'WM_DEVMODECHANGE'; - $001C: - Result := 'WM_ACTIVATEAPP'; - $001D: - Result := 'WM_FONTCHANGE'; - $001E: - Result := 'WM_TIMECHANGE'; - $001F: - Result := 'WM_CANCELMODE'; - $0020: - Result := 'WM_SETCURSOR'; - $0021: - Result := 'WM_MOUSEACTIVATE'; - $0022: - Result := 'WM_CHILDACTIVATE'; - $0023: - Result := 'WM_QUEUESYNC'; - $0024: - Result := 'WM_GETMINMAXINFO'; - $0026: - Result := 'WM_PAINTICON'; - $0027: - Result := 'WM_ICONERASEBKGND'; - $0028: - Result := 'WM_NEXTDLGCTL'; - $002A: - Result := 'WM_SPOOLERSTATUS'; - $002B: - Result := 'WM_DRAWITEM'; - $002C: - Result := 'WM_MEASUREITEM'; - $002D: - Result := 'WM_DELETEITEM'; - $002E: - Result := 'WM_VKEYTOITEM'; - $002F: - Result := 'WM_CHARTOITEM'; - $0030: - Result := 'WM_SETFONT'; - $0031: - Result := 'WM_GETFONT'; - $0032: - Result := 'WM_SETHOTKEY'; - $0033: - Result := 'WM_GETHOTKEY'; - $0037: - Result := 'WM_QUERYDRAGICON'; - $0039: - Result := 'WM_COMPAREITEM'; - $003D: - Result := 'WM_GETOBJECT'; - $0041: - Result := 'WM_COMPACTING'; - $0044: - Result := 'WM_COMMNOTIFY { obsolete in Win32}'; - $0046: - Result := 'WM_WINDOWPOSCHANGING'; - $0047: - Result := 'WM_WINDOWPOSCHANGED'; - $0048: - Result := 'WM_POWER'; - $004A: - Result := 'WM_COPYDATA'; - $004B: - Result := 'WM_CANCELJOURNAL'; - $004E: - Result := 'WM_NOTIFY'; - $0050: - Result := 'WM_INPUTLANGCHANGEREQUEST'; - $0051: - Result := 'WM_INPUTLANGCHANGE'; - $0052: - Result := 'WM_TCARD'; - $0053: - Result := 'WM_HELP'; - $0054: - Result := 'WM_USERCHANGED'; - $0055: - Result := 'WM_NOTIFYFORMAT'; - $007B: - Result := 'WM_CONTEXTMENU'; - $007C: - Result := 'WM_STYLECHANGING'; - $007D: - Result := 'WM_STYLECHANGED'; - $007E: - Result := 'WM_DISPLAYCHANGE'; - $007F: - Result := 'WM_GETICON'; - $0080: - Result := 'WM_SETICON'; - $0081: - Result := 'WM_NCCREATE'; - $0082: - Result := 'WM_NCDESTROY'; - $0083: - Result := 'WM_NCCALCSIZE'; - $0084: - Result := 'WM_NCHITTEST'; - $0085: - Result := 'WM_NCPAINT'; - $0086: - Result := 'WM_NCACTIVATE'; - $0087: - Result := 'WM_GETDLGCODE'; - $0088: - Result := 'WM_SYNCPAINT'; - $00A0: - Result := 'WM_NCMOUSEMOVE'; - $00A1: - Result := 'WM_NCLBUTTONDOWN'; - $00A2: - Result := 'WM_NCLBUTTONUP'; - $00A3: - Result := 'WM_NCLBUTTONDBLCLK'; - $00A4: - Result := 'WM_NCRBUTTONDOWN'; - $00A5: - Result := 'WM_NCRBUTTONUP'; - $00A6: - Result := 'WM_NCRBUTTONDBLCLK'; - $00A7: - Result := 'WM_NCMBUTTONDOWN'; - $00A8: - Result := 'WM_NCMBUTTONUP'; - $00A9: - Result := 'WM_NCMBUTTONDBLCLK'; - // edit control messages start (todo: add more if needed) - $00B0: - Result := 'EM_GETSEL'; - $00B1: - Result := 'EM_SETSEL'; - $00B2: - Result := 'EM_GETRECT'; - $00B3: - Result := 'EM_SETRECT'; - $00B4: - Result := 'EM_SETRECTNP'; - $00B5: - Result := 'EM_SCROLL'; - $00B6: - Result := 'EM_LINESCROLL'; - $00B7: - Result := 'EM_SCROLLCARET'; - $00B8: - Result := 'EM_GETMODIFY'; - $00B9: - Result := 'EM_SETMODIFY'; - $00BA: - Result := 'EM_GETLINECOUNT'; - $00BB: - Result := 'EM_LINEINDEX'; - $00BC: - Result := 'EM_SETHANDLE'; - $00BD: - Result := 'EM_GETHANDLE'; - $00BE: - Result := 'EM_GETTHUMB'; - $00C1: - Result := 'EM_LINELENGTH'; - $00C2: - Result := 'EM_REPLACESEL'; - $00C4: - Result := 'EM_GETLINE'; - $00C5: - Result := 'EM_LIMITTEXT'; - $00C6: - Result := 'EM_CANUNDO'; - $00C7: - Result := 'EM_UNDO'; - $00C8: - Result := 'EM_FMTLINES'; - $00C9: - Result := 'EM_LINEFROMCHAR'; - $00CB: - Result := 'EM_SETTABSTOPS'; - $00CC: - Result := 'EM_SETPASSWORDCHAR'; - $00CD: - Result := 'EM_EMPTYUNDOBUFFER'; - $00CE: - Result := 'EM_GETFIRSTVISIBLELINE'; - $00CF: - Result := 'EM_SETREADONLY'; - $00D0: - Result := 'EM_SETWORDBREAKPROC'; - $00D1: - Result := 'EM_GETWORDBREAKPROC'; - $00D2: - Result := 'EM_GETPASSWORDCHAR'; - $00D3: - Result := 'EM_SETMARGINS'; - $00D4: - Result := 'EM_GETMARGINS'; - $00D5: - Result := 'EM_GETLIMITTEXT'; - $00D6: - Result := 'EM_POSFROMCHAR'; - $00D7: - Result := 'EM_CHARFROMPOS'; - // edit control messages end - // scrollbar control messages start - $00E0: - Result := 'SBM_SETPOS'; - $00E1: - Result := 'SBM_GETPOS'; - $00E2: - Result := 'SBM_SETRANGE'; - $00E3: - Result := 'SBM_GETRANGE'; - $00E4: - Result := 'SBM_ENABLE_ARROWS'; - $00E6: - Result := 'SBM_SETRANGEREDRAW'; - $00E9: - Result := 'SBM_SETSCROLLINFO'; - $00EA: - Result := 'SBM_GETSCROLLINFO'; - $00EB: - Result := 'SBM_GETSCROLLBARINFO'; - // scrollbar control messages end - // button control messages start - $00F0: - Result := 'BM_GETCHECK'; - $00F1: - Result := 'BM_SETCHECK'; - $00F2: - Result := 'BM_GETSTATE'; - $00F3: - Result := 'BM_SETSTATE'; - $00F4: - Result := 'BM_SETSTYLE'; - $00F5: - Result := 'BM_CLICK'; - $00F6: - Result := 'BM_GETIMAGE'; - $00F7: - Result := 'BM_SETIMAGE'; - $00F8: - Result := 'BM_SETDONTCLICK'; - - $0090: - Result := 'WM_UAHDESTROYWINDOW'; - $0091: - Result := 'WM_UAHDRAWMENU'; - $0092: - Result := 'WM_UAHDRAWMENUITEM'; - $0093: - Result := 'WM_UAHINITMENU'; - $0094: - Result := 'WM_UAHMEASUREMENUITEM'; - $0095: - Result := 'WM_UAHNCPAINTMENUPOPUP'; - - $01E0: - Result := 'MN_SETHMENU'; - $01E1: - Result := 'MN_GETHMENU'; - $01E2: - Result := 'MN_SIZEWINDOW'; - $01E3: - Result := 'MN_OPENHIERARCHY'; - $01E4: - Result := 'MN_CLOSEHIERARCHY'; - $01E5: - Result := 'MN_SELECTITEM'; - $01E6: - Result := 'MN_CANCELMENUS'; - $01E7: - Result := 'MN_SELECTFIRSTVALIDITEM'; - - $01EA: - Result := 'MN_GETPPOPUPMENU'; - $01EB: - Result := 'MN_FINDMENUWINDOWFROMPOINT'; - $01EC: - Result := 'MN_SHOWPOPUPWINDOW'; - $01ED: - Result := 'MN_BUTTONDOWN'; - $01F0: - Result := 'MN_SETTIMERTOOPENHIERARCHY'; - $01F1: - Result := 'MN_DBLCLK'; - $01F2: - Result := 'MN_ENDMENU'; - $01F3: - Result := 'MN_DODRAGDROP'; - - // button control messages end - $0100: - Result := 'WM_KEYFIRST or WM_KEYDOWN'; - $0101: - Result := 'WM_KEYUP'; - $0102: - Result := 'WM_CHAR'; - $0103: - Result := 'WM_DEADCHAR'; - $0104: - Result := 'WM_SYSKEYDOWN'; - $0105: - Result := 'WM_SYSKEYUP'; - $0106: - Result := 'WM_SYSCHAR'; - $0107: - Result := 'WM_SYSDEADCHAR'; - $0108: - Result := 'WM_KEYLAST'; - $010D: - Result := 'WM_IME_STARTCOMPOSITION'; - $010E: - Result := 'WM_IME_ENDCOMPOSITION'; - $010F: - Result := 'WM_IME_COMPOSITION or WM_IME_KEYLAST'; - $0110: - Result := 'WM_INITDIALOG'; - $0111: - Result := 'WM_COMMAND'; - $0112: - Result := 'WM_SYSCOMMAND'; - $0113: - Result := 'WM_TIMER'; - $0114: - Result := 'WM_HSCROLL'; - $0115: - Result := 'WM_VSCROLL'; - $0116: - Result := 'WM_INITMENU'; - $0117: - Result := 'WM_INITMENUPOPUP'; - $011F: - Result := 'WM_MENUSELECT'; - $0120: - Result := 'WM_MENUCHAR'; - $0121: - Result := 'WM_ENTERIDLE'; - $0122: - Result := 'WM_MENURBUTTONUP'; - $0123: - Result := 'WM_MENUDRAG'; - $0124: - Result := 'WM_MENUGETOBJECT'; - $0125: - Result := 'WM_UNINITMENUPOPUP'; - $0126: - Result := 'WM_MENUCOMMAND'; - $0127: - Result := 'WM_CHANGEUISTATE'; - $0128: - Result := 'WM_UPDATEUISTATE'; - $0129: - Result := 'WM_QUERYUISTATE'; - $0132: - Result := 'WM_CTLCOLORMSGBOX'; - $0133: - Result := 'WM_CTLCOLOREDIT'; - $0134: - Result := 'WM_CTLCOLORLISTBOX'; - $0135: - Result := 'WM_CTLCOLORBTN'; - $0136: - Result := 'WM_CTLCOLORDLG'; - $0137: - Result := 'WM_CTLCOLORSCROLLBAR'; - $0138: - Result := 'WM_CTLCOLORSTATIC'; - $0140: - Result := 'CB_GETEDITSEL'; - $0141: - Result := 'CB_LIMITTEXT'; - $0142: - Result := 'CB_SETEDITSEL'; - $0143: - Result := 'CB_ADDSTRING'; - $0144: - Result := 'CB_DELETESTRING'; - $0145: - Result := 'CB_DIR'; - $0146: - Result := 'CB_GETCOUNT'; - $0147: - Result := 'CB_GETCURSEL'; - $0148: - Result := 'CB_GETLBTEXT'; - $0149: - Result := 'CB_GETLBTEXTLEN'; - $014A: - Result := 'CB_INSERTSTRING'; - $014B: - Result := 'CB_RESETCONTENT'; - $014C: - Result := 'CB_FINDSTRING'; - $014D: - Result := 'CB_SELECTSTRING'; - $014E: - Result := 'CB_SETCURSEL'; - $014F: - Result := 'CB_SHOWDROPDOWN'; - $0150: - Result := 'CB_GETITEMDATA'; - $0151: - Result := 'CB_SETITEMDATA'; - $0152: - Result := 'CB_GETDROPPEDCONTROLRECT'; - $0153: - Result := 'CB_SETITEMHEIGHT'; - $0154: - Result := 'CB_GETITEMHEIGHT'; - $0155: - Result := 'CB_SETEXTENDEDUI'; - $0156: - Result := 'CB_GETEXTENDEDUI'; - $0157: - Result := 'CB_GETDROPPEDSTATE'; - $0158: - Result := 'CB_FINDSTRINGEXACT'; - $0159: - Result := 'CB_SETLOCALE'; - $015A: - Result := 'CB_GETLOCALE'; - $015B: - Result := 'CB_GETTOPINDEX'; - $015C: - Result := 'CB_SETTOPINDEX'; - $015D: - Result := 'CB_GETHORIZONTALEXTENT'; - $015E: - Result := 'CB_SETHORIZONTALEXTENT'; - $015F: - Result := 'CB_GETDROPPEDWIDTH'; - $0160: - Result := 'CB_SETDROPPEDWIDTH'; - $0161: - Result := 'CB_INITSTORAGE'; - $0163: - Result := 'CB_MULTIPLEADDSTRING'; - $0164: - Result := 'CB_GETCOMBOBOXINFO'; - $0200: - Result := 'WM_MOUSEFIRST or WM_MOUSEMOVE'; - $0201: - Result := 'WM_LBUTTONDOWN'; - $0202: - Result := 'WM_LBUTTONUP'; - $0203: - Result := 'WM_LBUTTONDBLCLK'; - $0204: - Result := 'WM_RBUTTONDOWN'; - $0205: - Result := 'WM_RBUTTONUP'; - $0206: - Result := 'WM_RBUTTONDBLCLK'; - $0207: - Result := 'WM_MBUTTONDOWN'; - $0208: - Result := 'WM_MBUTTONUP'; - $0209: - Result := 'WM_MBUTTONDBLCLK'; - $020A: - Result := 'WM_MOUSEWHEEL or WM_MOUSELAST'; - $0210: - Result := 'WM_PARENTNOTIFY'; - $0211: - Result := 'WM_ENTERMENULOOP'; - $0212: - Result := 'WM_EXITMENULOOP'; - $0213: - Result := 'WM_NEXTMENU'; - $0214: - Result := 'WM_SIZING'; - $0215: - Result := 'WM_CAPTURECHANGED'; - $0216: - Result := 'WM_MOVING'; - $0218: - Result := 'WM_POWERBROADCAST'; - $0219: - Result := 'WM_DEVICECHANGE'; - $0220: - Result := 'WM_MDICREATE'; - $0221: - Result := 'WM_MDIDESTROY'; - $0222: - Result := 'WM_MDIACTIVATE'; - $0223: - Result := 'WM_MDIRESTORE'; - $0224: - Result := 'WM_MDINEXT'; - $0225: - Result := 'WM_MDIMAXIMIZE'; - $0226: - Result := 'WM_MDITILE'; - $0227: - Result := 'WM_MDICASCADE'; - $0228: - Result := 'WM_MDIICONARRANGE'; - $0229: - Result := 'WM_MDIGETACTIVE'; - $0230: - Result := 'WM_MDISETMENU'; - $0231: - Result := 'WM_ENTERSIZEMOVE'; - $0232: - Result := 'WM_EXITSIZEMOVE'; - $0233: - Result := 'WM_DROPFILES'; - $0234: - Result := 'WM_MDIREFRESHMENU'; - $0281: - Result := 'WM_IME_SETCONTEXT'; - $0282: - Result := 'WM_IME_NOTIFY'; - $0283: - Result := 'WM_IME_CONTROL'; - $0284: - Result := 'WM_IME_COMPOSITIONFULL'; - $0285: - Result := 'WM_IME_SELECT'; - $0286: - Result := 'WM_IME_CHAR'; - $0288: - Result := 'WM_IME_REQUEST'; - $0290: - Result := 'WM_IME_KEYDOWN'; - $0291: - Result := 'WM_IME_KEYUP'; - $02A1: - Result := 'WM_MOUSEHOVER'; - $02A2: - Result := 'WM_NCMOUSELEAVE'; - $02A3: - Result := 'WM_MOUSELEAVE'; - $0300: - Result := 'WM_CUT'; - $0301: - Result := 'WM_COPY'; - $0302: - Result := 'WM_PASTE'; - $0303: - Result := 'WM_CLEAR'; - $0304: - Result := 'WM_UNDO'; - $0305: - Result := 'WM_RENDERFORMAT'; - $0306: - Result := 'WM_RENDERALLFORMATS'; - $0307: - Result := 'WM_DESTROYCLIPBOARD'; - $0308: - Result := 'WM_DRAWCLIPBOARD'; - $0309: - Result := 'WM_PAINTCLIPBOARD'; - $030A: - Result := 'WM_VSCROLLCLIPBOARD'; - $030B: - Result := 'WM_SIZECLIPBOARD'; - $030C: - Result := 'WM_ASKCBFORMATNAME'; - $030D: - Result := 'WM_CHANGECBCHAIN'; - $030E: - Result := 'WM_HSCROLLCLIPBOARD'; - $030F: - Result := 'WM_QUERYNEWPALETTE'; - $0310: - Result := 'WM_PALETTEISCHANGING'; - $0311: - Result := 'WM_PALETTECHANGED'; - $0312: - Result := 'WM_HOTKEY'; - $0317: - Result := 'WM_PRINT'; - $0318: - Result := 'WM_PRINTCLIENT'; - $031F: - Result := 'WM_DWMNCRENDERINGCHANGED'; - $0358: - Result := 'WM_HANDHELDFIRST'; - $035F: - Result := 'WM_HANDHELDLAST'; - $0380: - Result := 'WM_PENWINFIRST'; - $038F: - Result := 'WM_PENWINLAST'; - $0390: - Result := 'WM_COALESCE_FIRST'; - $039F: - Result := 'WM_COALESCE_LAST'; - $03E0: - Result := 'WM_DDE_FIRST or WM_DDE_INITIATE'; - $03E1: - Result := 'WM_DDE_TERMINATE'; - $03E2: - Result := 'WM_DDE_ADVISE'; - $03E3: - Result := 'WM_DDE_UNADVISE'; - $03E4: - Result := 'WM_DDE_ACK'; - $03E5: - Result := 'WM_DDE_DATA'; - $03E6: - Result := 'WM_DDE_REQUEST'; - $03E7: - Result := 'WM_DDE_POKE'; - $03E8: - Result := 'WM_DDE_EXECUTE or WM_DDE_LAST'; - $0400: - Result := 'WM_USER'; - // progress bar - $0401: - Result := 'PBM_SETRANGE'; - $0402: - Result := 'PBM_SETPOS'; - $0403: - Result := 'PBM_DELTAPOS'; - $0404: - Result := 'PBM_SETSTEP'; - $0405: - Result := 'PBM_STEPIT'; - $0406: - Result := 'PBM_SETRANGE32'; - $0407: - Result := 'PBM_GETRANGE'; - $0408: - Result := 'PBM_GETPOS'; - $0409: - Result := 'PBM_SETBARCOLOR'; - $040A: - Result := 'PBM_SETMARQUEE'; - $040D: - Result := 'PBM_GETSTEP'; - $040E: - Result := 'PBM_GETBKCOLOR'; - $040F: - Result := 'PBM_GETBARCOLOR'; - $0410: - Result := 'PBM_SETSTATE'; - $0411: - Result := 'PBM_GETSTATE'; - // misc - $0469: - Result := 'UDM_SETBUDDY'; - $046A: - Result := 'UDM_GETBUDDY'; - $102C: - Result := 'LVM_GETITEMSTATE'; - $8000: - Result := 'WM_APP'; - - LM_HITTEST: - Result := 'LM_HITTEST'; - LM_GETIDEALHEIGHT: - Result := 'LM_GETIDEALHEIGHT'; - LM_SETITEM: - Result := 'LM_SETITEM'; - LM_GETITEM: - Result := 'LM_GETITEM'; - // LM_GETIDEALSIZE : Result:= 'LM_GETIDEALSIZE'; - - else - begin - if WM_Message > WM_USER then - Result := 'WM_USER + (' + IntToHex(WM_Message - WM_USER, 4) + ')' - - else - Result := 'Unknown(' + IntToHex(WM_Message, 4) + ')'; - end; - end; { Case } -end; - -{$ENDIF} - -function GetWindowClassName(Window: HWND): String; -var - lpClassName: array [0 .. 255] of Char; -begin - Result := ''; - if GetClassName(Window, @lpClassName, Length(lpClassName)) > 0 then - Result := lpClassName; -end; - -function RectVCenter(var R: TRect; const Bounds: TRect): TRect; -begin - OffsetRect(R, -R.Left, -R.Top); - OffsetRect(R, 0, (Bounds.Height - R.Height) div 2); - OffsetRect(R, Bounds.Left, Bounds.Top); - Result := R; -end; - -procedure MoveWindowOrg(DC: HDC; const DX, DY: Integer); -var - P: TPoint; -begin - GetWindowOrgEx(DC, P); - SetWindowOrgEx(DC, P.X - DX, P.Y - DY, nil); -end; - -end. + +{$IFDEF EventLog} + +{ Useful functions when debugging } +procedure AddToLog(const Msg: TMessage); +begin + with Msg do + OutputDebugString(PChar(FormatDateTime('hh:nn:ss.zzz', Now) + ' Msg = ' + WM_To_String(Msg) + ' wParam = ' + + IntToStr(wParam) + ' LParam = ' + IntToStr(lParam))); +end; + +procedure AddToLog(const S: string; const Value: Integer); +begin + OutputDebugString(PChar((S) + ' = ' + IntToStr(Value))); +end; + +procedure AddToLog(const Msg: string); +begin + OutputDebugString(PChar(Msg)); +end; + +function WM_To_String(const WM_Message: Integer): string; +begin + case WM_Message of + $0000: + Result := 'WM_NULL'; + $0001: + Result := 'WM_CREATE'; + $0002: + Result := 'WM_DESTROY'; + $0003: + Result := 'WM_MOVE'; + $0005: + Result := 'WM_SIZE'; + $0006: + Result := 'WM_ACTIVATE'; + $0007: + Result := 'WM_SETFOCUS'; + $0008: + Result := 'WM_KILLFOCUS'; + $000A: + Result := 'WM_ENABLE'; + $000B: + Result := 'WM_SETREDRAW'; + $000C: + Result := 'WM_SETTEXT'; + $000D: + Result := 'WM_GETTEXT'; + $000E: + Result := 'WM_GETTEXTLENGTH'; + $000F: + Result := 'WM_PAINT'; + $0010: + Result := 'WM_CLOSE'; + $0011: + Result := 'WM_QUERYENDSESSION'; + $0012: + Result := 'WM_QUIT'; + $0013: + Result := 'WM_QUERYOPEN'; + $0014: + Result := 'WM_ERASEBKGND'; + $0015: + Result := 'WM_SYSCOLORCHANGE'; + $0016: + Result := 'WM_EndSESSION'; + $0017: + Result := 'WM_SYSTEMERROR'; + $0018: + Result := 'WM_SHOWWINDOW'; + $0019: + Result := 'WM_CTLCOLOR'; + $001A: + Result := 'WM_WININICHANGE or WM_SETTINGCHANGE'; + $001B: + Result := 'WM_DEVMODECHANGE'; + $001C: + Result := 'WM_ACTIVATEAPP'; + $001D: + Result := 'WM_FONTCHANGE'; + $001E: + Result := 'WM_TIMECHANGE'; + $001F: + Result := 'WM_CANCELMODE'; + $0020: + Result := 'WM_SETCURSOR'; + $0021: + Result := 'WM_MOUSEACTIVATE'; + $0022: + Result := 'WM_CHILDACTIVATE'; + $0023: + Result := 'WM_QUEUESYNC'; + $0024: + Result := 'WM_GETMINMAXINFO'; + $0026: + Result := 'WM_PAINTICON'; + $0027: + Result := 'WM_ICONERASEBKGND'; + $0028: + Result := 'WM_NEXTDLGCTL'; + $002A: + Result := 'WM_SPOOLERSTATUS'; + $002B: + Result := 'WM_DRAWITEM'; + $002C: + Result := 'WM_MEASUREITEM'; + $002D: + Result := 'WM_DELETEITEM'; + $002E: + Result := 'WM_VKEYTOITEM'; + $002F: + Result := 'WM_CHARTOITEM'; + $0030: + Result := 'WM_SETFONT'; + $0031: + Result := 'WM_GETFONT'; + $0032: + Result := 'WM_SETHOTKEY'; + $0033: + Result := 'WM_GETHOTKEY'; + $0037: + Result := 'WM_QUERYDRAGICON'; + $0039: + Result := 'WM_COMPAREITEM'; + $003D: + Result := 'WM_GETOBJECT'; + $0041: + Result := 'WM_COMPACTING'; + $0044: + Result := 'WM_COMMNOTIFY { obsolete in Win32}'; + $0046: + Result := 'WM_WINDOWPOSCHANGING'; + $0047: + Result := 'WM_WINDOWPOSCHANGED'; + $0048: + Result := 'WM_POWER'; + $004A: + Result := 'WM_COPYDATA'; + $004B: + Result := 'WM_CANCELJOURNAL'; + $004E: + Result := 'WM_NOTIFY'; + $0050: + Result := 'WM_INPUTLANGCHANGEREQUEST'; + $0051: + Result := 'WM_INPUTLANGCHANGE'; + $0052: + Result := 'WM_TCARD'; + $0053: + Result := 'WM_HELP'; + $0054: + Result := 'WM_USERCHANGED'; + $0055: + Result := 'WM_NOTIFYFORMAT'; + $007B: + Result := 'WM_CONTEXTMENU'; + $007C: + Result := 'WM_STYLECHANGING'; + $007D: + Result := 'WM_STYLECHANGED'; + $007E: + Result := 'WM_DISPLAYCHANGE'; + $007F: + Result := 'WM_GETICON'; + $0080: + Result := 'WM_SETICON'; + $0081: + Result := 'WM_NCCREATE'; + $0082: + Result := 'WM_NCDESTROY'; + $0083: + Result := 'WM_NCCALCSIZE'; + $0084: + Result := 'WM_NCHITTEST'; + $0085: + Result := 'WM_NCPAINT'; + $0086: + Result := 'WM_NCACTIVATE'; + $0087: + Result := 'WM_GETDLGCODE'; + $0088: + Result := 'WM_SYNCPAINT'; + $00A0: + Result := 'WM_NCMOUSEMOVE'; + $00A1: + Result := 'WM_NCLBUTTONDOWN'; + $00A2: + Result := 'WM_NCLBUTTONUP'; + $00A3: + Result := 'WM_NCLBUTTONDBLCLK'; + $00A4: + Result := 'WM_NCRBUTTONDOWN'; + $00A5: + Result := 'WM_NCRBUTTONUP'; + $00A6: + Result := 'WM_NCRBUTTONDBLCLK'; + $00A7: + Result := 'WM_NCMBUTTONDOWN'; + $00A8: + Result := 'WM_NCMBUTTONUP'; + $00A9: + Result := 'WM_NCMBUTTONDBLCLK'; + // edit control messages start (todo: add more if needed) + $00B0: + Result := 'EM_GETSEL'; + $00B1: + Result := 'EM_SETSEL'; + $00B2: + Result := 'EM_GETRECT'; + $00B3: + Result := 'EM_SETRECT'; + $00B4: + Result := 'EM_SETRECTNP'; + $00B5: + Result := 'EM_SCROLL'; + $00B6: + Result := 'EM_LINESCROLL'; + $00B7: + Result := 'EM_SCROLLCARET'; + $00B8: + Result := 'EM_GETMODIFY'; + $00B9: + Result := 'EM_SETMODIFY'; + $00BA: + Result := 'EM_GETLINECOUNT'; + $00BB: + Result := 'EM_LINEINDEX'; + $00BC: + Result := 'EM_SETHANDLE'; + $00BD: + Result := 'EM_GETHANDLE'; + $00BE: + Result := 'EM_GETTHUMB'; + $00C1: + Result := 'EM_LINELENGTH'; + $00C2: + Result := 'EM_REPLACESEL'; + $00C4: + Result := 'EM_GETLINE'; + $00C5: + Result := 'EM_LIMITTEXT'; + $00C6: + Result := 'EM_CANUNDO'; + $00C7: + Result := 'EM_UNDO'; + $00C8: + Result := 'EM_FMTLINES'; + $00C9: + Result := 'EM_LINEFROMCHAR'; + $00CB: + Result := 'EM_SETTABSTOPS'; + $00CC: + Result := 'EM_SETPASSWORDCHAR'; + $00CD: + Result := 'EM_EMPTYUNDOBUFFER'; + $00CE: + Result := 'EM_GETFIRSTVISIBLELINE'; + $00CF: + Result := 'EM_SETREADONLY'; + $00D0: + Result := 'EM_SETWORDBREAKPROC'; + $00D1: + Result := 'EM_GETWORDBREAKPROC'; + $00D2: + Result := 'EM_GETPASSWORDCHAR'; + $00D3: + Result := 'EM_SETMARGINS'; + $00D4: + Result := 'EM_GETMARGINS'; + $00D5: + Result := 'EM_GETLIMITTEXT'; + $00D6: + Result := 'EM_POSFROMCHAR'; + $00D7: + Result := 'EM_CHARFROMPOS'; + // edit control messages end + // scrollbar control messages start + $00E0: + Result := 'SBM_SETPOS'; + $00E1: + Result := 'SBM_GETPOS'; + $00E2: + Result := 'SBM_SETRANGE'; + $00E3: + Result := 'SBM_GETRANGE'; + $00E4: + Result := 'SBM_ENABLE_ARROWS'; + $00E6: + Result := 'SBM_SETRANGEREDRAW'; + $00E9: + Result := 'SBM_SETSCROLLINFO'; + $00EA: + Result := 'SBM_GETSCROLLINFO'; + $00EB: + Result := 'SBM_GETSCROLLBARINFO'; + // scrollbar control messages end + // button control messages start + $00F0: + Result := 'BM_GETCHECK'; + $00F1: + Result := 'BM_SETCHECK'; + $00F2: + Result := 'BM_GETSTATE'; + $00F3: + Result := 'BM_SETSTATE'; + $00F4: + Result := 'BM_SETSTYLE'; + $00F5: + Result := 'BM_CLICK'; + $00F6: + Result := 'BM_GETIMAGE'; + $00F7: + Result := 'BM_SETIMAGE'; + $00F8: + Result := 'BM_SETDONTCLICK'; + + $0090: + Result := 'WM_UAHDESTROYWINDOW'; + $0091: + Result := 'WM_UAHDRAWMENU'; + $0092: + Result := 'WM_UAHDRAWMENUITEM'; + $0093: + Result := 'WM_UAHINITMENU'; + $0094: + Result := 'WM_UAHMEASUREMENUITEM'; + $0095: + Result := 'WM_UAHNCPAINTMENUPOPUP'; + + $01E0: + Result := 'MN_SETHMENU'; + $01E1: + Result := 'MN_GETHMENU'; + $01E2: + Result := 'MN_SIZEWINDOW'; + $01E3: + Result := 'MN_OPENHIERARCHY'; + $01E4: + Result := 'MN_CLOSEHIERARCHY'; + $01E5: + Result := 'MN_SELECTITEM'; + $01E6: + Result := 'MN_CANCELMENUS'; + $01E7: + Result := 'MN_SELECTFIRSTVALIDITEM'; + + $01EA: + Result := 'MN_GETPPOPUPMENU'; + $01EB: + Result := 'MN_FINDMENUWINDOWFROMPOINT'; + $01EC: + Result := 'MN_SHOWPOPUPWINDOW'; + $01ED: + Result := 'MN_BUTTONDOWN'; + $01F0: + Result := 'MN_SETTIMERTOOPENHIERARCHY'; + $01F1: + Result := 'MN_DBLCLK'; + $01F2: + Result := 'MN_ENDMENU'; + $01F3: + Result := 'MN_DODRAGDROP'; + + // button control messages end + $0100: + Result := 'WM_KEYFIRST or WM_KEYDOWN'; + $0101: + Result := 'WM_KEYUP'; + $0102: + Result := 'WM_CHAR'; + $0103: + Result := 'WM_DEADCHAR'; + $0104: + Result := 'WM_SYSKEYDOWN'; + $0105: + Result := 'WM_SYSKEYUP'; + $0106: + Result := 'WM_SYSCHAR'; + $0107: + Result := 'WM_SYSDEADCHAR'; + $0108: + Result := 'WM_KEYLAST'; + $010D: + Result := 'WM_IME_STARTCOMPOSITION'; + $010E: + Result := 'WM_IME_ENDCOMPOSITION'; + $010F: + Result := 'WM_IME_COMPOSITION or WM_IME_KEYLAST'; + $0110: + Result := 'WM_INITDIALOG'; + $0111: + Result := 'WM_COMMAND'; + $0112: + Result := 'WM_SYSCOMMAND'; + $0113: + Result := 'WM_TIMER'; + $0114: + Result := 'WM_HSCROLL'; + $0115: + Result := 'WM_VSCROLL'; + $0116: + Result := 'WM_INITMENU'; + $0117: + Result := 'WM_INITMENUPOPUP'; + $011F: + Result := 'WM_MENUSELECT'; + $0120: + Result := 'WM_MENUCHAR'; + $0121: + Result := 'WM_ENTERIDLE'; + $0122: + Result := 'WM_MENURBUTTONUP'; + $0123: + Result := 'WM_MENUDRAG'; + $0124: + Result := 'WM_MENUGETOBJECT'; + $0125: + Result := 'WM_UNINITMENUPOPUP'; + $0126: + Result := 'WM_MENUCOMMAND'; + $0127: + Result := 'WM_CHANGEUISTATE'; + $0128: + Result := 'WM_UPDATEUISTATE'; + $0129: + Result := 'WM_QUERYUISTATE'; + $0132: + Result := 'WM_CTLCOLORMSGBOX'; + $0133: + Result := 'WM_CTLCOLOREDIT'; + $0134: + Result := 'WM_CTLCOLORLISTBOX'; + $0135: + Result := 'WM_CTLCOLORBTN'; + $0136: + Result := 'WM_CTLCOLORDLG'; + $0137: + Result := 'WM_CTLCOLORSCROLLBAR'; + $0138: + Result := 'WM_CTLCOLORSTATIC'; + $0140: + Result := 'CB_GETEDITSEL'; + $0141: + Result := 'CB_LIMITTEXT'; + $0142: + Result := 'CB_SETEDITSEL'; + $0143: + Result := 'CB_ADDSTRING'; + $0144: + Result := 'CB_DELETESTRING'; + $0145: + Result := 'CB_DIR'; + $0146: + Result := 'CB_GETCOUNT'; + $0147: + Result := 'CB_GETCURSEL'; + $0148: + Result := 'CB_GETLBTEXT'; + $0149: + Result := 'CB_GETLBTEXTLEN'; + $014A: + Result := 'CB_INSERTSTRING'; + $014B: + Result := 'CB_RESETCONTENT'; + $014C: + Result := 'CB_FINDSTRING'; + $014D: + Result := 'CB_SELECTSTRING'; + $014E: + Result := 'CB_SETCURSEL'; + $014F: + Result := 'CB_SHOWDROPDOWN'; + $0150: + Result := 'CB_GETITEMDATA'; + $0151: + Result := 'CB_SETITEMDATA'; + $0152: + Result := 'CB_GETDROPPEDCONTROLRECT'; + $0153: + Result := 'CB_SETITEMHEIGHT'; + $0154: + Result := 'CB_GETITEMHEIGHT'; + $0155: + Result := 'CB_SETEXTENDEDUI'; + $0156: + Result := 'CB_GETEXTENDEDUI'; + $0157: + Result := 'CB_GETDROPPEDSTATE'; + $0158: + Result := 'CB_FINDSTRINGEXACT'; + $0159: + Result := 'CB_SETLOCALE'; + $015A: + Result := 'CB_GETLOCALE'; + $015B: + Result := 'CB_GETTOPINDEX'; + $015C: + Result := 'CB_SETTOPINDEX'; + $015D: + Result := 'CB_GETHORIZONTALEXTENT'; + $015E: + Result := 'CB_SETHORIZONTALEXTENT'; + $015F: + Result := 'CB_GETDROPPEDWIDTH'; + $0160: + Result := 'CB_SETDROPPEDWIDTH'; + $0161: + Result := 'CB_INITSTORAGE'; + $0163: + Result := 'CB_MULTIPLEADDSTRING'; + $0164: + Result := 'CB_GETCOMBOBOXINFO'; + $0200: + Result := 'WM_MOUSEFIRST or WM_MOUSEMOVE'; + $0201: + Result := 'WM_LBUTTONDOWN'; + $0202: + Result := 'WM_LBUTTONUP'; + $0203: + Result := 'WM_LBUTTONDBLCLK'; + $0204: + Result := 'WM_RBUTTONDOWN'; + $0205: + Result := 'WM_RBUTTONUP'; + $0206: + Result := 'WM_RBUTTONDBLCLK'; + $0207: + Result := 'WM_MBUTTONDOWN'; + $0208: + Result := 'WM_MBUTTONUP'; + $0209: + Result := 'WM_MBUTTONDBLCLK'; + $020A: + Result := 'WM_MOUSEWHEEL or WM_MOUSELAST'; + $0210: + Result := 'WM_PARENTNOTIFY'; + $0211: + Result := 'WM_ENTERMENULOOP'; + $0212: + Result := 'WM_EXITMENULOOP'; + $0213: + Result := 'WM_NEXTMENU'; + $0214: + Result := 'WM_SIZING'; + $0215: + Result := 'WM_CAPTURECHANGED'; + $0216: + Result := 'WM_MOVING'; + $0218: + Result := 'WM_POWERBROADCAST'; + $0219: + Result := 'WM_DEVICECHANGE'; + $0220: + Result := 'WM_MDICREATE'; + $0221: + Result := 'WM_MDIDESTROY'; + $0222: + Result := 'WM_MDIACTIVATE'; + $0223: + Result := 'WM_MDIRESTORE'; + $0224: + Result := 'WM_MDINEXT'; + $0225: + Result := 'WM_MDIMAXIMIZE'; + $0226: + Result := 'WM_MDITILE'; + $0227: + Result := 'WM_MDICASCADE'; + $0228: + Result := 'WM_MDIICONARRANGE'; + $0229: + Result := 'WM_MDIGETACTIVE'; + $0230: + Result := 'WM_MDISETMENU'; + $0231: + Result := 'WM_ENTERSIZEMOVE'; + $0232: + Result := 'WM_EXITSIZEMOVE'; + $0233: + Result := 'WM_DROPFILES'; + $0234: + Result := 'WM_MDIREFRESHMENU'; + $0281: + Result := 'WM_IME_SETCONTEXT'; + $0282: + Result := 'WM_IME_NOTIFY'; + $0283: + Result := 'WM_IME_CONTROL'; + $0284: + Result := 'WM_IME_COMPOSITIONFULL'; + $0285: + Result := 'WM_IME_SELECT'; + $0286: + Result := 'WM_IME_CHAR'; + $0288: + Result := 'WM_IME_REQUEST'; + $0290: + Result := 'WM_IME_KEYDOWN'; + $0291: + Result := 'WM_IME_KEYUP'; + $02A1: + Result := 'WM_MOUSEHOVER'; + $02A2: + Result := 'WM_NCMOUSELEAVE'; + $02A3: + Result := 'WM_MOUSELEAVE'; + $0300: + Result := 'WM_CUT'; + $0301: + Result := 'WM_COPY'; + $0302: + Result := 'WM_PASTE'; + $0303: + Result := 'WM_CLEAR'; + $0304: + Result := 'WM_UNDO'; + $0305: + Result := 'WM_RENDERFORMAT'; + $0306: + Result := 'WM_RENDERALLFORMATS'; + $0307: + Result := 'WM_DESTROYCLIPBOARD'; + $0308: + Result := 'WM_DRAWCLIPBOARD'; + $0309: + Result := 'WM_PAINTCLIPBOARD'; + $030A: + Result := 'WM_VSCROLLCLIPBOARD'; + $030B: + Result := 'WM_SIZECLIPBOARD'; + $030C: + Result := 'WM_ASKCBFORMATNAME'; + $030D: + Result := 'WM_CHANGECBCHAIN'; + $030E: + Result := 'WM_HSCROLLCLIPBOARD'; + $030F: + Result := 'WM_QUERYNEWPALETTE'; + $0310: + Result := 'WM_PALETTEISCHANGING'; + $0311: + Result := 'WM_PALETTECHANGED'; + $0312: + Result := 'WM_HOTKEY'; + $0317: + Result := 'WM_PRINT'; + $0318: + Result := 'WM_PRINTCLIENT'; + $031F: + Result := 'WM_DWMNCRENDERINGCHANGED'; + $0358: + Result := 'WM_HANDHELDFIRST'; + $035F: + Result := 'WM_HANDHELDLAST'; + $0380: + Result := 'WM_PENWINFIRST'; + $038F: + Result := 'WM_PENWINLAST'; + $0390: + Result := 'WM_COALESCE_FIRST'; + $039F: + Result := 'WM_COALESCE_LAST'; + $03E0: + Result := 'WM_DDE_FIRST or WM_DDE_INITIATE'; + $03E1: + Result := 'WM_DDE_TERMINATE'; + $03E2: + Result := 'WM_DDE_ADVISE'; + $03E3: + Result := 'WM_DDE_UNADVISE'; + $03E4: + Result := 'WM_DDE_ACK'; + $03E5: + Result := 'WM_DDE_DATA'; + $03E6: + Result := 'WM_DDE_REQUEST'; + $03E7: + Result := 'WM_DDE_POKE'; + $03E8: + Result := 'WM_DDE_EXECUTE or WM_DDE_LAST'; + $0400: + Result := 'WM_USER'; + // progress bar + $0401: + Result := 'PBM_SETRANGE'; + $0402: + Result := 'PBM_SETPOS'; + $0403: + Result := 'PBM_DELTAPOS'; + $0404: + Result := 'PBM_SETSTEP'; + $0405: + Result := 'PBM_STEPIT'; + $0406: + Result := 'PBM_SETRANGE32'; + $0407: + Result := 'PBM_GETRANGE'; + $0408: + Result := 'PBM_GETPOS'; + $0409: + Result := 'PBM_SETBARCOLOR'; + $040A: + Result := 'PBM_SETMARQUEE'; + $040D: + Result := 'PBM_GETSTEP'; + $040E: + Result := 'PBM_GETBKCOLOR'; + $040F: + Result := 'PBM_GETBARCOLOR'; + $0410: + Result := 'PBM_SETSTATE'; + $0411: + Result := 'PBM_GETSTATE'; + // misc + $0469: + Result := 'UDM_SETBUDDY'; + $046A: + Result := 'UDM_GETBUDDY'; + $102C: + Result := 'LVM_GETITEMSTATE'; + $8000: + Result := 'WM_APP'; + + LM_HITTEST: + Result := 'LM_HITTEST'; + LM_GETIDEALHEIGHT: + Result := 'LM_GETIDEALHEIGHT'; + LM_SETITEM: + Result := 'LM_SETITEM'; + LM_GETITEM: + Result := 'LM_GETITEM'; + // LM_GETIDEALSIZE: Result:= 'LM_GETIDEALSIZE'; + + else + begin + if WM_Message > WM_USER then + Result := 'WM_USER + (' + IntToHex(WM_Message - WM_USER, 4) + ')' + + else + Result := 'Unknown(' + IntToHex(WM_Message, 4) + ')'; + end; + end; { Case } +end; + +{$ENDIF} + +function GetWindowClassName(Window: HWND): String; +var + lpClassName: array [0 .. 255] of Char; +begin + Result := ''; + if GetClassName(Window, @lpClassName, Length(lpClassName)) > 0 then + Result := lpClassName; +end; + +function RectVCenter(var R: TRect; const Bounds: TRect): TRect; +begin + OffsetRect(R, -R.Left, -R.Top); + OffsetRect(R, 0, (Bounds.Height - R.Height) div 2); + OffsetRect(R, Bounds.Left, Bounds.Top); + Result := R; +end; + +procedure MoveWindowOrg(DC: HDC; const DX, DY: Integer); +var + P: TPoint; +begin + GetWindowOrgEx(DC, P); + SetWindowOrgEx(DC, P.X - DX, P.Y - DY, nil); +end; + +end. diff --git a/source/vcl-styles-utils/Vcl.Styles.Utils.ScreenTips.pas b/source/vcl-styles-utils/Vcl.Styles.Utils.ScreenTips.pas index 187d43927..32f99c534 100644 --- a/source/vcl-styles-utils/Vcl.Styles.Utils.ScreenTips.pas +++ b/source/vcl-styles-utils/Vcl.Styles.Utils.ScreenTips.pas @@ -1,161 +1,161 @@ -// ************************************************************************************************** -// -// Unit Vcl.Styles.Utils.ScreenTips -// unit for the VCL Styles Utils -// https://github.com/RRUZ/vcl-styles-utils/ -// -// 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. -// -// -// Portions created by Mahdi Safsafi [SMP3] e-mail SMP@LIVE.FR -// Portions created by Rodrigo Ruz V. are Copyright (C) 2013-2019 Rodrigo Ruz V. -// All Rights Reserved. -// -// ************************************************************************************************** -unit Vcl.Styles.Utils.ScreenTips; - -interface - -uses - System.Classes, - System.SysUtils, - Winapi.Windows, - Winapi.Messages, - Vcl.Themes, - Vcl.Graphics, - Vcl.Controls, - Vcl.Styles.Utils.SysStyleHook, - Vcl.Forms, - Vcl.GraphUtil; - -type - TSysTooltipsStyleHook = class(TSysStyleHook) - private - procedure WMPaint(var Message: TMessage); message WM_PAINT; - - protected - procedure Paint(Canvas: TCanvas); override; - procedure PaintHint(Canvas: TCanvas; TextRect: TRect); - procedure WndProc(var Message: TMessage); override; - - public - constructor Create(AHandle: THandle); override; - Destructor Destroy; override; - - end; - -implementation - -uses - Winapi.CommCtrl, - {$IF CompilerVersion >= 30.0} //DX Seattle and UP. - Vcl.SysStyles, - {$IFEND} - Vcl.Styles.Utils.SysControls; - -{ TSysTooltipsStyleHook } -const - TTM_ADJUSTRECT = WM_USER + 31; - -procedure TSysTooltipsStyleHook.PaintHint(Canvas: TCanvas; TextRect: TRect); -var - DC: HDC; - LDetails: TThemedElementDetails; - BkColor, GradientStartColor, GradientEndColor, TextColor, LColor: TColor; - Brush: HBRUSH; - AText: PChar; -begin - DC := Canvas.Handle; - BkColor := $00767676; - GradientStartColor := clWhite; - GradientEndColor := $EFE4E3; - TextColor := $00575757; - - if StyleServices.Enabled then - begin - LDetails := StyleServices.GetElementDetails(thHintBalloon); - if StyleServices.GetElementColor(LDetails, ecBorderColor, LColor) and (LColor <> clNone) then - BkColor := LColor; - if StyleServices.GetElementColor(LDetails, ecGradientColor1, LColor) and (LColor <> clNone) then - GradientStartColor := LColor; - if StyleServices.GetElementColor(LDetails, ecGradientColor2, LColor) and (LColor <> clNone) then - GradientEndColor := LColor; - if StyleServices.GetElementColor(LDetails, ecTextColor, LColor) and (LColor <> clNone) then - TextColor := LColor; - end; - { Draw Tooltips Face } - GradientFillCanvas(Canvas, GradientStartColor, GradientEndColor, SysControl.ClientRect, gdVertical); - { Draw Tooltips Border } - Brush := CreateSolidBrush(ColorToRGB(BkColor)); - FrameRect(DC, SysControl.ClientRect, Brush); - DeleteObject(Brush); - { Use default font for Tooltips text } - SelectObject(DC, Screen.HintFont.Handle); - { Draw Tooltips Text } - SetBkMode(DC, TRANSPARENT); - SetTextColor(DC, ColorToRGB(TextColor)); - AText := PChar(SysControl.Text); - Winapi.Windows.DrawText(DC, AText, -1, TextRect, DT_LEFT); -end; - -procedure TSysTooltipsStyleHook.WMPaint(var Message: TMessage); -begin - CallDefaultProc(Message); - if (GetWindowLong(Handle, GWL_STYLE) and TTS_BALLOON) = TTS_BALLOON then - Handled := True - else - inherited; -end; - -procedure TSysTooltipsStyleHook.WndProc(var Message: TMessage); -begin - inherited; -end; - -constructor TSysTooltipsStyleHook.Create(AHandle: THandle); -begin - inherited; -{$IF CompilerVersion > 23.0} - StyleElements := [seClient]; -{$ELSE} - OverridePaint := True; - OverridePaintNC := False; - OverrideFont := False; -{$IFEND} -end; - -destructor TSysTooltipsStyleHook.Destroy; -begin - inherited; -end; - -procedure TSysTooltipsStyleHook.Paint(Canvas: TCanvas); -Var - TextRect: TRect; -begin - { Adjust text rectangle } - TextRect := SysControl.ClientRect; - SendMessage(Handle, TTM_ADJUSTRECT, 0, UINT_PTR(@TextRect)); - PaintHint(Canvas, TextRect); -end; - -initialization - -{$IF CompilerVersion >= 30.0} //DX Seattle and UP. - TCustomStyleEngine.UnRegisterSysStyleHook('tooltips_class32', Vcl.SysStyles.TSysTooltipsStyleHook); -{$IFEND} - - -if StyleServices.Available then - TSysStyleManager.RegisterSysStyleHook(TOOLTIPS_CLASS, TSysTooltipsStyleHook); - -finalization - TSysStyleManager.UnRegisterSysStyleHook(TOOLTIPS_CLASS, TSysTooltipsStyleHook); - -end. +// ************************************************************************************************** +// +// Unit Vcl.Styles.Utils.ScreenTips +// unit for the VCL Styles Utils +// https://github.com/RRUZ/vcl-styles-utils/ +// +// 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. +// +// +// Portions created by Mahdi Safsafi [SMP3] e-mail SMP@LIVE.FR +// Portions created by Rodrigo Ruz V. are Copyright (C) 2013-2023 Rodrigo Ruz V. +// All Rights Reserved. +// +// ************************************************************************************************** +unit Vcl.Styles.Utils.ScreenTips; + +interface + +uses + System.Classes, + System.SysUtils, + Winapi.Windows, + Winapi.Messages, + Vcl.Themes, + Vcl.Graphics, + Vcl.Controls, + Vcl.Styles.Utils.SysStyleHook, + Vcl.Forms, + Vcl.GraphUtil; + +type + TSysTooltipsStyleHook = class(TSysStyleHook) + private + procedure WMPaint(var Message: TMessage); message WM_PAINT; + + protected + procedure Paint(Canvas: TCanvas); override; + procedure PaintHint(Canvas: TCanvas; TextRect: TRect); + procedure WndProc(var Message: TMessage); override; + + public + constructor Create(AHandle: THandle); override; + Destructor Destroy; override; + + end; + +implementation + +uses + Winapi.CommCtrl, + {$IF CompilerVersion >= 30.0} //DX Seattle and UP. + Vcl.SysStyles, + {$IFEND} + Vcl.Styles.Utils.SysControls; + +{ TSysTooltipsStyleHook } +const + TTM_ADJUSTRECT = WM_USER + 31; + +procedure TSysTooltipsStyleHook.PaintHint(Canvas: TCanvas; TextRect: TRect); +var + DC: HDC; + LDetails: TThemedElementDetails; + BkColor, GradientStartColor, GradientEndColor, TextColor, LColor: TColor; + Brush: HBRUSH; + AText: PChar; +begin + DC := Canvas.Handle; + BkColor := $00767676; + GradientStartColor := clWhite; + GradientEndColor := $EFE4E3; + TextColor := $00575757; + + if StyleServices.Enabled then + begin + LDetails := StyleServices.GetElementDetails(thHintBalloon); + if StyleServices.GetElementColor(LDetails, ecBorderColor, LColor) and (LColor <> clNone) then + BkColor := LColor; + if StyleServices.GetElementColor(LDetails, ecGradientColor1, LColor) and (LColor <> clNone) then + GradientStartColor := LColor; + if StyleServices.GetElementColor(LDetails, ecGradientColor2, LColor) and (LColor <> clNone) then + GradientEndColor := LColor; + if StyleServices.GetElementColor(LDetails, ecTextColor, LColor) and (LColor <> clNone) then + TextColor := LColor; + end; + { Draw Tooltips Face } + GradientFillCanvas(Canvas, GradientStartColor, GradientEndColor, SysControl.ClientRect, gdVertical); + { Draw Tooltips Border } + Brush := CreateSolidBrush(ColorToRGB(BkColor)); + FrameRect(DC, SysControl.ClientRect, Brush); + DeleteObject(Brush); + { Use default font for Tooltips text } + SelectObject(DC, Screen.HintFont.Handle); + { Draw Tooltips Text } + SetBkMode(DC, TRANSPARENT); + SetTextColor(DC, ColorToRGB(TextColor)); + AText := PChar(SysControl.Text); + Winapi.Windows.DrawText(DC, AText, -1, TextRect, DT_LEFT); +end; + +procedure TSysTooltipsStyleHook.WMPaint(var Message: TMessage); +begin + CallDefaultProc(Message); + if (GetWindowLong(Handle, GWL_STYLE) and TTS_BALLOON) = TTS_BALLOON then + Handled := True + else + inherited; +end; + +procedure TSysTooltipsStyleHook.WndProc(var Message: TMessage); +begin + inherited; +end; + +constructor TSysTooltipsStyleHook.Create(AHandle: THandle); +begin + inherited; +{$IF CompilerVersion > 23.0} + StyleElements := [seClient]; +{$ELSE} + OverridePaint := True; + OverridePaintNC := False; + OverrideFont := False; +{$IFEND} +end; + +destructor TSysTooltipsStyleHook.Destroy; +begin + inherited; +end; + +procedure TSysTooltipsStyleHook.Paint(Canvas: TCanvas); +Var + TextRect: TRect; +begin + { Adjust text rectangle } + TextRect := SysControl.ClientRect; + SendMessage(Handle, TTM_ADJUSTRECT, 0, UINT_PTR(@TextRect)); + PaintHint(Canvas, TextRect); +end; + +initialization + +{$IF CompilerVersion >= 30.0} //DX Seattle and UP. + TCustomStyleEngine.UnRegisterSysStyleHook('tooltips_class32', Vcl.SysStyles.TSysTooltipsStyleHook); +{$IFEND} + + +if StyleServices.Available then + TSysStyleManager.RegisterSysStyleHook(TOOLTIPS_CLASS, TSysTooltipsStyleHook); + +finalization + TSysStyleManager.UnRegisterSysStyleHook(TOOLTIPS_CLASS, TSysTooltipsStyleHook); + +end. diff --git a/source/vcl-styles-utils/Vcl.Styles.Utils.StdCtrls.pas b/source/vcl-styles-utils/Vcl.Styles.Utils.StdCtrls.pas index 815c5b7b9..88a2bc37f 100644 --- a/source/vcl-styles-utils/Vcl.Styles.Utils.StdCtrls.pas +++ b/source/vcl-styles-utils/Vcl.Styles.Utils.StdCtrls.pas @@ -1,2866 +1,2888 @@ -// ************************************************************************************************** -// -// Unit Vcl.Styles.Utils.StdCtrls -// unit for the VCL Styles Utils -// https://github.com/RRUZ/vcl-styles-utils/ -// -// 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. -// -// -// Portions created by Mahdi Safsafi [SMP3] e-mail SMP@LIVE.FR -// Portions created by Rodrigo Ruz V. are Copyright (C) 2013-2019 Rodrigo Ruz V. -// All Rights Reserved. -// -// ************************************************************************************************** -unit Vcl.Styles.Utils.StdCtrls; - -interface - -uses - System.Classes, - System.SysUtils, - System.Types, - Winapi.Windows, - Winapi.Messages, - Winapi.CommCtrl, - Vcl.Themes, - Vcl.Graphics, - Vcl.Styles.Utils.SysStyleHook, - Vcl.Forms, - Vcl.StdCtrls, - Vcl.Styles.Utils.Forms, - Vcl.GraphUtil, - Vcl.Controls; - -const - BS_SPLITBUTTON = $0000000C; -{$EXTERNALSYM BS_DEFSPLITBUTTON} - BS_DEFSPLITBUTTON = $0000000D; -{$EXTERNALSYM BS_COMMANDLINK} - BS_COMMANDLINK = $0000000E; -{$EXTERNALSYM BS_DEFCOMMANDLINK} - BS_DEFCOMMANDLINK = $0000000F; - -type - TSysCheckBoxState = (cbUnchecked, cbChecked, cbGrayed); - - TSysButtonStyleHook = class(TMouseTrackSysControlStyleHook) - private - function GetCaptionRect(Canvas: TCanvas): TRect; - function GetBoxRect: TRect; - function IsCheckBox: Boolean; - function IsRadioButton: Boolean; - function IsGroupBox: Boolean; - function IsPushButton: Boolean; - function IsSplitButton: Boolean; - function IsCommandButton: Boolean; - function GetTextAlign: TTextFormat; - function GetShowText: Boolean; - function GetCheckBoxState: TSysCheckBoxState; - procedure WMPaint(var Message: TMessage); message WM_PAINT; - procedure WMNCPaint(var Message: TMessage); message WM_NCPAINT; - procedure WMEraseBkgnd(var Message: TMessage); message WM_ERASEBKGND; - function IsOwnerDraw: Boolean; - protected - procedure DrawCheckBoxText(DC: HDC; Text: String; - LDetails: TThemedElementDetails; R: TRect); virtual; - procedure PaintButton(Canvas: TCanvas); virtual; - procedure PaintCheckBox(Canvas: TCanvas); virtual; - procedure PaintRadioButton(Canvas: TCanvas); virtual; - procedure PaintGroupBox(Canvas: TCanvas); virtual; - procedure MouseEnter; override; - procedure MouseLeave; override; - procedure Paint(Canvas: TCanvas); override; - procedure PaintNC(Canvas: TCanvas); override; - procedure PaintBackground(Canvas: TCanvas); override; - procedure WndProc(var Message: TMessage); override; - procedure UpdateColors; override; - public - constructor Create(AHandle: THandle); override; - Destructor Destroy; override; - property CheckBox: Boolean read IsCheckBox; - property CommandButton: Boolean read IsCommandButton; - property RadioButton: Boolean read IsRadioButton; - property GroupBox: Boolean read IsGroupBox; - property PushButton: Boolean read IsPushButton; - property SplitButton: Boolean read IsSplitButton; - property CheckBoxState: TSysCheckBoxState read GetCheckBoxState; - property TextAlign: TTextFormat read GetTextAlign; - property ShowText: Boolean read GetShowText; - property OwnerDraw: Boolean read IsOwnerDraw; - end; - - TSysEditStyleHook = class(TMouseTrackSysControlStyleHook) - private - procedure WMNCCalcSize(var Message: TWMNCCalcSize); message WM_NCCALCSIZE; - protected - procedure PaintNC(Canvas: TCanvas); override; - procedure WndProc(var Message: TMessage); override; - procedure UpdateColors; override; - procedure MouseEnter; override; - procedure MouseLeave; override; - function GetBorderSize: TRect; override; - public - constructor Create(AHandle: THandle); override; - Destructor Destroy; override; - end; - - TSysMemoStyleHook = class(TSysScrollingStyleHook) - strict protected - procedure UpdateColors; override; - procedure WndProc(var Message: TMessage); override; - function GetBorderSize: TRect; override; - public - constructor Create(AHandle: THandle); override; - end; - - TSysListBoxStyleHook = class(TSysScrollingStyleHook) - protected - function GetBorderSize: TRect; override; - procedure WndProc(var Message: TMessage); override; - procedure UpdateColors; override; - procedure PaintBackground(Canvas: TCanvas); override; - public - constructor Create(AHandle: THandle); override; - Destructor Destroy; override; - end; - - TSysComboBoxStyleHook = class(TMouseTrackSysControlStyleHook) - strict private - FDownPos, FMovePos: TPoint; - FDownSliderPos: Integer; - FOldIdx, FInvsibleCount, FSliderSize: Integer; - FVSliderState, FVUpState, FVDownState: TThemedScrollBar; - FIgnoreStyleChanged: Boolean; - FMouseOnButton: Boolean; - FListHandle, FEditHandle: HWnd; - FListBoxInstance: Pointer; - FDefListBoxProc: Pointer; - FListBoxTimerCode: Integer; - FListBoxUpBtnDown, FListBoxDownBtnDown, FListBoxTrackUpDown, - FListBoxTrackDownDown: Boolean; - procedure DrawListBoxVertScroll(DC: HDC); - procedure DrawListBoxBorder; - function IsDroppedDown: Boolean; - function GetButtonRect: TRect; - function Style: TComboBoxStyle; - function ListBoxBoundsRect: TRect; - function ListBoxClientRect: TRect; - procedure ListBoxSetTimer(const ATimerCode: Integer); - procedure ListBoxStopTimer; - function ListBoxVertScrollRect: TRect; - function ListBoxVertDownButtonRect: TRect; - function ListBoxVertUpButtonRect: TRect; - function ListBoxVertScrollArea: TRect; - function ListBoxVertSliderRect: TRect; - function ListBoxVertTrackRect: TRect; - function ListBoxVertTrackRectUp: TRect; - function ListBoxVertTrackRectDown: TRect; - procedure PaintListBoxBorder(Canvas: TCanvas; const R: TRect); - procedure WMCommand(var Message: TWMCommand); message WM_COMMAND; - procedure CNCommand(var Message: TWMCommand); message CN_COMMAND; - procedure WMPaint(var Message: TMessage); message WM_PAINT; - procedure WMMouseMove(var Message: TWMMouse); message WM_MOUSEMOVE; - procedure CNDrawItem(var Message: TWMDrawItem); message CN_DRAWITEM; - procedure WMDrawItem(var Message: TWMDrawItem); message WM_DRAWITEM; - procedure WMParentNotify(var Message: TMessage); message WM_PARENTNOTIFY; - strict protected - procedure UpdateColors; override; - function IsChildHandle(AHandle: HWnd): Boolean; override; - procedure DrawItem(Canvas: TCanvas;const Index: UINT; const R: TRect; - const Selected: Boolean); virtual; - procedure HookListBox(AListHandle: HWnd); - property ListBoxInstance: Pointer read FListBoxInstance; - procedure ListBoxWndProc(var Msg: TMessage); virtual; - property ListHandle: HWnd read FListHandle; - procedure MouseEnter; override; - procedure MouseLeave; override; - procedure PaintBorder(Canvas: TCanvas); virtual; - procedure WndProc(var Message: TMessage); override; - function CallDefaultListBoxProc(var Msg: TMessage): LRESULT; - property ButtonRect: TRect read GetButtonRect; - property MouseOnButton: Boolean read FMouseOnButton write FMouseOnButton; - property DroppedDown: Boolean read IsDroppedDown; - public - constructor Create(AHandle: THandle); override; - Destructor Destroy; override; - end; - - TSysStaticStyleHook = class(TSysStyleHook) - private - FUpdatedColor: TColor; - function GetIsText: Boolean; - function GetTextFormat: TTextFormat; - function GetIsFrameOrLine: Boolean; - protected - procedure Paint(Canvas: TCanvas); override; - procedure PaintNC(Canvas: TCanvas); override; - procedure UpdateColors; override; - procedure WndProc(var Message: TMessage); override; - public - constructor Create(AHandle: THandle); override; - Destructor Destroy; override; - property IsText: Boolean read GetIsText; - property IsFrameOrLine: Boolean read GetIsFrameOrLine; - property TextFormat: TTextFormat read GetTextFormat; - end; - - TSysCheckBoxStyleHook = class(TMouseTrackSysControlStyleHook) - strict private - FPressed: Boolean; - procedure WMLButtonDown(var Message: TWMMouse); message WM_LBUTTONDOWN; - procedure WMLButtonUp(var Message: TWMMouse); message WM_LBUTTONUP; - procedure WMLButtonDblClk(var Message: TWMMouse); message WM_LBUTTONDBLCLK; - procedure WMKeyDown(var Message: TWMKeyDown); message WM_KEYDOWN; - procedure WMKeyUp(var Message: TWMKeyUp); message WM_KEYUP; - procedure BMSetCheck(var Message: TMessage); message BM_SETCHECK; - function RightAlignment: Boolean; - strict protected - function GetDrawState(State: TSysCheckBoxState): TThemedButton; virtual; - procedure Paint(Canvas: TCanvas); override; - procedure PaintBackground(Canvas: TCanvas); override; - procedure MouseEnter; override; - procedure MouseLeave; override; - procedure WndProc(var Message: TMessage); override; - property Pressed: Boolean read FPressed; - public - constructor Create(AHandle: THandle); override; - end; - - TSysRadioButtonStyleHook = class(TSysCheckBoxStyleHook) - strict protected - function GetDrawState(State: TSysCheckBoxState): TThemedButton; override; - procedure WndProc(var Message: TMessage); override; - public - constructor Create(AHandle: THandle); override; - end; - - -implementation - -uses - Vcl.ExtCtrls, - System.UITypes, - Vcl.Styles.Utils.Misc, - Vcl.Styles.Utils.SysControls; - -{ TSysEditStyleHook } - -constructor TSysEditStyleHook.Create(AHandle: THandle); -begin - inherited; -{$IF CompilerVersion > 23} - StyleElements := [seFont, seBorder]; -{$ELSE} - OverridePaint := False; - OverridePaintNC := True; - OverrideFont := True; -{$IFEND} -end; - -destructor TSysEditStyleHook.Destroy; -begin - inherited; -end; - -function TSysEditStyleHook.GetBorderSize: TRect; -begin - if SysControl.HasBorder then - Result := Rect(2, 2, 2, 2); -end; - -procedure TSysEditStyleHook.MouseEnter; -begin - InvalidateNC; -end; - -procedure TSysEditStyleHook.MouseLeave; -begin - InvalidateNC; -end; - -procedure TSysEditStyleHook.PaintNC(Canvas: TCanvas); -var - Details: TThemedElementDetails; - R: TRect; -begin - if StyleServicesEnabled and SysControl.HasBorder then - begin - if Focused then - Details := StyleServices.GetElementDetails(teEditBorderNoScrollFocused) - else if MouseInControl then - Details := StyleServices.GetElementDetails(teEditBorderNoScrollHot) - else if SysControl.Enabled then - Details := StyleServices.GetElementDetails(teEditBorderNoScrollNormal) - else - Details := StyleServices.GetElementDetails(teEditBorderNoScrollDisabled); - R := Rect(0, 0, SysControl.Width, SysControl.Height); - InflateRect(R, -2, -2); - ExcludeClipRect(Canvas.Handle, R.Left, R.Top, R.Right, R.Bottom); - StyleServices.DrawElement(Canvas.Handle, Details, - Rect(0, 0, SysControl.Width, SysControl.Height)); - end; -end; - -procedure TSysEditStyleHook.UpdateColors; -const - ColorStates: array [Boolean] of TStyleColor = (scEditDisabled, scEdit); - FontColorStates: array [Boolean] of TStyleFont = (sfEditBoxTextDisabled, - sfEditBoxTextNormal); -begin - Color := StyleServices.GetStyleColor(ColorStates[SysControl.Enabled]); -{$IF CompilerVersion > 23} - if seFont in StyleElements then - FontColor := StyleServices.GetStyleFontColor - (FontColorStates[SysControl.Enabled]) - else - FontColor := clWindowText; -{$ELSE} - FontColor := StyleServices.GetStyleFontColor - (FontColorStates[SysControl.Enabled]); -{$IFEND} -end; - -procedure TSysEditStyleHook.WMNCCalcSize(var Message: TWMNCCalcSize); -var - Params: PNCCalcSizeParams; -begin - Handled := False; - if (not StyleServicesEnabled) or (not OverridePaintNC) then - Exit; - - Params := Message.CalcSize_Params; - if SysControl.HasBorder then - with Params^.rgrc[0] do - begin - Inc(Left, 2); - Inc(Top, 2); - Dec(Right, 2); - Dec(Bottom, 2); - end; - Handled := True; -end; - -procedure TSysEditStyleHook.WndProc(var Message: TMessage); -begin - case Message.Msg of - CM_CTLCOLORMSGBOX .. CM_CTLCOLORSTATIC: - begin - { Change edit control color . } - SetTextColor(Message.wParam, ColorToRGB(FontColor)); - SetBkColor(Message.wParam, ColorToRGB(Color)); - Message.Result := LRESULT(Brush.Handle); - end; - else - inherited WndProc(Message); - end; - -end; - -{ TSysListBoxStyleHook } - -constructor TSysListBoxStyleHook.Create(AHandle: THandle); -begin - inherited; -{$IF CompilerVersion > 23} - StyleElements := [seBorder]; -{$ELSE} - OverridePaint := False; - OverridePaintNC := True; - OverrideFont := False; -{$IFEND} - //OverrideEraseBkgnd:=True; -end; - -destructor TSysListBoxStyleHook.Destroy; -begin - - inherited; -end; - -function TSysListBoxStyleHook.GetBorderSize: TRect; -begin - Result := inherited GetBorderSize; - if (SysControl.HasBorder) then - begin - Result := Rect(2, 2, 2, 2); - end; - if SameText(SysControl.ControlClassName, 'ComboLBox') then - begin - if SysControl.Parent.Style and CBS_SIMPLE = CBS_SIMPLE then - Exit; - Result := Rect(0, 0, 0, 0); - end; -end; - -procedure TSysListBoxStyleHook.PaintBackground(Canvas: TCanvas); -begin - inherited; -end; - -procedure TSysListBoxStyleHook.UpdateColors; -const - ColorStates: array[Boolean] of TStyleColor = (scListBoxDisabled, scListBox); - FontColorStates: array[Boolean] of TStyleFont = (sfListItemTextDisabled, sfListItemTextNormal); -var - LStyle: TCustomStyleServices; -begin - LStyle := StyleServices; - Brush.Color := LStyle.GetStyleColor(ColorStates[SysControl.Enabled]); - FontColor := LStyle.GetStyleFontColor(FontColorStates[SysControl.Enabled]); -end; - -procedure TSysListBoxStyleHook.WndProc(var Message: TMessage); -begin - inherited; -end; - -{ TSysButtonStyleHook } - -constructor TSysButtonStyleHook.Create(AHandle: THandle); -begin - inherited; - ParentColor := True; -{$IF CompilerVersion > 23} - StyleElements := [seFont, seClient, seBorder]; -{$ELSE} - OverridePaint := True; - OverridePaintNC := True; - OverrideFont := True; -{$IFEND} - Color := StyleServices.GetStyleColor(scWindow); -end; - -destructor TSysButtonStyleHook.Destroy; -begin - - inherited; -end; - -procedure TSysButtonStyleHook.DrawCheckBoxText(DC: HDC; Text: String; - LDetails: TThemedElementDetails; R: TRect); -var - TextFormat: TTextFormat; -begin - if ShowText then - begin - TextFormat := [tfVerticalCenter, tfHidePrefix]; - if (SysControl.Style and BS_MULTILINE = BS_MULTILINE) then - include(TextFormat, tfWordBreak) - else - include(TextFormat, tfSingleLine); - if (SysControl.Style and BS_LEFT = BS_LEFT) then - include(TextFormat, tfLeft) - else if (SysControl.Style and BS_RIGHT = BS_RIGHT) then - include(TextFormat, tfRight) - else if (SysControl.Style and BS_CENTER = BS_CENTER) then - include(TextFormat, tfCenter); - DrawText(DC, LDetails, SysControl.Text, R, TextFormat); - end; -end; - -function TSysButtonStyleHook.GetCheckBoxState: TSysCheckBoxState; -var - LState: DWORD; -begin - LState := SendMessage(Handle, BM_GETCHECK, 0, 0); - Result := TSysCheckBoxState(LState) -end; - -function TSysButtonStyleHook.GetShowText: Boolean; -begin - Result := (SysControl.Style and BS_TEXT = BS_TEXT); -end; - -function TSysButtonStyleHook.GetTextAlign: TTextFormat; -begin - Result := []; - with SysControl do - begin - // if Style and BS_LEFTTEXT then - - end; -end; - -function TSysButtonStyleHook.IsCheckBox: Boolean; -begin - with SysControl do - Result := (Style and BS_CHECKBOX = BS_CHECKBOX) or - (Style and BS_AUTOCHECKBOX = BS_AUTOCHECKBOX); -end; - -function TSysButtonStyleHook.IsCommandButton: Boolean; -begin - Result := (SysControl.Style and BS_COMMANDLINK = BS_COMMANDLINK) or - (SysControl.Style and BS_DEFCOMMANDLINK = BS_DEFCOMMANDLINK); -end; - -function TSysButtonStyleHook.IsGroupBox: Boolean; -begin - Result := (SysControl.Style and BS_GROUPBOX = BS_GROUPBOX); -end; - -function TSysButtonStyleHook.IsOwnerDraw: Boolean; -begin - Result := (SysControl.Style and BS_OWNERDRAW = BS_OWNERDRAW); -end; - -function TSysButtonStyleHook.IsPushButton: Boolean; -begin - with SysControl do - Result := (Style and BS_PUSHBUTTON = BS_PUSHBUTTON) or - (not CheckBox and not RadioButton and not GroupBox and not CommandButton); -end; - -function TSysButtonStyleHook.IsRadioButton: Boolean; -begin - with SysControl do - Result := (Style and BS_RADIOBUTTON = BS_RADIOBUTTON) or - (Style and BS_AUTORADIOBUTTON = BS_AUTORADIOBUTTON); - - if Result then - Result:= not IsSplitButton; -end; - -function TSysButtonStyleHook.IsSplitButton: Boolean; -begin - Result := (SysControl.Style and BS_SPLITBUTTON = BS_SPLITBUTTON) or - (SysControl.Style and BS_DEFSPLITBUTTON = BS_DEFSPLITBUTTON); - -end; - -procedure TSysButtonStyleHook.MouseEnter; -begin - // Invalidate; -end; - -procedure TSysButtonStyleHook.MouseLeave; -begin - Invalidate; -end; - -procedure TSysButtonStyleHook.Paint(Canvas: TCanvas); -begin - //OutputDebugString(PChar('Paint '+IntToHex(SysControl.Handle, 8))); - if not GroupBox or CommandButton then - PaintBackground(Canvas) - else - Exit; - - if CommandButton then - PaintButton(Canvas) - else - if CheckBox then - PaintCheckBox(Canvas) - else - if RadioButton then - PaintRadioButton(Canvas) - else - if PushButton then - PaintButton(Canvas); - -end; - -procedure TSysButtonStyleHook.PaintBackground(Canvas: TCanvas); -begin - if not GroupBox then - inherited; -end; - -procedure TSysButtonStyleHook.PaintButton(Canvas: TCanvas); -var - LDetails: TThemedElementDetails; - LRect: TRect; - Detail: TThemedButton; - X, Y, i: Integer; - IW, IH, IY: Integer; - TextFormat: TTextFormat; - IL: BUTTON_IMAGELIST; - LText: string; - DrawRect: TRect; - ThemeTextColor: TColor; - Buffer: string; - BufferLength: Integer; -begin - LText := SysControl.Text; - LRect := SysControl.ClientRect; - - if SysControl.Enabled then - Detail := tbPushButtonNormal - else - Detail := tbPushButtonDisabled; - - if MouseDown then - Detail := tbPushButtonPressed - else - if MouseInControl then - Detail := tbPushButtonHot - else - if Focused then - Detail := tbPushButtonDefaulted; - - LDetails := StyleServices.GetElementDetails(Detail); - DrawRect := SysControl.ClientRect; - StyleServices.DrawElement(Canvas.Handle, LDetails, LRect); - - - if Button_GetImageList(handle, IL) and (IL.himl <> 0) and - ImageList_GetIconSize(IL.himl, IW, IH) then - begin - if (GetWindowLong(Handle, GWL_STYLE) and BS_COMMANDLINK) = BS_COMMANDLINK then - IY := DrawRect.Top + 15 - else - IY := DrawRect.Top + (DrawRect.Height - IH) div 2; - ImageList_Draw(IL.himl, 0, Canvas.Handle, DrawRect.Left + 3, IY, ILD_NORMAL); - Inc(DrawRect.Left, IW + 3); - end; - - if CommandButton then - begin - if IL.himl = 0 then - Inc(DrawRect.Left, 35); - Inc(DrawRect.Top, 15); - Inc(DrawRect.Left, 5); - Canvas.Font := SysControl.Font; - TextFormat := TTextFormatFlags(DT_LEFT); - if StyleServices.GetElementColor(LDetails, ecTextColor, ThemeTextColor) then - Canvas.Font.Color := ThemeTextColor; - StyleServices.DrawText(Canvas.Handle, LDetails, LText, DrawRect, TextFormat, Canvas.Font.Color); - SetLength(Buffer, Button_GetNoteLength(Handle) + 1); - if Length(Buffer) <> 0 then - begin - BufferLength := Length(Buffer); - if Button_GetNote(Handle, PChar(Buffer), BufferLength) then - begin - TextFormat := TTextFormatFlags(DT_LEFT or DT_WORDBREAK); - Inc(DrawRect.Top, Canvas.TextHeight('Wq') + 2); - Canvas.Font.Size := 8; - StyleServices.DrawText(Canvas.Handle, LDetails, Buffer, DrawRect, - TextFormat, Canvas.Font.Color); - end; - end; - if IL.himl = 0 then - begin - if MouseDown then - LDetails := StyleServices.GetElementDetails(tbCommandLinkGlyphPressed) - else if MouseInControl then - LDetails := StyleServices.GetElementDetails(tbCommandLinkGlyphHot) - else if SysControl.Enabled then - LDetails := StyleServices.GetElementDetails(tbCommandLinkGlyphNormal) - else - LDetails := StyleServices.GetElementDetails(tbCommandLinkGlyphDisabled); - DrawRect.Right := 35; - DrawRect.Left := 3; - DrawRect.Top := 10; - DrawRect.Bottom := DrawRect.Top + 32; - StyleServices.DrawElement(Canvas.Handle, LDetails, DrawRect); - end; - - end - else - if SplitButton then - with Canvas, SysControl do - begin - { draw vertical line } - Pen.Color := StyleServices.GetSystemColor(clBtnShadow); - MoveTo(Width - 15, 3); - LineTo(Width - 15, Height - 3); - if Enabled then - Pen.Color := StyleServices.GetSystemColor(clBtnHighLight) - else - Pen.Color := Font.Color; - MoveTo(Width - 14, 3); - LineTo(Width - 14, Height - 3); - { Draw arrow } - Pen.Color := Font.Color; - X := Width - 8; - Y := Height div 2 + 1; - for i := 3 downto 0 do - begin - MoveTo(X - i, Y - i); - LineTo(X + i + 1, Y - i); - end; - end; - - if ShowText and not IsCommandButton then - begin - TextFormat := [tfCenter, tfVerticalCenter, tfSingleLine, tfHidePrefix]; - if (SysControl.Style and BS_MULTILINE = BS_MULTILINE) then - begin - Exclude(TextFormat, tfSingleLine); - include(TextFormat, tfWordBreak) - end; - - - DrawText(Canvas.Handle, LDetails, SysControl.Text, LRect, TextFormat); - end; -end; - -function TSysButtonStyleHook.GetBoxRect: TRect; -var - DC: HDC; - sSize: TSize; -begin - DC := GetDC(Handle); - with SysControl do - begin - GetTextExtentPoint32(DC, Text, Length(Text) - 1, sSize); - Result := Rect(0, sSize.Height div 2 + 1, Width - 0, Height - 0); - end; - ReleaseDC(Handle, DC); - DeleteDC(DC); -end; - -function TSysButtonStyleHook.GetCaptionRect(Canvas: TCanvas): TRect; -const - FCaptionMargin = 12; -begin - with SysControl do - if BiDiMode <> bmRightToLeft then - Result := Rect(FCaptionMargin, 0, FCaptionMargin + Canvas.TextWidth(Text), - Canvas.TextHeight(Text)) - else - Result := Rect(Width - Canvas.TextWidth(Text) - FCaptionMargin, 0, - Width - FCaptionMargin, Canvas.TextHeight(Text)); -end; - -procedure TSysButtonStyleHook.PaintRadioButton(Canvas: TCanvas); -var - LDetails: TThemedElementDetails; - DC: HDC; - LRect: TRect; - Detail: TThemedButton; - TxtRect, BoxRect: TRect; - LState: TSysCheckBoxState; - Size: TSize; -begin - DC := Canvas.Handle; - LRect := SysControl.ClientRect; - LState := CheckBoxState; - Canvas.Brush.Color := Color; - Canvas.FillRect(LRect); - if SysControl.Enabled then - Detail := tbRadioButtonUncheckedNormal - else - Detail := tbRadioButtonUncheckedDisabled; - if MouseDown then - Detail := tbRadioButtonUncheckedPressed - else if MouseInControl then - Detail := tbRadioButtonUncheckedHot; - - if LState = cbChecked then - Detail := TThemedButton(Integer(Detail) + 4); - - Size.cx := GetSystemMetrics(SM_CXMENUCHECK); - Size.cy := GetSystemMetrics(SM_CYMENUCHECK); - - LDetails := StyleServices.GetElementDetails(Detail); - BoxRect := Rect(0, 0, Size.cx, Size.cy); - RectVCenter(BoxRect, LRect); - - if (SysControl.Style and BS_LEFTTEXT = BS_LEFTTEXT) then - begin - BoxRect.Left := LRect.Right - BoxRect.Width - 2; - BoxRect.Right := LRect.Right; - TxtRect := Rect(LRect.Left + 1, LRect.Top, BoxRect.Left, LRect.Bottom); - end - else - begin - OffsetRect(BoxRect, 1, 0); - TxtRect := Rect(BoxRect.Right + 2, LRect.Top, LRect.Right, LRect.Bottom); - end; - - StyleServices.DrawElement(DC, LDetails, BoxRect); - - if Focused then - Canvas.DrawFocusRect(LRect); - - DrawCheckBoxText(DC, SysControl.Text, LDetails, TxtRect); - -end; - -procedure TSysButtonStyleHook.PaintCheckBox(Canvas: TCanvas); -var - LDetails: TThemedElementDetails; - DC: HDC; - LRect: TRect; - Detail: TThemedButton; - TxtRect, BoxRect: TRect; - LState: TSysCheckBoxState; - Size: TSize; -begin - DC := Canvas.Handle; - LRect := SysControl.ClientRect; - LState := CheckBoxState; - Canvas.Brush.Color := Color; - Canvas.FillRect(LRect); - if SysControl.Enabled then - Detail := tbCheckBoxUncheckedNormal - else - Detail := tbCheckBoxUncheckedDisabled; - if MouseDown then - Detail := tbCheckBoxUncheckedPressed - else if MouseInControl then - Detail := tbCheckBoxUncheckedHot; - - if LState = cbChecked then - Detail := TThemedButton(Integer(Detail) + 4); - if LState = cbGrayed then - Detail := TThemedButton(Integer(Detail) + 8); - - // LDetails := StyleServices.GetElementDetails(tbCheckBoxUncheckedNormal); - // StyleServices.GetElementSize(DC, LDetails, esActual, Size); - Size.cx := GetSystemMetrics(SM_CXMENUCHECK); - Size.cy := GetSystemMetrics(SM_CYMENUCHECK); - - LDetails := StyleServices.GetElementDetails(Detail); - BoxRect := Rect(0, 0, Size.cx, Size.cy); - BoxRect := RectVCenter(BoxRect, LRect); - - if (SysControl.Style and BS_LEFTTEXT = BS_LEFTTEXT) then - begin - BoxRect.Left := LRect.Right - BoxRect.Width - 2; - BoxRect.Right := LRect.Right; - TxtRect := Rect(LRect.Left + 1, LRect.Top, BoxRect.Left, LRect.Bottom); - end - else - begin - OffsetRect(BoxRect, 1, 0); - TxtRect := Rect(BoxRect.Right + 2, LRect.Top, LRect.Right, LRect.Bottom); - end; - - StyleServices.DrawElement(DC, LDetails, BoxRect); - - if Focused then - Canvas.DrawFocusRect(LRect); - - DrawCheckBoxText(DC, SysControl.Text, LDetails, TxtRect); -end; - -procedure TSysButtonStyleHook.PaintGroupBox(Canvas: TCanvas); -var - R, CaptionRect: TRect; - LDetails: TThemedElementDetails; - SaveIndex: Integer; - procedure DoDrawParentBackground(DC: HDC; ARect: TRect); - begin - if SysControl.ParentHandle > 0 then - DrawParentBackground(DC, @ARect) - else - begin - Canvas.Brush.Color := StyleServices.GetStyleColor(scWindow); - Canvas.FillRect(ARect); - end; - end; - -begin - CaptionRect := GetCaptionRect(Canvas); - R := GetBoxRect; - - if SysControl.Enabled then - LDetails := StyleServices.GetElementDetails(tbGroupBoxNormal) - else - LDetails := StyleServices.GetElementDetails(tbGroupBoxDisabled); - - { Clean caption area } - DoDrawParentBackground(Canvas.Handle, CaptionRect); - ExcludeClipRect(Canvas.Handle, R.Left + 4, CaptionRect.Height + 2, - R.Right - 4, R.Height - 2); - { Clean GroupBox corners area } - DoDrawParentBackground(Canvas.Handle, R); - - SaveIndex := SaveDC(Canvas.Handle); - - try - ExcludeClipRect(Canvas.Handle, CaptionRect.Left, CaptionRect.Top, - CaptionRect.Right, CaptionRect.Bottom); - StyleServices.DrawElement(Canvas.Handle, LDetails, R); - finally - RestoreDC(Canvas.Handle, SaveIndex); - end; - - Inc(CaptionRect.Top, 3); - { Paint Text } - StyleServices.DrawText(Canvas.Handle, LDetails, SysControl.Text, CaptionRect, - [tfSingleLine, tfVerticalCenter, tfLeft, tfHidePrefix]); - -end; - -procedure TSysButtonStyleHook.PaintNC(Canvas: TCanvas); -begin - if GroupBox then - PaintGroupBox(Canvas); -end; - -procedure TSysButtonStyleHook.UpdateColors; -begin - inherited; -end; - -procedure TSysButtonStyleHook.WMEraseBkgnd(var Message: TMessage); -begin - if (not OwnerDraw) and (not GroupBox and ParentBkGndPainted) then - Message.Result := 1 - else - begin - Handled := False; - Exit; - end; - Handled := True; -end; - -procedure TSysButtonStyleHook.WMNCPaint(var Message: TMessage); -begin - if (not OwnerDraw and ParentBkGndPainted) then - Inherited - else - begin - Handled := False; - Exit; - end; - Handled := True; -end; - -procedure TSysButtonStyleHook.WMPaint(var Message: TMessage); -begin - if (not OwnerDraw and ParentBkGndPainted) then - Inherited - else - begin - Handled := False; - Exit; - end; - Handled := True; -end; - -procedure TSysButtonStyleHook.WndProc(var Message: TMessage); -begin - case Message.Msg of - WM_ENABLE: - begin - { Check first if Window is visible - if you dont check ..the InVisible window will be visible . - } - if SysControl.Visible then - Invalidate; - end; - - WM_STYLECHANGING, WM_STYLECHANGED: - begin - Invalidate; - end; - - WM_SETTEXT: - begin - SetRedraw(False); - CallDefaultProc(Message); - SetRedraw(True); - Invalidate; - end; - - WM_SETFOCUS, WM_KILLFOCUS: - begin - inherited; - Invalidate; - end; - - else - inherited; - end; - -end; - -{ TSysMemoStyleHook } - -constructor TSysMemoStyleHook.Create(AHandle: THandle); -begin - inherited; -{$IF CompilerVersion > 23} - StyleElements := [seBorder, seFont]; -{$ELSE} - OverridePaintNC := True; - OverrideFont := True; -{$IFEND} - UpdateColors; -end; - -function TSysMemoStyleHook.GetBorderSize: TRect; -begin - if SysControl.HasBorder then - Result := Rect(2, 2, 2, 2); -end; - -procedure TSysMemoStyleHook.UpdateColors; -const - ColorStates: array [Boolean] of TStyleColor = (scEditDisabled, scEdit); - FontColorStates: array [Boolean] of TStyleFont = (sfEditBoxTextDisabled, - sfEditBoxTextNormal); -var - LStyle: TCustomStyleServices; -begin - LStyle := StyleServices; - Brush.Color := LStyle.GetStyleColor(ColorStates[SysControl.Enabled]); - FontColor := LStyle.GetStyleFontColor(FontColorStates[SysControl.Enabled]); -end; - -procedure TSysMemoStyleHook.WndProc(var Message: TMessage); -begin - case Message.Msg of - WM_ERASEBKGND: - begin - CallDefaultProc(Message); - Exit; - end; - - CN_CTLCOLORMSGBOX .. CN_CTLCOLORSTATIC: - begin - SetTextColor(Message.wParam, ColorToRGB(FontColor)); - SetBkColor(Message.wParam, ColorToRGB(Brush.Color)); - Message.Result := LRESULT(Brush.Handle); - end; - - CM_ENABLEDCHANGED: - begin - UpdateColors; - CallDefaultProc(Message); - end - else - inherited WndProc(Message); - end; -end; - -{ TSysComboBoxStyleHook } -constructor TSysComboBoxStyleHook.Create(AHandle: THandle); -begin - inherited; - if Style = csSimple then - OverrideEraseBkgnd := True; - FMouseOnButton := False; - FEditHandle := 0; - FListHandle := 0; - FListBoxInstance := nil; - FIgnoreStyleChanged := False; - FVSliderState := tsThumbBtnVertNormal; - FVUpState := tsArrowBtnUpNormal; - FVDownState := tsArrowBtnDownNormal; - FSliderSize := 0; - FListBoxTimerCode := 0; - FListBoxUpBtnDown := False; - FListBoxDownBtnDown := False; - FListBoxTrackUpDown := False; - FListBoxTrackDownDown := False; - OverrideFont := True; - UpdateColors; -end; - -destructor TSysComboBoxStyleHook.Destroy; -begin - if (FListHandle <> 0) and (FListBoxInstance <> nil) then - begin - SetWindowLong(FListHandle, GWL_WNDPROC, IntPtr(FDefListBoxProc)); - FreeObjectInstance(FListBoxInstance); - FListBoxInstance := nil; - end; - if FListBoxTimerCode <> 0 then - ListBoxStopTimer; - inherited; -end; - -procedure TSysComboBoxStyleHook.CNCommand(var Message: TWMCommand); -begin - if (Message.NotifyCode = CBN_SELENDCANCEL) or - (Message.NotifyCode = CBN_SELENDOK) or (Message.NotifyCode = CBN_CLOSEUP) or - (Message.NotifyCode = CBN_DROPDOWN) or (Message.NotifyCode = CBN_SELCHANGE) - then - begin - if FListBoxTimerCode <> 0 then - ListBoxStopTimer; - FMouseOnButton := False; - Invalidate; - end; -end; - -procedure TSysComboBoxStyleHook.CNDrawItem(var Message: TWMDrawItem); -begin - WMDrawItem(Message); - Handled := True; -end; - -procedure TSysComboBoxStyleHook.DrawItem(Canvas: TCanvas;const Index: UINT; - const R: TRect;const Selected: Boolean); -var - DIS: TDrawItemStruct; -begin - FillChar(DIS, SizeOf(DIS), 0); - DIS.CtlType := ODT_COMBOBOX; - DIS.CtlID := GetDlgCtrlID(Handle); - DIS.itemAction := ODA_DRAWENTIRE; - DIS.HDC := Canvas.Handle; - DIS.hwndItem := Handle; - DIS.rcItem := R; - DIS.itemID := Index; - DIS.itemData := SendMessage(FListHandle, LB_GETITEMDATA, 0, 0); - if Selected then - DIS.itemState := DIS.itemState or ODS_FOCUS or ODS_SELECTED; - - SendMessage(Handle, WM_DRAWITEM, Handle, LPARAM(@DIS)); -end; - -procedure TSysComboBoxStyleHook.DrawListBoxBorder; -var - R: TRect; - Canvas: TCanvas; - SaveIdx: Integer; - P: TPoint; -begin - Canvas := TCanvas.Create; - try - Canvas.Handle := GetWindowDC(FListHandle); - P := Point(0, 0); - ClientToScreen(FListHandle, P); - GetWindowRect(FListHandle, R); - P.X := P.X - R.Left; - P.Y := P.Y - R.Top; - if (R.Width < 5000) and (R.Height < 5000) then - begin - GetClientRect(FListHandle, R); - ExcludeClipRect(Canvas.Handle, P.X, P.Y, R.Right - R.Left + P.X, - R.Bottom - R.Top + P.Y); - GetWindowRect(FListHandle, R); - OffsetRect(R, -R.Left, -R.Top); - SaveIdx := SaveDC(Canvas.Handle); - try - PaintListBoxBorder(Canvas, R); - finally - RestoreDC(Canvas.Handle, SaveIdx); - end; - DrawListBoxVertScroll(Canvas.Handle); - end; - finally - ReleaseDC(FListHandle, Canvas.Handle); - Canvas.Handle := 0; - Canvas.Free; - end; -end; - -procedure TSysComboBoxStyleHook.DrawListBoxVertScroll(DC: HDC); -var - B: TBitmap; - Details: TThemedElementDetails; - Canvas: TCanvas; - R: TRect; -begin - if GetWindowLong(FListHandle, GWL_STYLE) and WS_VSCROLL = 0 then - Exit; - Canvas := TCanvas.Create; - try - if DC <> 0 then - Canvas.Handle := DC - else - Canvas.Handle := GetWindowDC(FListHandle); - if ListBoxVertScrollRect.Width > 0 then - begin - B := TBitmap.Create; - try - B.Width := ListBoxVertScrollRect.Width; - B.Height := ListBoxVertScrollRect.Height; - MoveWindowOrg(B.Canvas.Handle, -ListBoxVertScrollRect.Left, - -ListBoxVertScrollRect.Top); - - if StyleServices.Available then - begin - R := ListBoxVertScrollRect; - R.Top := ListBoxVertUpButtonRect.Bottom; - R.Bottom := ListBoxVertDownButtonRect.Top; - if R.Height > 0 then - begin - Details := StyleServices.GetElementDetails(tsUpperTrackVertNormal); - StyleServices.DrawElement(B.Canvas.Handle, Details, R); - end; - Details := StyleServices.GetElementDetails(FVSliderState); - StyleServices.DrawElement(B.Canvas.Handle, Details, - ListBoxVertSliderRect); - Details := StyleServices.GetElementDetails(FVUpState); - StyleServices.DrawElement(B.Canvas.Handle, Details, - ListBoxVertUpButtonRect); - Details := StyleServices.GetElementDetails(FVDownState); - StyleServices.DrawElement(B.Canvas.Handle, Details, - ListBoxVertDownButtonRect); - end; - - MoveWindowOrg(B.Canvas.Handle, ListBoxVertScrollRect.Left, - ListBoxVertScrollRect.Top); - Canvas.Draw(ListBoxVertScrollRect.Left, ListBoxVertScrollRect.Top, B); - finally - B.Free; - end; - end; - finally - if DC <> 0 then - Canvas.Handle := 0 - else - begin - ReleaseDC(FListHandle, Canvas.Handle); - Canvas.Handle := 0; - end; - Canvas.Free; - end; -end; - -function TSysComboBoxStyleHook.IsDroppedDown: Boolean; -begin - if Handle <> 0 then - Result := LongBool(SendMessage(Handle, CB_GETDROPPEDSTATE, 0, 0)) - else - Result := False; -end; - -function TSysComboBoxStyleHook.GetButtonRect: TRect; -begin - Result := SysControl.ClientRect; - InflateRect(Result, -2, -2); - if SysControl.BiDiMode <> bmRightToLeft then - Result.Left := Result.Right - GetSystemMetrics(SM_CXVSCROLL) + 1 - else - Result.Right := Result.Left + GetSystemMetrics(SM_CXVSCROLL) - 1; -end; - -procedure TSysComboBoxStyleHook.HookListBox(AListHandle: HWnd); -begin - if (AListHandle <> 0) and (FListBoxInstance = nil) then - begin - FListHandle := AListHandle; - FListBoxInstance := MakeObjectInstance(ListBoxWndProc); - FDefListBoxProc := Pointer(GetWindowLong(FListHandle, GWL_WNDPROC)); - SetWindowLong(FListHandle, GWL_WNDPROC, IntPtr(FListBoxInstance)); - end; -end; - -function TSysComboBoxStyleHook.IsChildHandle(AHandle: HWnd): Boolean; -begin - Result := (FEditHandle <> 0) and (FEditHandle = AHandle); - -end; - -function TSysComboBoxStyleHook.ListBoxBoundsRect: TRect; -begin - GetWindowRect(FListHandle, Result); -end; - -function TSysComboBoxStyleHook.ListBoxClientRect: TRect; -begin - GetClientRect(FListHandle, Result); -end; - -procedure TSysComboBoxStyleHook.ListBoxSetTimer(const ATimerCode: Integer); -begin - if FListBoxTimerCode <> 0 then - ListBoxStopTimer; - FListBoxTimerCode := ATimerCode; - if ATimerCode < 4 then - SetTimer(FListHandle, 1, 300, nil) - else - SetTimer(FListHandle, 1, 50, nil); -end; - -procedure TSysComboBoxStyleHook.ListBoxStopTimer; -begin - FListBoxTimerCode := -1; - KillTimer(FListHandle, 1); -end; - -function TSysComboBoxStyleHook.ListBoxVertDownButtonRect: TRect; -begin - Result := ListBoxVertScrollRect; - if Result.Width > 0 then - Result.Top := Result.Bottom - GetSystemMetrics(SM_CYVTHUMB) - else - Result := TRect.Empty; -end; - -function TSysComboBoxStyleHook.ListBoxVertScrollArea: TRect; -begin - if GetWindowLong(FListHandle, GWL_STYLE) and WS_VSCROLL = 0 then - begin - Result := TRect.Empty; - Exit; - end; - Result := ListBoxBoundsRect; - OffsetRect(Result, -Result.Left, -Result.Top); - if SysControl.BiDiMode <> bmRightToLeft then - Result.Left := Result.Right - GetSystemMetrics(SM_CYVSCROLL) - 1 - else - Result.Right := Result.Left + GetSystemMetrics(SM_CYVSCROLL); -end; - -function TSysComboBoxStyleHook.ListBoxVertScrollRect: TRect; -begin - Result := ListBoxBoundsRect; - OffsetRect(Result, -Result.Left, -Result.Top); - InflateRect(Result, -1, -1); - OffsetRect(Result, 1, 1); - if SysControl.BiDiMode <> TBidiModeDirection.bmRightToLeft then - Result.Left := Result.Right - GetSystemMetrics(SM_CXVSCROLL) - else - Result.Right := Result.Left + GetSystemMetrics(SM_CXVSCROLL); - if ListBoxBoundsRect.Height > 30 then OffsetRect(Result, -1, -1); - -end; - -function TSysComboBoxStyleHook.ListBoxVertSliderRect: TRect; -var - i, LVisibleHeight, LTotalHeight, LSize, LTotalSize, LFinalHeight, LItemHeight, - LBoundsHeight, LBorderHeight: Integer; -begin - Result := ListBoxVertScrollRect; - Result.Top := ListBoxVertUpButtonRect.Bottom; - Result.Bottom := ListBoxVertDownButtonRect.Top; - LSize := Result.Bottom - Result.Top; - LTotalSize := SendMessage(FListHandle, LB_GETCOUNT, 0, 0) * LSize; - if LTotalSize = 0 then - Exit; - Result.Top := Result.Top + Round((SendMessage(FListHandle, LB_GETTOPINDEX, 0, - 0) / SendMessage(FListHandle, LB_GETCOUNT, 0, 0)) * LSize); - - LTotalHeight := 1; - FInvsibleCount := 0; - LBoundsHeight := ListBoxBoundsRect.Height; - for i := 0 to SendMessage(FListHandle, LB_GETCOUNT, 0, 0) - 1 do - begin - LItemHeight := SendMessage(FListHandle, LB_GETITEMHEIGHT, i, 0); - LTotalHeight := LTotalHeight + LItemHeight; - if (LTotalHeight > LBoundsHeight) and (FInvsibleCount = 0) then - FInvsibleCount := SendMessage(FListHandle, LB_GETCOUNT, 0, 0) - i; - end; - - LVisibleHeight := 0; - for i := SendMessage(FListHandle, LB_GETTOPINDEX, 0, 0) - to SendMessage(FListHandle, LB_GETCOUNT, 0, 0) - 1 do - begin - LVisibleHeight := LVisibleHeight + SendMessage(FListHandle, - LB_GETITEMHEIGHT, i, 0); - if Style <> csSimple then - LBorderHeight := 2 - else - LBorderHeight := 4; - if LVisibleHeight >= ListBoxBoundsRect.Height - LBorderHeight then - Break; - end; - - Result.Bottom := Result.Top + Round((LVisibleHeight / LTotalHeight) * LSize); - if (i = SendMessage(FListHandle, LB_GETCOUNT, 0, 0) - 1) and - (Result.Bottom <> ListBoxVertDownButtonRect.Top) then - begin - LFinalHeight := Result.Height; - Result.Bottom := ListBoxVertDownButtonRect.Top; - Result.Top := Result.Bottom - LFinalHeight; - end; - FSliderSize := Round((LVisibleHeight / LTotalHeight) * LSize); -end; - -function TSysComboBoxStyleHook.ListBoxVertTrackRect: TRect; -begin - Result := ListBoxVertScrollRect; - if Result.Width > 0 then - begin - Result.Top := Result.Top + GetSystemMetrics(SM_CYVTHUMB); - Result.Bottom := Result.Bottom - GetSystemMetrics(SM_CYVTHUMB); - end - else - Result := TRect.Empty; -end; - -function TSysComboBoxStyleHook.ListBoxVertTrackRectDown: TRect; -begin - Result := ListBoxVertTrackRect; - if (Result.Width > 0) and (ListBoxVertSliderRect.Height > 0) then - Result.Top := ListBoxVertSliderRect.Bottom; -end; - -function TSysComboBoxStyleHook.ListBoxVertTrackRectUp: TRect; -begin - Result := ListBoxVertTrackRect; - if (Result.Width > 0) and (ListBoxVertSliderRect.Height > 0) then - Result.Bottom := ListBoxVertSliderRect.Top; -end; - -function TSysComboBoxStyleHook.ListBoxVertUpButtonRect: TRect; -begin - Result := ListBoxVertScrollRect; - if Result.Width > 0 then - Result.Top := Result.Bottom - GetSystemMetrics(SM_CYVTHUMB) - else - Result := TRect.Empty; -end; - -procedure TSysComboBoxStyleHook.ListBoxWndProc(var Msg: TMessage); -var - MsgHandled: Boolean; - - procedure WMNCCalcSize(var Msg: TWMNCCalcSize); - var - LCalcSizeParams: PNCCalcSizeParams; - LWindowPos: PWindowPos; - LLeft, LRight, LTop, LBottom: Integer; - LStyle, LNewStyle: Integer; - begin - LStyle := GetWindowLong(FListHandle, GWL_STYLE); - if ((LStyle and WS_VSCROLL = WS_VSCROLL) or - (LStyle and WS_HSCROLL = WS_HSCROLL)) then - begin - LNewStyle := LStyle and not WS_VSCROLL and not WS_HSCROLL; - FIgnoreStyleChanged := True; - SetWindowLong(FListHandle, GWL_STYLE, LNewStyle); - Msg.Result := CallDefaultListBoxProc(TMessage(Msg)); - SetWindowLong(FListHandle, GWL_STYLE, LStyle); - FIgnoreStyleChanged := False; - end - else - Msg.Result := CallDefaultListBoxProc(TMessage(Msg)); - - if (Msg.CalcValidRects) then - begin - LCalcSizeParams := Msg.CalcSize_Params; - if SysControl.BiDiMode <> bmRightToLeft then - begin - LLeft := 1; - if LStyle and WS_VSCROLL = WS_VSCROLL then - LRight := ListBoxVertScrollRect.Width + 1 - else - LRight := 1; - end - else - begin - LRight := 1; - if LStyle and WS_VSCROLL = WS_VSCROLL then - LLeft := ListBoxVertScrollRect.Width + 1 - else - LLeft := 1; - end; - - LTop := 1; - LBottom := 1; - LWindowPos := LCalcSizeParams.lppos; - with LCalcSizeParams^.rgrc[0] do - begin - Left := LWindowPos^.X; - Top := LWindowPos^.Y; - Right := LWindowPos^.X + LWindowPos^.cx; - Bottom := LWindowPos^.Y + LWindowPos^.cy; - Left := Left + LLeft; - Top := Top + LTop; - Right := Right - LRight; - Bottom := Bottom - LBottom; - end; - LCalcSizeParams^.rgrc[1] := LCalcSizeParams^.rgrc[0]; - Msg.CalcSize_Params := LCalcSizeParams; - Msg.Result := WVR_VALIDRECTS; - end; - Msg.Result := 0; - MsgHandled := True; - end; - - procedure WMMouseWheel(var Msg: TWMMouseWheel); - var - Index: Integer; - R: TRect; - begin - SendMessage(FListHandle, WM_SETREDRAW, 0, 0); - Index := SendMessage(FListHandle, LB_GETTOPINDEX, 0, 0); - if Msg.WheelDelta < 0 then - Inc(Index) - else - Dec(Index); - SendMessage(FListHandle, LB_SETTOPINDEX, Index, 0); - SendMessage(FListHandle, WM_SETREDRAW, 1, 0); - R := Rect(0, 0, ListBoxBoundsRect.Width, ListBoxBoundsRect.Height); - RedrawWindow(FListHandle, @R, 0, RDW_INVALIDATE or RDW_ERASE); - DrawListBoxVertScroll(0); - MsgHandled := True; - end; - - procedure WMNCLButtonDblClk(var Msg: TWMMouse); - var - R: TRect; - P: TPoint; - begin - P := Point(Msg.XPos, Msg.YPos); - if ListBoxVertScrollArea.Contains(P) then - begin - if ListBoxVertUpButtonRect.Contains(Point(Msg.XPos, Msg.YPos)) then - begin - SendMessage(FListHandle, WM_SETREDRAW, 0, 0); - SendMessage(FListHandle, LB_SETTOPINDEX, SendMessage(FListHandle, - LB_GETTOPINDEX, 0, 0) - 1, 0); - SendMessage(FListHandle, WM_SETREDRAW, 1, 0); - R := Rect(0, 0, ListBoxBoundsRect.Width, ListBoxBoundsRect.Height); - RedrawWindow(FListHandle, @R, 0, RDW_INVALIDATE or RDW_ERASE); - DrawListBoxVertScroll(0); - Exit; - end; - - if ListBoxVertDownButtonRect.Contains(Point(Msg.XPos, Msg.YPos)) then - begin - SendMessage(FListHandle, WM_SETREDRAW, 0, 0); - SendMessage(FListHandle, LB_SETTOPINDEX, SendMessage(FListHandle, - LB_GETTOPINDEX, 0, 0) + 1, 0); - SendMessage(FListHandle, WM_SETREDRAW, 1, 0); - R := Rect(0, 0, ListBoxBoundsRect.Width, ListBoxBoundsRect.Height); - RedrawWindow(FListHandle, @R, 0, RDW_INVALIDATE or RDW_ERASE); - DrawListBoxVertScroll(0); - Exit; - end; - end; - MsgHandled := True; - end; - - procedure WMLButtonDown(var Msg: TWMMouse); - var - P: TPoint; - R: TRect; - ItemHeight, VisibleCount, TopIndex: Integer; - begin - MsgHandled := False; - P := Point(Msg.XPos, Msg.YPos); - if SysControl.BiDiMode = bmRightToLeft then - P.X := -P.X; - FDownPos := P; - if ListBoxVertScrollArea.Contains(P) then - begin - if Style = csSimple then - SetCapture(FListHandle); - FDownPos := P; - if ListBoxVertTrackRectUp.Contains(P) then - begin - ItemHeight := SendMessage(FListHandle, LB_GETITEMHEIGHT, 0, 0); - if ItemHeight > 0 then - VisibleCount := ListBoxClientRect.Height div ItemHeight - else - VisibleCount := 0; - TopIndex := SendMessage(FListHandle, LB_GETTOPINDEX, 0, 0) - - VisibleCount + 1; - if TopIndex < 0 then - TopIndex := 0; - SendMessage(FListHandle, WM_SETREDRAW, 0, 0); - SendMessage(FListHandle, LB_SETTOPINDEX, TopIndex, 0); - SendMessage(FListHandle, WM_SETREDRAW, 1, 0); - R := Rect(0, 0, ListBoxBoundsRect.Width, ListBoxBoundsRect.Height); - RedrawWindow(FListHandle, @R, 0, RDW_INVALIDATE or RDW_ERASE); - DrawListBoxVertScroll(0); - ListBoxSetTimer(3); - end - else if ListBoxVertTrackRectDown.Contains(P) then - begin - ItemHeight := SendMessage(FListHandle, LB_GETITEMHEIGHT, 0, 0); - if ItemHeight > 0 then - VisibleCount := ListBoxClientRect.Height div ItemHeight - else - VisibleCount := 0; - TopIndex := SendMessage(FListHandle, LB_GETTOPINDEX, 0, 0) + - VisibleCount - 1; - SendMessage(FListHandle, WM_SETREDRAW, 0, 0); - SendMessage(FListHandle, LB_SETTOPINDEX, TopIndex, 0); - SendMessage(FListHandle, WM_SETREDRAW, 1, 0); - R := Rect(0, 0, ListBoxBoundsRect.Width, ListBoxBoundsRect.Height); - RedrawWindow(FListHandle, @R, 0, RDW_INVALIDATE or RDW_ERASE); - DrawListBoxVertScroll(0); - ListBoxSetTimer(4); - end - else if ListBoxVertSliderRect.Contains(P) then - begin - FVSliderState := tsThumbBtnVertPressed; - FDownSliderPos := FDownPos.Y - ListBoxVertSliderRect.Top; - DrawListBoxVertScroll(0); - end - else if ListBoxVertDownButtonRect.Contains(P) then - begin - FListBoxDownBtnDown := True; - FVDownState := tsArrowBtnDownPressed; - DrawListBoxVertScroll(0); - - SendMessage(FListHandle, WM_SETREDRAW, 0, 0); - SendMessage(FListHandle, LB_SETTOPINDEX, SendMessage(FListHandle, - LB_GETTOPINDEX, 0, 0) + 1, 0); - SendMessage(FListHandle, WM_SETREDRAW, 1, 0); - R := Rect(0, 0, ListBoxBoundsRect.Width, ListBoxBoundsRect.Height); - RedrawWindow(FListHandle, @R, 0, RDW_INVALIDATE or RDW_ERASE); - - ListBoxSetTimer(2); - end - else if ListBoxVertUpButtonRect.Contains(P) then - begin - FListBoxUpBtnDown := True; - FVUpState := tsArrowBtnUpPressed; - DrawListBoxVertScroll(0); - - SendMessage(FListHandle, WM_SETREDRAW, 0, 0); - SendMessage(FListHandle, LB_SETTOPINDEX, SendMessage(FListHandle, - LB_GETTOPINDEX, 0, 0) - 1, 0); - SendMessage(FListHandle, WM_SETREDRAW, 1, 0); - R := Rect(0, 0, ListBoxBoundsRect.Width, ListBoxBoundsRect.Height); - RedrawWindow(FListHandle, @R, 0, RDW_INVALIDATE or RDW_ERASE); - - ListBoxSetTimer(1); - end; - MsgHandled := True; - end - else - begin - if (FVSliderState <> tsThumbBtnVertNormal) or - (FVUpState <> tsArrowBtnUpNormal) or - (FVDownState <> tsArrowBtnDownNormal) then - begin - FVSliderState := tsArrowBtnUpNormal; - FVUpState := tsArrowBtnUpNormal; - FVDownState := tsArrowBtnDownNormal; - DrawListBoxVertScroll(0); - end; - end; - FOldIdx := SendMessage(FListHandle, LB_GETTOPINDEX, 0, 0); - end; - - procedure WMMouseMove(var Msg: TWMMouse); - var - P: TPoint; - NewIndex, Index: Integer; - Dist: Integer; - R: TRect; - begin - P := Point(Msg.XPos, Msg.YPos); - if SysControl.BiDiMode = bmRightToLeft then - P.X := -P.X; - - FMovePos := P; - if (FVSliderState = tsThumbBtnVertPressed) then - begin - Index := SendMessage(FListHandle, LB_GETTOPINDEX, 0, 0); - Dist := (ListBoxVertScrollRect.Height - ListBoxVertUpButtonRect.Height - - ListBoxVertDownButtonRect.Height - ListBoxVertSliderRect.Height); - if Dist > 0 then - begin - NewIndex := - Round((((FMovePos.Y - FDownSliderPos - ListBoxVertUpButtonRect.Bottom) - / Dist) * FInvsibleCount)); - if NewIndex <> Index then - begin - if NewIndex < 0 then - NewIndex := 0; - if NewIndex >= SendMessage(FListHandle, LB_GETCOUNT, 0, 0) then - NewIndex := SendMessage(FListHandle, LB_GETCOUNT, 0, 0) - 1; - SendMessage(FListHandle, WM_SETREDRAW, 0, 0); - SendMessage(FListHandle, LB_SETTOPINDEX, NewIndex, 0); - SendMessage(FListHandle, WM_SETREDRAW, 1, 0); - R := Rect(0, 0, ListBoxBoundsRect.Width, ListBoxBoundsRect.Height); - RedrawWindow(FListHandle, @R, 0, RDW_INVALIDATE or RDW_ERASE); - DrawListBoxVertScroll(0); - end; - end; - MsgHandled := True; - Exit; - end; - - if FListBoxUpBtnDown and not ListBoxVertUpButtonRect.Contains(P) and - (FVUpState = tsArrowBtnUpPressed) then - begin - FVUpState := tsArrowBtnUpNormal; - DrawListBoxVertScroll(0); - ListBoxStopTimer; - Exit; - end; - - if FListBoxUpBtnDown and ListBoxVertUpButtonRect.Contains(P) and - (FVUpState = tsArrowBtnUpNormal) then - begin - FVUpState := tsArrowBtnUpPressed; - DrawListBoxVertScroll(0); - ListBoxSetTimer(5); - Exit; - end; - - if FListBoxDownBtnDown and not ListBoxVertDownButtonRect.Contains(P) and - (FVDownState = tsArrowBtnDownPressed) then - begin - FVDownState := tsArrowBtnDownNormal; - DrawListBoxVertScroll(0); - ListBoxStopTimer; - Exit; - end; - - if FListBoxDownBtnDown and ListBoxVertDownButtonRect.Contains(P) and - (FVDownState = tsArrowBtnDownNormal) then - begin - FVDownState := tsArrowBtnDownPressed; - DrawListBoxVertScroll(0); - ListBoxSetTimer(6); - Exit; - end; - - if ListBoxVertScrollArea.Contains(P) then - begin - if ListBoxVertSliderRect.Contains(P) and - (FVSliderState = tsThumbBtnVertNormal) then - begin - FVSliderState := tsThumbBtnVertHot; - DrawListBoxVertScroll(0); - end - else if not ListBoxVertSliderRect.Contains(P) and - (FVSliderState = tsThumbBtnVertHot) then - begin - FVSliderState := tsThumbBtnVertNormal; - DrawListBoxVertScroll(0); - end - else if ListBoxVertUpButtonRect.Contains(P) and - (FVUpState = tsArrowBtnUpNormal) then - begin - FVUpState := tsArrowBtnUpHot; - DrawListBoxVertScroll(0); - end - else if not ListBoxVertUpButtonRect.Contains(P) and - (FVUpState = tsArrowBtnUpHot) then - begin - FVUpState := tsArrowBtnUpNormal; - DrawListBoxVertScroll(0); - end - else if ListBoxVertDownButtonRect.Contains(P) and - (FVDownState = tsArrowBtnDownNormal) then - begin - FVDownState := tsArrowBtnDownHot; - DrawListBoxVertScroll(0); - end - else if not ListBoxVertDownButtonRect.Contains(P) and - (FVDownState = tsArrowBtnDownHot) then - begin - FVDownState := tsArrowBtnDownNormal; - DrawListBoxVertScroll(0); - end; - MsgHandled := True; - end - else - begin - if (FVSliderState <> tsThumbBtnVertNormal) or - (FVUpState <> tsArrowBtnUpNormal) or (FVUpState <> tsArrowBtnDownNormal) - then - begin - if FListBoxTimerCode <> 0 then - ListBoxStopTimer; - FVSliderState := tsThumbBtnVertNormal; - FVUpState := tsArrowBtnUpNormal; - FVDownState := tsArrowBtnDownNormal; - DrawListBoxVertScroll(0); - end; - end; - end; - - procedure WMLButtonUp(var Msg: TWMMouse); - var - P: TPoint; - begin - FListBoxUpBtnDown := False; - FListBoxDownBtnDown := False; - FListBoxTrackUpDown := False; - FListBoxTrackDownDown := False; - - P := Point(Msg.XPos, Msg.YPos); - if SysControl.BiDiMode = bmRightToLeft then - P.X := -P.X; - - if (Style = csSimple) and ListBoxVertScrollArea.Contains(FDownPos) then - ReleaseCapture; - - if ListBoxVertSliderRect.Contains(P) then - FVSliderState := tsThumbBtnVertHot - else - FVSliderState := tsThumbBtnVertNormal; - - if ListBoxVertUpButtonRect.Contains(P) then - FVUpState := tsArrowBtnUpHot - else - FVUpState := tsArrowBtnUpNormal; - - if ListBoxVertDownButtonRect.Contains(P) then - FVDownState := tsArrowBtnDownHot - else - FVDownState := tsArrowBtnDownNormal; - - DrawListBoxVertScroll(0); - - if FListBoxTimerCode <> 0 then - ListBoxStopTimer; - - MsgHandled := ListBoxVertScrollArea.Contains(P); - end; - - procedure WMNCLButtonDown(var Msg: TWMMouse); - var - P: TPoint; - begin - if Style <> csSimple then - SetCapture(FListHandle); - P := Point(Msg.XPos, Msg.YPos); - ScreenToClient(FListHandle, P); - with P do - begin - Msg.XPos := X; - Msg.YPos := Y; - end; - WMLButtonDown(Msg); - MsgHandled := True; - end; - - procedure WMPrint(var Msg: TMessage); - var - SaveIndex: Integer; - Canvas: TCanvas; - R: TRect; - begin - Msg.Result := CallDefaultListBoxProc(Msg); - - if (Msg.LPARAM and PRF_NONCLIENT = PRF_NONCLIENT) and (Msg.wParam > 0) then - begin - SaveIndex := 0; - Canvas := TCanvas.Create; - try - SaveIndex := SaveDC(Msg.wParam); - Canvas.Handle := Msg.wParam; - GetWindowRect(FListHandle, R); - OffsetRect(R, -R.Left, -R.Top); - ExcludeClipRect(Canvas.Handle, R.Left + 2, R.Top + 2, R.Right - 2, - R.Bottom - 2); - PaintListBoxBorder(Canvas, R); - finally - if SaveIndex <> 0 then - RestoreDC(Canvas.Handle, SaveIndex); - Canvas.Handle := 0; - Canvas.Free; - end; - DrawListBoxVertScroll(Msg.wParam); - end; - MsgHandled := True; - end; - - procedure WMTimer(var Msg: TMessage); - var - R: TRect; - ItemHeight, VisibleCount, TopIndex: Integer; - begin - case FListBoxTimerCode of - 1: - ListBoxSetTimer(5); - 2: - ListBoxSetTimer(6); - 3: - ListBoxSetTimer(7); - 4: - ListBoxSetTimer(8); - 5: - begin - SendMessage(FListHandle, WM_SETREDRAW, 0, 0); - SendMessage(FListHandle, LB_SETTOPINDEX, - SendMessage(FListHandle, LB_GETTOPINDEX, 0, 0) - 1, 0); - SendMessage(FListHandle, WM_SETREDRAW, 1, 0); - R := Rect(0, 0, ListBoxBoundsRect.Width, ListBoxBoundsRect.Height); - RedrawWindow(FListHandle, @R, 0, RDW_INVALIDATE or RDW_ERASE); - DrawListBoxVertScroll(0); - end; - 6: - begin - SendMessage(FListHandle, WM_SETREDRAW, 0, 0); - SendMessage(FListHandle, LB_SETTOPINDEX, - SendMessage(FListHandle, LB_GETTOPINDEX, 0, 0) + 1, 0); - SendMessage(FListHandle, WM_SETREDRAW, 1, 0); - R := Rect(0, 0, ListBoxBoundsRect.Width, ListBoxBoundsRect.Height); - RedrawWindow(FListHandle, @R, 0, RDW_INVALIDATE or RDW_ERASE); - DrawListBoxVertScroll(0); - end; - 7: - begin - if ListBoxVertSliderRect.Contains(FMovePos) or - (FMovePos.Y > ListBoxVertSliderRect.Bottom) then - begin - ListBoxStopTimer; - Exit; - end; - ItemHeight := SendMessage(FListHandle, LB_GETITEMHEIGHT, 0, 0); - if ItemHeight > 0 then - VisibleCount := ListBoxClientRect.Height div ItemHeight - else - VisibleCount := 0; - TopIndex := SendMessage(FListHandle, LB_GETTOPINDEX, 0, 0) - - VisibleCount + 1; - if TopIndex < 0 then - TopIndex := 0; - SendMessage(FListHandle, WM_SETREDRAW, 0, 0); - SendMessage(FListHandle, LB_SETTOPINDEX, TopIndex, 0); - SendMessage(FListHandle, WM_SETREDRAW, 1, 0); - R := Rect(0, 0, ListBoxBoundsRect.Width, ListBoxBoundsRect.Height); - RedrawWindow(FListHandle, @R, 0, RDW_INVALIDATE or RDW_ERASE); - DrawListBoxVertScroll(0); - end; - 8: - begin - if ListBoxVertSliderRect.Contains(FMovePos) or - (FMovePos.Y < ListBoxVertSliderRect.Top) then - begin - ListBoxStopTimer; - Exit; - end; - ItemHeight := SendMessage(FListHandle, LB_GETITEMHEIGHT, 0, 0); - if ItemHeight > 0 then - VisibleCount := ListBoxClientRect.Height div ItemHeight - else - VisibleCount := 0; - TopIndex := SendMessage(FListHandle, LB_GETTOPINDEX, 0, 0) + - VisibleCount - 1; - SendMessage(FListHandle, WM_SETREDRAW, 0, 0); - SendMessage(FListHandle, LB_SETTOPINDEX, TopIndex, 0); - SendMessage(FListHandle, WM_SETREDRAW, 1, 0); - R := Rect(0, 0, ListBoxBoundsRect.Width, ListBoxBoundsRect.Height); - RedrawWindow(FListHandle, @R, 0, RDW_INVALIDATE or RDW_ERASE); - DrawListBoxVertScroll(0); - end; - end; - end; - -begin - - MsgHandled := False; - if ListBoxVertScrollArea.Height = 0 then - begin - case Msg.Msg of - WM_NCCALCSIZE: - WMNCCalcSize(TWMNCCalcSize(Msg)); - WM_NCPAINT: - begin - DrawListBoxBorder; - MsgHandled := True; - end; - end; - end - else - case Msg.Msg of - WM_NCHITTEST: - if Style = csSimple then - begin - Msg.Result := HTCLIENT; - MsgHandled := True; - end; - WM_MOUSELEAVE, WM_NCMOUSELEAVE: - if Style = csSimple then - begin - FVSliderState := tsThumbBtnVertNormal; - FVUpState := tsArrowBtnUpNormal; - FVDownState := tsArrowBtnDownNormal; - DrawListBoxVertScroll(0); - end; - WM_TIMER: - WMTimer(Msg); - WM_UpdateUIState: - MsgHandled := True; - WM_NCCALCSIZE: - WMNCCalcSize(TWMNCCalcSize(Msg)); - WM_MOUSEWHEEL: - WMMouseWheel(TWMMouseWheel(Msg)); - WM_NCLButtonDblClk: - WMNCLButtonDblClk(TWMMouse(Msg)); - WM_LBUTTONDOWN: - WMLButtonDown(TWMMouse(Msg)); - WM_MOUSEMOVE: - WMMouseMove(TWMMouse(Msg)); - WM_LBUTTONUP: - WMLButtonUp(TWMMouse(Msg)); - WM_NCLButtonDown: - WMNCLButtonDown(TWMMouse(Msg)); - WM_NCLButtonUp, WM_NCMouseMove: - MsgHandled := True; - WM_PRINT: - WMPrint(Msg); - WM_KEYDOWN, WM_KEYUP: - begin - Msg.Result := CallDefaultListBoxProc(Msg); - DrawListBoxVertScroll(0); - MsgHandled := True; - end; - WM_NCPAINT: - begin - DrawListBoxBorder; - DrawListBoxVertScroll(0); - MsgHandled := True; - end; - LB_SETTOPINDEX: - begin - Msg.Result := CallDefaultListBoxProc(Msg); - DrawListBoxVertScroll(0); - MsgHandled := True; - end; - WM_STYLECHANGED, WM_STYLECHANGING: - if FIgnoreStyleChanged then - begin - Msg.Result := 0; - MsgHandled := True; - end; - - end; - if not MsgHandled then - Msg.Result := CallDefaultListBoxProc(Msg); -end; - -function TSysComboBoxStyleHook.CallDefaultListBoxProc(var Msg: TMessage): LRESULT; -begin - Result := 0; - try - if (FDefListBoxProc <> nil) then - Result := CallWindowProc(FDefListBoxProc, FListHandle, Msg.Msg, Msg.wParam, Msg.lParam); - except - on e : exception do - OutputDebugString(PWideChar('CallDefaultListBoxProc error : ' + e.message + chr(0))); - end; -end; - -procedure TSysComboBoxStyleHook.MouseEnter; -begin - inherited; - Invalidate; -end; - -procedure TSysComboBoxStyleHook.MouseLeave; -begin - inherited; - if not DroppedDown and FMouseOnButton then - begin - FMouseOnButton := False; - Invalidate; - end -end; - -procedure TSysComboBoxStyleHook.PaintBorder(Canvas: TCanvas); -var - R, ControlRect, EditRect, ListRect: TRect; - DrawState: TThemedComboBox; - BtnDrawState: TThemedComboBox; - Details: TThemedElementDetails; - Buffer: TBitmap; -begin - if not StyleServices.Available then - Exit; - - if not SysControl.Enabled then - BtnDrawState := tcDropDownButtonDisabled - else if DroppedDown then - BtnDrawState := tcDropDownButtonPressed - else if (FMouseOnButton and MouseInControl) then - BtnDrawState := tcDropDownButtonHot - else - BtnDrawState := tcDropDownButtonNormal; - - if not SysControl.Enabled then - DrawState := tcBorderDisabled - else if SysControl.Focused then - DrawState := tcBorderFocused - else if MouseInControl then - DrawState := tcBorderHot - else - DrawState := tcBorderNormal; - - Buffer := TBitmap.Create; - Buffer.SetSize(SysControl.Width, SysControl.Height); - try - R := Rect(0, 0, Buffer.Width, Buffer.Height); - // draw border + client in buffer - Details := StyleServices.GetElementDetails(DrawState); - if (Style = csSimple) and (FListHandle <> 0) then - begin - GetWindowRect(FListHandle, ListRect); - GetWindowRect(Handle, ControlRect); - R.Bottom := ListRect.Top - ControlRect.Top; - StyleServices.DrawElement(Buffer.Canvas.Handle, Details, R); - R := Rect(0, SysControl.Height - (ControlRect.Bottom - ListRect.Bottom), - SysControl.Width, SysControl.Height); - with Buffer.Canvas do - begin - Brush.Style := bsSolid; - Brush.Color := StyleServices.GetSystemColor(clBtnFace); - FillRect(R); - end; - R := Rect(0, 0, Buffer.Width, Buffer.Height); - R.Bottom := ListRect.Top - ControlRect.Top; - end - else - StyleServices.DrawElement(Buffer.Canvas.Handle, Details, R); - - // if not (seClient in SysControl.StyleElements) and (FEditHandle = 0) then - // begin - // R := SysControl.ClientRect; - // InflateRect(R, -3, -3); - // R.Right := ButtonRect.Left - 2; - // with Buffer.Canvas do - // begin - // Brush.Color := TWinControlClass(Control).Color; - // FillRect(R); - // end; - // end; - // draw button in buffer - if Style <> csSimple then - begin - Details := StyleServices.GetElementDetails(BtnDrawState); - StyleServices.DrawElement(Buffer.Canvas.Handle, Details, ButtonRect); - end; - // calculation of exclude area for drawing buffer - if (SendMessage(Handle, CB_GETCURSEL, 0, 0) >= 0) and (FEditHandle = 0) then - begin - R := SysControl.ClientRect; - InflateRect(R, -3, -3); - R.Right := ButtonRect.Left - 2; - ExcludeClipRect(Canvas.Handle, R.Left, R.Top, R.Right, R.Bottom); - end - else if FEditHandle <> 0 then - begin - GetWindowRect(Handle, R); - GetWindowRect(FEditHandle, EditRect); - OffsetRect(EditRect, -R.Left, -R.Top); - with EditRect do - ExcludeClipRect(Canvas.Handle, Left, Top, Right, Bottom); - end; - // draw buffer - Canvas.Draw(0, 0, Buffer); - finally - Buffer.Free; - end; -end; - -procedure TSysComboBoxStyleHook.PaintListBoxBorder(Canvas: TCanvas; - const R: TRect); -begin - with Canvas do - begin - Brush.Color := StyleServices.GetSystemColor(clWindowFrame); - FillRect(R); - end; -end; - -function TSysComboBoxStyleHook.Style: TComboBoxStyle; -const - ComboBoxStyles: array [TComboBoxStyle] of DWORD = (CBS_DROPDOWN, CBS_SIMPLE, - CBS_DROPDOWNLIST, CBS_DROPDOWNLIST or CBS_OWNERDRAWFIXED, - CBS_DROPDOWNLIST or CBS_OWNERDRAWVARIABLE); -var - LStyle: Cardinal; -begin - if Handle <> 0 then - begin - LStyle := GetWindowLong(Handle, GWL_STYLE); - Result := csDropDown; - if LStyle and ComboBoxStyles[csDropDown] = ComboBoxStyles[csDropDown] then - Result := csDropDown; - if LStyle and ComboBoxStyles[csSimple] = ComboBoxStyles[csSimple] then - Result := csSimple; - if LStyle and ComboBoxStyles[csDropDownList] = ComboBoxStyles[csDropDownList] - then - Result := csDropDownList; - if LStyle and ComboBoxStyles[csOwnerDrawFixed] = ComboBoxStyles - [csOwnerDrawFixed] then - Result := csOwnerDrawFixed; - if LStyle and ComboBoxStyles[csOwnerDrawVariable] = ComboBoxStyles - [csOwnerDrawVariable] then - Result := csOwnerDrawVariable; - end - else - Result := csDropDown; -end; -{$HINTS OFF} - -procedure TSysComboBoxStyleHook.UpdateColors; -const - ColorStates: array [Boolean] of TStyleColor = (scComboBoxDisabled, - scComboBox); - FontColorStates: array [Boolean] of TStyleFont = (sfComboBoxItemDisabled, - sfComboBoxItemNormal); -var - LStyle: TCustomStyleServices; -begin - LStyle := StyleServices; - Color := StyleServices.GetStyleColor(ColorStates[SysControl.Enabled]); -{$IF CompilerVersion > 23} - if OverrideFont then - FontColor := StyleServices.GetStyleFontColor(FontColorStates[True]) - else - FontColor := clWindowText; -{$ELSE} - FontColor := StyleServices.GetStyleFontColor - (FontColorStates[SysControl.Enabled]); - Brush.Color := LStyle.GetStyleColor(ColorStates[SysControl.Enabled]); -{$IFEND} -end; -{$HINTS ON} - -procedure TSysComboBoxStyleHook.WMCommand(var Message: TWMCommand); -begin - if (Message.NotifyCode = CBN_SELENDCANCEL) or - (Message.NotifyCode = CBN_SELENDOK) or (Message.NotifyCode = CBN_CLOSEUP) or - (Message.NotifyCode = CBN_DROPDOWN) or (Message.NotifyCode = CBN_SELCHANGE) - then - begin - if FListBoxTimerCode <> 0 then - ListBoxStopTimer; - FMouseOnButton := False; - Invalidate; - end; -end; - -procedure TSysComboBoxStyleHook.WMDrawItem(var Message: TWMDrawItem); -begin - CallDefaultProc(TMessage(Message)); - Handled := True; -end; - -procedure TSysComboBoxStyleHook.WMMouseMove(var Message: TWMMouse); -var - P: TPoint; - R: TRect; - FOldMouseOnButton: Boolean; -begin - CallDefaultProc(TMessage(Message)); - inherited; - - P := Point(Message.XPos, Message.YPos); - FOldMouseOnButton := FMouseOnButton; - R := ButtonRect; - if R.Contains(P) then - FMouseOnButton := True - else - FMouseOnButton := False; - - if FOldMouseOnButton <> FMouseOnButton then - InvalidateRect(Handle, @R, False); - - Handled := True; -end; - -procedure TSysComboBoxStyleHook.WMPaint(var Message: TMessage); -var - R: TRect; - Canvas: TCanvas; - PS: TPaintStruct; - SaveIndex: Integer; - DC: HDC; - //LItemIndex: UINT; - LDetails: TThemedElementDetails; -begin - DC := Message.wParam; - Canvas := TCanvas.Create; - try - if DC = 0 then - Canvas.Handle := BeginPaint(Handle, PS) - else - Canvas.Handle := DC; - - SaveIndex := SaveDC(Canvas.Handle); - try - PaintBorder(Canvas); - finally - RestoreDC(Canvas.Handle, SaveIndex); - end; - - if (Style <> csSimple) and (FEditHandle = 0) then - begin - R := SysControl.ClientRect; - InflateRect(R, -3, -3); - if SysControl.BiDiMode <> bmRightToLeft then - R.Right := ButtonRect.Left - 1 - else - R.Left := ButtonRect.Right + 1; - SaveIndex := SaveDC(Canvas.Handle); - try - IntersectClipRect(Canvas.Handle, R.Left, R.Top, R.Right, R.Bottom); - //LItemIndex := UINT(SendMessage(SysControl.Handle, CB_GETCURSEL, 0, 0)); - Canvas.Brush.Color := StyleServices.GetSystemColor(clWindow); - Canvas.FillRect(R); - if (SysControl.Style and CBS_OWNERDRAWFIXED = CBS_OWNERDRAWFIXED) or - (SysControl.Style and CBS_OWNERDRAWVARIABLE = CBS_OWNERDRAWVARIABLE) - then - begin - //DrawItem(Canvas, LItemIndex, R, Focused); - LDetails := StyleServices.GetElementDetails - (TThemedComboBox.tcComboBoxDontCare); - DrawText(Canvas.Handle, LDetails, SysControl.Text, R, - [tfLeft, tfVerticalCenter, tfSingleLine]); - end - else - begin - LDetails := StyleServices.GetElementDetails - (TThemedComboBox.tcComboBoxDontCare); - DrawText(Canvas.Handle, LDetails, SysControl.Text, R, - [tfLeft, tfVerticalCenter, tfSingleLine]); - end; - finally - RestoreDC(Canvas.Handle, SaveIndex); - end; - end; - - finally - Canvas.Handle := 0; - Canvas.Free; - if DC = 0 then - EndPaint(Handle, PS); - end; - Handled := True; -end; - -procedure TSysComboBoxStyleHook.WMParentNotify(var Message: TMessage); -begin - if (FListHandle = 0) and (LoWord(Message.wParam) = WM_CREATE) then - begin - if (Message.LPARAM <> 0) and (FListBoxInstance = nil) then - HookListBox(Message.LPARAM); - end - else if (FEditHandle = 0) and (LoWord(Message.wParam) = WM_CREATE) then - FEditHandle := Message.LPARAM; -end; - -procedure TSysComboBoxStyleHook.WndProc(var Message: TMessage); -const - States: array [Boolean] of TStyleColor = (scEditDisabled, scComboBox); -begin - case Message.Msg of - - CB_SETCURSEL, WM_KILLFOCUS: - begin - SetRedraw(False); // do not allow default drawing . - CallDefaultProc(Message); - SetRedraw(True); // allow vcl style drawing . - Invalidate; - Exit; - end; - - WM_CTLCOLORMSGBOX .. WM_CTLCOLORSTATIC, - CN_CTLCOLORMSGBOX .. CN_CTLCOLORSTATIC: - begin - SetTextColor(Message.wParam, ColorToRGB(FontColor)); - Brush.Color := StyleServices.GetStyleColor(States[SysControl.Enabled]); - SetBkColor(Message.wParam, ColorToRGB(Brush.Color)); - Message.Result := LRESULT(Brush.Handle); - end; - - CM_ENABLEDCHANGED: - begin - UpdateColors; - CallDefaultProc(Message); // Allow control to handle message - end; - CM_FOCUSCHANGED: - begin - Invalidate; - // Handled := False; // Allow control to handle message - CallDefaultProc(Message); - end; - else - inherited WndProc(Message); - end; -end; - -{ TSysStaticStyleHook } - -constructor TSysStaticStyleHook.Create(AHandle: THandle); -var - Style: DWORD; -begin - Style := GetWindowLongPtr(AHandle, GWL_STYLE); - if (Style and SS_ICON <> SS_ICON) and (Style and SS_BITMAP <> SS_BITMAP) then - - inherited; - FUpdatedColor := 0; - -{$IF CompilerVersion > 23} - StyleElements := [seFont, seBorder, seClient]; -{$ELSE} - OverridePaint := True; - OverridePaintNC := True; - OverrideFont := True; -{$IFEND} - UpdateColors; -end; - -destructor TSysStaticStyleHook.Destroy; -begin - inherited; -end; - -function TSysStaticStyleHook.GetIsFrameOrLine: Boolean; -begin - with SysControl do - Result := - (Style and SS_ETCHEDFRAME = SS_ETCHEDFRAME) or - (Style and SS_ETCHEDHORZ = SS_ETCHEDHORZ) or - (Style and SS_SUNKEN = SS_SUNKEN) or - (Style and SS_ETCHEDVERT = SS_ETCHEDVERT); -end; - -function TSysStaticStyleHook.GetIsText: Boolean; -begin - with SysControl do - Result := (Style and SS_ICON <> SS_ICON) and - (Style and SS_BITMAP <> SS_BITMAP) and - (Style and SS_GRAYRECT <> SS_GRAYRECT) and - (Style and SS_GRAYFRAME <> SS_GRAYFRAME) and - (Style and SS_OWNERDRAW <> SS_OWNERDRAW) and - (Style and SS_REALSIZEIMAGE <> SS_REALSIZEIMAGE) and - (Style and SS_ICON <> SS_ICON) and (Style and SS_USERITEM <> SS_USERITEM) - and (Style and SS_REALSIZEIMAGE <> SS_REALSIZEIMAGE) and - (Style and SS_SIMPLE <> SS_SIMPLE); -end; - -function TSysStaticStyleHook.GetTextFormat: TTextFormat; -const - SS_EDITCONTROL = $2000; -begin - Result := [tfHidePrefix]; - with SysControl do - begin - if Style and SS_LEFT = SS_LEFT then - include(Result, tfLeft) - else if Style and SS_RIGHT = SS_RIGHT then - include(Result, tfRight) - else if Style and SS_CENTER = SS_CENTER then - include(Result, tfCenter); - - if Style and SS_ENDELLIPSIS = SS_ENDELLIPSIS then - include(Result, tfEndEllipsis); - - if Style and SS_PATHELLIPSIS = SS_PATHELLIPSIS then - include(Result, tfPathEllipsis); - - if Style and SS_WORDELLIPSIS = SS_WORDELLIPSIS then - include(Result, tfWordEllipsis); - - if Style and SS_NOPREFIX = SS_NOPREFIX then - include(Result, tfNoPrefix); - - if Style and SS_EDITCONTROL = SS_EDITCONTROL then - include(Result, tfEditControl); - - if not(Style and SS_ENDELLIPSIS = SS_ENDELLIPSIS) and - not(Style and SS_PATHELLIPSIS = SS_PATHELLIPSIS) and - not(Style and SS_WORDELLIPSIS = SS_WORDELLIPSIS) then - include(Result, tfWordBreak); - end; -end; - -procedure TSysStaticStyleHook.Paint(Canvas: TCanvas); -const - States: array [Boolean] of TThemedTextLabel = (ttlTextLabelDisabled, - ttlTextLabelNormal); -var - LDetails: TThemedElementDetails; - LRect: TRect; -begin - LRect := SysControl.ClientRect; - if GetBkMode(Canvas.Handle) = TRANSPARENT then - begin - LDetails := StyleServices.GetElementDetails(tbCheckBoxUncheckedNormal); - StyleServices.DrawParentBackground(Handle, Canvas.Handle, LDetails, False); - Canvas.Brush.Style := bsClear; - end - else - begin - Canvas.Brush.Color := StyleServices.GetStyleColor(scWindow); - Canvas.FillRect(LRect); - end; - - LDetails := StyleServices.GetElementDetails(States[SysControl.Enabled]); - Canvas.Font := SysControl.Font; - DrawText(Canvas.Handle, LDetails, SysControl.Text, LRect, TextFormat); -end; - -procedure TSysStaticStyleHook.PaintNC(Canvas: TCanvas); -var - LRect: TRect; - LBitMap: TBitmap; -begin - if IsFrameOrLine then - begin - LRect := Rect(0, 0, SysControl.Width, SysControl.Height); - LBitMap := TBitmap.Create; - try - LBitMap.Width := LRect.Width; - LBitMap.Height := LRect.Height; - Frame3D(LBitMap.Canvas, LRect, StyleServices.ColorToRGB(clBtnShadow), - StyleServices.ColorToRGB(clBtnHighLight), 1); - ExcludeClipRect(Canvas.Handle, 1, 1, SysControl.Width - 1, - SysControl.Height - 1); - Canvas.Draw(0, 0, LBitMap); - finally - LBitMap.Free; - end; - end; -end; - -procedure TSysStaticStyleHook.UpdateColors; -const - ColorStates: array [Boolean] of TStyleColor = (scEditDisabled, scEdit); - FontColorStates: array [Boolean] of TStyleFont = (sfEditBoxTextDisabled, - sfEditBoxTextNormal); -begin - Color := StyleServices.GetStyleColor(scWindow); - FontColor := StyleServices.GetSystemColor(clWindowText); - //Addlog(Format('UpdateColors Handle %d Color %d FontColor %d ',[SysControl.Handle, Color, FontColor])); -end; - -procedure TSysStaticStyleHook.WndProc(var Message: TMessage); -begin - //Addlog(Format('TSysStaticStyleHook $0x%x %s', [SysControl.Handle, WM_To_String(Message.Msg)])); - case Message.Msg of - - WM_SETTEXT: - begin - CallDefaultProc(Message); - if SysControl.Visible then - Invalidate; - - end; - - WM_ENABLE: - if SysControl.Visible then - Invalidate; - - WM_PAINT: - begin - if OverridePaint and StyleServicesEnabled then - begin - if (IsText and (Length(SysControl.Text) > 0)) then - inherited - else - CallDefaultProc(Message); - end - else - CallDefaultProc(Message); - end; - - else - inherited; - end; -end; - -{ TSysCheckBoxStyleHook } -function RectVCenter(var R: TRect; Bounds: TRect): TRect; -begin - OffsetRect(R, -R.Left, -R.Top); - OffsetRect(R, 0, (Bounds.Height - R.Height) div 2); - OffsetRect(R, Bounds.Left, Bounds.Top); - - Result := R; -end; - -procedure TSysCheckBoxStyleHook.BMSetCheck(var Message: TMessage); -begin - SetRedraw(False); - CallDefaultProc(TMessage(Message)); - SetRedraw(True); - Invalidate; - Handled := True; -end; - -constructor TSysCheckBoxStyleHook.Create(AHandle: THandle); -begin - inherited; - OverridePaint := True; - OverrideEraseBkgnd := True; - // DoubleBuffered := True; -end; - -function TSysCheckBoxStyleHook.GetDrawState(State: TSysCheckBoxState) - : TThemedButton; -begin - Result := tbButtonDontCare; - - if not SysControl.Enabled then - case State of - cbUnchecked: - Result := tbCheckBoxUncheckedDisabled; - cbChecked: - Result := tbCheckBoxCheckedDisabled; - cbGrayed: - Result := tbCheckBoxMixedDisabled; - end - else if Pressed and MouseInControl then - case State of - cbUnchecked: - Result := tbCheckBoxUncheckedPressed; - cbChecked: - Result := tbCheckBoxCheckedPressed; - cbGrayed: - Result := tbCheckBoxMixedPressed; - end - else if MouseInControl then - case State of - cbUnchecked: - Result := tbCheckBoxUncheckedHot; - cbChecked: - Result := tbCheckBoxCheckedHot; - cbGrayed: - Result := tbCheckBoxMixedHot; - end - else - case State of - cbUnchecked: - Result := tbCheckBoxUncheckedNormal; - cbChecked: - Result := tbCheckBoxCheckedNormal; - cbGrayed: - Result := tbCheckBoxMixedNormal; - end; -end; - -procedure TSysCheckBoxStyleHook.MouseEnter; -begin - inherited; - Invalidate; - Handled := True; -end; - -procedure TSysCheckBoxStyleHook.MouseLeave; -begin - inherited; - Invalidate; - Handled := True; -end; - -procedure TSysCheckBoxStyleHook.Paint(Canvas: TCanvas); -var - State: TSysCheckBoxState; - Details: TThemedElementDetails; - R: TRect; - Spacing: Integer; - BoxSize: TSize; - LCaption: string; - LRect: TRect; - ElementSize: TElementSize; -begin - if StyleServices.Available then - begin - State := TSysCheckBoxState(SendMessage(Handle, BM_GETCHECK, 0, 0)); - Details := StyleServices.GetElementDetails(GetDrawState(State)); - - Spacing := 3; - LRect := System.Classes.Rect(0, 0, 20, 20); - ElementSize := esActual; - R := SysControl.ClientRect; - with StyleServices do - if not GetElementSize(Canvas.Handle, - GetElementDetails(tbCheckBoxCheckedNormal), LRect, ElementSize, BoxSize) - then - begin - BoxSize.cx := GetSystemMetrics(SM_CXMENUCHECK); - BoxSize.cy := GetSystemMetrics(SM_CYMENUCHECK); - end; - if not RightAlignment then - begin - R := Rect(0, 0, BoxSize.cx, BoxSize.cy); - RectVCenter(R, Rect(0, 0, SysControl.Width, SysControl.Height)); - end - else - begin - R := Rect(SysControl.Width - BoxSize.cx - 1, 0, SysControl.Width, - SysControl.Height); - RectVCenter(R, Rect(SysControl.Width - BoxSize.cy - 1, 0, - SysControl.Width, SysControl.Height)); - end; - - StyleServices.DrawElement(Canvas.Handle, Details, R); - Canvas.Font := SysControl.Font; - - R := Rect(0, 0, SysControl.Width - BoxSize.cx - 10, SysControl.Height); - LCaption := Text; - Winapi.Windows.DrawText(Canvas.Handle, PWideChar(LCaption), - Length(LCaption), R, SysControl.DrawTextBiDiModeFlags(DT_CALCRECT or - DT_EXPANDTABS)); - - if not RightAlignment then - RectVCenter(R, Rect(BoxSize.cx + Spacing, 0, SysControl.Width, - SysControl.Height)) - else - begin - if SysControl.BiDiMode <> bmRightToLeft then - RectVCenter(R, Rect(3, 0, SysControl.Width - BoxSize.cx - Spacing, - SysControl.Height)) - else - RectVCenter(R, Rect(SysControl.Width - BoxSize.cx - Spacing - R.Right, - 0, SysControl.Width - BoxSize.cx - Spacing, SysControl.Height)); - end; - - DrawControlText(Canvas, Details, LCaption, R, - SysControl.DrawTextBiDiModeFlags(DT_LEFT or DT_VCENTER or DT_EXPANDTABS)); - - if Focused then - begin - InflateRect(R, 2, 1); - if R.Top < 0 then - R.Top := 0; - if R.Bottom > SysControl.Height then - R.Bottom := SysControl.Height; - Canvas.Brush.Color := StyleServices.GetSystemColor(clBtnFace); - Canvas.DrawFocusRect(R); - end; - end; -end; - -procedure TSysCheckBoxStyleHook.PaintBackground(Canvas: TCanvas); -var - Details: TThemedElementDetails; -begin - if StyleServices.Available then - begin - Details.Element := teButton; - if StyleServices.HasTransparentParts(Details) then - StyleServices.DrawParentBackground(Handle, Canvas.Handle, Details, False); - end; -end; - -function TSysCheckBoxStyleHook.RightAlignment: Boolean; -begin - Result := (SysControl.BiDiMode = bmRightToLeft) or - (GetWindowLong(Handle, GWL_STYLE) and BS_RIGHTBUTTON = BS_RIGHTBUTTON); - -end; - -procedure TSysCheckBoxStyleHook.WMKeyDown(var Message: TWMKeyDown); -begin - if Message.CharCode = VK_SPACE then - SetRedraw(False); - CallDefaultProc(TMessage(Message)); - if Message.CharCode = VK_SPACE then - begin - SetRedraw(True); - Invalidate; - end; - Handled := True; -end; - -procedure TSysCheckBoxStyleHook.WMKeyUp(var Message: TWMKeyUp); -begin - if Message.CharCode = VK_SPACE then - SetRedraw(False); - CallDefaultProc(TMessage(Message)); - if Message.CharCode = VK_SPACE then - begin - SetRedraw(True); - Invalidate; - end; - Handled := True; -end; - -procedure TSysCheckBoxStyleHook.WMLButtonDblClk(var Message: TWMMouse); -begin - SetRedraw(False); - CallDefaultProc(TMessage(Message)); - SetRedraw(True); - Invalidate; - Handled := True; -end; - -procedure TSysCheckBoxStyleHook.WMLButtonDown(var Message: TWMMouse); -begin - SetRedraw(False); - CallDefaultProc(TMessage(Message)); - SetRedraw(True); - FPressed := True; - Invalidate; - Handled := True; -end; - -procedure TSysCheckBoxStyleHook.WMLButtonUp(var Message: TWMMouse); -begin - SetRedraw(False); - CallDefaultProc(TMessage(Message)); - SetRedraw(True); - FPressed := False; - Invalidate; - Handled := True; -end; - -procedure TSysCheckBoxStyleHook.WndProc(var Message: TMessage); -begin - inherited; -end; - -{ TSysRadioButtonStyleHook } - -constructor TSysRadioButtonStyleHook.Create(AHandle: THandle); -begin - inherited; - OverridePaint := True; - OverrideEraseBkgnd := True; - // DoubleBuffered := True; -end; - -function TSysRadioButtonStyleHook.GetDrawState(State: TSysCheckBoxState) - : TThemedButton; -begin - Result := tbButtonDontCare; - - if not SysControl.Enabled then - case State of - cbUnchecked: - Result := tbRadioButtonUncheckedDisabled; - cbChecked: - Result := tbRadioButtonCheckedDisabled; - end - else if Pressed and MouseInControl then - case State of - cbUnchecked: - Result := tbRadioButtonUncheckedPressed; - cbChecked: - Result := tbRadioButtonCheckedPressed; - end - else if MouseInControl then - case State of - cbUnchecked: - Result := tbRadioButtonUncheckedHot; - cbChecked: - Result := tbRadioButtonCheckedHot; - end - else - case State of - cbUnchecked: - Result := tbRadioButtonUncheckedNormal; - cbChecked: - Result := tbRadioButtonCheckedNormal; - end; -end; - -procedure TSysRadioButtonStyleHook.WndProc(var Message: TMessage); -begin - inherited; -end; - -initialization - -if StyleServices.Available then -begin - with TSysStyleManager do - begin - RegisterSysStyleHook(WC_BUTTON, TSysButtonStyleHook); - RegisterSysStyleHook(WC_EDIT, TSysEditStyleHook); - RegisterSysStyleHook('ComboLBox', TSysListBoxStyleHook); - RegisterSysStyleHook(WC_COMBOBOX, TSysComboBoxStyleHook); - RegisterSysStyleHook( 'ListBox', TSysListBoxStyleHook); - RegisterSysStyleHook( 'Static', TSysStaticStyleHook); - end; -end; - -finalization - -with TSysStyleManager do -begin - UnRegisterSysStyleHook(WC_BUTTON, TSysButtonStyleHook); - UnRegisterSysStyleHook(WC_EDIT, TSysEditStyleHook); - UnRegisterSysStyleHook('ComboLBox', TSysListBoxStyleHook); - UnRegisterSysStyleHook(WC_COMBOBOX, TSysComboBoxStyleHook); - UnRegisterSysStyleHook('ListBox', TSysListBoxStyleHook); - UnRegisterSysStyleHook('Static', TSysStaticStyleHook); -end; - -end. +// ************************************************************************************************** +// +// Unit Vcl.Styles.Utils.StdCtrls +// unit for the VCL Styles Utils +// https://github.com/RRUZ/vcl-styles-utils/ +// +// 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. +// +// +// Portions created by Mahdi Safsafi [SMP3] e-mail SMP@LIVE.FR +// Portions created by Rodrigo Ruz V. are Copyright (C) 2013-2023 Rodrigo Ruz V. +// All Rights Reserved. +// +// ************************************************************************************************** +unit Vcl.Styles.Utils.StdCtrls; + +interface + +uses + System.Classes, + System.SysUtils, + System.Types, + Winapi.Windows, + Winapi.Messages, + Winapi.CommCtrl, + Vcl.Themes, + Vcl.Graphics, + Vcl.Styles.Utils.SysStyleHook, + Vcl.Forms, + Vcl.StdCtrls, + Vcl.Styles.Utils.Forms, + Vcl.GraphUtil, + Vcl.Controls; + +const + BS_SPLITBUTTON = $0000000C; +{$EXTERNALSYM BS_DEFSPLITBUTTON} + BS_DEFSPLITBUTTON = $0000000D; +{$EXTERNALSYM BS_COMMANDLINK} + BS_COMMANDLINK = $0000000E; +{$EXTERNALSYM BS_DEFCOMMANDLINK} + BS_DEFCOMMANDLINK = $0000000F; + +type + TSysCheckBoxState = (cbUnchecked, cbChecked, cbGrayed); + + TSysButtonStyleHook = class(TMouseTrackSysControlStyleHook) + private + function GetCaptionRect(Canvas: TCanvas): TRect; + function GetBoxRect: TRect; + function IsCheckBox: Boolean; + function IsRadioButton: Boolean; + function IsGroupBox: Boolean; + function IsPushButton: Boolean; + function IsSplitButton: Boolean; + function IsCommandButton: Boolean; + function GetTextAlign: TTextFormat; + function GetShowText: Boolean; + function GetCheckBoxState: TSysCheckBoxState; + procedure WMPaint(var Message: TMessage); message WM_PAINT; + procedure WMNCPaint(var Message: TMessage); message WM_NCPAINT; + procedure WMEraseBkgnd(var Message: TMessage); message WM_ERASEBKGND; + function IsOwnerDraw: Boolean; + protected + procedure DrawCheckBoxText(DC: HDC; Text: String; + LDetails: TThemedElementDetails; R: TRect); virtual; + procedure PaintButton(Canvas: TCanvas); virtual; + procedure PaintCheckBox(Canvas: TCanvas); virtual; + procedure PaintRadioButton(Canvas: TCanvas); virtual; + procedure PaintGroupBox(Canvas: TCanvas); virtual; + procedure MouseEnter; override; + procedure MouseLeave; override; + procedure Paint(Canvas: TCanvas); override; + procedure PaintNC(Canvas: TCanvas); override; + procedure PaintBackground(Canvas: TCanvas); override; + procedure WndProc(var Message: TMessage); override; + procedure UpdateColors; override; + public + constructor Create(AHandle: THandle); override; + Destructor Destroy; override; + property CheckBox: Boolean read IsCheckBox; + property CommandButton: Boolean read IsCommandButton; + property RadioButton: Boolean read IsRadioButton; + property GroupBox: Boolean read IsGroupBox; + property PushButton: Boolean read IsPushButton; + property SplitButton: Boolean read IsSplitButton; + property CheckBoxState: TSysCheckBoxState read GetCheckBoxState; + property TextAlign: TTextFormat read GetTextAlign; + property ShowText: Boolean read GetShowText; + property OwnerDraw: Boolean read IsOwnerDraw; + end; + + TSysEditStyleHook = class(TMouseTrackSysControlStyleHook) + private + procedure WMNCCalcSize(var Message: TWMNCCalcSize); message WM_NCCALCSIZE; + protected + procedure PaintNC(Canvas: TCanvas); override; + procedure WndProc(var Message: TMessage); override; + procedure UpdateColors; override; + procedure MouseEnter; override; + procedure MouseLeave; override; + function GetBorderSize: TRect; override; + public + constructor Create(AHandle: THandle); override; + Destructor Destroy; override; + end; + + TSysMemoStyleHook = class(TSysScrollingStyleHook) + strict protected + procedure UpdateColors; override; + procedure WndProc(var Message: TMessage); override; + function GetBorderSize: TRect; override; + public + constructor Create(AHandle: THandle); override; + end; + + TSysListBoxStyleHook = class(TSysScrollingStyleHook) + protected + function GetBorderSize: TRect; override; + procedure WndProc(var Message: TMessage); override; + procedure UpdateColors; override; + procedure PaintBackground(Canvas: TCanvas); override; + public + constructor Create(AHandle: THandle); override; + Destructor Destroy; override; + end; + + TSysComboBoxStyleHook = class(TMouseTrackSysControlStyleHook) + strict private + FDownPos, FMovePos: TPoint; + FDownSliderPos: Integer; + FOldIdx, FInvsibleCount, FSliderSize: Integer; + FVSliderState, FVUpState, FVDownState: TThemedScrollBar; + FIgnoreStyleChanged: Boolean; + FMouseOnButton: Boolean; + FListHandle, FEditHandle: HWnd; + FListBoxInstance: Pointer; + FDefListBoxProc: Pointer; + FListBoxTimerCode: Integer; + FListBoxUpBtnDown, FListBoxDownBtnDown, FListBoxTrackUpDown, + FListBoxTrackDownDown: Boolean; + procedure DrawListBoxVertScroll(DC: HDC); + procedure DrawListBoxBorder; + function IsDroppedDown: Boolean; + function GetButtonRect: TRect; + function Style: TComboBoxStyle; + function ListBoxBoundsRect: TRect; + function ListBoxClientRect: TRect; + procedure ListBoxSetTimer(const ATimerCode: Integer); + procedure ListBoxStopTimer; + function ListBoxVertScrollRect: TRect; + function ListBoxVertDownButtonRect: TRect; + function ListBoxVertUpButtonRect: TRect; + function ListBoxVertScrollArea: TRect; + function ListBoxVertSliderRect: TRect; + function ListBoxVertTrackRect: TRect; + function ListBoxVertTrackRectUp: TRect; + function ListBoxVertTrackRectDown: TRect; + procedure PaintListBoxBorder(Canvas: TCanvas; const R: TRect); + procedure WMCommand(var Message: TWMCommand); message WM_COMMAND; + procedure CNCommand(var Message: TWMCommand); message CN_COMMAND; + procedure WMPaint(var Message: TMessage); message WM_PAINT; + procedure WMMouseMove(var Message: TWMMouse); message WM_MOUSEMOVE; + procedure CNDrawItem(var Message: TWMDrawItem); message CN_DRAWITEM; + procedure WMDrawItem(var Message: TWMDrawItem); message WM_DRAWITEM; + procedure WMParentNotify(var Message: TMessage); message WM_PARENTNOTIFY; + strict protected + procedure UpdateColors; override; + function IsChildHandle(AHandle: HWnd): Boolean; override; + procedure DrawItem(Canvas: TCanvas;const Index: UINT; const R: TRect; + const Selected: Boolean); virtual; + procedure HookListBox(AListHandle: HWnd); + property ListBoxInstance: Pointer read FListBoxInstance; + procedure ListBoxWndProc(var Msg: TMessage); virtual; + property ListHandle: HWnd read FListHandle; + procedure MouseEnter; override; + procedure MouseLeave; override; + procedure PaintBorder(Canvas: TCanvas); virtual; + procedure WndProc(var Message: TMessage); override; + function CallDefaultListBoxProc(var Msg: TMessage): LRESULT; + property ButtonRect: TRect read GetButtonRect; + property MouseOnButton: Boolean read FMouseOnButton write FMouseOnButton; + property DroppedDown: Boolean read IsDroppedDown; + public + constructor Create(AHandle: THandle); override; + Destructor Destroy; override; + end; + + TSysStaticStyleHook = class(TSysStyleHook) + private + FUpdatedColor: TColor; + function GetIsText: Boolean; + function GetTextFormat: TTextFormat; + function GetIsFrameOrLine: Boolean; + protected + procedure Paint(Canvas: TCanvas); override; + procedure PaintNC(Canvas: TCanvas); override; + procedure UpdateColors; override; + procedure WndProc(var Message: TMessage); override; + public + constructor Create(AHandle: THandle); override; + Destructor Destroy; override; + property IsText: Boolean read GetIsText; + property IsFrameOrLine: Boolean read GetIsFrameOrLine; + property TextFormat: TTextFormat read GetTextFormat; + end; + + TSysCheckBoxStyleHook = class(TMouseTrackSysControlStyleHook) + strict private + FPressed: Boolean; + procedure WMLButtonDown(var Message: TWMMouse); message WM_LBUTTONDOWN; + procedure WMLButtonUp(var Message: TWMMouse); message WM_LBUTTONUP; + procedure WMLButtonDblClk(var Message: TWMMouse); message WM_LBUTTONDBLCLK; + procedure WMKeyDown(var Message: TWMKeyDown); message WM_KEYDOWN; + procedure WMKeyUp(var Message: TWMKeyUp); message WM_KEYUP; + procedure BMSetCheck(var Message: TMessage); message BM_SETCHECK; + function RightAlignment: Boolean; + strict protected + function GetDrawState(State: TSysCheckBoxState): TThemedButton; virtual; + procedure Paint(Canvas: TCanvas); override; + procedure PaintBackground(Canvas: TCanvas); override; + procedure MouseEnter; override; + procedure MouseLeave; override; + procedure WndProc(var Message: TMessage); override; + property Pressed: Boolean read FPressed; + public + constructor Create(AHandle: THandle); override; + end; + + TSysRadioButtonStyleHook = class(TSysCheckBoxStyleHook) + strict protected + function GetDrawState(State: TSysCheckBoxState): TThemedButton; override; + procedure WndProc(var Message: TMessage); override; + public + constructor Create(AHandle: THandle); override; + end; + + +implementation + +uses + Vcl.ExtCtrls, + System.UITypes, + Vcl.Styles.Utils.Misc, + Vcl.Styles.Utils.SysControls, Vcl.Styles.Utils.Graphics; + +{ TSysEditStyleHook } + +constructor TSysEditStyleHook.Create(AHandle: THandle); +begin + inherited; +{$IF CompilerVersion > 23} + StyleElements := [seFont, seBorder]; +{$ELSE} + OverridePaint := False; + OverridePaintNC := True; + OverrideFont := True; +{$IFEND} +end; + +destructor TSysEditStyleHook.Destroy; +begin + inherited; +end; + +function TSysEditStyleHook.GetBorderSize: TRect; +begin + if SysControl.HasBorder then + Result := Rect(2, 2, 2, 2) + else + Result := Rect(0, 0, 0, 0); +end; + +procedure TSysEditStyleHook.MouseEnter; +begin + InvalidateNC; +end; + +procedure TSysEditStyleHook.MouseLeave; +begin + InvalidateNC; +end; + +procedure TSysEditStyleHook.PaintNC(Canvas: TCanvas); +var + Details: TThemedElementDetails; + R: TRect; +begin + if StyleServicesEnabled and SysControl.HasBorder then + begin + if Focused then + Details := StyleServices.GetElementDetails(teEditBorderNoScrollFocused) + else if MouseInControl then + Details := StyleServices.GetElementDetails(teEditBorderNoScrollHot) + else if SysControl.Enabled then + Details := StyleServices.GetElementDetails(teEditBorderNoScrollNormal) + else + Details := StyleServices.GetElementDetails(teEditBorderNoScrollDisabled); + R := Rect(0, 0, SysControl.Width, SysControl.Height); + InflateRect(R, -2, -2); + ExcludeClipRect(Canvas.Handle, R.Left, R.Top, R.Right, R.Bottom); + DrawStyleElement(Canvas.Handle, Details, + Rect(0, 0, SysControl.Width, SysControl.Height)); + end; +end; + +procedure TSysEditStyleHook.UpdateColors; +const + ColorStates: array [Boolean] of TStyleColor = (scEditDisabled, scEdit); + FontColorStates: array [Boolean] of TStyleFont = (sfEditBoxTextDisabled, + sfEditBoxTextNormal); +begin + Color := StyleServices.GetStyleColor(ColorStates[SysControl.Enabled]); +{$IF CompilerVersion > 23} + if seFont in StyleElements then + FontColor := StyleServices.GetStyleFontColor + (FontColorStates[SysControl.Enabled]) + else + FontColor := clWindowText; +{$ELSE} + FontColor := StyleServices.GetStyleFontColor + (FontColorStates[SysControl.Enabled]); +{$IFEND} +end; + +procedure TSysEditStyleHook.WMNCCalcSize(var Message: TWMNCCalcSize); +var + Params: PNCCalcSizeParams; +begin + Handled := False; + if (not StyleServicesEnabled) or (not OverridePaintNC) then + Exit; + + Params := Message.CalcSize_Params; + if SysControl.HasBorder then + with Params^.rgrc[0] do + begin + Inc(Left, 2); + Inc(Top, 2); + Dec(Right, 2); + Dec(Bottom, 2); + end; + Handled := True; +end; + +procedure TSysEditStyleHook.WndProc(var Message: TMessage); +begin + case Message.Msg of + CM_CTLCOLORMSGBOX .. CM_CTLCOLORSTATIC: + begin + { Change edit control color . } + SetTextColor(Message.wParam, ColorToRGB(FontColor)); + SetBkColor(Message.wParam, ColorToRGB(Color)); + Message.Result := LRESULT(Brush.Handle); + end; + else + inherited WndProc(Message); + end; + +end; + +{ TSysListBoxStyleHook } + +constructor TSysListBoxStyleHook.Create(AHandle: THandle); +begin + inherited; +{$IF CompilerVersion > 23} + StyleElements := [seBorder]; +{$ELSE} + OverridePaint := False; + OverridePaintNC := True; + OverrideFont := False; +{$IFEND} + //OverrideEraseBkgnd:=True; +end; + +destructor TSysListBoxStyleHook.Destroy; +begin + + inherited; +end; + +function TSysListBoxStyleHook.GetBorderSize: TRect; +begin + Result := inherited GetBorderSize; + if (SysControl.HasBorder) then + begin + Result := Rect(2, 2, 2, 2); + end; + if SameText(SysControl.ControlClassName, 'ComboLBox') then + begin + if SysControl.Parent.Style and CBS_SIMPLE = CBS_SIMPLE then + Exit; + Result := Rect(0, 0, 0, 0); + end; +end; + +procedure TSysListBoxStyleHook.PaintBackground(Canvas: TCanvas); +begin + inherited; +end; + +procedure TSysListBoxStyleHook.UpdateColors; +const + ColorStates: array[Boolean] of TStyleColor = (scListBoxDisabled, scListBox); + FontColorStates: array[Boolean] of TStyleFont = (sfListItemTextDisabled, sfListItemTextNormal); +var + LStyle: TCustomStyleServices; +begin + LStyle := StyleServices; + Brush.Color := LStyle.GetStyleColor(ColorStates[SysControl.Enabled]); + FontColor := LStyle.GetStyleFontColor(FontColorStates[SysControl.Enabled]); +end; + +procedure TSysListBoxStyleHook.WndProc(var Message: TMessage); +begin + inherited; +end; + +{ TSysButtonStyleHook } + +constructor TSysButtonStyleHook.Create(AHandle: THandle); +begin + inherited; + ParentColor := True; +{$IF CompilerVersion > 23} + StyleElements := [seFont, seClient, seBorder]; +{$ELSE} + OverridePaint := True; + OverridePaintNC := True; + OverrideFont := True; +{$IFEND} + Color := StyleServices.GetStyleColor(scWindow); +end; + +destructor TSysButtonStyleHook.Destroy; +begin + + inherited; +end; + +procedure TSysButtonStyleHook.DrawCheckBoxText(DC: HDC; Text: String; + LDetails: TThemedElementDetails; R: TRect); +var + TextFormat: TTextFormat; +begin + if ShowText then + begin + TextFormat := [tfVerticalCenter, tfHidePrefix]; + if (SysControl.Style and BS_MULTILINE = BS_MULTILINE) then + include(TextFormat, tfWordBreak) + else + include(TextFormat, tfSingleLine); + if (SysControl.Style and BS_LEFT = BS_LEFT) then + include(TextFormat, tfLeft) + else if (SysControl.Style and BS_RIGHT = BS_RIGHT) then + include(TextFormat, tfRight) + else if (SysControl.Style and BS_CENTER = BS_CENTER) then + include(TextFormat, tfCenter); + DrawText(DC, LDetails, SysControl.Text, R, TextFormat); + end; +end; + +function TSysButtonStyleHook.GetCheckBoxState: TSysCheckBoxState; +var + LState: DWORD; +begin + LState := SendMessage(Handle, BM_GETCHECK, 0, 0); + Result := TSysCheckBoxState(LState) +end; + +function TSysButtonStyleHook.GetShowText: Boolean; +begin + Result := (SysControl.Style and BS_TEXT = BS_TEXT); +end; + +function TSysButtonStyleHook.GetTextAlign: TTextFormat; +begin + Result := []; + with SysControl do + begin + // if Style and BS_LEFTTEXT then + + end; +end; + +function TSysButtonStyleHook.IsCheckBox: Boolean; +begin + with SysControl do + Result := (Style and BS_CHECKBOX = BS_CHECKBOX) or + (Style and BS_AUTOCHECKBOX = BS_AUTOCHECKBOX); +end; + +function TSysButtonStyleHook.IsCommandButton: Boolean; +begin + Result := (SysControl.Style and BS_COMMANDLINK = BS_COMMANDLINK) or + (SysControl.Style and BS_DEFCOMMANDLINK = BS_DEFCOMMANDLINK); +end; + +function TSysButtonStyleHook.IsGroupBox: Boolean; +begin + Result := (SysControl.Style and BS_GROUPBOX = BS_GROUPBOX); +end; + +function TSysButtonStyleHook.IsOwnerDraw: Boolean; +begin + Result := (SysControl.Style and BS_OWNERDRAW = BS_OWNERDRAW); +end; + +function TSysButtonStyleHook.IsPushButton: Boolean; +begin + with SysControl do + Result := (Style and BS_PUSHBUTTON = BS_PUSHBUTTON) or + (not CheckBox and not RadioButton and not GroupBox and not CommandButton); +end; + +function TSysButtonStyleHook.IsRadioButton: Boolean; +begin + with SysControl do + Result := (Style and BS_RADIOBUTTON = BS_RADIOBUTTON) or + (Style and BS_AUTORADIOBUTTON = BS_AUTORADIOBUTTON); + + if Result then + Result:= not IsSplitButton; +end; + +function TSysButtonStyleHook.IsSplitButton: Boolean; +begin + Result := (SysControl.Style and BS_SPLITBUTTON = BS_SPLITBUTTON) or + (SysControl.Style and BS_DEFSPLITBUTTON = BS_DEFSPLITBUTTON); + +end; + +procedure TSysButtonStyleHook.MouseEnter; +begin + // Invalidate; +end; + +procedure TSysButtonStyleHook.MouseLeave; +begin + Invalidate; +end; + +procedure TSysButtonStyleHook.Paint(Canvas: TCanvas); +begin + //OutputDebugString(PChar('Paint '+IntToHex(SysControl.Handle, 8))); + if not GroupBox or CommandButton then + PaintBackground(Canvas) + else + Exit; + + if CommandButton then + PaintButton(Canvas) + else + if CheckBox then + PaintCheckBox(Canvas) + else + if RadioButton then + PaintRadioButton(Canvas) + else + if PushButton then + PaintButton(Canvas); + +end; + +procedure TSysButtonStyleHook.PaintBackground(Canvas: TCanvas); +begin + if not GroupBox then + inherited; +end; + +procedure TSysButtonStyleHook.PaintButton(Canvas: TCanvas); +var + LDetails: TThemedElementDetails; + LRect: TRect; + Detail: TThemedButton; + X, Y, i: Integer; + IW, IH, IY: Integer; + TextFormat: TTextFormat; + IL: BUTTON_IMAGELIST; + LText: string; + DrawRect: TRect; + ThemeTextColor: TColor; + Buffer: string; + BufferLength: Integer; +begin + Canvas.Font.Assign(SysControl.Font); + LText := SysControl.Text; + LRect := SysControl.ClientRect; + + if SysControl.Enabled then + Detail := tbPushButtonNormal + else + Detail := tbPushButtonDisabled; + + if MouseDown then + Detail := tbPushButtonPressed + else + if MouseInControl then + Detail := tbPushButtonHot + else + if Focused then + Detail := tbPushButtonDefaulted; + + LDetails := StyleServices.GetElementDetails(Detail); + DrawRect := SysControl.ClientRect; + DrawStyleElement(Canvas.Handle, LDetails, LRect); + + + if Button_GetImageList(handle, IL) and (IL.himl <> 0) and + ImageList_GetIconSize(IL.himl, IW, IH) then + begin + if (GetWindowLong(Handle, GWL_STYLE) and BS_COMMANDLINK) = BS_COMMANDLINK then + IY := DrawRect.Top + 15 + else + IY := DrawRect.Top + (DrawRect.Height - IH) div 2; + ImageList_Draw(IL.himl, 0, Canvas.Handle, DrawRect.Left + 3, IY, ILD_NORMAL); + Inc(DrawRect.Left, IW + 3); + end; + + if CommandButton then + begin + if IL.himl = 0 then + Inc(DrawRect.Left, 35); + Inc(DrawRect.Top, 15); + Inc(DrawRect.Left, 5); + Canvas.Font := SysControl.Font; + TextFormat := TTextFormatFlags(DT_LEFT); + if StyleServices.GetElementColor(LDetails, ecTextColor, ThemeTextColor) then + Canvas.Font.Color := ThemeTextColor; + StyleServices.DrawText(Canvas.Handle, LDetails, LText, DrawRect, TextFormat, Canvas.Font.Color); + SetLength(Buffer, Button_GetNoteLength(Handle) + 1); + if Length(Buffer) <> 0 then + begin + BufferLength := Length(Buffer); + if Button_GetNote(Handle, PChar(Buffer), BufferLength) then + begin + TextFormat := TTextFormatFlags(DT_LEFT or DT_WORDBREAK); + Inc(DrawRect.Top, Canvas.TextHeight('Wq') + 2); + Canvas.Font.Size := 8; + StyleServices.DrawText(Canvas.Handle, LDetails, Buffer, DrawRect, + TextFormat, Canvas.Font.Color); + end; + end; + if IL.himl = 0 then + begin + if MouseDown then + LDetails := StyleServices.GetElementDetails(tbCommandLinkGlyphPressed) + else if MouseInControl then + LDetails := StyleServices.GetElementDetails(tbCommandLinkGlyphHot) + else if SysControl.Enabled then + LDetails := StyleServices.GetElementDetails(tbCommandLinkGlyphNormal) + else + LDetails := StyleServices.GetElementDetails(tbCommandLinkGlyphDisabled); + DrawRect.Right := 35; + DrawRect.Left := 3; + DrawRect.Top := 10; + DrawRect.Bottom := DrawRect.Top + 32; + StyleServices.DrawElement(Canvas.Handle, LDetails, DrawRect); + end; + + end + else + if SplitButton then + with Canvas, SysControl do + begin + { draw vertical line } + Pen.Color := StyleServices.GetSystemColor(clBtnShadow); + MoveTo(Width - 15, 3); + LineTo(Width - 15, Height - 3); + if Enabled then + Pen.Color := StyleServices.GetSystemColor(clBtnHighLight) + else + Pen.Color := Font.Color; + MoveTo(Width - 14, 3); + LineTo(Width - 14, Height - 3); + { Draw arrow } + Pen.Color := Font.Color; + X := Width - 8; + Y := Height div 2 + 1; + for i := 3 downto 0 do + begin + MoveTo(X - i, Y - i); + LineTo(X + i + 1, Y - i); + end; + end; + + if ShowText and not IsCommandButton then + begin + TextFormat := [tfCenter, tfVerticalCenter, tfSingleLine, tfHidePrefix]; + if (SysControl.Style and BS_MULTILINE = BS_MULTILINE) then + begin + Exclude(TextFormat, tfSingleLine); + include(TextFormat, tfWordBreak); + end; + + + DrawText(Canvas.Handle, LDetails, SysControl.Text, LRect, TextFormat); + end; +end; + +function TSysButtonStyleHook.GetBoxRect: TRect; +var + DC: HDC; + sSize: TSize; +begin + DC := GetDC(Handle); + with SysControl do + begin + GetTextExtentPoint32(DC, Text, Length(Text) - 1, sSize); + Result := Rect(0, sSize.Height div 2 + 1, Width - 0, Height - 0); + end; + ReleaseDC(Handle, DC); + DeleteDC(DC); +end; + +function TSysButtonStyleHook.GetCaptionRect(Canvas: TCanvas): TRect; +const + FCaptionMargin = 12; +begin + with SysControl do + if BiDiMode <> bmRightToLeft then + Result := Rect(FCaptionMargin, 0, FCaptionMargin + Canvas.TextWidth(Text), + Canvas.TextHeight(Text)) + else + Result := Rect(Width - Canvas.TextWidth(Text) - FCaptionMargin, 0, + Width - FCaptionMargin, Canvas.TextHeight(Text)); +end; + +procedure TSysButtonStyleHook.PaintRadioButton(Canvas: TCanvas); +var + LDetails: TThemedElementDetails; + DC: HDC; + LRect: TRect; + Detail: TThemedButton; + TxtRect, BoxRect: TRect; + LState: TSysCheckBoxState; + Size: TSize; +begin + Canvas.Font.Assign(SysControl.Font); + DC := Canvas.Handle; + LRect := SysControl.ClientRect; + LState := CheckBoxState; + Canvas.Brush.Color := Color; + Canvas.FillRect(LRect); + if SysControl.Enabled then + Detail := tbRadioButtonUncheckedNormal + else + Detail := tbRadioButtonUncheckedDisabled; + if MouseDown then + Detail := tbRadioButtonUncheckedPressed + else if MouseInControl then + Detail := tbRadioButtonUncheckedHot; + + if LState = cbChecked then + Detail := TThemedButton(Integer(Detail) + 4); + + Size.cx := GetSysMetrics(SM_CXMENUCHECK); + Size.cy := GetSysMetrics(SM_CYMENUCHECK); + + LDetails := StyleServices.GetElementDetails(Detail); + BoxRect := Rect(0, 0, Size.cx, Size.cy); + RectVCenter(BoxRect, LRect); + + if (SysControl.Style and BS_LEFTTEXT = BS_LEFTTEXT) then + begin + BoxRect.Left := LRect.Right - BoxRect.Width - 2; + BoxRect.Right := LRect.Right; + TxtRect := Rect(LRect.Left + 1, LRect.Top, BoxRect.Left, LRect.Bottom); + end + else + begin + OffsetRect(BoxRect, 1, 0); + TxtRect := Rect(BoxRect.Right + 2, LRect.Top, LRect.Right, LRect.Bottom); + end; + + DrawStyleElement(DC, LDetails, BoxRect); + + if Focused then + Canvas.DrawFocusRect(LRect); + + DrawCheckBoxText(DC, SysControl.Text, LDetails, TxtRect); + +end; + +procedure TSysButtonStyleHook.PaintCheckBox(Canvas: TCanvas); +var + LDetails: TThemedElementDetails; + DC: HDC; + LRect: TRect; + Detail: TThemedButton; + TxtRect, BoxRect: TRect; + LState: TSysCheckBoxState; + Size: TSize; +begin + Canvas.Font.Assign(SysControl.Font); + DC := Canvas.Handle; + LRect := SysControl.ClientRect; + LState := CheckBoxState; + Canvas.Brush.Color := Color; + Canvas.FillRect(LRect); + if SysControl.Enabled then + Detail := tbCheckBoxUncheckedNormal + else + Detail := tbCheckBoxUncheckedDisabled; + if MouseDown then + Detail := tbCheckBoxUncheckedPressed + else if MouseInControl then + Detail := tbCheckBoxUncheckedHot; + + if LState = cbChecked then + Detail := TThemedButton(Integer(Detail) + 4); + if LState = cbGrayed then + Detail := TThemedButton(Integer(Detail) + 8); + + // LDetails := StyleServices.GetElementDetails(tbCheckBoxUncheckedNormal); + // StyleServices.GetElementSize(DC, LDetails, esActual, Size); + Size.cx := GetSysMetrics(SM_CXMENUCHECK); + Size.cy := GetSysMetrics(SM_CYMENUCHECK); + + LDetails := StyleServices.GetElementDetails(Detail); + BoxRect := Rect(0, 0, Size.cx, Size.cy); + BoxRect := RectVCenter(BoxRect, LRect); + + if (SysControl.Style and BS_LEFTTEXT = BS_LEFTTEXT) then + begin + BoxRect.Left := LRect.Right - BoxRect.Width - 2; + BoxRect.Right := LRect.Right; + TxtRect := Rect(LRect.Left + 1, LRect.Top, BoxRect.Left, LRect.Bottom); + end + else + begin + OffsetRect(BoxRect, 1, 0); + TxtRect := Rect(BoxRect.Right + 2, LRect.Top, LRect.Right, LRect.Bottom); + end; + + DrawStyleElement(DC, LDetails, BoxRect); + + if Focused then + Canvas.DrawFocusRect(LRect); + + DrawCheckBoxText(DC, SysControl.Text, LDetails, TxtRect); +end; + +procedure TSysButtonStyleHook.PaintGroupBox(Canvas: TCanvas); +var + R, CaptionRect: TRect; + LDetails: TThemedElementDetails; + SaveIndex: Integer; + procedure DoDrawParentBackground(DC: HDC; ARect: TRect); + begin + if SysControl.ParentHandle > 0 then + DrawParentBackground(DC, @ARect) + else + begin + Canvas.Brush.Color := StyleServices.GetStyleColor(scWindow); + Canvas.FillRect(ARect); + end; + end; + +begin + Canvas.Font.Assign(SysControl.Font); + CaptionRect := GetCaptionRect(Canvas); + R := GetBoxRect; + + if SysControl.Enabled then + LDetails := StyleServices.GetElementDetails(tbGroupBoxNormal) + else + LDetails := StyleServices.GetElementDetails(tbGroupBoxDisabled); + + { Clean caption area } + DoDrawParentBackground(Canvas.Handle, CaptionRect); + ExcludeClipRect(Canvas.Handle, R.Left + 4, CaptionRect.Height + 2, + R.Right - 4, R.Height - 2); + { Clean GroupBox corners area } + DoDrawParentBackground(Canvas.Handle, R); + + SaveIndex := SaveDC(Canvas.Handle); + + try + ExcludeClipRect(Canvas.Handle, CaptionRect.Left, CaptionRect.Top, + CaptionRect.Right, CaptionRect.Bottom); + DrawStyleElement(Canvas.Handle, LDetails, R); + finally + RestoreDC(Canvas.Handle, SaveIndex); + end; + + Inc(CaptionRect.Top, 3); + { Paint Text } + StyleServices.DrawText(Canvas.Handle, LDetails, SysControl.Text, CaptionRect, + [tfSingleLine, tfVerticalCenter, tfLeft, tfHidePrefix]); + +end; + +procedure TSysButtonStyleHook.PaintNC(Canvas: TCanvas); +begin + if GroupBox then + PaintGroupBox(Canvas); +end; + +procedure TSysButtonStyleHook.UpdateColors; +begin + inherited; +end; + +procedure TSysButtonStyleHook.WMEraseBkgnd(var Message: TMessage); +begin + if (not OwnerDraw) and (not GroupBox and ParentBkGndPainted) then + Message.Result := 1 + else + begin + Handled := False; + Exit; + end; + Handled := True; +end; + +procedure TSysButtonStyleHook.WMNCPaint(var Message: TMessage); +begin + if (not OwnerDraw and ParentBkGndPainted) then + Inherited + else + begin + Handled := False; + Exit; + end; + Handled := True; +end; + +procedure TSysButtonStyleHook.WMPaint(var Message: TMessage); +begin + if (not OwnerDraw and ParentBkGndPainted) then + Inherited + else + begin + Handled := False; + Exit; + end; + Handled := True; +end; + +procedure TSysButtonStyleHook.WndProc(var Message: TMessage); +begin + case Message.Msg of + WM_ENABLE: + begin + { Check first if Window is visible + if you dont check ..the InVisible window will be visible . + } + if SysControl.Visible then + Invalidate; + end; + + WM_STYLECHANGING, WM_STYLECHANGED: + begin + Invalidate; + end; + + WM_SETTEXT: + begin + SetRedraw(False); + CallDefaultProc(Message); + SetRedraw(True); + Invalidate; + end; + + WM_SETFOCUS, WM_KILLFOCUS: + begin + inherited; + Invalidate; + end; + + else + inherited; + end; + +end; + +{ TSysMemoStyleHook } + +constructor TSysMemoStyleHook.Create(AHandle: THandle); +begin + inherited; +{$IF CompilerVersion > 23} + StyleElements := [seBorder, seFont]; +{$ELSE} + OverridePaintNC := True; + OverrideFont := True; +{$IFEND} + UpdateColors; +end; + +function TSysMemoStyleHook.GetBorderSize: TRect; +begin + if SysControl.HasBorder then + Result := Rect(2, 2, 2, 2) + else + Result := Rect(0, 0, 0, 0); +end; + +procedure TSysMemoStyleHook.UpdateColors; +const + ColorStates: array [Boolean] of TStyleColor = (scEditDisabled, scEdit); + FontColorStates: array [Boolean] of TStyleFont = (sfEditBoxTextDisabled, + sfEditBoxTextNormal); +var + LStyle: TCustomStyleServices; +begin + LStyle := StyleServices; + Brush.Color := LStyle.GetStyleColor(ColorStates[SysControl.Enabled]); + FontColor := LStyle.GetStyleFontColor(FontColorStates[SysControl.Enabled]); +end; + +procedure TSysMemoStyleHook.WndProc(var Message: TMessage); +begin + case Message.Msg of + WM_ERASEBKGND: + begin + CallDefaultProc(Message); + Exit; + end; + + CN_CTLCOLORMSGBOX .. CN_CTLCOLORSTATIC: + begin + SetTextColor(Message.wParam, ColorToRGB(FontColor)); + SetBkColor(Message.wParam, ColorToRGB(Brush.Color)); + Message.Result := LRESULT(Brush.Handle); + end; + + CM_ENABLEDCHANGED: + begin + UpdateColors; + CallDefaultProc(Message); + end + else + inherited WndProc(Message); + end; +end; + +{ TSysComboBoxStyleHook } +constructor TSysComboBoxStyleHook.Create(AHandle: THandle); +begin + inherited; + if Style = csSimple then + OverrideEraseBkgnd := True; + FMouseOnButton := False; + FEditHandle := 0; + FListHandle := 0; + FListBoxInstance := nil; + FIgnoreStyleChanged := False; + FVSliderState := tsThumbBtnVertNormal; + FVUpState := tsArrowBtnUpNormal; + FVDownState := tsArrowBtnDownNormal; + FSliderSize := 0; + FListBoxTimerCode := 0; + FListBoxUpBtnDown := False; + FListBoxDownBtnDown := False; + FListBoxTrackUpDown := False; + FListBoxTrackDownDown := False; + OverrideFont := True; + UpdateColors; +end; + +destructor TSysComboBoxStyleHook.Destroy; +begin + if (FListHandle <> 0) and (FListBoxInstance <> nil) then + begin + SetWindowLong(FListHandle, GWL_WNDPROC, IntPtr(FDefListBoxProc)); + FreeObjectInstance(FListBoxInstance); + FListBoxInstance := nil; + end; + if FListBoxTimerCode <> 0 then + ListBoxStopTimer; + inherited; +end; + +procedure TSysComboBoxStyleHook.CNCommand(var Message: TWMCommand); +begin + if (Message.NotifyCode = CBN_SELENDCANCEL) or + (Message.NotifyCode = CBN_SELENDOK) or (Message.NotifyCode = CBN_CLOSEUP) or + (Message.NotifyCode = CBN_DROPDOWN) or (Message.NotifyCode = CBN_SELCHANGE) + then + begin + if FListBoxTimerCode <> 0 then + ListBoxStopTimer; + FMouseOnButton := False; + Invalidate; + end; +end; + +procedure TSysComboBoxStyleHook.CNDrawItem(var Message: TWMDrawItem); +begin + WMDrawItem(Message); + Handled := True; +end; + +procedure TSysComboBoxStyleHook.DrawItem(Canvas: TCanvas;const Index: UINT; + const R: TRect;const Selected: Boolean); +var + DIS: TDrawItemStruct; +begin + FillChar(DIS, SizeOf(DIS), 0); + DIS.CtlType := ODT_COMBOBOX; + DIS.CtlID := GetDlgCtrlID(Handle); + DIS.itemAction := ODA_DRAWENTIRE; + DIS.HDC := Canvas.Handle; + DIS.hwndItem := Handle; + DIS.rcItem := R; + DIS.itemID := Index; + DIS.itemData := SendMessage(FListHandle, LB_GETITEMDATA, 0, 0); + if Selected then + DIS.itemState := DIS.itemState or ODS_FOCUS or ODS_SELECTED; + + SendMessage(Handle, WM_DRAWITEM, Handle, LPARAM(@DIS)); +end; + +procedure TSysComboBoxStyleHook.DrawListBoxBorder; +var + R: TRect; + Canvas: TCanvas; + SaveIdx: Integer; + P: TPoint; +begin + Canvas := TCanvas.Create; + try + Canvas.Handle := GetWindowDC(FListHandle); + P := Point(0, 0); + ClientToScreen(FListHandle, P); + GetWindowRect(FListHandle, R); + P.X := P.X - R.Left; + P.Y := P.Y - R.Top; + if (R.Width < 5000) and (R.Height < 5000) then + begin + GetClientRect(FListHandle, R); + ExcludeClipRect(Canvas.Handle, P.X, P.Y, R.Right - R.Left + P.X, + R.Bottom - R.Top + P.Y); + GetWindowRect(FListHandle, R); + OffsetRect(R, -R.Left, -R.Top); + SaveIdx := SaveDC(Canvas.Handle); + try + PaintListBoxBorder(Canvas, R); + finally + RestoreDC(Canvas.Handle, SaveIdx); + end; + DrawListBoxVertScroll(Canvas.Handle); + end; + finally + ReleaseDC(FListHandle, Canvas.Handle); + Canvas.Handle := 0; + Canvas.Free; + end; +end; + +procedure TSysComboBoxStyleHook.DrawListBoxVertScroll(DC: HDC); +var + B: TBitmap; + Details: TThemedElementDetails; + Canvas: TCanvas; + R: TRect; +begin + if GetWindowLong(FListHandle, GWL_STYLE) and WS_VSCROLL = 0 then + Exit; + Canvas := TCanvas.Create; + try + if DC <> 0 then + Canvas.Handle := DC + else + Canvas.Handle := GetWindowDC(FListHandle); + if ListBoxVertScrollRect.Width > 0 then + begin + B := TBitmap.Create; + try + B.Width := ListBoxVertScrollRect.Width; + B.Height := ListBoxVertScrollRect.Height; + MoveWindowOrg(B.Canvas.Handle, -ListBoxVertScrollRect.Left, + -ListBoxVertScrollRect.Top); + + if StyleServices.Available then + begin + R := ListBoxVertScrollRect; + R.Top := ListBoxVertUpButtonRect.Bottom; + R.Bottom := ListBoxVertDownButtonRect.Top; + if R.Height > 0 then + begin + Details := StyleServices.GetElementDetails(tsUpperTrackVertNormal); + DrawStyleElement(B.Canvas.Handle, Details, R); + end; + Details := StyleServices.GetElementDetails(FVSliderState); + DrawStyleElement(B.Canvas.Handle, Details, + ListBoxVertSliderRect); + Details := StyleServices.GetElementDetails(FVUpState); + DrawStyleElement(B.Canvas.Handle, Details, + ListBoxVertUpButtonRect); + Details := StyleServices.GetElementDetails(FVDownState); + DrawStyleElement(B.Canvas.Handle, Details, + ListBoxVertDownButtonRect); + end; + + MoveWindowOrg(B.Canvas.Handle, ListBoxVertScrollRect.Left, + ListBoxVertScrollRect.Top); + Canvas.Draw(ListBoxVertScrollRect.Left, ListBoxVertScrollRect.Top, B); + finally + B.Free; + end; + end; + finally + if DC <> 0 then + Canvas.Handle := 0 + else + begin + ReleaseDC(FListHandle, Canvas.Handle); + Canvas.Handle := 0; + end; + Canvas.Free; + end; +end; + +function TSysComboBoxStyleHook.IsDroppedDown: Boolean; +begin + if Handle <> 0 then + Result := LongBool(SendMessage(Handle, CB_GETDROPPEDSTATE, 0, 0)) + else + Result := False; +end; + +function TSysComboBoxStyleHook.GetButtonRect: TRect; +begin + Result := SysControl.ClientRect; + InflateRect(Result, -2, -2); + if SysControl.BiDiMode <> bmRightToLeft then + Result.Left := Result.Right - GetSysMetrics(SM_CXVSCROLL) + 1 + else + Result.Right := Result.Left + GetSysMetrics(SM_CXVSCROLL) - 1; +end; + +procedure TSysComboBoxStyleHook.HookListBox(AListHandle: HWnd); +begin + if (AListHandle <> 0) and (FListBoxInstance = nil) then + begin + FListHandle := AListHandle; + FListBoxInstance := MakeObjectInstance(ListBoxWndProc); + FDefListBoxProc := Pointer(GetWindowLong(FListHandle, GWL_WNDPROC)); + SetWindowLong(FListHandle, GWL_WNDPROC, IntPtr(FListBoxInstance)); + end; +end; + +function TSysComboBoxStyleHook.IsChildHandle(AHandle: HWnd): Boolean; +begin + Result := (FEditHandle <> 0) and (FEditHandle = AHandle); + +end; + +function TSysComboBoxStyleHook.ListBoxBoundsRect: TRect; +begin + GetWindowRect(FListHandle, Result); +end; + +function TSysComboBoxStyleHook.ListBoxClientRect: TRect; +begin + GetClientRect(FListHandle, Result); +end; + +procedure TSysComboBoxStyleHook.ListBoxSetTimer(const ATimerCode: Integer); +begin + if FListBoxTimerCode <> 0 then + ListBoxStopTimer; + FListBoxTimerCode := ATimerCode; + if ATimerCode < 4 then + SetTimer(FListHandle, 1, 300, nil) + else + SetTimer(FListHandle, 1, 50, nil); +end; + +procedure TSysComboBoxStyleHook.ListBoxStopTimer; +begin + FListBoxTimerCode := -1; + KillTimer(FListHandle, 1); +end; + +function TSysComboBoxStyleHook.ListBoxVertDownButtonRect: TRect; +begin + Result := ListBoxVertScrollRect; + if Result.Width > 0 then + Result.Top := Result.Bottom - GetSysMetrics(SM_CYVTHUMB) + else + Result := TRect.Empty; +end; + +function TSysComboBoxStyleHook.ListBoxVertScrollArea: TRect; +begin + if GetWindowLong(FListHandle, GWL_STYLE) and WS_VSCROLL = 0 then + begin + Result := TRect.Empty; + Exit; + end; + Result := ListBoxBoundsRect; + OffsetRect(Result, -Result.Left, -Result.Top); + if SysControl.BiDiMode <> bmRightToLeft then + Result.Left := Result.Right - GetSysMetrics(SM_CYVSCROLL) - 1 + else + Result.Right := Result.Left + GetSysMetrics(SM_CYVSCROLL); +end; + +function TSysComboBoxStyleHook.ListBoxVertScrollRect: TRect; +begin + Result := ListBoxBoundsRect; + OffsetRect(Result, -Result.Left, -Result.Top); + InflateRect(Result, -1, -1); + OffsetRect(Result, 1, 1); + if SysControl.BiDiMode <> TBidiModeDirection.bmRightToLeft then + Result.Left := Result.Right - GetSysMetrics(SM_CXVSCROLL) + else + Result.Right := Result.Left + GetSysMetrics(SM_CXVSCROLL); + if ListBoxBoundsRect.Height > 30 then OffsetRect(Result, -1, -1); + +end; + +function TSysComboBoxStyleHook.ListBoxVertSliderRect: TRect; +var + i, LVisibleHeight, LTotalHeight, LSize, LTotalSize, LFinalHeight, LItemHeight, + LBoundsHeight, LBorderHeight: Integer; +begin + Result := ListBoxVertScrollRect; + Result.Top := ListBoxVertUpButtonRect.Bottom; + Result.Bottom := ListBoxVertDownButtonRect.Top; + LSize := Result.Bottom - Result.Top; + LTotalSize := SendMessage(FListHandle, LB_GETCOUNT, 0, 0) * LSize; + if LTotalSize = 0 then + Exit; + Result.Top := Result.Top + Round((SendMessage(FListHandle, LB_GETTOPINDEX, 0, + 0) / SendMessage(FListHandle, LB_GETCOUNT, 0, 0)) * LSize); + + LTotalHeight := 1; + FInvsibleCount := 0; + LBoundsHeight := ListBoxBoundsRect.Height; + for i := 0 to SendMessage(FListHandle, LB_GETCOUNT, 0, 0) - 1 do + begin + LItemHeight := SendMessage(FListHandle, LB_GETITEMHEIGHT, i, 0); + LTotalHeight := LTotalHeight + LItemHeight; + if (LTotalHeight > LBoundsHeight) and (FInvsibleCount = 0) then + FInvsibleCount := SendMessage(FListHandle, LB_GETCOUNT, 0, 0) - i; + end; + + LVisibleHeight := 0; + for i := SendMessage(FListHandle, LB_GETTOPINDEX, 0, 0) + to SendMessage(FListHandle, LB_GETCOUNT, 0, 0) - 1 do + begin + LVisibleHeight := LVisibleHeight + SendMessage(FListHandle, + LB_GETITEMHEIGHT, i, 0); + if Style <> csSimple then + LBorderHeight := 2 + else + LBorderHeight := 4; + if LVisibleHeight >= ListBoxBoundsRect.Height - LBorderHeight then + Break; + end; + + Result.Bottom := Result.Top + Round((LVisibleHeight / LTotalHeight) * LSize); + if (i = SendMessage(FListHandle, LB_GETCOUNT, 0, 0) - 1) and + (Result.Bottom <> ListBoxVertDownButtonRect.Top) then + begin + LFinalHeight := Result.Height; + Result.Bottom := ListBoxVertDownButtonRect.Top; + Result.Top := Result.Bottom - LFinalHeight; + end; + FSliderSize := Round((LVisibleHeight / LTotalHeight) * LSize); +end; + +function TSysComboBoxStyleHook.ListBoxVertTrackRect: TRect; +begin + Result := ListBoxVertScrollRect; + if Result.Width > 0 then + begin + Result.Top := Result.Top + GetSysMetrics(SM_CYVTHUMB); + Result.Bottom := Result.Bottom - GetSysMetrics(SM_CYVTHUMB); + end + else + Result := TRect.Empty; +end; + +function TSysComboBoxStyleHook.ListBoxVertTrackRectDown: TRect; +begin + Result := ListBoxVertTrackRect; + if (Result.Width > 0) and (ListBoxVertSliderRect.Height > 0) then + Result.Top := ListBoxVertSliderRect.Bottom; +end; + +function TSysComboBoxStyleHook.ListBoxVertTrackRectUp: TRect; +begin + Result := ListBoxVertTrackRect; + if (Result.Width > 0) and (ListBoxVertSliderRect.Height > 0) then + Result.Bottom := ListBoxVertSliderRect.Top; +end; + +function TSysComboBoxStyleHook.ListBoxVertUpButtonRect: TRect; +begin + Result := ListBoxVertScrollRect; + if Result.Width > 0 then + Result.Top := Result.Bottom - GetSysMetrics(SM_CYVTHUMB) + else + Result := TRect.Empty; +end; + +procedure TSysComboBoxStyleHook.ListBoxWndProc(var Msg: TMessage); +var + MsgHandled: Boolean; + + procedure WMNCCalcSize(var Msg: TWMNCCalcSize); + var + LCalcSizeParams: PNCCalcSizeParams; + LWindowPos: PWindowPos; + LLeft, LRight, LTop, LBottom: Integer; + LStyle, LNewStyle: Integer; + begin + LStyle := GetWindowLong(FListHandle, GWL_STYLE); + if ((LStyle and WS_VSCROLL = WS_VSCROLL) or + (LStyle and WS_HSCROLL = WS_HSCROLL)) then + begin + LNewStyle := LStyle and not WS_VSCROLL and not WS_HSCROLL; + FIgnoreStyleChanged := True; + SetWindowLong(FListHandle, GWL_STYLE, LNewStyle); + Msg.Result := CallDefaultListBoxProc(TMessage(Msg)); + SetWindowLong(FListHandle, GWL_STYLE, LStyle); + FIgnoreStyleChanged := False; + end + else + Msg.Result := CallDefaultListBoxProc(TMessage(Msg)); + + if (Msg.CalcValidRects) then + begin + LCalcSizeParams := Msg.CalcSize_Params; + if SysControl.BiDiMode <> bmRightToLeft then + begin + LLeft := 1; + if LStyle and WS_VSCROLL = WS_VSCROLL then + LRight := ListBoxVertScrollRect.Width + 1 + else + LRight := 1; + end + else + begin + LRight := 1; + if LStyle and WS_VSCROLL = WS_VSCROLL then + LLeft := ListBoxVertScrollRect.Width + 1 + else + LLeft := 1; + end; + + LTop := 1; + LBottom := 1; + LWindowPos := LCalcSizeParams.lppos; + with LCalcSizeParams^.rgrc[0] do + begin + Left := LWindowPos^.X; + Top := LWindowPos^.Y; + Right := LWindowPos^.X + LWindowPos^.cx; + Bottom := LWindowPos^.Y + LWindowPos^.cy; + Left := Left + LLeft; + Top := Top + LTop; + Right := Right - LRight; + Bottom := Bottom - LBottom; + end; + LCalcSizeParams^.rgrc[1] := LCalcSizeParams^.rgrc[0]; + Msg.CalcSize_Params := LCalcSizeParams; + Msg.Result := WVR_VALIDRECTS; + end; + Msg.Result := 0; + MsgHandled := True; + end; + + procedure WMMouseWheel(var Msg: TWMMouseWheel); + var + Index: Integer; + R: TRect; + begin + SendMessage(FListHandle, WM_SETREDRAW, 0, 0); + Index := SendMessage(FListHandle, LB_GETTOPINDEX, 0, 0); + if Msg.WheelDelta < 0 then + Inc(Index) + else + Dec(Index); + SendMessage(FListHandle, LB_SETTOPINDEX, Index, 0); + SendMessage(FListHandle, WM_SETREDRAW, 1, 0); + R := Rect(0, 0, ListBoxBoundsRect.Width, ListBoxBoundsRect.Height); + RedrawWindow(FListHandle, @R, 0, RDW_INVALIDATE or RDW_ERASE); + DrawListBoxVertScroll(0); + MsgHandled := True; + end; + + procedure WMNCLButtonDblClk(var Msg: TWMMouse); + var + R: TRect; + P: TPoint; + begin + P := Point(Msg.XPos, Msg.YPos); + if ListBoxVertScrollArea.Contains(P) then + begin + if ListBoxVertUpButtonRect.Contains(Point(Msg.XPos, Msg.YPos)) then + begin + SendMessage(FListHandle, WM_SETREDRAW, 0, 0); + SendMessage(FListHandle, LB_SETTOPINDEX, SendMessage(FListHandle, + LB_GETTOPINDEX, 0, 0) - 1, 0); + SendMessage(FListHandle, WM_SETREDRAW, 1, 0); + R := Rect(0, 0, ListBoxBoundsRect.Width, ListBoxBoundsRect.Height); + RedrawWindow(FListHandle, @R, 0, RDW_INVALIDATE or RDW_ERASE); + DrawListBoxVertScroll(0); + Exit; + end; + + if ListBoxVertDownButtonRect.Contains(Point(Msg.XPos, Msg.YPos)) then + begin + SendMessage(FListHandle, WM_SETREDRAW, 0, 0); + SendMessage(FListHandle, LB_SETTOPINDEX, SendMessage(FListHandle, + LB_GETTOPINDEX, 0, 0) + 1, 0); + SendMessage(FListHandle, WM_SETREDRAW, 1, 0); + R := Rect(0, 0, ListBoxBoundsRect.Width, ListBoxBoundsRect.Height); + RedrawWindow(FListHandle, @R, 0, RDW_INVALIDATE or RDW_ERASE); + DrawListBoxVertScroll(0); + Exit; + end; + end; + MsgHandled := True; + end; + + procedure WMLButtonDown(var Msg: TWMMouse); + var + P: TPoint; + R: TRect; + ItemHeight, VisibleCount, TopIndex: Integer; + begin + MsgHandled := False; + P := Point(Msg.XPos, Msg.YPos); + if SysControl.BiDiMode = bmRightToLeft then + P.X := -P.X; + FDownPos := P; + if ListBoxVertScrollArea.Contains(P) then + begin + if Style = csSimple then + SetCapture(FListHandle); + FDownPos := P; + if ListBoxVertTrackRectUp.Contains(P) then + begin + ItemHeight := SendMessage(FListHandle, LB_GETITEMHEIGHT, 0, 0); + if ItemHeight > 0 then + VisibleCount := ListBoxClientRect.Height div ItemHeight + else + VisibleCount := 0; + TopIndex := SendMessage(FListHandle, LB_GETTOPINDEX, 0, 0) - + VisibleCount + 1; + if TopIndex < 0 then + TopIndex := 0; + SendMessage(FListHandle, WM_SETREDRAW, 0, 0); + SendMessage(FListHandle, LB_SETTOPINDEX, TopIndex, 0); + SendMessage(FListHandle, WM_SETREDRAW, 1, 0); + R := Rect(0, 0, ListBoxBoundsRect.Width, ListBoxBoundsRect.Height); + RedrawWindow(FListHandle, @R, 0, RDW_INVALIDATE or RDW_ERASE); + DrawListBoxVertScroll(0); + ListBoxSetTimer(3); + end + else if ListBoxVertTrackRectDown.Contains(P) then + begin + ItemHeight := SendMessage(FListHandle, LB_GETITEMHEIGHT, 0, 0); + if ItemHeight > 0 then + VisibleCount := ListBoxClientRect.Height div ItemHeight + else + VisibleCount := 0; + TopIndex := SendMessage(FListHandle, LB_GETTOPINDEX, 0, 0) + + VisibleCount - 1; + SendMessage(FListHandle, WM_SETREDRAW, 0, 0); + SendMessage(FListHandle, LB_SETTOPINDEX, TopIndex, 0); + SendMessage(FListHandle, WM_SETREDRAW, 1, 0); + R := Rect(0, 0, ListBoxBoundsRect.Width, ListBoxBoundsRect.Height); + RedrawWindow(FListHandle, @R, 0, RDW_INVALIDATE or RDW_ERASE); + DrawListBoxVertScroll(0); + ListBoxSetTimer(4); + end + else if ListBoxVertSliderRect.Contains(P) then + begin + FVSliderState := tsThumbBtnVertPressed; + FDownSliderPos := FDownPos.Y - ListBoxVertSliderRect.Top; + DrawListBoxVertScroll(0); + end + else if ListBoxVertDownButtonRect.Contains(P) then + begin + FListBoxDownBtnDown := True; + FVDownState := tsArrowBtnDownPressed; + DrawListBoxVertScroll(0); + + SendMessage(FListHandle, WM_SETREDRAW, 0, 0); + SendMessage(FListHandle, LB_SETTOPINDEX, SendMessage(FListHandle, + LB_GETTOPINDEX, 0, 0) + 1, 0); + SendMessage(FListHandle, WM_SETREDRAW, 1, 0); + R := Rect(0, 0, ListBoxBoundsRect.Width, ListBoxBoundsRect.Height); + RedrawWindow(FListHandle, @R, 0, RDW_INVALIDATE or RDW_ERASE); + + ListBoxSetTimer(2); + end + else if ListBoxVertUpButtonRect.Contains(P) then + begin + FListBoxUpBtnDown := True; + FVUpState := tsArrowBtnUpPressed; + DrawListBoxVertScroll(0); + + SendMessage(FListHandle, WM_SETREDRAW, 0, 0); + SendMessage(FListHandle, LB_SETTOPINDEX, SendMessage(FListHandle, + LB_GETTOPINDEX, 0, 0) - 1, 0); + SendMessage(FListHandle, WM_SETREDRAW, 1, 0); + R := Rect(0, 0, ListBoxBoundsRect.Width, ListBoxBoundsRect.Height); + RedrawWindow(FListHandle, @R, 0, RDW_INVALIDATE or RDW_ERASE); + + ListBoxSetTimer(1); + end; + MsgHandled := True; + end + else + begin + if (FVSliderState <> tsThumbBtnVertNormal) or + (FVUpState <> tsArrowBtnUpNormal) or + (FVDownState <> tsArrowBtnDownNormal) then + begin + FVSliderState := tsArrowBtnUpNormal; + FVUpState := tsArrowBtnUpNormal; + FVDownState := tsArrowBtnDownNormal; + DrawListBoxVertScroll(0); + end; + end; + FOldIdx := SendMessage(FListHandle, LB_GETTOPINDEX, 0, 0); + end; + + procedure WMMouseMove(var Msg: TWMMouse); + var + P: TPoint; + NewIndex, Index: Integer; + Dist: Integer; + R: TRect; + begin + P := Point(Msg.XPos, Msg.YPos); + if SysControl.BiDiMode = bmRightToLeft then + P.X := -P.X; + + FMovePos := P; + if (FVSliderState = tsThumbBtnVertPressed) then + begin + Index := SendMessage(FListHandle, LB_GETTOPINDEX, 0, 0); + Dist := (ListBoxVertScrollRect.Height - ListBoxVertUpButtonRect.Height - + ListBoxVertDownButtonRect.Height - ListBoxVertSliderRect.Height); + if Dist > 0 then + begin + NewIndex := + Round((((FMovePos.Y - FDownSliderPos - ListBoxVertUpButtonRect.Bottom) + / Dist) * FInvsibleCount)); + if NewIndex <> Index then + begin + if NewIndex < 0 then + NewIndex := 0; + if NewIndex >= SendMessage(FListHandle, LB_GETCOUNT, 0, 0) then + NewIndex := SendMessage(FListHandle, LB_GETCOUNT, 0, 0) - 1; + SendMessage(FListHandle, WM_SETREDRAW, 0, 0); + SendMessage(FListHandle, LB_SETTOPINDEX, NewIndex, 0); + SendMessage(FListHandle, WM_SETREDRAW, 1, 0); + R := Rect(0, 0, ListBoxBoundsRect.Width, ListBoxBoundsRect.Height); + RedrawWindow(FListHandle, @R, 0, RDW_INVALIDATE or RDW_ERASE); + DrawListBoxVertScroll(0); + end; + end; + MsgHandled := True; + Exit; + end; + + if FListBoxUpBtnDown and not ListBoxVertUpButtonRect.Contains(P) and + (FVUpState = tsArrowBtnUpPressed) then + begin + FVUpState := tsArrowBtnUpNormal; + DrawListBoxVertScroll(0); + ListBoxStopTimer; + Exit; + end; + + if FListBoxUpBtnDown and ListBoxVertUpButtonRect.Contains(P) and + (FVUpState = tsArrowBtnUpNormal) then + begin + FVUpState := tsArrowBtnUpPressed; + DrawListBoxVertScroll(0); + ListBoxSetTimer(5); + Exit; + end; + + if FListBoxDownBtnDown and not ListBoxVertDownButtonRect.Contains(P) and + (FVDownState = tsArrowBtnDownPressed) then + begin + FVDownState := tsArrowBtnDownNormal; + DrawListBoxVertScroll(0); + ListBoxStopTimer; + Exit; + end; + + if FListBoxDownBtnDown and ListBoxVertDownButtonRect.Contains(P) and + (FVDownState = tsArrowBtnDownNormal) then + begin + FVDownState := tsArrowBtnDownPressed; + DrawListBoxVertScroll(0); + ListBoxSetTimer(6); + Exit; + end; + + if ListBoxVertScrollArea.Contains(P) then + begin + if ListBoxVertSliderRect.Contains(P) and + (FVSliderState = tsThumbBtnVertNormal) then + begin + FVSliderState := tsThumbBtnVertHot; + DrawListBoxVertScroll(0); + end + else if not ListBoxVertSliderRect.Contains(P) and + (FVSliderState = tsThumbBtnVertHot) then + begin + FVSliderState := tsThumbBtnVertNormal; + DrawListBoxVertScroll(0); + end + else if ListBoxVertUpButtonRect.Contains(P) and + (FVUpState = tsArrowBtnUpNormal) then + begin + FVUpState := tsArrowBtnUpHot; + DrawListBoxVertScroll(0); + end + else if not ListBoxVertUpButtonRect.Contains(P) and + (FVUpState = tsArrowBtnUpHot) then + begin + FVUpState := tsArrowBtnUpNormal; + DrawListBoxVertScroll(0); + end + else if ListBoxVertDownButtonRect.Contains(P) and + (FVDownState = tsArrowBtnDownNormal) then + begin + FVDownState := tsArrowBtnDownHot; + DrawListBoxVertScroll(0); + end + else if not ListBoxVertDownButtonRect.Contains(P) and + (FVDownState = tsArrowBtnDownHot) then + begin + FVDownState := tsArrowBtnDownNormal; + DrawListBoxVertScroll(0); + end; + MsgHandled := True; + end + else + begin + if (FVSliderState <> tsThumbBtnVertNormal) or + (FVUpState <> tsArrowBtnUpNormal) or (FVUpState <> tsArrowBtnDownNormal) + then + begin + if FListBoxTimerCode <> 0 then + ListBoxStopTimer; + FVSliderState := tsThumbBtnVertNormal; + FVUpState := tsArrowBtnUpNormal; + FVDownState := tsArrowBtnDownNormal; + DrawListBoxVertScroll(0); + end; + end; + end; + + procedure WMLButtonUp(var Msg: TWMMouse); + var + P: TPoint; + begin + FListBoxUpBtnDown := False; + FListBoxDownBtnDown := False; + FListBoxTrackUpDown := False; + FListBoxTrackDownDown := False; + + P := Point(Msg.XPos, Msg.YPos); + if SysControl.BiDiMode = bmRightToLeft then + P.X := -P.X; + + if (Style = csSimple) and ListBoxVertScrollArea.Contains(FDownPos) then + ReleaseCapture; + + if ListBoxVertSliderRect.Contains(P) then + FVSliderState := tsThumbBtnVertHot + else + FVSliderState := tsThumbBtnVertNormal; + + if ListBoxVertUpButtonRect.Contains(P) then + FVUpState := tsArrowBtnUpHot + else + FVUpState := tsArrowBtnUpNormal; + + if ListBoxVertDownButtonRect.Contains(P) then + FVDownState := tsArrowBtnDownHot + else + FVDownState := tsArrowBtnDownNormal; + + DrawListBoxVertScroll(0); + + if FListBoxTimerCode <> 0 then + ListBoxStopTimer; + + MsgHandled := ListBoxVertScrollArea.Contains(P); + end; + + procedure WMNCLButtonDown(var Msg: TWMMouse); + var + P: TPoint; + begin + if Style <> csSimple then + SetCapture(FListHandle); + P := Point(Msg.XPos, Msg.YPos); + ScreenToClient(FListHandle, P); + with P do + begin + Msg.XPos := X; + Msg.YPos := Y; + end; + WMLButtonDown(Msg); + MsgHandled := True; + end; + + procedure WMPrint(var Msg: TMessage); + var + SaveIndex: Integer; + Canvas: TCanvas; + R: TRect; + begin + Msg.Result := CallDefaultListBoxProc(Msg); + + if (Msg.LPARAM and PRF_NONCLIENT = PRF_NONCLIENT) and (Msg.wParam > 0) then + begin + SaveIndex := 0; + Canvas := TCanvas.Create; + try + SaveIndex := SaveDC(Msg.wParam); + Canvas.Handle := Msg.wParam; + GetWindowRect(FListHandle, R); + OffsetRect(R, -R.Left, -R.Top); + ExcludeClipRect(Canvas.Handle, R.Left + 2, R.Top + 2, R.Right - 2, + R.Bottom - 2); + PaintListBoxBorder(Canvas, R); + finally + if SaveIndex <> 0 then + RestoreDC(Canvas.Handle, SaveIndex); + Canvas.Handle := 0; + Canvas.Free; + end; + DrawListBoxVertScroll(Msg.wParam); + end; + MsgHandled := True; + end; + + procedure WMTimer(var Msg: TMessage); + var + R: TRect; + ItemHeight, VisibleCount, TopIndex: Integer; + begin + case FListBoxTimerCode of + 1: + ListBoxSetTimer(5); + 2: + ListBoxSetTimer(6); + 3: + ListBoxSetTimer(7); + 4: + ListBoxSetTimer(8); + 5: + begin + SendMessage(FListHandle, WM_SETREDRAW, 0, 0); + SendMessage(FListHandle, LB_SETTOPINDEX, + SendMessage(FListHandle, LB_GETTOPINDEX, 0, 0) - 1, 0); + SendMessage(FListHandle, WM_SETREDRAW, 1, 0); + R := Rect(0, 0, ListBoxBoundsRect.Width, ListBoxBoundsRect.Height); + RedrawWindow(FListHandle, @R, 0, RDW_INVALIDATE or RDW_ERASE); + DrawListBoxVertScroll(0); + end; + 6: + begin + SendMessage(FListHandle, WM_SETREDRAW, 0, 0); + SendMessage(FListHandle, LB_SETTOPINDEX, + SendMessage(FListHandle, LB_GETTOPINDEX, 0, 0) + 1, 0); + SendMessage(FListHandle, WM_SETREDRAW, 1, 0); + R := Rect(0, 0, ListBoxBoundsRect.Width, ListBoxBoundsRect.Height); + RedrawWindow(FListHandle, @R, 0, RDW_INVALIDATE or RDW_ERASE); + DrawListBoxVertScroll(0); + end; + 7: + begin + if ListBoxVertSliderRect.Contains(FMovePos) or + (FMovePos.Y > ListBoxVertSliderRect.Bottom) then + begin + ListBoxStopTimer; + Exit; + end; + ItemHeight := SendMessage(FListHandle, LB_GETITEMHEIGHT, 0, 0); + if ItemHeight > 0 then + VisibleCount := ListBoxClientRect.Height div ItemHeight + else + VisibleCount := 0; + TopIndex := SendMessage(FListHandle, LB_GETTOPINDEX, 0, 0) - + VisibleCount + 1; + if TopIndex < 0 then + TopIndex := 0; + SendMessage(FListHandle, WM_SETREDRAW, 0, 0); + SendMessage(FListHandle, LB_SETTOPINDEX, TopIndex, 0); + SendMessage(FListHandle, WM_SETREDRAW, 1, 0); + R := Rect(0, 0, ListBoxBoundsRect.Width, ListBoxBoundsRect.Height); + RedrawWindow(FListHandle, @R, 0, RDW_INVALIDATE or RDW_ERASE); + DrawListBoxVertScroll(0); + end; + 8: + begin + if ListBoxVertSliderRect.Contains(FMovePos) or + (FMovePos.Y < ListBoxVertSliderRect.Top) then + begin + ListBoxStopTimer; + Exit; + end; + ItemHeight := SendMessage(FListHandle, LB_GETITEMHEIGHT, 0, 0); + if ItemHeight > 0 then + VisibleCount := ListBoxClientRect.Height div ItemHeight + else + VisibleCount := 0; + TopIndex := SendMessage(FListHandle, LB_GETTOPINDEX, 0, 0) + + VisibleCount - 1; + SendMessage(FListHandle, WM_SETREDRAW, 0, 0); + SendMessage(FListHandle, LB_SETTOPINDEX, TopIndex, 0); + SendMessage(FListHandle, WM_SETREDRAW, 1, 0); + R := Rect(0, 0, ListBoxBoundsRect.Width, ListBoxBoundsRect.Height); + RedrawWindow(FListHandle, @R, 0, RDW_INVALIDATE or RDW_ERASE); + DrawListBoxVertScroll(0); + end; + end; + end; + +begin + + MsgHandled := False; + if ListBoxVertScrollArea.Height = 0 then + begin + case Msg.Msg of + WM_NCCALCSIZE: + WMNCCalcSize(TWMNCCalcSize(Msg)); + WM_NCPAINT: + begin + DrawListBoxBorder; + MsgHandled := True; + end; + end; + end + else + case Msg.Msg of + WM_NCHITTEST: + if Style = csSimple then + begin + Msg.Result := HTCLIENT; + MsgHandled := True; + end; + WM_MOUSELEAVE, WM_NCMOUSELEAVE: + if Style = csSimple then + begin + FVSliderState := tsThumbBtnVertNormal; + FVUpState := tsArrowBtnUpNormal; + FVDownState := tsArrowBtnDownNormal; + DrawListBoxVertScroll(0); + end; + WM_TIMER: + WMTimer(Msg); + WM_UpdateUIState: + MsgHandled := True; + WM_NCCALCSIZE: + WMNCCalcSize(TWMNCCalcSize(Msg)); + WM_MOUSEWHEEL: + WMMouseWheel(TWMMouseWheel(Msg)); + WM_NCLButtonDblClk: + WMNCLButtonDblClk(TWMMouse(Msg)); + WM_LBUTTONDOWN: + WMLButtonDown(TWMMouse(Msg)); + WM_MOUSEMOVE: + WMMouseMove(TWMMouse(Msg)); + WM_LBUTTONUP: + WMLButtonUp(TWMMouse(Msg)); + WM_NCLButtonDown: + WMNCLButtonDown(TWMMouse(Msg)); + WM_NCLButtonUp, WM_NCMouseMove: + MsgHandled := True; + WM_PRINT: + WMPrint(Msg); + WM_KEYDOWN, WM_KEYUP: + begin + Msg.Result := CallDefaultListBoxProc(Msg); + DrawListBoxVertScroll(0); + MsgHandled := True; + end; + WM_NCPAINT: + begin + DrawListBoxBorder; + DrawListBoxVertScroll(0); + MsgHandled := True; + end; + LB_SETTOPINDEX: + begin + Msg.Result := CallDefaultListBoxProc(Msg); + DrawListBoxVertScroll(0); + MsgHandled := True; + end; + WM_STYLECHANGED, WM_STYLECHANGING: + if FIgnoreStyleChanged then + begin + Msg.Result := 0; + MsgHandled := True; + end; + + end; + if not MsgHandled then + Msg.Result := CallDefaultListBoxProc(Msg); +end; + +function TSysComboBoxStyleHook.CallDefaultListBoxProc(var Msg: TMessage): LRESULT; +begin + Result := 0; + try + if (FDefListBoxProc <> nil) then + Result := CallWindowProc(FDefListBoxProc, FListHandle, Msg.Msg, Msg.wParam, Msg.lParam); + except + on e: exception do + OutputDebugString(PWideChar('CallDefaultListBoxProc error: ' + e.message + chr(0))); + end; +end; + +procedure TSysComboBoxStyleHook.MouseEnter; +begin + inherited; + Invalidate; +end; + +procedure TSysComboBoxStyleHook.MouseLeave; +begin + inherited; + if not DroppedDown and FMouseOnButton then + begin + FMouseOnButton := False; + Invalidate; + end +end; + +procedure TSysComboBoxStyleHook.PaintBorder(Canvas: TCanvas); +var + R, ControlRect, EditRect, ListRect: TRect; + DrawState: TThemedComboBox; + BtnDrawState: TThemedComboBox; + Details: TThemedElementDetails; + Buffer: TBitmap; +begin + if not StyleServices.Available then + Exit; + + if not SysControl.Enabled then + BtnDrawState := tcDropDownButtonDisabled + else if DroppedDown then + BtnDrawState := tcDropDownButtonPressed + else if (FMouseOnButton and MouseInControl) then + BtnDrawState := tcDropDownButtonHot + else + BtnDrawState := tcDropDownButtonNormal; + + if not SysControl.Enabled then + DrawState := tcBorderDisabled + else if SysControl.Focused then + DrawState := tcBorderFocused + else if MouseInControl then + DrawState := tcBorderHot + else + DrawState := tcBorderNormal; + + Buffer := TBitmap.Create; + Buffer.SetSize(SysControl.Width, SysControl.Height); + try + R := Rect(0, 0, Buffer.Width, Buffer.Height); + // draw border + client in buffer + Details := StyleServices.GetElementDetails(DrawState); + if (Style = csSimple) and (FListHandle <> 0) then + begin + GetWindowRect(FListHandle, ListRect); + GetWindowRect(Handle, ControlRect); + R.Bottom := ListRect.Top - ControlRect.Top; + DrawStyleElement(Buffer.Canvas.Handle, Details, R); + R := Rect(0, SysControl.Height - (ControlRect.Bottom - ListRect.Bottom), + SysControl.Width, SysControl.Height); + with Buffer.Canvas do + begin + Brush.Style := bsSolid; + Brush.Color := StyleServices.GetSystemColor(clBtnFace); + FillRect(R); + end; + R := Rect(0, 0, Buffer.Width, Buffer.Height); + R.Bottom := ListRect.Top - ControlRect.Top; + end + else + DrawStyleElement(Buffer.Canvas.Handle, Details, R); + + // if not (seClient in SysControl.StyleElements) and (FEditHandle = 0) then + // begin + // R := SysControl.ClientRect; + // InflateRect(R, -3, -3); + // R.Right := ButtonRect.Left - 2; + // with Buffer.Canvas do + // begin + // Brush.Color := TWinControlClass(Control).Color; + // FillRect(R); + // end; + // end; + // draw button in buffer + if Style <> csSimple then + begin + Details := StyleServices.GetElementDetails(BtnDrawState); + DrawStyleElement(Buffer.Canvas.Handle, Details, ButtonRect); + end; + // calculation of exclude area for drawing buffer + if (SendMessage(Handle, CB_GETCURSEL, 0, 0) >= 0) and (FEditHandle = 0) then + begin + R := SysControl.ClientRect; + InflateRect(R, -3, -3); + R.Right := ButtonRect.Left - 2; + ExcludeClipRect(Canvas.Handle, R.Left, R.Top, R.Right, R.Bottom); + end + else if FEditHandle <> 0 then + begin + GetWindowRect(Handle, R); + GetWindowRect(FEditHandle, EditRect); + OffsetRect(EditRect, -R.Left, -R.Top); + with EditRect do + ExcludeClipRect(Canvas.Handle, Left, Top, Right, Bottom); + end; + // draw buffer + Canvas.Draw(0, 0, Buffer); + finally + Buffer.Free; + end; +end; + +procedure TSysComboBoxStyleHook.PaintListBoxBorder(Canvas: TCanvas; + const R: TRect); +begin + with Canvas do + begin + Brush.Color := StyleServices.GetSystemColor(clWindowFrame); + FillRect(R); + end; +end; + +function TSysComboBoxStyleHook.Style: TComboBoxStyle; +const + ComboBoxStyles: array [TComboBoxStyle] of DWORD = (CBS_DROPDOWN, CBS_SIMPLE, + CBS_DROPDOWNLIST, CBS_DROPDOWNLIST or CBS_OWNERDRAWFIXED, + CBS_DROPDOWNLIST or CBS_OWNERDRAWVARIABLE); +var + LStyle: Cardinal; +begin + if Handle <> 0 then + begin + LStyle := GetWindowLong(Handle, GWL_STYLE); + Result := csDropDown; + if LStyle and ComboBoxStyles[csDropDown] = ComboBoxStyles[csDropDown] then + Result := csDropDown; + if LStyle and ComboBoxStyles[csSimple] = ComboBoxStyles[csSimple] then + Result := csSimple; + if LStyle and ComboBoxStyles[csDropDownList] = ComboBoxStyles[csDropDownList] + then + Result := csDropDownList; + if LStyle and ComboBoxStyles[csOwnerDrawFixed] = ComboBoxStyles + [csOwnerDrawFixed] then + Result := csOwnerDrawFixed; + if LStyle and ComboBoxStyles[csOwnerDrawVariable] = ComboBoxStyles + [csOwnerDrawVariable] then + Result := csOwnerDrawVariable; + end + else + Result := csDropDown; +end; +{$HINTS OFF} + +procedure TSysComboBoxStyleHook.UpdateColors; +const + ColorStates: array [Boolean] of TStyleColor = (scComboBoxDisabled, + scComboBox); + FontColorStates: array [Boolean] of TStyleFont = (sfComboBoxItemDisabled, + sfComboBoxItemNormal); +var + LStyle: TCustomStyleServices; +begin + LStyle := StyleServices; + Color := StyleServices.GetStyleColor(ColorStates[SysControl.Enabled]); +{$IF CompilerVersion > 23} + if OverrideFont then + FontColor := StyleServices.GetStyleFontColor(FontColorStates[True]) + else + FontColor := clWindowText; +{$ELSE} + FontColor := StyleServices.GetStyleFontColor + (FontColorStates[SysControl.Enabled]); + Brush.Color := LStyle.GetStyleColor(ColorStates[SysControl.Enabled]); +{$IFEND} +end; +{$HINTS ON} + +procedure TSysComboBoxStyleHook.WMCommand(var Message: TWMCommand); +begin + if (Message.NotifyCode = CBN_SELENDCANCEL) or + (Message.NotifyCode = CBN_SELENDOK) or (Message.NotifyCode = CBN_CLOSEUP) or + (Message.NotifyCode = CBN_DROPDOWN) or (Message.NotifyCode = CBN_SELCHANGE) + then + begin + if FListBoxTimerCode <> 0 then + ListBoxStopTimer; + FMouseOnButton := False; + Invalidate; + end; +end; + +procedure TSysComboBoxStyleHook.WMDrawItem(var Message: TWMDrawItem); +begin + CallDefaultProc(TMessage(Message)); + Handled := True; +end; + +procedure TSysComboBoxStyleHook.WMMouseMove(var Message: TWMMouse); +var + P: TPoint; + R: TRect; + FOldMouseOnButton: Boolean; +begin + CallDefaultProc(TMessage(Message)); + inherited; + + P := Point(Message.XPos, Message.YPos); + FOldMouseOnButton := FMouseOnButton; + R := ButtonRect; + if R.Contains(P) then + FMouseOnButton := True + else + FMouseOnButton := False; + + if FOldMouseOnButton <> FMouseOnButton then + InvalidateRect(Handle, @R, False); + + Handled := True; +end; + +procedure TSysComboBoxStyleHook.WMPaint(var Message: TMessage); +var + R: TRect; + Canvas: TCanvas; + PS: TPaintStruct; + SaveIndex: Integer; + DC: HDC; + //LItemIndex: UINT; + LDetails: TThemedElementDetails; +begin + DC := Message.wParam; + Canvas := TCanvas.Create; + try + if DC = 0 then + Canvas.Handle := BeginPaint(Handle, PS) + else + Canvas.Handle := DC; + + SaveIndex := SaveDC(Canvas.Handle); + try + PaintBorder(Canvas); + finally + RestoreDC(Canvas.Handle, SaveIndex); + end; + + if (Style <> csSimple) and (FEditHandle = 0) then + begin + R := SysControl.ClientRect; + InflateRect(R, -3, -3); + if SysControl.BiDiMode <> bmRightToLeft then + R.Right := ButtonRect.Left - 1 + else + R.Left := ButtonRect.Right + 1; + SaveIndex := SaveDC(Canvas.Handle); + try + IntersectClipRect(Canvas.Handle, R.Left, R.Top, R.Right, R.Bottom); + //LItemIndex := UINT(SendMessage(SysControl.Handle, CB_GETCURSEL, 0, 0)); + Canvas.Brush.Color := StyleServices.GetSystemColor(clWindow); + Canvas.FillRect(R); + if (SysControl.Style and CBS_OWNERDRAWFIXED = CBS_OWNERDRAWFIXED) or + (SysControl.Style and CBS_OWNERDRAWVARIABLE = CBS_OWNERDRAWVARIABLE) + then + begin + //DrawItem(Canvas, LItemIndex, R, Focused); + LDetails := StyleServices.GetElementDetails(TThemedComboBox.tcComboBoxDontCare); + {$IF (CompilerVersion >= 33)} + if Assigned(Application.Mainform) then + Canvas.Font.Size := Round(Font.Size * Application.MainForm.Monitor.PixelsPerInch / Screen.PixelsPerInch) + else + Canvas.Font.Size := Font.Size; + {$ENDIF} + DrawText(Canvas.Handle, LDetails, SysControl.Text, R, + [tfLeft, tfVerticalCenter, tfSingleLine]); + end + else + begin + LDetails := StyleServices.GetElementDetails(TThemedComboBox.tcComboBoxDontCare); + {$IF (CompilerVersion >= 33)} + if Assigned(Application.Mainform) then + Canvas.Font.Size := Round(Font.Size * Application.MainForm.Monitor.PixelsPerInch / Screen.PixelsPerInch) + else + Canvas.Font.Size := Font.Size; + {$ENDIF} + DrawText(Canvas.Handle, LDetails, SysControl.Text, R, + [tfLeft, tfVerticalCenter, tfSingleLine]); + end; + finally + RestoreDC(Canvas.Handle, SaveIndex); + end; + end; + + finally + Canvas.Handle := 0; + Canvas.Free; + if DC = 0 then + EndPaint(Handle, PS); + end; + Handled := True; +end; + +procedure TSysComboBoxStyleHook.WMParentNotify(var Message: TMessage); +begin + if (FListHandle = 0) and (LoWord(Message.wParam) = WM_CREATE) then + begin + if (Message.LPARAM <> 0) and (FListBoxInstance = nil) then + HookListBox(Message.LPARAM); + end + else if (FEditHandle = 0) and (LoWord(Message.wParam) = WM_CREATE) then + FEditHandle := Message.LPARAM; +end; + +procedure TSysComboBoxStyleHook.WndProc(var Message: TMessage); +const + States: array [Boolean] of TStyleColor = (scEditDisabled, scComboBox); +begin + case Message.Msg of + + CB_SETCURSEL, WM_KILLFOCUS: + begin + SetRedraw(False); // do not allow default drawing . + CallDefaultProc(Message); + SetRedraw(True); // allow vcl style drawing . + Invalidate; + Exit; + end; + + WM_CTLCOLORMSGBOX .. WM_CTLCOLORSTATIC, + CN_CTLCOLORMSGBOX .. CN_CTLCOLORSTATIC: + begin + SetTextColor(Message.wParam, ColorToRGB(FontColor)); + Brush.Color := StyleServices.GetStyleColor(States[SysControl.Enabled]); + SetBkColor(Message.wParam, ColorToRGB(Brush.Color)); + Message.Result := LRESULT(Brush.Handle); + end; + + CM_ENABLEDCHANGED: + begin + UpdateColors; + CallDefaultProc(Message); // Allow control to handle message + end; + CM_FOCUSCHANGED: + begin + Invalidate; + // Handled := False; // Allow control to handle message + CallDefaultProc(Message); + end; + else + inherited WndProc(Message); + end; +end; + +{ TSysStaticStyleHook } + +constructor TSysStaticStyleHook.Create(AHandle: THandle); +var + Style: DWORD; +begin + Style := GetWindowLongPtr(AHandle, GWL_STYLE); + if (Style and SS_ICON <> SS_ICON) and (Style and SS_BITMAP <> SS_BITMAP) then + + inherited; + FUpdatedColor := 0; + +{$IF CompilerVersion > 23} + StyleElements := [seFont, seBorder, seClient]; +{$ELSE} + OverridePaint := True; + OverridePaintNC := True; + OverrideFont := True; +{$IFEND} + UpdateColors; +end; + +destructor TSysStaticStyleHook.Destroy; +begin + inherited; +end; + +function TSysStaticStyleHook.GetIsFrameOrLine: Boolean; +begin + with SysControl do + Result := + (Style and SS_ETCHEDFRAME = SS_ETCHEDFRAME) or + (Style and SS_ETCHEDHORZ = SS_ETCHEDHORZ) or + (Style and SS_SUNKEN = SS_SUNKEN) or + (Style and SS_ETCHEDVERT = SS_ETCHEDVERT); +end; + +function TSysStaticStyleHook.GetIsText: Boolean; +begin + with SysControl do + Result := (Style and SS_ICON <> SS_ICON) and + (Style and SS_BITMAP <> SS_BITMAP) and + (Style and SS_GRAYRECT <> SS_GRAYRECT) and + (Style and SS_GRAYFRAME <> SS_GRAYFRAME) and + (Style and SS_OWNERDRAW <> SS_OWNERDRAW) and + (Style and SS_REALSIZEIMAGE <> SS_REALSIZEIMAGE) and + (Style and SS_ICON <> SS_ICON) and (Style and SS_USERITEM <> SS_USERITEM) + and (Style and SS_REALSIZEIMAGE <> SS_REALSIZEIMAGE) and + (Style and SS_SIMPLE <> SS_SIMPLE); +end; + +function TSysStaticStyleHook.GetTextFormat: TTextFormat; +const + SS_EDITCONTROL = $2000; +begin + Result := [tfHidePrefix]; + with SysControl do + begin + if Style and SS_LEFT = SS_LEFT then + include(Result, tfLeft) + else if Style and SS_RIGHT = SS_RIGHT then + include(Result, tfRight) + else if Style and SS_CENTER = SS_CENTER then + include(Result, tfCenter); + + if Style and SS_ENDELLIPSIS = SS_ENDELLIPSIS then + include(Result, tfEndEllipsis); + + if Style and SS_PATHELLIPSIS = SS_PATHELLIPSIS then + include(Result, tfPathEllipsis); + + if Style and SS_WORDELLIPSIS = SS_WORDELLIPSIS then + include(Result, tfWordEllipsis); + + if Style and SS_NOPREFIX = SS_NOPREFIX then + include(Result, tfNoPrefix); + + if Style and SS_EDITCONTROL = SS_EDITCONTROL then + include(Result, tfEditControl); + + if not(Style and SS_ENDELLIPSIS = SS_ENDELLIPSIS) and + not(Style and SS_PATHELLIPSIS = SS_PATHELLIPSIS) and + not(Style and SS_WORDELLIPSIS = SS_WORDELLIPSIS) then + include(Result, tfWordBreak); + end; +end; + +procedure TSysStaticStyleHook.Paint(Canvas: TCanvas); +const + States: array [Boolean] of TThemedTextLabel = (ttlTextLabelDisabled, + ttlTextLabelNormal); +var + LDetails: TThemedElementDetails; + LRect: TRect; +begin + LRect := SysControl.ClientRect; + if GetBkMode(Canvas.Handle) = TRANSPARENT then + begin + LDetails := StyleServices.GetElementDetails(tbCheckBoxUncheckedNormal); + StyleServices.DrawParentBackground(Handle, Canvas.Handle, LDetails, False); + Canvas.Brush.Style := bsClear; + end + else + begin + Canvas.Brush.Color := StyleServices.GetStyleColor(scWindow); + Canvas.FillRect(LRect); + end; + + LDetails := StyleServices.GetElementDetails(States[SysControl.Enabled]); + Canvas.Font := SysControl.Font; + DrawText(Canvas.Handle, LDetails, SysControl.Text, LRect, TextFormat); +end; + +procedure TSysStaticStyleHook.PaintNC(Canvas: TCanvas); +var + LRect: TRect; + LBitMap: TBitmap; +begin + if IsFrameOrLine then + begin + LRect := Rect(0, 0, SysControl.Width, SysControl.Height); + LBitMap := TBitmap.Create; + try + LBitMap.Width := LRect.Width; + LBitMap.Height := LRect.Height; + Frame3D(LBitMap.Canvas, LRect, StyleServices.ColorToRGB(clBtnShadow), + StyleServices.ColorToRGB(clBtnHighLight), 1); + ExcludeClipRect(Canvas.Handle, 1, 1, SysControl.Width - 1, + SysControl.Height - 1); + Canvas.Draw(0, 0, LBitMap); + finally + LBitMap.Free; + end; + end; +end; + +procedure TSysStaticStyleHook.UpdateColors; +const + ColorStates: array [Boolean] of TStyleColor = (scEditDisabled, scEdit); + FontColorStates: array [Boolean] of TStyleFont = (sfEditBoxTextDisabled, + sfEditBoxTextNormal); +begin + Color := StyleServices.GetStyleColor(scWindow); + FontColor := StyleServices.GetSystemColor(clWindowText); + //Addlog(Format('UpdateColors Handle %d Color %d FontColor %d ',[SysControl.Handle, Color, FontColor])); +end; + +procedure TSysStaticStyleHook.WndProc(var Message: TMessage); +begin + //Addlog(Format('TSysStaticStyleHook $0x%x %s', [SysControl.Handle, WM_To_String(Message.Msg)])); + case Message.Msg of + + WM_SETTEXT: + begin + CallDefaultProc(Message); + if SysControl.Visible then + Invalidate; + + end; + + WM_ENABLE: + if SysControl.Visible then + Invalidate; + + WM_PAINT: + begin + if OverridePaint and StyleServicesEnabled then + begin + if (IsText and (Length(SysControl.Text) > 0)) then + inherited + else + CallDefaultProc(Message); + end + else + CallDefaultProc(Message); + end; + + else + inherited; + end; +end; + +{ TSysCheckBoxStyleHook } +function RectVCenter(var R: TRect; Bounds: TRect): TRect; +begin + OffsetRect(R, -R.Left, -R.Top); + OffsetRect(R, 0, (Bounds.Height - R.Height) div 2); + OffsetRect(R, Bounds.Left, Bounds.Top); + + Result := R; +end; + +procedure TSysCheckBoxStyleHook.BMSetCheck(var Message: TMessage); +begin + SetRedraw(False); + CallDefaultProc(TMessage(Message)); + SetRedraw(True); + Invalidate; + Handled := True; +end; + +constructor TSysCheckBoxStyleHook.Create(AHandle: THandle); +begin + inherited; + OverridePaint := True; + OverrideEraseBkgnd := True; + // DoubleBuffered := True; +end; + +function TSysCheckBoxStyleHook.GetDrawState(State: TSysCheckBoxState) +: TThemedButton; +begin + Result := tbButtonDontCare; + + if not SysControl.Enabled then + case State of + cbUnchecked: + Result := tbCheckBoxUncheckedDisabled; + cbChecked: + Result := tbCheckBoxCheckedDisabled; + cbGrayed: + Result := tbCheckBoxMixedDisabled; + end + else if Pressed and MouseInControl then + case State of + cbUnchecked: + Result := tbCheckBoxUncheckedPressed; + cbChecked: + Result := tbCheckBoxCheckedPressed; + cbGrayed: + Result := tbCheckBoxMixedPressed; + end + else if MouseInControl then + case State of + cbUnchecked: + Result := tbCheckBoxUncheckedHot; + cbChecked: + Result := tbCheckBoxCheckedHot; + cbGrayed: + Result := tbCheckBoxMixedHot; + end + else + case State of + cbUnchecked: + Result := tbCheckBoxUncheckedNormal; + cbChecked: + Result := tbCheckBoxCheckedNormal; + cbGrayed: + Result := tbCheckBoxMixedNormal; + end; +end; + +procedure TSysCheckBoxStyleHook.MouseEnter; +begin + inherited; + Invalidate; + Handled := True; +end; + +procedure TSysCheckBoxStyleHook.MouseLeave; +begin + inherited; + Invalidate; + Handled := True; +end; + +procedure TSysCheckBoxStyleHook.Paint(Canvas: TCanvas); +var + State: TSysCheckBoxState; + Details: TThemedElementDetails; + R: TRect; + Spacing: Integer; + BoxSize: TSize; + LCaption: string; + LRect: TRect; + ElementSize: TElementSize; +begin + if StyleServices.Available then + begin + State := TSysCheckBoxState(SendMessage(Handle, BM_GETCHECK, 0, 0)); + Details := StyleServices.GetElementDetails(GetDrawState(State)); + + Spacing := 3; + LRect := System.Classes.Rect(0, 0, 20, 20); + ElementSize := esActual; + R := SysControl.ClientRect; + with StyleServices do + begin + {$IF (CompilerVersion >= 33)} + if not (Assigned(Application.Mainform) and GetElementSize(Canvas.Handle, GetElementDetails(tbCheckBoxCheckedNormal), LRect, ElementSize, BoxSize, Application.MainForm.Monitor.PixelsPerInch)) then + {$ELSE} + if not GetElementSize(Canvas.Handle, GetElementDetails(tbCheckBoxCheckedNormal), LRect, ElementSize, BoxSize) then + {$ENDIF} + begin + BoxSize.cx := GetSysMetrics(SM_CXMENUCHECK); + BoxSize.cy := GetSysMetrics(SM_CYMENUCHECK); + end; + end; + if not RightAlignment then + begin + R := Rect(0, 0, BoxSize.cx, BoxSize.cy); + RectVCenter(R, Rect(0, 0, SysControl.Width, SysControl.Height)); + end + else + begin + R := Rect(SysControl.Width - BoxSize.cx - 1, 0, SysControl.Width, + SysControl.Height); + RectVCenter(R, Rect(SysControl.Width - BoxSize.cy - 1, 0, + SysControl.Width, SysControl.Height)); + end; + + DrawStyleElement(Canvas.Handle, Details, R); + Canvas.Font := SysControl.Font; + + R := Rect(0, 0, SysControl.Width - BoxSize.cx - 10, SysControl.Height); + LCaption := Text; + Winapi.Windows.DrawText(Canvas.Handle, PWideChar(LCaption), + Length(LCaption), R, SysControl.DrawTextBiDiModeFlags(DT_CALCRECT or + DT_EXPANDTABS)); + + if not RightAlignment then + RectVCenter(R, Rect(BoxSize.cx + Spacing, 0, SysControl.Width, + SysControl.Height)) + else + begin + if SysControl.BiDiMode <> bmRightToLeft then + RectVCenter(R, Rect(3, 0, SysControl.Width - BoxSize.cx - Spacing, + SysControl.Height)) + else + RectVCenter(R, Rect(SysControl.Width - BoxSize.cx - Spacing - R.Right, + 0, SysControl.Width - BoxSize.cx - Spacing, SysControl.Height)); + end; + + DrawControlText(Canvas, Details, LCaption, R, + SysControl.DrawTextBiDiModeFlags(DT_LEFT or DT_VCENTER or DT_EXPANDTABS)); + + if Focused then + begin + InflateRect(R, 2, 1); + if R.Top < 0 then + R.Top := 0; + if R.Bottom > SysControl.Height then + R.Bottom := SysControl.Height; + Canvas.Brush.Color := StyleServices.GetSystemColor(clBtnFace); + Canvas.DrawFocusRect(R); + end; + end; +end; + +procedure TSysCheckBoxStyleHook.PaintBackground(Canvas: TCanvas); +var + Details: TThemedElementDetails; +begin + if StyleServices.Available then + begin + Details.Element := teButton; + if StyleServices.HasTransparentParts(Details) then + StyleServices.DrawParentBackground(Handle, Canvas.Handle, Details, False); + end; +end; + +function TSysCheckBoxStyleHook.RightAlignment: Boolean; +begin + Result := (SysControl.BiDiMode = bmRightToLeft) or + (GetWindowLong(Handle, GWL_STYLE) and BS_RIGHTBUTTON = BS_RIGHTBUTTON); + +end; + +procedure TSysCheckBoxStyleHook.WMKeyDown(var Message: TWMKeyDown); +begin + if Message.CharCode = VK_SPACE then + SetRedraw(False); + CallDefaultProc(TMessage(Message)); + if Message.CharCode = VK_SPACE then + begin + SetRedraw(True); + Invalidate; + end; + Handled := True; +end; + +procedure TSysCheckBoxStyleHook.WMKeyUp(var Message: TWMKeyUp); +begin + if Message.CharCode = VK_SPACE then + SetRedraw(False); + CallDefaultProc(TMessage(Message)); + if Message.CharCode = VK_SPACE then + begin + SetRedraw(True); + Invalidate; + end; + Handled := True; +end; + +procedure TSysCheckBoxStyleHook.WMLButtonDblClk(var Message: TWMMouse); +begin + SetRedraw(False); + CallDefaultProc(TMessage(Message)); + SetRedraw(True); + Invalidate; + Handled := True; +end; + +procedure TSysCheckBoxStyleHook.WMLButtonDown(var Message: TWMMouse); +begin + SetRedraw(False); + CallDefaultProc(TMessage(Message)); + SetRedraw(True); + FPressed := True; + Invalidate; + Handled := True; +end; + +procedure TSysCheckBoxStyleHook.WMLButtonUp(var Message: TWMMouse); +begin + SetRedraw(False); + CallDefaultProc(TMessage(Message)); + SetRedraw(True); + FPressed := False; + Invalidate; + Handled := True; +end; + +procedure TSysCheckBoxStyleHook.WndProc(var Message: TMessage); +begin + inherited; +end; + +{ TSysRadioButtonStyleHook } + +constructor TSysRadioButtonStyleHook.Create(AHandle: THandle); +begin + inherited; + OverridePaint := True; + OverrideEraseBkgnd := True; + // DoubleBuffered := True; +end; + +function TSysRadioButtonStyleHook.GetDrawState(State: TSysCheckBoxState) +: TThemedButton; +begin + Result := tbButtonDontCare; + + if not SysControl.Enabled then + case State of + cbUnchecked: + Result := tbRadioButtonUncheckedDisabled; + cbChecked: + Result := tbRadioButtonCheckedDisabled; + end + else if Pressed and MouseInControl then + case State of + cbUnchecked: + Result := tbRadioButtonUncheckedPressed; + cbChecked: + Result := tbRadioButtonCheckedPressed; + end + else if MouseInControl then + case State of + cbUnchecked: + Result := tbRadioButtonUncheckedHot; + cbChecked: + Result := tbRadioButtonCheckedHot; + end + else + case State of + cbUnchecked: + Result := tbRadioButtonUncheckedNormal; + cbChecked: + Result := tbRadioButtonCheckedNormal; + end; +end; + +procedure TSysRadioButtonStyleHook.WndProc(var Message: TMessage); +begin + inherited; +end; + +initialization + +if StyleServices.Available then +begin + with TSysStyleManager do + begin + RegisterSysStyleHook(WC_BUTTON, TSysButtonStyleHook); + RegisterSysStyleHook(WC_EDIT, TSysEditStyleHook); + RegisterSysStyleHook('ComboLBox', TSysListBoxStyleHook); + RegisterSysStyleHook(WC_COMBOBOX, TSysComboBoxStyleHook); + RegisterSysStyleHook( 'ListBox', TSysListBoxStyleHook); + RegisterSysStyleHook( 'Static', TSysStaticStyleHook); + end; +end; + +finalization + +with TSysStyleManager do +begin + UnRegisterSysStyleHook(WC_BUTTON, TSysButtonStyleHook); + UnRegisterSysStyleHook(WC_EDIT, TSysEditStyleHook); + UnRegisterSysStyleHook('ComboLBox', TSysListBoxStyleHook); + UnRegisterSysStyleHook(WC_COMBOBOX, TSysComboBoxStyleHook); + UnRegisterSysStyleHook('ListBox', TSysListBoxStyleHook); + UnRegisterSysStyleHook('Static', TSysStaticStyleHook); +end; + +end. diff --git a/source/vcl-styles-utils/Vcl.Styles.Utils.SysControls.pas b/source/vcl-styles-utils/Vcl.Styles.Utils.SysControls.pas index 6b43c6016..072033e6e 100644 --- a/source/vcl-styles-utils/Vcl.Styles.Utils.SysControls.pas +++ b/source/vcl-styles-utils/Vcl.Styles.Utils.SysControls.pas @@ -1,498 +1,498 @@ -// *************************************************************************************************** -// -// Unit Vcl.Styles.Utils.SysControls -// unit for the VCL Styles Utils -// https://github.com/RRUZ/vcl-styles-utils/ -// -// 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. -// -// -// Portions created by Mahdi Safsafi [SMP3] e-mail SMP@LIVE.FR -// Portions created by Rodrigo Ruz V. are Copyright (C) 2013-2019 Rodrigo Ruz V. -// All Rights Reserved. -// -// ************************************************************************************************** -unit Vcl.Styles.Utils.SysControls; - - -interface - -uses - System.Classes, - System.Types, - System.SysUtils, - System.Generics.Collections, - Winapi.Windows, - Winapi.Messages, - Vcl.Controls, - Vcl.Graphics, - Vcl.Themes, - Vcl.Styles.Utils.SysStyleHook; - -type - PChildControlInfo = ^TChildControlInfo; - - TChildControlInfo = record - Parent: HWND; - ParentStyle: NativeInt; - StyleHookClass: TSysStyleHookClass; - end; - - PControlInfo = ^TControlInfo; - - TControlInfo = record - Handle: HWND; - Parent: HWND; - Style: NativeInt; - ParentStyle: NativeInt; - ExStyle: NativeInt; - ParentExStyle: NativeInt; - ClassName: PChar; - ParentClassName: PChar; - end; - -type - TSysHookAction = (cAdded, cRemoved); - TBeforeHookingControl = function(Info: PControlInfo): Boolean; - TSysHookNotification = procedure(Action: TSysHookAction; Info: PControlInfo); - - TSysStyleManager = class(TComponent) - private - class var - FEnabled: Boolean; - FHook_WH_CBT: HHook; - FBeforeHookingControlProc: TBeforeHookingControl; - FSysHookNotificationProc: TSysHookNotification; - FRegSysStylesList: TObjectDictionary; - FSysStyleHookList: TObjectDictionary; - FChildRegSysStylesList: TObjectDictionary; - FHookVclControls: Boolean; - FUseStyleColorsChildControls: Boolean; - class var FHookDialogIcons: Boolean; - protected - /// - /// Install the Hook - /// - class procedure InstallHook_WH_CBT; - /// - /// Remove the Hook - /// - class procedure RemoveHook_WH_CBT; - /// - /// Hook Callback - /// - class function HookActionCallBackCBT(nCode: Integer; wParam: wParam; lParam: lParam): LRESULT; stdcall; static; - public - /// - /// Register a Sys Style Hook for an specified class. - /// - class procedure RegisterSysStyleHook(const SysControlClass: String; SysStyleHookClass: TSysStyleHookClass); - /// - /// UnRegister a Sys Style Hook for an specified class. - /// - class procedure UnRegisterSysStyleHook(const SysControlClass: String; SysStyleHookClass: TSysStyleHookClass); - class constructor Create; - class destructor Destroy; - constructor Create(AOwner: TComponent); override; - destructor Destroy; override; - /// - /// Event to preventvor allowhook a control. - /// - class Property OnBeforeHookingControl: TBeforeHookingControl read FBeforeHookingControlProc write FBeforeHookingControlProc; - /// - /// Notify when a hook foircontrol is added or removed - /// - class Property OnHookNotification: TSysHookNotification read FSysHookNotificationProc write FSysHookNotificationProc; - /// - /// Enable or disable the style of the controls - /// - class property Enabled: Boolean read FEnabled write FEnabled; - /// - /// Allowset thecurrent VCL Stylefont and background color in child - /// controls. - /// - class property UseStyleColorsChildControls: Boolean read FUseStyleColorsChildControls write FUseStyleColorsChildControls; - /// - /// Allow disable or enable the hook of VCL Controls - /// - class property HookVclControls: Boolean read FHookVclControls write FHookVclControls; - /// - /// Allow disable or enable the hook of the icons dialogs - /// - class property HookDialogIcons: Boolean read FHookDialogIcons write FHookDialogIcons; - /// - /// Collection of Styled (Hooked) Controls - /// - class property SysStyleHookList: TObjectDictionary read FSysStyleHookList; - /// - /// Collection of Styled ChildControls - /// - class property ChildRegSysStylesList: TObjectDictionary read FChildRegSysStylesList; - class procedure AddControlDirectly(Handle: HWND; const sClassName : string; IncludeChildControls : Boolean = False); - end; - - -implementation - -uses - WinApi.CommCtrl, - Vcl.Styles.Utils.Misc; - -function FindWinFromRoot(Root: HWND; ClassName: PChar): HWND; -var - Next, Child: HWND; - S: String; -begin - Result := 0; - Next := GetWindow(Root, GW_CHILD or GW_HWNDFIRST); - while (Next > 0) do - begin - S := GetWindowClassName(Next); - if S = String(ClassName) then - Exit(Next); - Next := GetWindow(Next, GW_HWNDNEXT); - Child := GetWindow(Next, GW_CHILD or GW_HWNDFIRST); - if Child > 0 then - Result := FindWinFromRoot(Next, ClassName); - if Result > 0 then - Exit; - end; -end; - -{ -------------------------------------------------------------------------------------- } -{ TSysStyleManager } -function BeforeHookingControl(Info: PControlInfo): Boolean; -var - LInfo: TControlInfo; - Root, C: HWND; -begin - { - Return true to allow control hooking ! - Return false to prevent control hooking ! - } - { NB: The ClassName is always in lowercase . } - LInfo := Info^; - Result := True; - Root := GetAncestor(LInfo.Parent, GA_ROOT); - if FindWinFromRoot(Root, 'DirectUIHWND') > 0 then - begin - Result := False; - Exit; - end; - - if SameText(LInfo.ClassName, WC_LISTVIEW) then - begin - if SameText(LInfo.ParentClassName, 'listviewpopup') then - Result:=False; - end - else - if SameText(LInfo.ClassName, TRACKBAR_CLASS) then - begin - if SameText(LInfo.ParentClassName, 'ViewControlClass') then - Result:=False; - end - else - //Prevent hook Toolbars on DirectUIHWND - if SameText(LInfo.ClassName, TOOLBARCLASSNAME) then - begin - if SameText(LInfo.ParentClassName, 'ViewControlClass') then - Result:=False - else - if Root > 0 then - begin - C := FindWinFromRoot(Root, REBARCLASSNAME); - Result := not(C > 0); - end; - end; -end; - -procedure HookNotification(Action: TSysHookAction; Info: PControlInfo); -begin - -end; - -class constructor TSysStyleManager.Create; -begin - FHook_WH_CBT:=0; - FBeforeHookingControlProc := @BeforeHookingControl; - FSysHookNotificationProc := @HookNotification; - FUseStyleColorsChildControls := True; - FEnabled := True; - FHookDialogIcons := False; - FHookVclControls := False; - FSysStyleHookList := TObjectDictionary.Create([doOwnsValues]); - FRegSysStylesList := TObjectDictionary.Create; - FChildRegSysStylesList := TObjectDictionary.Create; - //FSysStyleHookList := TObjectDictionary.Create([]); - InstallHook_WH_CBT; -end; - -class destructor TSysStyleManager.Destroy; -begin - RemoveHook_WH_CBT; - FRegSysStylesList.Free; - FSysStyleHookList.Free; // remove the childs too because doOwnsValues - FChildRegSysStylesList.Free; - inherited; -end; - -class procedure TSysStyleManager.AddControlDirectly(Handle: HWND; const sClassName : string; IncludeChildControls : Boolean = False); -var - LStyleHook : TSysStyleHook; - ParentStyle : DWORD; - - procedure AddChildControl(ChildHandle: HWND); - var - Info: TChildControlInfo; - sChildClassName : string; - LStyleHook : TSysStyleHook; - begin - { Hook the control directly ! } - ZeroMemory(@Info, sizeof(TChildControlInfo)); - Info.Parent := Handle; - Info.ParentStyle := ParentStyle; - sChildClassName := LowerCase(GetWindowClassName(ChildHandle)); - if FRegSysStylesList.ContainsKey(sChildClassName) then - begin - LStyleHook:=FRegSysStylesList[LowerCase(sChildClassName)].Create(ChildHandle); - FSysStyleHookList.Add(ChildHandle, LStyleHook); - SendMessage(ChildHandle, CM_CONTROLHOOKEDDIRECTLY, 0, 0); - InvalidateRect(ChildHandle, nil, False); -// if Assigned(FSysHookNotificationProc) then -// FSysHookNotificationProc(cAdded, @Info); - end; - end; - - function EnumChildProc(const hWindow: hWnd; const LParam : LParam): boolean; stdcall; - begin - AddChildControl(hWindow); - Result:= True; - end; - -begin - if not FRegSysStylesList.ContainsKey(LowerCase(sClassName)) then - Exit; - { Hook the control directly ! } - if FSysStyleHookList.ContainsKey(Handle) then - FSysStyleHookList.Remove(Handle); - LStyleHook:=FRegSysStylesList[LowerCase(sClassName)].Create(Handle); - FSysStyleHookList.Add(Handle, LStyleHook); - SendMessage(Handle, CM_CONTROLHOOKEDDIRECTLY, 0, 0); -// if Assigned(FSysHookNotificationProc) then -// FSysHookNotificationProc(cAdded, @Info); - - if IncludeChildControls then - begin - ParentStyle:=GetWindowLongPtr(Handle, GWL_STYLE); - EnumChildWindows(Handle, @EnumChildProc, 0); - end; -end; - - -constructor TSysStyleManager.Create(AOwner: TComponent); -begin - inherited; -end; - -destructor TSysStyleManager.Destroy; -begin - inherited; -end; - -type - TSysStyleClass = class(TSysStyleHook); - -class function TSysStyleManager.HookActionCallBackCBT(nCode: Integer; wParam: wParam; lParam: lParam): LRESULT; -var - CBTSturct: TCBTCreateWnd; - sClassName, Tmp: string; - {LHWND,} Parent: HWND; - Style, ParentStyle, ExStyle, ParentExStyle: NativeInt; - Info: TControlInfo; - - procedure RemoveUnusedHooks; - var - LHandle : THandle; - begin - for LHandle in TSysStyleManager.SysStyleHookList.Keys do - if TSysStyleClass(TSysStyleManager.SysStyleHookList.Items[LHandle]).MustRemove then - TSysStyleManager.SysStyleHookList.Remove(LHandle); - end; - - procedure AddChildControl(Handle: HWND); - var - Info: TChildControlInfo; - begin - { The child control will be hooked inside it's parent control. } - ZeroMemory(@Info, sizeof(TChildControlInfo)); - Info.Parent := Parent; - Info.ParentStyle := ParentStyle; - Info.StyleHookClass := FRegSysStylesList[sClassName]; - if FChildRegSysStylesList.ContainsKey(Handle) then - FChildRegSysStylesList.Remove(Handle); - FChildRegSysStylesList.Add(Handle, Info); - if Assigned(FSysHookNotificationProc) then - FSysHookNotificationProc(cAdded, @Info); - end; - - procedure AddControl(Handle: HWND); - var - LStyleHook : TSysStyleHook; - begin - { Hook the control directly ! } - RemoveUnusedHooks; - if FSysStyleHookList.ContainsKey(Handle) then - FSysStyleHookList.Remove(Handle); - LStyleHook:=FRegSysStylesList[sClassName].Create(Handle); - FSysStyleHookList.Add(Handle, LStyleHook); - SendMessage(Handle, CM_CONTROLHOOKEDDIRECTLY, 0, 0); - if Assigned(FSysHookNotificationProc) then - FSysHookNotificationProc(cAdded, @Info); - end; - -begin - Result := CallNextHookEx(FHook_WH_CBT, nCode, wParam, lParam); - if not FEnabled then - Exit; - -// if (nCode = HCBT_ACTIVATE) and not(StyleServices.IsSystemStyle) then -// begin -// LHWND := HWND(wParam); -// if(LHWND>0) then -// begin -// sClassName:= GetWindowClassName(LHWND); -// if (sClassName<>'') and (not TSysStyleManager.SysStyleHookList.ContainsKey(LHWND)) and (SameText(sClassName,'#32770')) then -// begin -// TSysStyleManager.AddControlDirectly(LHWND, sClassName); -// InvalidateRect(LHWND, nil, False); -// end; -// end; -// end; - - - if (nCode = HCBT_CREATEWND) and not(StyleServices.IsSystemStyle) then - begin - - CBTSturct := PCBTCreateWnd(lParam)^; - sClassName := GetWindowClassName(wParam); - sClassName := LowerCase(sClassName); - -// if SameText(sClassName, '#32770') then -// OutputDebugString(PChar('Class '+sclassName+' '+IntToHex(wParam, 8))); - - Parent := CBTSturct.lpcs.hwndParent; - Style := CBTSturct.lpcs.Style; - ExStyle := CBTSturct.lpcs.dwExStyle; - ParentExStyle := 0; - ParentStyle := 0; - - if Parent > 0 then - begin - ParentStyle := GetWindowLongPtr(Parent, GWL_STYLE); - ParentExStyle := GetWindowLongPtr(Parent, GWL_EXSTYLE); - end; - - if FRegSysStylesList.ContainsKey(sClassName) then - begin - Info.Handle := wParam; - Info.Parent := Parent; - Info.Style := Style; - Info.ParentStyle := ParentStyle; - Info.ExStyle := ExStyle; - Info.ParentExStyle := ParentExStyle; - Tmp := sClassName; - Info.ClassName := PChar(Tmp); - Tmp := LowerCase(GetWindowClassName(Parent)); - Info.ParentClassName := PChar(Tmp); - - if not HookVclControls then - if IsVCLControl(wParam) then - Exit; - - if Assigned(FBeforeHookingControlProc) then - if not FBeforeHookingControlProc(@Info) then - Exit; - - if (Style and DS_CONTROL = DS_CONTROL) then - begin - { TabSheet ! } - AddControl(wParam); - PostMessage(wParam, CM_INITCHILDS, 0, 0); - end - else if (Style and WS_POPUP = WS_POPUP) then - begin - { Parent Control ! } - AddControl(wParam); - end - else if (Style and WS_CHILD = WS_CHILD) then - begin - { Child Control ! } - if FSysStyleHookList.ContainsKey(Parent) then - begin - { Parent is already hooked . } - if IsVCLControl(Parent) then - { Parent is a VCL control . } - AddControl(wParam) - else - AddChildControl(wParam) - end - else - { Parent not registered (not hooked). } - AddControl(wParam); - end - else - { Not (WS_CHILD or WS_POPUP) !! } - AddControl(wParam); - end; - - // if FSysStyleHookList.ContainsKey(wParam) or FChildRegSysStylesList.ContainsKey(wParam) then - // OutputDebugString(PChar('Hooked '+IntToHex(wParam, 8))); - - end; - - - if nCode = HCBT_DESTROYWND then - begin - //OutputDebugString(PChar('HCBT_DESTROYWND Handle '+IntToHex(wParam, 8))); - if FSysStyleHookList.ContainsKey(wParam) then - begin - ZeroMemory(@Info, sizeof(TControlInfo)); - Info.Handle := wParam; - if Assigned(FSysHookNotificationProc) then - OnHookNotification(cRemoved, @Info); - // FSysStyleHookList.Remove(wParam); -> removed in WM_NCDESTROY - end; - end; -end; - -class procedure TSysStyleManager.InstallHook_WH_CBT; -begin - FHook_WH_CBT := SetWindowsHookEx(WH_CBT, @HookActionCallBackCBT, 0, GetCurrentThreadId); -end; - -class procedure TSysStyleManager.RegisterSysStyleHook(const SysControlClass: String; SysStyleHookClass: TSysStyleHookClass); -begin - if FRegSysStylesList.ContainsKey(LowerCase(SysControlClass)) then - FRegSysStylesList.Remove(LowerCase(SysControlClass)); - FRegSysStylesList.Add(LowerCase(SysControlClass), SysStyleHookClass); -end; - -class procedure TSysStyleManager.RemoveHook_WH_CBT; -begin - if FHook_WH_CBT <> 0 then - UnhookWindowsHookEx(FHook_WH_CBT); -end; - -class procedure TSysStyleManager.UnRegisterSysStyleHook(const SysControlClass: String; SysStyleHookClass: TSysStyleHookClass); -begin - if FRegSysStylesList.ContainsKey(LowerCase(SysControlClass)) then - FRegSysStylesList.Remove(LowerCase(SysControlClass)); -end; - -end. +// *************************************************************************************************** +// +// Unit Vcl.Styles.Utils.SysControls +// unit for the VCL Styles Utils +// https://github.com/RRUZ/vcl-styles-utils/ +// +// 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. +// +// +// Portions created by Mahdi Safsafi [SMP3] e-mail SMP@LIVE.FR +// Portions created by Rodrigo Ruz V. are Copyright (C) 2013-2023 Rodrigo Ruz V. +// All Rights Reserved. +// +// ************************************************************************************************** +unit Vcl.Styles.Utils.SysControls; + + +interface + +uses + System.Classes, + System.Types, + System.SysUtils, + System.Generics.Collections, + Winapi.Windows, + Winapi.Messages, + Vcl.Controls, + Vcl.Graphics, + Vcl.Themes, + Vcl.Styles.Utils.SysStyleHook; + +type + PChildControlInfo = ^TChildControlInfo; + + TChildControlInfo = record + Parent: HWND; + ParentStyle: NativeInt; + StyleHookClass: TSysStyleHookClass; + end; + + PControlInfo = ^TControlInfo; + + TControlInfo = record + Handle: HWND; + Parent: HWND; + Style: NativeInt; + ParentStyle: NativeInt; + ExStyle: NativeInt; + ParentExStyle: NativeInt; + ClassName: PChar; + ParentClassName: PChar; + end; + +type + TSysHookAction = (cAdded, cRemoved); + TBeforeHookingControl = function(Info: PControlInfo): Boolean; + TSysHookNotification = procedure(Action: TSysHookAction; Info: PControlInfo); + + TSysStyleManager = class(TComponent) + private + class var + FEnabled: Boolean; + FHook_WH_CBT: HHook; + FBeforeHookingControlProc: TBeforeHookingControl; + FSysHookNotificationProc: TSysHookNotification; + FRegSysStylesList: TObjectDictionary; + FSysStyleHookList: TObjectDictionary; + FChildRegSysStylesList: TObjectDictionary; + FHookVclControls: Boolean; + FUseStyleColorsChildControls: Boolean; + class var FHookDialogIcons: Boolean; + protected + /// + /// Install the Hook + /// + class procedure InstallHook_WH_CBT; + /// + /// Remove the Hook + /// + class procedure RemoveHook_WH_CBT; + /// + /// Hook Callback + /// + class function HookActionCallBackCBT(nCode: Integer; wParam: wParam; lParam: lParam): LRESULT; stdcall; static; + public + /// + /// Register a Sys Style Hook for an specified class. + /// + class procedure RegisterSysStyleHook(const SysControlClass: String; SysStyleHookClass: TSysStyleHookClass); + /// + /// UnRegister a Sys Style Hook for an specified class. + /// + class procedure UnRegisterSysStyleHook(const SysControlClass: String; SysStyleHookClass: TSysStyleHookClass); + class constructor Create; + class destructor Destroy; + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + /// + /// Event to preventvor allowhook a control. + /// + class Property OnBeforeHookingControl: TBeforeHookingControl read FBeforeHookingControlProc write FBeforeHookingControlProc; + /// + /// Notify when a hook foircontrol is added or removed + /// + class Property OnHookNotification: TSysHookNotification read FSysHookNotificationProc write FSysHookNotificationProc; + /// + /// Enable or disable the style of the controls + /// + class property Enabled: Boolean read FEnabled write FEnabled; + /// + /// Allowset thecurrent VCL Stylefont and background color in child + /// controls. + /// + class property UseStyleColorsChildControls: Boolean read FUseStyleColorsChildControls write FUseStyleColorsChildControls; + /// + /// Allow disable or enable the hook of VCL Controls + /// + class property HookVclControls: Boolean read FHookVclControls write FHookVclControls; + /// + /// Allow disable or enable the hook of the icons dialogs + /// + class property HookDialogIcons: Boolean read FHookDialogIcons write FHookDialogIcons; + /// + /// Collection of Styled (Hooked) Controls + /// + class property SysStyleHookList: TObjectDictionary read FSysStyleHookList; + /// + /// Collection of Styled ChildControls + /// + class property ChildRegSysStylesList: TObjectDictionary read FChildRegSysStylesList; + class procedure AddControlDirectly(Handle: HWND; const sClassName: string; IncludeChildControls: Boolean = False); + end; + + +implementation + +uses + WinApi.CommCtrl, + Vcl.Styles.Utils.Misc; + +function FindWinFromRoot(Root: HWND; ClassName: PChar): HWND; +var + Next, Child: HWND; + S: String; +begin + Result := 0; + Next := GetWindow(Root, GW_CHILD or GW_HWNDFIRST); + while (Next > 0) do + begin + S := GetWindowClassName(Next); + if S = String(ClassName) then + Exit(Next); + Next := GetWindow(Next, GW_HWNDNEXT); + Child := GetWindow(Next, GW_CHILD or GW_HWNDFIRST); + if Child > 0 then + Result := FindWinFromRoot(Next, ClassName); + if Result > 0 then + Exit; + end; +end; + +{ -------------------------------------------------------------------------------------- } +{ TSysStyleManager } +function BeforeHookingControl(Info: PControlInfo): Boolean; +var + LInfo: TControlInfo; + Root, C: HWND; +begin + { + Return true to allow control hooking ! + Return false to prevent control hooking ! + } + { NB: The ClassName is always in lowercase . } + LInfo := Info^; + Result := True; + Root := GetAncestor(LInfo.Parent, GA_ROOT); + if FindWinFromRoot(Root, 'DirectUIHWND') > 0 then + begin + Result := False; + Exit; + end; + + if SameText(LInfo.ClassName, WC_LISTVIEW) then + begin + if SameText(LInfo.ParentClassName, 'listviewpopup') then + Result:=False; + end + else + if SameText(LInfo.ClassName, TRACKBAR_CLASS) then + begin + if SameText(LInfo.ParentClassName, 'ViewControlClass') then + Result:=False; + end + else + //Prevent hook Toolbars on DirectUIHWND + if SameText(LInfo.ClassName, TOOLBARCLASSNAME) then + begin + if SameText(LInfo.ParentClassName, 'ViewControlClass') then + Result:=False + else + if Root > 0 then + begin + C := FindWinFromRoot(Root, REBARCLASSNAME); + Result := not(C > 0); + end; + end; +end; + +procedure HookNotification(Action: TSysHookAction; Info: PControlInfo); +begin + +end; + +class constructor TSysStyleManager.Create; +begin + FHook_WH_CBT:=0; + FBeforeHookingControlProc := @BeforeHookingControl; + FSysHookNotificationProc := @HookNotification; + FUseStyleColorsChildControls := True; + FEnabled := True; + FHookDialogIcons := False; + FHookVclControls := False; + FSysStyleHookList := TObjectDictionary.Create([doOwnsValues]); + FRegSysStylesList := TObjectDictionary.Create; + FChildRegSysStylesList := TObjectDictionary.Create; + //FSysStyleHookList := TObjectDictionary.Create([]); + InstallHook_WH_CBT; +end; + +class destructor TSysStyleManager.Destroy; +begin + RemoveHook_WH_CBT; + FRegSysStylesList.Free; + FSysStyleHookList.Free; // remove the childs too because doOwnsValues + FChildRegSysStylesList.Free; + inherited; +end; + +class procedure TSysStyleManager.AddControlDirectly(Handle: HWND; const sClassName: string; IncludeChildControls: Boolean = False); +var + LStyleHook: TSysStyleHook; + ParentStyle: DWORD; + + procedure AddChildControl(ChildHandle: HWND); + var + Info: TChildControlInfo; + sChildClassName: string; + LStyleHook: TSysStyleHook; + begin + { Hook the control directly ! } + ZeroMemory(@Info, sizeof(TChildControlInfo)); + Info.Parent := Handle; + Info.ParentStyle := ParentStyle; + sChildClassName := LowerCase(GetWindowClassName(ChildHandle)); + if FRegSysStylesList.ContainsKey(sChildClassName) then + begin + LStyleHook:=FRegSysStylesList[LowerCase(sChildClassName)].Create(ChildHandle); + FSysStyleHookList.Add(ChildHandle, LStyleHook); + SendMessage(ChildHandle, CM_CONTROLHOOKEDDIRECTLY, 0, 0); + InvalidateRect(ChildHandle, nil, False); +// if Assigned(FSysHookNotificationProc) then +// FSysHookNotificationProc(cAdded, @Info); + end; + end; + + function EnumChildProc(const hWindow: hWnd; const LParam: LParam): boolean; stdcall; + begin + AddChildControl(hWindow); + Result:= True; + end; + +begin + if not FRegSysStylesList.ContainsKey(LowerCase(sClassName)) then + Exit; + { Hook the control directly ! } + if FSysStyleHookList.ContainsKey(Handle) then + FSysStyleHookList.Remove(Handle); + LStyleHook:=FRegSysStylesList[LowerCase(sClassName)].Create(Handle); + FSysStyleHookList.Add(Handle, LStyleHook); + SendMessage(Handle, CM_CONTROLHOOKEDDIRECTLY, 0, 0); +// if Assigned(FSysHookNotificationProc) then +// FSysHookNotificationProc(cAdded, @Info); + + if IncludeChildControls then + begin + ParentStyle:=GetWindowLongPtr(Handle, GWL_STYLE); + EnumChildWindows(Handle, @EnumChildProc, 0); + end; +end; + + +constructor TSysStyleManager.Create(AOwner: TComponent); +begin + inherited; +end; + +destructor TSysStyleManager.Destroy; +begin + inherited; +end; + +type + TSysStyleClass = class(TSysStyleHook); + +class function TSysStyleManager.HookActionCallBackCBT(nCode: Integer; wParam: wParam; lParam: lParam): LRESULT; +var + CBTSturct: TCBTCreateWnd; + sClassName, Tmp: string; + {LHWND,} Parent: HWND; + Style, ParentStyle, ExStyle, ParentExStyle: NativeInt; + Info: TControlInfo; + + procedure RemoveUnusedHooks; + var + LHandle: THandle; + begin + for LHandle in TSysStyleManager.SysStyleHookList.Keys do + if TSysStyleClass(TSysStyleManager.SysStyleHookList.Items[LHandle]).MustRemove then + TSysStyleManager.SysStyleHookList.Remove(LHandle); + end; + + procedure AddChildControl(Handle: HWND); + var + Info: TChildControlInfo; + begin + { The child control will be hooked inside it's parent control. } + ZeroMemory(@Info, sizeof(TChildControlInfo)); + Info.Parent := Parent; + Info.ParentStyle := ParentStyle; + Info.StyleHookClass := FRegSysStylesList[sClassName]; + if FChildRegSysStylesList.ContainsKey(Handle) then + FChildRegSysStylesList.Remove(Handle); + FChildRegSysStylesList.Add(Handle, Info); + if Assigned(FSysHookNotificationProc) then + FSysHookNotificationProc(cAdded, @Info); + end; + + procedure AddControl(Handle: HWND); + var + LStyleHook: TSysStyleHook; + begin + { Hook the control directly ! } + RemoveUnusedHooks; + if FSysStyleHookList.ContainsKey(Handle) then + FSysStyleHookList.Remove(Handle); + LStyleHook:=FRegSysStylesList[sClassName].Create(Handle); + FSysStyleHookList.Add(Handle, LStyleHook); + SendMessage(Handle, CM_CONTROLHOOKEDDIRECTLY, 0, 0); + if Assigned(FSysHookNotificationProc) then + FSysHookNotificationProc(cAdded, @Info); + end; + +begin + Result := CallNextHookEx(FHook_WH_CBT, nCode, wParam, lParam); + if not FEnabled then + Exit; + +// if (nCode = HCBT_ACTIVATE) and not(StyleServices.IsSystemStyle) then +// begin +// LHWND := HWND(wParam); +// if(LHWND>0) then +// begin +// sClassName:= GetWindowClassName(LHWND); +// if (sClassName<>'') and (not TSysStyleManager.SysStyleHookList.ContainsKey(LHWND)) and (SameText(sClassName,'#32770')) then +// begin +// TSysStyleManager.AddControlDirectly(LHWND, sClassName); +// InvalidateRect(LHWND, nil, False); +// end; +// end; +// end; + + + if (nCode = HCBT_CREATEWND) and not(StyleServices.IsSystemStyle) then + begin + + CBTSturct := PCBTCreateWnd(lParam)^; + sClassName := GetWindowClassName(wParam); + sClassName := LowerCase(sClassName); + +// if SameText(sClassName, '#32770') then +// OutputDebugString(PChar('Class '+sclassName+' '+IntToHex(wParam, 8))); + + Parent := CBTSturct.lpcs.hwndParent; + Style := CBTSturct.lpcs.Style; + ExStyle := CBTSturct.lpcs.dwExStyle; + ParentExStyle := 0; + ParentStyle := 0; + + if Parent > 0 then + begin + ParentStyle := GetWindowLongPtr(Parent, GWL_STYLE); + ParentExStyle := GetWindowLongPtr(Parent, GWL_EXSTYLE); + end; + + if FRegSysStylesList.ContainsKey(sClassName) then + begin + Info.Handle := wParam; + Info.Parent := Parent; + Info.Style := Style; + Info.ParentStyle := ParentStyle; + Info.ExStyle := ExStyle; + Info.ParentExStyle := ParentExStyle; + Tmp := sClassName; + Info.ClassName := PChar(Tmp); + Tmp := LowerCase(GetWindowClassName(Parent)); + Info.ParentClassName := PChar(Tmp); + + if not HookVclControls then + if IsVCLControl(wParam) then + Exit; + + if Assigned(FBeforeHookingControlProc) then + if not FBeforeHookingControlProc(@Info) then + Exit; + + if (Style and DS_CONTROL = DS_CONTROL) then + begin + { TabSheet ! } + AddControl(wParam); + PostMessage(wParam, CM_INITCHILDS, 0, 0); + end + else if (Style and WS_POPUP = WS_POPUP) then + begin + { Parent Control ! } + AddControl(wParam); + end + else if (Style and WS_CHILD = WS_CHILD) then + begin + { Child Control ! } + if FSysStyleHookList.ContainsKey(Parent) then + begin + { Parent is already hooked . } + if IsVCLControl(Parent) then + { Parent is a VCL control . } + AddControl(wParam) + else + AddChildControl(wParam) + end + else + { Parent not registered (not hooked). } + AddControl(wParam); + end + else + { Not (WS_CHILD or WS_POPUP) !! } + AddControl(wParam); + end; + + // if FSysStyleHookList.ContainsKey(wParam) or FChildRegSysStylesList.ContainsKey(wParam) then + // OutputDebugString(PChar('Hooked '+IntToHex(wParam, 8))); + + end; + + + if nCode = HCBT_DESTROYWND then + begin + //OutputDebugString(PChar('HCBT_DESTROYWND Handle '+IntToHex(wParam, 8))); + if FSysStyleHookList.ContainsKey(wParam) then + begin + ZeroMemory(@Info, sizeof(TControlInfo)); + Info.Handle := wParam; + if Assigned(FSysHookNotificationProc) then + OnHookNotification(cRemoved, @Info); + // FSysStyleHookList.Remove(wParam); -> removed in WM_NCDESTROY + end; + end; +end; + +class procedure TSysStyleManager.InstallHook_WH_CBT; +begin + FHook_WH_CBT := SetWindowsHookEx(WH_CBT, @HookActionCallBackCBT, 0, GetCurrentThreadId); +end; + +class procedure TSysStyleManager.RegisterSysStyleHook(const SysControlClass: String; SysStyleHookClass: TSysStyleHookClass); +begin + if FRegSysStylesList.ContainsKey(LowerCase(SysControlClass)) then + FRegSysStylesList.Remove(LowerCase(SysControlClass)); + FRegSysStylesList.Add(LowerCase(SysControlClass), SysStyleHookClass); +end; + +class procedure TSysStyleManager.RemoveHook_WH_CBT; +begin + if FHook_WH_CBT <> 0 then + UnhookWindowsHookEx(FHook_WH_CBT); +end; + +class procedure TSysStyleManager.UnRegisterSysStyleHook(const SysControlClass: String; SysStyleHookClass: TSysStyleHookClass); +begin + if FRegSysStylesList.ContainsKey(LowerCase(SysControlClass)) then + FRegSysStylesList.Remove(LowerCase(SysControlClass)); +end; + +end. diff --git a/source/vcl-styles-utils/Vcl.Styles.Utils.SysStyleHook.pas b/source/vcl-styles-utils/Vcl.Styles.Utils.SysStyleHook.pas index f4c9aa789..e07a6b2dc 100644 --- a/source/vcl-styles-utils/Vcl.Styles.Utils.SysStyleHook.pas +++ b/source/vcl-styles-utils/Vcl.Styles.Utils.SysStyleHook.pas @@ -1,1414 +1,1414 @@ -// ************************************************************************************************** -// -// Unit Vcl.Styles.SysStyleHook -// unit for the VCL Styles Utils -// https://github.com/RRUZ/vcl-styles-utils/ -// -// 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. -// -// The Original Code is uSysStyleHook.pas. -// -// Portions created by Mahdi Safsafi [SMP3] e-mail SMP@LIVE.FR -// Portions created by Rodrigo Ruz V. are Copyright (C) 2013-2019 Rodrigo Ruz V. -// All Rights Reserved. -// -// ************************************************************************************************** -unit Vcl.Styles.Utils.SysStyleHook; - -interface - -uses - System.Classes, - System.Types, - System.SysUtils, - Winapi.Windows, - Winapi.Messages, - Winapi.UxTheme, - Winapi.CommCtrl, - Vcl.Themes, - Vcl.ExtCtrls, - Vcl.Controls, - Vcl.Graphics; - -const - CM_BASE = WM_USER + $113; - CM_CTLCOLORBTN = CM_BASE + WM_CTLCOLORBTN; - CM_CTLCOLORDLG = CM_BASE + WM_CTLCOLORDLG; - CM_CTLCOLOREDIT = CM_BASE + WM_CTLCOLOREDIT; - CM_CTLCOLORLISTBOX = CM_BASE + WM_CTLCOLORLISTBOX; - CM_CTLCOLORMSGBOX = CM_BASE + WM_CTLCOLORMSGBOX; - CM_CTLCOLORSCROLLBAR = CM_BASE + WM_CTLCOLORSCROLLBAR; - CM_CTLCOLORSTATIC = CM_BASE + WM_CTLCOLORSTATIC; - CM_SCROLLTRACKING = CM_BASE + 350; - CM_PARENTHOOKED = CM_BASE + 360; - CM_CONTROLHOOKED = CM_BASE + 361; - CM_INITCHILDS = CM_BASE + 362; - CM_CONTROLHOOKEDDIRECTLY = CM_BASE + 363; - -type - TBidiModeDirection = (bmLeftToRight, bmRightToLeft); - -type - TSysStyleHook = class; - TMouseTrackSysControlStyleHook = class; - TSysControl = class; - TSysStyleHookClass = class of TSysStyleHook; - -{$REGION 'TSysControl'} - - TSysControl = class - private - FFont: TFont; - FParent: TSysControl; - FHandle: THandle; - FWindowClassName : string; - FDestroyed : Boolean; - function GetParent: TSysControl; - function GetParentHandle: THandle; - function GetText: String; - function GetStyle: NativeInt; - function GetExStyle: NativeInt; - function GetWidth: Integer; - function GetHeight: Integer; - function GetLeft: Integer; - function GetTop: Integer; - function GetBorder: Boolean; - function GetEnabled: Boolean; - function GetVisible: Boolean; - function GetClientRect: TRect; - function GetWinRect: TRect; - function GetClientEdge: Boolean; - function GetControlClassName: String; - function GetWndProc: NativeInt; - procedure SetWndProc(Value: NativeInt); - function GetBidiMode: TBidiModeDirection; - procedure SetExStyle(const Value: NativeInt); - procedure SetStyle(const Value: NativeInt); - function GetControlID: Integer; - function GetBoundsRect: TRect; - function GetFont: TFont; - function IsControlChild: Boolean; - function GetClientHeight: Integer; - function GetClientWidth: Integer; - public - constructor Create(AHandle: THandle); virtual; - Destructor Destroy; override; - property ClientHeight: Integer read GetClientHeight; - property ClientWidth: Integer read GetClientWidth; - property Font: TFont read GetFont; - property Parent: TSysControl read GetParent; - property ParentHandle: THandle read GetParentHandle; - property Handle: THandle read FHandle write FHandle; - property Text: String read GetText; - property Style: NativeInt read GetStyle write SetStyle; - property ExStyle: NativeInt read GetExStyle write SetExStyle; - property Width: Integer read GetWidth; - property Height: Integer read GetHeight; - property Left: Integer read GetLeft; - property Top: Integer read GetTop; - property HasBorder: Boolean read GetBorder; - property Enabled: Boolean read GetEnabled; - property Visible: Boolean read GetVisible; - property ClientRect: TRect read GetClientRect; - property WindowRect: TRect read GetWinRect; - property HasClientEdge: Boolean read GetClientEdge; - property ControlClassName: string read GetControlClassName; - property WndProc: NativeInt read GetWndProc write SetWndProc; - property BidiMode: TBidiModeDirection read GetBidiMode; - property ControlID: Integer read GetControlID; - property BoundsRect: TRect read GetBoundsRect; - property IsChild: Boolean read IsControlChild; - property Destroyed : Boolean read FDestroyed write FDestroyed; //WM_DESTROY - function DrawTextBiDiModeFlags(const Flags: Longint): Longint; - function UseRightToLeftAlignment: Boolean; dynamic; - function DrawTextBiDiModeFlagsReadingOnly: Longint; - function UseRightToLeftReading: Boolean; - function Focused: Boolean; dynamic; - - end; -{$ENDREGION} -{$REGION 'TSysStyleHook'} - - TSysStyleHook = class - private - FHandle: HWND; - FProcInstance: Pointer; - FOrgWndProc: NativeInt; - FSysControl: TSysControl; - FOverrideEraseBkgnd: Boolean; - FOverridePaint: Boolean; - FOverridePaintNC: Boolean; - FOverrideFont: Boolean; - FDoubleBuffered: Boolean; - FPaintOnEraseBkgnd: Boolean; - FFontColor: TColor; - FBrush: TBrush; - FHandled: Boolean; - FParentColor: Boolean; -{$IF CompilerVersion > 23} - FStyleElements: TStyleElements; -{$IFEND} - FColor: TColor; - FFont: TFont; - FText: string; - FHookedDirectly, FMustRemove: Boolean; - procedure WMPaint(var Message: TMessage); message WM_PAINT; - procedure WMNCPaint(var Message: TMessage); message WM_NCPAINT; - procedure WMEraseBkgnd(var Message: TMessage); message WM_ERASEBKGND; -{$IF CompilerVersion > 23} - procedure SetStyleElements(Value: TStyleElements); -{$IFEND} - function GetFontColor: TColor; - function GetColor: TColor; - procedure SetColor(const Value: TColor); - procedure SetOverridePaint(const Value: Boolean); - function GetFocused: Boolean; - function GetParentHandle: HWND; - procedure SetFont(Value: TFont); - function UseLeftScrollBar: Boolean; - function GetText: string; - protected - function GetBorderSize: TRect; virtual; - function CheckIfParentBkGndPainted: Boolean; virtual; - function CheckIfParentHooked: Boolean; - procedure Paint(Canvas: TCanvas); virtual; - procedure DrawParentBackground(DC: HDC); overload; - procedure DrawParentBackground(DC: HDC; const ARect: PRect); overload; - procedure PaintBorder(Control: TSysControl; const EraseLRCorner: Boolean); - procedure DrawBorder(Canvas: TCanvas); virtual; - procedure PaintBackground(Canvas: TCanvas); virtual; - procedure PaintNC(Canvas: TCanvas); virtual; - function CallDefaultProc(var Msg: TMessage): LRESULT; - procedure SetRedraw(const Value: Boolean); overload; - procedure SetRedraw(AHandle: HWND; const Value: Boolean); overload; virtual; - function StyleServicesEnabled: Boolean; - procedure WndProc(var Message: TMessage); virtual; - function InternalPaint(DC: HDC): Boolean; virtual; - procedure UpdateColors; virtual; - function PaintControls(AControl: HWND; DC: HDC): Boolean; - property HookedDirectly: Boolean read FHookedDirectly write FHookedDirectly; - property MustRemove : Boolean read FMustRemove; - public - constructor Create(AHandle: THandle); virtual; - Destructor Destroy; override; - procedure Invalidate; virtual; - procedure InvalidateNC; virtual; - procedure Refresh; virtual; - procedure DrawControlText(Canvas: TCanvas; Details: TThemedElementDetails; const S: string; var R: TRect; const Flags: Cardinal); - function DrawTextCentered(DC: HDC; Details: TThemedElementDetails; const R: TRect; S: String; Const Flags: DWORD = 0): Integer; - function DrawText(DC: HDC; Details: TThemedElementDetails; S: String; var R: TRect; Const Flags: TTextFormat = []): Integer; - property Handle: HWND read FHandle; - property ParentHandle: HWND read GetParentHandle; - property Handled: Boolean read FHandled write FHandled; - property SysControl: TSysControl read FSysControl write FSysControl; -{$IF CompilerVersion > 23} - property StyleElements: TStyleElements read FStyleElements write SetStyleElements; -{$IFEND} - property DoubleBuffered: Boolean read FDoubleBuffered write FDoubleBuffered; - property OverridePaint: Boolean read FOverridePaint write SetOverridePaint; - property OverridePaintNC: Boolean read FOverridePaintNC write FOverridePaintNC; - property OverrideFont: Boolean read FOverrideFont write FOverrideFont; - property OverrideEraseBkgnd: Boolean read FOverrideEraseBkgnd write FOverrideEraseBkgnd; - property FontColor: TColor read GetFontColor write FFontColor; - property Color: TColor read GetColor write SetColor; - property Brush: TBrush read FBrush; - property Font: TFont read FFont write SetFont; - property Focused: Boolean read GetFocused; - property ParentBkGndPainted: Boolean read CheckIfParentBkGndPainted; - property ParentColor: Boolean read FParentColor write FParentColor; - property Text: string read GetText; - end; - -{$ENDREGION} -{$REGION 'TMouseTrackSysControlStyleHook'} - - TMouseTrackSysControlStyleHook = class(TSysStyleHook) - private - FMouseInControl: Boolean; - FMouseInNCArea: Boolean; - FHotTrackTimer: TComponent; - FMouseDown: Boolean; - procedure WMMouseMove(var Message: TWMMouse); message WM_MOUSEMOVE; - procedure WMNCMouseMove(var Message: TWMMouse); message WM_NCMOUSEMOVE; - procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN; - procedure WMLButtonUp(var Message: TWMLButtonUp); message WM_LBUTTONUP; - protected - procedure MouseEnter; virtual; - procedure MouseLeave; virtual; - function IsChildHandle(AHandle: HWND): Boolean; virtual; - procedure StartHotTrackTimer; - procedure StopHotTrackTimer; - procedure DoHotTrackTimer(Sender: TObject); virtual; - public - constructor Create(AHandle: THandle); override; - Destructor Destroy; override; - - property MouseInControl: Boolean read FMouseInControl write FMouseInControl; - property MouseInNCArea: Boolean read FMouseInNCArea write FMouseInNCArea; - property MouseDown: Boolean read FMouseDown; - - end; - -{$ENDREGION} - -function IsControlHooked(Handle: HWND): Boolean; - -implementation - -uses - System.UITypes, - Vcl.Styles.Utils.Misc, - Vcl.Styles.Utils.SysControls; - -// ------------------------------------------------------------------------------ - -function IsControlHooked(Handle: HWND): Boolean; -begin - { Return True if Control is already hooked ! } - Result := False; - if Handle > 0 then - Result := (SendMessage(Handle, CM_CONTROLHOOKED, 0, 0) = $77); -end; -// ------------------------------------------------------------------------------ - -{ TSysControl } -{$REGION 'TSysControl'} - -constructor TSysControl.Create(AHandle: THandle); -begin - inherited Create; - FFont := nil; - FParent := nil; - Handle := AHandle; - FWindowClassName := ''; - FDestroyed := False; -end; - -destructor TSysControl.Destroy; -begin - if Assigned(FParent) then - FreeAndNil(FParent); - if FFont <> nil then - FFont.Free; - inherited; -end; - -function TSysControl.DrawTextBiDiModeFlags(const Flags: Integer): Longint; -begin - Result := Flags; - { do not change center alignment } - if UseRightToLeftAlignment then - if Result and DT_RIGHT = DT_RIGHT then - Result := Result and not DT_RIGHT { removing DT_RIGHT, makes it DT_LEFT } - else if not(Result and DT_CENTER = DT_CENTER) then - Result := Result or DT_RIGHT; - Result := Result or DrawTextBiDiModeFlagsReadingOnly; -end; - -function TSysControl.DrawTextBiDiModeFlagsReadingOnly: Longint; -begin - if UseRightToLeftReading then - Result := DT_RTLREADING - else - Result := 0; -end; - -function TSysControl.Focused: Boolean; -begin - Result := (Handle <> 0) and (GetFocus = Handle); -end; - -function TSysControl.GetBidiMode: TBidiModeDirection; -begin - Result := bmLeftToRight; - if Style <> 0 then - if (ExStyle and WS_EX_RIGHT = WS_EX_RIGHT) or (ExStyle and WS_EX_RTLREADING = WS_EX_RTLREADING) or (ExStyle and WS_EX_LAYOUTRTL = WS_EX_LAYOUTRTL) then - Result := bmRightToLeft; -end; - -function TSysControl.GetBorder: Boolean; -begin - Result := (Style and WS_BORDER = WS_BORDER) or (ExStyle and WS_EX_CLIENTEDGE = WS_EX_CLIENTEDGE); -end; - -function TSysControl.GetBoundsRect: TRect; -begin - Result.Left := Left; - Result.Top := Top; - Result.Right := Left + Width; - Result.Bottom := Top + Height; -end; - -function TSysControl.GetClientEdge: Boolean; -begin - Result := ExStyle and WS_EX_CLIENTEDGE = WS_EX_CLIENTEDGE; -end; - -function TSysControl.GetClientHeight: Integer; -begin - Result := ClientRect.Bottom; -end; - -function TSysControl.GetClientRect: TRect; -begin - Result := Rect(0, 0, 0, 0); - Winapi.Windows.GetClientRect(Handle, Result); -end; - -function TSysControl.GetClientWidth: Integer; -begin - Result := ClientRect.Right; -end; - -function TSysControl.GetControlClassName: String; -begin - if FWindowClassName='' then - FWindowClassName := GetWindowClassName(Handle); - Result:=FWindowClassName; -end; - -function TSysControl.GetControlID: Integer; -begin - Result := GetWindowLongPtr(Handle, GWL_ID); -end; - -function TSysControl.GetEnabled: Boolean; -begin - Result := False; - if Handle > 0 then - Result := IsWindowEnabled(Handle); -end; - -function TSysControl.GetHeight: Integer; -begin - Result := WindowRect.Height; -end; - -function TSysControl.GetLeft: Integer; -begin - Result := WindowRect.Left; -end; - -function TSysControl.GetParent: TSysControl; -begin - Result := nil; - if Assigned(FParent) then - FreeAndNil(FParent); - if ParentHandle <> 0 then - begin - FParent := TSysControl.Create(ParentHandle); - Result := FParent; - end; -end; - -function TSysControl.GetParentHandle: THandle; -begin - Result := Winapi.Windows.GetParent(Handle); -end; - -function TSysControl.GetStyle: NativeInt; -begin - Result := GetWindowLongPtr(Handle, GWL_STYLE); -end; - -function TSysControl.GetExStyle: NativeInt; -begin - Result := GetWindowLongPtr(Handle, GWL_EXSTYLE); -end; - -function TSysControl.GetFont: TFont; -var - LogFont: TLogFont; - hFont: HGDIOBJ; -begin - if FFont <> nil then - Exit(FFont); - - hFont := HGDIOBJ(SendMessage(Handle, WM_GETFONT, 0, 0)); - Result := TFont.Create; - FillChar(LogFont, SizeOf(LogFont), 0); - GetObject(hFont, SizeOf(LogFont), @LogFont); - Result.Name := StrPas(LogFont.lffaceName); - Result.Height := LogFont.lfHeight; - if LogFont.lfWeight >= FW_MEDIUM then - Result.Style := Result.Style + [fsBold]; - if LogFont.lfItalic <> 0 then - Result.Style := Result.Style + [fsItalic]; - if LogFont.lfUnderline <> 0 then - Result.Style := Result.Style + [fsUnderline]; - if LogFont.lfStrikeout <> 0 then - Result.Style := Result.Style + [fsStrikeout]; - case (LogFont.lfPitchAndFamily and 3) of - VARIABLE_PITCH: Result.Pitch := fpVariable; - FIXED_PITCH: Result.Pitch := fpFixed; - end; - - FFont := Result; -end; - -function TSysControl.GetText: String; -var - Buffer: array [0 .. 1023] of Char; -begin - SetString(Result, Buffer, Winapi.Windows.GetWindowText(Handle, Buffer, Length(Buffer))); -end; - -function TSysControl.GetTop: Integer; -begin - Result := WindowRect.Top; -end; - -function TSysControl.GetVisible: Boolean; -begin - Result := IsWindowVisible(Handle); -end; - -function TSysControl.GetWidth: Integer; -begin - Result := WindowRect.Width; -end; - -function TSysControl.GetWinRect: TRect; -begin - Result := Rect(0, 0, 0, 0); - GetWindowRect(Handle, Result); -end; - -function TSysControl.GetWndProc: NativeInt; -begin - Result := GetWindowLongPtr(Handle, GWL_WNDPROC); -end; - -function TSysControl.IsControlChild: Boolean; -begin - Result := (Style and WS_CHILD = WS_CHILD); -end; - -procedure TSysControl.SetExStyle(const Value: NativeInt); -begin - SetWindowLongPtr(Handle, GWL_EXSTYLE, Value); -end; - -procedure TSysControl.SetStyle(const Value: NativeInt); -begin - SetWindowLongPtr(Handle, GWL_STYLE, Value); -end; - -procedure TSysControl.SetWndProc(Value: NativeInt); -begin - if Value <> WndProc then - SetWindowLongPtr(Handle, GWL_WNDPROC, Value); -end; - -function TSysControl.UseRightToLeftAlignment: Boolean; -begin - Result := SysLocale.MiddleEast and (BidiMode = TBidiModeDirection.bmRightToLeft); -end; - -function TSysControl.UseRightToLeftReading: Boolean; -begin - Result := SysLocale.MiddleEast and (BidiMode <> TBidiModeDirection.bmLeftToRight); -end; - -{$ENDREGION} -{ TSysStyleHook } -{$REGION 'TSysStyleHook'} - -constructor TSysStyleHook.Create(AHandle: THandle); -begin - FHandled := False; - FSysControl := nil; - FHandle := AHandle; - FOrgWndProc := 0; - FProcInstance := nil; - FBrush := nil; - FFont := TFont.Create; -{$IF CompilerVersion > 23} - StyleElements := []; -{$IFEND} - FMustRemove := False; - FParentColor := False; - FDoubleBuffered := False; - FPaintOnEraseBkgnd := False; - FHookedDirectly := False; - OverridePaint := False; - OverridePaintNC := False; - OverrideEraseBkgnd := False; - OverrideFont := False; - if AHandle > 0 then - begin - FProcInstance := MakeObjectInstance(WndProc); - FSysControl := TSysControl.Create(AHandle); - FOrgWndProc := FSysControl.WndProc; - // if FOrgWndProc > 0 then - begin - FSysControl.WndProc := LONG_PTR(FProcInstance); - FBrush := TBrush.Create; - UpdateColors; - end; - end; -end; - -destructor TSysStyleHook.Destroy; -begin - if FOrgWndProc <> 0 then - FSysControl.WndProc := FOrgWndProc; - - if Assigned(FProcInstance) then - FreeObjectInstance(FProcInstance); - - if Assigned(FSysControl) then - FreeAndNil(FSysControl); - - if Assigned(FBrush) then - FreeAndNil(FBrush); - - if Assigned(FFont) then - FreeAndNil(FFont); - - inherited; -end; - -function TSysStyleHook.CallDefaultProc(var Msg: TMessage): LRESULT; -begin - Result := 0; - try - if (FOrgWndProc <> 0) then - Result := CallWindowProc(Pointer(FOrgWndProc), Handle, Msg.Msg, Msg.wParam, Msg.lParam); - except - on e : exception do - OutputDebugString(PWideChar('CallDefaultProc error : ' + e.message + chr(0))); - end; -end; - -procedure TSysStyleHook.DrawBorder(Canvas: TCanvas); -var - BorderSize: TRect; -begin - BorderSize := GetBorderSize; - with BorderSize do - if (Left > 0) and (Right > 0) and (Top > 0) and (Bottom > 0) then - PaintBorder(SysControl, True); -end; - -procedure TSysStyleHook.DrawControlText(Canvas: TCanvas; Details: TThemedElementDetails; const S: string; var R: TRect; const Flags: Cardinal); -var - ThemeTextColor: TColor; - TextFormat: TTextFormatFlags; -begin - Canvas.Font := SysControl.Font; - TextFormat := TTextFormatFlags(Flags); - if StyleServices.GetElementColor(Details, ecTextColor, ThemeTextColor) then - begin - Canvas.Font.Color := ThemeTextColor; - StyleServices.DrawText(Canvas.Handle, Details, S, R, TextFormat, Canvas.Font.Color); - end - else - begin - Canvas.Refresh; - StyleServices.DrawText(Canvas.Handle, Details, S, R, TextFormat); - end; -end; - -procedure TSysStyleHook.DrawParentBackground(DC: HDC; const ARect: PRect); -var - Bmp: TBitmap; - P: TPoint; -begin - P := Point(0, 0); - if ARect <> nil then - P := Point(ARect.Left, ARect.Top); - - Bmp := TBitmap.Create; - try - Bmp.SetSize(SysControl.Parent.Width, SysControl.Parent.Height); - SendMessage(ParentHandle, WM_ERASEBKGND, Bmp.Canvas.Handle, $93); - ClientToScreen(Handle, P); - ScreenToClient(ParentHandle, P); - if ARect <> nil then - BitBlt(DC, ARect.Left, ARect.Top, ARect.Width, ARect.Height, Bmp.Canvas.Handle, P.X, P.Y, SRCCOPY) - else - BitBlt(DC, 0, 0, SysControl.Width, SysControl.Height, Bmp.Canvas.Handle, P.X, P.Y, SRCCOPY); - finally - Bmp.Free; - end; - -end; - -function TSysStyleHook.DrawText(DC: HDC; Details: TThemedElementDetails; S: String; var R: TRect; const Flags: TTextFormat): Integer; -var - DrawFlags: Cardinal; - SaveIndex: Integer; - LColor: TColor; -begin - SaveIndex := SaveDC(DC); - try - SetBkMode(DC, TRANSPARENT); - if not StyleServices.GetElementColor(Details, ecTextColor, LColor) then - LColor := FontColor; - if not OverrideFont then - LColor := FontColor; - SetTextColor(DC, ColorToRGB(LColor)); - DrawFlags := TTextFormatFlags(Flags); - Result := Winapi.Windows.DrawText(DC, S, -1, R, DrawFlags); - finally - RestoreDC(DC, SaveIndex); - end; -end; - -function TSysStyleHook.DrawTextCentered(DC: HDC; Details: TThemedElementDetails; const R: TRect; S: String; Const Flags: DWORD = 0): Integer; -var - DrawRect: TRect; - DrawFlags: Cardinal; - DrawParams: TDrawTextParams; - SaveIndex: Integer; - LColor: TColor; -begin - SaveIndex := SaveDC(DC); - try - SetBkMode(DC, TRANSPARENT); - if not StyleServices.GetElementColor(Details, ecTextColor, LColor) then - LColor := FontColor; - if not OverrideFont then - LColor := FontColor; - SetTextColor(DC, ColorToRGB(LColor)); - DrawRect := R; - DrawFlags := DT_END_ELLIPSIS or DT_WORDBREAK or DT_EDITCONTROL or DT_CENTER; - if DrawFlags <> 0 then - DrawFlags := DrawFlags or Flags; - - Winapi.Windows.DrawText(DC, PChar(S), -1, DrawRect, DrawFlags or DT_CALCRECT); - DrawRect.Right := R.Right; - if DrawRect.Bottom < R.Bottom then - OffsetRect(DrawRect, 0, (R.Bottom - DrawRect.Bottom) div 2) - else - DrawRect.Bottom := R.Bottom; - ZeroMemory(@DrawParams, SizeOf(DrawParams)); - DrawParams.cbSize := SizeOf(DrawParams); - DrawTextEx(DC, PChar(S), -1, DrawRect, DrawFlags, @DrawParams); - Result := DrawParams.uiLengthDrawn; - finally - RestoreDC(DC, SaveIndex); - end; -end; - -function TSysStyleHook.GetFocused: Boolean; -begin - Result := (GetFocus = Handle); -end; - -function TSysStyleHook.GetBorderSize: TRect; -begin - Result := Rect(0, 0, 0, 0); -end; - -function TSysStyleHook.GetColor: TColor; -begin - // if OverrideEraseBkgnd then - // Result := StyleServices.GetStyleColor(scWindow) - // else - Result := FColor; -end; - -function TSysStyleHook.GetFontColor: TColor; -begin - // if OverrideFont then - // Result := StyleServices.GetSystemColor(clWindowText) - // else - Result := FFontColor; -end; - -function TSysStyleHook.GetParentHandle: HWND; -begin - Result := GetParent(Handle); -end; - -function TSysStyleHook.GetText: string; -var - Buffer: array [0 .. 255] of Char; -begin - if (Handle <> 0) then - SetString(Result, Buffer, Winapi.Windows.GetWindowText(Handle, Buffer, Length(Buffer))); - FText := Result; -end; - -function TSysStyleHook.InternalPaint(DC: HDC): Boolean; -begin - Result := False; -end; - -procedure TSysStyleHook.SetColor(const Value: TColor); -begin - if (FBrush <> nil) and ((Value <> FColor) or (Value <> FBrush.Color)) then - begin - FColor := Value; - FBrush.Color := Value; - end; -end; - -procedure TSysStyleHook.SetFont(Value: TFont); -begin - if Value <> FFont then - FFont.Assign(Value); -end; - -procedure TSysStyleHook.SetOverridePaint(const Value: Boolean); -begin - if Value then - OverrideEraseBkgnd := Value; - FOverridePaint := Value; -end; - -procedure TSysStyleHook.SetRedraw(AHandle: HWND; const Value: Boolean); -begin - SendMessage(AHandle, WM_SETREDRAW, wParam(Value), 0); -end; - -procedure TSysStyleHook.SetRedraw(const Value: Boolean); -begin - SetRedraw(Handle, Value); -end; - -{$IF CompilerVersion > 23} - -procedure TSysStyleHook.SetStyleElements(Value: TStyleElements); -begin - if Value <> FStyleElements then - begin - FStyleElements := Value; - OverridePaint := (seClient in FStyleElements); - // OverrideEraseBkgnd := OverridePaint; - OverridePaintNC := (seBorder in FStyleElements); - OverrideFont := (seFont in FStyleElements); - end; -end; -{$IFEND} - -function TSysStyleHook.StyleServicesEnabled: Boolean; -begin - Result := (StyleServices.Available) and not(StyleServices.IsSystemStyle); - if Result then - if not TSysStyleManager.HookVclControls then - Result := not(IsVCLControl(Handle)); -end; - -procedure TSysStyleHook.UpdateColors; -begin - if (OverrideEraseBkgnd) or (OverridePaint) then - Color := StyleServices.GetStyleColor(scWindow) - else - Color := clBtnFace; - if OverrideFont then - FontColor := StyleServices.GetSystemColor(clWindowText) - else - FontColor := clBlack; -end; - -function TSysStyleHook.UseLeftScrollBar: Boolean; -begin - Result := (SysControl.ExStyle and WS_EX_LEFTSCROLLBAR = WS_EX_LEFTSCROLLBAR) -end; - -procedure TSysStyleHook.Invalidate; -begin - if FOverridePaintNC then - InvalidateNC; - InvalidateRect(Handle, nil, False); -end; - -procedure TSysStyleHook.InvalidateNC; -begin - SendMessage(Handle, WM_NCPAINT, 0, 0); -end; - -procedure TSysStyleHook.Paint(Canvas: TCanvas); -begin - // -end; - -procedure TSysStyleHook.PaintBackground(Canvas: TCanvas); -begin - Canvas.Brush.Color := Color; - Canvas.FillRect(SysControl.ClientRect); -end; - -procedure TSysStyleHook.PaintBorder(Control: TSysControl; const EraseLRCorner: Boolean); -var - EmptyRect, DrawRect: TRect; - DC: HDC; - H, W: Integer; - AStyle: Integer; - Details: TThemedElementDetails; - BorderSize: TRect; -begin - BorderSize := GetBorderSize; - Control.ExStyle := GetWindowLong(Handle, GWL_EXSTYLE); - if (Control.ExStyle and WS_EX_CLIENTEDGE) <> 0 then - begin - GetWindowRect(Control.Handle, DrawRect); - OffsetRect(DrawRect, -DrawRect.Left, -DrawRect.Top); - DC := GetWindowDC(Control.Handle); - try - EmptyRect := DrawRect; - if EraseLRCorner then - begin - AStyle := GetWindowLong(Control.Handle, GWL_STYLE); - if ((AStyle and WS_HSCROLL) <> 0) and ((AStyle and WS_VSCROLL) <> 0) then - begin - W := GetSystemMetrics(SM_CXVSCROLL); - H := GetSystemMetrics(SM_CYHSCROLL); - InflateRect(EmptyRect, -2, -2); - with EmptyRect do - if not UseLeftScrollBar then - EmptyRect := Rect(Left, Bottom - H, Left + W, Bottom) - else - EmptyRect := Rect(Right - W, Bottom - H, Right, Bottom); - FillRect(DC, EmptyRect, GetSysColorBrush(COLOR_BTNFACE)); - end; - end; - with DrawRect do - ExcludeClipRect(DC, Left + BorderSize.Left, Top + BorderSize.Top, Right - BorderSize.Right, Bottom - BorderSize.Bottom); - Details := StyleServices.GetElementDetails(teEditTextNormal); - StyleServices.DrawElement(DC, Details, DrawRect); - finally - ReleaseDC(Control.Handle, DC); - end; - end; -end; - -function TSysStyleHook.PaintControls(AControl: HWND; DC: HDC): Boolean; -var - Child: HWND; - SavedDC: HDC; - SysChild: TSysControl; - P: TPoint; - FrameBrush: HBRUSH; -begin - Result := False; - Child := GetTopWindow(AControl); - while Child <> 0 do - begin - Result := True; - SysChild := TSysControl.Create(Child); - with SysChild do - begin - SavedDC := SaveDC(DC); - P := Point(Left, Top); - ScreenToClient(ParentHandle, P); - if Visible and IsChild and RectVisible(DC, Rect(P.X, P.Y, P.X + Width, P.Y + Height)) then - begin - MoveWindowOrg(DC, P.X, P.Y); - IntersectClipRect(DC, 0, 0, Width, Height); - SendMessage(Child, WM_PAINT, lParam(DC), 0); - if SysChild.HasBorder then - begin - // SendMessage(Child, WM_NCPAINT, 0, 0); - FrameBrush := CreateSolidBrush(ColorToRGB(clBtnShadow)); - FrameRect(DC, System.Types.Rect(0, 0, Width, Height), FrameBrush); - DeleteObject(FrameBrush); - FrameBrush := CreateSolidBrush(ColorToRGB(clBtnHighlight)); - FrameRect(DC, System.Types.Rect(0, 0, Width + 1, Height + 1), FrameBrush); - DeleteObject(FrameBrush); - end; - end; - FreeAndNil(SysChild); - PaintControls(Child, DC); - RestoreDC(DC, SavedDC); - Child := GetNextWindow(Child, GW_HWNDNEXT); - end; - end; -end; - -procedure TSysStyleHook.PaintNC(Canvas: TCanvas); -begin - -end; - -procedure TSysStyleHook.DrawParentBackground(DC: HDC); -begin - DrawParentBackground(DC, nil); -end; - -procedure TSysStyleHook.Refresh; -begin - SendMessage(Handle, WM_PAINT, 0, 0); -end; - -procedure TSysStyleHook.WMEraseBkgnd(var Message: TMessage); -var - DC: HDC; - Canvas: TCanvas; - SaveIndex: Integer; -begin - Handled := False; - - if not StyleServicesEnabled then - Exit; - - UpdateColors; - - if FOverrideEraseBkgnd then - begin - if not FDoubleBuffered then - begin - DC := HDC(Message.wParam); - - SaveIndex := 0; - if DC = 0 then - DC := GetDC(Handle) - else - SaveIndex := SaveDC(DC); - - Canvas := TCanvas.Create; - try - Canvas.Handle := DC; - if Assigned(FFont) then - Canvas.Font.Assign(FFont); - - if (FParentColor) and (ParentHandle > 0) then - DrawParentBackground(Canvas.Handle) - else - PaintBackground(Canvas); - - if (FPaintOnEraseBkgnd) and (Message.lParam <> $93) then - Paint(Canvas); - finally - Canvas.Handle := 0; - Canvas.Free; - if Message.wParam = 0 then - ReleaseDC(Handle, DC) - else if SaveIndex <> 0 then - RestoreDC(DC, SaveIndex); - end; - end; - Handled := True; - Message.Result := 1; - end; -end; - -function TSysStyleHook.CheckIfParentBkGndPainted: Boolean; -var - Test: Integer; - PTest: PInteger; - LParentHandle: HWND; -begin - //Exit(True); - Test := $93; - PTest := @Test; - Result := False; - LParentHandle := GetParent(Handle); - if LParentHandle > 0 then - begin - if not IsControlHooked(LParentHandle) then - Exit(False); - SendMessage(LParentHandle, WM_ERASEBKGND, 0, lParam(PTest)); - Result := (PTest^ = $11); - end; -end; - -function TSysStyleHook.CheckIfParentHooked: Boolean; -begin - Result := (SendMessage(ParentHandle, CM_PARENTHOOKED, 0, 0) = $77); -end; - -procedure TSysStyleHook.WMNCPaint(var Message: TMessage); -var - Canvas: TCanvas; -begin - Handled := False; - if not StyleServicesEnabled then - Exit; - - if FOverridePaintNC then - begin - Canvas := TCanvas.Create; - try - Canvas.Handle := GetWindowDC(SysControl.Handle); - if Assigned(FFont) then - Canvas.Font.Assign(FFont); - DrawBorder(Canvas); - PaintNC(Canvas); - finally - ReleaseDC(Handle, Canvas.Handle); - Canvas.Handle := 0; - Canvas.Free; - end; - Handled := True; - end; -end; - -procedure TSysStyleHook.WMPaint(var Message: TMessage); -var - OrgDC, DC: HDC; - Buffer: TBitmap; - Canvas: TCanvas; - PS: TPaintStruct; - - function ClipControls(AControl: HWND; Siblings: Boolean): Boolean; - var - Child: HWND; - SysChild: TSysControl; - P: TPoint; - begin - Result := False; - SysChild := nil; - Child := GetTopWindow(AControl); - if GetParent(Child) = Handle then - while Child <> 0 do - begin - Result := True; - SysChild := TSysControl.Create(Child); - with SysChild, P do - begin - P := Point(Left, Top); - ScreenToClient(Self.Handle, P); - if Visible and IsChild and RectVisible(DC, Rect(X, Y, X + Width, Y + Height)) then - begin - ExcludeClipRect(DC, X, Y, X + Width, Y + Height); - end; - FreeAndNil(SysChild); - if Siblings then - ClipControls(Child, Siblings); - Child := GetNextWindow(Child, GW_HWNDNEXT); - end; - end; - if Assigned(SysChild) then - FreeAndNil(SysChild); - end; - - function DoClipControls: Boolean; - begin - Result := False; - if SysControl.Style and WS_CLIPSIBLINGS = WS_CLIPSIBLINGS then - Result := ClipControls(Handle, True) - else if SysControl.Style and WS_CLIPCHILDREN = WS_CLIPCHILDREN then - Result := ClipControls(Handle, False); - end; - -begin - Handled := False; - if not StyleServicesEnabled then - Exit; - - if OverridePaint then - begin - OrgDC := HDC(Message.wParam); - Canvas := TCanvas.Create; - try - - if OrgDC <> 0 then - begin - Canvas.Handle := OrgDC; - DC:= OrgDC; - end - else - begin - DC := GetDC(Handle); - BeginPaint(SysControl.Handle, PS); - Canvas.Handle := DC; - end; - - if Assigned(FFont) then - Canvas.Font.Assign(FFont); - - if not InternalPaint(Canvas.Handle) then - if FDoubleBuffered and (DC = 0) then - begin - Buffer := TBitmap.Create; - try - Buffer.SetSize(SysControl.Width, SysControl.Height); - DoClipControls; - PaintBackground(Buffer.Canvas); - Paint(Buffer.Canvas); - // PaintControls(Handle,Canvas.Handle); - Canvas.Draw(0, 0, Buffer); - finally - Buffer.Free; - end; - end - else - begin - DoClipControls; - Paint(Canvas); - // PaintControls(Handle,Canvas.Handle); - end; - - if OrgDC = 0 then - begin - ReleaseDC(SysControl.Handle, DC); - EndPaint(SysControl.Handle, PS); - end; - - finally - Canvas.Handle := 0; - Canvas.Free; - end; - Handled := True; - end; - -end; - - -procedure TSysStyleHook.WndProc(var Message: TMessage); -var - TempResult: LRESULT; - ChildHandle: HWND; - ItemRemoved : Boolean; -begin - case Message.Msg of - - CM_CONTROLHOOKEDDIRECTLY: - begin - { Child controls are not hooked inside the parent . } - FHookedDirectly := True; - Exit; - end; - - CM_INITCHILDS: - begin - Message.Result := 0; - with TSysStyleManager do - begin - for ChildHandle in ChildRegSysStylesList.Keys do - if (not IsControlHooked(ChildHandle)) and (ChildRegSysStylesList[ChildHandle].Parent = Handle) then - begin - if not SysStyleHookList.ContainsKey(ChildHandle) then - begin - SysStyleHookList.Add(ChildHandle, ChildRegSysStylesList[ChildHandle].StyleHookClass.Create(ChildHandle)); - { Child control need to be repainted . } - RedrawWindow(ChildHandle, nil, 0, RDW_ERASE or RDW_FRAME or RDW_INTERNALPAINT or RDW_INVALIDATE); - { Send WM_NCCALCSIZE message to the child control . } - SetWindowPos(ChildHandle, 0, 0, 0, 0, 0, SWP_NOSIZE or SWP_NOMOVE or SWP_NOZORDER or SWP_FRAMECHANGED); - Message.Result := 1; - end; - end; - end; - Exit; - end; - - CM_PARENTHOOKED, CM_CONTROLHOOKED: - begin - Message.Result := $77; - Exit; - end; - - WM_CHANGEUISTATE, WM_PARENTNOTIFY, WM_QUERYUISTATE: - begin - CallDefaultProc(Message); - { - Do not Send ===> Use Post - Return first then hook child ! - } - PostMessage(Handle, CM_INITCHILDS, 0, 0); - Exit; - end; - - WM_ERASEBKGND: - begin - if (Message.lParam > 0) and (Message.wParam = 0) and (FOverrideEraseBkgnd or FOverridePaint or FPaintOnEraseBkgnd) then - if PInteger(Message.lParam)^ = $93 then - begin - { lParam = Result - if (lParam=$11) then Parent background was painted . - } - PInteger(Message.lParam)^ := $11; - { Do not process the default message .. - this is only for test !! . - } - Exit; { Do not Dispatch . } - end; - end; - - WM_SETREDRAW: - begin - Message.Result := CallDefaultProc(Message); - Dispatch(Message); - Exit; - end; - - WM_CTLCOLORMSGBOX .. WM_CTLCOLORSTATIC: - begin - // avoid use cuurent style colors on ignored controls - if (not StyleServicesEnabled) or (not TSysStyleManager.UseStyleColorsChildControls and (not TSysStyleManager.SysStyleHookList.ContainsKey(Message.lParam))) then - // if (not StyleServicesEnabled) then - begin - Message.Result := CallDefaultProc(Message); - Exit; - end; - - TempResult := SendMessage(Handle, CM_BASE + Message.Msg, Message.wParam, Message.lParam); - Message.Result := SendMessage(Message.lParam, CM_BASE + Message.Msg, Message.wParam, Message.lParam); - if Message.Result = 0 then - Message.Result := TempResult; - Exit; - end; - - CM_CTLCOLORMSGBOX .. CM_CTLCOLORSTATIC: - begin - SetTextColor(Message.wParam, ColorToRGB(FontColor)); - SetBkColor(Message.wParam, ColorToRGB(FBrush.Color)); - Message.Result := LRESULT(FBrush.Handle); - Exit; - end; - - WM_DESTROY: - begin - Message.Result := CallDefaultProc(Message); - Dispatch(Message); - Exit; - end; - - //The WM_NCDESTROY message is sent after the child windows have been destroyed. - //In contrast, WM_DESTROY is sent before the child windows are destroyed. - WM_NCDESTROY: - begin - Message.Result := CallDefaultProc(Message); - ItemRemoved:=False; - if TSysStyleManager.SysStyleHookList.ContainsKey(FHandle) then - begin -// OutputDebugString(PChar('SysStyleHookList WM_NCDESTROY Removed '+IntToHex(Handle, 8))); -// TSysStyleManager.SysStyleHookList.Remove(FHandle); - FMustRemove:=True; - ItemRemoved:=True; - end; - - if not ItemRemoved and TSysStyleManager.ChildRegSysStylesList.ContainsKey(FHandle) then - begin - TSysStyleManager.ChildRegSysStylesList.Remove(Handle); - //OutputDebugString(PChar('ChildRegSysStylesList WM_NCDESTROY Removed '+IntToHex(Handle, 8))); - end; - - for ChildHandle in TSysStyleManager.ChildRegSysStylesList.Keys do - if (TSysStyleManager.ChildRegSysStylesList[ChildHandle].Parent = FHandle) then - begin - TSysStyleManager.ChildRegSysStylesList.Remove(ChildHandle); - //OutputDebugString(PChar('Sub ChildRegSysStylesList WM_NCDESTROY Removed '+IntToHex(ChildHandle, 8))); - end; - Exit; - end; - - end; - - Dispatch(Message); - if not Handled then - Message.Result := CallDefaultProc(Message); - Handled := False; -end; -{$ENDREGION} -{ TMouseTrackSysControlStyleHook } -{$REGION 'TMouseTrackSysControlStyleHook'} - -constructor TMouseTrackSysControlStyleHook.Create(AHandle: THandle); -begin - inherited; - FMouseInControl := False; - FMouseInNCArea := False; - FHotTrackTimer := nil; -end; - -destructor TMouseTrackSysControlStyleHook.Destroy; -begin - if Assigned(FHotTrackTimer) then - FreeAndNil(FHotTrackTimer); - - inherited; -end; - -procedure TMouseTrackSysControlStyleHook.WMLButtonDown(var Message: TWMLButtonDown); -begin - FMouseDown := True; - inherited; -end; - -procedure TMouseTrackSysControlStyleHook.WMLButtonUp(var Message: TWMLButtonUp); -begin - FMouseDown := False; - inherited; -end; - -procedure TMouseTrackSysControlStyleHook.WMMouseMove(var Message: TWMMouse); -begin - inherited; - if not FMouseInControl and not FMouseInNCArea then - begin - FMouseInControl := True; - StartHotTrackTimer; - MouseEnter; - end - else if FMouseInNCArea and FMouseInControl then - begin - StopHotTrackTimer; - FMouseInControl := False; - MouseLeave; - end; -end; - -procedure TMouseTrackSysControlStyleHook.WMNCMouseMove(var Message: TWMMouse); -begin - inherited; - if not FMouseInControl then - begin - FMouseInControl := True; - StartHotTrackTimer; - MouseEnter; - end; -end; - -procedure TMouseTrackSysControlStyleHook.StartHotTrackTimer; -begin - if FHotTrackTimer <> nil then - StopHotTrackTimer; - FHotTrackTimer := TTimer.Create(nil); - TTimer(FHotTrackTimer).Interval := 100; - TTimer(FHotTrackTimer).OnTimer := DoHotTrackTimer; - TTimer(FHotTrackTimer).Enabled := True; - -end; - -procedure TMouseTrackSysControlStyleHook.StopHotTrackTimer; -begin - if FHotTrackTimer <> nil then - begin - TTimer(FHotTrackTimer).Enabled := False; - FreeAndNil(FHotTrackTimer); - end; -end; - -function TMouseTrackSysControlStyleHook.IsChildHandle(AHandle: HWND): Boolean; -begin - Result := False; -end; - -procedure TMouseTrackSysControlStyleHook.DoHotTrackTimer(Sender: TObject); -var - P: TPoint; - FWindowHandle: HWND; -begin - GetCursorPos(P); - FWindowHandle := WindowFromPoint(P); - if (FWindowHandle <> Handle) and not IsChildHandle(FWindowHandle) then - begin - StopHotTrackTimer; - FMouseInControl := False; - MouseLeave; - end; -end; - -procedure TMouseTrackSysControlStyleHook.MouseEnter; -begin - -end; - -procedure TMouseTrackSysControlStyleHook.MouseLeave; -begin - -end; -{$ENDREGION} - -end. +// ************************************************************************************************** +// +// Unit Vcl.Styles.SysStyleHook +// unit for the VCL Styles Utils +// https://github.com/RRUZ/vcl-styles-utils/ +// +// 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. +// +// The Original Code is uSysStyleHook.pas. +// +// Portions created by Mahdi Safsafi [SMP3] e-mail SMP@LIVE.FR +// Portions created by Rodrigo Ruz V. are Copyright (C) 2013-2023 Rodrigo Ruz V. +// All Rights Reserved. +// +// ************************************************************************************************** +unit Vcl.Styles.Utils.SysStyleHook; + +interface + +uses + System.Classes, + System.Types, + System.SysUtils, + Winapi.Windows, + Winapi.Messages, + Winapi.UxTheme, + Winapi.CommCtrl, + Vcl.Themes, + Vcl.ExtCtrls, + Vcl.Controls, + Vcl.Graphics; + +const + CM_BASE = WM_USER + $113; + CM_CTLCOLORBTN = CM_BASE + WM_CTLCOLORBTN; + CM_CTLCOLORDLG = CM_BASE + WM_CTLCOLORDLG; + CM_CTLCOLOREDIT = CM_BASE + WM_CTLCOLOREDIT; + CM_CTLCOLORLISTBOX = CM_BASE + WM_CTLCOLORLISTBOX; + CM_CTLCOLORMSGBOX = CM_BASE + WM_CTLCOLORMSGBOX; + CM_CTLCOLORSCROLLBAR = CM_BASE + WM_CTLCOLORSCROLLBAR; + CM_CTLCOLORSTATIC = CM_BASE + WM_CTLCOLORSTATIC; + CM_SCROLLTRACKING = CM_BASE + 350; + CM_PARENTHOOKED = CM_BASE + 360; + CM_CONTROLHOOKED = CM_BASE + 361; + CM_INITCHILDS = CM_BASE + 362; + CM_CONTROLHOOKEDDIRECTLY = CM_BASE + 363; + +type + TBidiModeDirection = (bmLeftToRight, bmRightToLeft); + +type + TSysStyleHook = class; + TMouseTrackSysControlStyleHook = class; + TSysControl = class; + TSysStyleHookClass = class of TSysStyleHook; + +{$REGION 'TSysControl'} + + TSysControl = class + private + FFont: TFont; + FParent: TSysControl; + FHandle: THandle; + FWindowClassName: string; + FDestroyed: Boolean; + function GetParent: TSysControl; + function GetParentHandle: THandle; + function GetText: String; + function GetStyle: NativeInt; + function GetExStyle: NativeInt; + function GetWidth: Integer; + function GetHeight: Integer; + function GetLeft: Integer; + function GetTop: Integer; + function GetBorder: Boolean; + function GetEnabled: Boolean; + function GetVisible: Boolean; + function GetClientRect: TRect; + function GetWinRect: TRect; + function GetClientEdge: Boolean; + function GetControlClassName: String; + function GetWndProc: NativeInt; + procedure SetWndProc(Value: NativeInt); + function GetBidiMode: TBidiModeDirection; + procedure SetExStyle(const Value: NativeInt); + procedure SetStyle(const Value: NativeInt); + function GetControlID: Integer; + function GetBoundsRect: TRect; + function GetFont: TFont; + function IsControlChild: Boolean; + function GetClientHeight: Integer; + function GetClientWidth: Integer; + public + constructor Create(AHandle: THandle); virtual; + Destructor Destroy; override; + property ClientHeight: Integer read GetClientHeight; + property ClientWidth: Integer read GetClientWidth; + property Font: TFont read GetFont; + property Parent: TSysControl read GetParent; + property ParentHandle: THandle read GetParentHandle; + property Handle: THandle read FHandle write FHandle; + property Text: String read GetText; + property Style: NativeInt read GetStyle write SetStyle; + property ExStyle: NativeInt read GetExStyle write SetExStyle; + property Width: Integer read GetWidth; + property Height: Integer read GetHeight; + property Left: Integer read GetLeft; + property Top: Integer read GetTop; + property HasBorder: Boolean read GetBorder; + property Enabled: Boolean read GetEnabled; + property Visible: Boolean read GetVisible; + property ClientRect: TRect read GetClientRect; + property WindowRect: TRect read GetWinRect; + property HasClientEdge: Boolean read GetClientEdge; + property ControlClassName: string read GetControlClassName; + property WndProc: NativeInt read GetWndProc write SetWndProc; + property BidiMode: TBidiModeDirection read GetBidiMode; + property ControlID: Integer read GetControlID; + property BoundsRect: TRect read GetBoundsRect; + property IsChild: Boolean read IsControlChild; + property Destroyed: Boolean read FDestroyed write FDestroyed; //WM_DESTROY + function DrawTextBiDiModeFlags(const Flags: Longint): Longint; + function UseRightToLeftAlignment: Boolean; dynamic; + function DrawTextBiDiModeFlagsReadingOnly: Longint; + function UseRightToLeftReading: Boolean; + function Focused: Boolean; dynamic; + + end; +{$ENDREGION} +{$REGION 'TSysStyleHook'} + + TSysStyleHook = class + private + FHandle: HWND; + FProcInstance: Pointer; + FOrgWndProc: NativeInt; + FSysControl: TSysControl; + FOverrideEraseBkgnd: Boolean; + FOverridePaint: Boolean; + FOverridePaintNC: Boolean; + FOverrideFont: Boolean; + FDoubleBuffered: Boolean; + FPaintOnEraseBkgnd: Boolean; + FFontColor: TColor; + FBrush: TBrush; + FHandled: Boolean; + FParentColor: Boolean; +{$IF CompilerVersion > 23} + FStyleElements: TStyleElements; +{$IFEND} + FColor: TColor; + FFont: TFont; + FText: string; + FHookedDirectly, FMustRemove: Boolean; + procedure WMPaint(var Message: TMessage); message WM_PAINT; + procedure WMNCPaint(var Message: TMessage); message WM_NCPAINT; + procedure WMEraseBkgnd(var Message: TMessage); message WM_ERASEBKGND; +{$IF CompilerVersion > 23} + procedure SetStyleElements(Value: TStyleElements); +{$IFEND} + function GetFontColor: TColor; + function GetColor: TColor; + procedure SetColor(const Value: TColor); + procedure SetOverridePaint(const Value: Boolean); + function GetFocused: Boolean; + function GetParentHandle: HWND; + procedure SetFont(Value: TFont); + function UseLeftScrollBar: Boolean; + function GetText: string; + protected + function GetBorderSize: TRect; virtual; + function CheckIfParentBkGndPainted: Boolean; virtual; + function CheckIfParentHooked: Boolean; + procedure Paint(Canvas: TCanvas); virtual; + procedure DrawParentBackground(DC: HDC); overload; + procedure DrawParentBackground(DC: HDC; const ARect: PRect); overload; + procedure PaintBorder(Control: TSysControl; const EraseLRCorner: Boolean); + procedure DrawBorder(Canvas: TCanvas); virtual; + procedure PaintBackground(Canvas: TCanvas); virtual; + procedure PaintNC(Canvas: TCanvas); virtual; + function CallDefaultProc(var Msg: TMessage): LRESULT; + procedure SetRedraw(const Value: Boolean); overload; + procedure SetRedraw(AHandle: HWND; const Value: Boolean); overload; virtual; + function StyleServicesEnabled: Boolean; + procedure WndProc(var Message: TMessage); virtual; + function InternalPaint(DC: HDC): Boolean; virtual; + procedure UpdateColors; virtual; + function PaintControls(AControl: HWND; DC: HDC): Boolean; + property HookedDirectly: Boolean read FHookedDirectly write FHookedDirectly; + property MustRemove: Boolean read FMustRemove; + public + constructor Create(AHandle: THandle); virtual; + Destructor Destroy; override; + procedure Invalidate; virtual; + procedure InvalidateNC; virtual; + procedure Refresh; virtual; + procedure DrawControlText(Canvas: TCanvas; Details: TThemedElementDetails; const S: string; var R: TRect; const Flags: Cardinal); + function DrawTextCentered(DC: HDC; Details: TThemedElementDetails; const R: TRect; S: String; Const Flags: DWORD = 0): Integer; + function DrawText(DC: HDC; Details: TThemedElementDetails; S: String; var R: TRect; Const Flags: TTextFormat = []): Integer; + property Handle: HWND read FHandle; + property ParentHandle: HWND read GetParentHandle; + property Handled: Boolean read FHandled write FHandled; + property SysControl: TSysControl read FSysControl write FSysControl; +{$IF CompilerVersion > 23} + property StyleElements: TStyleElements read FStyleElements write SetStyleElements; +{$IFEND} + property DoubleBuffered: Boolean read FDoubleBuffered write FDoubleBuffered; + property OverridePaint: Boolean read FOverridePaint write SetOverridePaint; + property OverridePaintNC: Boolean read FOverridePaintNC write FOverridePaintNC; + property OverrideFont: Boolean read FOverrideFont write FOverrideFont; + property OverrideEraseBkgnd: Boolean read FOverrideEraseBkgnd write FOverrideEraseBkgnd; + property FontColor: TColor read GetFontColor write FFontColor; + property Color: TColor read GetColor write SetColor; + property Brush: TBrush read FBrush; + property Font: TFont read FFont write SetFont; + property Focused: Boolean read GetFocused; + property ParentBkGndPainted: Boolean read CheckIfParentBkGndPainted; + property ParentColor: Boolean read FParentColor write FParentColor; + property Text: string read GetText; + end; + +{$ENDREGION} +{$REGION 'TMouseTrackSysControlStyleHook'} + + TMouseTrackSysControlStyleHook = class(TSysStyleHook) + private + FMouseInControl: Boolean; + FMouseInNCArea: Boolean; + FHotTrackTimer: TComponent; + FMouseDown: Boolean; + procedure WMMouseMove(var Message: TWMMouse); message WM_MOUSEMOVE; + procedure WMNCMouseMove(var Message: TWMMouse); message WM_NCMOUSEMOVE; + procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN; + procedure WMLButtonUp(var Message: TWMLButtonUp); message WM_LBUTTONUP; + protected + procedure MouseEnter; virtual; + procedure MouseLeave; virtual; + function IsChildHandle(AHandle: HWND): Boolean; virtual; + procedure StartHotTrackTimer; + procedure StopHotTrackTimer; + procedure DoHotTrackTimer(Sender: TObject); virtual; + public + constructor Create(AHandle: THandle); override; + Destructor Destroy; override; + + property MouseInControl: Boolean read FMouseInControl write FMouseInControl; + property MouseInNCArea: Boolean read FMouseInNCArea write FMouseInNCArea; + property MouseDown: Boolean read FMouseDown; + + end; + +{$ENDREGION} + +function IsControlHooked(Handle: HWND): Boolean; + +implementation + +uses + System.UITypes, + Vcl.Styles.Utils.Misc, + Vcl.Styles.Utils.SysControls; + +// ------------------------------------------------------------------------------ + +function IsControlHooked(Handle: HWND): Boolean; +begin + { Return True if Control is already hooked ! } + Result := False; + if Handle > 0 then + Result := (SendMessage(Handle, CM_CONTROLHOOKED, 0, 0) = $77); +end; +// ------------------------------------------------------------------------------ + +{ TSysControl } +{$REGION 'TSysControl'} + +constructor TSysControl.Create(AHandle: THandle); +begin + inherited Create; + FFont := nil; + FParent := nil; + Handle := AHandle; + FWindowClassName := ''; + FDestroyed := False; +end; + +destructor TSysControl.Destroy; +begin + if Assigned(FParent) then + FreeAndNil(FParent); + if FFont <> nil then + FFont.Free; + inherited; +end; + +function TSysControl.DrawTextBiDiModeFlags(const Flags: Integer): Longint; +begin + Result := Flags; + { do not change center alignment } + if UseRightToLeftAlignment then + if Result and DT_RIGHT = DT_RIGHT then + Result := Result and not DT_RIGHT { removing DT_RIGHT, makes it DT_LEFT } + else if not(Result and DT_CENTER = DT_CENTER) then + Result := Result or DT_RIGHT; + Result := Result or DrawTextBiDiModeFlagsReadingOnly; +end; + +function TSysControl.DrawTextBiDiModeFlagsReadingOnly: Longint; +begin + if UseRightToLeftReading then + Result := DT_RTLREADING + else + Result := 0; +end; + +function TSysControl.Focused: Boolean; +begin + Result := (Handle <> 0) and (GetFocus = Handle); +end; + +function TSysControl.GetBidiMode: TBidiModeDirection; +begin + Result := bmLeftToRight; + if Style <> 0 then + if (ExStyle and WS_EX_RIGHT = WS_EX_RIGHT) or (ExStyle and WS_EX_RTLREADING = WS_EX_RTLREADING) or (ExStyle and WS_EX_LAYOUTRTL = WS_EX_LAYOUTRTL) then + Result := bmRightToLeft; +end; + +function TSysControl.GetBorder: Boolean; +begin + Result := (Style and WS_BORDER = WS_BORDER) or (ExStyle and WS_EX_CLIENTEDGE = WS_EX_CLIENTEDGE); +end; + +function TSysControl.GetBoundsRect: TRect; +begin + Result.Left := Left; + Result.Top := Top; + Result.Right := Left + Width; + Result.Bottom := Top + Height; +end; + +function TSysControl.GetClientEdge: Boolean; +begin + Result := ExStyle and WS_EX_CLIENTEDGE = WS_EX_CLIENTEDGE; +end; + +function TSysControl.GetClientHeight: Integer; +begin + Result := ClientRect.Bottom; +end; + +function TSysControl.GetClientRect: TRect; +begin + Result := Rect(0, 0, 0, 0); + Winapi.Windows.GetClientRect(Handle, Result); +end; + +function TSysControl.GetClientWidth: Integer; +begin + Result := ClientRect.Right; +end; + +function TSysControl.GetControlClassName: String; +begin + if FWindowClassName='' then + FWindowClassName := GetWindowClassName(Handle); + Result:=FWindowClassName; +end; + +function TSysControl.GetControlID: Integer; +begin + Result := GetWindowLongPtr(Handle, GWL_ID); +end; + +function TSysControl.GetEnabled: Boolean; +begin + Result := False; + if Handle > 0 then + Result := IsWindowEnabled(Handle); +end; + +function TSysControl.GetHeight: Integer; +begin + Result := WindowRect.Height; +end; + +function TSysControl.GetLeft: Integer; +begin + Result := WindowRect.Left; +end; + +function TSysControl.GetParent: TSysControl; +begin + Result := nil; + if Assigned(FParent) then + FreeAndNil(FParent); + if ParentHandle <> 0 then + begin + FParent := TSysControl.Create(ParentHandle); + Result := FParent; + end; +end; + +function TSysControl.GetParentHandle: THandle; +begin + Result := Winapi.Windows.GetParent(Handle); +end; + +function TSysControl.GetStyle: NativeInt; +begin + Result := GetWindowLongPtr(Handle, GWL_STYLE); +end; + +function TSysControl.GetExStyle: NativeInt; +begin + Result := GetWindowLongPtr(Handle, GWL_EXSTYLE); +end; + +function TSysControl.GetFont: TFont; +var + LogFont: TLogFont; + hFont: HGDIOBJ; +begin + if FFont <> nil then + Exit(FFont); + + hFont := HGDIOBJ(SendMessage(Handle, WM_GETFONT, 0, 0)); + Result := TFont.Create; + FillChar(LogFont, SizeOf(LogFont), 0); + GetObject(hFont, SizeOf(LogFont), @LogFont); + Result.Name := StrPas(LogFont.lffaceName); + Result.Height := LogFont.lfHeight; + if LogFont.lfWeight >= FW_MEDIUM then + Result.Style := Result.Style + [fsBold]; + if LogFont.lfItalic <> 0 then + Result.Style := Result.Style + [fsItalic]; + if LogFont.lfUnderline <> 0 then + Result.Style := Result.Style + [fsUnderline]; + if LogFont.lfStrikeout <> 0 then + Result.Style := Result.Style + [fsStrikeout]; + case (LogFont.lfPitchAndFamily and 3) of + VARIABLE_PITCH: Result.Pitch := fpVariable; + FIXED_PITCH: Result.Pitch := fpFixed; + end; + + FFont := Result; +end; + +function TSysControl.GetText: String; +var + Buffer: array [0 .. 1023] of Char; +begin + SetString(Result, Buffer, Winapi.Windows.GetWindowText(Handle, Buffer, Length(Buffer))); +end; + +function TSysControl.GetTop: Integer; +begin + Result := WindowRect.Top; +end; + +function TSysControl.GetVisible: Boolean; +begin + Result := IsWindowVisible(Handle); +end; + +function TSysControl.GetWidth: Integer; +begin + Result := WindowRect.Width; +end; + +function TSysControl.GetWinRect: TRect; +begin + Result := Rect(0, 0, 0, 0); + GetWindowRect(Handle, Result); +end; + +function TSysControl.GetWndProc: NativeInt; +begin + Result := GetWindowLongPtr(Handle, GWL_WNDPROC); +end; + +function TSysControl.IsControlChild: Boolean; +begin + Result := (Style and WS_CHILD = WS_CHILD); +end; + +procedure TSysControl.SetExStyle(const Value: NativeInt); +begin + SetWindowLongPtr(Handle, GWL_EXSTYLE, Value); +end; + +procedure TSysControl.SetStyle(const Value: NativeInt); +begin + SetWindowLongPtr(Handle, GWL_STYLE, Value); +end; + +procedure TSysControl.SetWndProc(Value: NativeInt); +begin + if Value <> WndProc then + SetWindowLongPtr(Handle, GWL_WNDPROC, Value); +end; + +function TSysControl.UseRightToLeftAlignment: Boolean; +begin + Result := SysLocale.MiddleEast and (BidiMode = TBidiModeDirection.bmRightToLeft); +end; + +function TSysControl.UseRightToLeftReading: Boolean; +begin + Result := SysLocale.MiddleEast and (BidiMode <> TBidiModeDirection.bmLeftToRight); +end; + +{$ENDREGION} +{ TSysStyleHook } +{$REGION 'TSysStyleHook'} + +constructor TSysStyleHook.Create(AHandle: THandle); +begin + FHandled := False; + FSysControl := nil; + FHandle := AHandle; + FOrgWndProc := 0; + FProcInstance := nil; + FBrush := nil; + FFont := TFont.Create; +{$IF CompilerVersion > 23} + StyleElements := []; +{$IFEND} + FMustRemove := False; + FParentColor := False; + FDoubleBuffered := False; + FPaintOnEraseBkgnd := False; + FHookedDirectly := False; + OverridePaint := False; + OverridePaintNC := False; + OverrideEraseBkgnd := False; + OverrideFont := False; + if AHandle > 0 then + begin + FProcInstance := MakeObjectInstance(WndProc); + FSysControl := TSysControl.Create(AHandle); + FOrgWndProc := FSysControl.WndProc; + // if FOrgWndProc > 0 then + begin + FSysControl.WndProc := LONG_PTR(FProcInstance); + FBrush := TBrush.Create; + UpdateColors; + end; + end; +end; + +destructor TSysStyleHook.Destroy; +begin + if FOrgWndProc <> 0 then + FSysControl.WndProc := FOrgWndProc; + + if Assigned(FProcInstance) then + FreeObjectInstance(FProcInstance); + + if Assigned(FSysControl) then + FreeAndNil(FSysControl); + + if Assigned(FBrush) then + FreeAndNil(FBrush); + + if Assigned(FFont) then + FreeAndNil(FFont); + + inherited; +end; + +function TSysStyleHook.CallDefaultProc(var Msg: TMessage): LRESULT; +begin + Result := 0; + try + if (FOrgWndProc <> 0) then + Result := CallWindowProc(Pointer(FOrgWndProc), Handle, Msg.Msg, Msg.wParam, Msg.lParam); + except + on e: exception do + OutputDebugString(PWideChar('CallDefaultProc error: ' + e.message + chr(0))); + end; +end; + +procedure TSysStyleHook.DrawBorder(Canvas: TCanvas); +var + BorderSize: TRect; +begin + BorderSize := GetBorderSize; + with BorderSize do + if (Left > 0) and (Right > 0) and (Top > 0) and (Bottom > 0) then + PaintBorder(SysControl, True); +end; + +procedure TSysStyleHook.DrawControlText(Canvas: TCanvas; Details: TThemedElementDetails; const S: string; var R: TRect; const Flags: Cardinal); +var + ThemeTextColor: TColor; + TextFormat: TTextFormatFlags; +begin + Canvas.Font := SysControl.Font; + TextFormat := TTextFormatFlags(Flags); + if StyleServices.GetElementColor(Details, ecTextColor, ThemeTextColor) then + begin + Canvas.Font.Color := ThemeTextColor; + StyleServices.DrawText(Canvas.Handle, Details, S, R, TextFormat, Canvas.Font.Color); + end + else + begin + Canvas.Refresh; + StyleServices.DrawText(Canvas.Handle, Details, S, R, TextFormat); + end; +end; + +procedure TSysStyleHook.DrawParentBackground(DC: HDC; const ARect: PRect); +var + Bmp: TBitmap; + P: TPoint; +begin + P := Point(0, 0); + if ARect <> nil then + P := Point(ARect.Left, ARect.Top); + + Bmp := TBitmap.Create; + try + Bmp.SetSize(SysControl.Parent.Width, SysControl.Parent.Height); + SendMessage(ParentHandle, WM_ERASEBKGND, Bmp.Canvas.Handle, $93); + ClientToScreen(Handle, P); + ScreenToClient(ParentHandle, P); + if ARect <> nil then + BitBlt(DC, ARect.Left, ARect.Top, ARect.Width, ARect.Height, Bmp.Canvas.Handle, P.X, P.Y, SRCCOPY) + else + BitBlt(DC, 0, 0, SysControl.Width, SysControl.Height, Bmp.Canvas.Handle, P.X, P.Y, SRCCOPY); + finally + Bmp.Free; + end; + +end; + +function TSysStyleHook.DrawText(DC: HDC; Details: TThemedElementDetails; S: String; var R: TRect; const Flags: TTextFormat): Integer; +var + DrawFlags: Cardinal; + SaveIndex: Integer; + LColor: TColor; +begin + SaveIndex := SaveDC(DC); + try + SetBkMode(DC, TRANSPARENT); + if not StyleServices.GetElementColor(Details, ecTextColor, LColor) then + LColor := FontColor; + if not OverrideFont then + LColor := FontColor; + SetTextColor(DC, ColorToRGB(LColor)); + DrawFlags := TTextFormatFlags(Flags); + Result := Winapi.Windows.DrawText(DC, S, -1, R, DrawFlags); + finally + RestoreDC(DC, SaveIndex); + end; +end; + +function TSysStyleHook.DrawTextCentered(DC: HDC; Details: TThemedElementDetails; const R: TRect; S: String; Const Flags: DWORD = 0): Integer; +var + DrawRect: TRect; + DrawFlags: Cardinal; + DrawParams: TDrawTextParams; + SaveIndex: Integer; + LColor: TColor; +begin + SaveIndex := SaveDC(DC); + try + SetBkMode(DC, TRANSPARENT); + if not StyleServices.GetElementColor(Details, ecTextColor, LColor) then + LColor := FontColor; + if not OverrideFont then + LColor := FontColor; + SetTextColor(DC, ColorToRGB(LColor)); + DrawRect := R; + DrawFlags := DT_END_ELLIPSIS or DT_WORDBREAK or DT_EDITCONTROL or DT_CENTER; + if DrawFlags <> 0 then + DrawFlags := DrawFlags or Flags; + + Winapi.Windows.DrawText(DC, PChar(S), -1, DrawRect, DrawFlags or DT_CALCRECT); + DrawRect.Right := R.Right; + if DrawRect.Bottom < R.Bottom then + OffsetRect(DrawRect, 0, (R.Bottom - DrawRect.Bottom) div 2) + else + DrawRect.Bottom := R.Bottom; + ZeroMemory(@DrawParams, SizeOf(DrawParams)); + DrawParams.cbSize := SizeOf(DrawParams); + DrawTextEx(DC, PChar(S), -1, DrawRect, DrawFlags, @DrawParams); + Result := DrawParams.uiLengthDrawn; + finally + RestoreDC(DC, SaveIndex); + end; +end; + +function TSysStyleHook.GetFocused: Boolean; +begin + Result := (GetFocus = Handle); +end; + +function TSysStyleHook.GetBorderSize: TRect; +begin + Result := Rect(0, 0, 0, 0); +end; + +function TSysStyleHook.GetColor: TColor; +begin + // if OverrideEraseBkgnd then + // Result := StyleServices.GetStyleColor(scWindow) + // else + Result := FColor; +end; + +function TSysStyleHook.GetFontColor: TColor; +begin + // if OverrideFont then + // Result := StyleServices.GetSystemColor(clWindowText) + // else + Result := FFontColor; +end; + +function TSysStyleHook.GetParentHandle: HWND; +begin + Result := GetParent(Handle); +end; + +function TSysStyleHook.GetText: string; +var + Buffer: array [0 .. 255] of Char; +begin + if (Handle <> 0) then + SetString(Result, Buffer, Winapi.Windows.GetWindowText(Handle, Buffer, Length(Buffer))); + FText := Result; +end; + +function TSysStyleHook.InternalPaint(DC: HDC): Boolean; +begin + Result := False; +end; + +procedure TSysStyleHook.SetColor(const Value: TColor); +begin + if (FBrush <> nil) and ((Value <> FColor) or (Value <> FBrush.Color)) then + begin + FColor := Value; + FBrush.Color := Value; + end; +end; + +procedure TSysStyleHook.SetFont(Value: TFont); +begin + if Value <> FFont then + FFont.Assign(Value); +end; + +procedure TSysStyleHook.SetOverridePaint(const Value: Boolean); +begin + if Value then + OverrideEraseBkgnd := Value; + FOverridePaint := Value; +end; + +procedure TSysStyleHook.SetRedraw(AHandle: HWND; const Value: Boolean); +begin + SendMessage(AHandle, WM_SETREDRAW, wParam(Value), 0); +end; + +procedure TSysStyleHook.SetRedraw(const Value: Boolean); +begin + SetRedraw(Handle, Value); +end; + +{$IF CompilerVersion > 23} + +procedure TSysStyleHook.SetStyleElements(Value: TStyleElements); +begin + if Value <> FStyleElements then + begin + FStyleElements := Value; + OverridePaint := (seClient in FStyleElements); + // OverrideEraseBkgnd := OverridePaint; + OverridePaintNC := (seBorder in FStyleElements); + OverrideFont := (seFont in FStyleElements); + end; +end; +{$IFEND} + +function TSysStyleHook.StyleServicesEnabled: Boolean; +begin + Result := (StyleServices.Available) and not(StyleServices.IsSystemStyle); + if Result then + if not TSysStyleManager.HookVclControls then + Result := not(IsVCLControl(Handle)); +end; + +procedure TSysStyleHook.UpdateColors; +begin + if (OverrideEraseBkgnd) or (OverridePaint) then + Color := StyleServices.GetStyleColor(scWindow) + else + Color := clBtnFace; + if OverrideFont then + FontColor := StyleServices.GetSystemColor(clWindowText) + else + FontColor := clBlack; +end; + +function TSysStyleHook.UseLeftScrollBar: Boolean; +begin + Result := (SysControl.ExStyle and WS_EX_LEFTSCROLLBAR = WS_EX_LEFTSCROLLBAR) +end; + +procedure TSysStyleHook.Invalidate; +begin + if FOverridePaintNC then + InvalidateNC; + InvalidateRect(Handle, nil, False); +end; + +procedure TSysStyleHook.InvalidateNC; +begin + SendMessage(Handle, WM_NCPAINT, 0, 0); +end; + +procedure TSysStyleHook.Paint(Canvas: TCanvas); +begin + // +end; + +procedure TSysStyleHook.PaintBackground(Canvas: TCanvas); +begin + Canvas.Brush.Color := Color; + Canvas.FillRect(SysControl.ClientRect); +end; + +procedure TSysStyleHook.PaintBorder(Control: TSysControl; const EraseLRCorner: Boolean); +var + EmptyRect, DrawRect: TRect; + DC: HDC; + H, W: Integer; + AStyle: Integer; + Details: TThemedElementDetails; + BorderSize: TRect; +begin + BorderSize := GetBorderSize; + Control.ExStyle := GetWindowLong(Handle, GWL_EXSTYLE); + if (Control.ExStyle and WS_EX_CLIENTEDGE) <> 0 then + begin + GetWindowRect(Control.Handle, DrawRect); + OffsetRect(DrawRect, -DrawRect.Left, -DrawRect.Top); + DC := GetWindowDC(Control.Handle); + try + EmptyRect := DrawRect; + if EraseLRCorner then + begin + AStyle := GetWindowLong(Control.Handle, GWL_STYLE); + if ((AStyle and WS_HSCROLL) <> 0) and ((AStyle and WS_VSCROLL) <> 0) then + begin + W := GetSystemMetrics(SM_CXVSCROLL); + H := GetSystemMetrics(SM_CYHSCROLL); + InflateRect(EmptyRect, -2, -2); + with EmptyRect do + if not UseLeftScrollBar then + EmptyRect := Rect(Left, Bottom - H, Left + W, Bottom) + else + EmptyRect := Rect(Right - W, Bottom - H, Right, Bottom); + FillRect(DC, EmptyRect, GetSysColorBrush(COLOR_BTNFACE)); + end; + end; + with DrawRect do + ExcludeClipRect(DC, Left + BorderSize.Left, Top + BorderSize.Top, Right - BorderSize.Right, Bottom - BorderSize.Bottom); + Details := StyleServices.GetElementDetails(teEditTextNormal); + StyleServices.DrawElement(DC, Details, DrawRect); + finally + ReleaseDC(Control.Handle, DC); + end; + end; +end; + +function TSysStyleHook.PaintControls(AControl: HWND; DC: HDC): Boolean; +var + Child: HWND; + SavedDC: HDC; + SysChild: TSysControl; + P: TPoint; + FrameBrush: HBRUSH; +begin + Result := False; + Child := GetTopWindow(AControl); + while Child <> 0 do + begin + Result := True; + SysChild := TSysControl.Create(Child); + with SysChild do + begin + SavedDC := SaveDC(DC); + P := Point(Left, Top); + ScreenToClient(ParentHandle, P); + if Visible and IsChild and RectVisible(DC, Rect(P.X, P.Y, P.X + Width, P.Y + Height)) then + begin + MoveWindowOrg(DC, P.X, P.Y); + IntersectClipRect(DC, 0, 0, Width, Height); + SendMessage(Child, WM_PAINT, lParam(DC), 0); + if SysChild.HasBorder then + begin + // SendMessage(Child, WM_NCPAINT, 0, 0); + FrameBrush := CreateSolidBrush(ColorToRGB(clBtnShadow)); + FrameRect(DC, System.Types.Rect(0, 0, Width, Height), FrameBrush); + DeleteObject(FrameBrush); + FrameBrush := CreateSolidBrush(ColorToRGB(clBtnHighlight)); + FrameRect(DC, System.Types.Rect(0, 0, Width + 1, Height + 1), FrameBrush); + DeleteObject(FrameBrush); + end; + end; + FreeAndNil(SysChild); + PaintControls(Child, DC); + RestoreDC(DC, SavedDC); + Child := GetNextWindow(Child, GW_HWNDNEXT); + end; + end; +end; + +procedure TSysStyleHook.PaintNC(Canvas: TCanvas); +begin + +end; + +procedure TSysStyleHook.DrawParentBackground(DC: HDC); +begin + DrawParentBackground(DC, nil); +end; + +procedure TSysStyleHook.Refresh; +begin + SendMessage(Handle, WM_PAINT, 0, 0); +end; + +procedure TSysStyleHook.WMEraseBkgnd(var Message: TMessage); +var + DC: HDC; + Canvas: TCanvas; + SaveIndex: Integer; +begin + Handled := False; + + if not StyleServicesEnabled then + Exit; + + UpdateColors; + + if FOverrideEraseBkgnd then + begin + if not FDoubleBuffered then + begin + DC := HDC(Message.wParam); + + SaveIndex := 0; + if DC = 0 then + DC := GetDC(Handle) + else + SaveIndex := SaveDC(DC); + + Canvas := TCanvas.Create; + try + Canvas.Handle := DC; + if Assigned(FFont) then + Canvas.Font.Assign(FFont); + + if (FParentColor) and (ParentHandle > 0) then + DrawParentBackground(Canvas.Handle) + else + PaintBackground(Canvas); + + if (FPaintOnEraseBkgnd) and (Message.lParam <> $93) then + Paint(Canvas); + finally + Canvas.Handle := 0; + Canvas.Free; + if Message.wParam = 0 then + ReleaseDC(Handle, DC) + else if SaveIndex <> 0 then + RestoreDC(DC, SaveIndex); + end; + end; + Handled := True; + Message.Result := 1; + end; +end; + +function TSysStyleHook.CheckIfParentBkGndPainted: Boolean; +var + Test: Integer; + PTest: PInteger; + LParentHandle: HWND; +begin + //Exit(True); + Test := $93; + PTest := @Test; + Result := False; + LParentHandle := GetParent(Handle); + if LParentHandle > 0 then + begin + if not IsControlHooked(LParentHandle) then + Exit(False); + SendMessage(LParentHandle, WM_ERASEBKGND, 0, lParam(PTest)); + Result := (PTest^ = $11); + end; +end; + +function TSysStyleHook.CheckIfParentHooked: Boolean; +begin + Result := (SendMessage(ParentHandle, CM_PARENTHOOKED, 0, 0) = $77); +end; + +procedure TSysStyleHook.WMNCPaint(var Message: TMessage); +var + Canvas: TCanvas; +begin + Handled := False; + if not StyleServicesEnabled then + Exit; + + if FOverridePaintNC then + begin + Canvas := TCanvas.Create; + try + Canvas.Handle := GetWindowDC(SysControl.Handle); + if Assigned(FFont) then + Canvas.Font.Assign(FFont); + DrawBorder(Canvas); + PaintNC(Canvas); + finally + ReleaseDC(Handle, Canvas.Handle); + Canvas.Handle := 0; + Canvas.Free; + end; + Handled := True; + end; +end; + +procedure TSysStyleHook.WMPaint(var Message: TMessage); +var + OrgDC, DC: HDC; + Buffer: TBitmap; + Canvas: TCanvas; + PS: TPaintStruct; + + function ClipControls(AControl: HWND; Siblings: Boolean): Boolean; + var + Child: HWND; + SysChild: TSysControl; + P: TPoint; + begin + Result := False; + SysChild := nil; + Child := GetTopWindow(AControl); + if GetParent(Child) = Handle then + while Child <> 0 do + begin + Result := True; + SysChild := TSysControl.Create(Child); + with SysChild, P do + begin + P := Point(Left, Top); + ScreenToClient(Self.Handle, P); + if Visible and IsChild and RectVisible(DC, Rect(X, Y, X + Width, Y + Height)) then + begin + ExcludeClipRect(DC, X, Y, X + Width, Y + Height); + end; + FreeAndNil(SysChild); + if Siblings then + ClipControls(Child, Siblings); + Child := GetNextWindow(Child, GW_HWNDNEXT); + end; + end; + if Assigned(SysChild) then + FreeAndNil(SysChild); + end; + + function DoClipControls: Boolean; + begin + Result := False; + if SysControl.Style and WS_CLIPSIBLINGS = WS_CLIPSIBLINGS then + Result := ClipControls(Handle, True) + else if SysControl.Style and WS_CLIPCHILDREN = WS_CLIPCHILDREN then + Result := ClipControls(Handle, False); + end; + +begin + Handled := False; + if not StyleServicesEnabled then + Exit; + + if OverridePaint then + begin + OrgDC := HDC(Message.wParam); + Canvas := TCanvas.Create; + try + + if OrgDC <> 0 then + begin + Canvas.Handle := OrgDC; + DC:= OrgDC; + end + else + begin + DC := GetDC(Handle); + BeginPaint(SysControl.Handle, PS); + Canvas.Handle := DC; + end; + + if Assigned(FFont) then + Canvas.Font.Assign(FFont); + + if not InternalPaint(Canvas.Handle) then + if FDoubleBuffered and (DC = 0) then + begin + Buffer := TBitmap.Create; + try + Buffer.SetSize(SysControl.Width, SysControl.Height); + DoClipControls; + PaintBackground(Buffer.Canvas); + Paint(Buffer.Canvas); + // PaintControls(Handle,Canvas.Handle); + Canvas.Draw(0, 0, Buffer); + finally + Buffer.Free; + end; + end + else + begin + DoClipControls; + Paint(Canvas); + // PaintControls(Handle,Canvas.Handle); + end; + + if OrgDC = 0 then + begin + ReleaseDC(SysControl.Handle, DC); + EndPaint(SysControl.Handle, PS); + end; + + finally + Canvas.Handle := 0; + Canvas.Free; + end; + Handled := True; + end; + +end; + + +procedure TSysStyleHook.WndProc(var Message: TMessage); +var + TempResult: LRESULT; + ChildHandle: HWND; + ItemRemoved: Boolean; +begin + case Message.Msg of + + CM_CONTROLHOOKEDDIRECTLY: + begin + { Child controls are not hooked inside the parent . } + FHookedDirectly := True; + Exit; + end; + + CM_INITCHILDS: + begin + Message.Result := 0; + with TSysStyleManager do + begin + for ChildHandle in ChildRegSysStylesList.Keys do + if (not IsControlHooked(ChildHandle)) and (ChildRegSysStylesList[ChildHandle].Parent = Handle) then + begin + if not SysStyleHookList.ContainsKey(ChildHandle) then + begin + SysStyleHookList.Add(ChildHandle, ChildRegSysStylesList[ChildHandle].StyleHookClass.Create(ChildHandle)); + { Child control need to be repainted . } + RedrawWindow(ChildHandle, nil, 0, RDW_ERASE or RDW_FRAME or RDW_INTERNALPAINT or RDW_INVALIDATE); + { Send WM_NCCALCSIZE message to the child control . } + SetWindowPos(ChildHandle, 0, 0, 0, 0, 0, SWP_NOSIZE or SWP_NOMOVE or SWP_NOZORDER or SWP_FRAMECHANGED); + Message.Result := 1; + end; + end; + end; + Exit; + end; + + CM_PARENTHOOKED, CM_CONTROLHOOKED: + begin + Message.Result := $77; + Exit; + end; + + WM_CHANGEUISTATE, WM_PARENTNOTIFY, WM_QUERYUISTATE: + begin + CallDefaultProc(Message); + { + Do not Send ===> Use Post + Return first then hook child ! + } + PostMessage(Handle, CM_INITCHILDS, 0, 0); + Exit; + end; + + WM_ERASEBKGND: + begin + if (Message.lParam > 0) and (Message.wParam = 0) and (FOverrideEraseBkgnd or FOverridePaint or FPaintOnEraseBkgnd) then + if PInteger(Message.lParam)^ = $93 then + begin + { lParam = Result + if (lParam=$11) then Parent background was painted . + } + PInteger(Message.lParam)^ := $11; + { Do not process the default message .. + this is only for test !! . + } + Exit; { Do not Dispatch . } + end; + end; + + WM_SETREDRAW: + begin + Message.Result := CallDefaultProc(Message); + Dispatch(Message); + Exit; + end; + + WM_CTLCOLORMSGBOX .. WM_CTLCOLORSTATIC: + begin + // avoid use cuurent style colors on ignored controls + if (not StyleServicesEnabled) or (not TSysStyleManager.UseStyleColorsChildControls and (not TSysStyleManager.SysStyleHookList.ContainsKey(Message.lParam))) then + // if (not StyleServicesEnabled) then + begin + Message.Result := CallDefaultProc(Message); + Exit; + end; + + TempResult := SendMessage(Handle, CM_BASE + Message.Msg, Message.wParam, Message.lParam); + Message.Result := SendMessage(Message.lParam, CM_BASE + Message.Msg, Message.wParam, Message.lParam); + if Message.Result = 0 then + Message.Result := TempResult; + Exit; + end; + + CM_CTLCOLORMSGBOX .. CM_CTLCOLORSTATIC: + begin + SetTextColor(Message.wParam, ColorToRGB(FontColor)); + SetBkColor(Message.wParam, ColorToRGB(FBrush.Color)); + Message.Result := LRESULT(FBrush.Handle); + Exit; + end; + + WM_DESTROY: + begin + Message.Result := CallDefaultProc(Message); + Dispatch(Message); + Exit; + end; + + //The WM_NCDESTROY message is sent after the child windows have been destroyed. + //In contrast, WM_DESTROY is sent before the child windows are destroyed. + WM_NCDESTROY: + begin + Message.Result := CallDefaultProc(Message); + ItemRemoved:=False; + if TSysStyleManager.SysStyleHookList.ContainsKey(FHandle) then + begin +// OutputDebugString(PChar('SysStyleHookList WM_NCDESTROY Removed '+IntToHex(Handle, 8))); +// TSysStyleManager.SysStyleHookList.Remove(FHandle); + FMustRemove:=True; + ItemRemoved:=True; + end; + + if not ItemRemoved and TSysStyleManager.ChildRegSysStylesList.ContainsKey(FHandle) then + begin + TSysStyleManager.ChildRegSysStylesList.Remove(Handle); + //OutputDebugString(PChar('ChildRegSysStylesList WM_NCDESTROY Removed '+IntToHex(Handle, 8))); + end; + + for ChildHandle in TSysStyleManager.ChildRegSysStylesList.Keys do + if (TSysStyleManager.ChildRegSysStylesList[ChildHandle].Parent = FHandle) then + begin + TSysStyleManager.ChildRegSysStylesList.Remove(ChildHandle); + //OutputDebugString(PChar('Sub ChildRegSysStylesList WM_NCDESTROY Removed '+IntToHex(ChildHandle, 8))); + end; + Exit; + end; + + end; + + Dispatch(Message); + if not Handled then + Message.Result := CallDefaultProc(Message); + Handled := False; +end; +{$ENDREGION} +{ TMouseTrackSysControlStyleHook } +{$REGION 'TMouseTrackSysControlStyleHook'} + +constructor TMouseTrackSysControlStyleHook.Create(AHandle: THandle); +begin + inherited; + FMouseInControl := False; + FMouseInNCArea := False; + FHotTrackTimer := nil; +end; + +destructor TMouseTrackSysControlStyleHook.Destroy; +begin + if Assigned(FHotTrackTimer) then + FreeAndNil(FHotTrackTimer); + + inherited; +end; + +procedure TMouseTrackSysControlStyleHook.WMLButtonDown(var Message: TWMLButtonDown); +begin + FMouseDown := True; + inherited; +end; + +procedure TMouseTrackSysControlStyleHook.WMLButtonUp(var Message: TWMLButtonUp); +begin + FMouseDown := False; + inherited; +end; + +procedure TMouseTrackSysControlStyleHook.WMMouseMove(var Message: TWMMouse); +begin + inherited; + if not FMouseInControl and not FMouseInNCArea then + begin + FMouseInControl := True; + StartHotTrackTimer; + MouseEnter; + end + else if FMouseInNCArea and FMouseInControl then + begin + StopHotTrackTimer; + FMouseInControl := False; + MouseLeave; + end; +end; + +procedure TMouseTrackSysControlStyleHook.WMNCMouseMove(var Message: TWMMouse); +begin + inherited; + if not FMouseInControl then + begin + FMouseInControl := True; + StartHotTrackTimer; + MouseEnter; + end; +end; + +procedure TMouseTrackSysControlStyleHook.StartHotTrackTimer; +begin + if FHotTrackTimer <> nil then + StopHotTrackTimer; + FHotTrackTimer := TTimer.Create(nil); + TTimer(FHotTrackTimer).Interval := 100; + TTimer(FHotTrackTimer).OnTimer := DoHotTrackTimer; + TTimer(FHotTrackTimer).Enabled := True; + +end; + +procedure TMouseTrackSysControlStyleHook.StopHotTrackTimer; +begin + if FHotTrackTimer <> nil then + begin + TTimer(FHotTrackTimer).Enabled := False; + FreeAndNil(FHotTrackTimer); + end; +end; + +function TMouseTrackSysControlStyleHook.IsChildHandle(AHandle: HWND): Boolean; +begin + Result := False; +end; + +procedure TMouseTrackSysControlStyleHook.DoHotTrackTimer(Sender: TObject); +var + P: TPoint; + FWindowHandle: HWND; +begin + GetCursorPos(P); + FWindowHandle := WindowFromPoint(P); + if (FWindowHandle <> Handle) and not IsChildHandle(FWindowHandle) then + begin + StopHotTrackTimer; + FMouseInControl := False; + MouseLeave; + end; +end; + +procedure TMouseTrackSysControlStyleHook.MouseEnter; +begin + +end; + +procedure TMouseTrackSysControlStyleHook.MouseLeave; +begin + +end; +{$ENDREGION} + +end. diff --git a/source/vcl-styles-utils/Vcl.Styles.Utils.SystemMenu.pas b/source/vcl-styles-utils/Vcl.Styles.Utils.SystemMenu.pas index 57e6af067..53f346d96 100644 --- a/source/vcl-styles-utils/Vcl.Styles.Utils.SystemMenu.pas +++ b/source/vcl-styles-utils/Vcl.Styles.Utils.SystemMenu.pas @@ -1,254 +1,256 @@ -// ************************************************************************************************** -// -// Unit Vcl.Styles.Utils.SystemMenu -// unit for the VCL Styles Utils -// https://github.com/RRUZ/vcl-styles-utils/ -// -// 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. -// -// The Initial Developer of the Original Code is Rodrigo Ruz V. -// Portions created by Rodrigo Ruz V. are Copyright (C) 2014-2019 Rodrigo Ruz V. -// All Rights Reserved. -// -// ************************************************************************************************** -unit Vcl.Styles.Utils.SystemMenu; - -interface - -uses - System.Rtti, - System.Classes, - System.Generics.Collections, - WinApi.Windows, - WinApi.Messages, - Vcl.Themes, - Vcl.Forms; - -type - TMethodInfo = class; - - TProcCallback = reference to procedure(Info: TMethodInfo); - - TMethodInfo = class - Value1: TValue; - Value2: TValue; - Method: TProcCallback; - end; - - TVclStylesSystemMenu = class(TComponent) - strict private - FVCLStylesMenu: HMenu; - FOrgWndProc: TWndMethod; - FForm: TForm; - FMethodsDict: TObjectDictionary; - procedure CreateMenus; - procedure DeleteMenus; - procedure CreateMenuStyles; - procedure WndProc(var Message: TMessage); - private - FMenuCaption: string; - FShowNativeStyle: Boolean; - procedure SetMenuCaption(const Value: string); - procedure SetShowNativeStyle(const Value: Boolean); - public - property ShowNativeStyle: Boolean read FShowNativeStyle write SetShowNativeStyle; - property MenuCaption: string read FMenuCaption write SetMenuCaption; - constructor Create(AOwner: TForm); reintroduce; - destructor Destroy; override; - end; - -implementation - -uses - Vcl.Controls, - System.SysUtils; - -const - VCLStylesMenu = WM_USER + 666; - -function InsertMenuHelper(HMenu: HMenu; uPosition: UINT; uIDNewItem: UINT_PTR; lpNewItem, IconName: LPCWSTR): BOOL; -var - LMenuItem: TMenuItemInfo; -begin - ZeroMemory(@LMenuItem, SizeOf(TMenuItemInfo)); - LMenuItem.cbSize := SizeOf(TMenuItemInfo); - LMenuItem.fMask := MIIM_FTYPE or MIIM_ID or MIIM_BITMAP or MIIM_STRING; - LMenuItem.fType := MFT_STRING; - LMenuItem.wID := uIDNewItem; - LMenuItem.dwTypeData := lpNewItem; - Result := InsertMenuItem(HMenu, uPosition, True, LMenuItem); -end; - -procedure AddMenuSeparatorHelper(HMenu: HMenu; var MenuIndex: Integer); -var - LMenuInfo: TMenuItemInfo; - Buffer: array [0 .. 79] of char; -begin - ZeroMemory(@LMenuInfo, SizeOf(TMenuItemInfo)); - LMenuInfo.cbSize := SizeOf(LMenuInfo); - LMenuInfo.fMask := MIIM_TYPE; - LMenuInfo.dwTypeData := Buffer; - LMenuInfo.cch := SizeOf(Buffer); - if GetMenuItemInfo(HMenu, MenuIndex - 1, True, LMenuInfo) then - begin - if (LMenuInfo.fType and MFT_SEPARATOR) = MFT_SEPARATOR then - else - begin - InsertMenu(HMenu, MenuIndex, MF_BYPOSITION or MF_SEPARATOR, 0, nil); - inc(MenuIndex); - end; - end; -end; - -{ TVclStylesSystemMenu } - -constructor TVclStylesSystemMenu.Create(AOwner: TForm); -begin - inherited Create(AOwner); - FShowNativeStyle := True; - FMenuCaption := 'VCL Styles'; - FForm := AOwner; - FMethodsDict := TObjectDictionary.Create([doOwnsValues]); - FOrgWndProc := FForm.WindowProc; - FForm.WindowProc := WndProc; - CreateMenus; -end; - -destructor TVclStylesSystemMenu.Destroy; -begin - DeleteMenus; - FForm.WindowProc := FOrgWndProc; - FMethodsDict.Free; - inherited; -end; - -procedure TVclStylesSystemMenu.SetMenuCaption(const Value: string); -begin - DeleteMenus; - FMenuCaption := Value; - CreateMenus; -end; - -procedure TVclStylesSystemMenu.SetShowNativeStyle(const Value: Boolean); -begin - DeleteMenus; - FShowNativeStyle := Value; - CreateMenus; -end; - -procedure TVclStylesSystemMenu.CreateMenus; -begin - CreateMenuStyles; -end; - -procedure TVclStylesSystemMenu.DeleteMenus; -var - LSysMenu: HMenu; -begin - if IsMenu(FVCLStylesMenu) then - while GetMenuItemCount(FVCLStylesMenu) > 0 do - DeleteMenu(FVCLStylesMenu, 0, MF_BYPOSITION); - - if FForm.HandleAllocated then - begin - LSysMenu := GetSystemMenu(FForm.Handle, False); - if IsMenu(LSysMenu) then - DeleteMenu(LSysMenu, VCLStylesMenu, MF_BYCOMMAND); - end; - - FMethodsDict.Clear; -end; - -procedure TVclStylesSystemMenu.CreateMenuStyles; -var - LSysMenu: HMenu; - LMenuItem: TMenuItemInfo; - uIDNewItem, LSubMenuIndex: Integer; - LMethodInfo: TMethodInfo; - s: string; - LStyleNames: TArray; - -begin - LSysMenu := GetSystemMenu(FForm.Handle, False); - - LSubMenuIndex := GetMenuItemCount(LSysMenu); - AddMenuSeparatorHelper(LSysMenu, LSubMenuIndex); - - FVCLStylesMenu := CreatePopupMenu(); - - uIDNewItem := VCLStylesMenu; - ZeroMemory(@LMenuItem, SizeOf(TMenuItemInfo)); - LMenuItem.cbSize := SizeOf(TMenuItemInfo); - LMenuItem.fMask := MIIM_SUBMENU or MIIM_FTYPE or MIIM_ID or MIIM_BITMAP or MIIM_STRING; - LMenuItem.fType := MFT_STRING; - LMenuItem.wID := VCLStylesMenu; - LMenuItem.hSubMenu := FVCLStylesMenu; - LMenuItem.dwTypeData := PWideChar(FMenuCaption); - LMenuItem.cch := Length(FMenuCaption); - - InsertMenuItem(LSysMenu, GetMenuItemCount(LSysMenu), True, LMenuItem); - inc(uIDNewItem); - LSubMenuIndex := 0; - - LStyleNames := TStyleManager.StyleNames; - TArray.Sort(LStyleNames); - - for s in LStyleNames do - begin - - if not FShowNativeStyle and SameText('Windows', s) then - Continue; - - InsertMenuHelper(FVCLStylesMenu, LSubMenuIndex, uIDNewItem, PChar(s), nil); - if SameText(TStyleManager.ActiveStyle.Name, s) then - CheckMenuItem(FVCLStylesMenu, LSubMenuIndex, MF_BYPOSITION or MF_CHECKED); - - if SameText('Windows', s) then - AddMenuSeparatorHelper(FVCLStylesMenu, LSubMenuIndex); - - inc(LSubMenuIndex); - inc(uIDNewItem); - LMethodInfo := TMethodInfo.Create; - LMethodInfo.Value1 := s; - LMethodInfo.Method := procedure(Info: TMethodInfo) - begin - TStyleManager.SetStyle(Info.Value1.AsString); - end; - FMethodsDict.Add(uIDNewItem - 1, LMethodInfo); - end; -end; - -procedure TVclStylesSystemMenu.WndProc(var Message: TMessage); -var - LVerb: NativeUInt; -begin - case Message.Msg of - CM_RECREATEWND: - begin - DeleteMenus; - FOrgWndProc(Message); - CreateMenus; - end; - - WM_SYSCOMMAND: - begin - if FMethodsDict.ContainsKey(TWMSysCommand(Message).CmdType) then - begin - LVerb := TWMSysCommand(Message).CmdType; - FMethodsDict.Items[LVerb].Method(FMethodsDict.Items[LVerb]); - end - else - FOrgWndProc(Message); - end - else - FOrgWndProc(Message); - end; -end; - -end. +// ************************************************************************************************** +// +// Unit Vcl.Styles.Utils.SystemMenu +// unit for the VCL Styles Utils +// https://github.com/RRUZ/vcl-styles-utils/ +// +// 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. +// +// The Initial Developer of the Original Code is Rodrigo Ruz V. +// Portions created by Rodrigo Ruz V. are Copyright (C) 2014-2021 Rodrigo Ruz V. +// All Rights Reserved. +// +// ************************************************************************************************** +unit Vcl.Styles.Utils.SystemMenu; + +interface + +uses + System.Rtti, + System.Classes, + System.Generics.Collections, + WinApi.Windows, + WinApi.Messages, + Vcl.Themes, + Vcl.Forms; + +type + TMethodInfo = class; + + TProcCallback = reference to procedure(Info: TMethodInfo); + + TMethodInfo = class + Value1: TValue; + Value2: TValue; + Method: TProcCallback; + end; + + TVclStylesSystemMenu = class(TComponent) + strict private + FVCLStylesMenu: HMenu; + FOrgWndProc: TWndMethod; + FForm: TForm; + FMethodsDict: TObjectDictionary; + procedure CreateMenus; + procedure DeleteMenus; + procedure CreateMenuStyles; + procedure WndProc(var Message: TMessage); + private + FMenuCaption: string; + FShowNativeStyle: Boolean; + procedure SetMenuCaption(const Value: string); + procedure SetShowNativeStyle(const Value: Boolean); + public + property ShowNativeStyle: Boolean read FShowNativeStyle write SetShowNativeStyle; + property MenuCaption: string read FMenuCaption write SetMenuCaption; + constructor Create(AOwner: TForm); reintroduce; + destructor Destroy; override; + end; + +implementation + +uses + Vcl.Controls, + System.SysUtils; + +const + VCLStylesMenu = WM_USER + 666; + +function InsertMenuHelper(HMenu: HMenu; uPosition: UINT; uIDNewItem: UINT_PTR; lpNewItem, IconName: LPCWSTR): BOOL; +var + LMenuItem: TMenuItemInfo; +begin + ZeroMemory(@LMenuItem, SizeOf(TMenuItemInfo)); + LMenuItem.cbSize := SizeOf(TMenuItemInfo); + LMenuItem.fMask := MIIM_FTYPE or MIIM_ID or MIIM_BITMAP or MIIM_STRING; + LMenuItem.fType := MFT_STRING; + LMenuItem.wID := uIDNewItem; + LMenuItem.dwTypeData := lpNewItem; + Result := InsertMenuItem(HMenu, uPosition, True, LMenuItem); +end; + +procedure AddMenuSeparatorHelper(HMenu: HMenu; var MenuIndex: Integer); +var + LMenuInfo: TMenuItemInfo; + Buffer: array [0 .. 79] of char; +begin + ZeroMemory(@LMenuInfo, SizeOf(TMenuItemInfo)); + LMenuInfo.cbSize := SizeOf(LMenuInfo); + LMenuInfo.fMask := MIIM_TYPE; + LMenuInfo.dwTypeData := Buffer; + LMenuInfo.cch := SizeOf(Buffer); + if GetMenuItemInfo(HMenu, MenuIndex - 1, True, LMenuInfo) then + begin + if (LMenuInfo.fType and MFT_SEPARATOR) = MFT_SEPARATOR then + else + begin + InsertMenu(HMenu, MenuIndex, MF_BYPOSITION or MF_SEPARATOR, 0, nil); + inc(MenuIndex); + end; + end; +end; + +{ TVclStylesSystemMenu } + +constructor TVclStylesSystemMenu.Create(AOwner: TForm); +begin + inherited Create(AOwner); + FShowNativeStyle := True; + FMenuCaption := 'VCL Styles'; + FForm := AOwner; + FMethodsDict := TObjectDictionary.Create([doOwnsValues]); + FOrgWndProc := FForm.WindowProc; + FForm.WindowProc := WndProc; + CreateMenus; +end; + +destructor TVclStylesSystemMenu.Destroy; +begin + DeleteMenus; + FForm.WindowProc := FOrgWndProc; + FMethodsDict.Free; + inherited; +end; + +procedure TVclStylesSystemMenu.SetMenuCaption(const Value: string); +begin + DeleteMenus; + FMenuCaption := Value; + CreateMenus; +end; + +procedure TVclStylesSystemMenu.SetShowNativeStyle(const Value: Boolean); +begin + DeleteMenus; + FShowNativeStyle := Value; + CreateMenus; +end; + +procedure TVclStylesSystemMenu.CreateMenus; +begin + CreateMenuStyles; +end; + +procedure TVclStylesSystemMenu.DeleteMenus; +var + LSysMenu: HMenu; +begin + if IsMenu(FVCLStylesMenu) then + while GetMenuItemCount(FVCLStylesMenu) > 0 do + DeleteMenu(FVCLStylesMenu, 0, MF_BYPOSITION); + + if FForm.HandleAllocated then + begin + LSysMenu := GetSystemMenu(FForm.Handle, False); + if IsMenu(LSysMenu) then + DeleteMenu(LSysMenu, VCLStylesMenu, MF_BYCOMMAND); + end; + + FMethodsDict.Clear; +end; + +procedure TVclStylesSystemMenu.CreateMenuStyles; +var + LSysMenu: HMenu; + LMenuItem: TMenuItemInfo; + uIDNewItem, LSubMenuIndex: Integer; + LMethodInfo: TMethodInfo; + s: string; + LStyleNames: TArray; + +begin + LSysMenu := GetSystemMenu(FForm.Handle, False); + + LSubMenuIndex := GetMenuItemCount(LSysMenu); + AddMenuSeparatorHelper(LSysMenu, LSubMenuIndex); + + FVCLStylesMenu := CreatePopupMenu(); + + uIDNewItem := VCLStylesMenu; + ZeroMemory(@LMenuItem, SizeOf(TMenuItemInfo)); + LMenuItem.cbSize := SizeOf(TMenuItemInfo); + LMenuItem.fMask := MIIM_SUBMENU or MIIM_FTYPE or MIIM_ID or MIIM_BITMAP or MIIM_STRING; + LMenuItem.fType := MFT_STRING; + LMenuItem.wID := VCLStylesMenu; + LMenuItem.hSubMenu := FVCLStylesMenu; + LMenuItem.dwTypeData := PWideChar(FMenuCaption); + LMenuItem.cch := Length(FMenuCaption); + + InsertMenuItem(LSysMenu, GetMenuItemCount(LSysMenu), True, LMenuItem); + inc(uIDNewItem); + LSubMenuIndex := 0; + + LStyleNames := TStyleManager.StyleNames; + TArray.Sort(LStyleNames); + + for s in LStyleNames do + begin + + if not FShowNativeStyle and SameText('Windows', s) then + Continue; + + InsertMenuHelper(FVCLStylesMenu, LSubMenuIndex, uIDNewItem, PChar(s), nil); + if SameText(TStyleManager.ActiveStyle.Name, s) then + CheckMenuItem(FVCLStylesMenu, LSubMenuIndex, MF_BYPOSITION or MF_CHECKED); + + if SameText('Windows', s) then + begin + inc(LSubMenuIndex); + AddMenuSeparatorHelper(FVCLStylesMenu, LSubMenuIndex); + end; + + inc(uIDNewItem); + LMethodInfo := TMethodInfo.Create; + LMethodInfo.Value1 := s; + LMethodInfo.Method := procedure(Info: TMethodInfo) + begin + TStyleManager.SetStyle(Info.Value1.AsString); + end; + FMethodsDict.Add(uIDNewItem - 1, LMethodInfo); + end; +end; + +procedure TVclStylesSystemMenu.WndProc(var Message: TMessage); +var + LVerb: NativeUInt; +begin + case Message.Msg of + CM_RECREATEWND: + begin + DeleteMenus; + FOrgWndProc(Message); + CreateMenus; + end; + + WM_SYSCOMMAND: + begin + if FMethodsDict.ContainsKey(TWMSysCommand(Message).CmdType) then + begin + LVerb := TWMSysCommand(Message).CmdType; + FMethodsDict.Items[LVerb].Method(FMethodsDict.Items[LVerb]); + end + else + FOrgWndProc(Message); + end + else + FOrgWndProc(Message); + end; +end; + +end. diff --git a/source/vcl-styles-utils/Vcl.Styles.Utils.pas b/source/vcl-styles-utils/Vcl.Styles.Utils.pas index 9df9bce96..5c819830c 100644 --- a/source/vcl-styles-utils/Vcl.Styles.Utils.pas +++ b/source/vcl-styles-utils/Vcl.Styles.Utils.pas @@ -1,281 +1,281 @@ -//************************************************************************************************** -// -// Unit Vcl.Styles.Utils -// unit for the VCL Styles Utils -// https://github.com/RRUZ/vcl-styles-utils/ -// -// 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. -// -// The Original Code is Vcl.Styles.Utils.pas. -// -// The Initial Developer of the Original Code is Rodrigo Ruz V. -// Portions created by Rodrigo Ruz V. are Copyright (C) 2012-2016 Rodrigo Ruz V. -// All Rights Reserved. -// -//************************************************************************************************** -unit Vcl.Styles.Utils; - -interface -uses - System.Classes, - System.Generics.Collections, - Vcl.Styles.Utils.Graphics, - Vcl.Themes, - Vcl.Styles.Ext; - -type - TVCLStylesElement = (vseBitmaps, vseSysColors, vseStyleColors, vseStyleFontColors); - TVCLStylesElements = set of TVCLStylesElement; - TVCLStylesFilter = (vsfHSL, vsfRGB, vsfBlend, vsfTextureBlend); - - TVclStylesUtils = class - private - FClone : Boolean; - FStream : TStream; - FStyleExt : TCustomStyleExt; - FElements : TVCLStylesElements; - //FSourceInfo: TSourceInfo; - public - procedure SetFilters(Filters : TObjectList); - procedure ApplyChanges; - procedure SaveToFile(const FileName: string); - //property SourceInfo: TSourceInfo read FSourceInfo; - property StyleExt : TCustomStyleExt read FStyleExt; - property Elements : TVCLStylesElements read FElements write FElements; - constructor Create(const StyleName : string;Clone:Boolean=False); - destructor Destroy;override; - class procedure SaveSettings(const FileName:String;Elements :TVCLStylesElements; FilterType : TVCLStylesFilter;Filters : TObjectList); - class procedure LoadSettings(const FileName:String;var Elements :TVCLStylesElements; var FilterType : TVCLStylesFilter;Filters : TObjectList); - //class procedure LoadAndApplySettings(const FileName:String); - end; - -const - VCLStylesFilterNames : Array[TVCLStylesFilter] of string = ('HSL','RGB','Blend','Texture Blend'); - -implementation - -uses - System.Rtti, - System.IOUtils, - System.SysUtils, - Xml.XMLDoc, - Xml.XMLIntf, - Vcl.Graphics; - - -{ TVclStylesUtils } -constructor TVclStylesUtils.Create(const StyleName : string;Clone:Boolean=False); -var - FSourceInfo: TSourceInfo; -begin - TStyleManager.StyleNames;//call DiscoverStyleResources - FElements :=[vseBitmaps]; - FClone :=Clone; - FStyleExt:=nil; - FStream :=nil; - - if (StyleName<>'') and (CompareText('Windows',StyleName)<>0) then - begin - if FClone then - begin - FStream:=TMemoryStream.Create; - FSourceInfo:=TStyleManager.StyleSourceInfo[StyleName]; - TStream(FSourceInfo.Data).Position:=0; - FStream.CopyFrom(TStream(FSourceInfo.Data),TStream(FSourceInfo.Data).Size); - //restore original index - TStream(FSourceInfo.Data).Position:=0; - FStream.Position:=0; - end - else - FStream:=TStream(TStyleManager.StyleSourceInfo[StyleName].Data); - FStyleExt:=TCustomStyleExt.Create(FStream); - end; -end; - -destructor TVclStylesUtils.Destroy; -begin - if Assigned(StyleExt) then - StyleExt.Free; - if FClone and Assigned(FStream) then - FStream.Free; - inherited; -end; - -procedure TVclStylesUtils.ApplyChanges; -begin - if Assigned(StyleExt) then - begin - FStream.Size:=0; - StyleExt.CopyToStream(FStream); - FStream.Seek(0,soFromBeginning); - end; -end; - -class procedure TVclStylesUtils.SaveSettings(const FileName:String;Elements :TVCLStylesElements; FilterType : TVCLStylesFilter;Filters : TObjectList); -var - Doc : IXMLDocument; - RootNode, ChildNode, oNode : IXMLNode; - LFilter : TBitmapFilter; -begin - Doc :=TXMLDocument.Create(nil); - try - Doc.Active := True; - Doc.Version :='1.0'; - Doc.Encoding:='utf-8'; - Doc.Options := [doNodeAutoIndent]; - RootNode := Doc.AddChild('VCLStylesEQ'); - RootNode.Attributes['created'] := FormatDateTime('YYYY-MM-DD HH:NN:SS',Now); - RootNode.Attributes['vseBitmaps'] := BoolToStr({vseBitmaps in Elements}True, True); - RootNode.Attributes['vseSysColors'] := BoolToStr(vseSysColors in Elements, True); - RootNode.Attributes['vseStyleColors'] := BoolToStr(vseStyleColors in Elements, True); - RootNode.Attributes['vseStyleFontColors'] := BoolToStr(vseStyleFontColors in Elements, True); - ChildNode := RootNode.AddChild('FilterType'); - ChildNode.Attributes['Name'] := VCLStylesFilterNames[FilterType]; - - for LFilter in Filters do - begin - oNode := ChildNode.AddChild(LFilter.ClassName); - oNode.Text:=IntToStr(LFilter.ColorValue); - end; - Doc.SaveToFile(FileName); - finally - Doc:=nil; - end; -end; - -class procedure TVclStylesUtils.LoadSettings(const FileName:String;var Elements :TVCLStylesElements; var FilterType : TVCLStylesFilter;Filters : TObjectList); -var - Doc : IXMLDocument; - RootNode, ChildNode, oNode : IXMLNode; - LFilterType :TVCLStylesFilter; - i : Integer; - LClassName : string; - Ctx : TRttiContext; - RttiInstanceType : TRttiInstanceType; - Value : TValue; -begin - Doc :=LoadXMLDocument(FileName); - try - RootNode :=Doc.DocumentElement; - - Elements:=[]; - if SameText(RootNode.Attributes['vseBitmaps'],'True') then - Elements:=Elements+[vseBitmaps]; - - if SameText(RootNode.Attributes['vseSysColors'],'True') then - Elements:=Elements+[vseSysColors]; - - if SameText(RootNode.Attributes['vseStyleColors'],'True') then - Elements:=Elements+[vseStyleColors]; - - if SameText(RootNode.Attributes['vseStyleFontColors'],'True') then - Elements:=Elements+[vseStyleFontColors]; - - ChildNode:=RootNode.ChildNodes[0]; - for LFilterType:=Low(TVCLStylesFilter) to High(TVCLStylesFilter) do - if SameText(VCLStylesFilterNames[LFilterType], ChildNode.Attributes['Name']) then - begin - FilterType:=LFilterType; - break; - end; - - for i:=0 to ChildNode.ChildNodes.Count-1 do - begin - oNode:= ChildNode.ChildNodes[i]; - LClassName:='uHSLUtils.'+oNode.NodeName; - RttiInstanceType := (Ctx.FindType(LClassName) as TRttiInstanceType); - Value := RttiInstanceType.GetMethod('Create').Invoke(RttiInstanceType.MetaclassType,[StrToInt(oNode.Text)]); - Filters.Add((Value.AsObject as TBitmapFilter)); - end; - finally - Doc:=nil; - end; -end; - -procedure TVclStylesUtils.SaveToFile(const FileName: string); -var - FileStream: TFileStream; -begin - if FileName<>'' then - begin - FileStream:=TFile.Create(FileName); - try - StyleExt.CopyToStream(FileStream); - finally - FileStream.Free; - end; - end; -end; - -procedure TVclStylesUtils.SetFilters(Filters: TObjectList); -var - LBitmap : TBitmap; - BitmapList: TObjectList; - Index : Integer; - Filter : TBitmapFilter; - Element : TIdentMapEntry; - LColor : TColor; - StyleColor: TStyleColor; - StyleFont : TStyleFont; -begin - if vseBitmaps in FElements then - begin - BitmapList:=StyleExt.BitmapList; - try - Index:=0; - for LBitmap in BitmapList do - begin - for Filter in Filters do - Filter.ProcessBitmap(LBitmap); - StyleExt.ReplaceBitmap(Index, LBitmap); - Inc(Index); - end; - finally - BitmapList.Free; - end; - end; - - if vseSysColors in FElements then - begin - for Element in VclStyles_SysColors do - begin - LColor:=StyleExt.GetSystemColor(Element.Value); - for Filter in Filters do - LColor:=Filter.ProcessColor(LColor); - - StyleExt.SetSystemColor(Element.Value,LColor); - end; - end; - - if vseStyleColors in FElements then - begin - for StyleColor := Low(TStyleColor) to High(TStyleColor) do - begin - LColor:=StyleExt.GetStyleColor(StyleColor); - for Filter in Filters do - LColor:=Filter.ProcessColor(LColor); - - StyleExt.SetStyleColor(StyleColor, LColor); - end; - end; - - if vseStyleFontColors in FElements then - begin - for StyleFont := Low(TStyleFont) to High(TStyleFont) do - begin - LColor:=StyleExt.GetStyleFontColor(StyleFont); - for Filter in Filters do - LColor:=Filter.ProcessColor(LColor); - - StyleExt.SetStyleFontColor(StyleFont, LColor); - end; - end; -end; - -end. +//************************************************************************************************** +// +// Unit Vcl.Styles.Utils +// unit for the VCL Styles Utils +// https://github.com/RRUZ/vcl-styles-utils/ +// +// 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. +// +// The Original Code is Vcl.Styles.Utils.pas. +// +// The Initial Developer of the Original Code is Rodrigo Ruz V. +// Portions created by Rodrigo Ruz V. are Copyright (C) 2012-2023 Rodrigo Ruz V. +// All Rights Reserved. +// +//************************************************************************************************** +unit Vcl.Styles.Utils; + +interface +uses + System.Classes, + System.Generics.Collections, + Vcl.Styles.Utils.Graphics, + Vcl.Themes, + Vcl.Styles.Ext; + +type + TVCLStylesElement = (vseBitmaps, vseSysColors, vseStyleColors, vseStyleFontColors); + TVCLStylesElements = set of TVCLStylesElement; + TVCLStylesFilter = (vsfHSL, vsfRGB, vsfBlend, vsfTextureBlend); + + TVclStylesUtils = class + private + FClone: Boolean; + FStream: TStream; + FStyleExt: TCustomStyleExt; + FElements: TVCLStylesElements; + //FSourceInfo: TSourceInfo; + public + procedure SetFilters(Filters: TObjectList); + procedure ApplyChanges; + procedure SaveToFile(const FileName: string); + //property SourceInfo: TSourceInfo read FSourceInfo; + property StyleExt: TCustomStyleExt read FStyleExt; + property Elements: TVCLStylesElements read FElements write FElements; + constructor Create(const StyleName: string;Clone:Boolean=False); + destructor Destroy;override; + class procedure SaveSettings(const FileName:String;Elements :TVCLStylesElements; FilterType: TVCLStylesFilter;Filters: TObjectList); + class procedure LoadSettings(const FileName:String;var Elements :TVCLStylesElements; var FilterType: TVCLStylesFilter;Filters: TObjectList); + //class procedure LoadAndApplySettings(const FileName:String); + end; + +const + VCLStylesFilterNames: Array[TVCLStylesFilter] of string = ('HSL','RGB','Blend','Texture Blend'); + +implementation + +uses + System.Rtti, + System.IOUtils, + System.SysUtils, + Xml.XMLDoc, + Xml.XMLIntf, + Vcl.Graphics; + + +{ TVclStylesUtils } +constructor TVclStylesUtils.Create(const StyleName: string;Clone:Boolean=False); +var + FSourceInfo: TSourceInfo; +begin + TStyleManager.StyleNames;//call DiscoverStyleResources + FElements :=[vseBitmaps]; + FClone :=Clone; + FStyleExt:=nil; + FStream :=nil; + + if (StyleName<>'') and (CompareText('Windows',StyleName)<>0) then + begin + if FClone then + begin + FStream:=TMemoryStream.Create; + FSourceInfo:=TStyleManager.StyleSourceInfo[StyleName]; + TStream(FSourceInfo.Data).Position:=0; + FStream.CopyFrom(TStream(FSourceInfo.Data),TStream(FSourceInfo.Data).Size); + //restore original index + TStream(FSourceInfo.Data).Position:=0; + FStream.Position:=0; + end + else + FStream:=TStream(TStyleManager.StyleSourceInfo[StyleName].Data); + FStyleExt:=TCustomStyleExt.Create(FStream); + end; +end; + +destructor TVclStylesUtils.Destroy; +begin + if Assigned(StyleExt) then + StyleExt.Free; + if FClone and Assigned(FStream) then + FStream.Free; + inherited; +end; + +procedure TVclStylesUtils.ApplyChanges; +begin + if Assigned(StyleExt) then + begin + FStream.Size:=0; + StyleExt.CopyToStream(FStream); + FStream.Seek(0,soFromBeginning); + end; +end; + +class procedure TVclStylesUtils.SaveSettings(const FileName:String;Elements :TVCLStylesElements; FilterType: TVCLStylesFilter;Filters: TObjectList); +var + Doc: IXMLDocument; + RootNode, ChildNode, oNode: IXMLNode; + LFilter: TBitmapFilter; +begin + Doc :=TXMLDocument.Create(nil); + try + Doc.Active := True; + Doc.Version :='1.0'; + Doc.Encoding:='utf-8'; + Doc.Options := [doNodeAutoIndent]; + RootNode := Doc.AddChild('VCLStylesEQ'); + RootNode.Attributes['created'] := FormatDateTime('YYYY-MM-DD HH:NN:SS',Now); + RootNode.Attributes['vseBitmaps'] := BoolToStr({vseBitmaps in Elements}True, True); + RootNode.Attributes['vseSysColors'] := BoolToStr(vseSysColors in Elements, True); + RootNode.Attributes['vseStyleColors'] := BoolToStr(vseStyleColors in Elements, True); + RootNode.Attributes['vseStyleFontColors'] := BoolToStr(vseStyleFontColors in Elements, True); + ChildNode := RootNode.AddChild('FilterType'); + ChildNode.Attributes['Name'] := VCLStylesFilterNames[FilterType]; + + for LFilter in Filters do + begin + oNode := ChildNode.AddChild(LFilter.ClassName); + oNode.Text:=IntToStr(LFilter.ColorValue); + end; + Doc.SaveToFile(FileName); + finally + Doc:=nil; + end; +end; + +class procedure TVclStylesUtils.LoadSettings(const FileName:String;var Elements :TVCLStylesElements; var FilterType: TVCLStylesFilter;Filters: TObjectList); +var + Doc: IXMLDocument; + RootNode, ChildNode, oNode: IXMLNode; + LFilterType :TVCLStylesFilter; + i: Integer; + LClassName: string; + Ctx: TRttiContext; + RttiInstanceType: TRttiInstanceType; + Value: TValue; +begin + Doc :=LoadXMLDocument(FileName); + try + RootNode :=Doc.DocumentElement; + + Elements:=[]; + if SameText(RootNode.Attributes['vseBitmaps'],'True') then + Elements:=Elements+[vseBitmaps]; + + if SameText(RootNode.Attributes['vseSysColors'],'True') then + Elements:=Elements+[vseSysColors]; + + if SameText(RootNode.Attributes['vseStyleColors'],'True') then + Elements:=Elements+[vseStyleColors]; + + if SameText(RootNode.Attributes['vseStyleFontColors'],'True') then + Elements:=Elements+[vseStyleFontColors]; + + ChildNode:=RootNode.ChildNodes[0]; + for LFilterType:=Low(TVCLStylesFilter) to High(TVCLStylesFilter) do + if SameText(VCLStylesFilterNames[LFilterType], ChildNode.Attributes['Name']) then + begin + FilterType:=LFilterType; + break; + end; + + for i:=0 to ChildNode.ChildNodes.Count-1 do + begin + oNode:= ChildNode.ChildNodes[i]; + LClassName:='uHSLUtils.'+oNode.NodeName; + RttiInstanceType := (Ctx.FindType(LClassName) as TRttiInstanceType); + Value := RttiInstanceType.GetMethod('Create').Invoke(RttiInstanceType.MetaclassType,[StrToInt(oNode.Text)]); + Filters.Add((Value.AsObject as TBitmapFilter)); + end; + finally + Doc:=nil; + end; +end; + +procedure TVclStylesUtils.SaveToFile(const FileName: string); +var + FileStream: TFileStream; +begin + if FileName<>'' then + begin + FileStream:=TFile.Create(FileName); + try + StyleExt.CopyToStream(FileStream); + finally + FileStream.Free; + end; + end; +end; + +procedure TVclStylesUtils.SetFilters(Filters: TObjectList); +var + LBitmap: TBitmap; + BitmapList: TObjectList; + Index: Integer; + Filter: TBitmapFilter; + Element: TIdentMapEntry; + LColor: TColor; + StyleColor: TStyleColor; + StyleFont: TStyleFont; +begin + if vseBitmaps in FElements then + begin + BitmapList:=StyleExt.BitmapList; + try + Index:=0; + for LBitmap in BitmapList do + begin + for Filter in Filters do + Filter.ProcessBitmap(LBitmap); + StyleExt.ReplaceBitmap(Index, LBitmap); + Inc(Index); + end; + finally + BitmapList.Free; + end; + end; + + if vseSysColors in FElements then + begin + for Element in VclStyles_SysColors do + begin + LColor:=StyleExt.GetSystemColor(Element.Value); + for Filter in Filters do + LColor:=Filter.ProcessColor(LColor); + + StyleExt.SetSystemColor(Element.Value,LColor); + end; + end; + + if vseStyleColors in FElements then + begin + for StyleColor := Low(TStyleColor) to High(TStyleColor) do + begin + LColor:=StyleExt.GetStyleColor(StyleColor); + for Filter in Filters do + LColor:=Filter.ProcessColor(LColor); + + StyleExt.SetStyleColor(StyleColor, LColor); + end; + end; + + if vseStyleFontColors in FElements then + begin + for StyleFont := Low(TStyleFont) to High(TStyleFont) do + begin + LColor:=StyleExt.GetStyleFontColor(StyleFont); + for Filter in Filters do + LColor:=Filter.ProcessColor(LColor); + + StyleExt.SetStyleFontColor(StyleFont, LColor); + end; + end; +end; + +end. diff --git a/source/vcl-styles-utils/Vcl.Styles.UxTheme.pas b/source/vcl-styles-utils/Vcl.Styles.UxTheme.pas index d0b131cf2..8a158e890 100644 --- a/source/vcl-styles-utils/Vcl.Styles.UxTheme.pas +++ b/source/vcl-styles-utils/Vcl.Styles.UxTheme.pas @@ -15,7 +15,7 @@ // The Original Code is Vcl.Styles.UxTheme.pas. // // The Initial Developer of the Original Code is Rodrigo Ruz V. -// Portions created by Rodrigo Ruz V. are Copyright (C) 2013-2019 Rodrigo Ruz V. +// Portions created by Rodrigo Ruz V. are Copyright (C) 2013-2023 Rodrigo Ruz V. // All Rights Reserved. // // ************************************************************************************************** @@ -103,6 +103,7 @@ implementation VSCLASS_SEARCHEDITBOX = 'SearchEditBox'; VSCLASS_SEARCHBOX = 'SearchBox'; VSCLASS_CompositedSEARCHBOX = 'SearchBoxCompositedSearchBox::SearchBox'; + VSCLASS_SearchBoxComposited = 'SearchBoxComposited::SearchBox'; VSCLASS_INACTIVESEARCHBOX = 'InactiveSearchBoxCompositedSearchBox::SearchBox'; {$ENDIF} @@ -151,32 +152,36 @@ implementation MARLETT_MAXIMIZE_CHAR = Char(49); {$ENDIF} +{$IFDEF HOOK_ExplorerStatusBar} + VSCLASS_EXPLORERSTATUSBAR = 'ExplorerStatusBar'; +{$IFEND} + type TDrawThemeBackground = function(hTheme: hTheme; hdc: hdc; iPartId, iStateId: Integer; const pRect: TRect; Foo: Pointer): HRESULT; stdcall; - TFuncDrawThemeBackground = function(hTheme: HTHEME; hdc: HDC; iPartId, iStateId: Integer; const pRect: TRect; Foo: Pointer; Trampoline : TDrawThemeBackground; LThemeClass : string; hwnd : HWND): HRESULT; stdcall; + TFuncDrawThemeBackground = function(hTheme: HTHEME; hdc: HDC; iPartId, iStateId: Integer; const pRect: TRect; Foo: Pointer; Trampoline: TDrawThemeBackground; LThemeClass: string; hwnd: HWND): HRESULT; stdcall; var - Trampoline_UxTheme_OpenThemeDataEx : function(hwnd: HWND; pszClassList: LPCWSTR; dwFlags: DWORD): HTHEME; stdcall = nil; - Trampoline_UxTheme_OpenThemeData : function(hwnd: HWND; pszClassList: LPCWSTR): HTHEME; stdcall = nil; + Trampoline_UxTheme_OpenThemeDataEx: function(hwnd: HWND; pszClassList: LPCWSTR; dwFlags: DWORD): HTHEME; stdcall = nil; + Trampoline_UxTheme_OpenThemeData: function(hwnd: HWND; pszClassList: LPCWSTR): HTHEME; stdcall = nil; {$IF CompilerVersion >= 30} - Trampoline_UxTheme_OpenThemeDataForDPI : function(hwnd: HWND; pszClassList: LPCWSTR; dpi: UINT): HTHEME; stdcall = nil; + Trampoline_UxTheme_OpenThemeDataForDPI: function(hwnd: HWND; pszClassList: LPCWSTR; dpi: UINT): HTHEME; stdcall = nil; {$IFEND} - Trampoline_UxTheme_CloseThemeData : function(hTheme: HTHEME): HRESULT; stdcall = nil; - Trampoline_UxTheme_DrawThemeBackground : function(hTheme: HTHEME; hdc: HDC; iPartId, iStateId: Integer; const pRect: TRect; pClipRect: Pointer): HRESULT; stdcall = nil; - Trampoline_UxTheme_DrawThemeBackgroundEx : function(hTheme: HTHEME; hdc: HDC; iPartId, iStateId: Integer; const pRect: TRect; pOptions: Pointer): HResult; stdcall = nil; - Trampoline_UxTheme_GetThemeColor : function(hTheme: HTHEME; iPartId, iStateId, iPropId: Integer; var pColor: COLORREF): HRESULT; stdcall = nil; - Trampoline_UxTheme_GetThemeSysColor : function(hTheme: HTHEME; iColorId: Integer): COLORREF; stdcall = nil; - Trampoline_UxTheme_GetThemeSysColorBrush : function(hTheme: HTHEME; iColorId: Integer): HBRUSH; stdcall = nil; - Trampoline_UxTheme_DrawThemeText : function(hTheme: HTHEME; hdc: HDC; iPartId, iStateId: Integer; pszText: LPCWSTR; iCharCount: Integer; dwTextFlags, dwTextFlags2: DWORD; const pRect: TRect): HRESULT; stdcall = nil; - Trampoline_UxTheme_DrawThemeTextEx : function(hTheme: HTHEME; hdc: HDC; iPartId: Integer; iStateId: Integer; pszText: LPCWSTR; cchText: Integer; dwTextFlags: DWORD; pRect: PRect; var pOptions: TDTTOpts): HResult; stdcall = nil; - Trampoline_UxTheme_DrawThemeEdge : function(hTheme: HTHEME; hdc: HDC; iPartId, iStateId: Integer; const pDestRect: TRect; uEdge, uFlags: UINT; pContentRect: PRECT): HRESULT; stdcall = nil; + Trampoline_UxTheme_CloseThemeData: function(hTheme: HTHEME): HRESULT; stdcall = nil; + Trampoline_UxTheme_DrawThemeBackground: function(hTheme: HTHEME; hdc: HDC; iPartId, iStateId: Integer; const pRect: TRect; pClipRect: Pointer): HRESULT; stdcall = nil; + Trampoline_UxTheme_DrawThemeBackgroundEx: function(hTheme: HTHEME; hdc: HDC; iPartId, iStateId: Integer; const pRect: TRect; pOptions: Pointer): HResult; stdcall = nil; + Trampoline_UxTheme_GetThemeColor: function(hTheme: HTHEME; iPartId, iStateId, iPropId: Integer; var pColor: COLORREF): HRESULT; stdcall = nil; + Trampoline_UxTheme_GetThemeSysColor: function(hTheme: HTHEME; iColorId: Integer): COLORREF; stdcall = nil; + Trampoline_UxTheme_GetThemeSysColorBrush: function(hTheme: HTHEME; iColorId: Integer): HBRUSH; stdcall = nil; + Trampoline_UxTheme_DrawThemeText: function(hTheme: HTHEME; hdc: HDC; iPartId, iStateId: Integer; pszText: LPCWSTR; iCharCount: Integer; dwTextFlags, dwTextFlags2: DWORD; const pRect: TRect): HRESULT; stdcall = nil; + Trampoline_UxTheme_DrawThemeTextEx: function(hTheme: HTHEME; hdc: HDC; iPartId: Integer; iStateId: Integer; pszText: LPCWSTR; cchText: Integer; dwTextFlags: DWORD; pRect: PRect; var pOptions: TDTTOpts): HResult; stdcall = nil; + Trampoline_UxTheme_DrawThemeEdge: function(hTheme: HTHEME; hdc: HDC; iPartId, iStateId: Integer; const pDestRect: TRect; uEdge, uFlags: UINT; pContentRect: PRECT): HRESULT; stdcall = nil; - THThemesClasses : TDictionary; - THThemesHWND : TDictionary; + THThemesClasses: TDictionary; + THThemesHWND: TDictionary; - FuncsDrawThemeBackground : TDictionary; + FuncsDrawThemeBackground: TDictionary; - VCLStylesLock : TCriticalSection = nil; + VCLStylesLock: TCriticalSection = nil; { Helper methods } @@ -284,7 +289,7 @@ function GetThemeClass(hTheme: hTheme; iPartId, iStateId: Integer): string; {$IF CompilerVersion >= 30} function InterceptCreateOrdinal(const Module: string; MethodName: Integer; const InterceptProc: Pointer; - ForceLoadModule: Boolean = True; Options: Byte = v1compatibility): Pointer; + ForceLoadModule: Boolean = True; const Options: TInterceptOptions = DefaultInterceptOptions): Pointer; var pOrgPointer: Pointer; LModule: THandle; @@ -298,7 +303,7 @@ function InterceptCreateOrdinal(const Module: string; MethodName: Integer; const begin pOrgPointer := GetProcAddress(LModule, PChar(MethodName)); if Assigned(pOrgPointer) then - Result := DDetours.InterceptCreate(pOrgPointer, InterceptProc, Options); + DDetours.InterceptCreate(pOrgPointer, InterceptProc, Result, nil, Options); end; end; {$IFEND} @@ -480,6 +485,7 @@ function Detour_UxTheme_DrawThemeMain(hTheme: hTheme; hdc: hdc; iPartId, iStateI finally VCLStylesLock.Leave; end; + // OutputDebugString(PChar(Format('Detour_UxTheme_DrawThemeMain hTheme %d iPartId %d iStateId %d text %s', [hTheme, iPartId, iStateId, LThemeClass]))); end; function Detour_UxTheme_DrawThemeBackgroundEx(hTheme: hTheme; hdc: hdc; iPartId, iStateId: Integer; const pRect: TRect; @@ -528,7 +534,7 @@ function Detour_UxTheme_GetThemeSysColorBrush(hTheme: hTheme; iColorId: Integer) Doesn't affect Compressed files font color (blue) } -function Detour_UxTheme_GetThemeColor(hTheme: hTheme; iPartId, iStateId, iPropId: Integer; var pColor: COLORREF) : HRESULT; stdcall; +function Detour_UxTheme_GetThemeColor(hTheme: hTheme; iPartId, iStateId, iPropId: Integer; var pColor: COLORREF): HRESULT; stdcall; var LThemeClass: string; begin @@ -596,17 +602,13 @@ function Detour_UxTheme_GetThemeColor(hTheme: hTheme; iPartId, iStateId, iPropId begin pColor := clNone; case iPartId of - 0: case iStateId of - 0: - pColor := ColorToRGB(StyleServices.GetSystemColor(clWindowText)); + 0: pColor := ColorToRGB(StyleServices.GetSystemColor(clWindowText)); end; - 1: case iStateId of - 1: - pColor := ColorToRGB(StyleServices.GetSystemColor(clWindowText)); + 1: pColor := ColorToRGB(StyleServices.GetSystemColor(clWindowText)); end; end; @@ -623,12 +625,10 @@ function Detour_UxTheme_GetThemeColor(hTheme: hTheme; iPartId, iStateId, iPropId {$IFDEF HOOK_SearchBox} if SameText(VSCLASS_SEARCHEDITBOX, LThemeClass) then begin - pColor := clNone; case iPartId of 1: case iStateId of - 2: - pColor := ColorToRGB(StyleServices.GetSystemColor(clWindowText)); + 2: pColor := ColorToRGB(StyleServices.GetSystemColor(clWindowText)); end; end; @@ -649,13 +649,11 @@ function Detour_UxTheme_GetThemeColor(hTheme: hTheme; iPartId, iStateId, iPropId case iPartId of TTP_STANDARD: case iStateId of - 0: - pColor := ColorToRGB(StyleServices.GetSystemColor(clBtnText)); + 0: pColor := ColorToRGB(StyleServices.GetSystemColor(clBtnText)); end; 4: case iStateId of - 0: - pColor := ColorToRGB(StyleServices.GetSystemColor(clHighlight)); + 0: pColor := ColorToRGB(StyleServices.GetSystemColor(clHighlight)); end; end; @@ -676,8 +674,8 @@ function Detour_UxTheme_GetThemeColor(hTheme: hTheme; iPartId, iStateId, iPropId case iPartId of 9: case iStateId of - 1 : pColor := ColorToRGB(StyleServices.GetSystemColor(clWindow)); - 2 : pColor := ColorToRGB(StyleServices.GetSystemColor(clHighlight)); + 1: pColor := ColorToRGB(StyleServices.GetSystemColor(clWindow)); + 2: pColor := ColorToRGB(StyleServices.GetSystemColor(clHighlight)); end; end; @@ -698,7 +696,7 @@ function Detour_UxTheme_GetThemeColor(hTheme: hTheme; iPartId, iStateId, iPropId case iPartId of 13: case iStateId of - 0 : pColor := ColorToRGB(StyleServices.GetSystemColor(clBtnFace)); + 0: pColor := ColorToRGB(StyleServices.GetSystemColor(clBtnFace)); end; end; @@ -712,6 +710,28 @@ function Detour_UxTheme_GetThemeColor(hTheme: hTheme; iPartId, iStateId, iPropId end else {$ENDIF} + {$IFDEF HOOK_VirtualShell} + if SameText(LThemeClass, VSCLASS_SCROLLBAR) then + begin + // Fix a theme issue in Mustangpeak Virtual Shell + pColor := clNone; + case iPartId of + 11: + case iStateId of + 0: pColor := ColorToRGB(StyleServices.GetStyleColor(scPanel)); + end; + end; + + if TColor(pColor) = clNone then + begin + Result := Trampoline_UxTheme_GetThemeColor(hTheme, iPartId, iStateId, iPropId, pColor); + //OutputDebugString(PChar(Format('Detour_GetThemeColor Class %s hTheme %d iPartId %d iStateId %d iPropId %d Color %8.x', [LThemeClass, hTheme, iPartId, iStateId, iPropId, pColor]))); + end + else + Result := S_OK; + end + else + {$ENDIF} if SameText(LThemeClass, VSCLASS_TEXTSTYLE) then begin pColor := clNone; @@ -719,8 +739,7 @@ function Detour_UxTheme_GetThemeColor(hTheme: hTheme; iPartId, iStateId, iPropId TEXT_MAININSTRUCTION: case iStateId of - 0: - pColor := ColorToRGB(StyleServices.GetSystemColor(clHighlightText)); + 0: pColor := ColorToRGB(StyleServices.GetSystemColor(clHighlightText)); end; end; @@ -741,8 +760,7 @@ function Detour_UxTheme_GetThemeColor(hTheme: hTheme; iPartId, iStateId, iPropId HP_HEADERITEM: case iStateId of - 0: - pColor := ColorToRGB(StyleServices.GetSystemColor(clBtnText)); + 0: pColor := ColorToRGB(StyleServices.GetSystemColor(clBtnText)); end; end; @@ -765,14 +783,12 @@ function Detour_UxTheme_GetThemeColor(hTheme: hTheme; iPartId, iStateId, iPropId 1: // preview background case iStateId of - 0: - pColor := ColorToRGB(StyleServices.GetSystemColor(clWindow)); + 0: pColor := ColorToRGB(StyleServices.GetSystemColor(clWindow)); end; 2: // preview text case iStateId of - 0: - pColor := ColorToRGB(StyleServices.GetSystemColor(clWindowText)); + 0: pColor := ColorToRGB(StyleServices.GetSystemColor(clWindowText)); end; end; @@ -788,39 +804,27 @@ function Detour_UxTheme_GetThemeColor(hTheme: hTheme; iPartId, iStateId, iPropId begin pColor := clNone; case iPartId of - 5: case iStateId of - 0: - ColorToRGB(StyleServices.GetSystemColor(clHighlight)); + 0: ColorToRGB(StyleServices.GetSystemColor(clHighlight)); end; - 6: case iStateId of - 0: - pColor := ColorToRGB(StyleServices.GetSystemColor(clBtnText)); + 0: pColor := ColorToRGB(StyleServices.GetSystemColor(clBtnText)); end; - 7: case iStateId of - 1: - pColor := GetStyleHighLightColor(); - 2: - pColor := ColorToRGB(clGreen); + 1: pColor := GetStyleHighLightColor(); + 2: pColor := ColorToRGB(clGreen); end; - 8: case iStateId of - 0: - pColor := ColorToRGB(clRed); + 0: pColor := ColorToRGB(clRed); end; - 9: case iStateId of - 1: - pColor := ColorToRGB(clBlue); - 2: - pColor := ColorToRGB(clYellow); + 1: pColor := ColorToRGB(clBlue); + 2: pColor := ColorToRGB(clYellow); end; end; @@ -861,7 +865,7 @@ function Detour_UxTheme_GetThemeColor(hTheme: hTheme; iPartId, iStateId, iPropId pColor := ColorToRGB(StyleServices.GetSystemColor(clBtnText)); end; else - pColor := ColorToRGB(clRed); + pColor := ColorToRGB(clBtnText); end; if TColor(pColor) = clNone then @@ -878,14 +882,11 @@ function Detour_UxTheme_GetThemeColor(hTheme: hTheme; iPartId, iStateId, iPropId if SameText(LThemeClass, VSCLASS_TREEVIEW) or SameText(LThemeClass, VSCLASS_PROPERTREE) or SameText(LThemeClass, 'ExplorerNavPane') then begin - pColor := clNone; case iPartId of 0, 2: case iStateId of - 0: - pColor := ColorToRGB(StyleServices.GetSystemColor(clWindow)); // OK - + 0: pColor := ColorToRGB(StyleServices.GetSystemColor(clWindow)); // OK end; end; @@ -900,7 +901,7 @@ function Detour_UxTheme_GetThemeColor(hTheme: hTheme; iPartId, iStateId, iPropId else {$ENDIF} {$IFDEF HOOK_ListView} - if (SameText(LThemeClass, VSCLASS_ITEMSVIEW) or SameText(LThemeClass, VSCLASS_LISTVIEW) or + if (SameText(LThemeClass, VSCLASS_ITEMSVIEW) or SameText(LThemeClass, VSCLASS_LISTVIEW) or SameText(LThemeClass, VSCLASS_LISTVIEWSTYLE) or SameText(LThemeClass, VSCLASS_ITEMSVIEW_LISTVIEW) or SameText(LThemeClass, VSCLASS_EXPLORER_LISTVIEW)) then begin @@ -909,51 +910,38 @@ function Detour_UxTheme_GetThemeColor(hTheme: hTheme; iPartId, iStateId, iPropId case iPartId of 0: case iStateId of - 0: - pColor := ColorToRGB(StyleServices.GetSystemColor(clWindow)); + 0: pColor := ColorToRGB(StyleServices.GetSystemColor(clWindow)); end; LVP_LISTITEM: case iStateId of - 0: - pColor := ColorToRGB(clRed); + 0: pColor := ColorToRGB(clRed); end; LVP_LISTSORTEDDETAIL: case iStateId of - 1: - pColor := ColorToRGB(StyleServices.GetSystemColor(clWindowText)); + 1: pColor := ColorToRGB(StyleServices.GetSystemColor(clWindowText)); // normal main column (name) - 2: - pColor := ColorToRGB(clWindowText); - + 2: pColor := ColorToRGB(clWindowText); // SELECTED - 3: - pColor := ColorToRGB(StyleServices.GetSystemColor(clWindowText)); + 3: pColor := ColorToRGB(StyleServices.GetSystemColor(clWindowText)); // hot text - 4: - pColor := ColorToRGB(StyleServices.GetSystemColor(clWindowText)); - 5: - pColor := ColorToRGB(clBlue); - 6: - pColor := ColorToRGB(clYellow); - 7: - pColor := ColorToRGB(clGreen); - 8: - pColor := ColorToRGB(clFuchsia); + 4: pColor := ColorToRGB(StyleServices.GetSystemColor(clWindowText)); + 5: pColor := ColorToRGB(clBlue); + 6: pColor := ColorToRGB(clYellow); + 7: pColor := ColorToRGB(clGreen); + 8: pColor := ColorToRGB(clFuchsia); end; LVP_EMPTYTEXT: case iStateId of - 0: - pColor := ColorToRGB(StyleServices.GetSystemColor(clHighlight)); + 0: pColor := ColorToRGB(StyleServices.GetSystemColor(clHighlight)); end; LVP_GROUPHEADER: case iStateId of - 0: - pColor := ColorToRGB(StyleServices.GetSystemColor(clWindowText)); + 0: pColor := ColorToRGB(StyleServices.GetSystemColor(clWindowText)); end; end; @@ -977,39 +965,30 @@ function Detour_UxTheme_GetThemeColor(hTheme: hTheme; iPartId, iStateId, iPropId // button with dropdown 3: case iStateId of - 1: - pColor := ColorToRGB(GetStyleBtnTextColor); // GetStyleHighLightColor; - 6: - pColor := ColorToRGB(clYellow); // StyleServices.GetSystemColor(clBtnShadow); + 1: pColor := ColorToRGB(GetStyleBtnTextColor); // GetStyleHighLightColor; + 6: pColor := ColorToRGB(clYellow); // StyleServices.GetSystemColor(clBtnShadow); end; - 4: case iStateId of - 1: - pColor := ColorToRGB(GetStyleBtnTextColor); + 1: pColor := ColorToRGB(GetStyleBtnTextColor); end; 9: case iStateId of - 1: - pColor := ColorToRGB(GetStyleBtnTextColor); + 1: pColor := ColorToRGB(GetStyleBtnTextColor); // ColorToRGB(StyleServices.GetSystemColor(clBtnText)); // Highlight - 2: - pColor := ColorToRGB(GetStyleBtnTextColor); + 2: pColor := ColorToRGB(GetStyleBtnTextColor); // ColorToRGB(StyleServices.GetSystemColor(clBtnText)); //OK - 3: - pColor := ColorToRGB(GetStyleBtnTextColor); + 3: pColor := ColorToRGB(GetStyleBtnTextColor); // ColorToRGB(StyleServices.GetSystemColor(clBtnText)); //OK - 6: - pColor := ColorToRGB(clLime); // StyleServices.GetSystemColor(clBtnShadow); + 6: pColor := ColorToRGB(clLime); // StyleServices.GetSystemColor(clBtnShadow); end; // header text 10: case iStateId of - 1: - pColor := ColorToRGB(GetStyleHighLightColor); + 1: pColor := ColorToRGB(GetStyleHighLightColor); end; end; @@ -1019,6 +998,24 @@ function Detour_UxTheme_GetThemeColor(hTheme: hTheme; iPartId, iStateId, iPropId end else {$ENDIF} + {$IFDEF HOOK_EXPLORERSTATUSBAR} + if SameText(LThemeClass, VSCLASS_EXPLORERSTATUSBAR) then + begin + pColor := clNone; + if (iPartId = 0) and (iStateId = 0) then + begin + pColor := ColorToRGB(StyleServices.GetSystemColor(clWindow)); + end; + if TColor(pColor) = clNone then + begin + // OutputDebugString(PChar(Format('Detour_GetThemeColor Class %s hTheme %d iPartId %d iStateId %d iPropId %d Color %8.x', [LThemeClass, hTheme, iPartId, iStateId, iPropId, pColor]))); + Result := Trampoline_UxTheme_GetThemeColor(hTheme, iPartId, iStateId, iPropId, pColor); + end + else + Result := S_OK; + end + else + {$ENDIF} begin Result := Trampoline_UxTheme_GetThemeColor(hTheme, iPartId, iStateId, iPropId, pColor); // pColor:=ColorToRGB(clRed); @@ -1156,16 +1153,12 @@ function Detour_UxTheme_DrawThemeText(hTheme: hTheme; hdc: hdc; iPartId, iStateI SaveIndex := SaveDC(hdc); try case iStateId of - MPI_NORMAL: - LDetails := StyleServices.GetElementDetails(tmPopupItemNormal); - MPI_HOT: - LDetails := StyleServices.GetElementDetails(tmPopupItemHot); - // MPI_PUSHED : LDetails := StyleServices.GetElementDetails(tmMenuBarItemPushed); - MPI_DISABLED: - LDetails := StyleServices.GetElementDetails(tmPopupItemDisabled); - MPI_DISABLEDHOT: - LDetails := StyleServices.GetElementDetails(tmPopupItemDisabledHot); - // MPI_DISABLEDPUSHED : LDetails := StyleServices.GetElementDetails(tmMenuBarItemDisabledPushed); + MPI_NORMAL: LDetails := StyleServices.GetElementDetails(tmPopupItemNormal); + MPI_HOT: LDetails := StyleServices.GetElementDetails(tmPopupItemHot); + // MPI_PUSHED: LDetails := StyleServices.GetElementDetails(tmMenuBarItemPushed); + MPI_DISABLED: LDetails := StyleServices.GetElementDetails(tmPopupItemDisabled); + MPI_DISABLEDHOT: LDetails := StyleServices.GetElementDetails(tmPopupItemDisabledHot); + // MPI_DISABLEDPUSHED: LDetails := StyleServices.GetElementDetails(tmMenuBarItemDisabledPushed); else LDetails := StyleServices.GetElementDetails(tmPopupItemNormal); end; @@ -1186,18 +1179,12 @@ function Detour_UxTheme_DrawThemeText(hTheme: hTheme; hdc: hdc; iPartId, iStateI SaveIndex := SaveDC(hdc); try case iStateId of - MBI_NORMAL: - LDetails := StyleServices.GetElementDetails(tmPopupItemNormal); - MBI_HOT: - LDetails := StyleServices.GetElementDetails(tmMenuBarItemHot); - MBI_PUSHED: - LDetails := StyleServices.GetElementDetails(tmMenuBarItemPushed); - MBI_DISABLED: - LDetails := StyleServices.GetElementDetails(tmMenuBarItemDisabled); - MBI_DISABLEDHOT: - LDetails := StyleServices.GetElementDetails(tmMenuBarItemDisabledHot); - MBI_DISABLEDPUSHED: - LDetails := StyleServices.GetElementDetails(tmMenuBarItemDisabledPushed); + MBI_NORMAL: LDetails := StyleServices.GetElementDetails(tmPopupItemNormal); + MBI_HOT: LDetails := StyleServices.GetElementDetails(tmMenuBarItemHot); + MBI_PUSHED: LDetails := StyleServices.GetElementDetails(tmMenuBarItemPushed); + MBI_DISABLED: LDetails := StyleServices.GetElementDetails(tmMenuBarItemDisabled); + MBI_DISABLEDHOT: LDetails := StyleServices.GetElementDetails(tmMenuBarItemDisabledHot); + MBI_DISABLEDPUSHED: LDetails := StyleServices.GetElementDetails(tmMenuBarItemDisabledPushed); end; LRect := pRect; @@ -1259,11 +1246,11 @@ function Detour_UxTheme_DrawThemeText(hTheme: hTheme; hdc: hdc; iPartId, iStateI MC_TRAILINGGRIDCELLUPPER, MC_GRIDCELLUPPER, MC_GRIDCELL: begin // case iStateId of - // MCGCB_SELECTED : LDetails := StyleServices.GetElementDetails(tgCellSelected); - // MCGCB_HOT : LDetails := StyleServices.GetElementDetails(tgFixedCellHot); - // MCGCB_SELECTEDHOT : LDetails := StyleServices.GetElementDetails(tgCellSelected); - // MCGCB_SELECTEDNOTFOCUSED : LDetails := StyleServices.GetElementDetails(tgCellSelected); - // MCGCB_TODAY : LDetails := StyleServices.GetElementDetails(tgFixedCellHot); + // MCGCB_SELECTED: LDetails := StyleServices.GetElementDetails(tgCellSelected); + // MCGCB_HOT: LDetails := StyleServices.GetElementDetails(tgFixedCellHot); + // MCGCB_SELECTEDHOT: LDetails := StyleServices.GetElementDetails(tgCellSelected); + // MCGCB_SELECTEDNOTFOCUSED: LDetails := StyleServices.GetElementDetails(tgCellSelected); + // MCGCB_TODAY: LDetails := StyleServices.GetElementDetails(tgFixedCellHot); // else // LDetails := StyleServices.GetElementDetails(tgCellNormal); // end; @@ -1305,14 +1292,10 @@ function Detour_UxTheme_DrawThemeText(hTheme: hTheme; hdc: hdc; iPartId, iStateI MC_TRAILINGGRIDCELL: begin case iStateId of - MCTGC_HOT: - LDetails := StyleServices.GetElementDetails(tgFixedCellHot); - MCTGC_HASSTATE: - LDetails := StyleServices.GetElementDetails(tgCellSelected); - MCTGC_HASSTATEHOT: - LDetails := StyleServices.GetElementDetails(tgCellSelected); - MCTGC_TODAY: - LDetails := StyleServices.GetElementDetails(tgFixedCellHot); + MCTGC_HOT: LDetails := StyleServices.GetElementDetails(tgFixedCellHot); + MCTGC_HASSTATE: LDetails := StyleServices.GetElementDetails(tgCellSelected); + MCTGC_HASSTATEHOT: LDetails := StyleServices.GetElementDetails(tgCellSelected); + MCTGC_TODAY: LDetails := StyleServices.GetElementDetails(tgFixedCellHot); else LDetails := StyleServices.GetElementDetails(teEditTextDisabled); end; @@ -1363,18 +1346,12 @@ function Detour_UxTheme_DrawThemeText(hTheme: hTheme; hdc: hdc; iPartId, iStateI BP_PUSHBUTTON: begin case iStateId of - PBS_NORMAL: - LDetails := StyleServices.GetElementDetails(tbPushButtonNormal); - PBS_HOT: - LDetails := StyleServices.GetElementDetails(tbPushButtonHot); - PBS_PRESSED: - LDetails := StyleServices.GetElementDetails(tbPushButtonPressed); - PBS_DISABLED: - LDetails := StyleServices.GetElementDetails(tbPushButtonDisabled); - PBS_DEFAULTED: - LDetails := StyleServices.GetElementDetails(tbPushButtonDefaulted); - PBS_DEFAULTED_ANIMATING: - LDetails := StyleServices.GetElementDetails(tbPushButtonDefaultedAnimating); + PBS_NORMAL: LDetails := StyleServices.GetElementDetails(tbPushButtonNormal); + PBS_HOT: LDetails := StyleServices.GetElementDetails(tbPushButtonHot); + PBS_PRESSED: LDetails := StyleServices.GetElementDetails(tbPushButtonPressed); + PBS_DISABLED: LDetails := StyleServices.GetElementDetails(tbPushButtonDisabled); + PBS_DEFAULTED: LDetails := StyleServices.GetElementDetails(tbPushButtonDefaulted); + PBS_DEFAULTED_ANIMATING: LDetails := StyleServices.GetElementDetails(tbPushButtonDefaultedAnimating); end; // StyleServices.DrawText(hdc, LDetails, string(pszText), pRect, dwTextFlags, dwTextFlags2); @@ -1390,22 +1367,14 @@ function Detour_UxTheme_DrawThemeText(hTheme: hTheme; hdc: hdc; iPartId, iStateI BP_RADIOBUTTON: begin case iStateId of - RBS_UNCHECKEDNORMAL: - LDetails := StyleServices.GetElementDetails(tbRadioButtonUncheckedNormal); - RBS_UNCHECKEDHOT: - LDetails := StyleServices.GetElementDetails(tbRadioButtonUncheckedHot); - RBS_UNCHECKEDPRESSED: - LDetails := StyleServices.GetElementDetails(tbRadioButtonUncheckedPressed); - RBS_UNCHECKEDDISABLED: - LDetails := StyleServices.GetElementDetails(tbRadioButtonUncheckedDisabled); - RBS_CHECKEDNORMAL: - LDetails := StyleServices.GetElementDetails(tbRadioButtonCheckedNormal); - RBS_CHECKEDHOT: - LDetails := StyleServices.GetElementDetails(tbRadioButtonCheckedHot); - RBS_CHECKEDPRESSED: - LDetails := StyleServices.GetElementDetails(tbRadioButtonCheckedPressed); - RBS_CHECKEDDISABLED: - LDetails := StyleServices.GetElementDetails(tbRadioButtonCheckedDisabled); + RBS_UNCHECKEDNORMAL: LDetails := StyleServices.GetElementDetails(tbRadioButtonUncheckedNormal); + RBS_UNCHECKEDHOT: LDetails := StyleServices.GetElementDetails(tbRadioButtonUncheckedHot); + RBS_UNCHECKEDPRESSED: LDetails := StyleServices.GetElementDetails(tbRadioButtonUncheckedPressed); + RBS_UNCHECKEDDISABLED: LDetails := StyleServices.GetElementDetails(tbRadioButtonUncheckedDisabled); + RBS_CHECKEDNORMAL: LDetails := StyleServices.GetElementDetails(tbRadioButtonCheckedNormal); + RBS_CHECKEDHOT: LDetails := StyleServices.GetElementDetails(tbRadioButtonCheckedHot); + RBS_CHECKEDPRESSED: LDetails := StyleServices.GetElementDetails(tbRadioButtonCheckedPressed); + RBS_CHECKEDDISABLED: LDetails := StyleServices.GetElementDetails(tbRadioButtonCheckedDisabled); end; if not StyleServices.GetElementColor(LDetails, ecTextColor, ThemeTextColor) then @@ -1420,18 +1389,12 @@ function Detour_UxTheme_DrawThemeText(hTheme: hTheme; hdc: hdc; iPartId, iStateI begin case iStateId of - CMDLS_NORMAL: - LDetails := StyleServices.GetElementDetails(tbPushButtonNormal); - CMDLS_HOT: - LDetails := StyleServices.GetElementDetails(tbPushButtonHot); - CMDLS_PRESSED: - LDetails := StyleServices.GetElementDetails(tbPushButtonPressed); - CMDLS_DISABLED: - LDetails := StyleServices.GetElementDetails(tbPushButtonDisabled); - CMDLS_DEFAULTED: - LDetails := StyleServices.GetElementDetails(tbPushButtonDefaulted); - CMDLS_DEFAULTED_ANIMATING: - LDetails := StyleServices.GetElementDetails(tbPushButtonDefaultedAnimating); + CMDLS_NORMAL: LDetails := StyleServices.GetElementDetails(tbPushButtonNormal); + CMDLS_HOT: LDetails := StyleServices.GetElementDetails(tbPushButtonHot); + CMDLS_PRESSED: LDetails := StyleServices.GetElementDetails(tbPushButtonPressed); + CMDLS_DISABLED: LDetails := StyleServices.GetElementDetails(tbPushButtonDisabled); + CMDLS_DEFAULTED: LDetails := StyleServices.GetElementDetails(tbPushButtonDefaulted); + CMDLS_DEFAULTED_ANIMATING: LDetails := StyleServices.GetElementDetails(tbPushButtonDefaultedAnimating); end; LCanvas := TCanvas.Create; @@ -1509,7 +1472,7 @@ function Detour_UxTheme_DrawThemeTextEx(hTheme: hTheme; hdc: hdc; iPartId: Integ case iPartId of 1 : begin - if iStateId = 2 then + if iStateId in [1,2] then begin SaveIndex := SaveDC(hdc); try @@ -1614,18 +1577,12 @@ function Detour_UxTheme_DrawThemeTextEx(hTheme: hTheme; hdc: hdc; iPartId: Integ BP_COMMANDLINK: begin case iStateId of - CMDLS_NORMAL: - LDetails := StyleServices.GetElementDetails(tbPushButtonNormal); - CMDLS_HOT: - LDetails := StyleServices.GetElementDetails(tbPushButtonHot); - CMDLS_PRESSED: - LDetails := StyleServices.GetElementDetails(tbPushButtonPressed); - CMDLS_DISABLED: - LDetails := StyleServices.GetElementDetails(tbPushButtonDisabled); - CMDLS_DEFAULTED: - LDetails := StyleServices.GetElementDetails(tbPushButtonDefaulted); - CMDLS_DEFAULTED_ANIMATING: - LDetails := StyleServices.GetElementDetails(tbPushButtonDefaultedAnimating); + CMDLS_NORMAL: LDetails := StyleServices.GetElementDetails(tbPushButtonNormal); + CMDLS_HOT: LDetails := StyleServices.GetElementDetails(tbPushButtonHot); + CMDLS_PRESSED: LDetails := StyleServices.GetElementDetails(tbPushButtonPressed); + CMDLS_DISABLED: LDetails := StyleServices.GetElementDetails(tbPushButtonDisabled); + CMDLS_DEFAULTED: LDetails := StyleServices.GetElementDetails(tbPushButtonDefaulted); + CMDLS_DEFAULTED_ANIMATING: LDetails := StyleServices.GetElementDetails(tbPushButtonDefaultedAnimating); end; if not StyleServices.GetElementColor(LDetails, ecTextColor, ThemeTextColor) then @@ -1946,12 +1903,9 @@ function UxTheme_ListView(hTheme: hTheme; hdc: hdc; iPartId, iStateId: Integer; LVP_EXPANDBUTTON: begin case iStateId of - LVEB_NORMAL: - LDetails := StyleServices.GetElementDetails(tcpThemedChevronOpenedNormal); - LVEB_HOVER: - LDetails := StyleServices.GetElementDetails(tcpThemedChevronOpenedHot); - LVEB_PUSHED: - LDetails := StyleServices.GetElementDetails(tcpThemedChevronOpenedPressed); + LVEB_NORMAL: LDetails := StyleServices.GetElementDetails(tcpThemedChevronOpenedNormal); + LVEB_HOVER: LDetails := StyleServices.GetElementDetails(tcpThemedChevronOpenedHot); + LVEB_PUSHED: LDetails := StyleServices.GetElementDetails(tcpThemedChevronOpenedPressed); else LDetails := StyleServices.GetElementDetails(tcpThemedChevronOpenedNormal); end; @@ -1960,7 +1914,7 @@ function UxTheme_ListView(hTheme: hTheme; hdc: hdc; iPartId, iStateId: Integer; try if hwnd <> 0 then DrawStyleParentBackground(hwnd, hdc, pRect); - StyleServices.DrawElement(hdc, LDetails, pRect, nil); + DrawStyleElement(hdc, LDetails, pRect); finally RestoreDC(hdc, SaveIndex); end; @@ -1970,12 +1924,9 @@ function UxTheme_ListView(hTheme: hTheme; hdc: hdc; iPartId, iStateId: Integer; LVP_COLLAPSEBUTTON: begin case iStateId of - LVCB_NORMAL: - LDetails := StyleServices.GetElementDetails(tcpThemedChevronClosedNormal); - LVCB_HOVER: - LDetails := StyleServices.GetElementDetails(tcpThemedChevronClosedHot); - LVCB_PUSHED: - LDetails := StyleServices.GetElementDetails(tcpThemedChevronClosedPressed); + LVCB_NORMAL: LDetails := StyleServices.GetElementDetails(tcpThemedChevronClosedNormal); + LVCB_HOVER: LDetails := StyleServices.GetElementDetails(tcpThemedChevronClosedHot); + LVCB_PUSHED: LDetails := StyleServices.GetElementDetails(tcpThemedChevronClosedPressed); else LDetails := StyleServices.GetElementDetails(tcpThemedChevronClosedNormal); end; @@ -1984,7 +1935,7 @@ function UxTheme_ListView(hTheme: hTheme; hdc: hdc; iPartId, iStateId: Integer; try if hwnd <> 0 then DrawStyleParentBackground(hwnd, hdc, pRect); - StyleServices.DrawElement(hdc, LDetails, pRect, nil); + DrawStyleElement(hdc, LDetails, pRect); finally RestoreDC(hdc, SaveIndex); end; @@ -2102,33 +2053,18 @@ function UxTheme_Header(hTheme: hTheme; hdc: hdc; iPartId, iStateId: Integer; co HP_HEADERITEM: begin case iStateId of - HIS_NORMAL: - LDetails := StyleServices.GetElementDetails(thHeaderItemNormal); - HIS_HOT: - LDetails := StyleServices.GetElementDetails(thHeaderItemHot); - HIS_PRESSED: - LDetails := StyleServices.GetElementDetails(thHeaderItemPressed); - - HIS_SORTEDNORMAL: - LDetails := StyleServices.GetElementDetails(thHeaderItemNormal); - HIS_SORTEDHOT: - LDetails := StyleServices.GetElementDetails(thHeaderItemHot); - HIS_SORTEDPRESSED: - LDetails := StyleServices.GetElementDetails(thHeaderItemPressed); - - HIS_ICONNORMAL: - LDetails := StyleServices.GetElementDetails(thHeaderItemNormal); - HIS_ICONHOT: - LDetails := StyleServices.GetElementDetails(thHeaderItemHot); - HIS_ICONPRESSED: - LDetails := StyleServices.GetElementDetails(thHeaderItemPressed); - - HIS_ICONSORTEDNORMAL: - LDetails := StyleServices.GetElementDetails(thHeaderItemNormal); - HIS_ICONSORTEDHOT: - LDetails := StyleServices.GetElementDetails(thHeaderItemHot); - HIS_ICONSORTEDPRESSED: - LDetails := StyleServices.GetElementDetails(thHeaderItemPressed); + HIS_NORMAL: LDetails := StyleServices.GetElementDetails(thHeaderItemNormal); + HIS_HOT: LDetails := StyleServices.GetElementDetails(thHeaderItemHot); + HIS_PRESSED: LDetails := StyleServices.GetElementDetails(thHeaderItemPressed); + HIS_SORTEDNORMAL: LDetails := StyleServices.GetElementDetails(thHeaderItemNormal); + HIS_SORTEDHOT: LDetails := StyleServices.GetElementDetails(thHeaderItemHot); + HIS_SORTEDPRESSED: LDetails := StyleServices.GetElementDetails(thHeaderItemPressed); + HIS_ICONNORMAL: LDetails := StyleServices.GetElementDetails(thHeaderItemNormal); + HIS_ICONHOT: LDetails := StyleServices.GetElementDetails(thHeaderItemHot); + HIS_ICONPRESSED: LDetails := StyleServices.GetElementDetails(thHeaderItemPressed); + HIS_ICONSORTEDNORMAL: LDetails := StyleServices.GetElementDetails(thHeaderItemNormal); + HIS_ICONSORTEDHOT: LDetails := StyleServices.GetElementDetails(thHeaderItemHot); + HIS_ICONSORTEDPRESSED: LDetails := StyleServices.GetElementDetails(thHeaderItemPressed); else LDetails := StyleServices.GetElementDetails(thHeaderItemNormal); end; @@ -2137,7 +2073,7 @@ function UxTheme_Header(hTheme: hTheme; hdc: hdc; iPartId, iStateId: Integer; co try if hwnd <> 0 then DrawStyleParentBackground(hwnd, hdc, pRect); - StyleServices.DrawElement(hdc, LDetails, pRect, nil); + DrawStyleElement(hdc, LDetails, pRect); finally RestoreDC(hdc, SaveIndex); end; @@ -2148,8 +2084,8 @@ function UxTheme_Header(hTheme: hTheme; hdc: hdc; iPartId, iStateId: Integer; co HP_HEADERSORTARROW: begin // case iStateId of - // HSAS_SORTEDUP : LDetails := StyleServices.GetElementDetails(thHeaderSortArrowSortedUp); - // HSAS_SORTEDDOWN : LDetails := StyleServices.GetElementDetails(thHeaderSortArrowSortedDown); + // HSAS_SORTEDUP: LDetails := StyleServices.GetElementDetails(thHeaderSortArrowSortedUp); + // HSAS_SORTEDDOWN: LDetails := StyleServices.GetElementDetails(thHeaderSortArrowSortedDown); // end; LColor := GetStyleHighLightColor(); @@ -2166,14 +2102,11 @@ function UxTheme_Header(hTheme: hTheme; hdc: hdc; iPartId, iStateId: Integer; co HP_HEADERDROPDOWN: begin case iStateId of - HDDS_NORMAL: - LDetails := StyleServices.GetElementDetails(ttbSplitButtonDropDownNormal); + HDDS_NORMAL: LDetails := StyleServices.GetElementDetails(ttbSplitButtonDropDownNormal); // tcDropDownButtonNormal, thHeaderDropDownNormal - HDDS_SOFTHOT: - LDetails := StyleServices.GetElementDetails(ttbSplitButtonDropDownHot); + HDDS_SOFTHOT: LDetails := StyleServices.GetElementDetails(ttbSplitButtonDropDownHot); // tcDropDownButtonHot, thHeaderDropDownSoftHot - HDDS_HOT: - LDetails := StyleServices.GetElementDetails(ttbSplitButtonDropDownHot); + HDDS_HOT: LDetails := StyleServices.GetElementDetails(ttbSplitButtonDropDownHot); // tcDropDownButtonHot, thHeaderDropDownHot end; @@ -2184,14 +2117,11 @@ function UxTheme_Header(hTheme: hTheme; hdc: hdc; iPartId, iStateId: Integer; co HP_HEADERDROPDOWNFILTER: begin case iStateId of - HDDFS_NORMAL: - LDetails := StyleServices.GetElementDetails(ttbSplitButtonDropDownNormal); + HDDFS_NORMAL: LDetails := StyleServices.GetElementDetails(ttbSplitButtonDropDownNormal); // tcDropDownButtonNormal, thHeaderDropDownNormal - HDDFS_SOFTHOT: - LDetails := StyleServices.GetElementDetails(ttbSplitButtonDropDownHot); + HDDFS_SOFTHOT: LDetails := StyleServices.GetElementDetails(ttbSplitButtonDropDownHot); // tcDropDownButtonHot, thHeaderDropDownSoftHot - HDDFS_HOT: - LDetails := StyleServices.GetElementDetails(ttbSplitButtonDropDownHot); + HDDFS_HOT: LDetails := StyleServices.GetElementDetails(ttbSplitButtonDropDownHot); // tcDropDownButtonHot, thHeaderDropDownHot end; @@ -2374,12 +2304,10 @@ function UxTheme_ToolBar(hTheme: hTheme; hdc: hdc; iPartId, iStateId: Integer; c 0: begin case iStateId of - 0: begin if (hwnd <> 0) then DrawStyleParentBackground(hwnd, hdc, pRect); - LDetails.Element := teToolBar; LDetails.Part := 0; LDetails.State := 0; @@ -2388,7 +2316,6 @@ function UxTheme_ToolBar(hTheme: hTheme; hdc: hdc; iPartId, iStateId: Integer; c DrawStyleElement(hdc, StyleServices.GetElementDetails(tmPopupBackground), pRect); exit(S_OK); end; - end; end; @@ -2716,16 +2643,11 @@ function UxTheme_MonthCal(hTheme: hTheme; hdc: hdc; iPartId, iStateId: Integer; MC_NAVNEXT: begin case iStateId of - MCNN_NORMAL: - LDetails := StyleServices.GetElementDetails(tsArrowBtnRightNormal); - MCNN_HOT: - LDetails := StyleServices.GetElementDetails(tsArrowBtnRightHot); - MCNN_PRESSED: - LDetails := StyleServices.GetElementDetails(tsArrowBtnRightPressed); - MCNN_DISABLED: - LDetails := StyleServices.GetElementDetails(tsArrowBtnRightDisabled); + MCNN_NORMAL: LDetails := StyleServices.GetElementDetails(tsArrowBtnRightNormal); + MCNN_HOT: LDetails := StyleServices.GetElementDetails(tsArrowBtnRightHot); + MCNN_PRESSED: LDetails := StyleServices.GetElementDetails(tsArrowBtnRightPressed); + MCNN_DISABLED: LDetails := StyleServices.GetElementDetails(tsArrowBtnRightDisabled); end; - DrawStyleElement(hdc, LDetails, pRect); exit(S_OK); end; @@ -2733,14 +2655,10 @@ function UxTheme_MonthCal(hTheme: hTheme; hdc: hdc; iPartId, iStateId: Integer; MC_NAVPREV: begin case iStateId of - MCNP_NORMAL: - LDetails := StyleServices.GetElementDetails(tsArrowBtnLeftNormal); - MCNP_HOT: - LDetails := StyleServices.GetElementDetails(tsArrowBtnLeftHot); - MCNP_PRESSED: - LDetails := StyleServices.GetElementDetails(tsArrowBtnLeftPressed); - MCNP_DISABLED: - LDetails := StyleServices.GetElementDetails(tsArrowBtnLeftDisabled); + MCNP_NORMAL: LDetails := StyleServices.GetElementDetails(tsArrowBtnLeftNormal); + MCNP_HOT: LDetails := StyleServices.GetElementDetails(tsArrowBtnLeftHot); + MCNP_PRESSED: LDetails := StyleServices.GetElementDetails(tsArrowBtnLeftPressed); + MCNP_DISABLED: LDetails := StyleServices.GetElementDetails(tsArrowBtnLeftDisabled); end; DrawStyleElement(hdc, LDetails, pRect); @@ -2763,14 +2681,10 @@ function UxTheme_DatePicker(hTheme: hTheme; hdc: hdc; iPartId, iStateId: Integer DP_DATEBORDER: begin case iStateId of - DPDB_NORMAL: - LDetails := StyleServices.GetElementDetails(teEditBorderNoScrollNormal); - DPDB_HOT: - LDetails := StyleServices.GetElementDetails(teEditBorderNoScrollHot); - DPDB_FOCUSED: - LDetails := StyleServices.GetElementDetails(teEditBorderNoScrollFocused); - DPDB_DISABLED: - LDetails := StyleServices.GetElementDetails(teEditBorderNoScrollDisabled); + DPDB_NORMAL: LDetails := StyleServices.GetElementDetails(teEditBorderNoScrollNormal); + DPDB_HOT: LDetails := StyleServices.GetElementDetails(teEditBorderNoScrollHot); + DPDB_FOCUSED: LDetails := StyleServices.GetElementDetails(teEditBorderNoScrollFocused); + DPDB_DISABLED: LDetails := StyleServices.GetElementDetails(teEditBorderNoScrollDisabled); end; DrawStyleElement(hdc, LDetails, pRect); @@ -2781,14 +2695,10 @@ function UxTheme_DatePicker(hTheme: hTheme; hdc: hdc; iPartId, iStateId: Integer begin case iStateId of - DPSCBR_NORMAL: - LDetails := StyleServices.GetElementDetails(tcBorderNormal); - DPSCBR_HOT: - LDetails := StyleServices.GetElementDetails(tcBorderHot); - DPSCBR_PRESSED: - LDetails := StyleServices.GetElementDetails(tcBorderHot); - DPSCBR_DISABLED: - LDetails := StyleServices.GetElementDetails(tcBorderDisabled); + DPSCBR_NORMAL: LDetails := StyleServices.GetElementDetails(tcBorderNormal); + DPSCBR_HOT: LDetails := StyleServices.GetElementDetails(tcBorderHot); + DPSCBR_PRESSED: LDetails := StyleServices.GetElementDetails(tcBorderHot); + DPSCBR_DISABLED: LDetails := StyleServices.GetElementDetails(tcBorderDisabled); end; DrawStyleElement(hdc, LDetails, pRect); @@ -2915,26 +2825,18 @@ function UxTheme_Spin(hTheme: hTheme; hdc: hdc; iPartId, iStateId: Integer; cons SPNP_UP: begin case iStateId of - UPS_NORMAL: - LDetails := StyleServices.GetElementDetails(tsUpNormal); - UPS_HOT: - LDetails := StyleServices.GetElementDetails(tsUpHot); - UPS_PRESSED: - LDetails := StyleServices.GetElementDetails(tsUpPressed); - UPS_DISABLED: - LDetails := StyleServices.GetElementDetails(tsUpDisabled); + UPS_NORMAL: LDetails := StyleServices.GetElementDetails(tsUpNormal); + UPS_HOT: LDetails := StyleServices.GetElementDetails(tsUpHot); + UPS_PRESSED: LDetails := StyleServices.GetElementDetails(tsUpPressed); + UPS_DISABLED: LDetails := StyleServices.GetElementDetails(tsUpDisabled); end; LColor := StyleServices.GetStyleFontColor(TStyleFont.sfButtonTextNormal); case iStateId of - UPS_NORMAL: - LColor := StyleServices.GetStyleFontColor(TStyleFont.sfButtonTextNormal); - UPS_HOT: - LColor := StyleServices.GetStyleFontColor(TStyleFont.sfButtonTextHot); - UPS_PRESSED: - LColor := StyleServices.GetStyleFontColor(TStyleFont.sfButtonTextPressed); - UPS_DISABLED: - LColor := StyleServices.GetStyleFontColor(TStyleFont.sfButtonTextDisabled); + UPS_NORMAL: LColor := StyleServices.GetStyleFontColor(TStyleFont.sfButtonTextNormal); + UPS_HOT: LColor := StyleServices.GetStyleFontColor(TStyleFont.sfButtonTextHot); + UPS_PRESSED: LColor := StyleServices.GetStyleFontColor(TStyleFont.sfButtonTextPressed); + UPS_DISABLED: LColor := StyleServices.GetStyleFontColor(TStyleFont.sfButtonTextDisabled); end; DrawStyleElement(hdc, LDetails, pRect); @@ -2942,35 +2844,25 @@ function UxTheme_Spin(hTheme: hTheme; hdc: hdc; iPartId, iStateId: Integer; cons LRect.Top := LRect.Top + 3; LRect.Left := LRect.Left + 5; DrawStyleArrow(hdc, TScrollDirection.sdUp, LRect.Location, 2, LColor); - exit(S_OK); end; SPNP_DOWN: begin case iStateId of - DNS_NORMAL: - LDetails := StyleServices.GetElementDetails(tsDownNormal); - DNS_HOT: - LDetails := StyleServices.GetElementDetails(tsDownHot); - DNS_PRESSED: - LDetails := StyleServices.GetElementDetails(tsDownPressed); - DNS_DISABLED: - LDetails := StyleServices.GetElementDetails(tsDownDisabled); + DNS_NORMAL: LDetails := StyleServices.GetElementDetails(tsDownNormal); + DNS_HOT: LDetails := StyleServices.GetElementDetails(tsDownHot); + DNS_PRESSED: LDetails := StyleServices.GetElementDetails(tsDownPressed); + DNS_DISABLED: LDetails := StyleServices.GetElementDetails(tsDownDisabled); end; LColor := StyleServices.GetStyleFontColor(TStyleFont.sfButtonTextNormal); case iStateId of - DNS_NORMAL: - LColor := StyleServices.GetStyleFontColor(TStyleFont.sfButtonTextNormal); - DNS_HOT: - LColor := StyleServices.GetStyleFontColor(TStyleFont.sfButtonTextHot); - DNS_PRESSED: - LColor := StyleServices.GetStyleFontColor(TStyleFont.sfButtonTextPressed); - DNS_DISABLED: - LColor := StyleServices.GetStyleFontColor(TStyleFont.sfButtonTextDisabled); + DNS_NORMAL: LColor := StyleServices.GetStyleFontColor(TStyleFont.sfButtonTextNormal); + DNS_HOT: LColor := StyleServices.GetStyleFontColor(TStyleFont.sfButtonTextHot); + DNS_PRESSED: LColor := StyleServices.GetStyleFontColor(TStyleFont.sfButtonTextPressed); + DNS_DISABLED: LColor := StyleServices.GetStyleFontColor(TStyleFont.sfButtonTextDisabled); end; - DrawStyleElement(hdc, LDetails, pRect); LRect := pRect; LRect.Top := LRect.Top + 3; @@ -2995,16 +2887,11 @@ function UxTheme_ListBox(hTheme: hTheme; hdc: hdc; iPartId, iStateId: Integer; c LBCP_BORDER_NOSCROLL: begin case iStateId of - LBPSN_NORMAL: - LDetails := StyleServices.GetElementDetails(teEditBorderNoScrollNormal); - LBPSN_FOCUSED: - LDetails := StyleServices.GetElementDetails(teEditBorderNoScrollFocused); - LBPSN_HOT: - LDetails := StyleServices.GetElementDetails(teEditBorderNoScrollHot); - LBPSN_DISABLED: - LDetails := StyleServices.GetElementDetails(teEditBorderNoScrollDisabled); + LBPSN_NORMAL: LDetails := StyleServices.GetElementDetails(teEditBorderNoScrollNormal); + LBPSN_FOCUSED: LDetails := StyleServices.GetElementDetails(teEditBorderNoScrollFocused); + LBPSN_HOT: LDetails := StyleServices.GetElementDetails(teEditBorderNoScrollHot); + LBPSN_DISABLED: LDetails := StyleServices.GetElementDetails(teEditBorderNoScrollDisabled); end; - DrawStyleElement(hdc, LDetails, pRect); exit(S_OK); end; @@ -3051,7 +2938,6 @@ function UxTheme_Navigation(hTheme: hTheme; hdc: hdc; iPartId, iStateId: Integer DrawStyleFillRect(LBitmap.Canvas.Handle, pRect, LColor); case iStateId of - 1: begin DrawStyleElement(LBitmap.Canvas.Handle, StyleServices.GetElementDetails(ttbButtonNormal), pRect); @@ -3106,11 +2992,9 @@ function UxTheme_Navigation(hTheme: hTheme; hdc: hdc; iPartId, iStateId: Integer LCanvas.Handle := 0; LCanvas.Free; end; - finally LBitmap.Free; end; - exit(S_OK); end; end; @@ -3227,45 +3111,60 @@ function UxTheme_TreeView(hTheme: hTheme; hdc: hdc; iPartId, iStateId: Integer; end; end; end; - // OutputDebugString(PChar(Format('UxTheme_TreeView class %s hTheme %d iPartId %d iStateId %d', [THThemesClasses.Items[hTheme],hTheme, iPartId, iStateId]))); exit(Trampoline(hTheme, hdc, iPartId, iStateId, pRect, Foo)); end; {$ENDIF} {$IF Defined(HOOK_Button) or Defined(HOOK_AllButtons)} -function UxTheme_Button(hTheme: hTheme; hdc: hdc; iPartId, iStateId: Integer; const pRect: TRect; Foo: Pointer; - Trampoline: TDrawThemeBackground; LThemeClass: string; hwnd: hwnd): HRESULT; stdcall; +function UxTheme_Button(hTheme: hTheme; hndc: hdc; iPartId, iStateId: Integer; + const pRect: TRect; Foo: Pointer; Trampoline: TDrawThemeBackground; + LThemeClass: string; hwnd: hwnd): HRESULT; stdcall; var LDetails: TThemedElementDetails; SaveIndex: Integer; + LBtnBmp: TBitmap; + LDC: HDC; + LColor: TColor; + LCanvas: TCanvas; begin case iPartId of BP_PUSHBUTTON: begin case iStateId of - PBS_NORMAL: - LDetails := StyleServices.GetElementDetails(tbPushButtonNormal); - PBS_HOT: - LDetails := StyleServices.GetElementDetails(tbPushButtonHot); - PBS_PRESSED: - LDetails := StyleServices.GetElementDetails(tbPushButtonPressed); - PBS_DISABLED: - LDetails := StyleServices.GetElementDetails(tbPushButtonDisabled); - PBS_DEFAULTED: - LDetails := StyleServices.GetElementDetails(tbPushButtonDefaulted); - PBS_DEFAULTED_ANIMATING: - LDetails := StyleServices.GetElementDetails(tbPushButtonDefaultedAnimating); + PBS_NORMAL: LDetails := StyleServices.GetElementDetails(tbPushButtonNormal); + PBS_HOT: LDetails := StyleServices.GetElementDetails(tbPushButtonHot); + PBS_PRESSED: LDetails := StyleServices.GetElementDetails(tbPushButtonPressed); + PBS_DISABLED: LDetails := StyleServices.GetElementDetails(tbPushButtonDisabled); + PBS_DEFAULTED: LDetails := StyleServices.GetElementDetails(tbPushButtonDefaulted); + PBS_DEFAULTED_ANIMATING: LDetails := StyleServices.GetElementDetails(tbPushButtonDefaultedAnimating); end; - - SaveIndex := SaveDC(hdc); + + SaveIndex := SaveDC(hndc); try - if hwnd <> 0 then - DrawStyleParentBackground(hwnd, hdc, pRect); - StyleServices.DrawElement(hdc, LDetails, pRect, nil); + LBtnBmp := TBitmap.Create; + LCanvas := TCanvas.Create; + try + LCanvas.Handle := hndc; + LBtnBmp.PixelFormat := pf24bit; + LBtnBmp.Transparent := True; + LBtnBmp.SetSize(pRect.Width, pRect.Height); + LDC := LBtnBmp.Canvas.Handle; + LColor := StyleServices.GetSystemColor(clBtnFace); + DrawStyleFillRect(LDC, pRect, LColor); + + if hwnd <> 0 then + DrawStyleParentBackground(hwnd, hndc, pRect); + DrawStyleElement(LDC, LDetails, pRect); + + LCanvas.Draw(0, 0, LBtnBmp); + finally + LCanvas.Free; + LBtnBmp.Free; + end; finally - RestoreDC(hdc, SaveIndex); + RestoreDC(hndc, SaveIndex); end; exit(S_OK); @@ -3275,27 +3174,38 @@ function UxTheme_Button(hTheme: hTheme; hdc: hdc; iPartId, iStateId: Integer; co begin case iStateId of - CMDLS_NORMAL: - LDetails := StyleServices.GetElementDetails(tbPushButtonNormal); - CMDLS_HOT: - LDetails := StyleServices.GetElementDetails(tbPushButtonHot); - CMDLS_PRESSED: - LDetails := StyleServices.GetElementDetails(tbPushButtonPressed); - CMDLS_DISABLED: - LDetails := StyleServices.GetElementDetails(tbPushButtonDisabled); - CMDLS_DEFAULTED: - LDetails := StyleServices.GetElementDetails(tbPushButtonDefaulted); - CMDLS_DEFAULTED_ANIMATING: - LDetails := StyleServices.GetElementDetails(tbPushButtonDefaultedAnimating); + CMDLS_NORMAL: LDetails := StyleServices.GetElementDetails(tbPushButtonNormal); + CMDLS_HOT: LDetails := StyleServices.GetElementDetails(tbPushButtonHot); + CMDLS_PRESSED: LDetails := StyleServices.GetElementDetails(tbPushButtonPressed); + CMDLS_DISABLED: LDetails := StyleServices.GetElementDetails(tbPushButtonDisabled); + CMDLS_DEFAULTED: LDetails := StyleServices.GetElementDetails(tbPushButtonDefaulted); + CMDLS_DEFAULTED_ANIMATING: LDetails := StyleServices.GetElementDetails(tbPushButtonDefaultedAnimating); end; - SaveIndex := SaveDC(hdc); + SaveIndex := SaveDC(hndc); try - if hwnd <> 0 then - DrawStyleParentBackground(hwnd, hdc, pRect); - StyleServices.DrawElement(hdc, LDetails, pRect, nil); + LBtnBmp := TBitmap.Create; + LCanvas := TCanvas.Create; + try + LCanvas.Handle := hndc; + LBtnBmp.PixelFormat := pf24bit; + LBtnBmp.Transparent := True; + LBtnBmp.SetSize(pRect.Width, pRect.Height); + LDC := LBtnBmp.Canvas.Handle; + LColor := StyleServices.GetSystemColor(clBtnFace); + DrawStyleFillRect(LDC, pRect, LColor); + + if hwnd <> 0 then + DrawStyleParentBackground(hwnd, hndc, pRect); + DrawStyleElement(LDC, LDetails, pRect); + + LCanvas.Draw(0, 0, LBtnBmp); + finally + LCanvas.Free; + LBtnBmp.Free; + end; finally - RestoreDC(hdc, SaveIndex); + RestoreDC(hndc, SaveIndex); end; exit(S_OK); @@ -3304,25 +3214,20 @@ function UxTheme_Button(hTheme: hTheme; hdc: hdc; iPartId, iStateId: Integer; co BP_COMMANDLINKGLYPH: begin case iStateId of - CMDLGS_NORMAL: - LDetails := StyleServices.GetElementDetails(tbCommandLinkGlyphNormal); - CMDLGS_HOT: - LDetails := StyleServices.GetElementDetails(tbCommandLinkGlyphHot); - CMDLGS_PRESSED: - LDetails := StyleServices.GetElementDetails(tbCommandLinkGlyphPressed); - CMDLGS_DISABLED: - LDetails := StyleServices.GetElementDetails(tbCommandLinkGlyphDisabled); - CMDLGS_DEFAULTED: - LDetails := StyleServices.GetElementDetails(tbCommandLinkGlyphDefaulted); + CMDLGS_NORMAL: LDetails := StyleServices.GetElementDetails(tbCommandLinkGlyphNormal); + CMDLGS_HOT: LDetails := StyleServices.GetElementDetails(tbCommandLinkGlyphHot); + CMDLGS_PRESSED: LDetails := StyleServices.GetElementDetails(tbCommandLinkGlyphPressed); + CMDLGS_DISABLED: LDetails := StyleServices.GetElementDetails(tbCommandLinkGlyphDisabled); + CMDLGS_DEFAULTED: LDetails := StyleServices.GetElementDetails(tbCommandLinkGlyphDefaulted); end; - SaveIndex := SaveDC(hdc); + SaveIndex := SaveDC(hndc); try if hwnd <> 0 then - DrawStyleParentBackground(hwnd, hdc, pRect); - StyleServices.DrawElement(hdc, LDetails, pRect, nil); + DrawStyleParentBackground(hwnd, hndc, pRect); + DrawStyleElement(hndc, LDetails, pRect); finally - RestoreDC(hdc, SaveIndex); + RestoreDC(hndc, SaveIndex); end; exit(S_OK); @@ -3331,81 +3236,53 @@ function UxTheme_Button(hTheme: hTheme; hdc: hdc; iPartId, iStateId: Integer; co BP_RADIOBUTTON: begin case iStateId of - RBS_UNCHECKEDNORMAL: - LDetails := StyleServices.GetElementDetails(tbRadioButtonUncheckedNormal); - RBS_UNCHECKEDHOT: - LDetails := StyleServices.GetElementDetails(tbRadioButtonUncheckedHot); - RBS_UNCHECKEDPRESSED: - LDetails := StyleServices.GetElementDetails(tbRadioButtonUncheckedPressed); - RBS_UNCHECKEDDISABLED: - LDetails := StyleServices.GetElementDetails(tbRadioButtonUncheckedDisabled); - RBS_CHECKEDNORMAL: - LDetails := StyleServices.GetElementDetails(tbRadioButtonCheckedNormal); - RBS_CHECKEDHOT: - LDetails := StyleServices.GetElementDetails(tbRadioButtonCheckedHot); - RBS_CHECKEDPRESSED: - LDetails := StyleServices.GetElementDetails(tbRadioButtonCheckedPressed); - RBS_CHECKEDDISABLED: - LDetails := StyleServices.GetElementDetails(tbRadioButtonCheckedDisabled); + RBS_UNCHECKEDNORMAL: LDetails := StyleServices.GetElementDetails(tbRadioButtonUncheckedNormal); + RBS_UNCHECKEDHOT: LDetails := StyleServices.GetElementDetails(tbRadioButtonUncheckedHot); + RBS_UNCHECKEDPRESSED: LDetails := StyleServices.GetElementDetails(tbRadioButtonUncheckedPressed); + RBS_UNCHECKEDDISABLED: LDetails := StyleServices.GetElementDetails(tbRadioButtonUncheckedDisabled); + RBS_CHECKEDNORMAL: LDetails := StyleServices.GetElementDetails(tbRadioButtonCheckedNormal); + RBS_CHECKEDHOT: LDetails := StyleServices.GetElementDetails(tbRadioButtonCheckedHot); + RBS_CHECKEDPRESSED: LDetails := StyleServices.GetElementDetails(tbRadioButtonCheckedPressed); + RBS_CHECKEDDISABLED: LDetails := StyleServices.GetElementDetails(tbRadioButtonCheckedDisabled); end; - DrawStyleElement(hdc, LDetails, pRect); + DrawStyleElement(hndc, LDetails, pRect); exit(S_OK); end; BP_CHECKBOX: begin case iStateId of - CBS_UNCHECKEDNORMAL: - LDetails := StyleServices.GetElementDetails(tbCheckBoxUncheckedNormal); - CBS_UNCHECKEDHOT: - LDetails := StyleServices.GetElementDetails(tbCheckBoxUncheckedHot); - CBS_UNCHECKEDPRESSED: - LDetails := StyleServices.GetElementDetails(tbCheckBoxUncheckedPressed); - CBS_UNCHECKEDDISABLED: - LDetails := StyleServices.GetElementDetails(tbCheckBoxUncheckedDisabled); - CBS_CHECKEDNORMAL: - LDetails := StyleServices.GetElementDetails(tbCheckBoxCheckedNormal); - CBS_CHECKEDHOT: - LDetails := StyleServices.GetElementDetails(tbCheckBoxCheckedHot); - CBS_CHECKEDPRESSED: - LDetails := StyleServices.GetElementDetails(tbCheckBoxCheckedPressed); - CBS_CHECKEDDISABLED: - LDetails := StyleServices.GetElementDetails(tbCheckBoxCheckedDisabled); - CBS_MIXEDNORMAL: - LDetails := StyleServices.GetElementDetails(tbCheckBoxMixedNormal); - CBS_MIXEDHOT: - LDetails := StyleServices.GetElementDetails(tbCheckBoxMixedHot); - CBS_MIXEDPRESSED: - LDetails := StyleServices.GetElementDetails(tbCheckBoxMixedPressed); - CBS_MIXEDDISABLED: - LDetails := StyleServices.GetElementDetails(tbCheckBoxMixedDisabled); + CBS_UNCHECKEDNORMAL: LDetails := StyleServices.GetElementDetails(tbCheckBoxUncheckedNormal); + CBS_UNCHECKEDHOT: LDetails := StyleServices.GetElementDetails(tbCheckBoxUncheckedHot); + CBS_UNCHECKEDPRESSED: LDetails := StyleServices.GetElementDetails(tbCheckBoxUncheckedPressed); + CBS_UNCHECKEDDISABLED: LDetails := StyleServices.GetElementDetails(tbCheckBoxUncheckedDisabled); + CBS_CHECKEDNORMAL: LDetails := StyleServices.GetElementDetails(tbCheckBoxCheckedNormal); + CBS_CHECKEDHOT: LDetails := StyleServices.GetElementDetails(tbCheckBoxCheckedHot); + CBS_CHECKEDPRESSED: LDetails := StyleServices.GetElementDetails(tbCheckBoxCheckedPressed); + CBS_CHECKEDDISABLED: LDetails := StyleServices.GetElementDetails(tbCheckBoxCheckedDisabled); + CBS_MIXEDNORMAL: LDetails := StyleServices.GetElementDetails(tbCheckBoxMixedNormal); + CBS_MIXEDHOT: LDetails := StyleServices.GetElementDetails(tbCheckBoxMixedHot); + CBS_MIXEDPRESSED: LDetails := StyleServices.GetElementDetails(tbCheckBoxMixedPressed); + CBS_MIXEDDISABLED: LDetails := StyleServices.GetElementDetails(tbCheckBoxMixedDisabled); { For Windows >= Vista } - CBS_IMPLICITNORMAL: - LDetails := StyleServices.GetElementDetails(tbCheckBoxImplicitNormal); - CBS_IMPLICITHOT: - LDetails := StyleServices.GetElementDetails(tbCheckBoxImplicitHot); - CBS_IMPLICITPRESSED: - LDetails := StyleServices.GetElementDetails(tbCheckBoxImplicitPressed); - CBS_IMPLICITDISABLED: - LDetails := StyleServices.GetElementDetails(tbCheckBoxImplicitDisabled); - CBS_EXCLUDEDNORMAL: - LDetails := StyleServices.GetElementDetails(tbCheckBoxExcludedNormal); - CBS_EXCLUDEDHOT: - LDetails := StyleServices.GetElementDetails(tbCheckBoxExcludedHot); - CBS_EXCLUDEDPRESSED: - LDetails := StyleServices.GetElementDetails(tbCheckBoxExcludedPressed); - CBS_EXCLUDEDDISABLED: - LDetails := StyleServices.GetElementDetails(tbCheckBoxExcludedDisabled); + CBS_IMPLICITNORMAL: LDetails := StyleServices.GetElementDetails(tbCheckBoxImplicitNormal); + CBS_IMPLICITHOT: LDetails := StyleServices.GetElementDetails(tbCheckBoxImplicitHot); + CBS_IMPLICITPRESSED: LDetails := StyleServices.GetElementDetails(tbCheckBoxImplicitPressed); + CBS_IMPLICITDISABLED: LDetails := StyleServices.GetElementDetails(tbCheckBoxImplicitDisabled); + CBS_EXCLUDEDNORMAL: LDetails := StyleServices.GetElementDetails(tbCheckBoxExcludedNormal); + CBS_EXCLUDEDHOT: LDetails := StyleServices.GetElementDetails(tbCheckBoxExcludedHot); + CBS_EXCLUDEDPRESSED: LDetails := StyleServices.GetElementDetails(tbCheckBoxExcludedPressed); + CBS_EXCLUDEDDISABLED: LDetails := StyleServices.GetElementDetails(tbCheckBoxExcludedDisabled); end; - DrawStyleElement(hdc, LDetails, pRect); + DrawStyleElement(hndc, LDetails, pRect); exit(S_OK); end end; // OutputDebugString(PChar(Format('UxTheme_Button class %s hTheme %d iPartId %d iStateId %d', [THThemesClasses.Items[hTheme],hTheme, iPartId, iStateId]))); - exit(Trampoline(hTheme, hdc, iPartId, iStateId, pRect, Foo)); + exit(Trampoline(hTheme, hndc, iPartId, iStateId, pRect, Foo)); end; {$ENDIF} @@ -3423,7 +3300,6 @@ function UxTheme_TaskDialog(hTheme: hTheme; hdc: hdc; iPartId, iStateId: Integer TDLG_PRIMARYPANEL: begin // LDetails := StyleServices.GetElementDetails(ttdPrimaryPanel); //ttdPrimaryPanel this element is not included in the VCL Styles yet - LColor := StyleServices.GetStyleColor(scEdit); if LColor = StyleServices.GetStyleColor(scBorder) then LColor := StyleServices.GetStyleColor(scPanel); // GetShadowColor(LColor, -10); @@ -3442,25 +3318,19 @@ function UxTheme_TaskDialog(hTheme: hTheme; hdc: hdc; iPartId, iStateId: Integer TDLG_EXPANDOBUTTON: begin case iStateId of - TDLGEBS_NORMAL: - LDetails := StyleServices.GetElementDetails(tcpThemedChevronClosedNormal); - TDLGEBS_HOVER: - LDetails := StyleServices.GetElementDetails(tcpThemedChevronClosedHot); - TDLGEBS_PRESSED: - LDetails := StyleServices.GetElementDetails(tcpThemedChevronClosedPressed); - TDLGEBS_EXPANDEDNORMAL: - LDetails := StyleServices.GetElementDetails(tcpThemedChevronOpenedNormal); - TDLGEBS_EXPANDEDHOVER: - LDetails := StyleServices.GetElementDetails(tcpThemedChevronOpenedHot); - TDLGEBS_EXPANDEDPRESSED: - LDetails := StyleServices.GetElementDetails(tcpThemedChevronOpenedPressed); + TDLGEBS_NORMAL: LDetails := StyleServices.GetElementDetails(tcpThemedChevronClosedNormal); + TDLGEBS_HOVER: LDetails := StyleServices.GetElementDetails(tcpThemedChevronClosedHot); + TDLGEBS_PRESSED: LDetails := StyleServices.GetElementDetails(tcpThemedChevronClosedPressed); + TDLGEBS_EXPANDEDNORMAL: LDetails := StyleServices.GetElementDetails(tcpThemedChevronOpenedNormal); + TDLGEBS_EXPANDEDHOVER: LDetails := StyleServices.GetElementDetails(tcpThemedChevronOpenedHot); + TDLGEBS_EXPANDEDPRESSED: LDetails := StyleServices.GetElementDetails(tcpThemedChevronOpenedPressed); end; SaveIndex := SaveDC(hdc); try if (hwnd <> 0) then DrawStyleParentBackground(hwnd, hdc, pRect); - StyleServices.DrawElement(hdc, LDetails, pRect, nil); + DrawStyleElement(hdc, LDetails, pRect); finally RestoreDC(hdc, SaveIndex); end; @@ -3493,7 +3363,7 @@ function UxTheme_TaskDialog(hTheme: hTheme; hdc: hdc; iPartId, iStateId: Integer end end; - OutputDebugString(PChar(Format('UxTheme_TaskDialog class %s hTheme %d iPartId %d iStateId %d', [THThemesClasses.Items[hTheme],hTheme, iPartId, iStateId]))); + // OutputDebugString(PChar(Format('UxTheme_TaskDialog class %s hTheme %d iPartId %d iStateId %d', [THThemesClasses.Items[hTheme],hTheme, iPartId, iStateId]))); exit(Trampoline(hTheme, hdc, iPartId, iStateId, pRect, Foo)); end; {$ENDIF} @@ -3506,14 +3376,10 @@ function UxTheme_ProgressBar(hTheme: hTheme; hdc: hdc; iPartId, iStateId: Intege SaveIndex: Integer; begin case iPartId of - PP_BAR: - LDetails := StyleServices.GetElementDetails(tpBar); - PP_BARVERT: - LDetails := StyleServices.GetElementDetails(tpBarVert); - PP_CHUNK: - LDetails := StyleServices.GetElementDetails(tpChunk); - PP_CHUNKVERT: - LDetails := StyleServices.GetElementDetails(tpChunkVert); + PP_BAR: LDetails := StyleServices.GetElementDetails(tpBar); + PP_BARVERT: LDetails := StyleServices.GetElementDetails(tpBarVert); + PP_CHUNK: LDetails := StyleServices.GetElementDetails(tpChunk); + PP_CHUNKVERT: LDetails := StyleServices.GetElementDetails(tpChunkVert); PP_FILL: if SameText(LThemeClass, VSCLASS_PROGRESS) then @@ -3525,7 +3391,7 @@ function UxTheme_ProgressBar(hTheme: hTheme; hdc: hdc; iPartId, iStateId: Intege LDetails := StyleServices.GetElementDetails(tpChunkVert); // GetElementDetails(tpFillVert); not defined // Use the Native PP_PULSEOVERLAY part to get better results. - // PP_PULSEOVERLAY : if SameText(THThemesClasses.Items[hTheme], VSCLASS_PROGRESS) then + // PP_PULSEOVERLAY: if SameText(THThemesClasses.Items[hTheme], VSCLASS_PROGRESS) then // LDetails := StyleServices.GetElementDetails(tpChunk)//GetElementDetails(tpPulseOverlay); // else // LDetails := StyleServices.GetElementDetails(tpBar); @@ -3536,8 +3402,8 @@ function UxTheme_ProgressBar(hTheme: hTheme; hdc: hdc; iPartId, iStateId: Intege else LDetails := StyleServices.GetElementDetails(tpChunk); - // PP_PULSEOVERLAYVERT : LDetails := StyleServices.GetElementDetails(tpPulseOverlayVert); - // PP_MOVEOVERLAYVERT : LDetails := StyleServices.GetElementDetails(tpMoveOverlayVert); + // PP_PULSEOVERLAYVERT: LDetails := StyleServices.GetElementDetails(tpPulseOverlayVert); + // PP_MOVEOVERLAYVERT: LDetails := StyleServices.GetElementDetails(tpMoveOverlayVert); PP_TRANSPARENTBAR: LDetails := StyleServices.GetElementDetails(tpBar); // GetElementDetails(tpTransparentBarNormal); not defined @@ -3555,7 +3421,7 @@ function UxTheme_ProgressBar(hTheme: hTheme; hdc: hdc; iPartId, iStateId: Intege try if hwnd <> 0 then DrawStyleParentBackground(hwnd, hdc, pRect); - StyleServices.DrawElement(hdc, LDetails, pRect, nil); + DrawStyleElement(hdc, LDetails, pRect); finally RestoreDC(hdc, SaveIndex); end; @@ -3580,196 +3446,128 @@ function UxTheme_ScrollBar(hTheme: hTheme; hdc: hdc; iPartId, iStateId: Integer; SBP_ARROWBTN: begin case iStateId of - ABS_UPNORMAL: - LScrollDetails := tsArrowBtnUpNormal; - ABS_UPHOT: - LScrollDetails := tsArrowBtnUpHot; - ABS_UPPRESSED: - LScrollDetails := tsArrowBtnUpPressed; - ABS_UPDISABLED: - LScrollDetails := tsArrowBtnUpDisabled; - ABS_DOWNNORMAL: - LScrollDetails := tsArrowBtnDownNormal; - ABS_DOWNHOT: - LScrollDetails := tsArrowBtnDownHot; - ABS_DOWNPRESSED: - LScrollDetails := tsArrowBtnDownPressed; - ABS_DOWNDISABLED: - LScrollDetails := tsArrowBtnDownDisabled; - ABS_LEFTNORMAL: - LScrollDetails := tsArrowBtnLeftNormal; - ABS_LEFTHOT: - LScrollDetails := tsArrowBtnLeftHot; - ABS_LEFTPRESSED: - LScrollDetails := tsArrowBtnLeftPressed; - ABS_LEFTDISABLED: - LScrollDetails := tsArrowBtnLeftDisabled; - ABS_RIGHTNORMAL: - LScrollDetails := tsArrowBtnRightNormal; - ABS_RIGHTHOT: - LScrollDetails := tsArrowBtnRightHot; - ABS_RIGHTPRESSED: - LScrollDetails := tsArrowBtnRightPressed; - ABS_RIGHTDISABLED: - LScrollDetails := tsArrowBtnRightDisabled; - ABS_UPHOVER: - LScrollDetails := tsArrowBtnUpNormal; // tsArrowBtnUpHover; - ABS_DOWNHOVER: - LScrollDetails := tsArrowBtnDownNormal; // tsArrowBtnDownHover; - ABS_LEFTHOVER: - LScrollDetails := tsArrowBtnLeftNormal; // tsArrowBtnLeftHover; - ABS_RIGHTHOVER: - LScrollDetails := tsArrowBtnRightNormal; // tsArrowBtnRightHover; + ABS_UPNORMAL: LScrollDetails := tsArrowBtnUpNormal; + ABS_UPHOT: LScrollDetails := tsArrowBtnUpHot; + ABS_UPPRESSED: LScrollDetails := tsArrowBtnUpPressed; + ABS_UPDISABLED: LScrollDetails := tsArrowBtnUpDisabled; + ABS_DOWNNORMAL: LScrollDetails := tsArrowBtnDownNormal; + ABS_DOWNHOT: LScrollDetails := tsArrowBtnDownHot; + ABS_DOWNPRESSED: LScrollDetails := tsArrowBtnDownPressed; + ABS_DOWNDISABLED: LScrollDetails := tsArrowBtnDownDisabled; + ABS_LEFTNORMAL: LScrollDetails := tsArrowBtnLeftNormal; + ABS_LEFTHOT: LScrollDetails := tsArrowBtnLeftHot; + ABS_LEFTPRESSED: LScrollDetails := tsArrowBtnLeftPressed; + ABS_LEFTDISABLED: LScrollDetails := tsArrowBtnLeftDisabled; + ABS_RIGHTNORMAL: LScrollDetails := tsArrowBtnRightNormal; + ABS_RIGHTHOT: LScrollDetails := tsArrowBtnRightHot; + ABS_RIGHTPRESSED: LScrollDetails := tsArrowBtnRightPressed; + ABS_RIGHTDISABLED: LScrollDetails := tsArrowBtnRightDisabled; + ABS_UPHOVER: LScrollDetails := tsArrowBtnUpNormal; // tsArrowBtnUpHover; + ABS_DOWNHOVER: LScrollDetails := tsArrowBtnDownNormal; // tsArrowBtnDownHover; + ABS_LEFTHOVER: LScrollDetails := tsArrowBtnLeftNormal; // tsArrowBtnLeftHover; + ABS_RIGHTHOVER: LScrollDetails := tsArrowBtnRightNormal; // tsArrowBtnRightHover; end; end; SBP_THUMBBTNHORZ: begin case iStateId of - SCRBS_NORMAL: - LScrollDetails := tsThumbBtnHorzNormal; - SCRBS_HOT: - LScrollDetails := tsThumbBtnHorzHot; - SCRBS_PRESSED: - LScrollDetails := tsThumbBtnHorzPressed; - SCRBS_DISABLED: - LScrollDetails := tsThumbBtnHorzDisabled; - SCRBS_HOVER: - LScrollDetails := tsThumbBtnHorzNormal; + SCRBS_NORMAL: LScrollDetails := tsThumbBtnHorzNormal; + SCRBS_HOT: LScrollDetails := tsThumbBtnHorzHot; + SCRBS_PRESSED: LScrollDetails := tsThumbBtnHorzPressed; + SCRBS_DISABLED: LScrollDetails := tsThumbBtnHorzDisabled; + SCRBS_HOVER: LScrollDetails := tsThumbBtnHorzNormal; end; end; SBP_THUMBBTNVERT: begin case iStateId of - SCRBS_NORMAL: - LScrollDetails := tsThumbBtnVertNormal; - SCRBS_HOT: - LScrollDetails := tsThumbBtnVertHot; - SCRBS_PRESSED: - LScrollDetails := tsThumbBtnVertPressed; - SCRBS_DISABLED: - LScrollDetails := tsThumbBtnVertDisabled; - SCRBS_HOVER: - LScrollDetails := tsThumbBtnVertNormal; + SCRBS_NORMAL: LScrollDetails := tsThumbBtnVertNormal; + SCRBS_HOT: LScrollDetails := tsThumbBtnVertHot; + SCRBS_PRESSED: LScrollDetails := tsThumbBtnVertPressed; + SCRBS_DISABLED: LScrollDetails := tsThumbBtnVertDisabled; + SCRBS_HOVER: LScrollDetails := tsThumbBtnVertNormal; end; end; SBP_LOWERTRACKHORZ: begin case iStateId of - SCRBS_NORMAL: - LScrollDetails := tsLowerTrackHorzNormal; - SCRBS_HOT: - LScrollDetails := tsLowerTrackHorzHot; - SCRBS_PRESSED: - LScrollDetails := tsLowerTrackHorzPressed; - SCRBS_DISABLED: - LScrollDetails := tsLowerTrackHorzDisabled; - SCRBS_HOVER: - LScrollDetails := tsLowerTrackHorzNormal; // tsLowerTrackHorzHover; //no support for hover + SCRBS_NORMAL: LScrollDetails := tsLowerTrackHorzNormal; + SCRBS_HOT: LScrollDetails := tsLowerTrackHorzHot; + SCRBS_PRESSED: LScrollDetails := tsLowerTrackHorzPressed; + SCRBS_DISABLED: LScrollDetails := tsLowerTrackHorzDisabled; + SCRBS_HOVER: LScrollDetails := tsLowerTrackHorzNormal; // tsLowerTrackHorzHover; //no support for hover end; end; SBP_UPPERTRACKHORZ: begin case iStateId of - SCRBS_NORMAL: - LScrollDetails := tsUpperTrackHorzNormal; - SCRBS_HOT: - LScrollDetails := tsUpperTrackHorzHot; - SCRBS_PRESSED: - LScrollDetails := tsUpperTrackHorzPressed; - SCRBS_DISABLED: - LScrollDetails := tsUpperTrackHorzDisabled; - SCRBS_HOVER: - LScrollDetails := tsUpperTrackHorzNormal; // tsUpperTrackHorzHover; //no support for hover + SCRBS_NORMAL: LScrollDetails := tsUpperTrackHorzNormal; + SCRBS_HOT: LScrollDetails := tsUpperTrackHorzHot; + SCRBS_PRESSED: LScrollDetails := tsUpperTrackHorzPressed; + SCRBS_DISABLED: LScrollDetails := tsUpperTrackHorzDisabled; + SCRBS_HOVER: LScrollDetails := tsUpperTrackHorzNormal; // tsUpperTrackHorzHover; //no support for hover end; end; SBP_LOWERTRACKVERT: begin case iStateId of - SCRBS_NORMAL: - LScrollDetails := tsLowerTrackVertNormal; - SCRBS_HOT: - LScrollDetails := tsLowerTrackVertHot; - SCRBS_PRESSED: - LScrollDetails := tsLowerTrackVertPressed; - SCRBS_DISABLED: - LScrollDetails := tsLowerTrackVertDisabled; - SCRBS_HOVER: - LScrollDetails := tsLowerTrackVertNormal; // tsLowerTrackVertHover; //no support for hover + SCRBS_NORMAL: LScrollDetails := tsLowerTrackVertNormal; + SCRBS_HOT: LScrollDetails := tsLowerTrackVertHot; + SCRBS_PRESSED: LScrollDetails := tsLowerTrackVertPressed; + SCRBS_DISABLED: LScrollDetails := tsLowerTrackVertDisabled; + SCRBS_HOVER: LScrollDetails := tsLowerTrackVertNormal; // tsLowerTrackVertHover; //no support for hover end; end; SBP_UPPERTRACKVERT: begin case iStateId of - SCRBS_NORMAL: - LScrollDetails := tsUpperTrackVertNormal; - SCRBS_HOT: - LScrollDetails := tsUpperTrackVertHot; - SCRBS_PRESSED: - LScrollDetails := tsUpperTrackVertPressed; - SCRBS_DISABLED: - LScrollDetails := tsUpperTrackVertDisabled; - SCRBS_HOVER: - LScrollDetails := tsUpperTrackVertNormal; // tsUpperTrackVertHover; //no support for hover + SCRBS_NORMAL: LScrollDetails := tsUpperTrackVertNormal; + SCRBS_HOT: LScrollDetails := tsUpperTrackVertHot; + SCRBS_PRESSED: LScrollDetails := tsUpperTrackVertPressed; + SCRBS_DISABLED: LScrollDetails := tsUpperTrackVertDisabled; + SCRBS_HOVER: LScrollDetails := tsUpperTrackVertNormal; // tsUpperTrackVertHover; //no support for hover end; end; SBP_SIZEBOX: begin case iStateId of - SZB_RIGHTALIGN: - LScrollDetails := tsSizeBoxRightAlign; - SZB_LEFTALIGN: - LScrollDetails := tsSizeBoxLeftAlign; - SZB_TOPRIGHTALIGN: - LScrollDetails := tsSizeBoxTopRightAlign; - SZB_TOPLEFTALIGN: - LScrollDetails := tsSizeBoxTopLeftAlign; - SZB_HALFBOTTOMRIGHTALIGN: - LScrollDetails := tsSizeBoxHalfBottomRightAlign; - SZB_HALFBOTTOMLEFTALIGN: - LScrollDetails := tsSizeBoxHalfBottomLeftAlign; - SZB_HALFTOPRIGHTALIGN: - LScrollDetails := tsSizeBoxHalfTopRightAlign; - SZB_HALFTOPLEFTALIGN: - LScrollDetails := tsSizeBoxHalfTopLeftAlign; + SZB_RIGHTALIGN: LScrollDetails := tsSizeBoxRightAlign; + SZB_LEFTALIGN:LScrollDetails := tsSizeBoxLeftAlign; + SZB_TOPRIGHTALIGN: LScrollDetails := tsSizeBoxTopRightAlign; + SZB_TOPLEFTALIGN: LScrollDetails := tsSizeBoxTopLeftAlign; + SZB_HALFBOTTOMRIGHTALIGN: LScrollDetails := tsSizeBoxHalfBottomRightAlign; + SZB_HALFBOTTOMLEFTALIGN: LScrollDetails := tsSizeBoxHalfBottomLeftAlign; + SZB_HALFTOPRIGHTALIGN: LScrollDetails := tsSizeBoxHalfTopRightAlign; + SZB_HALFTOPLEFTALIGN: LScrollDetails := tsSizeBoxHalfTopLeftAlign; end; end; SBP_GRIPPERHORZ: begin case iStateId of - SCRBS_NORMAL: - LScrollDetails := tsGripperHorzNormal; - SCRBS_HOT: - LScrollDetails := tsGripperHorzHot; - SCRBS_PRESSED: - LScrollDetails := tsGripperHorzPressed; - SCRBS_DISABLED: - LScrollDetails := tsGripperHorzDisabled; - SCRBS_HOVER: - LScrollDetails := tsGripperHorzHover; // tsGripperHorzHover; //no support for hover + SCRBS_NORMAL: LScrollDetails := tsGripperHorzNormal; + SCRBS_HOT: LScrollDetails := tsGripperHorzHot; + SCRBS_PRESSED: LScrollDetails := tsGripperHorzPressed; + SCRBS_DISABLED: LScrollDetails := tsGripperHorzDisabled; + SCRBS_HOVER: LScrollDetails := tsGripperHorzHover; // tsGripperHorzHover; //no support for hover end; end; SBP_GRIPPERVERT: begin case iStateId of - SCRBS_NORMAL: - LScrollDetails := tsGripperVertNormal; - SCRBS_HOT: - LScrollDetails := tsGripperVertHot; - SCRBS_PRESSED: - LScrollDetails := tsGripperVertPressed; - SCRBS_DISABLED: - LScrollDetails := tsGripperVertDisabled; - SCRBS_HOVER: - LScrollDetails := tsGripperVertNormal; // tsGripperVertHover; //no support for hover + SCRBS_NORMAL: LScrollDetails := tsGripperVertNormal; + SCRBS_HOT: LScrollDetails := tsGripperVertHot; + SCRBS_PRESSED: LScrollDetails := tsGripperVertPressed; + SCRBS_DISABLED: LScrollDetails := tsGripperVertDisabled; + SCRBS_HOVER: LScrollDetails := tsGripperVertNormal; // tsGripperVertHover; //no support for hover end; end; end; @@ -3777,13 +3575,13 @@ function UxTheme_ScrollBar(hTheme: hTheme; hdc: hdc; iPartId, iStateId: Integer; LDetails := StyleServices.GetElementDetails(LScrollDetails); if (iPartId = SBP_THUMBBTNHORZ) then - StyleServices.DrawElement(hdc, StyleServices.GetElementDetails(tsUpperTrackHorzNormal), pRect, nil) + DrawStyleElement(hdc, StyleServices.GetElementDetails(tsUpperTrackHorzNormal), pRect) else if (iPartId = SBP_THUMBBTNVERT) then - StyleServices.DrawElement(hdc, StyleServices.GetElementDetails(tsUpperTrackVertNormal), pRect, nil); + DrawStyleElement(hdc, StyleServices.GetElementDetails(tsUpperTrackVertNormal), pRect); // OutputDebugString(PChar(Format('UxTheme_ScrollBar class %s hTheme %d iPartId %d iStateId %d Left %d Top %d Width %d Height %d', // [THThemesClasses.Items[hTheme],hTheme, iPartId, iStateId, PRect.Left, prect.Top, prect.Width, prect.Height]))); - StyleServices.DrawElement(hdc, LDetails, pRect, nil); + DrawStyleElement(hdc, LDetails, pRect); exit(S_OK); end; {$ENDIF} @@ -3800,12 +3598,9 @@ function UxTheme_Edit(hTheme: hTheme; hdc: hdc; iPartId, iStateId: Integer; cons EP_BACKGROUNDWITHBORDER, EP_EDITBORDER_NOSCROLL: begin case iStateId of - EPSN_NORMAL: - LDetails := StyleServices.GetElementDetails(teEditBorderNoScrollNormal); - EPSN_HOT: - LDetails := StyleServices.GetElementDetails(teEditBorderNoScrollHot); - EPSN_FOCUSED: - LDetails := StyleServices.GetElementDetails(teEditBorderNoScrollFocused); + EPSN_NORMAL: LDetails := StyleServices.GetElementDetails(teEditBorderNoScrollNormal); + EPSN_HOT: LDetails := StyleServices.GetElementDetails(teEditBorderNoScrollHot); + EPSN_FOCUSED: LDetails := StyleServices.GetElementDetails(teEditBorderNoScrollFocused); EPSN_DISABLED: begin // LDetails := StyleServices.GetElementDetails(teEditBorderNoScrollDisabled); @@ -3821,14 +3616,10 @@ function UxTheme_Edit(hTheme: hTheme; hdc: hdc; iPartId, iStateId: Integer; cons EP_EDITBORDER_HSCROLL: begin case iStateId of - EPSH_NORMAL: - LDetails := StyleServices.GetElementDetails(teEditBorderHScrollNormal); - EPSH_HOT: - LDetails := StyleServices.GetElementDetails(teEditBorderHScrollHot); - EPSH_FOCUSED: - LDetails := StyleServices.GetElementDetails(teEditBorderHScrollFocused); - EPSH_DISABLED: - LDetails := StyleServices.GetElementDetails(teEditBorderHScrollDisabled); + EPSH_NORMAL: LDetails := StyleServices.GetElementDetails(teEditBorderHScrollNormal); + EPSH_HOT: LDetails := StyleServices.GetElementDetails(teEditBorderHScrollHot); + EPSH_FOCUSED: LDetails := StyleServices.GetElementDetails(teEditBorderHScrollFocused); + EPSH_DISABLED: LDetails := StyleServices.GetElementDetails(teEditBorderHScrollDisabled); end; DrawStyleElement(hdc, LDetails, pRect); @@ -3838,14 +3629,10 @@ function UxTheme_Edit(hTheme: hTheme; hdc: hdc; iPartId, iStateId: Integer; cons EP_EDITBORDER_VSCROLL: begin case iStateId of - EPSV_NORMAL: - LDetails := StyleServices.GetElementDetails(teEditBorderVScrollNormal); - EPSV_HOT: - LDetails := StyleServices.GetElementDetails(teEditBorderVScrollHot); - EPSV_FOCUSED: - LDetails := StyleServices.GetElementDetails(teEditBorderVScrollFocused); - EPSV_DISABLED: - LDetails := StyleServices.GetElementDetails(teEditBorderVScrollDisabled); + EPSV_NORMAL: LDetails := StyleServices.GetElementDetails(teEditBorderVScrollNormal); + EPSV_HOT: LDetails := StyleServices.GetElementDetails(teEditBorderVScrollHot); + EPSV_FOCUSED: LDetails := StyleServices.GetElementDetails(teEditBorderVScrollFocused); + EPSV_DISABLED: LDetails := StyleServices.GetElementDetails(teEditBorderVScrollDisabled); end; DrawStyleElement(hdc, LDetails, pRect); @@ -3855,14 +3642,10 @@ function UxTheme_Edit(hTheme: hTheme; hdc: hdc; iPartId, iStateId: Integer; cons EP_EDITBORDER_HVSCROLL: begin case iStateId of - EPSHV_NORMAL: - LDetails := StyleServices.GetElementDetails(teEditBorderHVScrollNormal); - EPSHV_HOT: - LDetails := StyleServices.GetElementDetails(teEditBorderHVScrollHot); - EPSHV_FOCUSED: - LDetails := StyleServices.GetElementDetails(teEditBorderHVScrollFocused); - EPSHV_DISABLED: - LDetails := StyleServices.GetElementDetails(teEditBorderHVScrollDisabled); + EPSHV_NORMAL: LDetails := StyleServices.GetElementDetails(teEditBorderHVScrollNormal); + EPSHV_HOT: LDetails := StyleServices.GetElementDetails(teEditBorderHVScrollHot); + EPSHV_FOCUSED: LDetails := StyleServices.GetElementDetails(teEditBorderHVScrollFocused); + EPSHV_DISABLED: LDetails := StyleServices.GetElementDetails(teEditBorderHVScrollDisabled); end; DrawStyleElement(hdc, LDetails, pRect); @@ -4572,155 +4355,156 @@ function UxTheme_CommandModule(hTheme: hTheme; hdc: hdc; iPartId, iStateId: Inte initialization -VCLStylesLock := TCriticalSection.Create; -THThemesClasses := TDictionary.Create; -THThemesHWND := TDictionary.Create; -FuncsDrawThemeBackground := TDictionary.Create(TIStringComparer.Ordinal); + VCLStylesLock := TCriticalSection.Create; + THThemesClasses := TDictionary.Create; + THThemesHWND := TDictionary.Create; + FuncsDrawThemeBackground := TDictionary.Create(TIStringComparer.Ordinal); -if StyleServices.Available then -begin -// Element specific handlers + if StyleServices.Available then + begin + // Element specific handlers -{$IFDEF HOOK_InfoBar} - FuncsDrawThemeBackground.Add(VSCLASS_INFOBAR, @UxTheme_InfoBar); -{$ENDIF} -{$IFDEF HOOK_BREADCRUMBAR} - FuncsDrawThemeBackground.Add(VSCLASS_BREADCRUMBAR, @UxTheme_BreadCrumBar); -{$ENDIF} -{$IFDEF HOOK_TRYHARDER} - FuncsDrawThemeBackground.Add(VSCLASS_TRYHARDER, @UxTheme_TryHarder); -{$ENDIF} -{$IFDEF HOOK_Tab} - FuncsDrawThemeBackground.Add(VSCLASS_TAB, @UxTheme_Tab); -{$ENDIF} -{$IFDEF HOOK_ToolTip} - FuncsDrawThemeBackground.Add(VSCLASS_TOOLTIP, @UxTheme_ToolTip); -{$ENDIF} -{$IFDEF HOOK_TrackBar} - FuncsDrawThemeBackground.Add(VSCLASS_TRACKBAR, @UxTheme_TrackBar); -{$ENDIF} -{$IFDEF HOOK_PreviewPane} - FuncsDrawThemeBackground.Add(VSCLASS_PREVIEWPANE, @UxTheme_PreviewPane); -{$ENDIF} -{$IFDEF HOOK_ToolBar} - FuncsDrawThemeBackground.Add(VSCLASS_TOOLBAR, @UxTheme_ToolBar); -{$ENDIF} -{$IFDEF HOOK_AddressBand} - FuncsDrawThemeBackground.Add(VSCLASS_ADDRESSBAND, @UxTheme_AddressBand); -{$ENDIF} -{$IFDEF HOOK_SearchBox} - FuncsDrawThemeBackground.Add(VSCLASS_SEARCHBOX, @UxTheme_SearchBox); - FuncsDrawThemeBackground.Add(VSCLASS_CompositedSEARCHBOX, @UxTheme_SearchBox); - FuncsDrawThemeBackground.Add(VSCLASS_INACTIVESEARCHBOX, @UxTheme_SearchBox); -{$ENDIF} -{$IFDEF HOOK_CommandModule} - FuncsDrawThemeBackground.Add(VSCLASS_COMMANDMODULE, @UxTheme_CommandModule); -{$ENDIF} -{$IFDEF HOOK_Menu} - FuncsDrawThemeBackground.Add(VSCLASS_MENU, @UxTheme_Menu); -{$ENDIF} -{$IFDEF HOOK_Rebar} - FuncsDrawThemeBackground.Add(VSCLASS_REBAR, @UxTheme_Rebar); -{$ENDIF} -{$IFDEF HOOK_Edit} - FuncsDrawThemeBackground.Add(VSCLASS_EDIT, @UxTheme_Edit); -{$ENDIF} -{$IFDEF HOOK_ListBox} - FuncsDrawThemeBackground.Add(VSCLASS_LISTBOX, @UxTheme_ListBox); -{$ENDIF} -{$IFDEF HOOK_Spin} - FuncsDrawThemeBackground.Add(VSCLASS_SPIN, @UxTheme_Spin); -{$ENDIF} -{$IFDEF HOOK_ComboBox} - FuncsDrawThemeBackground.Add(VSCLASS_COMBOBOX, @UxTheme_ComboBox); -{$ENDIF} -{$IFDEF HOOK_ListView} - FuncsDrawThemeBackground.Add(VSCLASS_LISTVIEWPOPUP, @UxTheme_ListViewPopup); + {$IFDEF HOOK_InfoBar} + FuncsDrawThemeBackground.Add(VSCLASS_INFOBAR, @UxTheme_InfoBar); + {$ENDIF} + {$IFDEF HOOK_BREADCRUMBAR} + FuncsDrawThemeBackground.Add(VSCLASS_BREADCRUMBAR, @UxTheme_BreadCrumBar); + {$ENDIF} + {$IFDEF HOOK_TRYHARDER} + FuncsDrawThemeBackground.Add(VSCLASS_TRYHARDER, @UxTheme_TryHarder); + {$ENDIF} + {$IFDEF HOOK_Tab} + FuncsDrawThemeBackground.Add(VSCLASS_TAB, @UxTheme_Tab); + {$ENDIF} + {$IFDEF HOOK_ToolTip} + FuncsDrawThemeBackground.Add(VSCLASS_TOOLTIP, @UxTheme_ToolTip); + {$ENDIF} + {$IFDEF HOOK_TrackBar} + FuncsDrawThemeBackground.Add(VSCLASS_TRACKBAR, @UxTheme_TrackBar); + {$ENDIF} + {$IFDEF HOOK_PreviewPane} + FuncsDrawThemeBackground.Add(VSCLASS_PREVIEWPANE, @UxTheme_PreviewPane); + {$ENDIF} + {$IFDEF HOOK_ToolBar} + FuncsDrawThemeBackground.Add(VSCLASS_TOOLBAR, @UxTheme_ToolBar); + {$ENDIF} + {$IFDEF HOOK_AddressBand} + FuncsDrawThemeBackground.Add(VSCLASS_ADDRESSBAND, @UxTheme_AddressBand); + {$ENDIF} + {$IFDEF HOOK_SearchBox} + FuncsDrawThemeBackground.Add(VSCLASS_SEARCHBOX, @UxTheme_SearchBox); + FuncsDrawThemeBackground.Add(VSCLASS_CompositedSEARCHBOX, @UxTheme_SearchBox); + FuncsDrawThemeBackground.Add(VSCLASS_SearchBoxComposited, @UxTheme_SearchBox); + FuncsDrawThemeBackground.Add(VSCLASS_INACTIVESEARCHBOX, @UxTheme_SearchBox); + {$ENDIF} + {$IFDEF HOOK_CommandModule} + FuncsDrawThemeBackground.Add(VSCLASS_COMMANDMODULE, @UxTheme_CommandModule); + {$ENDIF} + {$IFDEF HOOK_Menu} + FuncsDrawThemeBackground.Add(VSCLASS_MENU, @UxTheme_Menu); + {$ENDIF} + {$IFDEF HOOK_Rebar} + FuncsDrawThemeBackground.Add(VSCLASS_REBAR, @UxTheme_Rebar); + {$ENDIF} + {$IFDEF HOOK_Edit} + FuncsDrawThemeBackground.Add(VSCLASS_EDIT, @UxTheme_Edit); + {$ENDIF} + {$IFDEF HOOK_ListBox} + FuncsDrawThemeBackground.Add(VSCLASS_LISTBOX, @UxTheme_ListBox); + {$ENDIF} + {$IFDEF HOOK_Spin} + FuncsDrawThemeBackground.Add(VSCLASS_SPIN, @UxTheme_Spin); + {$ENDIF} + {$IFDEF HOOK_ComboBox} + FuncsDrawThemeBackground.Add(VSCLASS_COMBOBOX, @UxTheme_ComboBox); + {$ENDIF} + {$IFDEF HOOK_ListView} + FuncsDrawThemeBackground.Add(VSCLASS_LISTVIEWPOPUP, @UxTheme_ListViewPopup); - FuncsDrawThemeBackground.Add(VSCLASS_HEADER, @UxTheme_Header); - FuncsDrawThemeBackground.Add(VSCLASS_ITEMSVIEW_HEADER, @UxTheme_Header); + FuncsDrawThemeBackground.Add(VSCLASS_HEADER, @UxTheme_Header); + FuncsDrawThemeBackground.Add(VSCLASS_ITEMSVIEW_HEADER, @UxTheme_Header); - FuncsDrawThemeBackground.Add(VSCLASS_LISTVIEW, @UxTheme_ListView); - FuncsDrawThemeBackground.Add(VSCLASS_ITEMSVIEW, @UxTheme_ListView); - FuncsDrawThemeBackground.Add(VSCLASS_ITEMSVIEW_LISTVIEW, @UxTheme_ListView); - FuncsDrawThemeBackground.Add(VSCLASS_EXPLORER_LISTVIEW, @UxTheme_ListView); -{$ENDIF} -{$IFDEF HOOK_DateTimePicker} - FuncsDrawThemeBackground.Add(VSCLASS_DATEPICKER, @UxTheme_DatePicker); - FuncsDrawThemeBackground.Add(VSCLASS_MONTHCAL, @UxTheme_MonthCal); -{$ENDIF} -{$IFDEF HOOK_Scrollbar} - FuncsDrawThemeBackground.Add(VSCLASS_SCROLLBAR, @UxTheme_ScrollBar); -{$ENDIF} -{$IFDEF HOOK_Progressbar} - FuncsDrawThemeBackground.Add(VSCLASS_PROGRESS, @UxTheme_ProgressBar); - FuncsDrawThemeBackground.Add(VSCLASS_PROGRESS_INDERTERMINATE, @UxTheme_ProgressBar); -{$ENDIF} -{$IFDEF HOOK_TaskDialog} - FuncsDrawThemeBackground.Add(VSCLASS_TASKDIALOG, @UxTheme_TaskDialog); -{$ENDIF} -{$IFDEF HOOK_Button} - FuncsDrawThemeBackground.Add(VSCLASS_BUTTON, @UxTheme_Button); -{$ENDIF} -{$IFDEF HOOK_AllButtons} - FuncsDrawThemeBackground.Add('Button-OK;Button', @UxTheme_Button); - FuncsDrawThemeBackground.Add('Button-CANCEL;Button', @UxTheme_Button); -{$ENDIF} -{$IFDEF HOOK_TreeView} - FuncsDrawThemeBackground.Add(VSCLASS_TREEVIEW, @UxTheme_TreeView); -{$ENDIF} -{$IFDEF HOOK_Navigation} - if TOSVersion.Check(6, 2) then // Windows 8, 10... - begin - FuncsDrawThemeBackground.Add(VSCLASS_NAVIGATION, @UxTheme_Navigation); - FuncsDrawThemeBackground.Add(VSCLASS_COMMONITEMSDIALOG, @UxTheme_CommonItemsDialog); - end; -{$ENDIF} + FuncsDrawThemeBackground.Add(VSCLASS_LISTVIEW, @UxTheme_ListView); + FuncsDrawThemeBackground.Add(VSCLASS_ITEMSVIEW, @UxTheme_ListView); + FuncsDrawThemeBackground.Add(VSCLASS_ITEMSVIEW_LISTVIEW, @UxTheme_ListView); + FuncsDrawThemeBackground.Add(VSCLASS_EXPLORER_LISTVIEW, @UxTheme_ListView); + {$ENDIF} + {$IFDEF HOOK_DateTimePicker} + FuncsDrawThemeBackground.Add(VSCLASS_DATEPICKER, @UxTheme_DatePicker); + FuncsDrawThemeBackground.Add(VSCLASS_MONTHCAL, @UxTheme_MonthCal); + {$ENDIF} + {$IFDEF HOOK_Scrollbar} + FuncsDrawThemeBackground.Add(VSCLASS_SCROLLBAR, @UxTheme_ScrollBar); + {$ENDIF} + {$IFDEF HOOK_Progressbar} + FuncsDrawThemeBackground.Add(VSCLASS_PROGRESS, @UxTheme_ProgressBar); + FuncsDrawThemeBackground.Add(VSCLASS_PROGRESS_INDERTERMINATE, @UxTheme_ProgressBar); + {$ENDIF} + {$IFDEF HOOK_TaskDialog} + FuncsDrawThemeBackground.Add(VSCLASS_TASKDIALOG, @UxTheme_TaskDialog); + {$ENDIF} + {$IFDEF HOOK_Button} + FuncsDrawThemeBackground.Add(VSCLASS_BUTTON, @UxTheme_Button); + {$ENDIF} + {$IFDEF HOOK_AllButtons} + FuncsDrawThemeBackground.Add('Button-OK;Button', @UxTheme_Button); + FuncsDrawThemeBackground.Add('Button-CANCEL;Button', @UxTheme_Button); + {$ENDIF} + {$IFDEF HOOK_TreeView} + FuncsDrawThemeBackground.Add(VSCLASS_TREEVIEW, @UxTheme_TreeView); + {$ENDIF} + {$IFDEF HOOK_Navigation} + if TOSVersion.Check(6, 2) then // Windows 8, 10... + begin + FuncsDrawThemeBackground.Add(VSCLASS_NAVIGATION, @UxTheme_Navigation); + FuncsDrawThemeBackground.Add(VSCLASS_COMMONITEMSDIALOG, @UxTheme_CommonItemsDialog); + end; + {$ENDIF} - // General hooks - @Trampoline_UxTheme_OpenThemeData := InterceptCreate(themelib, 'OpenThemeData', @Detour_UxTheme_OpenThemeData); - {$IF CompilerVersion >= 30} - if TOSVersion.Check(10) then - begin - @Trampoline_UxTheme_OpenThemeDataForDPI := InterceptCreate(themelib, 'OpenThemeDataForDpi', @Detour_UxTheme_OpenThemeDataForDPI); - if (@Trampoline_UxTheme_OpenThemeDataForDPI = nil) and (TOSVersion.Build < 15063) then // W10 Creators Update? - @Trampoline_UxTheme_OpenThemeDataForDPI := InterceptCreateOrdinal(themelib, 129, @Detour_UxTheme_OpenThemeDataForDPI); + // General hooks + @Trampoline_UxTheme_OpenThemeData := InterceptCreate(themelib, 'OpenThemeData', @Detour_UxTheme_OpenThemeData); + {$IF CompilerVersion >= 30} + if TOSVersion.Check(10) then + begin + @Trampoline_UxTheme_OpenThemeDataForDPI := InterceptCreate(themelib, 'OpenThemeDataForDpi', @Detour_UxTheme_OpenThemeDataForDPI); + if (@Trampoline_UxTheme_OpenThemeDataForDPI = nil) and (TOSVersion.Build < 15063) then // W10 Creators Update? + @Trampoline_UxTheme_OpenThemeDataForDPI := InterceptCreateOrdinal(themelib, 129, @Detour_UxTheme_OpenThemeDataForDPI); + end; + {$IFEND} + @Trampoline_UxTheme_OpenThemeDataEx := InterceptCreate(themelib, 'OpenThemeDataEx', @Detour_UxTheme_OpenThemeDataEx); + @Trampoline_UxTheme_DrawThemeBackground := InterceptCreate(themelib, 'DrawThemeBackground', @Detour_UxTheme_DrawThemeBackground); + @Trampoline_UxTheme_DrawThemeBackgroundEx := InterceptCreate(themelib, 'DrawThemeBackgroundEx', @Detour_UxTheme_DrawThemeBackgroundEx); + @Trampoline_UxTheme_DrawThemeEdge := InterceptCreate(themelib, 'DrawThemeEdge', @Detour_UxTheme_DrawThemeEdge); + + @Trampoline_UxTheme_DrawThemeText := InterceptCreate(themelib, 'DrawThemeText', @Detour_UxTheme_DrawThemeText); + @Trampoline_UxTheme_DrawThemeTextEx := InterceptCreate(themelib, 'DrawThemeTextEx', @Detour_UxTheme_DrawThemeTextEx); + @Trampoline_UxTheme_GetThemeSysColor := InterceptCreate(themelib, 'GetThemeSysColor', @Detour_UxTheme_GetThemeSysColor); + @Trampoline_UxTheme_GetThemeSysColorBrush := InterceptCreate(themelib, 'GetThemeSysColorBrush', @Detour_UxTheme_GetThemeSysColorBrush); + @Trampoline_UxTheme_GetThemeColor := InterceptCreate(themelib, 'GetThemeColor', @Detour_UxTheme_GetThemeColor); end; - {$IFEND} - @Trampoline_UxTheme_OpenThemeDataEx := InterceptCreate(themelib, 'OpenThemeDataEx', @Detour_UxTheme_OpenThemeDataEx); - @Trampoline_UxTheme_DrawThemeBackground := InterceptCreate(themelib, 'DrawThemeBackground', @Detour_UxTheme_DrawThemeBackground); - @Trampoline_UxTheme_DrawThemeBackgroundEx := InterceptCreate(themelib, 'DrawThemeBackgroundEx', @Detour_UxTheme_DrawThemeBackgroundEx); - @Trampoline_UxTheme_DrawThemeEdge := InterceptCreate(themelib, 'DrawThemeEdge', @Detour_UxTheme_DrawThemeEdge); - - @Trampoline_UxTheme_DrawThemeText := InterceptCreate(themelib, 'DrawThemeText', @Detour_UxTheme_DrawThemeText); - @Trampoline_UxTheme_DrawThemeTextEx := InterceptCreate(themelib, 'DrawThemeTextEx', @Detour_UxTheme_DrawThemeTextEx); - @Trampoline_UxTheme_GetThemeSysColor := InterceptCreate(themelib, 'GetThemeSysColor', @Detour_UxTheme_GetThemeSysColor); - @Trampoline_UxTheme_GetThemeSysColorBrush := InterceptCreate(themelib, 'GetThemeSysColorBrush', @Detour_UxTheme_GetThemeSysColorBrush); - @Trampoline_UxTheme_GetThemeColor := InterceptCreate(themelib, 'GetThemeColor', @Detour_UxTheme_GetThemeColor); -end; finalization -InterceptRemove(@Trampoline_UxTheme_GetThemeSysColor); -InterceptRemove(@Trampoline_UxTheme_GetThemeSysColorBrush); -InterceptRemove(@Trampoline_UxTheme_OpenThemeData); -{$IF CompilerVersion >= 30} -if TOSVersion.Check(10) then - InterceptRemove(@Trampoline_UxTheme_OpenThemeDataForDPI); -{$IFEND} -InterceptRemove(@Trampoline_UxTheme_OpenThemeDataEx); -InterceptRemove(@Trampoline_UxTheme_GetThemeColor); -InterceptRemove(@Trampoline_UxTheme_DrawThemeBackground); -InterceptRemove(@Trampoline_UxTheme_DrawThemeText); -InterceptRemove(@Trampoline_UxTheme_DrawThemeTextEx); -InterceptRemove(@Trampoline_UxTheme_DrawThemeBackgroundEx); -InterceptRemove(@Trampoline_UxTheme_DrawThemeEdge); - -THThemesClasses.Free; -THThemesHWND.Free; -FuncsDrawThemeBackground.Free; - -VCLStylesLock.Free; -VCLStylesLock := nil; + InterceptRemove(@Trampoline_UxTheme_GetThemeSysColor); + InterceptRemove(@Trampoline_UxTheme_GetThemeSysColorBrush); + InterceptRemove(@Trampoline_UxTheme_OpenThemeData); + {$IF CompilerVersion >= 30} + if TOSVersion.Check(10) then + InterceptRemove(@Trampoline_UxTheme_OpenThemeDataForDPI); + {$IFEND} + InterceptRemove(@Trampoline_UxTheme_OpenThemeDataEx); + InterceptRemove(@Trampoline_UxTheme_GetThemeColor); + InterceptRemove(@Trampoline_UxTheme_DrawThemeBackground); + InterceptRemove(@Trampoline_UxTheme_DrawThemeText); + InterceptRemove(@Trampoline_UxTheme_DrawThemeTextEx); + InterceptRemove(@Trampoline_UxTheme_DrawThemeBackgroundEx); + InterceptRemove(@Trampoline_UxTheme_DrawThemeEdge); + + THThemesClasses.Free; + THThemesHWND.Free; + FuncsDrawThemeBackground.Free; + + VCLStylesLock.Free; + VCLStylesLock := nil; end. diff --git a/source/vcl-styles-utils/Vcl.Styles.WebBrowser.pas b/source/vcl-styles-utils/Vcl.Styles.WebBrowser.pas index f1b009fce..882269ee2 100644 --- a/source/vcl-styles-utils/Vcl.Styles.WebBrowser.pas +++ b/source/vcl-styles-utils/Vcl.Styles.WebBrowser.pas @@ -1,760 +1,760 @@ -// ************************************************************************************************** -// -// Unit Vcl.Styles.WebBrowser -// unit for the VCL Styles Utils -// https://github.com/RRUZ/vcl-styles-utils/ -// -// 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. -// -// The Original Code is Vcl.Styles.WebBrowser.pas. -// -// The Initial Developer of the Original Code is Rodrigo Ruz V. -// Portions created by Rodrigo Ruz V. are Copyright (C) 2012-2019 Rodrigo Ruz V. -// All Rights Reserved. -// -// ************************************************************************************************** -unit Vcl.Styles.WebBrowser; - -interface - -// Uncomment this option if you want which the TVclStylesWebBrowser class hook the dialogs messages directly. -{ .$DEFINE HOOKDialogs } -uses - System.Classes, - WinApi.Windows, - WinApi.Messages, - WinApi.Activex, - Vcl.Forms, - Vcl.OleServer, - Vcl.Graphics, - Vcl.Controls, - Vcl.StdCtrls, - SHDocVw; - -type - - TDocHostUIInfo = record - cbSize: ULONG; - dwFlags: DWORD; - dwDoubleClick: DWORD; - pchHostCss: PWChar; - pchHostNS: PWChar; - end; - -{$IFDEF HOOKDialogs} - - // http://msdn.microsoft.com/en-us/library/aa753269%28v=vs.85%29.aspx - IDocHostShowUI = interface(IUnknown) - ['{c4d244b0-d43e-11cf-893b-00aa00bdce1a}'] - function ShowMessage(hwnd: THandle; lpstrText: POLESTR; lpstrCaption: POLESTR; dwType: longint; - lpstrHelpFile: POLESTR; dwHelpContext: longint; var plResult: LRESULT): HRESULT; stdcall; - function ShowHelp(hwnd: THandle; pszHelpFile: POLESTR; uCommand: integer; dwData: longint; ptMouse: TPoint; - var pDispachObjectHit: IDispatch): HRESULT; stdcall; - end; // IDocHostShowUI -{$ENDIF} - - // http://msdn.microsoft.com/en-us/library/aa753260%28v=vs.85%29.aspx - IDocHostUIHandler = interface(IUnknown) - ['{BD3F23C0-D43E-11CF-893B-00AA00BDCE1A}'] - function ShowContextMenu(const dwID: DWORD; const ppt: PPOINT; const pcmdtReserved: IUnknown; - const pdispReserved: IDispatch): HRESULT; stdcall; - function GetHostInfo(var pInfo: TDocHostUIInfo): HRESULT; stdcall; - function ShowUI(const dwID: DWORD; const pActiveObject: IOleInPlaceActiveObject; - const pCommandTarget: IOleCommandTarget; const pFrame: IOleInPlaceFrame; const pDoc: IOleInPlaceUIWindow) - : HRESULT; stdcall; - function HideUI: HRESULT; stdcall; - function UpdateUI: HRESULT; stdcall; - function EnableModeless(const fEnable: BOOL): HRESULT; stdcall; - function OnDocWindowActivate(const fActivate: BOOL): HRESULT; stdcall; - function OnFrameWindowActivate(const fActivate: BOOL): HRESULT; stdcall; - function ResizeBorder(const prcBorder: PRECT; const pUIWindow: IOleInPlaceUIWindow; const FrameWindow: BOOL) - : HRESULT; stdcall; - function TranslateAccelerator(const lpMsg: PMSG; const pguidCmdGroup: PGUID; const nCmdID: DWORD): HRESULT; stdcall; - function GetOptionKeyPath(var pchKey: POLESTR; const dw: DWORD): HRESULT; stdcall; - function GetDropTarget(const pDropTarget: IDropTarget; out ppDropTarget: IDropTarget): HRESULT; stdcall; - function GetExternal(out ppDispatch: IDispatch): HRESULT; stdcall; - function TranslateUrl(const dwTranslate: DWORD; const pchURLIn: POLESTR; var ppchURLOut: POLESTR): HRESULT; stdcall; - function FilterDataObject(const pDO: IDataObject; out ppDORet: IDataObject): HRESULT; stdcall; - end; - - TVclStylesWebBrowser = class(SHDocVw.TWebBrowser, IDocHostUIHandler{$IFDEF HOOKDialogs}, IDocHostShowUI{$ENDIF}, - IOleCommandTarget) - strict private - type - TWinContainer = class(TWinControl) - procedure WMEraseBkgnd(var Msg: TWMEraseBkgnd); message WM_ERASEBKGND; - end; - - var - FLSM_CXHTHUMB: integer; - FLSM_CYVTHUMB: integer; - FVScrollBar: TScrollBar; - FHScrollBar: TScrollBar; - FVScrollBarContainer: TWinContainer; - FHScrollBarContainer: TWinContainer; - FScrollCornerContainer: TWinContainer; - procedure CMVisibleChanged(var Msg: TMessage); message CM_VISIBLECHANGED; - procedure ResizeScrollBars; - procedure VScrollChange(Sender: TObject); - procedure HScrollChange(Sender: TObject); - function GetIEHandle: hwnd; - - procedure DoDocumentComplete(Sender: TObject; const pDisp: IDispatch; const URL: OleVariant); - procedure DoNavigateComplete2(Sender: TObject; const pDisp: IDispatch; const URL: OleVariant); - procedure DoBeforeNavigate2(Sender: TObject; const pDisp: IDispatch; const URL, Flags, TargetFrameName, PostData, - Headers: OleVariant; var Cancel: WordBool); - procedure DoCommandStateChange(Sender: TObject; Command: integer; Enable: WordBool); - procedure DoProgressChange(Sender: TObject; Progress, ProgressMax: integer); - private - FCustomizeJSErrorDialog: Boolean; - FCustomizeStdDialogs: Boolean; - FUseVClStyleBackGroundColor: Boolean; - // IDocHostUIHandler - function ShowContextMenu(const dwID: DWORD; const ppt: PPOINT; const pcmdtReserved: IUnknown; - const pdispReserved: IDispatch): HRESULT; stdcall; - function GetHostInfo(var pInfo: TDocHostUIInfo): HRESULT; stdcall; - function ShowUI(const dwID: DWORD; const pActiveObject: IOleInPlaceActiveObject; - const pCommandTarget: IOleCommandTarget; const pFrame: IOleInPlaceFrame; const pDoc: IOleInPlaceUIWindow): HRESULT; stdcall; - function HideUI: HRESULT; stdcall; - function UpdateUI: HRESULT; stdcall; - function EnableModeless(const fEnable: BOOL): HRESULT; stdcall; - function OnDocWindowActivate(const fActivate: BOOL): HRESULT; stdcall; - function OnFrameWindowActivate(const fActivate: BOOL): HRESULT; stdcall; - function ResizeBorder(const prcBorder: PRECT; const pUIWindow: IOleInPlaceUIWindow; const FrameWindow: BOOL): HRESULT; stdcall; - function TranslateAccelerator(const lpMsg: PMSG; const pguidCmdGroup: PGUID; const nCmdID: DWORD): HRESULT; stdcall; - function GetOptionKeyPath(var pchKey: POLESTR; const dw: DWORD): HRESULT; stdcall; - function GetDropTarget(const pDropTarget: IDropTarget; out ppDropTarget: IDropTarget): HRESULT; stdcall; - function GetExternal(out ppDispatch: IDispatch): HRESULT; stdcall; - function TranslateUrl(const dwTranslate: DWORD; const pchURLIn: POLESTR; var ppchURLOut: POLESTR): HRESULT; stdcall; - function FilterDataObject(const pDO: IDataObject; out ppDORet: IDataObject): HRESULT; stdcall; -{$IFDEF HOOKDialogs} - // IDocHostShowUI - function ShowMessage(hwnd: THandle; lpstrText: POLESTR; lpstrCaption: POLESTR; dwType: longint; - lpstrHelpFile: POLESTR; dwHelpContext: longint; var plResult: LRESULT): HRESULT; stdcall; - function ShowHelp(hwnd: THandle; pszHelpFile: POLESTR; uCommand: integer; dwData: longint; ptMouse: TPoint; - var pDispachObjectHit: IDispatch): HRESULT; stdcall; - // IOleCommandTarget -{$ENDIF} - function QueryStatus(CmdGroup: PGUID; cCmds: Cardinal; prgCmds: POleCmd; CmdText: POleCmdText): HRESULT; stdcall; - function Exec(CmdGroup: PGUID; nCmdID, nCmdexecopt: DWORD; const vaIn: OleVariant; var vaOut: OleVariant): HRESULT; stdcall; - // procedure SetZOrder(TopMost: Boolean); override; - protected - procedure InvokeEvent(DispID: TDispID; var Params: TDispParams); override; - procedure SetParent(AParent: TWinControl); override; - procedure Loaded; override; - procedure WMSIZE(var Message: TWMSIZE); message WM_SIZE; - public - constructor Create(AOwner: TComponent); override; - property CustomizeStdDialogs: Boolean read FCustomizeStdDialogs write FCustomizeStdDialogs; - property CustomizeJSErrorDialog: Boolean read FCustomizeJSErrorDialog write FCustomizeJSErrorDialog; - property UseVClStyleBackGroundColor: Boolean read FUseVClStyleBackGroundColor write FUseVClStyleBackGroundColor; - end; - -implementation - -uses - MSHTML, - System.UITypes, - System.Sysutils, - System.Win.ComObj, - Vcl.Dialogs, - Vcl.Themes, - Vcl.Styles; - -const - // About Scroll Bars - // http://msdn.microsoft.com/en-us/library/windows/desktop/bb787527%28v=vs.85%29.aspx - - // MSDN WebBrowser Customization - // http://msdn.microsoft.com/en-us/library/aa770041%28v=vs.85%29.aspx - // MSDN WebBrowser Customization (Part 2) - // http://msdn.microsoft.com/en-us/library/aa770042%28v=vs.85%29.aspx - - // How to customize the TWebBrowser user interface - // http://www.delphidabbler.com/articles?article=18&part=1 - // TEmbeddedWB OnGetHostInfo - // http://www.bsalsa.com/ewb_on_get_host.html - - // http://msdn.microsoft.com/en-us/library/aa753277%28v=vs.85%29.aspx - DOCHOSTUIFLAG_FLAT_SCROLLBAR = $00000080; - DOCHOSTUIFLAG_SCROLL_NO = $00000008; - DOCHOSTUIFLAG_NO3DBORDER = $00000004; - DOCHOSTUIFLAG_DIALOG = $00000001; - DOCHOSTUIFLAG_THEME = $00040000; - DOCHOSTUIFLAG_NOTHEME = $00080000; - - // Set background to vcl styles windows color. -procedure TVclStylesWebBrowser.TWinContainer.WMEraseBkgnd(var Msg: TWMEraseBkgnd); -var - Details: TThemedElementDetails; - LCanvas: TCanvas; -begin - LCanvas := TCanvas.Create; - try - LCanvas.Handle := Msg.DC; - Details.Element := teWindow; - Details.Part := 0; - StyleServices.DrawElement(LCanvas.Handle, Details, ClientRect); - finally - LCanvas.Free; - end; -end; - -constructor TVclStylesWebBrowser.Create(AOwner: TComponent); -begin - inherited; - FLSM_CXHTHUMB := GetSystemMetrics(SM_CXHTHUMB); - FLSM_CYVTHUMB := GetSystemMetrics(SM_CYVTHUMB); - - FVScrollBarContainer := nil; - FHScrollBarContainer := nil; - - FScrollCornerContainer := TWinContainer.Create(Self); - FScrollCornerContainer.Visible := False; - - FVScrollBarContainer := TWinContainer.Create(Self); - FVScrollBarContainer.Visible := True; - FVScrollBar := TScrollBar.Create(Self); - FVScrollBar.Parent := FVScrollBarContainer; - FVScrollBar.Kind := sbVertical; - FVScrollBar.Visible := True; - FVScrollBar.Align := alClient; - FVScrollBar.OnChange := VScrollChange; - FVScrollBar.Enabled := False; - - FHScrollBarContainer := TWinContainer.Create(Self); - FHScrollBarContainer.Visible := False; - FHScrollBar := TScrollBar.Create(Self); - FHScrollBar.Parent := FHScrollBarContainer; - FHScrollBar.Visible := True; - FHScrollBar.Align := alClient; - FHScrollBar.OnChange := HScrollChange; - - FCustomizeJSErrorDialog := True; - FCustomizeStdDialogs := True; - FUseVClStyleBackGroundColor := False; -end; - -// check flicker issue; -procedure TVclStylesWebBrowser.WMSIZE(var Message: TWMSIZE); -begin - if Document <> nil then - SendMessage(Handle, WM_SETREDRAW, 0, 0); - - inherited; - ResizeScrollBars; - - if Document <> nil then - begin - SendMessage(Handle, WM_SETREDRAW, 1, 0); - RedrawWindow(Handle, nil, 0, RDW_INVALIDATE + RDW_ALLCHILDREN + RDW_UPDATENOW); - end; -end; - -function TVclStylesWebBrowser.GetOptionKeyPath(var pchKey: POLESTR; const dw: DWORD): HRESULT; -begin - Result := E_FAIL; -end; - -function TVclStylesWebBrowser.TranslateAccelerator(const lpMsg: PMSG; const pguidCmdGroup: PGUID; - const nCmdID: DWORD): HRESULT; -begin - Result := S_FALSE; -end; - -function TVclStylesWebBrowser.TranslateUrl(const dwTranslate: DWORD; const pchURLIn: POLESTR; - var ppchURLOut: POLESTR): HRESULT; -begin - Result := E_FAIL; -end; - -function TVclStylesWebBrowser.EnableModeless(const fEnable: BOOL): HRESULT; -begin - Result := S_OK; -end; - -function TVclStylesWebBrowser.FilterDataObject(const pDO: IDataObject; out ppDORet: IDataObject): HRESULT; -begin - ppDORet := nil; - Result := S_FALSE; -end; - -function TVclStylesWebBrowser.GetDropTarget(const pDropTarget: IDropTarget; out ppDropTarget: IDropTarget): HRESULT; -begin - ppDropTarget := nil; - Result := E_FAIL; -end; - -function TVclStylesWebBrowser.GetExternal(out ppDispatch: IDispatch): HRESULT; -begin - ppDispatch := nil; - Result := E_FAIL; -end; - -function TVclStylesWebBrowser.UpdateUI: HRESULT; -begin - Result := S_OK; -end; - -function TVclStylesWebBrowser.HideUI: HRESULT; -begin - Result := S_OK; -end; - -function TVclStylesWebBrowser.OnDocWindowActivate(const fActivate: BOOL): HRESULT; -begin - Result := S_OK; -end; - -function TVclStylesWebBrowser.OnFrameWindowActivate(const fActivate: BOOL): HRESULT; -begin - Result := S_OK; -end; - -// How to handle script errors as a WebBrowser control host -// http://support.microsoft.com/kb/261003 -function TVclStylesWebBrowser.Exec(CmdGroup: PGUID; nCmdID, nCmdexecopt: DWORD; const vaIn: OleVariant; - var vaOut: OleVariant): HRESULT; -const - CGID_DocHostCommandHandler: TGUID = (D1: $F38BC242; D2: $B950; D3: $11D1; - D4: ($89, $18, $00, $C0, $4F, $C2, $C8, $36)); -var - LHTMLEventObj: IHTMLEventObj; - LHTMLWindow2: IHTMLWindow2; - LHTMLDocument2: IHTMLDocument2; - LUnknown: IUnknown; - Msg: string; - - function GetPropertyValue(const PropName: WideString): OleVariant; - var - LParams: TDispParams; - LDispIDs: integer; - Status: integer; - ExcepInfo: TExcepInfo; - LName: PWideChar; - begin - ZeroMemory(@LParams, SizeOf(LParams)); - LName := PWideChar(PropName); - Status := LHTMLEventObj.GetIDsOfNames(GUID_NULL, @LName, 1, LOCALE_SYSTEM_DEFAULT, @LDispIDs); - if Status = 0 then - begin - Status := LHTMLEventObj.Invoke(LDispIDs, GUID_NULL, LOCALE_SYSTEM_DEFAULT, DISPATCH_PROPERTYGET, LParams, @Result, - @ExcepInfo, nil); - if Status <> 0 then - DispatchInvokeError(Status, ExcepInfo); - end - else if Status = DISP_E_UNKNOWNNAME then - raise EOleError.CreateFmt('Property "%s" is not supported.', [PropName]) - else - OleCheck(Status); - end; - -begin - Result := S_OK; - { - //to do -> prompt box [000214D0-0000-0000-C000-000000000046] + OLECMDID_UPDATETRAVELENTRY_DATARECOVERY - } - if (CmdGroup <> nil) and IsEqualGuid(CmdGroup^, CGID_DocHostCommandHandler) then - case nCmdID of - OLECMDID_SHOWSCRIPTERROR: - begin - if not FCustomizeJSErrorDialog then - exit; - LUnknown := IUnknown(TVarData(vaIn).VUnknown); - if Succeeded(LUnknown.QueryInterface(IID_IHTMLDocument2, LHTMLDocument2)) then - begin - LHTMLWindow2 := LHTMLDocument2.Get_parentWindow; - if LHTMLWindow2 <> nil then - begin - LHTMLEventObj := LHTMLWindow2.Get_event; - if LHTMLEventObj <> nil then - begin - Msg := 'An error has ocurred in the script in this page' + sLineBreak + 'Line %s' + sLineBreak + - 'Char %s' + sLineBreak + 'Error %s' + sLineBreak + 'Code %s' + sLineBreak + 'URL %s' + sLineBreak - + 'Do you want to continue running scripts on this page?'; - Msg := Format(Msg, [GetPropertyValue('errorline'), GetPropertyValue('errorCharacter'), - GetPropertyValue('errorMessage'), GetPropertyValue('errorCode'), GetPropertyValue('errorUrl')]); - if MessageDlg(Msg, mtWarning, [mbYes, mbNo], 0) = mrYes then - vaOut := True - else - vaOut := False; - - Result := S_OK; - end; - end; - end; - end; - else - Result := OLECMDERR_E_NOTSUPPORTED; - end - else - Result := OLECMDERR_E_UNKNOWNGROUP; -end; - -function TVclStylesWebBrowser.QueryStatus(CmdGroup: PGUID; cCmds: Cardinal; prgCmds: POleCmd; - CmdText: POleCmdText): HRESULT; -begin - Result := S_FALSE; -end; - -function TVclStylesWebBrowser.ResizeBorder(const prcBorder: PRECT; const pUIWindow: IOleInPlaceUIWindow; - const FrameWindow: BOOL): HRESULT; -begin - Result := S_FALSE; -end; - -function TVclStylesWebBrowser.ShowUI(const dwID: DWORD; const pActiveObject: IOleInPlaceActiveObject; - const pCommandTarget: IOleCommandTarget; const pFrame: IOleInPlaceFrame; const pDoc: IOleInPlaceUIWindow): HRESULT; -begin - Result := S_OK; -end; - -function TVclStylesWebBrowser.ShowContextMenu(const dwID: DWORD; const ppt: PPOINT; const pcmdtReserved: IUnknown; - const pdispReserved: IDispatch): HRESULT; -begin - Result := S_FALSE; -end; - -{$IFDEF HOOKDialogs} - -function TVclStylesWebBrowser.ShowHelp(hwnd: THandle; pszHelpFile: POLESTR; uCommand, dwData: integer; ptMouse: TPoint; - var pDispachObjectHit: IDispatch): HRESULT; -begin - Result := S_FALSE; -end; - -// http://msdn.microsoft.com/en-us/library/aa753271%28v=vs.85%29.aspx -function TVclStylesWebBrowser.ShowMessage(hwnd: THandle; lpstrText, lpstrCaption: POLESTR; dwType: integer; - lpstrHelpFile: POLESTR; dwHelpContext: integer; var plResult: LRESULT): HRESULT; -var - DlgType: TMsgDlgType; - Buttons: TMsgDlgButtons; -begin - Result := E_NOTIMPL; - if not FCustomizeStdDialogs then - exit; - - DlgType := mtInformation; - if ((dwType and MB_ICONMASK) = MB_ICONHAND) or ((dwType and MB_ICONMASK) = MB_USERICON) then - DlgType := mtCustom - else if (dwType and MB_ICONMASK) = MB_ICONWARNING then - DlgType := mtWarning - else if (dwType and MB_ICONMASK) = MB_ICONQUESTION then - DlgType := mtConfirmation - else if (dwType and MB_ICONMASK) = MB_ICONEXCLAMATION then - DlgType := mtInformation; - - case dwType and MB_TYPEMASK of - MB_OK: - Buttons := [mbOK]; - MB_OKCANCEL: - Buttons := [mbOK, mbCancel]; - MB_ABORTRETRYIGNORE: - Buttons := [mbAbort, mbRetry, mbIgnore]; - MB_YESNOCANCEL: - Buttons := [mbYes, mbNo, mbCancel]; - MB_YESNO: - Buttons := [mbYes, mbNo]; - MB_RETRYCANCEL: - Buttons := [mbRetry, mbCancel]; - else - Buttons := [mbOK]; - end; - - plResult := MessageDlg(lpstrText, DlgType, Buttons, dwHelpContext); - Result := S_OK; -end; -{$ENDIF} - -function TVclStylesWebBrowser.GetHostInfo(var pInfo: TDocHostUIInfo): HRESULT; -var - BodyCss: string; - ColorHtml: string; - LColor: TColor; -begin - LColor := StyleServices.GetSystemColor(clWindow); - ColorHtml := Format('#%.2x%.2x%.2x', [GetRValue(LColor), GetGValue(LColor), GetBValue(LColor)]); - BodyCss := Format('BODY {background-color:%s}', [ColorHtml]); - - pInfo.cbSize := SizeOf(pInfo); - pInfo.dwFlags := 0; - pInfo.dwFlags := pInfo.dwFlags or DOCHOSTUIFLAG_NO3DBORDER; // disable 3d border - pInfo.dwFlags := pInfo.dwFlags or DOCHOSTUIFLAG_THEME; - if FUseVClStyleBackGroundColor then - pInfo.pchHostCss := PWideChar(BodyCss); - Result := S_OK; - ResizeScrollBars; -end; - -function TVclStylesWebBrowser.GetIEHandle: hwnd; -var - ChildHWND: WinApi.Windows.hwnd; - TempHWND: WinApi.Windows.hwnd; - lpClassName: Array [0 .. 255] of Char; -begin - TempHWND := Self.Handle; - if TempHWND <> 0 then - while True do - begin - ChildHWND := GetWindow(TempHWND, GW_CHILD); - if ChildHWND = 0 then - break; - GetClassName(ChildHWND, lpClassName, SizeOf(lpClassName)); - if SameText(string(lpClassName), 'Internet Explorer_Server') then - begin - Result := ChildHWND; - exit; - end; - TempHWND := ChildHWND; - end; - Result := 0; -end; - -procedure TVclStylesWebBrowser.SetParent(AParent: TWinControl); -begin - inherited; - if not(csDestroying in ComponentState) then - begin - FVScrollBarContainer.Parent := AParent; - FHScrollBarContainer.Parent := AParent; - FScrollCornerContainer.Parent := AParent; - ResizeScrollBars; - end; -end; - -// procedure TVclStylesWebBrowser.SetZOrder(TopMost: Boolean); -// begin -// inherited; -// ResizeScrollBars; -// end; - -procedure TVclStylesWebBrowser.ResizeScrollBars; -var - StateVisible: Boolean; - DocClientWidth: integer; - ScrollWidth: integer; - ScrollHeight: integer; - HPageSize: integer; - VPageSize: integer; - LRect: TRect; - IEHWND: WinApi.Windows.hwnd; - - procedure UpdateContainers; - begin - if FVScrollBarContainer.Visible then - begin - LRect := BoundsRect; - // OutputDebugString(PChar(Format('Original VScrollBarContainer Left %d Top %d Width %d Height %d',[LRect.Left, LRect.Top, LRect.Width, LRect.Height]) )); - LRect.Left := LRect.Right - FLSM_CXHTHUMB; - if FHScrollBarContainer.Visible then - LRect.Bottom := LRect.Bottom - FLSM_CYVTHUMB; - - // LRect.Width:=2; - FVScrollBarContainer.BoundsRect := LRect; - end; - - if FHScrollBarContainer.Visible then - begin - LRect := BoundsRect; - // OutputDebugString(PChar(Format('Original HScrollBarContainer Left %d Top %d Width %d Height %d',[LRect.Left, LRect.Top, LRect.Width, LRect.Height]) )); - LRect.Top := LRect.Bottom - FLSM_CYVTHUMB; - if FVScrollBarContainer.Visible then - LRect.Right := LRect.Right - FLSM_CXHTHUMB; - - // LRect.Height:=2; - FHScrollBarContainer.BoundsRect := LRect; - // OutputDebugString(PChar(Format('ScrollBar Left %d Top %d Width %d Height %d',[LRect.Left, LRect.Top, LRect.Width, LRect.Height]) )); - end; - - StateVisible := FScrollCornerContainer.Visible; - FScrollCornerContainer.Visible := FHScrollBarContainer.Visible and FVScrollBarContainer.Visible; - - if FScrollCornerContainer.Visible then - begin - LRect := BoundsRect; - LRect.Left := LRect.Right - FLSM_CXHTHUMB; - LRect.Top := LRect.Bottom - FLSM_CYVTHUMB; - FScrollCornerContainer.BoundsRect := LRect; - if not StateVisible then - FScrollCornerContainer.BringToFront; - end; - end; - -begin - IEHWND := GetIEHandle; - - if (IEHWND = 0) or (FVScrollBarContainer = nil) or (FHScrollBarContainer = nil) then - exit; - - FVScrollBarContainer.Visible := True; - - if (Document <> nil) and (IHTMLDocument2(Document).Body <> nil) then - begin - DocClientWidth := OleVariant(Document).documentElement.ClientWidth; - if (DocClientWidth > 0) then - begin - ScrollWidth := OleVariant(Document).documentElement.ScrollWidth; - // OutputDebugString(PChar(Format('ScrollWidth %s',[inttoStr(ScrollWidth)]))); - - if (FHScrollBar.Max <> ScrollWidth) and (ScrollWidth >= FHScrollBar.PageSize) and (ScrollWidth >= FHScrollBar.Min) - then - FHScrollBar.Max := ScrollWidth; - - ScrollHeight := OleVariant(Document).documentElement.ScrollHeight; - // OutputDebugString(PChar(Format('ScrollHeight %s',[inttoStr(ScrollHeight)]))); - - if (FVScrollBar.Max <> ScrollHeight) and (ScrollHeight >= FVScrollBar.PageSize) and - (ScrollHeight >= FVScrollBar.Min) then - FVScrollBar.Max := ScrollHeight; - end - else - begin - ScrollWidth := IHTMLDocument2(Document).Body.getAttribute('ScrollWidth', 0); - if (FHScrollBar.Max <> ScrollWidth) and (ScrollWidth >= FHScrollBar.PageSize) and (ScrollWidth >= FHScrollBar.Min) - then - FHScrollBar.Max := ScrollWidth; - - ScrollHeight := IHTMLDocument2(Document).Body.getAttribute('ScrollHeight', 0); - if (FVScrollBar.Max <> ScrollHeight) and (ScrollHeight >= FVScrollBar.PageSize) and - (ScrollHeight >= FVScrollBar.Min) then - FVScrollBar.Max := ScrollHeight; - end; - - if (FHScrollBar.Max > Self.Width - FLSM_CXHTHUMB) and (FHScrollBar.Max > 0) and (FHScrollBar.Max <> Self.Width) then - VPageSize := Self.Height - FLSM_CYVTHUMB - else - VPageSize := Self.Height; - - FVScrollBar.PageSize := VPageSize; - FVScrollBar.SetParams(FVScrollBar.Position, 0, FVScrollBar.Max); - FVScrollBar.LargeChange := FVScrollBar.PageSize; - - HPageSize := Self.Width - FLSM_CXHTHUMB; - FHScrollBar.PageSize := HPageSize; - FHScrollBar.SetParams(FHScrollBar.Position, 0, FHScrollBar.Max); - FHScrollBar.LargeChange := FHScrollBar.PageSize; - - FVScrollBar.Enabled := (VPageSize < FVScrollBar.Max) and (FVScrollBar.PageSize > 0) and (FVScrollBar.Max > 0) and - (FVScrollBar.Max <> Self.Height); - - StateVisible := FHScrollBarContainer.Visible; - - if IsWindow(FHScrollBarContainer.Handle) then - FHScrollBarContainer.Visible := (HPageSize < FHScrollBar.Max) and (FHScrollBar.PageSize < FHScrollBar.Max) and - (FHScrollBar.Max > 0) and (FHScrollBar.Max <> Self.Width); - - if not StateVisible and FHScrollBarContainer.Visible then - FHScrollBarContainer.BringToFront; - - FVScrollBarContainer.BringToFront; - end; - - UpdateContainers; -end; - -procedure TVclStylesWebBrowser.DoProgressChange(Sender: TObject; Progress, ProgressMax: integer); -begin - ResizeScrollBars; -end; - -procedure TVclStylesWebBrowser.DoDocumentComplete(Sender: TObject; const pDisp: IDispatch; const URL: OleVariant); -begin - ResizeScrollBars; -end; - -procedure TVclStylesWebBrowser.DoNavigateComplete2(Sender: TObject; const pDisp: IDispatch; const URL: OleVariant); -begin - ResizeScrollBars; -end; - -procedure TVclStylesWebBrowser.DoCommandStateChange(Sender: TObject; Command: integer; Enable: WordBool); -begin - if (Document <> nil) and (IHTMLDocument2(Document).Body <> nil) then - begin - if (OleVariant(Document).documentElement.scrollTop = 0) then - FVScrollBar.Position := IHTMLDocument2(Document).Body.getAttribute('ScrollTop', 0) - else - FVScrollBar.Position := OleVariant(Document).documentElement.scrollTop; - - if (OleVariant(Document).documentElement.scrollLeft = 0) then - FHScrollBar.Position := IHTMLDocument2(Document).Body.getAttribute('ScrollLeft', 0) - else - FHScrollBar.Position := OleVariant(Document).documentElement.scrollLeft - end; - ResizeScrollBars; -end; - -procedure TVclStylesWebBrowser.DoBeforeNavigate2(Sender: TObject; const pDisp: IDispatch; - const URL, Flags, TargetFrameName, PostData, Headers: OleVariant; var Cancel: WordBool); -begin - ResizeScrollBars; -end; - -procedure TVclStylesWebBrowser.VScrollChange(Sender: TObject); -begin - if (Document <> nil) and (IHTMLDocument2(Document).ParentWindow <> nil) then - IHTMLWindow2(IHTMLDocument2(Document).ParentWindow).Scroll(FHScrollBar.Position, FVScrollBar.Position); -end; - -procedure TVclStylesWebBrowser.HScrollChange(Sender: TObject); -begin - if (Document <> nil) and (IHTMLDocument2(Document).ParentWindow <> nil) then - IHTMLWindow2(IHTMLDocument2(Document).ParentWindow).Scroll(FHScrollBar.Position, FVScrollBar.Position); -end; - -procedure TVclStylesWebBrowser.InvokeEvent(DispID: TDispID; var Params: TDispParams); -var - ArgCount: integer; - LVarArray: Array of OleVariant; - LIndex: integer; -begin - inherited; - ArgCount := Params.cArgs; - SetLength(LVarArray, ArgCount); - for LIndex := Low(LVarArray) to High(LVarArray) do - LVarArray[High(LVarArray) - LIndex] := OleVariant(TDispParams(Params).rgvarg^[LIndex]); - - case DispID of - 252: - DoNavigateComplete2(Self, LVarArray[0] { const IDispatch } , LVarArray[1] { const OleVariant } ); - - 259: - DoDocumentComplete(Self, LVarArray[0] { const IDispatch } , LVarArray[1] { const OleVariant } ); - - 250: - DoBeforeNavigate2(Self, LVarArray[0] { const IDispatch } , LVarArray[1] { const OleVariant } , - LVarArray[2] { const OleVariant } , LVarArray[3] { const OleVariant } , LVarArray[4] { const OleVariant } , - LVarArray[5] { const OleVariant } , WordBool((TVarData(LVarArray[6]).VPointer)^) { var WordBool } ); - - 105: - DoCommandStateChange(Self, LVarArray[0] { Integer } , LVarArray[1] { WordBool } ); - - 108: - DoProgressChange(Self, LVarArray[0] { Integer } , LVarArray[1] { Integer } ); - - end; - - SetLength(LVarArray, 0); -end; - -procedure TVclStylesWebBrowser.CMVisibleChanged(var Msg: TMessage); -begin - inherited; - FVScrollBarContainer.Visible := Self.Visible; - FHScrollBarContainer.Visible := Self.Visible; - FScrollCornerContainer.Visible := Self.Visible; -end; - -procedure TVclStylesWebBrowser.Loaded; -begin - inherited; - ResizeScrollBars; -end; - -end. +// ************************************************************************************************** +// +// Unit Vcl.Styles.WebBrowser +// unit for the VCL Styles Utils +// https://github.com/RRUZ/vcl-styles-utils/ +// +// 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. +// +// The Original Code is Vcl.Styles.WebBrowser.pas. +// +// The Initial Developer of the Original Code is Rodrigo Ruz V. +// Portions created by Rodrigo Ruz V. are Copyright (C) 2012-2023 Rodrigo Ruz V. +// All Rights Reserved. +// +// ************************************************************************************************** +unit Vcl.Styles.WebBrowser; + +interface + +// Uncomment this option if you want which the TVclStylesWebBrowser class hook the dialogs messages directly. +{ .$DEFINE HOOKDialogs } +uses + System.Classes, + WinApi.Windows, + WinApi.Messages, + WinApi.Activex, + Vcl.Forms, + Vcl.OleServer, + Vcl.Graphics, + Vcl.Controls, + Vcl.StdCtrls, + SHDocVw; + +type + + TDocHostUIInfo = record + cbSize: ULONG; + dwFlags: DWORD; + dwDoubleClick: DWORD; + pchHostCss: PWChar; + pchHostNS: PWChar; + end; + +{$IFDEF HOOKDialogs} + + // http://msdn.microsoft.com/en-us/library/aa753269%28v=vs.85%29.aspx + IDocHostShowUI = interface(IUnknown) + ['{c4d244b0-d43e-11cf-893b-00aa00bdce1a}'] + function ShowMessage(hwnd: THandle; lpstrText: POLESTR; lpstrCaption: POLESTR; dwType: longint; + lpstrHelpFile: POLESTR; dwHelpContext: longint; var plResult: LRESULT): HRESULT; stdcall; + function ShowHelp(hwnd: THandle; pszHelpFile: POLESTR; uCommand: integer; dwData: longint; ptMouse: TPoint; + var pDispachObjectHit: IDispatch): HRESULT; stdcall; + end; // IDocHostShowUI +{$ENDIF} + + // http://msdn.microsoft.com/en-us/library/aa753260%28v=vs.85%29.aspx + IDocHostUIHandler = interface(IUnknown) + ['{BD3F23C0-D43E-11CF-893B-00AA00BDCE1A}'] + function ShowContextMenu(const dwID: DWORD; const ppt: PPOINT; const pcmdtReserved: IUnknown; + const pdispReserved: IDispatch): HRESULT; stdcall; + function GetHostInfo(var pInfo: TDocHostUIInfo): HRESULT; stdcall; + function ShowUI(const dwID: DWORD; const pActiveObject: IOleInPlaceActiveObject; + const pCommandTarget: IOleCommandTarget; const pFrame: IOleInPlaceFrame; const pDoc: IOleInPlaceUIWindow) +: HRESULT; stdcall; + function HideUI: HRESULT; stdcall; + function UpdateUI: HRESULT; stdcall; + function EnableModeless(const fEnable: BOOL): HRESULT; stdcall; + function OnDocWindowActivate(const fActivate: BOOL): HRESULT; stdcall; + function OnFrameWindowActivate(const fActivate: BOOL): HRESULT; stdcall; + function ResizeBorder(const prcBorder: PRECT; const pUIWindow: IOleInPlaceUIWindow; const FrameWindow: BOOL) +: HRESULT; stdcall; + function TranslateAccelerator(const lpMsg: PMSG; const pguidCmdGroup: PGUID; const nCmdID: DWORD): HRESULT; stdcall; + function GetOptionKeyPath(var pchKey: POLESTR; const dw: DWORD): HRESULT; stdcall; + function GetDropTarget(const pDropTarget: IDropTarget; out ppDropTarget: IDropTarget): HRESULT; stdcall; + function GetExternal(out ppDispatch: IDispatch): HRESULT; stdcall; + function TranslateUrl(const dwTranslate: DWORD; const pchURLIn: POLESTR; var ppchURLOut: POLESTR): HRESULT; stdcall; + function FilterDataObject(const pDO: IDataObject; out ppDORet: IDataObject): HRESULT; stdcall; + end; + + TVclStylesWebBrowser = class(SHDocVw.TWebBrowser, IDocHostUIHandler{$IFDEF HOOKDialogs}, IDocHostShowUI{$ENDIF}, + IOleCommandTarget) + strict private + type + TWinContainer = class(TWinControl) + procedure WMEraseBkgnd(var Msg: TWMEraseBkgnd); message WM_ERASEBKGND; + end; + + var + FLSM_CXHTHUMB: integer; + FLSM_CYVTHUMB: integer; + FVScrollBar: TScrollBar; + FHScrollBar: TScrollBar; + FVScrollBarContainer: TWinContainer; + FHScrollBarContainer: TWinContainer; + FScrollCornerContainer: TWinContainer; + procedure CMVisibleChanged(var Msg: TMessage); message CM_VISIBLECHANGED; + procedure ResizeScrollBars; + procedure VScrollChange(Sender: TObject); + procedure HScrollChange(Sender: TObject); + function GetIEHandle: hwnd; + + procedure DoDocumentComplete(Sender: TObject; const pDisp: IDispatch; const URL: OleVariant); + procedure DoNavigateComplete2(Sender: TObject; const pDisp: IDispatch; const URL: OleVariant); + procedure DoBeforeNavigate2(Sender: TObject; const pDisp: IDispatch; const URL, Flags, TargetFrameName, PostData, + Headers: OleVariant; var Cancel: WordBool); + procedure DoCommandStateChange(Sender: TObject; Command: integer; Enable: WordBool); + procedure DoProgressChange(Sender: TObject; Progress, ProgressMax: integer); + private + FCustomizeJSErrorDialog: Boolean; + FCustomizeStdDialogs: Boolean; + FUseVClStyleBackGroundColor: Boolean; + // IDocHostUIHandler + function ShowContextMenu(const dwID: DWORD; const ppt: PPOINT; const pcmdtReserved: IUnknown; + const pdispReserved: IDispatch): HRESULT; stdcall; + function GetHostInfo(var pInfo: TDocHostUIInfo): HRESULT; stdcall; + function ShowUI(const dwID: DWORD; const pActiveObject: IOleInPlaceActiveObject; + const pCommandTarget: IOleCommandTarget; const pFrame: IOleInPlaceFrame; const pDoc: IOleInPlaceUIWindow): HRESULT; stdcall; + function HideUI: HRESULT; stdcall; + function UpdateUI: HRESULT; stdcall; + function EnableModeless(const fEnable: BOOL): HRESULT; stdcall; + function OnDocWindowActivate(const fActivate: BOOL): HRESULT; stdcall; + function OnFrameWindowActivate(const fActivate: BOOL): HRESULT; stdcall; + function ResizeBorder(const prcBorder: PRECT; const pUIWindow: IOleInPlaceUIWindow; const FrameWindow: BOOL): HRESULT; stdcall; + function TranslateAccelerator(const lpMsg: PMSG; const pguidCmdGroup: PGUID; const nCmdID: DWORD): HRESULT; stdcall; + function GetOptionKeyPath(var pchKey: POLESTR; const dw: DWORD): HRESULT; stdcall; + function GetDropTarget(const pDropTarget: IDropTarget; out ppDropTarget: IDropTarget): HRESULT; stdcall; + function GetExternal(out ppDispatch: IDispatch): HRESULT; stdcall; + function TranslateUrl(const dwTranslate: DWORD; const pchURLIn: POLESTR; var ppchURLOut: POLESTR): HRESULT; stdcall; + function FilterDataObject(const pDO: IDataObject; out ppDORet: IDataObject): HRESULT; stdcall; +{$IFDEF HOOKDialogs} + // IDocHostShowUI + function ShowMessage(hwnd: THandle; lpstrText: POLESTR; lpstrCaption: POLESTR; dwType: longint; + lpstrHelpFile: POLESTR; dwHelpContext: longint; var plResult: LRESULT): HRESULT; stdcall; + function ShowHelp(hwnd: THandle; pszHelpFile: POLESTR; uCommand: integer; dwData: longint; ptMouse: TPoint; + var pDispachObjectHit: IDispatch): HRESULT; stdcall; + // IOleCommandTarget +{$ENDIF} + function QueryStatus(CmdGroup: PGUID; cCmds: Cardinal; prgCmds: POleCmd; CmdText: POleCmdText): HRESULT; stdcall; + function Exec(CmdGroup: PGUID; nCmdID, nCmdexecopt: DWORD; const vaIn: OleVariant; var vaOut: OleVariant): HRESULT; stdcall; + // procedure SetZOrder(TopMost: Boolean); override; + protected + procedure InvokeEvent(DispID: TDispID; var Params: TDispParams); override; + procedure SetParent(AParent: TWinControl); override; + procedure Loaded; override; + procedure WMSIZE(var Message: TWMSIZE); message WM_SIZE; + public + constructor Create(AOwner: TComponent); override; + property CustomizeStdDialogs: Boolean read FCustomizeStdDialogs write FCustomizeStdDialogs; + property CustomizeJSErrorDialog: Boolean read FCustomizeJSErrorDialog write FCustomizeJSErrorDialog; + property UseVClStyleBackGroundColor: Boolean read FUseVClStyleBackGroundColor write FUseVClStyleBackGroundColor; + end; + +implementation + +uses + MSHTML, + System.UITypes, + System.Sysutils, + System.Win.ComObj, + Vcl.Dialogs, + Vcl.Themes, + Vcl.Styles; + +const + // About Scroll Bars + // http://msdn.microsoft.com/en-us/library/windows/desktop/bb787527%28v=vs.85%29.aspx + + // MSDN WebBrowser Customization + // http://msdn.microsoft.com/en-us/library/aa770041%28v=vs.85%29.aspx + // MSDN WebBrowser Customization (Part 2) + // http://msdn.microsoft.com/en-us/library/aa770042%28v=vs.85%29.aspx + + // How to customize the TWebBrowser user interface + // http://www.delphidabbler.com/articles?article=18&part=1 + // TEmbeddedWB OnGetHostInfo + // http://www.bsalsa.com/ewb_on_get_host.html + + // http://msdn.microsoft.com/en-us/library/aa753277%28v=vs.85%29.aspx + DOCHOSTUIFLAG_FLAT_SCROLLBAR = $00000080; + DOCHOSTUIFLAG_SCROLL_NO = $00000008; + DOCHOSTUIFLAG_NO3DBORDER = $00000004; + DOCHOSTUIFLAG_DIALOG = $00000001; + DOCHOSTUIFLAG_THEME = $00040000; + DOCHOSTUIFLAG_NOTHEME = $00080000; + + // Set background to vcl styles windows color. +procedure TVclStylesWebBrowser.TWinContainer.WMEraseBkgnd(var Msg: TWMEraseBkgnd); +var + Details: TThemedElementDetails; + LCanvas: TCanvas; +begin + LCanvas := TCanvas.Create; + try + LCanvas.Handle := Msg.DC; + Details.Element := teWindow; + Details.Part := 0; + StyleServices.DrawElement(LCanvas.Handle, Details, ClientRect); + finally + LCanvas.Free; + end; +end; + +constructor TVclStylesWebBrowser.Create(AOwner: TComponent); +begin + inherited; + FLSM_CXHTHUMB := GetSystemMetrics(SM_CXHTHUMB); + FLSM_CYVTHUMB := GetSystemMetrics(SM_CYVTHUMB); + + FVScrollBarContainer := nil; + FHScrollBarContainer := nil; + + FScrollCornerContainer := TWinContainer.Create(Self); + FScrollCornerContainer.Visible := False; + + FVScrollBarContainer := TWinContainer.Create(Self); + FVScrollBarContainer.Visible := True; + FVScrollBar := TScrollBar.Create(Self); + FVScrollBar.Parent := FVScrollBarContainer; + FVScrollBar.Kind := sbVertical; + FVScrollBar.Visible := True; + FVScrollBar.Align := alClient; + FVScrollBar.OnChange := VScrollChange; + FVScrollBar.Enabled := False; + + FHScrollBarContainer := TWinContainer.Create(Self); + FHScrollBarContainer.Visible := False; + FHScrollBar := TScrollBar.Create(Self); + FHScrollBar.Parent := FHScrollBarContainer; + FHScrollBar.Visible := True; + FHScrollBar.Align := alClient; + FHScrollBar.OnChange := HScrollChange; + + FCustomizeJSErrorDialog := True; + FCustomizeStdDialogs := True; + FUseVClStyleBackGroundColor := False; +end; + +// check flicker issue; +procedure TVclStylesWebBrowser.WMSIZE(var Message: TWMSIZE); +begin + if Document <> nil then + SendMessage(Handle, WM_SETREDRAW, 0, 0); + + inherited; + ResizeScrollBars; + + if Document <> nil then + begin + SendMessage(Handle, WM_SETREDRAW, 1, 0); + RedrawWindow(Handle, nil, 0, RDW_INVALIDATE + RDW_ALLCHILDREN + RDW_UPDATENOW); + end; +end; + +function TVclStylesWebBrowser.GetOptionKeyPath(var pchKey: POLESTR; const dw: DWORD): HRESULT; +begin + Result := E_FAIL; +end; + +function TVclStylesWebBrowser.TranslateAccelerator(const lpMsg: PMSG; const pguidCmdGroup: PGUID; + const nCmdID: DWORD): HRESULT; +begin + Result := S_FALSE; +end; + +function TVclStylesWebBrowser.TranslateUrl(const dwTranslate: DWORD; const pchURLIn: POLESTR; + var ppchURLOut: POLESTR): HRESULT; +begin + Result := E_FAIL; +end; + +function TVclStylesWebBrowser.EnableModeless(const fEnable: BOOL): HRESULT; +begin + Result := S_OK; +end; + +function TVclStylesWebBrowser.FilterDataObject(const pDO: IDataObject; out ppDORet: IDataObject): HRESULT; +begin + ppDORet := nil; + Result := S_FALSE; +end; + +function TVclStylesWebBrowser.GetDropTarget(const pDropTarget: IDropTarget; out ppDropTarget: IDropTarget): HRESULT; +begin + ppDropTarget := nil; + Result := E_FAIL; +end; + +function TVclStylesWebBrowser.GetExternal(out ppDispatch: IDispatch): HRESULT; +begin + ppDispatch := nil; + Result := E_FAIL; +end; + +function TVclStylesWebBrowser.UpdateUI: HRESULT; +begin + Result := S_OK; +end; + +function TVclStylesWebBrowser.HideUI: HRESULT; +begin + Result := S_OK; +end; + +function TVclStylesWebBrowser.OnDocWindowActivate(const fActivate: BOOL): HRESULT; +begin + Result := S_OK; +end; + +function TVclStylesWebBrowser.OnFrameWindowActivate(const fActivate: BOOL): HRESULT; +begin + Result := S_OK; +end; + +// How to handle script errors as a WebBrowser control host +// http://support.microsoft.com/kb/261003 +function TVclStylesWebBrowser.Exec(CmdGroup: PGUID; nCmdID, nCmdexecopt: DWORD; const vaIn: OleVariant; + var vaOut: OleVariant): HRESULT; +const + CGID_DocHostCommandHandler: TGUID = (D1: $F38BC242; D2: $B950; D3: $11D1; + D4: ($89, $18, $00, $C0, $4F, $C2, $C8, $36)); +var + LHTMLEventObj: IHTMLEventObj; + LHTMLWindow2: IHTMLWindow2; + LHTMLDocument2: IHTMLDocument2; + LUnknown: IUnknown; + Msg: string; + + function GetPropertyValue(const PropName: WideString): OleVariant; + var + LParams: TDispParams; + LDispIDs: integer; + Status: integer; + ExcepInfo: TExcepInfo; + LName: PWideChar; + begin + ZeroMemory(@LParams, SizeOf(LParams)); + LName := PWideChar(PropName); + Status := LHTMLEventObj.GetIDsOfNames(GUID_NULL, @LName, 1, LOCALE_SYSTEM_DEFAULT, @LDispIDs); + if Status = 0 then + begin + Status := LHTMLEventObj.Invoke(LDispIDs, GUID_NULL, LOCALE_SYSTEM_DEFAULT, DISPATCH_PROPERTYGET, LParams, @Result, + @ExcepInfo, nil); + if Status <> 0 then + DispatchInvokeError(Status, ExcepInfo); + end + else if Status = DISP_E_UNKNOWNNAME then + raise EOleError.CreateFmt('Property "%s" is not supported.', [PropName]) + else + OleCheck(Status); + end; + +begin + Result := S_OK; + { + //to do -> prompt box [000214D0-0000-0000-C000-000000000046] + OLECMDID_UPDATETRAVELENTRY_DATARECOVERY + } + if (CmdGroup <> nil) and IsEqualGuid(CmdGroup^, CGID_DocHostCommandHandler) then + case nCmdID of + OLECMDID_SHOWSCRIPTERROR: + begin + if not FCustomizeJSErrorDialog then + exit; + LUnknown := IUnknown(TVarData(vaIn).VUnknown); + if Succeeded(LUnknown.QueryInterface(IID_IHTMLDocument2, LHTMLDocument2)) then + begin + LHTMLWindow2 := LHTMLDocument2.Get_parentWindow; + if LHTMLWindow2 <> nil then + begin + LHTMLEventObj := LHTMLWindow2.Get_event; + if LHTMLEventObj <> nil then + begin + Msg := 'An error has ocurred in the script in this page' + sLineBreak + 'Line %s' + sLineBreak + + 'Char %s' + sLineBreak + 'Error %s' + sLineBreak + 'Code %s' + sLineBreak + 'URL %s' + sLineBreak + + 'Do you want to continue running scripts on this page?'; + Msg := Format(Msg, [GetPropertyValue('errorline'), GetPropertyValue('errorCharacter'), + GetPropertyValue('errorMessage'), GetPropertyValue('errorCode'), GetPropertyValue('errorUrl')]); + if MessageDlg(Msg, mtWarning, [mbYes, mbNo], 0) = mrYes then + vaOut := True + else + vaOut := False; + + Result := S_OK; + end; + end; + end; + end; + else + Result := OLECMDERR_E_NOTSUPPORTED; + end + else + Result := OLECMDERR_E_UNKNOWNGROUP; +end; + +function TVclStylesWebBrowser.QueryStatus(CmdGroup: PGUID; cCmds: Cardinal; prgCmds: POleCmd; + CmdText: POleCmdText): HRESULT; +begin + Result := S_FALSE; +end; + +function TVclStylesWebBrowser.ResizeBorder(const prcBorder: PRECT; const pUIWindow: IOleInPlaceUIWindow; + const FrameWindow: BOOL): HRESULT; +begin + Result := S_FALSE; +end; + +function TVclStylesWebBrowser.ShowUI(const dwID: DWORD; const pActiveObject: IOleInPlaceActiveObject; + const pCommandTarget: IOleCommandTarget; const pFrame: IOleInPlaceFrame; const pDoc: IOleInPlaceUIWindow): HRESULT; +begin + Result := S_OK; +end; + +function TVclStylesWebBrowser.ShowContextMenu(const dwID: DWORD; const ppt: PPOINT; const pcmdtReserved: IUnknown; + const pdispReserved: IDispatch): HRESULT; +begin + Result := S_FALSE; +end; + +{$IFDEF HOOKDialogs} + +function TVclStylesWebBrowser.ShowHelp(hwnd: THandle; pszHelpFile: POLESTR; uCommand, dwData: integer; ptMouse: TPoint; + var pDispachObjectHit: IDispatch): HRESULT; +begin + Result := S_FALSE; +end; + +// http://msdn.microsoft.com/en-us/library/aa753271%28v=vs.85%29.aspx +function TVclStylesWebBrowser.ShowMessage(hwnd: THandle; lpstrText, lpstrCaption: POLESTR; dwType: integer; + lpstrHelpFile: POLESTR; dwHelpContext: integer; var plResult: LRESULT): HRESULT; +var + DlgType: TMsgDlgType; + Buttons: TMsgDlgButtons; +begin + Result := E_NOTIMPL; + if not FCustomizeStdDialogs then + exit; + + DlgType := mtInformation; + if ((dwType and MB_ICONMASK) = MB_ICONHAND) or ((dwType and MB_ICONMASK) = MB_USERICON) then + DlgType := mtCustom + else if (dwType and MB_ICONMASK) = MB_ICONWARNING then + DlgType := mtWarning + else if (dwType and MB_ICONMASK) = MB_ICONQUESTION then + DlgType := mtConfirmation + else if (dwType and MB_ICONMASK) = MB_ICONEXCLAMATION then + DlgType := mtInformation; + + case dwType and MB_TYPEMASK of + MB_OK: + Buttons := [mbOK]; + MB_OKCANCEL: + Buttons := [mbOK, mbCancel]; + MB_ABORTRETRYIGNORE: + Buttons := [mbAbort, mbRetry, mbIgnore]; + MB_YESNOCANCEL: + Buttons := [mbYes, mbNo, mbCancel]; + MB_YESNO: + Buttons := [mbYes, mbNo]; + MB_RETRYCANCEL: + Buttons := [mbRetry, mbCancel]; + else + Buttons := [mbOK]; + end; + + plResult := MessageDlg(lpstrText, DlgType, Buttons, dwHelpContext); + Result := S_OK; +end; +{$ENDIF} + +function TVclStylesWebBrowser.GetHostInfo(var pInfo: TDocHostUIInfo): HRESULT; +var + BodyCss: string; + ColorHtml: string; + LColor: TColor; +begin + LColor := StyleServices.GetSystemColor(clWindow); + ColorHtml := Format('#%.2x%.2x%.2x', [GetRValue(LColor), GetGValue(LColor), GetBValue(LColor)]); + BodyCss := Format('BODY {background-color:%s}', [ColorHtml]); + + pInfo.cbSize := SizeOf(pInfo); + pInfo.dwFlags := 0; + pInfo.dwFlags := pInfo.dwFlags or DOCHOSTUIFLAG_NO3DBORDER; // disable 3d border + pInfo.dwFlags := pInfo.dwFlags or DOCHOSTUIFLAG_THEME; + if FUseVClStyleBackGroundColor then + pInfo.pchHostCss := PWideChar(BodyCss); + Result := S_OK; + ResizeScrollBars; +end; + +function TVclStylesWebBrowser.GetIEHandle: hwnd; +var + ChildHWND: WinApi.Windows.hwnd; + TempHWND: WinApi.Windows.hwnd; + lpClassName: Array [0 .. 255] of Char; +begin + TempHWND := Self.Handle; + if TempHWND <> 0 then + while True do + begin + ChildHWND := GetWindow(TempHWND, GW_CHILD); + if ChildHWND = 0 then + break; + GetClassName(ChildHWND, lpClassName, SizeOf(lpClassName)); + if SameText(string(lpClassName), 'Internet Explorer_Server') then + begin + Result := ChildHWND; + exit; + end; + TempHWND := ChildHWND; + end; + Result := 0; +end; + +procedure TVclStylesWebBrowser.SetParent(AParent: TWinControl); +begin + inherited; + if not(csDestroying in ComponentState) then + begin + FVScrollBarContainer.Parent := AParent; + FHScrollBarContainer.Parent := AParent; + FScrollCornerContainer.Parent := AParent; + ResizeScrollBars; + end; +end; + +// procedure TVclStylesWebBrowser.SetZOrder(TopMost: Boolean); +// begin +// inherited; +// ResizeScrollBars; +// end; + +procedure TVclStylesWebBrowser.ResizeScrollBars; +var + StateVisible: Boolean; + DocClientWidth: integer; + ScrollWidth: integer; + ScrollHeight: integer; + HPageSize: integer; + VPageSize: integer; + LRect: TRect; + IEHWND: WinApi.Windows.hwnd; + + procedure UpdateContainers; + begin + if FVScrollBarContainer.Visible then + begin + LRect := BoundsRect; + // OutputDebugString(PChar(Format('Original VScrollBarContainer Left %d Top %d Width %d Height %d',[LRect.Left, LRect.Top, LRect.Width, LRect.Height]) )); + LRect.Left := LRect.Right - FLSM_CXHTHUMB; + if FHScrollBarContainer.Visible then + LRect.Bottom := LRect.Bottom - FLSM_CYVTHUMB; + + // LRect.Width:=2; + FVScrollBarContainer.BoundsRect := LRect; + end; + + if FHScrollBarContainer.Visible then + begin + LRect := BoundsRect; + // OutputDebugString(PChar(Format('Original HScrollBarContainer Left %d Top %d Width %d Height %d',[LRect.Left, LRect.Top, LRect.Width, LRect.Height]) )); + LRect.Top := LRect.Bottom - FLSM_CYVTHUMB; + if FVScrollBarContainer.Visible then + LRect.Right := LRect.Right - FLSM_CXHTHUMB; + + // LRect.Height:=2; + FHScrollBarContainer.BoundsRect := LRect; + // OutputDebugString(PChar(Format('ScrollBar Left %d Top %d Width %d Height %d',[LRect.Left, LRect.Top, LRect.Width, LRect.Height]) )); + end; + + StateVisible := FScrollCornerContainer.Visible; + FScrollCornerContainer.Visible := FHScrollBarContainer.Visible and FVScrollBarContainer.Visible; + + if FScrollCornerContainer.Visible then + begin + LRect := BoundsRect; + LRect.Left := LRect.Right - FLSM_CXHTHUMB; + LRect.Top := LRect.Bottom - FLSM_CYVTHUMB; + FScrollCornerContainer.BoundsRect := LRect; + if not StateVisible then + FScrollCornerContainer.BringToFront; + end; + end; + +begin + IEHWND := GetIEHandle; + + if (IEHWND = 0) or (FVScrollBarContainer = nil) or (FHScrollBarContainer = nil) then + exit; + + FVScrollBarContainer.Visible := True; + + if (Document <> nil) and (IHTMLDocument2(Document).Body <> nil) then + begin + DocClientWidth := OleVariant(Document).documentElement.ClientWidth; + if (DocClientWidth > 0) then + begin + ScrollWidth := OleVariant(Document).documentElement.ScrollWidth; + // OutputDebugString(PChar(Format('ScrollWidth %s',[inttoStr(ScrollWidth)]))); + + if (FHScrollBar.Max <> ScrollWidth) and (ScrollWidth >= FHScrollBar.PageSize) and (ScrollWidth >= FHScrollBar.Min) + then + FHScrollBar.Max := ScrollWidth; + + ScrollHeight := OleVariant(Document).documentElement.ScrollHeight; + // OutputDebugString(PChar(Format('ScrollHeight %s',[inttoStr(ScrollHeight)]))); + + if (FVScrollBar.Max <> ScrollHeight) and (ScrollHeight >= FVScrollBar.PageSize) and + (ScrollHeight >= FVScrollBar.Min) then + FVScrollBar.Max := ScrollHeight; + end + else + begin + ScrollWidth := IHTMLDocument2(Document).Body.getAttribute('ScrollWidth', 0); + if (FHScrollBar.Max <> ScrollWidth) and (ScrollWidth >= FHScrollBar.PageSize) and (ScrollWidth >= FHScrollBar.Min) + then + FHScrollBar.Max := ScrollWidth; + + ScrollHeight := IHTMLDocument2(Document).Body.getAttribute('ScrollHeight', 0); + if (FVScrollBar.Max <> ScrollHeight) and (ScrollHeight >= FVScrollBar.PageSize) and + (ScrollHeight >= FVScrollBar.Min) then + FVScrollBar.Max := ScrollHeight; + end; + + if (FHScrollBar.Max > Self.Width - FLSM_CXHTHUMB) and (FHScrollBar.Max > 0) and (FHScrollBar.Max <> Self.Width) then + VPageSize := Self.Height - FLSM_CYVTHUMB + else + VPageSize := Self.Height; + + FVScrollBar.PageSize := VPageSize; + FVScrollBar.SetParams(FVScrollBar.Position, 0, FVScrollBar.Max); + FVScrollBar.LargeChange := FVScrollBar.PageSize; + + HPageSize := Self.Width - FLSM_CXHTHUMB; + FHScrollBar.PageSize := HPageSize; + FHScrollBar.SetParams(FHScrollBar.Position, 0, FHScrollBar.Max); + FHScrollBar.LargeChange := FHScrollBar.PageSize; + + FVScrollBar.Enabled := (VPageSize < FVScrollBar.Max) and (FVScrollBar.PageSize > 0) and (FVScrollBar.Max > 0) and + (FVScrollBar.Max <> Self.Height); + + StateVisible := FHScrollBarContainer.Visible; + + if IsWindow(FHScrollBarContainer.Handle) then + FHScrollBarContainer.Visible := (HPageSize < FHScrollBar.Max) and (FHScrollBar.PageSize < FHScrollBar.Max) and + (FHScrollBar.Max > 0) and (FHScrollBar.Max <> Self.Width); + + if not StateVisible and FHScrollBarContainer.Visible then + FHScrollBarContainer.BringToFront; + + FVScrollBarContainer.BringToFront; + end; + + UpdateContainers; +end; + +procedure TVclStylesWebBrowser.DoProgressChange(Sender: TObject; Progress, ProgressMax: integer); +begin + ResizeScrollBars; +end; + +procedure TVclStylesWebBrowser.DoDocumentComplete(Sender: TObject; const pDisp: IDispatch; const URL: OleVariant); +begin + ResizeScrollBars; +end; + +procedure TVclStylesWebBrowser.DoNavigateComplete2(Sender: TObject; const pDisp: IDispatch; const URL: OleVariant); +begin + ResizeScrollBars; +end; + +procedure TVclStylesWebBrowser.DoCommandStateChange(Sender: TObject; Command: integer; Enable: WordBool); +begin + if (Document <> nil) and (IHTMLDocument2(Document).Body <> nil) then + begin + if (OleVariant(Document).documentElement.scrollTop = 0) then + FVScrollBar.Position := IHTMLDocument2(Document).Body.getAttribute('ScrollTop', 0) + else + FVScrollBar.Position := OleVariant(Document).documentElement.scrollTop; + + if (OleVariant(Document).documentElement.scrollLeft = 0) then + FHScrollBar.Position := IHTMLDocument2(Document).Body.getAttribute('ScrollLeft', 0) + else + FHScrollBar.Position := OleVariant(Document).documentElement.scrollLeft + end; + ResizeScrollBars; +end; + +procedure TVclStylesWebBrowser.DoBeforeNavigate2(Sender: TObject; const pDisp: IDispatch; + const URL, Flags, TargetFrameName, PostData, Headers: OleVariant; var Cancel: WordBool); +begin + ResizeScrollBars; +end; + +procedure TVclStylesWebBrowser.VScrollChange(Sender: TObject); +begin + if (Document <> nil) and (IHTMLDocument2(Document).ParentWindow <> nil) then + IHTMLWindow2(IHTMLDocument2(Document).ParentWindow).Scroll(FHScrollBar.Position, FVScrollBar.Position); +end; + +procedure TVclStylesWebBrowser.HScrollChange(Sender: TObject); +begin + if (Document <> nil) and (IHTMLDocument2(Document).ParentWindow <> nil) then + IHTMLWindow2(IHTMLDocument2(Document).ParentWindow).Scroll(FHScrollBar.Position, FVScrollBar.Position); +end; + +procedure TVclStylesWebBrowser.InvokeEvent(DispID: TDispID; var Params: TDispParams); +var + ArgCount: integer; + LVarArray: Array of OleVariant; + LIndex: integer; +begin + inherited; + ArgCount := Params.cArgs; + SetLength(LVarArray, ArgCount); + for LIndex := Low(LVarArray) to High(LVarArray) do + LVarArray[High(LVarArray) - LIndex] := OleVariant(TDispParams(Params).rgvarg^[LIndex]); + + case DispID of + 252: + DoNavigateComplete2(Self, LVarArray[0] { const IDispatch } , LVarArray[1] { const OleVariant } ); + + 259: + DoDocumentComplete(Self, LVarArray[0] { const IDispatch } , LVarArray[1] { const OleVariant } ); + + 250: + DoBeforeNavigate2(Self, LVarArray[0] { const IDispatch } , LVarArray[1] { const OleVariant } , + LVarArray[2] { const OleVariant } , LVarArray[3] { const OleVariant } , LVarArray[4] { const OleVariant } , + LVarArray[5] { const OleVariant } , WordBool((TVarData(LVarArray[6]).VPointer)^) { var WordBool } ); + + 105: + DoCommandStateChange(Self, LVarArray[0] { Integer } , LVarArray[1] { WordBool } ); + + 108: + DoProgressChange(Self, LVarArray[0] { Integer } , LVarArray[1] { Integer } ); + + end; + + SetLength(LVarArray, 0); +end; + +procedure TVclStylesWebBrowser.CMVisibleChanged(var Msg: TMessage); +begin + inherited; + FVScrollBarContainer.Visible := Self.Visible; + FHScrollBarContainer.Visible := Self.Visible; + FScrollCornerContainer.Visible := Self.Visible; +end; + +procedure TVclStylesWebBrowser.Loaded; +begin + inherited; + ResizeScrollBars; +end; + +end. diff --git a/source/view.dfm b/source/view.dfm index d6c0b3c09..c3d3e00e1 100644 --- a/source/view.dfm +++ b/source/view.dfm @@ -7,13 +7,6 @@ object frmView: TfrmView DesignSize = ( 700 500) - object lblName: TLabel - Left = 3 - Top = 6 - Width = 31 - Height = 13 - Caption = 'Name:' - end object lblSelect: TLabel Left = 3 Top = 149 @@ -32,49 +25,11 @@ object frmView: TfrmView Layout = tlCenter Visible = False end - object lblDefiner: TLabel - Left = 408 - Top = 6 - Width = 39 - Height = 13 - Caption = 'Definer:' - end - object lblSecurity: TLabel - Left = 408 - Top = 32 - Width = 64 - Height = 13 - Caption = 'SQL security:' - end - object editName: TEdit - Left = 84 - Top = 3 - Width = 310 - Height = 21 - TabOrder = 0 - Text = 'editName' - TextHint = 'Enter view name' - OnChange = Modification - end - object rgAlgorithm: TRadioGroup - Left = 3 - Top = 57 - Width = 391 - Height = 86 - Caption = 'Algorithm' - ItemIndex = 0 - Items.Strings = ( - 'UNDEFINED' - 'MERGE' - 'TEMPTABLE') - TabOrder = 2 - OnClick = Modification - end object SynMemoBody: TSynMemo Left = 3 - Top = 168 + Top = 179 Width = 693 - Height = 299 + Height = 288 SingleLineMode = False Anchors = [akLeft, akTop, akRight, akBottom] Font.Charset = DEFAULT_CHARSET @@ -82,7 +37,15 @@ object frmView: TfrmView Font.Height = -13 Font.Name = 'Courier New' Font.Style = [] - TabOrder = 4 + TabOrder = 1 + CodeFolding.GutterShapeSize = 11 + CodeFolding.CollapsedLineColor = clGrayText + CodeFolding.FolderBarLinesColor = clGrayText + CodeFolding.IndentGuidesColor = clGray + CodeFolding.IndentGuides = True + CodeFolding.ShowCollapsedLine = False + CodeFolding.ShowHintMark = True + UseCodeFolding = False Gutter.AutoSize = True Gutter.DigitCount = 2 Gutter.Font.Charset = DEFAULT_CHARSET @@ -116,7 +79,7 @@ object frmView: TfrmView Height = 25 Anchors = [akLeft, akBottom] Caption = 'Discard' - TabOrder = 6 + TabOrder = 3 OnClick = btnDiscardClick end object btnSave: TButton @@ -127,24 +90,9 @@ object frmView: TfrmView Anchors = [akLeft, akBottom] Caption = 'Save' Default = True - TabOrder = 7 + TabOrder = 4 OnClick = btnSaveClick end - object rgCheck: TRadioGroup - Left = 408 - Top = 57 - Width = 288 - Height = 86 - Anchors = [akLeft, akTop, akRight] - Caption = 'Check option for updates' - ItemIndex = 0 - Items.Strings = ( - 'None' - 'CASCADED' - 'LOCAL') - TabOrder = 3 - OnClick = Modification - end object btnHelp: TButton Left = 3 Top = 472 @@ -152,28 +100,140 @@ object frmView: TfrmView Height = 25 Anchors = [akLeft, akBottom] Caption = 'Help' - TabOrder = 5 + TabOrder = 2 OnClick = btnHelpClick end - object comboDefiner: TComboBox - Left = 489 - Top = 3 - Width = 207 - Height = 21 - Anchors = [akLeft, akTop, akRight] - TabOrder = 1 - Text = 'comboDefiner' - OnChange = Modification - OnDropDown = comboDefinerDropDown - end - object comboSecurity: TComboBox - Left = 489 - Top = 30 - Width = 207 - Height = 21 - Style = csDropDownList - Anchors = [akLeft, akTop, akRight] - TabOrder = 8 - OnChange = Modification + object PageControlMain: TPageControl + Left = 0 + Top = 0 + Width = 700 + Height = 177 + ActivePage = tabOptions + Align = alTop + Images = MainForm.VirtualImageListMain + TabOrder = 0 + OnChange = PageControlMainChange + object tabOptions: TTabSheet + Caption = 'Options' + ImageIndex = 14 + DesignSize = ( + 692 + 148) + object lblName: TLabel + Left = 3 + Top = 6 + Width = 31 + Height = 13 + Caption = 'Name:' + end + object lblDefiner: TLabel + Left = 408 + Top = 6 + Width = 39 + Height = 13 + Caption = 'Definer:' + end + object lblSecurity: TLabel + Left = 408 + Top = 32 + Width = 64 + Height = 13 + Caption = 'SQL security:' + end + object rgAlgorithm: TRadioGroup + Left = 3 + Top = 57 + Width = 391 + Height = 86 + Caption = 'Algorithm' + ItemIndex = 0 + Items.Strings = ( + 'UNDEFINED' + 'MERGE' + 'TEMPTABLE') + TabOrder = 3 + OnClick = Modification + end + object editName: TEdit + Left = 84 + Top = 3 + Width = 310 + Height = 21 + TabOrder = 0 + Text = 'editName' + TextHint = 'Enter view name' + OnChange = Modification + end + object comboDefiner: TComboBox + Left = 485 + Top = 3 + Width = 204 + Height = 21 + AutoDropDownWidth = True + Anchors = [akLeft, akTop, akRight] + TabOrder = 1 + Text = 'comboDefiner' + OnChange = Modification + OnDropDown = comboDefinerDropDown + end + object comboSecurity: TComboBox + Left = 485 + Top = 30 + Width = 204 + Height = 21 + Style = csDropDownList + Anchors = [akLeft, akTop, akRight] + TabOrder = 2 + OnChange = Modification + end + object rgCheck: TRadioGroup + Left = 404 + Top = 57 + Width = 285 + Height = 86 + Anchors = [akLeft, akTop, akRight] + Caption = 'Check option for updates' + ItemIndex = 0 + Items.Strings = ( + 'None' + 'CASCADED' + 'LOCAL') + TabOrder = 4 + OnClick = Modification + end + end + object tabCreateCode: TTabSheet + Caption = 'CREATE code' + ImageIndex = 39 + object SynMemoCreateCode: TSynMemo + Left = 0 + Top = 0 + Width = 692 + Height = 148 + SingleLineMode = False + Align = alClient + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -13 + Font.Name = 'Courier New' + Font.Style = [] + TabOrder = 0 + CodeFolding.GutterShapeSize = 11 + CodeFolding.CollapsedLineColor = clGrayText + CodeFolding.FolderBarLinesColor = clGrayText + CodeFolding.IndentGuidesColor = clGray + CodeFolding.IndentGuides = True + CodeFolding.ShowCollapsedLine = False + CodeFolding.ShowHintMark = True + UseCodeFolding = False + Gutter.Font.Charset = DEFAULT_CHARSET + Gutter.Font.Color = clWindowText + Gutter.Font.Height = -11 + Gutter.Font.Name = 'Courier New' + Gutter.Font.Style = [] + ReadOnly = True + FontSmoothing = fsmNone + end + end end end diff --git a/source/view.pas b/source/view.pas index 9ec36462a..a30ff75b8 100644 --- a/source/view.pas +++ b/source/view.pas @@ -3,34 +3,40 @@ interface uses - Windows, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, SynEdit, SynMemo, - ExtCtrls, - dbconnection, dbstructures, apphelpers, gnugettext; + Winapi.Windows, System.SysUtils, System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, SynEdit, SynMemo, + Vcl.ExtCtrls, Vcl.Menus, + dbconnection, dbstructures, dbstructures.mysql, apphelpers, gnugettext, Vcl.ComCtrls, extra_controls; type TFrame = TDBObjectEditor; TfrmView = class(TFrame) - editName: TEdit; - lblName: TLabel; - rgAlgorithm: TRadioGroup; SynMemoBody: TSynMemo; lblSelect: TLabel; btnDiscard: TButton; btnSave: TButton; - rgCheck: TRadioGroup; btnHelp: TButton; lblDisabledWhy: TLabel; + PageControlMain: TPageControl; + tabOptions: TTabSheet; + tabCreateCode: TTabSheet; + rgAlgorithm: TRadioGroup; + lblName: TLabel; + editName: TEdit; lblDefiner: TLabel; comboDefiner: TComboBox; - lblSecurity: TLabel; comboSecurity: TComboBox; + lblSecurity: TLabel; + rgCheck: TRadioGroup; + SynMemoCreateCode: TSynMemo; procedure btnHelpClick(Sender: TObject); procedure btnSaveClick(Sender: TObject); procedure btnDiscardClick(Sender: TObject); procedure Modification(Sender: TObject); procedure comboDefinerDropDown(Sender: TObject); + procedure PageControlMainChange(Sender: TObject); private { Private declarations } + function ComposeCreateStatement: TSQLBatch; public { Public declarations } constructor Create(AOwner: TComponent); override; @@ -54,9 +60,13 @@ constructor TfrmView.Create(AOwner: TComponent); inherited; SynMemoBody.Highlighter := Mainform.SynSQLSynUsed; Mainform.SynCompletionProposal.AddEditor(SynMemoBody); + SynMemoCreateCode.Highlighter := Mainform.SynSQLSynUsed; + Mainform.SynCompletionProposal.AddEditor(SynMemoCreateCode); editName.MaxLength := NAME_LEN; comboSecurity.Items.Add('Definer'); comboSecurity.Items.Add('Invoker'); + FMainSynMemo := SynMemoBody; + btnSave.Hint := ShortCutToText(MainForm.actSaveSQL.ShortCut); end; @@ -96,6 +106,7 @@ procedure TfrmView.Init(Obj: TDBObject); rgAlgorithm.Enabled := editName.Enabled; rgCheck.Enabled := rgAlgorithm.Enabled; SynMemoBody.Enabled := rgAlgorithm.Enabled; + SynMemoBody.TopLine := FMainSynMemoPreviousTopLine; end else begin // Create mode editName.Text := ''; @@ -116,10 +127,13 @@ procedure TfrmView.Init(Obj: TDBObject); rgAlgorithm.Enabled := rgAlgorithm.Enabled and Obj.Connection.Parameters.IsAnyMySQL; rgCheck.Enabled := rgCheck.Enabled and Obj.Connection.Parameters.IsAnyMySQL; + // Update create code tab + Modification(Self); Modified := False; btnSave.Enabled := Modified; btnDiscard.Enabled := Modified; Mainform.ShowStatusMsg; + TExtForm.PageControlTabHighlight(PageControlMain); Screen.Cursor := crDefault; end; @@ -159,35 +173,18 @@ procedure TfrmView.btnSaveClick(Sender: TObject); function TfrmView.ApplyModifications: TModalResult; var - sql, viewname, renamed: String; + Batch: TSQLBatch; + Query: TSQLSentence; begin // Save changes Result := mrOk; - if DBObject.Name = '' then begin - sql := 'CREATE '; - viewname := editName.Text; - end else begin - sql := 'ALTER '; - viewname := DBObject.Name; - end; - viewname := DBObject.Connection.QuoteIdent(viewname); - if rgAlgorithm.Enabled and (rgAlgorithm.ItemIndex > -1) then - sql := sql + 'ALGORITHM = '+Uppercase(rgAlgorithm.Items[rgAlgorithm.ItemIndex])+' '; - if comboDefiner.Enabled and (comboDefiner.Text <> '') then - sql := sql + 'DEFINER='+DBObject.Connection.QuoteIdent(comboDefiner.Text, True, '@')+' '; - if comboSecurity.Enabled and (comboSecurity.Text <> '') then - sql := sql + 'SQL SECURITY ' + UpperCase(comboSecurity.Text)+' '; - sql := sql + 'VIEW ' + viewname+' AS '+SynMemoBody.Text+' '; - if rgCheck.Enabled and (rgCheck.ItemIndex > 0) then - sql := sql + 'WITH '+Uppercase(rgCheck.Items[rgCheck.ItemIndex])+' CHECK OPTION'; try - DBObject.Connection.Query(sql); - // Probably rename view - if (DBObject.Name <> '') and (DBObject.Name <> editName.Text) then begin - renamed := DBObject.Connection.QuoteIdent(editName.Text); - DBObject.Connection.Query('RENAME TABLE '+viewname + ' TO '+renamed); + Batch := ComposeCreateStatement; + for Query in Batch do begin + DBObject.Connection.Query(Query.SQL); end; + Batch.Free; DBObject.Name := editName.Text; DBObject.UnloadDetails; Mainform.UpdateEditorTab; @@ -205,10 +202,56 @@ function TfrmView.ApplyModifications: TModalResult; procedure TfrmView.Modification(Sender: TObject); +var + Batch: TSQLBatch; begin Modified := True; btnSave.Enabled := Modified and (editName.Text <> ''); btnDiscard.Enabled := Modified; + // Update create code + Batch := ComposeCreateStatement; + SynMemoCreateCode.Text := Batch.SQL; + Batch.Free; +end; + + +procedure TfrmView.PageControlMainChange(Sender: TObject); +begin + TExtForm.PageControlTabHighlight(PageControlMain); +end; + + +function TfrmView.ComposeCreateStatement: TSQLBatch; +var + sql, ViewName, RenameView: String; +begin + // Create or Alter code + if not ObjectExists then begin + sql := 'CREATE '; + ViewName := editName.Text; + end else begin + sql := 'ALTER '; + ViewName := DBObject.Name; + end; + ViewName := DBObject.Connection.QuoteIdent(ViewName); + if rgAlgorithm.Enabled and (rgAlgorithm.ItemIndex > -1) then + sql := sql + 'ALGORITHM = '+Uppercase(rgAlgorithm.Items[rgAlgorithm.ItemIndex])+' '; + if comboDefiner.Enabled and (comboDefiner.Text <> '') then + sql := sql + 'DEFINER='+DBObject.Connection.QuoteIdent(comboDefiner.Text, True, '@')+' '; + if comboSecurity.Enabled and (comboSecurity.Text <> '') then + sql := sql + 'SQL SECURITY ' + UpperCase(comboSecurity.Text)+' '; + sql := sql + 'VIEW ' + ViewName+' AS '+SynMemoBody.Text+' '; + if rgCheck.Enabled and (rgCheck.ItemIndex > 0) then + sql := sql + 'WITH '+Uppercase(rgCheck.Items[rgCheck.ItemIndex])+' CHECK OPTION'; + sql := sql + ';' + sLineBreak; + + if ObjectExists and (DBObject.Name <> editName.Text) then begin + RenameView := DBObject.Connection.QuoteIdent(editName.Text); + sql := sql + 'RENAME TABLE '+ViewName + ' TO '+RenameView + ';' + sLineBreak; + end; + + Result := TSQLBatch.Create(DBObject.Connection.Parameters.NetTypeGroup); + Result.SQL := Trim(SQL); end;